101 files changed, 129948 insertions, 0 deletions

diff --git a/gcc/ada/scans.adb b/gcc/ada/scans.adb
new file mode 100644
index 00000000000..327f3aa1b58
--- /dev/null
+++ b/gcc/ada/scans.adb
@@ -0,0 +1,76 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                                S C A N S                                 --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $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.                                                      --
+--                                                                          --
+-- 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). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+package body Scans is
+
+   ------------------------
+   -- Restore_Scan_State --
+   ------------------------
+
+   procedure Restore_Scan_State (Saved_State : in Saved_Scan_State) is
+   begin
+      Scan_Ptr                 := Saved_State.Save_Scan_Ptr;
+      Token                    := Saved_State.Save_Token;
+      Token_Ptr                := Saved_State.Save_Token_Ptr;
+      Current_Line_Start       := Saved_State.Save_Current_Line_Start;
+      Start_Column             := Saved_State.Save_Start_Column;
+      Checksum                 := Saved_State.Save_Checksum;
+      First_Non_Blank_Location := Saved_State.Save_First_Non_Blank_Location;
+      Token_Node               := Saved_State.Save_Token_Node;
+      Token_Name               := Saved_State.Save_Token_Name;
+      Prev_Token               := Saved_State.Save_Prev_Token;
+      Prev_Token_Ptr           := Saved_State.Save_Prev_Token_Ptr;
+   end Restore_Scan_State;
+
+   ---------------------
+   -- Save_Scan_State --
+   ---------------------
+
+   procedure Save_Scan_State (Saved_State : out Saved_Scan_State) is
+   begin
+      Saved_State.Save_Scan_Ptr                 := Scan_Ptr;
+      Saved_State.Save_Token                    := Token;
+      Saved_State.Save_Token_Ptr                := Token_Ptr;
+      Saved_State.Save_Current_Line_Start       := Current_Line_Start;
+      Saved_State.Save_Start_Column             := Start_Column;
+      Saved_State.Save_Checksum                 := Checksum;
+      Saved_State.Save_First_Non_Blank_Location := First_Non_Blank_Location;
+      Saved_State.Save_Token_Node               := Token_Node;
+      Saved_State.Save_Token_Name               := Token_Name;
+      Saved_State.Save_Prev_Token               := Prev_Token;
+      Saved_State.Save_Prev_Token_Ptr           := Prev_Token_Ptr;
+   end Save_Scan_State;
+
+end Scans;
diff --git a/gcc/ada/scans.ads b/gcc/ada/scans.ads
new file mode 100644
index 00000000000..b9d89e1f0ef
--- /dev/null
+++ b/gcc/ada/scans.ads
@@ -0,0 +1,418 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                                S C A N S                                 --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.32 $
+--                                                                          --
+--          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.                                                      --
+--                                                                          --
+-- 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 Types; use Types;
+package Scans is
+
+--  The scanner maintains a current state in the global variables defined
+--  in this package. The call to the Scan routine advances this state to
+--  the next token. The state is initialized by the call to one of the
+--  initialization routines in Sinput.
+
+   --  The following type is used to identify token types returned by Scan.
+   --  The class column in this table indicates the token classes which
+   --  apply to the token, as defined by subsquent subtype declarations.
+
+   --  Note: the coding in SCN depends on the fact that the first entry in
+   --  this type declaration is *not* for a reserved word. For details on
+   --  why there is this requirement, see Scn.Initialize_Scanner.
+
+   type Token_Type is (
+
+      --  Token name          Token type   Class(es)
+
+      Tok_Integer_Literal, -- numeric lit  Literal, Lit_Or_Name
+
+      Tok_Real_Literal,    -- numeric lit  Literal, Lit_Or_Name
+
+      Tok_String_Literal,  -- string lit   Literal. Lit_Or_Name
+
+      Tok_Char_Literal,    -- char lit     Name, Literal. Lit_Or_Name
+
+      Tok_Operator_Symbol, -- op symbol    Name, Literal, Lit_Or_Name, Desig
+
+      Tok_Identifier,      -- identifer    Name, Lit_Or_Name, Desig
+
+      Tok_Double_Asterisk, -- **
+
+      Tok_Ampersand,       -- &            Binary_Addop
+      Tok_Minus,           -- -            Binary_Addop, Unary_Addop
+      Tok_Plus,            -- +            Binary_Addop, Unary_Addop
+
+      Tok_Asterisk,        -- *            Mulop
+      Tok_Mod,             -- MOD          Mulop
+      Tok_Rem,             -- REM          Mulop
+      Tok_Slash,           -- /            Mulop
+
+      Tok_New,             -- NEW
+
+      Tok_Abs,             -- ABS
+      Tok_Others,          -- OTHERS
+      Tok_Null,            -- NULL
+
+      Tok_Dot,             -- .            Namext
+      Tok_Apostrophe,      -- '            Namext
+
+      Tok_Left_Paren,      -- (            Namext, Consk
+
+      Tok_Delta,           -- DELTA        Atkwd, Sterm, Consk
+      Tok_Digits,          -- DIGITS       Atkwd, Sterm, Consk
+      Tok_Range,           -- RANGE        Atkwd, Sterm, Consk
+
+      Tok_Right_Paren,     -- )            Sterm
+      Tok_Comma,           -- ,            Sterm
+
+      Tok_And,             -- AND          Logop, Sterm
+      Tok_Or,              -- OR           Logop, Sterm
+      Tok_Xor,             -- XOR          Logop, Sterm
+
+      Tok_Less,            -- <            Relop, Sterm
+      Tok_Equal,           -- =            Relop, Sterm
+      Tok_Greater,         -- >            Relop, Sterm
+      Tok_Not_Equal,       -- /=           Relop, Sterm
+      Tok_Greater_Equal,   -- >=           Relop, Sterm
+      Tok_Less_Equal,      -- <=           Relop, Sterm
+
+      Tok_In,              -- IN           Relop, Sterm
+      Tok_Not,             -- NOT          Relop, Sterm
+
+      Tok_Box,             -- <>           Relop, Eterm, Sterm
+      Tok_Colon_Equal,     -- :=           Eterm, Sterm
+      Tok_Colon,           -- :            Eterm, Sterm
+      Tok_Greater_Greater, -- >>           Eterm, Sterm
+
+      Tok_Abstract,        -- ABSTRACT     Eterm, Sterm
+      Tok_Access,          -- ACCESS       Eterm, Sterm
+      Tok_Aliased,         -- ALIASED      Eterm, Sterm
+      Tok_All,             -- ALL          Eterm, Sterm
+      Tok_Array,           -- ARRAY        Eterm, Sterm
+      Tok_At,              -- AT           Eterm, Sterm
+      Tok_Body,            -- BODY         Eterm, Sterm
+      Tok_Constant,        -- CONSTANT     Eterm, Sterm
+      Tok_Do,              -- DO           Eterm, Sterm
+      Tok_Is,              -- IS           Eterm, Sterm
+      Tok_Limited,         -- LIMITED      Eterm, Sterm
+      Tok_Of,              -- OF           Eterm, Sterm
+      Tok_Out,             -- OUT          Eterm, Sterm
+      Tok_Record,          -- RECORD       Eterm, Sterm
+      Tok_Renames,         -- RENAMES      Eterm, Sterm
+      Tok_Reverse,         -- REVERSE      Eterm, Sterm
+      Tok_Tagged,          -- TAGGED       Eterm, Sterm
+      Tok_Then,            -- THEN         Eterm, Sterm
+
+      Tok_Less_Less,       -- <<           Eterm, Sterm, After_SM
+
+      Tok_Abort,           -- ABORT        Eterm, Sterm, After_SM
+      Tok_Accept,          -- ACCEPT       Eterm, Sterm, After_SM
+      Tok_Case,            -- CASE         Eterm, Sterm, After_SM
+      Tok_Delay,           -- DELAY        Eterm, Sterm, After_SM
+      Tok_Else,            -- ELSE         Eterm, Sterm, After_SM
+      Tok_Elsif,           -- ELSIF        Eterm, Sterm, After_SM
+      Tok_End,             -- END          Eterm, Sterm, After_SM
+      Tok_Exception,       -- EXCEPTION    Eterm, Sterm, After_SM
+      Tok_Exit,            -- EXIT         Eterm, Sterm, After_SM
+      Tok_Goto,            -- GOTO         Eterm, Sterm, After_SM
+      Tok_If,              -- IF           Eterm, Sterm, After_SM
+      Tok_Pragma,          -- PRAGMA       Eterm, Sterm, After_SM
+      Tok_Raise,           -- RAISE        Eterm, Sterm, After_SM
+      Tok_Requeue,         -- REQUEUE      Eterm, Sterm, After_SM
+      Tok_Return,          -- RETURN       Eterm, Sterm, After_SM
+      Tok_Select,          -- SELECT       Eterm, Sterm, After_SM
+      Tok_Terminate,       -- TERMINATE    Eterm, Sterm, After_SM
+      Tok_Until,           -- UNTIL        Eterm, Sterm, After_SM
+      Tok_When,            -- WHEN         Eterm, Sterm, After_SM
+
+      Tok_Begin,           -- BEGIN        Eterm, Sterm, After_SM, Labeled_Stmt
+      Tok_Declare,         -- DECLARE      Eterm, Sterm, After_SM, Labeled_Stmt
+      Tok_For,             -- FOR          Eterm, Sterm, After_SM, Labeled_Stmt
+      Tok_Loop,            -- LOOP         Eterm, Sterm, After_SM, Labeled_Stmt
+      Tok_While,           -- WHILE        Eterm, Sterm, After_SM, Labeled_Stmt
+
+      Tok_Entry,           -- ENTRY        Eterm, Sterm, Declk, Deckn, After_SM
+      Tok_Protected,       -- PROTECTED    Eterm, Sterm, Declk, Deckn, After_SM
+      Tok_Task,            -- TASK         Eterm, Sterm, Declk, Deckn, After_SM
+      Tok_Type,            -- TYPE         Eterm, Sterm, Declk, Deckn, After_SM
+      Tok_Subtype,         -- SUBTYPE      Eterm, Sterm, Declk, Deckn, After_SM
+      Tok_Use,             -- USE          Eterm, Sterm, Declk, Deckn, After_SM
+
+      Tok_Function,        -- FUNCTION     Eterm, Sterm, Cunit, Declk, After_SM
+      Tok_Generic,         -- GENERIC      Eterm, Sterm, Cunit, Declk, After_SM
+      Tok_Package,         -- PACKAGE      Eterm, Sterm, Cunit, Declk, After_SM
+      Tok_Procedure,       -- PROCEDURE    Eterm, Sterm, Cunit, Declk, After_SM
+
+      Tok_Private,         -- PRIVATE      Eterm, Sterm, Cunit, After_SM
+      Tok_With,            -- WITH         Eterm, Sterm, Cunit, After_SM
+      Tok_Separate,        -- SEPARATE     Eterm, Sterm, Cunit, After_SM
+
+      Tok_EOF,             -- End of file  Eterm, Sterm, Cterm, After_SM
+
+      Tok_Semicolon,       -- ;            Eterm, Sterm, Cterm
+
+      Tok_Arrow,           -- =>           Sterm, Cterm, Chtok
+
+      Tok_Vertical_Bar,    -- |            Cterm, Sterm, Chtok
+
+      Tok_Dot_Dot,         -- ..           Sterm, Chtok
+
+      --  The following three entries are used only when scanning
+      --  project files.
+
+      Tok_Project,
+      Tok_Modifying,
+      Tok_External,
+
+      No_Token);
+      --  No_Token is used for initializing Token values to indicate that
+      --  no value has been set yet.
+
+   --  Note: in the RM, operator symbol is a special case of string literal.
+   --  We distinguish at the lexical level in this compiler, since there are
+   --  many syntactic situations in which only an operator symbol is allowed.
+
+   --  The following subtype declarations group the token types into classes.
+   --  These are used for class tests in the parser.
+
+      subtype Token_Class_Numeric_Literal is
+        Token_Type range Tok_Integer_Literal .. Tok_Real_Literal;
+      --  Numeric literal
+
+      subtype Token_Class_Literal is
+        Token_Type range Tok_Integer_Literal .. Tok_Operator_Symbol;
+      --  Literal
+
+      subtype Token_Class_Lit_Or_Name is
+        Token_Type range Tok_Integer_Literal .. Tok_Identifier;
+
+      subtype Token_Class_Binary_Addop is
+        Token_Type range Tok_Ampersand .. Tok_Plus;
+      --  Binary adding operator (& + -)
+
+      subtype Token_Class_Unary_Addop is
+        Token_Type range Tok_Minus .. Tok_Plus;
+      --  Unary adding operator (+ -)
+
+      subtype Token_Class_Mulop is
+        Token_Type range Tok_Asterisk .. Tok_Slash;
+      --  Multiplying operator
+
+      subtype Token_Class_Logop is
+        Token_Type range Tok_And .. Tok_Xor;
+      --  Logical operator (and, or, xor)
+
+      subtype Token_Class_Relop is
+        Token_Type range Tok_Less .. Tok_Box;
+      --  Relational operator (= /= < <= > >= not, in plus <> to catch misuse
+      --  of Pascal style not equal operator).
+
+      subtype Token_Class_Name is
+        Token_Type range Tok_Char_Literal .. Tok_Identifier;
+      --  First token of name (4.1),
+      --    (identifier, char literal, operator symbol)
+
+      subtype Token_Class_Desig is
+        Token_Type range Tok_Operator_Symbol .. Tok_Identifier;
+      --  Token which can be a Designator (identifier, operator symbol)
+
+      subtype Token_Class_Namext is
+        Token_Type range Tok_Dot .. Tok_Left_Paren;
+      --  Name extension tokens. These are tokens which can appear immediately
+      --  after a name to extend it recursively (period, quote, left paren)
+
+      subtype Token_Class_Consk is
+        Token_Type range Tok_Left_Paren .. Tok_Range;
+      --  Keywords which can start constraint
+      --    (left paren, delta, digits, range)
+
+      subtype Token_Class_Eterm is
+        Token_Type range Tok_Colon_Equal .. Tok_Semicolon;
+      --  Expression terminators. These tokens can never appear within a simple
+      --  expression. This is used for error recovery purposes (if we encounter
+      --  an error in an expression, we simply scan to the next Eterm token).
+
+      subtype Token_Class_Sterm is
+        Token_Type range Tok_Delta .. Tok_Dot_Dot;
+      --  Simple_Expression terminators. A Simple_Expression must be followed
+      --  by a token in this class, or an error message is issued complaining
+      --  about a missing binary operator.
+
+      subtype Token_Class_Atkwd is
+        Token_Type range Tok_Delta .. Tok_Range;
+      --  Attribute keywords. This class includes keywords which can be used
+      --  as an Attribute_Designator, namely DELTA, DIGITS and RANGE
+
+      subtype Token_Class_Cterm is
+        Token_Type range Tok_EOF .. Tok_Vertical_Bar;
+      --  Choice terminators. These tokens terminate a choice. This is used for
+      --  error recovery purposes (if we encounter an error in a Choice, we
+      --  simply scan to the next Cterm token).
+
+      subtype Token_Class_Chtok is
+        Token_Type range Tok_Arrow .. Tok_Dot_Dot;
+      --  Choice tokens. These tokens signal a choice when used in an Aggregate
+
+      subtype Token_Class_Cunit is
+        Token_Type range Tok_Function .. Tok_Separate;
+      --  Tokens which can begin a compilation unit
+
+      subtype Token_Class_Declk is
+        Token_Type range Tok_Entry .. Tok_Procedure;
+      --  Keywords which start a declaration
+
+      subtype Token_Class_Deckn is
+        Token_Type range Tok_Entry .. Tok_Use;
+      --  Keywords which start a declaration but can't start a compilation unit
+
+      subtype Token_Class_After_SM is
+        Token_Type range Tok_Less_Less .. Tok_EOF;
+      --  Tokens which always, or almost always, appear after a semicolon. Used
+      --  in the Resync_Past_Semicolon routine to avoid gobbling up stuff when
+      --  a semicolon is missing. Of significance only for error recovery.
+
+      subtype Token_Class_Labeled_Stmt is
+        Token_Type range Tok_Begin .. Tok_While;
+      --  Tokens which start labeled statements
+
+      type Token_Flag_Array is array (Token_Type) of Boolean;
+      Is_Reserved_Keyword : constant Token_Flag_Array := Token_Flag_Array'(
+         Tok_Mod      .. Tok_Rem      => True,
+         Tok_New      .. Tok_Null     => True,
+         Tok_Delta    .. Tok_Range    => True,
+         Tok_And      .. Tok_Xor      => True,
+         Tok_In       .. Tok_Not      => True,
+         Tok_Abstract .. Tok_Then     => True,
+         Tok_Abort    .. Tok_Separate => True,
+         others                       => False);
+      --  Flag array used to test for reserved word
+
+   --------------------------
+   -- Scan State Variables --
+   --------------------------
+
+   --  Note: these variables can only be referenced during the parsing of a
+   --  file. Reference to any of them from Sem or the expander is wrong.
+
+   Scan_Ptr : Source_Ptr;
+   --  Current scan pointer location. After a call to Scan, this points
+   --  just past the end of the token just scanned.
+
+   Token : Token_Type;
+   --  Type of current token
+
+   Token_Ptr : Source_Ptr;
+   --  Pointer to first character of current token
+
+   Current_Line_Start : Source_Ptr;
+   --  Pointer to first character of line containing current token
+
+   Start_Column : Column_Number;
+   --  Starting column number (zero origin) of the first non-blank character
+   --  on the line containing the current token. This is used for error
+   --  recovery circuits which depend on looking at the column line up.
+
+   Checksum : Word;
+   --  Used to accumulate a checksum representing the tokens in the source
+   --  file being compiled. This checksum includes only program tokens, and
+   --  excludes comments.
+
+   First_Non_Blank_Location : Source_Ptr;
+   --  Location of first non-blank character on the line containing the
+   --  current token (i.e. the location of the character whose column number
+   --  is stored in Start_Column).
+
+   Token_Node : Node_Id := Empty;
+   --  Node table Id for the current token. This is set only if the current
+   --  token is one for which the scanner constructs a node (i.e. it is an
+   --  identifier, operator symbol, or literal. For other token types,
+   --  Token_Node is undefined.
+
+   Token_Name : Name_Id := No_Name;
+   --  For identifiers, this is set to the Name_Id of the identifier scanned.
+   --  For all other tokens, Token_Name is set to Error_Name. Note that it
+   --  would be possible for the caller to extract this information from
+   --  Token_Node. We set Token_Name separately for two reasons. First it
+   --  allows a quicker test for a specific identifier. Second, it allows
+   --  a version of the parser to be built that does not build tree nodes,
+   --  usable as a syntax checker.
+
+   Prev_Token : Token_Type := No_Token;
+   --  Type of previous token
+
+   Prev_Token_Ptr : Source_Ptr;
+   --  Pointer to first character of previous token
+
+   Version_To_Be_Found : Boolean;
+   --  This flag is True if the scanner is still looking for an RCS version
+   --  number in a comment. Normally it is initialized to False so that this
+   --  circuit is not activated. If the -dv switch is set, then this flag is
+   --  initialized to True, and then reset when the version number is found.
+   --  We do things this way to minimize the impact on comment scanning.
+
+   --------------------------------------------------------
+   -- Procedures for Saving and Restoring the Scan State --
+   --------------------------------------------------------
+
+   --  The following procedures can be used to save and restore the entire
+   --  scan state. They are used in cases where it is necessary to backup
+   --  the scan during the parse.
+
+   type Saved_Scan_State is private;
+   --  Used for saving and restoring the scan state
+
+   procedure Save_Scan_State (Saved_State : out Saved_Scan_State);
+   pragma Inline (Save_Scan_State);
+   --  Saves the current scan state for possible later restoration. Note that
+   --  there is no harm in saving the state and then never restoring it.
+
+   procedure Restore_Scan_State (Saved_State : in Saved_Scan_State);
+   pragma Inline (Restore_Scan_State);
+   --  Restores a scan state saved by a call to Save_Scan_State.
+   --  The saved scan state must refer to the current source file.
+
+private
+   type Saved_Scan_State is record
+      Save_Scan_Ptr                 : Source_Ptr;
+      Save_Token                    : Token_Type;
+      Save_Token_Ptr                : Source_Ptr;
+      Save_Current_Line_Start       : Source_Ptr;
+      Save_Start_Column             : Column_Number;
+      Save_Checksum                 : Word;
+      Save_First_Non_Blank_Location : Source_Ptr;
+      Save_Token_Node               : Node_Id;
+      Save_Token_Name               : Name_Id;
+      Save_Prev_Token               : Token_Type;
+      Save_Prev_Token_Ptr           : Source_Ptr;
+   end record;
+
+end Scans;
diff --git a/gcc/ada/scn-nlit.adb b/gcc/ada/scn-nlit.adb
new file mode 100644
index 00000000000..f027ba25b3a
--- /dev/null
+++ b/gcc/ada/scn-nlit.adb
@@ -0,0 +1,371 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             S C N . N L I T                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.32 $                             --
+--                                                                          --
+--   Copyright (C) 1992,1993,1994,1995,1996 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 Urealp; use Urealp;
+
+separate (Scn)
+procedure Nlit is
+
+   C : Character;
+   --  Current source program character
+
+   Base_Char : Character;
+   --  Either # or : (character at start of based number)
+
+   Base : Int;
+   --  Value of base
+
+   UI_Base : Uint;
+   --  Value of base in Uint format
+
+   UI_Int_Value : Uint;
+   --  Value of integer scanned by Scan_Integer in Uint format
+
+   UI_Num_Value : Uint;
+   --  Value of integer in numeric value being scanned
+
+   Scale : Int;
+   --  Scale value for real literal
+
+   UI_Scale : Uint;
+   --  Scale in Uint format
+
+   Exponent_Is_Negative : Boolean;
+   --  Set true for negative exponent
+
+   Extended_Digit_Value : Int;
+   --  Extended digit value
+
+   Point_Scanned : Boolean;
+   --  Flag for decimal point scanned in numeric literal
+
+   -----------------------
+   -- Local Subprograms --
+   -----------------------
+
+   procedure Error_Digit_Expected;
+   --  Signal error of bad digit, Scan_Ptr points to the location at which
+   --  the digit was expected on input, and is unchanged on return.
+
+   procedure Scan_Integer;
+   --  Procedure to scan integer literal. On entry, Scan_Ptr points to a
+   --  digit, on exit Scan_Ptr points past the last character of the integer.
+   --  For each digit encountered, UI_Int_Value is multiplied by 10, and the
+   --  value of the digit added to the result. In addition, the value in
+   --  Scale is decremented by one for each actual digit scanned.
+
+   --------------------------
+   -- Error_Digit_Expected --
+   --------------------------
+
+   procedure Error_Digit_Expected is
+   begin
+      Error_Msg_S ("digit expected");
+   end Error_Digit_Expected;
+
+   -------------------
+   --  Scan_Integer --
+   -------------------
+
+   procedure Scan_Integer is
+      C : Character;
+      --  Next character scanned
+
+   begin
+      C := Source (Scan_Ptr);
+
+      --  Loop through digits (allowing underlines)
+
+      loop
+         Accumulate_Checksum (C);
+         UI_Int_Value :=
+           UI_Int_Value * 10 + (Character'Pos (C) - Character'Pos ('0'));
+         Scan_Ptr := Scan_Ptr + 1;
+         Scale := Scale - 1;
+         C := Source (Scan_Ptr);
+
+         if C = '_' then
+            Accumulate_Checksum ('_');
+
+            loop
+               Scan_Ptr := Scan_Ptr + 1;
+               C := Source (Scan_Ptr);
+               exit when C /= '_';
+               Error_No_Double_Underline;
+            end loop;
+
+            if C not in '0' .. '9' then
+               Error_Digit_Expected;
+               exit;
+            end if;
+
+         else
+            exit when C not in '0' .. '9';
+         end if;
+      end loop;
+
+   end Scan_Integer;
+
+----------------------------------
+-- Start of Processing for Nlit --
+----------------------------------
+
+begin
+   Base := 10;
+   UI_Base := Uint_10;
+   UI_Int_Value := Uint_0;
+   Scale := 0;
+   Scan_Integer;
+   Scale := 0;
+   Point_Scanned := False;
+   UI_Num_Value := UI_Int_Value;
+
+   --  Various possibilities now for continuing the literal are
+   --  period, E/e (for exponent), or :/# (for based literal).
+
+   Scale := 0;
+   C := Source (Scan_Ptr);
+
+   if C = '.' then
+
+      --  Scan out point, but do not scan past .. which is a range sequence,
+      --  and must not be eaten up scanning a numeric literal.
+
+      while C = '.' and then Source (Scan_Ptr + 1) /= '.' loop
+         Accumulate_Checksum ('.');
+
+         if Point_Scanned then
+            Error_Msg_S ("duplicate point ignored");
+         end if;
+
+         Point_Scanned := True;
+         Scan_Ptr := Scan_Ptr + 1;
+         C := Source (Scan_Ptr);
+
+         if C not in '0' .. '9' then
+            Error_Msg ("real literal cannot end with point", Scan_Ptr - 1);
+         else
+            Scan_Integer;
+            UI_Num_Value := UI_Int_Value;
+         end if;
+      end loop;
+
+   --  Based literal case. The base is the value we already scanned.
+   --  In the case of colon, we insist that the following character
+   --  is indeed an extended digit or a period. This catches a number
+   --  of common errors, as well as catching the well known tricky
+   --  bug otherwise arising from "x : integer range 1 .. 10:= 6;"
+
+   elsif C = '#'
+     or else (C = ':' and then
+                        (Source (Scan_Ptr + 1) = '.'
+                           or else
+                         Source (Scan_Ptr + 1) in '0' .. '9'
+                           or else
+                         Source (Scan_Ptr + 1) in 'A' .. 'Z'
+                           or else
+                         Source (Scan_Ptr + 1) in 'a' .. 'z'))
+   then
+      Accumulate_Checksum (C);
+      Base_Char := C;
+      UI_Base := UI_Int_Value;
+
+      if UI_Base < 2 or else UI_Base > 16 then
+         Error_Msg_SC ("base not 2-16");
+         UI_Base := Uint_16;
+      end if;
+
+      Base := UI_To_Int (UI_Base);
+      Scan_Ptr := Scan_Ptr + 1;
+
+      --  Scan out extended integer [. integer]
+
+      C := Source (Scan_Ptr);
+      UI_Int_Value := Uint_0;
+      Scale := 0;
+
+      loop
+         if C in '0' .. '9' then
+            Accumulate_Checksum (C);
+            Extended_Digit_Value :=
+              Int'(Character'Pos (C)) - Int'(Character'Pos ('0'));
+
+         elsif C in 'A' .. 'F' then
+            Accumulate_Checksum (Character'Val (Character'Pos (C) + 32));
+            Extended_Digit_Value :=
+              Int'(Character'Pos (C)) - Int'(Character'Pos ('A')) + 10;
+
+         elsif C in 'a' .. 'f' then
+            Accumulate_Checksum (C);
+            Extended_Digit_Value :=
+              Int'(Character'Pos (C)) - Int'(Character'Pos ('a')) + 10;
+
+         else
+            Error_Msg_S ("extended digit expected");
+            exit;
+         end if;
+
+         if Extended_Digit_Value >= Base then
+            Error_Msg_S ("digit >= base");
+         end if;
+
+         UI_Int_Value := UI_Int_Value * UI_Base + Extended_Digit_Value;
+         Scale := Scale - 1;
+         Scan_Ptr := Scan_Ptr + 1;
+         C := Source (Scan_Ptr);
+
+         if C = '_' then
+            loop
+               Accumulate_Checksum ('_');
+               Scan_Ptr := Scan_Ptr + 1;
+               C := Source (Scan_Ptr);
+               exit when C /= '_';
+               Error_No_Double_Underline;
+            end loop;
+
+         elsif C = '.' then
+            Accumulate_Checksum ('.');
+
+            if Point_Scanned then
+               Error_Msg_S ("duplicate point ignored");
+            end if;
+
+            Scan_Ptr := Scan_Ptr + 1;
+            C := Source (Scan_Ptr);
+            Point_Scanned := True;
+            Scale := 0;
+
+         elsif C = Base_Char then
+            Accumulate_Checksum (C);
+            Scan_Ptr := Scan_Ptr + 1;
+            exit;
+
+         elsif C = '#' or else C = ':' then
+            Error_Msg_S ("based number delimiters must match");
+            Scan_Ptr := Scan_Ptr + 1;
+            exit;
+
+         elsif not Identifier_Char (C) then
+            if Base_Char = '#' then
+               Error_Msg_S ("missing '#");
+            else
+               Error_Msg_S ("missing ':");
+            end if;
+
+            exit;
+         end if;
+
+      end loop;
+
+      UI_Num_Value := UI_Int_Value;
+   end if;
+
+   --  Scan out exponent
+
+   if not Point_Scanned then
+      Scale := 0;
+      UI_Scale := Uint_0;
+   else
+      UI_Scale := UI_From_Int (Scale);
+   end if;
+
+   if Source (Scan_Ptr) = 'e' or else Source (Scan_Ptr) = 'E' then
+      Accumulate_Checksum ('e');
+      Scan_Ptr := Scan_Ptr + 1;
+      Exponent_Is_Negative := False;
+
+      if Source (Scan_Ptr) = '+' then
+         Accumulate_Checksum ('+');
+         Scan_Ptr := Scan_Ptr + 1;
+
+      elsif Source (Scan_Ptr) = '-' then
+         Accumulate_Checksum ('-');
+
+         if not Point_Scanned then
+            Error_Msg_S ("negative exponent not allowed for integer literal");
+         else
+            Exponent_Is_Negative := True;
+         end if;
+
+         Scan_Ptr := Scan_Ptr + 1;
+      end if;
+
+      UI_Int_Value := Uint_0;
+
+      if Source (Scan_Ptr) in '0' .. '9' then
+         Scan_Integer;
+      else
+         Error_Digit_Expected;
+      end if;
+
+      if Exponent_Is_Negative then
+         UI_Scale := UI_Scale - UI_Int_Value;
+      else
+         UI_Scale := UI_Scale + UI_Int_Value;
+      end if;
+   end if;
+
+   --  Case of real literal to be returned
+
+   if Point_Scanned then
+      Token := Tok_Real_Literal;
+      Token_Node := New_Node (N_Real_Literal, Token_Ptr);
+      Set_Realval (Token_Node,
+        UR_From_Components (
+          Num   => UI_Num_Value,
+          Den   => -UI_Scale,
+          Rbase => Base));
+
+   --  Case of integer literal to be returned
+
+   else
+      Token := Tok_Integer_Literal;
+      Token_Node := New_Node (N_Integer_Literal, Token_Ptr);
+
+      if UI_Scale = 0 then
+         Set_Intval (Token_Node, UI_Num_Value);
+
+      --  Avoid doing possibly expensive calculations in cases like
+      --  parsing 163E800_000# when semantics will not be done anyway.
+      --  This is especially useful when parsing garbled input.
+
+      elsif Operating_Mode /= Check_Syntax
+        and then (Errors_Detected = 0 or else Try_Semantics)
+      then
+         Set_Intval (Token_Node, UI_Num_Value * UI_Base ** UI_Scale);
+
+      else
+         Set_Intval (Token_Node, No_Uint);
+      end if;
+
+   end if;
+
+   return;
+
+end Nlit;
diff --git a/gcc/ada/scn-slit.adb b/gcc/ada/scn-slit.adb
new file mode 100644
index 00000000000..508d5c225ac
--- /dev/null
+++ b/gcc/ada/scn-slit.adb
@@ -0,0 +1,373 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             S C N . S L I T                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.29 $                             --
+--                                                                          --
+--          Copyright (C) 1992-1999 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;
+
+separate (Scn)
+procedure Slit is
+
+   Delimiter : Character;
+   --  Delimiter (first character of string)
+
+   C : Character;
+   --  Current source program character
+
+   Code : Char_Code;
+   --  Current character code value
+
+   Err : Boolean;
+   --  Error flag for Scan_Wide call
+
+   String_Literal_Id : String_Id;
+   --  Id for currently scanned string value
+
+   Wide_Character_Found : Boolean := False;
+   --  Set True if wide character found
+
+   procedure Error_Bad_String_Char;
+   --  Signal bad character in string/character literal. On entry Scan_Ptr
+   --  points to the improper character encountered during the scan. Scan_Ptr
+   --  is not modified, so it still points to the bad character on return.
+
+   procedure Error_Unterminated_String;
+   --  Procedure called if a line terminator character is encountered during
+   --  scanning a string, meaning that the string is not properly terminated.
+
+   procedure Set_String;
+   --  Procedure used to distinguish between string and operator symbol.
+   --  On entry the string has been scanned out, and its characters start
+   --  at Token_Ptr and end one character before Scan_Ptr. On exit Token
+   --  is set to Tok_String_Literal or Tok_Operator_Symbol as appropriate,
+   --  and Token_Node is appropriately initialized. In addition, in the
+   --  operator symbol case, Token_Name is appropriately set.
+
+   ---------------------------
+   -- Error_Bad_String_Char --
+   ---------------------------
+
+   procedure Error_Bad_String_Char is
+      C : constant Character := Source (Scan_Ptr);
+
+   begin
+      if C = HT then
+         Error_Msg_S ("horizontal tab not allowed in string");
+
+      elsif C = VT or else C = FF then
+         Error_Msg_S ("format effector not allowed in string");
+
+      elsif C in Upper_Half_Character then
+         Error_Msg_S ("(Ada 83) upper half character not allowed");
+
+      else
+         Error_Msg_S ("control character not allowed in string");
+      end if;
+   end Error_Bad_String_Char;
+
+   -------------------------------
+   -- Error_Unterminated_String --
+   -------------------------------
+
+   procedure Error_Unterminated_String is
+   begin
+      --  An interesting little refinement. Consider the following examples:
+
+      --     A := "this is an unterminated string;
+      --     A := "this is an unterminated string &
+      --     P(A, "this is a parameter that didn't get terminated);
+
+      --  We fiddle a little to do slightly better placement in these cases
+      --  also if there is white space at the end of the line we place the
+      --  flag at the start of this white space, not at the end. Note that
+      --  we only have to test for blanks, since tabs aren't allowed in
+      --  strings in the first place and would have caused an error message.
+
+      --  Two more cases that we treat specially are:
+
+      --     A := "this string uses the wrong terminator'
+      --     A := "this string uses the wrong terminator' &
+
+      --  In these cases we give a different error message as well
+
+      --  We actually reposition the scan pointer to the point where we
+      --  place the flag in these cases, since it seems a better bet on
+      --  the original intention.
+
+      while Source (Scan_Ptr - 1) = ' '
+        or else Source (Scan_Ptr - 1) = '&'
+      loop
+         Scan_Ptr := Scan_Ptr - 1;
+         Unstore_String_Char;
+      end loop;
+
+      --  Check for case of incorrect string terminator, but single quote is
+      --  not considered incorrect if the opening terminator misused a single
+      --  quote (error message already given).
+
+      if Delimiter /= '''
+        and then Source (Scan_Ptr - 1) = '''
+      then
+         Unstore_String_Char;
+         Error_Msg ("incorrect string terminator character", Scan_Ptr - 1);
+         return;
+      end if;
+
+      if Source (Scan_Ptr - 1) = ';' then
+         Scan_Ptr := Scan_Ptr - 1;
+         Unstore_String_Char;
+
+         if Source (Scan_Ptr - 1) = ')' then
+            Scan_Ptr := Scan_Ptr - 1;
+            Unstore_String_Char;
+         end if;
+      end if;
+
+      Error_Msg_S ("missing string quote");
+   end Error_Unterminated_String;
+
+   ----------------
+   -- Set_String --
+   ----------------
+
+   procedure Set_String is
+      Slen : Int := Int (Scan_Ptr - Token_Ptr - 2);
+      C1   : Character;
+      C2   : Character;
+      C3   : Character;
+
+   begin
+      --  Token_Name is currently set to Error_Name. The following section of
+      --  code resets Token_Name to the proper Name_Op_xx value if the string
+      --  is a valid operator symbol, otherwise it is left set to Error_Name.
+
+      if Slen = 1 then
+         C1 := Source (Token_Ptr + 1);
+
+         case C1 is
+            when '=' =>
+               Token_Name := Name_Op_Eq;
+
+            when '>' =>
+               Token_Name := Name_Op_Gt;
+
+            when '<' =>
+               Token_Name := Name_Op_Lt;
+
+            when '+' =>
+               Token_Name := Name_Op_Add;
+
+            when '-' =>
+               Token_Name := Name_Op_Subtract;
+
+            when '&' =>
+               Token_Name := Name_Op_Concat;
+
+            when '*' =>
+               Token_Name := Name_Op_Multiply;
+
+            when '/' =>
+               Token_Name := Name_Op_Divide;
+
+            when others =>
+               null;
+         end case;
+
+      elsif Slen = 2 then
+         C1 := Source (Token_Ptr + 1);
+         C2 := Source (Token_Ptr + 2);
+
+         if C1 = '*' and then C2 = '*' then
+            Token_Name := Name_Op_Expon;
+
+         elsif C2 = '=' then
+
+            if C1 = '/' then
+               Token_Name := Name_Op_Ne;
+            elsif C1 = '<' then
+               Token_Name := Name_Op_Le;
+            elsif C1 = '>' then
+               Token_Name := Name_Op_Ge;
+            end if;
+
+         elsif (C1 = 'O' or else C1 = 'o') and then    -- OR
+               (C2 = 'R' or else C2 = 'r')
+         then
+            Token_Name := Name_Op_Or;
+         end if;
+
+      elsif Slen = 3 then
+         C1 := Source (Token_Ptr + 1);
+         C2 := Source (Token_Ptr + 2);
+         C3 := Source (Token_Ptr + 3);
+
+         if (C1 = 'A' or else C1 = 'a') and then       -- AND
+            (C2 = 'N' or else C2 = 'n') and then
+            (C3 = 'D' or else C3 = 'd')
+         then
+            Token_Name := Name_Op_And;
+
+         elsif (C1 = 'A' or else C1 = 'a') and then    -- ABS
+               (C2 = 'B' or else C2 = 'b') and then
+               (C3 = 'S' or else C3 = 's')
+         then
+            Token_Name := Name_Op_Abs;
+
+         elsif (C1 = 'M' or else C1 = 'm') and then    -- MOD
+               (C2 = 'O' or else C2 = 'o') and then
+               (C3 = 'D' or else C3 = 'd')
+         then
+            Token_Name := Name_Op_Mod;
+
+         elsif (C1 = 'N' or else C1 = 'n') and then    -- NOT
+               (C2 = 'O' or else C2 = 'o') and then
+               (C3 = 'T' or else C3 = 't')
+         then
+            Token_Name := Name_Op_Not;
+
+         elsif (C1 = 'R' or else C1 = 'r') and then    -- REM
+               (C2 = 'E' or else C2 = 'e') and then
+               (C3 = 'M' or else C3 = 'm')
+         then
+            Token_Name := Name_Op_Rem;
+
+         elsif (C1 = 'X' or else C1 = 'x') and then    -- XOR
+               (C2 = 'O' or else C2 = 'o') and then
+               (C3 = 'R' or else C3 = 'r')
+         then
+            Token_Name := Name_Op_Xor;
+         end if;
+
+      end if;
+
+      --  If it is an operator symbol, then Token_Name is set. If it is some
+      --  other string value, then Token_Name still contains Error_Name.
+
+      if Token_Name = Error_Name then
+         Token := Tok_String_Literal;
+         Token_Node := New_Node (N_String_Literal, Token_Ptr);
+         Set_Has_Wide_Character (Token_Node, Wide_Character_Found);
+
+      else
+         Token := Tok_Operator_Symbol;
+         Token_Node := New_Node (N_Operator_Symbol, Token_Ptr);
+         Set_Chars (Token_Node, Token_Name);
+      end if;
+
+      Set_Strval (Token_Node, String_Literal_Id);
+
+   end Set_String;
+
+----------
+-- Slit --
+----------
+
+begin
+   --  On entry, Scan_Ptr points to the opening character of the string which
+   --  is either a percent, double quote, or apostrophe (single quote). The
+   --  latter case is an error detected by the character literal circuit.
+
+   Delimiter := Source (Scan_Ptr);
+   Accumulate_Checksum (Delimiter);
+   Start_String;
+   Scan_Ptr := Scan_Ptr + 1;
+
+   --  Loop to scan out characters of string literal
+
+   loop
+      C := Source (Scan_Ptr);
+
+      if C = Delimiter then
+         Accumulate_Checksum (C);
+         Scan_Ptr := Scan_Ptr + 1;
+         exit when Source (Scan_Ptr) /= Delimiter;
+         Code := Get_Char_Code (C);
+         Accumulate_Checksum (C);
+         Scan_Ptr := Scan_Ptr + 1;
+
+      else
+         if C = '"' and then Delimiter = '%' then
+            Error_Msg_S ("quote not allowed in percent delimited string");
+            Code := Get_Char_Code (C);
+            Scan_Ptr := Scan_Ptr + 1;
+
+         elsif (C = ESC
+                 and then
+                Wide_Character_Encoding_Method in WC_ESC_Encoding_Method)
+           or else
+               (C in Upper_Half_Character
+                 and then
+                Upper_Half_Encoding)
+           or else
+               (C = '['
+                 and then
+                Source (Scan_Ptr + 1) = '"'
+                 and then
+                Identifier_Char (Source (Scan_Ptr + 2)))
+         then
+            Scan_Wide (Source, Scan_Ptr, Code, Err);
+            Accumulate_Checksum (Code);
+
+            if Err then
+               Error_Illegal_Wide_Character;
+               Code := Get_Char_Code (' ');
+            end if;
+
+         else
+            Accumulate_Checksum (C);
+
+            if C not in Graphic_Character then
+               if C in Line_Terminator then
+                  Error_Unterminated_String;
+                  exit;
+
+               elsif C in Upper_Half_Character then
+                  if Ada_83 then
+                     Error_Bad_String_Char;
+                  end if;
+
+               else
+                  Error_Bad_String_Char;
+               end if;
+            end if;
+
+            Code := Get_Char_Code (C);
+            Scan_Ptr := Scan_Ptr + 1;
+         end if;
+      end if;
+
+      Store_String_Char (Code);
+
+      if not In_Character_Range (Code) then
+         Wide_Character_Found := True;
+      end if;
+   end loop;
+
+   String_Literal_Id := End_String;
+   Set_String;
+   return;
+
+end Slit;
diff --git a/gcc/ada/scn.adb b/gcc/ada/scn.adb
new file mode 100644
index 00000000000..146314db117
--- /dev/null
+++ b/gcc/ada/scn.adb
@@ -0,0 +1,1570 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                                  S C N                                   --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.111 $
+--                                                                          --
+--          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 Csets;    use Csets;
+with Errout;   use Errout;
+with Hostparm; use Hostparm;
+with Namet;    use Namet;
+with Opt;      use Opt;
+with Scans;    use Scans;
+with Sinput;   use Sinput;
+with Sinfo;    use Sinfo;
+with Snames;   use Snames;
+with Style;
+with Widechar; use Widechar;
+
+with System.WCh_Con; use System.WCh_Con;
+
+package body Scn is
+
+   use ASCII;
+   --  Make control characters visible
+
+   Used_As_Identifier : array (Token_Type) of Boolean;
+   --  Flags set True if a given keyword is used as an identifier (used to
+   --  make sure that we only post an error message for incorrect use of a
+   --  keyword as an identifier once for a given keyword).
+
+   -----------------------
+   -- Local Subprograms --
+   -----------------------
+
+   procedure Accumulate_Checksum (C : Character);
+   pragma Inline (Accumulate_Checksum);
+   --  This routine accumulates the checksum given character C. During the
+   --  scanning of a source file, this routine is called with every character
+   --  in the source, excluding blanks, and all control characters (except
+   --  that ESC is included in the checksum). Upper case letters not in string
+   --  literals are folded by the caller. See Sinput spec for the documentation
+   --  of the checksum algorithm. Note: checksum values are only used if we
+   --  generate code, so it is not necessary to worry about making the right
+   --  sequence of calls in any error situation.
+
+   procedure Accumulate_Checksum (C : Char_Code);
+   pragma Inline (Accumulate_Checksum);
+   --  This version is identical, except that the argument, C, is a character
+   --  code value instead of a character. This is used when wide characters
+   --  are scanned. We use the character code rather than the ASCII characters
+   --  so that the checksum is independent of wide character encoding method.
+
+   procedure Check_End_Of_Line;
+   --  Called when end of line encountered. Checks that line is not
+   --  too long, and that other style checks for the end of line are met.
+
+   function Determine_License return License_Type;
+   --  Scan header of file and check that it has an appropriate GNAT-style
+   --  header with a proper license statement. Returns GPL, Unrestricted,
+   --  or Modified_GPL depending on header. If none of these, returns Unknown.
+
+   function Double_Char_Token (C : Character) return Boolean;
+   --  This function is used for double character tokens like := or <>. It
+   --  checks if the character following Source (Scan_Ptr) is C, and if so
+   --  bumps Scan_Ptr past the pair of characters and returns True. A space
+   --  between the two characters is also recognized with an appropriate
+   --  error message being issued. If C is not present, False is returned.
+   --  Note that Double_Char_Token can only be used for tokens defined in
+   --  the Ada syntax (it's use for error cases like && is not appropriate
+   --  since we do not want a junk message for a case like &-space-&).
+
+   procedure Error_Illegal_Character;
+   --  Give illegal character error, Scan_Ptr points to character. On return,
+   --  Scan_Ptr is bumped past the illegal character.
+
+   procedure Error_Illegal_Wide_Character;
+   --  Give illegal wide character message. On return, Scan_Ptr is bumped
+   --  past the illegal character, which may still leave us pointing to
+   --  junk, not much we can do if the escape sequence is messed up!
+
+   procedure Error_Long_Line;
+   --  Signal error of excessively long line
+
+   procedure Error_No_Double_Underline;
+   --  Signal error of double underline character
+
+   procedure Nlit;
+   --  This is the procedure for scanning out numeric literals. On entry,
+   --  Scan_Ptr points to the digit that starts the numeric literal (the
+   --  checksum for this character has not been accumulated yet). On return
+   --  Scan_Ptr points past the last character of the numeric literal, Token
+   --  and Token_Node are set appropriately, and the checksum is updated.
+
+   function Set_Start_Column return Column_Number;
+   --  This routine is called with Scan_Ptr pointing to the first character
+   --  of a line. On exit, Scan_Ptr is advanced to the first non-blank
+   --  character of this line (or to the terminating format effector if the
+   --  line contains no non-blank characters), and the returned result is the
+   --  column number of this non-blank character (zero origin), which is the
+   --  value to be stored in the Start_Column scan variable.
+
+   procedure Slit;
+   --  This is the procedure for scanning out string literals. On entry,
+   --  Scan_Ptr points to the opening string quote (the checksum for this
+   --  character has not been accumulated yet). On return Scan_Ptr points
+   --  past the closing quote of the string literal, Token and Token_Node
+   --  are set appropriately, and the checksum is upated.
+
+   -------------------------
+   -- Accumulate_Checksum --
+   -------------------------
+
+   procedure Accumulate_Checksum (C : Character) is
+   begin
+      Checksum := Checksum + Checksum + Character'Pos (C);
+
+      if Checksum > 16#8000_0000# then
+         Checksum := (Checksum + 1) and 16#7FFF_FFFF#;
+      end if;
+   end Accumulate_Checksum;
+
+   procedure Accumulate_Checksum (C : Char_Code) is
+   begin
+      Checksum := Checksum + Checksum + Char_Code'Pos (C);
+
+      if Checksum > 16#8000_0000# then
+         Checksum := (Checksum + 1) and 16#7FFF_FFFF#;
+      end if;
+   end Accumulate_Checksum;
+
+   -----------------------
+   -- Check_End_Of_Line --
+   -----------------------
+
+   procedure Check_End_Of_Line is
+      Len : constant Int := Int (Scan_Ptr) - Int (Current_Line_Start);
+
+   begin
+      if Len > Hostparm.Max_Line_Length then
+         Error_Long_Line;
+
+      elsif Style_Check then
+         Style.Check_Line_Terminator (Len);
+      end if;
+   end Check_End_Of_Line;
+
+   -----------------------
+   -- Determine_License --
+   -----------------------
+
+   function Determine_License return License_Type is
+      GPL_Found : Boolean := False;
+
+      function Contains (S : String) return Boolean;
+      --  See if current comment contains successive non-blank characters
+      --  matching the contents of S. If so leave Scan_Ptr unchanged and
+      --  return True, otherwise leave Scan_Ptr unchanged and return False.
+
+      procedure Skip_EOL;
+      --  Skip to line terminator character
+
+      --------------
+      -- Contains --
+      --------------
+
+      function Contains (S : String) return Boolean is
+         CP : Natural;
+         SP : Source_Ptr;
+         SS : Source_Ptr;
+
+      begin
+         SP := Scan_Ptr;
+         while Source (SP) /= CR and then Source (SP) /= LF loop
+            if Source (SP) = S (S'First) then
+               SS := SP;
+               CP := S'First;
+
+               loop
+                  SS := SS + 1;
+                  CP := CP + 1;
+
+                  if CP > S'Last then
+                     return True;
+                  end if;
+
+                  while Source (SS) = ' ' loop
+                     SS := SS + 1;
+                  end loop;
+
+                  exit when Source (SS) /= S (CP);
+               end loop;
+            end if;
+
+            SP := SP + 1;
+         end loop;
+
+         return False;
+      end Contains;
+
+      --------------
+      -- Skip_EOL --
+      --------------
+
+      procedure Skip_EOL is
+      begin
+         while Source (Scan_Ptr) /= CR
+           and then Source (Scan_Ptr) /= LF
+         loop
+            Scan_Ptr := Scan_Ptr + 1;
+         end loop;
+      end Skip_EOL;
+
+   --  Start of processing for Determine_License
+
+   begin
+      loop
+         if Source (Scan_Ptr) /= '-'
+           or else Source (Scan_Ptr + 1) /= '-'
+         then
+            if GPL_Found then
+               return GPL;
+            else
+               return Unknown;
+            end if;
+
+         elsif Contains ("Asaspecialexception") then
+            if GPL_Found then
+               return Modified_GPL;
+            end if;
+
+         elsif Contains ("GNUGeneralPublicLicense") then
+            GPL_Found := True;
+
+         elsif
+             Contains
+               ("ThisspecificationisadaptedfromtheAdaSemanticInterface")
+           or else
+             Contains
+              ("ThisspecificationisderivedfromtheAdaReferenceManual")
+         then
+            return Unrestricted;
+         end if;
+
+         Skip_EOL;
+
+         Check_End_Of_Line;
+
+         declare
+            Physical : Boolean;
+
+         begin
+            Skip_Line_Terminators (Scan_Ptr, Physical);
+
+            --  If we are at start of physical line, update scan pointers
+            --  to reflect the start of the new line.
+
+            if Physical then
+               Current_Line_Start       := Scan_Ptr;
+               Start_Column             := Set_Start_Column;
+               First_Non_Blank_Location := Scan_Ptr;
+            end if;
+         end;
+      end loop;
+   end Determine_License;
+
+   ----------------------------
+   -- Determine_Token_Casing --
+   ----------------------------
+
+   function Determine_Token_Casing return Casing_Type is
+   begin
+      return Determine_Casing (Source (Token_Ptr .. Scan_Ptr - 1));
+   end Determine_Token_Casing;
+
+   -----------------------
+   -- Double_Char_Token --
+   -----------------------
+
+   function Double_Char_Token (C : Character) return Boolean is
+   begin
+      if Source (Scan_Ptr + 1) = C then
+         Accumulate_Checksum (C);
+         Scan_Ptr := Scan_Ptr + 2;
+         return True;
+
+      elsif Source (Scan_Ptr + 1) = ' '
+        and then Source (Scan_Ptr + 2) = C
+      then
+         Scan_Ptr := Scan_Ptr + 1;
+         Error_Msg_S ("no space allowed here");
+         Scan_Ptr := Scan_Ptr + 2;
+         return True;
+
+      else
+         return False;
+      end if;
+   end Double_Char_Token;
+
+   -----------------------------
+   -- Error_Illegal_Character --
+   -----------------------------
+
+   procedure Error_Illegal_Character is
+   begin
+      Error_Msg_S ("illegal character");
+      Scan_Ptr := Scan_Ptr + 1;
+   end Error_Illegal_Character;
+
+   ----------------------------------
+   -- Error_Illegal_Wide_Character --
+   ----------------------------------
+
+   procedure Error_Illegal_Wide_Character is
+   begin
+      if OpenVMS then
+         Error_Msg_S
+           ("illegal wide character, check " &
+            "'/'W'I'D'E'_'C'H'A'R'A'C'T'E'R'_'E'N'C'O'D'I'N'G qualifer");
+      else
+         Error_Msg_S
+           ("illegal wide character, check -gnatW switch");
+      end if;
+
+      Scan_Ptr := Scan_Ptr + 1;
+   end Error_Illegal_Wide_Character;
+
+   ---------------------
+   -- Error_Long_Line --
+   ---------------------
+
+   procedure Error_Long_Line is
+   begin
+      Error_Msg
+        ("this line is too long",
+         Current_Line_Start + Hostparm.Max_Line_Length);
+   end Error_Long_Line;
+
+   -------------------------------
+   -- Error_No_Double_Underline --
+   -------------------------------
+
+   procedure Error_No_Double_Underline is
+   begin
+      Error_Msg_S ("two consecutive underlines not permitted");
+   end Error_No_Double_Underline;
+
+   ------------------------
+   -- Initialize_Scanner --
+   ------------------------
+
+   procedure Initialize_Scanner
+     (Unit  : Unit_Number_Type;
+      Index : Source_File_Index)
+   is
+      GNAT_Hedr : constant Text_Buffer (1 .. 78) := (others => '-');
+
+   begin
+      --  Set up Token_Type values in Names Table entries for reserved keywords
+      --  We use the Pos value of the Token_Type value. Note we are relying on
+      --  the fact that Token_Type'Val (0) is not a reserved word!
+
+      Set_Name_Table_Byte (Name_Abort,      Token_Type'Pos (Tok_Abort));
+      Set_Name_Table_Byte (Name_Abs,        Token_Type'Pos (Tok_Abs));
+      Set_Name_Table_Byte (Name_Abstract,   Token_Type'Pos (Tok_Abstract));
+      Set_Name_Table_Byte (Name_Accept,     Token_Type'Pos (Tok_Accept));
+      Set_Name_Table_Byte (Name_Access,     Token_Type'Pos (Tok_Access));
+      Set_Name_Table_Byte (Name_And,        Token_Type'Pos (Tok_And));
+      Set_Name_Table_Byte (Name_Aliased,    Token_Type'Pos (Tok_Aliased));
+      Set_Name_Table_Byte (Name_All,        Token_Type'Pos (Tok_All));
+      Set_Name_Table_Byte (Name_Array,      Token_Type'Pos (Tok_Array));
+      Set_Name_Table_Byte (Name_At,         Token_Type'Pos (Tok_At));
+      Set_Name_Table_Byte (Name_Begin,      Token_Type'Pos (Tok_Begin));
+      Set_Name_Table_Byte (Name_Body,       Token_Type'Pos (Tok_Body));
+      Set_Name_Table_Byte (Name_Case,       Token_Type'Pos (Tok_Case));
+      Set_Name_Table_Byte (Name_Constant,   Token_Type'Pos (Tok_Constant));
+      Set_Name_Table_Byte (Name_Declare,    Token_Type'Pos (Tok_Declare));
+      Set_Name_Table_Byte (Name_Delay,      Token_Type'Pos (Tok_Delay));
+      Set_Name_Table_Byte (Name_Delta,      Token_Type'Pos (Tok_Delta));
+      Set_Name_Table_Byte (Name_Digits,     Token_Type'Pos (Tok_Digits));
+      Set_Name_Table_Byte (Name_Do,         Token_Type'Pos (Tok_Do));
+      Set_Name_Table_Byte (Name_Else,       Token_Type'Pos (Tok_Else));
+      Set_Name_Table_Byte (Name_Elsif,      Token_Type'Pos (Tok_Elsif));
+      Set_Name_Table_Byte (Name_End,        Token_Type'Pos (Tok_End));
+      Set_Name_Table_Byte (Name_Entry,      Token_Type'Pos (Tok_Entry));
+      Set_Name_Table_Byte (Name_Exception,  Token_Type'Pos (Tok_Exception));
+      Set_Name_Table_Byte (Name_Exit,       Token_Type'Pos (Tok_Exit));
+      Set_Name_Table_Byte (Name_For,        Token_Type'Pos (Tok_For));
+      Set_Name_Table_Byte (Name_Function,   Token_Type'Pos (Tok_Function));
+      Set_Name_Table_Byte (Name_Generic,    Token_Type'Pos (Tok_Generic));
+      Set_Name_Table_Byte (Name_Goto,       Token_Type'Pos (Tok_Goto));
+      Set_Name_Table_Byte (Name_If,         Token_Type'Pos (Tok_If));
+      Set_Name_Table_Byte (Name_In,         Token_Type'Pos (Tok_In));
+      Set_Name_Table_Byte (Name_Is,         Token_Type'Pos (Tok_Is));
+      Set_Name_Table_Byte (Name_Limited,    Token_Type'Pos (Tok_Limited));
+      Set_Name_Table_Byte (Name_Loop,       Token_Type'Pos (Tok_Loop));
+      Set_Name_Table_Byte (Name_Mod,        Token_Type'Pos (Tok_Mod));
+      Set_Name_Table_Byte (Name_New,        Token_Type'Pos (Tok_New));
+      Set_Name_Table_Byte (Name_Not,        Token_Type'Pos (Tok_Not));
+      Set_Name_Table_Byte (Name_Null,       Token_Type'Pos (Tok_Null));
+      Set_Name_Table_Byte (Name_Of,         Token_Type'Pos (Tok_Of));
+      Set_Name_Table_Byte (Name_Or,         Token_Type'Pos (Tok_Or));
+      Set_Name_Table_Byte (Name_Others,     Token_Type'Pos (Tok_Others));
+      Set_Name_Table_Byte (Name_Out,        Token_Type'Pos (Tok_Out));
+      Set_Name_Table_Byte (Name_Package,    Token_Type'Pos (Tok_Package));
+      Set_Name_Table_Byte (Name_Pragma,     Token_Type'Pos (Tok_Pragma));
+      Set_Name_Table_Byte (Name_Private,    Token_Type'Pos (Tok_Private));
+      Set_Name_Table_Byte (Name_Procedure,  Token_Type'Pos (Tok_Procedure));
+      Set_Name_Table_Byte (Name_Protected,  Token_Type'Pos (Tok_Protected));
+      Set_Name_Table_Byte (Name_Raise,      Token_Type'Pos (Tok_Raise));
+      Set_Name_Table_Byte (Name_Range,      Token_Type'Pos (Tok_Range));
+      Set_Name_Table_Byte (Name_Record,     Token_Type'Pos (Tok_Record));
+      Set_Name_Table_Byte (Name_Rem,        Token_Type'Pos (Tok_Rem));
+      Set_Name_Table_Byte (Name_Renames,    Token_Type'Pos (Tok_Renames));
+      Set_Name_Table_Byte (Name_Requeue,    Token_Type'Pos (Tok_Requeue));
+      Set_Name_Table_Byte (Name_Return,     Token_Type'Pos (Tok_Return));
+      Set_Name_Table_Byte (Name_Reverse,    Token_Type'Pos (Tok_Reverse));
+      Set_Name_Table_Byte (Name_Select,     Token_Type'Pos (Tok_Select));
+      Set_Name_Table_Byte (Name_Separate,   Token_Type'Pos (Tok_Separate));
+      Set_Name_Table_Byte (Name_Subtype,    Token_Type'Pos (Tok_Subtype));
+      Set_Name_Table_Byte (Name_Tagged,     Token_Type'Pos (Tok_Tagged));
+      Set_Name_Table_Byte (Name_Task,       Token_Type'Pos (Tok_Task));
+      Set_Name_Table_Byte (Name_Terminate,  Token_Type'Pos (Tok_Terminate));
+      Set_Name_Table_Byte (Name_Then,       Token_Type'Pos (Tok_Then));
+      Set_Name_Table_Byte (Name_Type,       Token_Type'Pos (Tok_Type));
+      Set_Name_Table_Byte (Name_Until,      Token_Type'Pos (Tok_Until));
+      Set_Name_Table_Byte (Name_Use,        Token_Type'Pos (Tok_Use));
+      Set_Name_Table_Byte (Name_When,       Token_Type'Pos (Tok_When));
+      Set_Name_Table_Byte (Name_While,      Token_Type'Pos (Tok_While));
+      Set_Name_Table_Byte (Name_With,       Token_Type'Pos (Tok_With));
+      Set_Name_Table_Byte (Name_Xor,        Token_Type'Pos (Tok_Xor));
+
+      --  Initialize scan control variables
+
+      Current_Source_File       := Index;
+      Source                    := Source_Text (Current_Source_File);
+      Current_Source_Unit       := Unit;
+      Scan_Ptr                  := Source_First (Current_Source_File);
+      Token                     := No_Token;
+      Token_Ptr                 := Scan_Ptr;
+      Current_Line_Start        := Scan_Ptr;
+      Token_Node                := Empty;
+      Token_Name                := No_Name;
+      Start_Column              := Set_Start_Column;
+      First_Non_Blank_Location  := Scan_Ptr;
+      Checksum                  := 0;
+
+      --  Set default for Comes_From_Source. All nodes built now until we
+      --  reenter the analyzer will have Comes_From_Source set to True
+
+      Set_Comes_From_Source_Default (True);
+
+      --  Check license if GNAT type header possibly present
+
+      if Source_Last (Index) - Scan_Ptr > 80
+        and then Source (Scan_Ptr .. Scan_Ptr + 77) = GNAT_Hedr
+      then
+         Set_License (Current_Source_File, Determine_License);
+      end if;
+
+      --  Scan initial token (note this initializes Prev_Token, Prev_Token_Ptr)
+
+      Scan;
+
+      --  Clear flags for reserved words used as indentifiers
+
+      for J in Token_Type loop
+         Used_As_Identifier (J) := False;
+      end loop;
+
+   end Initialize_Scanner;
+
+   ----------
+   -- Nlit --
+   ----------
+
+   procedure Nlit is separate;
+
+   ----------
+   -- Scan --
+   ----------
+
+   procedure Scan is
+   begin
+      Prev_Token := Token;
+      Prev_Token_Ptr := Token_Ptr;
+      Token_Name := Error_Name;
+
+      --  The following loop runs more than once only if a format effector
+      --  (tab, vertical tab, form  feed, line feed, carriage return) is
+      --  encountered and skipped, or some error situation, such as an
+      --  illegal character, is encountered.
+
+      loop
+         --  Skip past blanks, loop is opened up for speed
+
+         while Source (Scan_Ptr) = ' ' loop
+
+            if Source (Scan_Ptr + 1) /= ' ' then
+               Scan_Ptr := Scan_Ptr + 1;
+               exit;
+            end if;
+
+            if Source (Scan_Ptr + 2) /= ' ' then
+               Scan_Ptr := Scan_Ptr + 2;
+               exit;
+            end if;
+
+            if Source (Scan_Ptr + 3) /= ' ' then
+               Scan_Ptr := Scan_Ptr + 3;
+               exit;
+            end if;
+
+            if Source (Scan_Ptr + 4) /= ' ' then
+               Scan_Ptr := Scan_Ptr + 4;
+               exit;
+            end if;
+
+            if Source (Scan_Ptr + 5) /= ' ' then
+               Scan_Ptr := Scan_Ptr + 5;
+               exit;
+            end if;
+
+            if Source (Scan_Ptr + 6) /= ' ' then
+               Scan_Ptr := Scan_Ptr + 6;
+               exit;
+            end if;
+
+            if Source (Scan_Ptr + 7) /= ' ' then
+               Scan_Ptr := Scan_Ptr + 7;
+               exit;
+            end if;
+
+            Scan_Ptr := Scan_Ptr + 8;
+         end loop;
+
+         --  We are now at a non-blank character, which is the first character
+         --  of the token we will scan, and hence the value of Token_Ptr.
+
+         Token_Ptr := Scan_Ptr;
+
+         --  Here begins the main case statement which transfers control on
+         --  the basis of the non-blank character we have encountered.
+
+         case Source (Scan_Ptr) is
+
+         --  Line terminator characters
+
+         when CR | LF | FF | VT => Line_Terminator_Case : begin
+
+            --  Check line too long
+
+            Check_End_Of_Line;
+
+            declare
+               Physical : Boolean;
+
+            begin
+               Skip_Line_Terminators (Scan_Ptr, Physical);
+
+               --  If we are at start of physical line, update scan pointers
+               --  to reflect the start of the new line.
+
+               if Physical then
+                  Current_Line_Start       := Scan_Ptr;
+                  Start_Column             := Set_Start_Column;
+                  First_Non_Blank_Location := Scan_Ptr;
+               end if;
+            end;
+         end Line_Terminator_Case;
+
+         --  Horizontal tab, just skip past it
+
+         when HT =>
+            if Style_Check then Style.Check_HT; end if;
+            Scan_Ptr := Scan_Ptr + 1;
+
+         --  End of file character, treated as an end of file only if it
+         --  is the last character in the buffer, otherwise it is ignored.
+
+         when EOF =>
+            if Scan_Ptr = Source_Last (Current_Source_File) then
+               Check_End_Of_Line;
+               Token := Tok_EOF;
+               return;
+
+            else
+               Scan_Ptr := Scan_Ptr + 1;
+            end if;
+
+         --  Ampersand
+
+         when '&' =>
+            Accumulate_Checksum ('&');
+
+            if Source (Scan_Ptr + 1) = '&' then
+               Error_Msg_S ("'&'& should be `AND THEN`");
+               Scan_Ptr := Scan_Ptr + 2;
+               Token := Tok_And;
+               return;
+
+            else
+               Scan_Ptr := Scan_Ptr + 1;
+               Token := Tok_Ampersand;
+               return;
+            end if;
+
+         --  Asterisk (can be multiplication operator or double asterisk
+         --  which is the exponentiation compound delimtier).
+
+         when '*' =>
+            Accumulate_Checksum ('*');
+
+            if Source (Scan_Ptr + 1) = '*' then
+               Accumulate_Checksum ('*');
+               Scan_Ptr := Scan_Ptr + 2;
+               Token := Tok_Double_Asterisk;
+               return;
+
+            else
+               Scan_Ptr := Scan_Ptr + 1;
+               Token := Tok_Asterisk;
+               return;
+            end if;
+
+         --  Colon, which can either be an isolated colon, or part of an
+         --  assignment compound delimiter.
+
+         when ':' =>
+            Accumulate_Checksum (':');
+
+            if Double_Char_Token ('=') then
+               Token := Tok_Colon_Equal;
+               if Style_Check then Style.Check_Colon_Equal; end if;
+               return;
+
+            elsif Source (Scan_Ptr + 1) = '-'
+              and then Source (Scan_Ptr + 2) /= '-'
+            then
+               Token := Tok_Colon_Equal;
+               Error_Msg (":- should be :=", Scan_Ptr);
+               Scan_Ptr := Scan_Ptr + 2;
+               return;
+
+            else
+               Scan_Ptr := Scan_Ptr + 1;
+               Token := Tok_Colon;
+               if Style_Check then Style.Check_Colon; end if;
+               return;
+            end if;
+
+         --  Left parenthesis
+
+         when '(' =>
+            Accumulate_Checksum ('(');
+            Scan_Ptr := Scan_Ptr + 1;
+            Token := Tok_Left_Paren;
+            if Style_Check then Style.Check_Left_Paren; end if;
+            return;
+
+         --  Left bracket
+
+         when '[' =>
+            if Source (Scan_Ptr + 1) = '"' then
+               Name_Len := 0;
+               goto Scan_Identifier;
+
+            else
+               Error_Msg_S ("illegal character, replaced by ""(""");
+               Scan_Ptr := Scan_Ptr + 1;
+               Token := Tok_Left_Paren;
+               return;
+            end if;
+
+         --  Left brace
+
+         when '{' =>
+            Error_Msg_S ("illegal character, replaced by ""(""");
+            Scan_Ptr := Scan_Ptr + 1;
+            Token := Tok_Left_Paren;
+            return;
+
+         --  Comma
+
+         when ',' =>
+            Accumulate_Checksum (',');
+            Scan_Ptr := Scan_Ptr + 1;
+            Token := Tok_Comma;
+            if Style_Check then Style.Check_Comma; end if;
+            return;
+
+         --  Dot, which is either an isolated period, or part of a double
+         --  dot compound delimiter sequence. We also check for the case of
+         --  a digit following the period, to give a better error message.
+
+         when '.' =>
+            Accumulate_Checksum ('.');
+
+            if Double_Char_Token ('.') then
+               Token := Tok_Dot_Dot;
+               if Style_Check then Style.Check_Dot_Dot; end if;
+               return;
+
+            elsif Source (Scan_Ptr + 1) in '0' .. '9' then
+               Error_Msg_S ("numeric literal cannot start with point");
+               Scan_Ptr := Scan_Ptr + 1;
+
+            else
+               Scan_Ptr := Scan_Ptr + 1;
+               Token := Tok_Dot;
+               return;
+            end if;
+
+         --  Equal, which can either be an equality operator, or part of the
+         --  arrow (=>) compound delimiter.
+
+         when '=' =>
+            Accumulate_Checksum ('=');
+
+            if Double_Char_Token ('>') then
+               Token := Tok_Arrow;
+               if Style_Check then Style.Check_Arrow; end if;
+               return;
+
+            elsif Source (Scan_Ptr + 1) = '=' then
+               Error_Msg_S ("== should be =");
+               Scan_Ptr := Scan_Ptr + 1;
+            end if;
+
+            Scan_Ptr := Scan_Ptr + 1;
+            Token := Tok_Equal;
+            return;
+
+         --  Greater than, which can be a greater than operator, greater than
+         --  or equal operator, or first character of a right label bracket.
+
+         when '>' =>
+            Accumulate_Checksum ('>');
+
+            if Double_Char_Token ('=') then
+               Token := Tok_Greater_Equal;
+               return;
+
+            elsif Double_Char_Token ('>') then
+               Token := Tok_Greater_Greater;
+               return;
+
+            else
+               Scan_Ptr := Scan_Ptr + 1;
+               Token := Tok_Greater;
+               return;
+            end if;
+
+         --  Less than, which can be a less than operator, less than or equal
+         --  operator, or the first character of a left label bracket, or the
+         --  first character of a box (<>) compound delimiter.
+
+         when '<' =>
+            Accumulate_Checksum ('<');
+
+            if Double_Char_Token ('=') then
+               Token := Tok_Less_Equal;
+               return;
+
+            elsif Double_Char_Token ('>') then
+               Token := Tok_Box;
+               if Style_Check then Style.Check_Box; end if;
+               return;
+
+            elsif Double_Char_Token ('<') then
+               Token := Tok_Less_Less;
+               return;
+
+            else
+               Scan_Ptr := Scan_Ptr + 1;
+               Token := Tok_Less;
+               return;
+            end if;
+
+         --  Minus, which is either a subtraction operator, or the first
+         --  character of double minus starting a comment
+
+         when '-' => Minus_Case : begin
+            if Source (Scan_Ptr + 1) = '>' then
+               Error_Msg_S ("invalid token");
+               Scan_Ptr := Scan_Ptr + 2;
+               Token := Tok_Arrow;
+               return;
+
+            elsif Source (Scan_Ptr + 1) /= '-' then
+               Accumulate_Checksum ('-');
+               Scan_Ptr := Scan_Ptr + 1;
+               Token := Tok_Minus;
+               return;
+
+            --  Comment
+
+            else -- Source (Scan_Ptr + 1) = '-' then
+               if Style_Check then Style.Check_Comment; end if;
+               Scan_Ptr := Scan_Ptr + 2;
+
+               --  Loop to scan comment (this loop runs more than once only if
+               --  a horizontal tab or other non-graphic character is scanned)
+
+               loop
+                  --  Scan to non graphic character (opened up for speed)
+
+                  loop
+                     exit when Source (Scan_Ptr) not in Graphic_Character;
+                     Scan_Ptr := Scan_Ptr + 1;
+                     exit when Source (Scan_Ptr) not in Graphic_Character;
+                     Scan_Ptr := Scan_Ptr + 1;
+                     exit when Source (Scan_Ptr) not in Graphic_Character;
+                     Scan_Ptr := Scan_Ptr + 1;
+                     exit when Source (Scan_Ptr) not in Graphic_Character;
+                     Scan_Ptr := Scan_Ptr + 1;
+                     exit when Source (Scan_Ptr) not in Graphic_Character;
+                     Scan_Ptr := Scan_Ptr + 1;
+                  end loop;
+
+                  --  Keep going if horizontal tab
+
+                  if Source (Scan_Ptr) = HT then
+                     if Style_Check then Style.Check_HT; end if;
+                     Scan_Ptr := Scan_Ptr + 1;
+
+                  --  Terminate scan of comment if line terminator
+
+                  elsif Source (Scan_Ptr) in Line_Terminator then
+                     exit;
+
+                  --  Terminate scan of comment if end of file encountered
+                  --  (embedded EOF character or real last character in file)
+
+                  elsif Source (Scan_Ptr) = EOF then
+                     exit;
+
+                  --  Keep going if character in 80-FF range, or is ESC. These
+                  --  characters are allowed in comments by RM-2.1(1), 2.7(2).
+                  --  They are allowed even in Ada 83 mode according to the
+                  --  approved AI. ESC was added to the AI in June 93.
+
+                  elsif Source (Scan_Ptr) in Upper_Half_Character
+                    or else Source (Scan_Ptr) = ESC
+                  then
+                     Scan_Ptr := Scan_Ptr + 1;
+
+                  --  Otherwise we have an illegal comment character
+
+                  else
+                     Error_Illegal_Character;
+                  end if;
+
+               end loop;
+
+               --  Note that we do NOT execute a return here, instead we fall
+               --  through to reexecute the scan loop to look for a token.
+
+            end if;
+         end Minus_Case;
+
+         --  Double quote or percent starting a string literal
+
+         when '"' | '%' =>
+            Slit;
+            return;
+
+         --  Apostrophe. This can either be the start of a character literal,
+         --  or an isolated apostrophe used in a qualified expression or an
+         --  attribute. We treat it as a character literal if it does not
+         --  follow a right parenthesis, identifier, the keyword ALL or
+         --  a literal. This means that we correctly treat constructs like:
+
+         --    A := CHARACTER'('A');
+
+         --  Note that RM-2.2(7) does not require a separator between
+         --  "CHARACTER" and "'" in the above.
+
+         when ''' => Char_Literal_Case : declare
+            Code : Char_Code;
+            Err  : Boolean;
+
+         begin
+            Accumulate_Checksum (''');
+            Scan_Ptr := Scan_Ptr + 1;
+
+            --  Here is where we make the test to distinguish the cases. Treat
+            --  as apostrophe if previous token is an identifier, right paren
+            --  or the reserved word "all" (latter case as in A.all'Address)
+            --  Also treat it as apostrophe after a literal (this catches
+            --  some legitimate cases, like A."abs"'Address, and also gives
+            --  better error behavior for impossible cases like 123'xxx).
+
+            if Prev_Token = Tok_Identifier
+               or else Prev_Token = Tok_Right_Paren
+               or else Prev_Token = Tok_All
+               or else Prev_Token in Token_Class_Literal
+            then
+               Token := Tok_Apostrophe;
+               return;
+
+            --  Otherwise the apostrophe starts a character literal
+
+            else
+               --  Case of wide character literal with ESC or [ encoding
+
+               if (Source (Scan_Ptr) = ESC
+                     and then
+                    Wide_Character_Encoding_Method in WC_ESC_Encoding_Method)
+                 or else
+                   (Source (Scan_Ptr) in Upper_Half_Character
+                     and then
+                    Upper_Half_Encoding)
+                 or else
+                   (Source (Scan_Ptr) = '['
+                     and then
+                    Source (Scan_Ptr + 1) = '"')
+               then
+                  Scan_Wide (Source, Scan_Ptr, Code, Err);
+                  Accumulate_Checksum (Code);
+
+                  if Err then
+                     Error_Illegal_Wide_Character;
+                  end if;
+
+                  if Source (Scan_Ptr) /= ''' then
+                     Error_Msg_S ("missing apostrophe");
+                  else
+                     Scan_Ptr := Scan_Ptr + 1;
+                  end if;
+
+               --  If we do not find a closing quote in the expected place then
+               --  assume that we have a misguided attempt at a string literal.
+
+               --  However, if previous token is RANGE, then we return an
+               --  apostrophe instead since this gives better error recovery
+
+               elsif Source (Scan_Ptr + 1) /= ''' then
+
+                  if Prev_Token = Tok_Range then
+                     Token := Tok_Apostrophe;
+                     return;
+
+                  else
+                     Scan_Ptr := Scan_Ptr - 1;
+                     Error_Msg_S
+                       ("strings are delimited by double quote character");
+                     Scn.Slit;
+                     return;
+                  end if;
+
+               --  Otherwise we have a (non-wide) character literal
+
+               else
+                  Accumulate_Checksum (Source (Scan_Ptr));
+
+                  if Source (Scan_Ptr) not in Graphic_Character then
+                     if Source (Scan_Ptr) in Upper_Half_Character then
+                        if Ada_83 then
+                           Error_Illegal_Character;
+                        end if;
+
+                     else
+                        Error_Illegal_Character;
+                     end if;
+                  end if;
+
+                  Code := Get_Char_Code (Source (Scan_Ptr));
+                  Scan_Ptr := Scan_Ptr + 2;
+               end if;
+
+               --  Fall through here with Scan_Ptr updated past the closing
+               --  quote, and Code set to the Char_Code value for the literal
+
+               Accumulate_Checksum (''');
+               Token := Tok_Char_Literal;
+               Token_Node := New_Node (N_Character_Literal, Token_Ptr);
+               Set_Char_Literal_Value (Token_Node, Code);
+               Set_Character_Literal_Name (Code);
+               Token_Name := Name_Find;
+               Set_Chars (Token_Node, Token_Name);
+               return;
+            end if;
+         end Char_Literal_Case;
+
+         --  Right parenthesis
+
+         when ')' =>
+            Accumulate_Checksum (')');
+            Scan_Ptr := Scan_Ptr + 1;
+            Token := Tok_Right_Paren;
+            if Style_Check then Style.Check_Right_Paren; end if;
+            return;
+
+         --  Right bracket or right brace, treated as right paren
+
+         when ']' | '}' =>
+            Error_Msg_S ("illegal character, replaced by "")""");
+            Scan_Ptr := Scan_Ptr + 1;
+            Token := Tok_Right_Paren;
+            return;
+
+         --  Slash (can be division operator or first character of not equal)
+
+         when '/' =>
+            Accumulate_Checksum ('/');
+
+            if Double_Char_Token ('=') then
+               Token := Tok_Not_Equal;
+               return;
+            else
+               Scan_Ptr := Scan_Ptr + 1;
+               Token := Tok_Slash;
+               return;
+            end if;
+
+         --  Semicolon
+
+         when ';' =>
+            Accumulate_Checksum (';');
+            Scan_Ptr := Scan_Ptr + 1;
+            Token := Tok_Semicolon;
+            if Style_Check then Style.Check_Semicolon; end if;
+            return;
+
+         --  Vertical bar
+
+         when '|' => Vertical_Bar_Case : begin
+            Accumulate_Checksum ('|');
+
+            --  Special check for || to give nice message
+
+            if Source (Scan_Ptr + 1) = '|' then
+               Error_Msg_S ("""||"" should be `OR ELSE`");
+               Scan_Ptr := Scan_Ptr + 2;
+               Token := Tok_Or;
+               return;
+
+            else
+               Scan_Ptr := Scan_Ptr + 1;
+               Token := Tok_Vertical_Bar;
+               if Style_Check then Style.Check_Vertical_Bar; end if;
+               return;
+            end if;
+         end Vertical_Bar_Case;
+
+         --  Exclamation, replacement character for vertical bar
+
+         when '!' => Exclamation_Case : begin
+            Accumulate_Checksum ('!');
+
+            if Source (Scan_Ptr + 1) = '=' then
+               Error_Msg_S ("'!= should be /=");
+               Scan_Ptr := Scan_Ptr + 2;
+               Token := Tok_Not_Equal;
+               return;
+
+            else
+               Scan_Ptr := Scan_Ptr + 1;
+               Token := Tok_Vertical_Bar;
+               return;
+            end if;
+
+         end Exclamation_Case;
+
+         --  Plus
+
+         when '+' => Plus_Case : begin
+            Accumulate_Checksum ('+');
+            Scan_Ptr := Scan_Ptr + 1;
+            Token := Tok_Plus;
+            return;
+         end Plus_Case;
+
+         --  Digits starting a numeric literal
+
+         when '0' .. '9' =>
+            Nlit;
+
+            if Identifier_Char (Source (Scan_Ptr)) then
+               Error_Msg_S
+                 ("delimiter required between literal and identifier");
+            end if;
+
+            return;
+
+         --  Lower case letters
+
+         when 'a' .. 'z' =>
+            Name_Len := 1;
+            Name_Buffer (1) := Source (Scan_Ptr);
+            Accumulate_Checksum (Name_Buffer (1));
+            Scan_Ptr := Scan_Ptr + 1;
+            goto Scan_Identifier;
+
+         --  Upper case letters
+
+         when 'A' .. 'Z' =>
+            Name_Len := 1;
+            Name_Buffer (1) :=
+              Character'Val (Character'Pos (Source (Scan_Ptr)) + 32);
+            Accumulate_Checksum (Name_Buffer (1));
+            Scan_Ptr := Scan_Ptr + 1;
+            goto Scan_Identifier;
+
+         --  Underline character
+
+         when '_' =>
+            Error_Msg_S ("identifier cannot start with underline");
+            Name_Len := 1;
+            Name_Buffer (1) := '_';
+            Scan_Ptr := Scan_Ptr + 1;
+            goto Scan_Identifier;
+
+         --  Space (not possible, because we scanned past blanks)
+
+         when ' ' =>
+            raise Program_Error;
+
+         --  Characters in top half of ASCII 8-bit chart
+
+         when Upper_Half_Character =>
+
+            --  Wide character case. Note that Scan_Identifier will issue
+            --  an appropriate message if wide characters are not allowed
+            --  in identifiers.
+
+            if Upper_Half_Encoding then
+               Name_Len := 0;
+               goto Scan_Identifier;
+
+            --  Otherwise we have OK Latin-1 character
+
+            else
+               --  Upper half characters may possibly be identifier letters
+               --  but can never be digits, so Identifier_Character can be
+               --  used to test for a valid start of identifier character.
+
+               if Identifier_Char (Source (Scan_Ptr)) then
+                  Name_Len := 0;
+                  goto Scan_Identifier;
+               else
+                  Error_Illegal_Character;
+               end if;
+            end if;
+
+         when ESC =>
+
+            --  ESC character, possible start of identifier if wide characters
+            --  using ESC encoding are allowed in identifiers, which we can
+            --  tell by looking at the Identifier_Char flag for ESC, which is
+            --  only true if these conditions are met.
+
+            if Identifier_Char (ESC) then
+               Name_Len := 0;
+               goto Scan_Identifier;
+            else
+               Error_Illegal_Wide_Character;
+            end if;
+
+         --  Invalid control characters
+
+         when NUL | SOH | STX | ETX | EOT | ENQ | ACK | BEL | BS  | SO  |
+              SI  | DLE | DC1 | DC2 | DC3 | DC4 | NAK | SYN | ETB | CAN |
+              EM  | FS  | GS  | RS  | US  | DEL
+         =>
+            Error_Illegal_Character;
+
+         --  Invalid graphic characters
+
+         when '#' | '$' | '?' | '@' | '`' | '\' | '^' | '~' =>
+            Error_Illegal_Character;
+
+         --  End switch on non-blank character
+
+         end case;
+
+      --  End loop past format effectors. The exit from this loop is by
+      --  executing a return statement following completion of token scan
+      --  (control never falls out of this loop to the code which follows)
+
+      end loop;
+
+      --  Identifier scanning routine. On entry, some initial characters
+      --  of the identifier may have already been stored in Name_Buffer.
+      --  If so, Name_Len has the number of characters stored. otherwise
+      --  Name_Len is set to zero on entry.
+
+      <<Scan_Identifier>>
+
+         --  This loop scans as fast as possible past lower half letters
+         --  and digits, which we expect to be the most common characters.
+
+         loop
+            if Source (Scan_Ptr) in 'a' .. 'z'
+              or else Source (Scan_Ptr) in '0' .. '9'
+            then
+               Name_Buffer (Name_Len + 1) := Source (Scan_Ptr);
+               Accumulate_Checksum (Source (Scan_Ptr));
+
+            elsif Source (Scan_Ptr) in 'A' .. 'Z' then
+               Name_Buffer (Name_Len + 1) :=
+                 Character'Val (Character'Pos (Source (Scan_Ptr)) + 32);
+               Accumulate_Checksum (Name_Buffer (Name_Len + 1));
+            else
+               exit;
+            end if;
+
+            --  Open out the loop a couple of times for speed
+
+            if Source (Scan_Ptr + 1) in 'a' .. 'z'
+              or else Source (Scan_Ptr + 1) in '0' .. '9'
+            then
+               Name_Buffer (Name_Len + 2) := Source (Scan_Ptr + 1);
+               Accumulate_Checksum (Source (Scan_Ptr + 1));
+
+            elsif Source (Scan_Ptr + 1) in 'A' .. 'Z' then
+               Name_Buffer (Name_Len + 2) :=
+                 Character'Val (Character'Pos (Source (Scan_Ptr + 1)) + 32);
+               Accumulate_Checksum (Name_Buffer (Name_Len + 2));
+
+            else
+               Scan_Ptr := Scan_Ptr + 1;
+               Name_Len := Name_Len + 1;
+               exit;
+            end if;
+
+            if Source (Scan_Ptr + 2) in 'a' .. 'z'
+              or else Source (Scan_Ptr + 2) in '0' .. '9'
+            then
+               Name_Buffer (Name_Len + 3) := Source (Scan_Ptr + 2);
+               Accumulate_Checksum (Source (Scan_Ptr + 2));
+
+            elsif Source (Scan_Ptr + 2) in 'A' .. 'Z' then
+               Name_Buffer (Name_Len + 3) :=
+                 Character'Val (Character'Pos (Source (Scan_Ptr + 2)) + 32);
+               Accumulate_Checksum (Name_Buffer (Name_Len + 3));
+            else
+               Scan_Ptr := Scan_Ptr + 2;
+               Name_Len := Name_Len + 2;
+               exit;
+            end if;
+
+            if Source (Scan_Ptr + 3) in 'a' .. 'z'
+              or else Source (Scan_Ptr + 3) in '0' .. '9'
+            then
+               Name_Buffer (Name_Len + 4) := Source (Scan_Ptr + 3);
+               Accumulate_Checksum (Source (Scan_Ptr + 3));
+
+            elsif Source (Scan_Ptr + 3) in 'A' .. 'Z' then
+               Name_Buffer (Name_Len + 4) :=
+                 Character'Val (Character'Pos (Source (Scan_Ptr + 3)) + 32);
+               Accumulate_Checksum (Name_Buffer (Name_Len + 4));
+
+            else
+               Scan_Ptr := Scan_Ptr + 3;
+               Name_Len := Name_Len + 3;
+               exit;
+            end if;
+
+            Scan_Ptr := Scan_Ptr + 4;
+            Name_Len := Name_Len + 4;
+         end loop;
+
+         --  If we fall through, then we have encountered either an underline
+         --  character, or an extended identifier character (i.e. one from the
+         --  upper half), or a wide character, or an identifier terminator.
+         --  The initial test speeds us up in the most common case where we
+         --  have an identifier terminator. Note that ESC is an identifier
+         --  character only if a wide character encoding method that uses
+         --  ESC encoding is active, so if we find an ESC character we know
+         --  that we have a wide character.
+
+         if Identifier_Char (Source (Scan_Ptr)) then
+
+            --  Case of underline, check for error cases of double underline,
+            --  and for a trailing underline character
+
+            if Source (Scan_Ptr) = '_' then
+               Accumulate_Checksum ('_');
+               Name_Len := Name_Len + 1;
+               Name_Buffer (Name_Len) := '_';
+
+               if Identifier_Char (Source (Scan_Ptr + 1)) then
+                  Scan_Ptr := Scan_Ptr + 1;
+
+                  if Source (Scan_Ptr) = '_' then
+                     Error_No_Double_Underline;
+                  end if;
+
+               else
+                  Error_Msg_S ("identifier cannot end with underline");
+                  Scan_Ptr := Scan_Ptr + 1;
+               end if;
+
+               goto Scan_Identifier;
+
+            --  Upper half character
+
+            elsif Source (Scan_Ptr) in Upper_Half_Character
+              and then not Upper_Half_Encoding
+            then
+               Accumulate_Checksum (Source (Scan_Ptr));
+               Store_Encoded_Character
+                 (Get_Char_Code (Fold_Lower (Source (Scan_Ptr))));
+               Scan_Ptr := Scan_Ptr + 1;
+               goto Scan_Identifier;
+
+            --  Left bracket not followed by a quote terminates an identifier.
+            --  This is an error, but we don't want to give a junk error msg
+            --  about wide characters in this case!
+
+            elsif Source (Scan_Ptr) = '['
+              and then Source (Scan_Ptr + 1) /= '"'
+            then
+               null;
+
+            --  We know we have a wide character encoding here (the current
+            --  character is either ESC, left bracket, or an upper half
+            --  character depending on the encoding method).
+
+            else
+               --  Scan out the wide character and insert the appropriate
+               --  encoding into the name table entry for the identifier.
+
+               declare
+                  Sptr : constant Source_Ptr := Scan_Ptr;
+                  Code : Char_Code;
+                  Err  : Boolean;
+
+               begin
+                  Scan_Wide (Source, Scan_Ptr, Code, Err);
+                  Accumulate_Checksum (Code);
+
+                  if Err then
+                     Error_Illegal_Wide_Character;
+                  else
+                     Store_Encoded_Character (Code);
+                  end if;
+
+                  --  Make sure we are allowing wide characters in identifiers.
+                  --  Note that we allow wide character notation for an OK
+                  --  identifier character. This in particular allows bracket
+                  --  or other notation to be used for upper half letters.
+
+                  if Identifier_Character_Set /= 'w'
+                    and then
+                      (not In_Character_Range (Code)
+                         or else
+                       not Identifier_Char (Get_Character (Code)))
+                  then
+                     Error_Msg
+                       ("wide character not allowed in identifier", Sptr);
+                  end if;
+               end;
+
+               goto Scan_Identifier;
+            end if;
+         end if;
+
+         --  Scan of identifier is complete. The identifier is stored in
+         --  Name_Buffer, and Scan_Ptr points past the last character.
+
+         Token_Name := Name_Find;
+
+         --  Here is where we check if it was a keyword
+
+         if Get_Name_Table_Byte (Token_Name) /= 0
+           and then (Ada_95 or else Token_Name not in Ada_95_Reserved_Words)
+         then
+            Token := Token_Type'Val (Get_Name_Table_Byte (Token_Name));
+
+            --  Deal with possible style check for non-lower case keyword,
+            --  but we don't treat ACCESS, DELTA, DIGITS, RANGE as keywords
+            --  for this purpose if they appear as attribute designators.
+            --  Actually we only check the first character for speed.
+
+            if Style_Check
+              and then Source (Token_Ptr) <= 'Z'
+              and then (Prev_Token /= Tok_Apostrophe
+                          or else
+                            (Token /= Tok_Access
+                               and then Token /= Tok_Delta
+                               and then Token /= Tok_Digits
+                               and then Token /= Tok_Range))
+            then
+               Style.Non_Lower_Case_Keyword;
+            end if;
+
+            --  We must reset Token_Name since this is not an identifier
+            --  and if we leave Token_Name set, the parser gets confused
+            --  because it thinks it is dealing with an identifier instead
+            --  of the corresponding keyword.
+
+            Token_Name := No_Name;
+            return;
+
+         --  It is an identifier after all
+
+         else
+            Token_Node := New_Node (N_Identifier, Token_Ptr);
+            Set_Chars (Token_Node, Token_Name);
+            Token := Tok_Identifier;
+            return;
+         end if;
+   end Scan;
+
+   ---------------------
+   -- Scan_First_Char --
+   ---------------------
+
+   function Scan_First_Char return Source_Ptr is
+      Ptr : Source_Ptr := Current_Line_Start;
+
+   begin
+      loop
+         if Source (Ptr) = ' ' then
+            Ptr := Ptr + 1;
+
+         elsif Source (Ptr) = HT then
+            if Style_Check then Style.Check_HT; end if;
+            Ptr := Ptr + 1;
+
+         else
+            return Ptr;
+         end if;
+      end loop;
+   end Scan_First_Char;
+
+   ------------------------------
+   -- Scan_Reserved_Identifier --
+   ------------------------------
+
+   procedure Scan_Reserved_Identifier (Force_Msg : Boolean) is
+      Token_Chars : constant String := Token_Type'Image (Token);
+
+   begin
+      --  We have in Token_Chars the image of the Token name, i.e. Tok_xxx.
+      --  This code extracts the xxx and makes an identifier out of it.
+
+      Name_Len := 0;
+
+      for J in 5 .. Token_Chars'Length loop
+         Name_Len := Name_Len + 1;
+         Name_Buffer (Name_Len) := Fold_Lower (Token_Chars (J));
+      end loop;
+
+      Token_Name := Name_Find;
+
+      if not Used_As_Identifier (Token) or else Force_Msg then
+         Error_Msg_Name_1 := Token_Name;
+         Error_Msg_SC ("reserved word* cannot be used as identifier!");
+         Used_As_Identifier (Token) := True;
+      end if;
+
+      Token := Tok_Identifier;
+      Token_Node := New_Node (N_Identifier, Token_Ptr);
+      Set_Chars (Token_Node, Token_Name);
+   end Scan_Reserved_Identifier;
+
+   ----------------------
+   -- Set_Start_Column --
+   ----------------------
+
+   --  Note: it seems at first glance a little expensive to compute this value
+   --  for every source line (since it is certainly not used for all source
+   --  lines). On the other hand, it doesn't take much more work to skip past
+   --  the initial white space on the line counting the columns than it would
+   --  to scan past the white space using the standard scanning circuits.
+
+   function Set_Start_Column return Column_Number is
+      Start_Column : Column_Number := 0;
+
+   begin
+      --  Outer loop scans past horizontal tab characters
+
+      Tabs_Loop : loop
+
+         --  Inner loop scans past blanks as fast as possible, bumping Scan_Ptr
+         --  past the blanks and adjusting Start_Column to account for them.
+
+         Blanks_Loop : loop
+            if Source (Scan_Ptr) = ' ' then
+               if Source (Scan_Ptr + 1) = ' ' then
+                  if Source (Scan_Ptr + 2) = ' ' then
+                     if Source (Scan_Ptr + 3) = ' ' then
+                        if Source (Scan_Ptr + 4) = ' ' then
+                           if Source (Scan_Ptr + 5) = ' ' then
+                              if Source (Scan_Ptr + 6) = ' ' then
+                                 Scan_Ptr := Scan_Ptr + 7;
+                                 Start_Column := Start_Column + 7;
+                              else
+                                 Scan_Ptr := Scan_Ptr + 6;
+                                 Start_Column := Start_Column + 6;
+                                 exit Blanks_Loop;
+                              end if;
+                           else
+                              Scan_Ptr := Scan_Ptr + 5;
+                              Start_Column := Start_Column + 5;
+                              exit Blanks_Loop;
+                           end if;
+                        else
+                           Scan_Ptr := Scan_Ptr + 4;
+                           Start_Column := Start_Column + 4;
+                           exit Blanks_Loop;
+                        end if;
+                     else
+                        Scan_Ptr := Scan_Ptr + 3;
+                        Start_Column := Start_Column + 3;
+                        exit Blanks_Loop;
+                     end if;
+                  else
+                     Scan_Ptr := Scan_Ptr + 2;
+                     Start_Column := Start_Column + 2;
+                     exit Blanks_Loop;
+                  end if;
+               else
+                  Scan_Ptr := Scan_Ptr + 1;
+                  Start_Column := Start_Column + 1;
+                  exit Blanks_Loop;
+               end if;
+            else
+               exit Blanks_Loop;
+            end if;
+         end loop Blanks_Loop;
+
+         --  Outer loop keeps going only if a horizontal tab follows
+
+         if Source (Scan_Ptr) = HT then
+            if Style_Check then Style.Check_HT; end if;
+            Scan_Ptr := Scan_Ptr + 1;
+            Start_Column := (Start_Column / 8) * 8 + 8;
+         else
+            exit Tabs_Loop;
+         end if;
+
+      end loop Tabs_Loop;
+
+      return Start_Column;
+   end Set_Start_Column;
+
+   ----------
+   -- Slit --
+   ----------
+
+   procedure Slit is separate;
+
+end Scn;
diff --git a/gcc/ada/scn.ads b/gcc/ada/scn.ads
new file mode 100644
index 00000000000..1fc5441f87a
--- /dev/null
+++ b/gcc/ada/scn.ads
@@ -0,0 +1,69 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                                  S C N                                   --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.19 $
+--                                                                          --
+--          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). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  This package contains the lexical analyzer routines. This is used both
+--  for scanning Ada source files and also for scanning Ada project files.
+
+with Casing; use Casing;
+with Types;  use Types;
+
+package Scn is
+
+   procedure Initialize_Scanner
+     (Unit  : Unit_Number_Type;
+      Index : Source_File_Index);
+   --  Initialize lexical scanner for scanning a new file. The caller has
+   --  completed the construction of the Units.Table entry for the specified
+   --  Unit and Index references the corresponding source file. A special
+   --  case is when Unit = No_Unit_Number, and Index corresponds to the
+   --  source index for reading the configuration pragma file.
+
+   procedure Scan;
+   --  Scan scans out the next token, and advances the scan state accordingly
+   --  (see package Scan_State for details). If the scan encounters an illegal
+   --  token, then an error message is issued pointing to the bad character,
+   --  and Scan returns a reasonable substitute token of some kind.
+
+   function Scan_First_Char return Source_Ptr;
+   --  This routine returns the position in Source of the first non-blank
+   --  character on the current line, used for certain error recovery actions.
+
+   procedure Scan_Reserved_Identifier (Force_Msg : Boolean);
+   --  This procedure is called to convert the current token, which the caller
+   --  has checked is for a reserved word, to an equivalent identifier. This is
+   --  of course only used in error situations where the parser can detect that
+   --  a reserved word is being used as an identifier. An appropriate error
+   --  message, pointing to the token, is also issued if either this is the
+   --  first occurrence of misuse of this identifier, or if Force_Msg is True.
+
+   function Determine_Token_Casing return Casing_Type;
+   pragma Inline (Determine_Token_Casing);
+   --  Determines the casing style of the current token, which is
+   --  either a keyword or an identifier. See also package Casing.
+
+end Scn;
diff --git a/gcc/ada/sdefault.ads b/gcc/ada/sdefault.ads
new file mode 100644
index 00000000000..7d4cbc16718
--- /dev/null
+++ b/gcc/ada/sdefault.ads
@@ -0,0 +1,40 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             S D E F A U L T                              --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.8 $                              --
+--                                                                          --
+--          Copyright (C) 1992-1999 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 Sdefault is
+
+   --  This package contains functions that return the default values for
+   --  the include and object file directories, target name, and the default
+   --  library subdirectory (libsubdir) prefix.
+
+   function Include_Dir_Default_Name return String_Ptr;
+   function Object_Dir_Default_Name return String_Ptr;
+   function Target_Name return String_Ptr;
+   function Search_Dir_Prefix return String_Ptr;
+end Sdefault;
diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb
new file mode 100644
index 00000000000..1eb315d481e
--- /dev/null
+++ b/gcc/ada/sem.adb
@@ -0,0 +1,1184 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                                  S E M                                   --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.290 $
+--                                                                          --
+--          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 Debug;    use Debug;
+with Debug_A;  use Debug_A;
+with Einfo;    use Einfo;
+with Errout;   use Errout;
+with Expander; use Expander;
+with Fname;    use Fname;
+with HLO;      use HLO;
+with Lib;      use Lib;
+with Lib.Load; use Lib.Load;
+with Nlists;   use Nlists;
+with Opt;      use Opt;
+with Sem_Attr; use Sem_Attr;
+with Sem_Ch2;  use Sem_Ch2;
+with Sem_Ch3;  use Sem_Ch3;
+with Sem_Ch4;  use Sem_Ch4;
+with Sem_Ch5;  use Sem_Ch5;
+with Sem_Ch6;  use Sem_Ch6;
+with Sem_Ch7;  use Sem_Ch7;
+with Sem_Ch8;  use Sem_Ch8;
+with Sem_Ch9;  use Sem_Ch9;
+with Sem_Ch10; use Sem_Ch10;
+with Sem_Ch11; use Sem_Ch11;
+with Sem_Ch12; use Sem_Ch12;
+with Sem_Ch13; use Sem_Ch13;
+with Sem_Prag; use Sem_Prag;
+with Sem_Util; use Sem_Util;
+with Sinfo;    use Sinfo;
+with Stand;    use Stand;
+with Uintp;    use Uintp;
+
+pragma Warnings (Off, Sem_Util);
+--  Suppress warnings of unused with for Sem_Util (used only in asserts)
+
+package body Sem is
+
+   Outer_Generic_Scope : Entity_Id := Empty;
+   --  Global reference to the outer scope that is generic. In a non
+   --  generic context, it is empty. At the moment, it is only used
+   --  for avoiding freezing of external references in generics.
+
+   -------------
+   -- Analyze --
+   -------------
+
+   procedure Analyze (N : Node_Id) is
+   begin
+      Debug_A_Entry ("analyzing  ", N);
+
+      --  Immediate return if already analyzed
+
+      if Analyzed (N) then
+         Debug_A_Exit ("analyzing  ", N, "  (done, analyzed already)");
+         return;
+      end if;
+
+      Current_Error_Node := N;
+
+      --  Otherwise processing depends on the node kind
+
+      case Nkind (N) is
+
+         when N_Abort_Statement =>
+            Analyze_Abort_Statement (N);
+
+         when N_Abstract_Subprogram_Declaration =>
+            Analyze_Abstract_Subprogram_Declaration (N);
+
+         when N_Accept_Alternative =>
+            Analyze_Accept_Alternative (N);
+
+         when N_Accept_Statement =>
+            Analyze_Accept_Statement (N);
+
+         when N_Aggregate =>
+            Analyze_Aggregate (N);
+
+         when N_Allocator =>
+            Analyze_Allocator (N);
+
+         when N_And_Then =>
+            Analyze_Short_Circuit (N);
+
+         when N_Assignment_Statement =>
+            Analyze_Assignment (N);
+
+         when N_Asynchronous_Select =>
+            Analyze_Asynchronous_Select (N);
+
+         when N_At_Clause =>
+            Analyze_At_Clause (N);
+
+         when N_Attribute_Reference =>
+            Analyze_Attribute (N);
+
+         when N_Attribute_Definition_Clause   =>
+            Analyze_Attribute_Definition_Clause (N);
+
+         when N_Block_Statement =>
+            Analyze_Block_Statement (N);
+
+         when N_Case_Statement =>
+            Analyze_Case_Statement (N);
+
+         when N_Character_Literal =>
+            Analyze_Character_Literal (N);
+
+         when N_Code_Statement =>
+            Analyze_Code_Statement (N);
+
+         when N_Compilation_Unit =>
+            Analyze_Compilation_Unit (N);
+
+         when N_Component_Declaration =>
+            Analyze_Component_Declaration (N);
+
+         when N_Conditional_Expression =>
+            Analyze_Conditional_Expression (N);
+
+         when N_Conditional_Entry_Call =>
+            Analyze_Conditional_Entry_Call (N);
+
+         when N_Delay_Alternative =>
+            Analyze_Delay_Alternative (N);
+
+         when N_Delay_Relative_Statement =>
+            Analyze_Delay_Relative (N);
+
+         when N_Delay_Until_Statement =>
+            Analyze_Delay_Until (N);
+
+         when N_Entry_Body =>
+            Analyze_Entry_Body (N);
+
+         when N_Entry_Body_Formal_Part =>
+            Analyze_Entry_Body_Formal_Part (N);
+
+         when N_Entry_Call_Alternative =>
+            Analyze_Entry_Call_Alternative (N);
+
+         when N_Entry_Declaration =>
+            Analyze_Entry_Declaration (N);
+
+         when N_Entry_Index_Specification     =>
+            Analyze_Entry_Index_Specification (N);
+
+         when N_Enumeration_Representation_Clause =>
+            Analyze_Enumeration_Representation_Clause (N);
+
+         when N_Exception_Declaration =>
+            Analyze_Exception_Declaration (N);
+
+         when N_Exception_Renaming_Declaration =>
+            Analyze_Exception_Renaming (N);
+
+         when N_Exit_Statement =>
+            Analyze_Exit_Statement (N);
+
+         when N_Expanded_Name =>
+            Analyze_Expanded_Name (N);
+
+         when N_Explicit_Dereference =>
+            Analyze_Explicit_Dereference (N);
+
+         when N_Extension_Aggregate =>
+            Analyze_Aggregate (N);
+
+         when N_Formal_Object_Declaration =>
+            Analyze_Formal_Object_Declaration (N);
+
+         when N_Formal_Package_Declaration =>
+            Analyze_Formal_Package (N);
+
+         when N_Formal_Subprogram_Declaration =>
+            Analyze_Formal_Subprogram (N);
+
+         when N_Formal_Type_Declaration =>
+            Analyze_Formal_Type_Declaration (N);
+
+         when N_Free_Statement =>
+            Analyze_Free_Statement (N);
+
+         when N_Freeze_Entity =>
+            null;  -- no semantic processing required
+
+         when N_Full_Type_Declaration =>
+            Analyze_Type_Declaration (N);
+
+         when N_Function_Call =>
+            Analyze_Function_Call (N);
+
+         when N_Function_Instantiation =>
+            Analyze_Function_Instantiation (N);
+
+         when N_Generic_Function_Renaming_Declaration =>
+            Analyze_Generic_Function_Renaming (N);
+
+         when N_Generic_Package_Declaration =>
+            Analyze_Generic_Package_Declaration (N);
+
+         when N_Generic_Package_Renaming_Declaration =>
+            Analyze_Generic_Package_Renaming (N);
+
+         when N_Generic_Procedure_Renaming_Declaration =>
+            Analyze_Generic_Procedure_Renaming (N);
+
+         when N_Generic_Subprogram_Declaration =>
+            Analyze_Generic_Subprogram_Declaration (N);
+
+         when N_Goto_Statement =>
+            Analyze_Goto_Statement (N);
+
+         when N_Handled_Sequence_Of_Statements =>
+            Analyze_Handled_Statements (N);
+
+         when N_Identifier =>
+            Analyze_Identifier (N);
+
+         when N_If_Statement =>
+            Analyze_If_Statement (N);
+
+         when N_Implicit_Label_Declaration =>
+            Analyze_Implicit_Label_Declaration (N);
+
+         when N_In =>
+            Analyze_Membership_Op (N);
+
+         when N_Incomplete_Type_Declaration =>
+            Analyze_Incomplete_Type_Decl (N);
+
+         when N_Indexed_Component =>
+            Analyze_Indexed_Component_Form (N);
+
+         when N_Integer_Literal =>
+            Analyze_Integer_Literal (N);
+
+         when N_Itype_Reference =>
+            Analyze_Itype_Reference (N);
+
+         when N_Label =>
+            Analyze_Label (N);
+
+         when N_Loop_Statement =>
+            Analyze_Loop_Statement (N);
+
+         when N_Not_In =>
+            Analyze_Membership_Op (N);
+
+         when N_Null =>
+            Analyze_Null (N);
+
+         when N_Null_Statement =>
+            Analyze_Null_Statement (N);
+
+         when N_Number_Declaration =>
+            Analyze_Number_Declaration (N);
+
+         when N_Object_Declaration =>
+            Analyze_Object_Declaration (N);
+
+         when N_Object_Renaming_Declaration  =>
+            Analyze_Object_Renaming (N);
+
+         when N_Operator_Symbol =>
+            Analyze_Operator_Symbol (N);
+
+         when N_Op_Abs =>
+            Analyze_Unary_Op (N);
+
+         when N_Op_Add =>
+            Analyze_Arithmetic_Op (N);
+
+         when N_Op_And =>
+            Analyze_Logical_Op (N);
+
+         when N_Op_Concat =>
+            Analyze_Concatenation (N);
+
+         when N_Op_Divide =>
+            Analyze_Arithmetic_Op (N);
+
+         when N_Op_Eq =>
+            Analyze_Equality_Op (N);
+
+         when N_Op_Expon =>
+            Analyze_Arithmetic_Op (N);
+
+         when N_Op_Ge =>
+            Analyze_Comparison_Op (N);
+
+         when N_Op_Gt =>
+            Analyze_Comparison_Op (N);
+
+         when N_Op_Le =>
+            Analyze_Comparison_Op (N);
+
+         when N_Op_Lt =>
+            Analyze_Comparison_Op (N);
+
+         when N_Op_Minus =>
+            Analyze_Unary_Op (N);
+
+         when N_Op_Mod =>
+            Analyze_Arithmetic_Op (N);
+
+         when N_Op_Multiply =>
+            Analyze_Arithmetic_Op (N);
+
+         when N_Op_Ne =>
+            Analyze_Equality_Op (N);
+
+         when N_Op_Not =>
+            Analyze_Negation (N);
+
+         when N_Op_Or =>
+            Analyze_Logical_Op (N);
+
+         when N_Op_Plus =>
+            Analyze_Unary_Op (N);
+
+         when N_Op_Rem =>
+            Analyze_Arithmetic_Op (N);
+
+         when N_Op_Rotate_Left =>
+            Analyze_Arithmetic_Op (N);
+
+         when N_Op_Rotate_Right =>
+            Analyze_Arithmetic_Op (N);
+
+         when N_Op_Shift_Left =>
+            Analyze_Arithmetic_Op (N);
+
+         when N_Op_Shift_Right =>
+            Analyze_Arithmetic_Op (N);
+
+         when N_Op_Shift_Right_Arithmetic =>
+            Analyze_Arithmetic_Op (N);
+
+         when N_Op_Subtract =>
+            Analyze_Arithmetic_Op (N);
+
+         when N_Op_Xor =>
+            Analyze_Logical_Op (N);
+
+         when N_Or_Else =>
+            Analyze_Short_Circuit (N);
+
+         when N_Others_Choice =>
+            Analyze_Others_Choice (N);
+
+         when N_Package_Body =>
+            Analyze_Package_Body (N);
+
+         when N_Package_Body_Stub =>
+            Analyze_Package_Body_Stub (N);
+
+         when N_Package_Declaration =>
+            Analyze_Package_Declaration (N);
+
+         when N_Package_Instantiation =>
+            Analyze_Package_Instantiation (N);
+
+         when N_Package_Renaming_Declaration =>
+            Analyze_Package_Renaming (N);
+
+         when N_Package_Specification =>
+            Analyze_Package_Specification (N);
+
+         when N_Parameter_Association =>
+            Analyze_Parameter_Association (N);
+
+         when N_Pragma =>
+            Analyze_Pragma (N);
+
+         when N_Private_Extension_Declaration =>
+            Analyze_Private_Extension_Declaration (N);
+
+         when N_Private_Type_Declaration =>
+            Analyze_Private_Type_Declaration (N);
+
+         when N_Procedure_Call_Statement =>
+            Analyze_Procedure_Call (N);
+
+         when N_Procedure_Instantiation =>
+            Analyze_Procedure_Instantiation (N);
+
+         when N_Protected_Body =>
+            Analyze_Protected_Body (N);
+
+         when N_Protected_Body_Stub =>
+            Analyze_Protected_Body_Stub (N);
+
+         when N_Protected_Definition =>
+            Analyze_Protected_Definition (N);
+
+         when N_Protected_Type_Declaration =>
+            Analyze_Protected_Type (N);
+
+         when N_Qualified_Expression =>
+            Analyze_Qualified_Expression (N);
+
+         when N_Raise_Statement =>
+            Analyze_Raise_Statement (N);
+
+         when N_Raise_xxx_Error =>
+            Analyze_Raise_xxx_Error (N);
+
+         when N_Range =>
+            Analyze_Range (N);
+
+         when N_Range_Constraint =>
+            Analyze_Range (Range_Expression (N));
+
+         when N_Real_Literal =>
+            Analyze_Real_Literal (N);
+
+         when N_Record_Representation_Clause =>
+            Analyze_Record_Representation_Clause (N);
+
+         when N_Reference =>
+            Analyze_Reference (N);
+
+         when N_Requeue_Statement =>
+            Analyze_Requeue (N);
+
+         when N_Return_Statement =>
+            Analyze_Return_Statement (N);
+
+         when N_Selected_Component =>
+            Find_Selected_Component (N);
+            --  ??? why not Analyze_Selected_Component, needs comments
+
+         when N_Selective_Accept =>
+            Analyze_Selective_Accept (N);
+
+         when N_Single_Protected_Declaration =>
+            Analyze_Single_Protected (N);
+
+         when N_Single_Task_Declaration =>
+            Analyze_Single_Task (N);
+
+         when N_Slice =>
+            Analyze_Slice (N);
+
+         when N_String_Literal =>
+            Analyze_String_Literal (N);
+
+         when N_Subprogram_Body =>
+            Analyze_Subprogram_Body (N);
+
+         when N_Subprogram_Body_Stub =>
+            Analyze_Subprogram_Body_Stub (N);
+
+         when N_Subprogram_Declaration =>
+            Analyze_Subprogram_Declaration (N);
+
+         when N_Subprogram_Info =>
+            Analyze_Subprogram_Info (N);
+
+         when N_Subprogram_Renaming_Declaration =>
+            Analyze_Subprogram_Renaming (N);
+
+         when N_Subtype_Declaration =>
+            Analyze_Subtype_Declaration (N);
+
+         when N_Subtype_Indication =>
+            Analyze_Subtype_Indication (N);
+
+         when N_Subunit =>
+            Analyze_Subunit (N);
+
+         when N_Task_Body =>
+            Analyze_Task_Body (N);
+
+         when N_Task_Body_Stub =>
+            Analyze_Task_Body_Stub (N);
+
+         when N_Task_Definition =>
+            Analyze_Task_Definition (N);
+
+         when N_Task_Type_Declaration =>
+            Analyze_Task_Type (N);
+
+         when N_Terminate_Alternative =>
+            Analyze_Terminate_Alternative (N);
+
+         when N_Timed_Entry_Call =>
+            Analyze_Timed_Entry_Call (N);
+
+         when N_Triggering_Alternative =>
+            Analyze_Triggering_Alternative (N);
+
+         when N_Type_Conversion =>
+            Analyze_Type_Conversion (N);
+
+         when N_Unchecked_Expression =>
+            Analyze_Unchecked_Expression (N);
+
+         when N_Unchecked_Type_Conversion =>
+            Analyze_Unchecked_Type_Conversion (N);
+
+         when N_Use_Package_Clause =>
+            Analyze_Use_Package (N);
+
+         when N_Use_Type_Clause =>
+            Analyze_Use_Type (N);
+
+         when N_Validate_Unchecked_Conversion =>
+            null;
+
+         when N_Variant_Part =>
+            Analyze_Variant_Part (N);
+
+         when N_With_Clause =>
+            Analyze_With_Clause (N);
+
+         when N_With_Type_Clause =>
+            Analyze_With_Type_Clause (N);
+
+         --  A call to analyze the Empty node is an error, but most likely
+         --  it is an error caused by an attempt to analyze a malformed
+         --  piece of tree caused by some other error, so if there have
+         --  been any other errors, we just ignore it, otherwise it is
+         --  a real internal error which we complain about.
+
+         when N_Empty =>
+            pragma Assert (Errors_Detected /= 0);
+            null;
+
+         --  A call to analyze the error node is simply ignored, to avoid
+         --  causing cascaded errors (happens of course only in error cases)
+
+         when N_Error =>
+            null;
+
+         --  For the remaining node types, we generate compiler abort, because
+         --  these nodes are always analyzed within the Sem_Chn routines and
+         --  there should never be a case of making a call to the main Analyze
+         --  routine for these node kinds. For example, an N_Access_Definition
+         --  node appears only in the context of a type declaration, and is
+         --  processed by the analyze routine for type declarations.
+
+         when
+           N_Abortable_Part                         |
+           N_Access_Definition                      |
+           N_Access_Function_Definition             |
+           N_Access_Procedure_Definition            |
+           N_Access_To_Object_Definition            |
+           N_Case_Statement_Alternative             |
+           N_Compilation_Unit_Aux                   |
+           N_Component_Association                  |
+           N_Component_Clause                       |
+           N_Component_List                         |
+           N_Constrained_Array_Definition           |
+           N_Decimal_Fixed_Point_Definition         |
+           N_Defining_Character_Literal             |
+           N_Defining_Identifier                    |
+           N_Defining_Operator_Symbol               |
+           N_Defining_Program_Unit_Name             |
+           N_Delta_Constraint                       |
+           N_Derived_Type_Definition                |
+           N_Designator                             |
+           N_Digits_Constraint                      |
+           N_Discriminant_Association               |
+           N_Discriminant_Specification             |
+           N_Elsif_Part                             |
+           N_Entry_Call_Statement                   |
+           N_Enumeration_Type_Definition            |
+           N_Exception_Handler                      |
+           N_Floating_Point_Definition              |
+           N_Formal_Decimal_Fixed_Point_Definition  |
+           N_Formal_Derived_Type_Definition         |
+           N_Formal_Discrete_Type_Definition        |
+           N_Formal_Floating_Point_Definition       |
+           N_Formal_Modular_Type_Definition         |
+           N_Formal_Ordinary_Fixed_Point_Definition |
+           N_Formal_Private_Type_Definition         |
+           N_Formal_Signed_Integer_Type_Definition  |
+           N_Function_Specification                 |
+           N_Generic_Association                    |
+           N_Index_Or_Discriminant_Constraint       |
+           N_Iteration_Scheme                       |
+           N_Loop_Parameter_Specification           |
+           N_Mod_Clause                             |
+           N_Modular_Type_Definition                |
+           N_Ordinary_Fixed_Point_Definition        |
+           N_Parameter_Specification                |
+           N_Pragma_Argument_Association            |
+           N_Procedure_Specification                |
+           N_Real_Range_Specification               |
+           N_Record_Definition                      |
+           N_Signed_Integer_Type_Definition         |
+           N_Unconstrained_Array_Definition         |
+           N_Unused_At_Start                        |
+           N_Unused_At_End                          |
+           N_Variant                                =>
+
+            raise Program_Error;
+      end case;
+
+      Debug_A_Exit ("analyzing  ", N, "  (done)");
+
+      --  Now that we have analyzed the node, we call the expander to
+      --  perform possible expansion. This is done only for nodes that
+      --  are not subexpressions, because in the case of subexpressions,
+      --  we don't have the type yet, and the expander will need to know
+      --  the type before it can do its job. For subexpression nodes, the
+      --  call to the expander happens in the Sem_Res.Resolve.
+
+      --  The Analyzed flag is also set at this point for non-subexpression
+      --  nodes (in the case of subexpression nodes, we can't set the flag
+      --  yet, since resolution and expansion have not yet been completed)
+
+      if Nkind (N) not in N_Subexpr then
+         Expand (N);
+      end if;
+
+   end Analyze;
+
+   --  Version with check(s) suppressed
+
+   procedure Analyze (N : Node_Id; Suppress : Check_Id) is
+   begin
+      if Suppress = All_Checks then
+         declare
+            Svg : constant Suppress_Record := Scope_Suppress;
+
+         begin
+            Scope_Suppress := (others => True);
+            Analyze (N);
+            Scope_Suppress := Svg;
+         end;
+
+      else
+         declare
+            Svg : constant Boolean := Get_Scope_Suppress (Suppress);
+
+         begin
+            Set_Scope_Suppress (Suppress, True);
+            Analyze (N);
+            Set_Scope_Suppress (Suppress, Svg);
+         end;
+      end if;
+   end Analyze;
+
+   ------------------
+   -- Analyze_List --
+   ------------------
+
+   procedure Analyze_List (L : List_Id) is
+      Node : Node_Id;
+
+   begin
+      Node := First (L);
+      while Present (Node) loop
+         Analyze (Node);
+         Next (Node);
+      end loop;
+   end Analyze_List;
+
+   --  Version with check(s) suppressed
+
+   procedure Analyze_List (L : List_Id; Suppress : Check_Id) is
+   begin
+      if Suppress = All_Checks then
+         declare
+            Svg : constant Suppress_Record := Scope_Suppress;
+
+         begin
+            Scope_Suppress := (others => True);
+            Analyze_List (L);
+            Scope_Suppress := Svg;
+         end;
+
+      else
+         declare
+            Svg : constant Boolean := Get_Scope_Suppress (Suppress);
+
+         begin
+            Set_Scope_Suppress (Suppress, True);
+            Analyze_List (L);
+            Set_Scope_Suppress (Suppress, Svg);
+         end;
+      end if;
+   end Analyze_List;
+
+   -------------------------
+   -- Enter_Generic_Scope --
+   -------------------------
+
+   procedure Enter_Generic_Scope (S : Entity_Id) is
+   begin
+      if No (Outer_Generic_Scope) then
+         Outer_Generic_Scope := S;
+      end if;
+   end Enter_Generic_Scope;
+
+   ------------------------
+   -- Exit_Generic_Scope --
+   ------------------------
+
+   procedure Exit_Generic_Scope  (S : Entity_Id) is
+   begin
+      if S = Outer_Generic_Scope then
+         Outer_Generic_Scope := Empty;
+      end if;
+   end  Exit_Generic_Scope;
+
+   -----------------------------
+   -- External_Ref_In_Generic --
+   -----------------------------
+
+   function External_Ref_In_Generic (E : Entity_Id) return Boolean is
+   begin
+
+      --  Entity is global if defined outside of current outer_generic_scope:
+      --  Either the entity has a smaller depth that the outer generic, or it
+      --  is in a different compilation unit.
+
+      return Present (Outer_Generic_Scope)
+        and then (Scope_Depth (Scope (E)) < Scope_Depth (Outer_Generic_Scope)
+                   or else not In_Same_Source_Unit (E, Outer_Generic_Scope));
+   end External_Ref_In_Generic;
+
+   ------------------------
+   -- Get_Scope_Suppress --
+   ------------------------
+
+   function Get_Scope_Suppress (C : Check_Id) return Boolean is
+      S : Suppress_Record renames Scope_Suppress;
+
+   begin
+      case C is
+         when Access_Check        => return S.Access_Checks;
+         when Accessibility_Check => return S.Accessibility_Checks;
+         when Discriminant_Check  => return S.Discriminant_Checks;
+         when Division_Check      => return S.Division_Checks;
+         when Elaboration_Check   => return S.Discriminant_Checks;
+         when Index_Check         => return S.Elaboration_Checks;
+         when Length_Check        => return S.Discriminant_Checks;
+         when Overflow_Check      => return S.Overflow_Checks;
+         when Range_Check         => return S.Range_Checks;
+         when Storage_Check       => return S.Storage_Checks;
+         when Tag_Check           => return S.Tag_Checks;
+         when All_Checks =>
+            raise Program_Error;
+      end case;
+   end Get_Scope_Suppress;
+
+   ----------------
+   -- Initialize --
+   ----------------
+
+   procedure Initialize is
+   begin
+      Entity_Suppress.Init;
+      Scope_Stack.Init;
+      Unloaded_Subunits := False;
+   end Initialize;
+
+   ------------------------------
+   -- Insert_After_And_Analyze --
+   ------------------------------
+
+   procedure Insert_After_And_Analyze (N : Node_Id; M : Node_Id) is
+      Node : Node_Id;
+
+   begin
+      if Present (M) then
+
+         --  If we are not at the end of the list, then the easiest
+         --  coding is simply to insert before our successor
+
+         if Present (Next (N)) then
+            Insert_Before_And_Analyze (Next (N), M);
+
+         --  Case of inserting at the end of the list
+
+         else
+            --  Capture the Node_Id of the node to be inserted. This Node_Id
+            --  will still be the same after the insert operation.
+
+            Node := M;
+            Insert_After (N, M);
+
+            --  Now just analyze from the inserted node to the end of
+            --  the new list (note that this properly handles the case
+            --  where any of the analyze calls result in the insertion of
+            --  nodes after the analyzed node, expecting analysis).
+
+            while Present (Node) loop
+               Analyze (Node);
+               Mark_Rewrite_Insertion (Node);
+               Next (Node);
+            end loop;
+         end if;
+      end if;
+
+   end Insert_After_And_Analyze;
+
+   --  Version with check(s) suppressed
+
+   procedure Insert_After_And_Analyze
+     (N : Node_Id; M : Node_Id; Suppress : Check_Id)
+   is
+   begin
+      if Suppress = All_Checks then
+         declare
+            Svg : constant Suppress_Record := Scope_Suppress;
+
+         begin
+            Scope_Suppress := (others => True);
+            Insert_After_And_Analyze (N, M);
+            Scope_Suppress := Svg;
+         end;
+
+      else
+         declare
+            Svg : constant Boolean := Get_Scope_Suppress (Suppress);
+
+         begin
+            Set_Scope_Suppress (Suppress, True);
+            Insert_After_And_Analyze (N, M);
+            Set_Scope_Suppress (Suppress, Svg);
+         end;
+      end if;
+   end Insert_After_And_Analyze;
+
+   -------------------------------
+   -- Insert_Before_And_Analyze --
+   -------------------------------
+
+   procedure Insert_Before_And_Analyze (N : Node_Id; M : Node_Id) is
+      Node : Node_Id;
+
+   begin
+      if Present (M) then
+
+         --  Capture the Node_Id of the first list node to be inserted.
+         --  This will still be the first node after the insert operation,
+         --  since Insert_List_After does not modify the Node_Id values.
+
+         Node := M;
+         Insert_Before (N, M);
+
+         --  The insertion does not change the Id's of any of the nodes in
+         --  the list, and they are still linked, so we can simply loop from
+         --  the original first node until we meet the node before which the
+         --  insertion is occurring. Note that this properly handles the case
+         --  where any of the analyzed nodes insert nodes after themselves,
+         --  expecting them to get analyzed.
+
+         while Node /= N loop
+            Analyze (Node);
+            Mark_Rewrite_Insertion (Node);
+            Next (Node);
+         end loop;
+      end if;
+
+   end Insert_Before_And_Analyze;
+
+   --  Version with check(s) suppressed
+
+   procedure Insert_Before_And_Analyze
+     (N : Node_Id; M : Node_Id; Suppress : Check_Id)
+   is
+   begin
+      if Suppress = All_Checks then
+         declare
+            Svg : constant Suppress_Record := Scope_Suppress;
+
+         begin
+            Scope_Suppress := (others => True);
+            Insert_Before_And_Analyze (N, M);
+            Scope_Suppress := Svg;
+         end;
+
+      else
+         declare
+            Svg : constant Boolean := Get_Scope_Suppress (Suppress);
+
+         begin
+            Set_Scope_Suppress (Suppress, True);
+            Insert_Before_And_Analyze (N, M);
+            Set_Scope_Suppress (Suppress, Svg);
+         end;
+      end if;
+   end Insert_Before_And_Analyze;
+
+   -----------------------------------
+   -- Insert_List_After_And_Analyze --
+   -----------------------------------
+
+   procedure Insert_List_After_And_Analyze (N : Node_Id; L : List_Id) is
+      After : constant Node_Id := Next (N);
+      Node  : Node_Id;
+
+   begin
+      if Is_Non_Empty_List (L) then
+
+         --  Capture the Node_Id of the first list node to be inserted.
+         --  This will still be the first node after the insert operation,
+         --  since Insert_List_After does not modify the Node_Id values.
+
+         Node := First (L);
+         Insert_List_After (N, L);
+
+         --  Now just analyze from the original first node until we get to
+         --  the successor of the original insertion point (which may be
+         --  Empty if the insertion point was at the end of the list). Note
+         --  that this properly handles the case where any of the analyze
+         --  calls result in the insertion of nodes after the analyzed
+         --  node (possibly calling this routine recursively).
+
+         while Node /= After loop
+            Analyze (Node);
+            Mark_Rewrite_Insertion (Node);
+            Next (Node);
+         end loop;
+      end if;
+
+   end Insert_List_After_And_Analyze;
+
+   --  Version with check(s) suppressed
+
+   procedure Insert_List_After_And_Analyze
+     (N : Node_Id; L : List_Id; Suppress : Check_Id)
+   is
+   begin
+      if Suppress = All_Checks then
+         declare
+            Svg : constant Suppress_Record := Scope_Suppress;
+
+         begin
+            Scope_Suppress := (others => True);
+            Insert_List_After_And_Analyze (N, L);
+            Scope_Suppress := Svg;
+         end;
+
+      else
+         declare
+            Svg : constant Boolean := Get_Scope_Suppress (Suppress);
+
+         begin
+            Set_Scope_Suppress (Suppress, True);
+            Insert_List_After_And_Analyze (N, L);
+            Set_Scope_Suppress (Suppress, Svg);
+         end;
+      end if;
+   end Insert_List_After_And_Analyze;
+
+   ------------------------------------
+   -- Insert_List_Before_And_Analyze --
+   ------------------------------------
+
+   procedure Insert_List_Before_And_Analyze (N : Node_Id; L : List_Id) is
+      Node : Node_Id;
+
+   begin
+      if Is_Non_Empty_List (L) then
+
+         --  Capture the Node_Id of the first list node to be inserted.
+         --  This will still be the first node after the insert operation,
+         --  since Insert_List_After does not modify the Node_Id values.
+
+         Node := First (L);
+         Insert_List_Before (N, L);
+
+         --  The insertion does not change the Id's of any of the nodes in
+         --  the list, and they are still linked, so we can simply loop from
+         --  the original first node until we meet the node before which the
+         --  insertion is occurring. Note that this properly handles the case
+         --  where any of the analyzed nodes insert nodes after themselves,
+         --  expecting them to get analyzed.
+
+         while Node /= N loop
+            Analyze (Node);
+            Mark_Rewrite_Insertion (Node);
+            Next (Node);
+         end loop;
+      end if;
+
+   end Insert_List_Before_And_Analyze;
+
+   --  Version with check(s) suppressed
+
+   procedure Insert_List_Before_And_Analyze
+     (N : Node_Id; L : List_Id; Suppress : Check_Id)
+   is
+   begin
+      if Suppress = All_Checks then
+         declare
+            Svg : constant Suppress_Record := Scope_Suppress;
+
+         begin
+            Scope_Suppress := (others => True);
+            Insert_List_Before_And_Analyze (N, L);
+            Scope_Suppress := Svg;
+         end;
+
+      else
+         declare
+            Svg : constant Boolean := Get_Scope_Suppress (Suppress);
+
+         begin
+            Set_Scope_Suppress (Suppress, True);
+            Insert_List_Before_And_Analyze (N, L);
+            Set_Scope_Suppress (Suppress, Svg);
+         end;
+      end if;
+   end Insert_List_Before_And_Analyze;
+
+   ----------
+   -- Lock --
+   ----------
+
+   procedure Lock is
+   begin
+      Entity_Suppress.Locked := True;
+      Scope_Stack.Locked := True;
+      Entity_Suppress.Release;
+      Scope_Stack.Release;
+   end Lock;
+
+   ---------------
+   -- Semantics --
+   ---------------
+
+   procedure Semantics (Comp_Unit : Node_Id) is
+
+      --  The following locations save the corresponding global flags and
+      --  variables so that they can be restored on completion. This is
+      --  needed so that calls to Rtsfind start with the proper default
+      --  values for these variables, and also that such calls do not
+      --  disturb the settings for units being analyzed at a higher level.
+
+      S_Full_Analysis    : constant Boolean          := Full_Analysis;
+      S_In_Default_Expr  : constant Boolean          := In_Default_Expression;
+      S_Inside_A_Generic : constant Boolean          := Inside_A_Generic;
+      S_New_Nodes_OK     : constant Int              := New_Nodes_OK;
+      S_Outer_Gen_Scope  : constant Entity_Id        := Outer_Generic_Scope;
+      S_Sem_Unit         : constant Unit_Number_Type := Current_Sem_Unit;
+
+      Save_Config_Switches : Config_Switches_Type;
+      --  Variable used to save values of config switches while we analyze
+      --  the new unit, to be restored on exit for proper recursive behavior.
+
+      procedure Do_Analyze;
+      --  Procedure to analyze the compilation unit. This is called more
+      --  than once when the high level optimizer is activated.
+
+      procedure Do_Analyze is
+      begin
+         Save_Scope_Stack;
+         New_Scope (Standard_Standard);
+         Scope_Suppress := Suppress_Options;
+         Scope_Stack.Table
+           (Scope_Stack.Last).Component_Alignment_Default := Calign_Default;
+         Scope_Stack.Table
+           (Scope_Stack.Last).Is_Active_Stack_Base := True;
+         Outer_Generic_Scope := Empty;
+
+         --  Now analyze the top level compilation unit node
+
+         Analyze (Comp_Unit);
+
+         --  Check for scope mismatch on exit from compilation
+
+         pragma Assert (Current_Scope = Standard_Standard
+                          or else Comp_Unit = Cunit (Main_Unit));
+
+         --  Then pop entry for Standard, and pop implicit types
+
+         Pop_Scope;
+         Restore_Scope_Stack;
+      end Do_Analyze;
+
+   --  Start of processing for Sem
+
+   begin
+      Compiler_State        := Analyzing;
+      Current_Sem_Unit      := Get_Cunit_Unit_Number (Comp_Unit);
+
+      Expander_Mode_Save_And_Set
+        (Operating_Mode = Generate_Code or Debug_Flag_X);
+
+      Full_Analysis         := True;
+      Inside_A_Generic      := False;
+      In_Default_Expression := False;
+
+      Set_Comes_From_Source_Default (False);
+      Save_Opt_Config_Switches (Save_Config_Switches);
+      Set_Opt_Config_Switches
+        (Is_Internal_File_Name (Unit_File_Name (Current_Sem_Unit)));
+
+      --  Only do analysis of unit that has not already been analyzed
+
+      if not Analyzed (Comp_Unit) then
+         Initialize_Version (Current_Sem_Unit);
+         if HLO_Active then
+            Expander_Mode_Save_And_Set (False);
+            New_Nodes_OK := 1;
+            Do_Analyze;
+            Reset_Analyzed_Flags (Comp_Unit);
+            Expander_Mode_Restore;
+            High_Level_Optimize (Comp_Unit);
+            New_Nodes_OK := 0;
+         end if;
+
+         Do_Analyze;
+      end if;
+
+      --  Save indication of dynamic elaboration checks for ALI file
+
+      Set_Dynamic_Elab (Current_Sem_Unit, Dynamic_Elaboration_Checks);
+
+      --  Restore settings of saved switches to entry values
+
+      Current_Sem_Unit       := S_Sem_Unit;
+      Full_Analysis          := S_Full_Analysis;
+      In_Default_Expression  := S_In_Default_Expr;
+      Inside_A_Generic       := S_Inside_A_Generic;
+      New_Nodes_OK           := S_New_Nodes_OK;
+      Outer_Generic_Scope    := S_Outer_Gen_Scope;
+
+      Restore_Opt_Config_Switches (Save_Config_Switches);
+      Expander_Mode_Restore;
+
+   end Semantics;
+
+   ------------------------
+   -- Set_Scope_Suppress --
+   ------------------------
+
+   procedure Set_Scope_Suppress (C : Check_Id; B : Boolean) is
+      S : Suppress_Record renames Scope_Suppress;
+
+   begin
+      case C is
+         when Access_Check        => S.Access_Checks        := B;
+         when Accessibility_Check => S.Accessibility_Checks := B;
+         when Discriminant_Check  => S.Discriminant_Checks  := B;
+         when Division_Check      => S.Division_Checks      := B;
+         when Elaboration_Check   => S.Discriminant_Checks  := B;
+         when Index_Check         => S.Elaboration_Checks   := B;
+         when Length_Check        => S.Discriminant_Checks  := B;
+         when Overflow_Check      => S.Overflow_Checks      := B;
+         when Range_Check         => S.Range_Checks         := B;
+         when Storage_Check       => S.Storage_Checks       := B;
+         when Tag_Check           => S.Tag_Checks           := B;
+         when All_Checks =>
+            raise Program_Error;
+      end case;
+   end Set_Scope_Suppress;
+
+end Sem;
diff --git a/gcc/ada/sem.ads b/gcc/ada/sem.ads
new file mode 100644
index 00000000000..a88761627fe
--- /dev/null
+++ b/gcc/ada/sem.ads
@@ -0,0 +1,492 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                                  S E M                                   --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.101 $
+--                                                                          --
+--          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). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--------------------------------------
+-- Semantic Analysis: General Model --
+--------------------------------------
+
+--  Semantic processing involves 3 phases which are highly interwined
+--  (ie mutually recursive):
+--
+--    Analysis     implements the bulk of semantic analysis such as
+--                 name analysis and type resolution for declarations,
+--                 instructions and expressions.  The main routine
+--                 driving this process is procedure Analyze given below.
+--                 This analysis phase is really a bottom up pass that is
+--                 achieved during the recursive traversal performed by the
+--                 Analyze_... procedures implemented in the sem_* packages.
+--                 For expressions this phase determines unambiguous types
+--                 and collects sets of possible types where the
+--                 interpretation is potentially ambiguous.
+--
+--    Resolution   is carried out only for expressions to finish type
+--                 resolution that was initiated but not necessarily
+--                 completed during analysis (because of overloading
+--                 ambiguities). Specifically, after completing the bottom
+--                 up pass carried out during analysis for expressions, the
+--                 Resolve routine (see the spec of sem_res for more info)
+--                 is called to perform a top down resolution with
+--                 recursive calls to itself to resolve operands.
+--
+--    Expansion    if we are not generating code this phase is a no-op.
+--                 otherwise this phase expands, ie transforms, original
+--                 declaration, expressions or instructions into simpler
+--                 structures that can be handled by the back-end. This
+--                 phase is also in charge of generating code which is
+--                 implicit in the original source (for instance for
+--                 default initializations, controlled types, etc.)
+--                 There are two separate instances where expansion is
+--                 invoked. For declarations and instructions, expansion is
+--                 invoked just after analysis since no resolution needs
+--                 to be performed. For expressions, expansion is done just
+--                 after resolution. In both cases expansion is done from the
+--                 bottom up just before the end of Analyze for instructions
+--                 and declarations or the call to Resolve for expressions.
+--                 The main routine driving expansion is Expand.
+--                 See the spec of Expander for more details.
+--
+--  To summarize, in normal code generation mode we recursively traverse the
+--  abstract syntax tree top-down performing semantic analysis bottom
+--  up. For instructions and declarations, before the call to the Analyze
+--  routine completes we perform expansion since at that point we have all
+--  semantic information needed. For expression nodes, after the call to
+--  Analysis terminates we invoke the Resolve routine to transmit top-down
+--  the type that was gathered by Analyze which will resolve possible
+--  ambiguities in the expression. Just before the call to Resolve
+--  terminates, the expression can be expanded since all the semantic
+--  information is available at that point.
+--
+--  If we are not generating code then the expansion phase is a no-op.
+--
+--  When generating code there are a number of exceptions to the basic
+--  Analysis-Resolution-Expansion model for expressions. The most prominent
+--  examples are the handling of default expressions and aggregates.
+
+-------------------------------------
+-- Handling of Default Expressions --
+-------------------------------------
+
+--  The default expressions in component declarations and in procedure
+--  specifications (but not the ones in object declarations) are quite
+--  tricky to handle. The problem is that some processing is required
+--  at the point where the expression appears:
+--
+--    visibility analysis (including user defined operators)
+--    freezing of static expressions
+--
+--  but other processing must be deferred until the enclosing entity
+--  (record or procedure specification) is frozen:
+--
+--    freezing of any other types in the expression
+--    expansion
+--
+--  Expansion has to be deferred since you can't generate code for
+--  expressions that refernce types that have not been frozen yet. As an
+--  example, consider the following:
+--
+--      type x is delta 0.5 range -10.0 .. +10.0;
+--      ...
+--      type q is record
+--        xx : x := y * z;
+--      end record;
+--
+--      for x'small use 0.25
+--
+--  The expander is in charge of dealing with fixed-point, and of course
+--  the small declaration, which is not too late, since the declaration of
+--  type q does *not* freeze type x, definitely affects the expanded code.
+--
+--  Generally our model is to combine analysis resolution and expansion, but
+--  this is the one case where this model falls down. Here is how we patch
+--  it up without causing too much distortion to our basic model.
+--
+--  A switch (sede below) is set to indicate that we are in the initial
+--  occurence of a default expression. The analyzer is then called on this
+--  expression with the switch set true. Analysis and resolution proceed
+--  almost as usual, except that Freeze_Expression will not freeze
+--  non-static expressions if this switch is set, and the call to Expand at
+--  the end of resolution is skipped. This also skips the code that normally
+--  sets the Analyzed flag to True). The result is that when we are done the
+--  tree is still marked as unanalyzed, but all types for static expressions
+--  are frozen as required, and all entities of variables have been
+--  recorded.  We then turn off the switch, and later on reanalyze the
+--  expression with the switch off. The effect is that this second analysis
+--  freezes the rest of the types as required, and generates code but
+--  visibility analysis is not repeated since all the entities are marked.
+--
+--  The second analysis (the one that generates code) is in the context
+--  where the code is required. For a record field default, this is in
+--  the initialization procedure for the record and for a subprogram
+--  default parameter, it is at the point the subprogram is frozen.
+
+------------------
+-- Pre-Analysis --
+------------------
+
+--  For certain kind of expressions, such as aggregates, we need to defer
+--  expansion of the aggregate and its inner expressions after the whole
+--  set of expressions appearing inside the aggregate have been analyzed.
+--  Consider, for instance the following example:
+--
+--     (1 .. 100 => new Thing (Function_Call))
+--
+--  The normal Analysis-Resolution-Expansion mechanism where expansion
+--  of the children is performed before expansion of the parent does not
+--  work if the code generated for the children by the expander needs
+--  to be evaluated repeatdly (for instance in the above aggregate
+--  "new Thing (Function_Call)" needs to be called 100 times.)
+--  The reason why this mecanism does not work is that, the expanded code
+--  for the children is typically inserted above the parent and thus
+--  when the father gets expanded no re-evaluation takes place. For instance
+--  in the case of aggregates if "new Thing (Function_Call)" is expanded
+--  before of the aggregate the expanded code will be placed outside
+--  of the aggregate and when expanding the aggregate the loop from 1 to 100
+--  will not surround the expanded code for "new Thing (Function_Call)".
+--
+--  To remedy this situation we introduce a new flag which signals whether
+--  we want a full analysis (ie expansion is enabled) or a pre-analysis
+--  which performs Analysis and Resolution but no expansion.
+--
+--  After the complete pre-analysis of an expression has been carried out
+--  we can transform the expression and then carry out the full
+--  Analyze-Resolve-Expand cycle on the transformed expression top-down
+--  so that the expansion of inner expressions happens inside the newly
+--  generated node for the parent expression.
+--
+--  Note that the difference between processing of default expressions and
+--  pre-analysis of other expressions is that we do carry out freezing in
+--  the latter but not in the former (except for static scalar expressions).
+--  The routine that performs pre-analysis is called Pre_Analyze_And_Resolve
+--  and is in Sem_Res.
+
+with Alloc;
+with Einfo;  use Einfo;
+with Opt;    use Opt;
+with Snames; use Snames;
+with Table;
+with Types;  use Types;
+
+package Sem is
+
+   New_Nodes_OK : Int := 1;
+   --  Temporary flag for use in checking out HLO. Set non-zero if it is
+   --  OK to generate new nodes.
+
+   -----------------------------
+   -- Semantic Analysis Flags --
+   -----------------------------
+
+   Full_Analysis : Boolean := True;
+   --  Switch to indicate whether we are doing a full analysis or a
+   --  pre-analysis. In normal analysis mode (Analysis-Expansion for
+   --  instructions or declarations) or (Analysis-Resolution-Expansion for
+   --  expressions) this flag is set. Note that if we are not generating
+   --  code the expansion phase merely sets the Analyzed flag to True in
+   --  this case. If we are in Pre-Analysis mode (see above) this flag is
+   --  set to False then the expansion phase is skipped.
+   --  When this flag is False the flag Expander_Active is also False
+   --  (the Expander_Activer flag defined in the spec of package Expander
+   --  tells you whether expansion is currently enabled).
+   --  You should really regard this as a read only flag.
+
+   In_Default_Expression : Boolean := False;
+   --  Switch to indicate that we are in a default expression, as described
+   --  above. Note that this must be recursively saved on a Semantics call
+   --  since it is possible for the analysis of an expression to result in
+   --  a recursive call (e.g. to get the entity for System.Address as part
+   --  of the processing of an Address attribute reference).
+   --  When this switch is True then Full_Analysis above must be False.
+   --  You should really regard this as a read only flag.
+
+   In_Inlined_Body : Boolean := False;
+   --  Switch to indicate that we are analyzing and resolving an inlined
+   --  body. Type checking is disabled in this context, because types are
+   --  known to be compatible. This avoids problems with private types whose
+   --  full view is derived from private types.
+
+   Inside_A_Generic : Boolean := False;
+   --  This flag is set if we are processing a generic specification,
+   --  generic definition, or generic body. When this flag is True the
+   --  Expander_Active flag is False to disable any code expansion (see
+   --  package Expander). Only the generic processing can modify the
+   --  status of this flag, any other client should regard it as read-only.
+
+   Unloaded_Subunits : Boolean := False;
+   --  This flag is set True if we have subunits that are not loaded. This
+   --  occurs when the main unit is a subunit, and contains lower level
+   --  subunits that are not loaded. We use this flag to suppress warnings
+   --  about unused variables, since these warnings are unreliable in this
+   --  case. We could perhaps do a more accurate job and retain some of the
+   --  warnings, but it is quite a tricky job. See test 4323-002.
+
+   -----------------
+   -- Scope Stack --
+   -----------------
+
+   Scope_Suppress : Suppress_Record := Suppress_Options;
+   --  This record contains the current scope based settings of the suppress
+   --  switches. It is initialized from the options as shown, and then modified
+   --  by pragma Suppress. On entry to each scope, the current setting is saved
+   --  the scope stack, and then restored on exit from the scope.
+
+   --  The scope stack holds all entries of the scope table. As in the parser,
+   --  we use Last as the stack pointer, so that we can always find the scope
+   --  that is currently open in Scope_Stack.Table (Scope_Stack.Last). The
+   --  oldest entry, at Scope_Stack (0) is Standard. The entries in the table
+   --  include the entity for the referenced scope, together with information
+   --  used to restore the proper setting of check suppressions on scope exit.
+
+   --  There are two kinds of suppress checks, scope based suppress checks
+   --  (from initial command line arguments, or from Suppress pragmas not
+   --  including an entity name). The scope based suppress checks are recorded
+   --  in the Sem.Supress variable, and all that is necessary is to save the
+   --  state of this variable on scope entry, and restore it on scope exit.
+
+   --  The other kind of suppress check is entity based suppress checks, from
+   --  Suppress pragmas giving an Entity_Id. These checks are reflected by the
+   --  appropriate bit being set in the corresponding entity, and restoring the
+   --  setting of these bits is a little trickier. In particular a given pragma
+   --  Suppress may or may not affect the current state. If it sets a check for
+   --  an entity that is already checked, then it is important that this check
+   --  not be restored on scope exit. The situation is made more complicated
+   --  by the fact that a given suppress pragma can specify multiple entities
+   --  (in the overloaded case), and multiple checks (by using All_Checks), so
+   --  that it may be partially effective. On exit only checks that were in
+   --  fact effective must be removed. Logically we could do this by saving
+   --  the entire state of the entity flags on scope entry and restoring them
+   --  on scope exit, but that would be ludicrous, so what we do instead is to
+   --  maintain the following differential structure that shows what checks
+   --  were installed for the current scope.
+
+   --  Note: Suppress pragmas that specify entities defined in a package
+   --  spec do not make entries in this table, since such checks suppress
+   --  requests are valid for the entire life of the entity.
+
+   type Entity_Check_Suppress_Record is record
+      Entity : Entity_Id;
+      --  Entity to which the check applies
+
+      Check : Check_Id;
+      --  Check which is set (note this cannot be All_Checks, if the All_Checks
+      --  case, a sequence of eentries appears for the individual checks.
+   end record;
+
+   --  Entity_Suppress is a stack, to which new entries are added as they
+   --  are processed (see pragma Suppress circuit in Sem_Prag). The scope
+   --  stack entry simply saves the stack pointer on entry, and restores
+   --  it on exit by reversing the checks one by one.
+
+   package Entity_Suppress is new Table.Table (
+     Table_Component_Type => Entity_Check_Suppress_Record,
+     Table_Index_Type     => Int,
+     Table_Low_Bound      => 0,
+     Table_Initial        => Alloc.Entity_Suppress_Initial,
+     Table_Increment      => Alloc.Entity_Suppress_Increment,
+     Table_Name           => "Entity_Suppress");
+
+   --  Here is the scope stack itself
+
+   type Scope_Stack_Entry is record
+      Entity : Entity_Id;
+      --  Entity representing the scope
+
+      Last_Subprogram_Name : String_Ptr;
+      --  Pointer to name of last subprogram body in this scope. Used for
+      --  testing proper alpha ordering of subprogram bodies in scope.
+
+      Save_Scope_Suppress  : Suppress_Record;
+      --  Save contents of Scope_Suppress on entry
+
+      Save_Entity_Suppress : Int;
+      --  Save contents of Entity_Suppress.Last on entry
+
+      Is_Transient : Boolean;
+      --  Marks Transient Scopes (See Exp_Ch7 body for details)
+
+      Previous_Visibility : Boolean;
+      --  Used when installing the parent (s) of the current compilation
+      --  unit. The parent may already be visible because of an ongoing
+      --  compilation, and the proper visibility must be restored on exit.
+
+      Node_To_Be_Wrapped : Node_Id;
+      --  Only used in transient scopes. Records the node which will
+      --  be wrapped by the transient block.
+
+      Actions_To_Be_Wrapped_Before : List_Id;
+      Actions_To_Be_Wrapped_After  : List_Id;
+      --  Actions that have to be inserted at the start or at the end of a
+      --  transient block. Used to temporarily hold these actions until the
+      --  block is created, at which time the actions are moved to the
+      --  block.
+
+      Pending_Freeze_Actions : List_Id;
+      --  Used to collect freeze entity nodes and associated actions that
+      --  are generated in a inner context but need to be analyzed outside,
+      --  such as records and initialization procedures. On exit from the
+      --  scope, this list of actions is inserted before the scope construct
+      --  and analyzed to generate the corresponding freeze processing and
+      --  elaboration of other associated actions.
+
+      First_Use_Clause : Node_Id;
+      --  Head of list of Use_Clauses in current scope. The list is built
+      --  when the declarations in the scope are processed. The list is
+      --  traversed on scope exit to undo the effect of the use clauses.
+
+      Component_Alignment_Default : Component_Alignment_Kind;
+      --  Component alignment to be applied to any record or array types
+      --  that are declared for which a specific component alignment pragma
+      --  does not set the alignment.
+
+      Is_Active_Stack_Base : Boolean;
+      --  Set to true only when entering the scope for Standard_Standard from
+      --  from within procedure Semantics. Indicates the base of the current
+      --  active set of scopes. Needed by In_Open_Scopes to handle cases
+      --  where Standard_Standard can be pushed in the middle of the active
+      --  set of scopes (occurs for instantiations of generic child units).
+   end record;
+
+   package Scope_Stack is new Table.Table (
+     Table_Component_Type => Scope_Stack_Entry,
+     Table_Index_Type     => Int,
+     Table_Low_Bound      => 0,
+     Table_Initial        => Alloc.Scope_Stack_Initial,
+     Table_Increment      => Alloc.Scope_Stack_Increment,
+     Table_Name           => "Sem.Scope_Stack");
+
+   function Get_Scope_Suppress (C : Check_Id) return Boolean;
+   --  Get suppress status of check C for the current scope
+
+   procedure Set_Scope_Suppress (C : Check_Id; B : Boolean);
+   --  Set suppress status of check C for the current scope
+
+   -----------------
+   -- Subprograms --
+   -----------------
+
+   procedure Initialize;
+   --  Initialize internal tables
+
+   procedure Lock;
+   --  Lock internal tables before calling back end
+
+   procedure Semantics (Comp_Unit : Node_Id);
+   --  This procedure is called to perform semantic analysis on the specified
+   --  node which is the N_Compilation_Unit node for the unit.
+
+   procedure Analyze (N : Node_Id);
+   procedure Analyze (N : Node_Id; Suppress : Check_Id);
+   --  This is the recursive procedure which is applied to individual nodes
+   --  of the tree, starting at the top level node (compilation unit node)
+   --  and then moving down the tree in a top down traversal. It calls
+   --  individual routines with names Analyze_xxx to analyze node xxx. Each
+   --  of these routines is responsible for calling Analyze on the components
+   --  of the subtree.
+   --
+   --  Note: In the case of expression components (nodes whose Nkind is in
+   --  N_Subexpr), the call to Analyze does not complete the semantic analysis
+   --  of the node, since the type resolution cannot be completed until the
+   --  complete context is analyzed. The completion of the type analysis occurs
+   --  in the corresponding Resolve routine (see Sem_Res).
+   --
+   --  Note: for integer and real literals, the analyzer sets the flag to
+   --  indicate that the result is a static expression. If the expander
+   --  generates a literal that does NOT correspond to a static expression,
+   --  e.g. by folding an expression whose value is known at compile-time,
+   --  but is not technically static, then the caller should reset the
+   --  Is_Static_Expression flag after analyzing but before resolving.
+   --
+   --  If the Suppress argument is present, then the analysis is done
+   --  with the specified check suppressed (can be All_Checks to suppress
+   --  all checks).
+
+   procedure Analyze_List (L : List_Id);
+   procedure Analyze_List (L : List_Id; Suppress : Check_Id);
+   --  Analyzes each element of a list. If the Suppress argument is present,
+   --  then the analysis is done with the specified check suppressed (can
+   --  be All_Checks to suppress all checks).
+
+   procedure Insert_List_After_And_Analyze
+     (N : Node_Id; L : List_Id);
+   procedure Insert_List_After_And_Analyze
+     (N : Node_Id; L : List_Id; Suppress : Check_Id);
+   --  Inserts list L after node N using Nlists.Insert_List_After, and then,
+   --  after this insertion is complete, analyzes all the nodes in the list,
+   --  including any additional nodes generated by this analysis. If the list
+   --  is empty or be No_List, the call has no effect. If the Suppress
+   --  argument is present, then the analysis is done with the specified
+   --  check suppressed (can be All_Checks to suppress all checks).
+
+   procedure Insert_List_Before_And_Analyze
+     (N : Node_Id; L : List_Id);
+   procedure Insert_List_Before_And_Analyze
+     (N : Node_Id; L : List_Id; Suppress : Check_Id);
+   --  Inserts list L before node N using Nlists.Insert_List_Before, and then,
+   --  after this insertion is complete, analyzes all the nodes in the list,
+   --  including any additional nodes generated by this analysis. If the list
+   --  is empty or be No_List, the call has no effect. If the Suppress
+   --  argument is present, then the analysis is done with the specified
+   --  check suppressed (can be All_Checks to suppress all checks).
+
+   procedure Insert_After_And_Analyze
+     (N : Node_Id; M : Node_Id);
+   procedure Insert_After_And_Analyze
+     (N : Node_Id; M : Node_Id; Suppress : Check_Id);
+   --  Inserts node M after node N and then after the insertion is complete,
+   --  analyzes the inserted node and all nodes that are generated by
+   --  this analysis. If the node is empty, the call has no effect. If the
+   --  Suppress argument is present, then the analysis is done with the
+   --  specified check suppressed (can be All_Checks to suppress all checks).
+
+   procedure Insert_Before_And_Analyze
+     (N : Node_Id; M : Node_Id);
+   procedure Insert_Before_And_Analyze
+     (N : Node_Id; M : Node_Id; Suppress : Check_Id);
+   --  Inserts node M before node N and then after the insertion is complete,
+   --  analyzes the inserted node and all nodes that could be generated by
+   --  this analysis. If the node is empty, the call has no effect. If the
+   --  Suppress argument is present, then the analysis is done with the
+   --  specified check suppressed (can be All_Checks to suppress all checks).
+
+   function External_Ref_In_Generic (E : Entity_Id) return Boolean;
+   --  Return True if we are in the context of a generic and E is
+   --  external (more global) to it.
+
+   procedure Enter_Generic_Scope (S : Entity_Id);
+   --  Shall be called each time a Generic subprogram or package scope is
+   --  entered.  S is the entity of the scope.
+   --  ??? At the moment, only called for package specs because this mechanism
+   --  is only used for avoiding freezing of external references in generics
+   --  and this can only be an issue if the outer generic scope is a package
+   --  spec (otherwise all external entities are already frozen)
+
+   procedure Exit_Generic_Scope  (S : Entity_Id);
+   --  Shall be called each time a Generic subprogram or package scope is
+   --  exited.  S is the entity of the scope.
+   --  ??? At the moment, only called for package specs exit.
+
+end Sem;
diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb
new file mode 100644
index 00000000000..29778ff49b0
--- /dev/null
+++ b/gcc/ada/sem_aggr.adb
@@ -0,0 +1,2848 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             S E M _ A G G R                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.232 $
+--                                                                          --
+--          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 Checks;   use Checks;
+with Einfo;    use Einfo;
+with Elists;   use Elists;
+with Errout;   use Errout;
+with Exp_Util; use Exp_Util;
+with Freeze;   use Freeze;
+with Itypes;   use Itypes;
+with Namet;    use Namet;
+with Nmake;    use Nmake;
+with Nlists;   use Nlists;
+with Opt;      use Opt;
+with Sem;      use Sem;
+with Sem_Cat;  use Sem_Cat;
+with Sem_Ch8;  use Sem_Ch8;
+with Sem_Ch13; use Sem_Ch13;
+with Sem_Eval; use Sem_Eval;
+with Sem_Res;  use Sem_Res;
+with Sem_Util; use Sem_Util;
+with Sem_Type; use Sem_Type;
+with Sinfo;    use Sinfo;
+with Snames;   use Snames;
+with Stringt;  use Stringt;
+with Stand;    use Stand;
+with Tbuild;   use Tbuild;
+with Uintp;    use Uintp;
+
+with GNAT.Spelling_Checker; use GNAT.Spelling_Checker;
+
+package body Sem_Aggr is
+
+   type Case_Bounds is record
+     Choice_Lo   : Node_Id;
+     Choice_Hi   : Node_Id;
+     Choice_Node : Node_Id;
+   end record;
+
+   type Case_Table_Type is array (Nat range <>) of Case_Bounds;
+   --  Table type used by Check_Case_Choices procedure
+
+   -----------------------
+   -- Local Subprograms --
+   -----------------------
+
+   procedure Sort_Case_Table (Case_Table : in out Case_Table_Type);
+   --  Sort the Case Table using the Lower Bound of each Choice as the key.
+   --  A simple insertion sort is used since the number of choices in a case
+   --  statement of variant part will usually be small and probably in near
+   --  sorted order.
+
+   ------------------------------------------------------
+   -- Subprograms used for RECORD AGGREGATE Processing --
+   ------------------------------------------------------
+
+   procedure Resolve_Record_Aggregate (N : Node_Id; Typ : Entity_Id);
+   --  This procedure performs all the semantic checks required for record
+   --  aggregates. Note that for aggregates analysis and resolution go
+   --  hand in hand. Aggregate analysis has been delayed up to here and
+   --  it is done while resolving the aggregate.
+   --
+   --    N is the N_Aggregate node.
+   --    Typ is the record type for the aggregate resolution
+   --
+   --  While performing the semantic checks, this procedure
+   --  builds a new Component_Association_List where each record field
+   --  appears alone in a Component_Choice_List along with its corresponding
+   --  expression. The record fields in the Component_Association_List
+   --  appear in the same order in which they appear in the record type Typ.
+   --
+   --  Once this new Component_Association_List is built and all the
+   --  semantic checks performed, the original aggregate subtree is replaced
+   --  with the new named record aggregate just built. Note that the subtree
+   --  substitution is performed with Rewrite so as to be
+   --  able to retrieve the original aggregate.
+   --
+   --  The aggregate subtree manipulation performed by Resolve_Record_Aggregate
+   --  yields the aggregate format expected by Gigi. Typically, this kind of
+   --  tree manipulations are done in the expander. However, because the
+   --  semantic checks that need to be performed on record aggregates really
+   --  go hand in hand with the record aggreagate normalization, the aggregate
+   --  subtree transformation is performed during resolution rather than
+   --  expansion. Had we decided otherwise we would have had to duplicate
+   --  most of the code in the expansion procedure Expand_Record_Aggregate.
+   --  Note, however, that all the expansion concerning aggegates for tagged
+   --  records is done in Expand_Record_Aggregate.
+   --
+   --  The algorithm of Resolve_Record_Aggregate proceeds as follows:
+   --
+   --  1. Make sure that the record type against which the record aggregate
+   --     has to be resolved is not abstract. Furthermore if the type is
+   --     a null aggregate make sure the input aggregate N is also null.
+   --
+   --  2. Verify that the structure of the aggregate is that of a record
+   --     aggregate. Specifically, look for component associations and ensure
+   --     that each choice list only has identifiers or the N_Others_Choice
+   --     node. Also make sure that if present, the N_Others_Choice occurs
+   --     last and by itself.
+   --
+   --  3. If Typ contains discriminants, the values for each discriminant
+   --     is looked for. If the record type Typ has variants, we check
+   --     that the expressions corresponding to each discriminant ruling
+   --     the (possibly nested) variant parts of Typ, are static. This
+   --     allows us to determine the variant parts to which the rest of
+   --     the aggregate must conform. The names of discriminants with their
+   --     values are saved in a new association list, New_Assoc_List which
+   --     is later augmented with the names and values of the remaining
+   --     components in the record type.
+   --
+   --     During this phase we also make sure that every discriminant is
+   --     assigned exactly one value. Note that when several values
+   --     for a given discriminant are found, semantic processing continues
+   --     looking for further errors. In this case it's the first
+   --     discriminant value found which we will be recorded.
+   --
+   --     IMPORTANT NOTE: For derived tagged types this procedure expects
+   --     First_Discriminant and Next_Discriminant to give the correct list
+   --     of discriminants, in the correct order.
+   --
+   --  4. After all the discriminant values have been gathered, we can
+   --     set the Etype of the record aggregate. If Typ contains no
+   --     discriminants this is straightforward: the Etype of N is just
+   --     Typ, otherwise a new implicit constrained subtype of Typ is
+   --     built to be the Etype of N.
+   --
+   --  5. Gather the remaining record components according to the discriminant
+   --     values. This involves recursively traversing the record type
+   --     structure to see what variants are selected by the given discriminant
+   --     values. This processing is a little more convoluted if Typ is a
+   --     derived tagged types since we need to retrieve the record structure
+   --     of all the ancestors of Typ.
+   --
+   --  6. After gathering the record components we look for their values
+   --     in the record aggregate and emit appropriate error messages
+   --     should we not find such values or should they be duplicated.
+   --
+   --  7. We then make sure no illegal component names appear in the
+   --     record aggegate and make sure that the type of the record
+   --     components appearing in a same choice list is the same.
+   --     Finally we ensure that the others choice, if present, is
+   --     used to provide the value of at least a record component.
+   --
+   --  8. The original aggregate node is replaced with the new named
+   --     aggregate built in steps 3 through 6, as explained earlier.
+   --
+   --  Given the complexity of record aggregate resolution, the primary
+   --  goal of this routine is clarity and simplicity rather than execution
+   --  and storage efficiency. If there are only positional components in the
+   --  aggregate the running time is linear. If there are associations
+   --  the running time is still linear as long as the order of the
+   --  associations is not too far off the order of the components in the
+   --  record type. If this is not the case the running time is at worst
+   --  quadratic in the size of the association list.
+
+   procedure Check_Misspelled_Component
+     (Elements      : Elist_Id;
+      Component     : Node_Id);
+   --  Give possible misspelling diagnostic if Component is likely to be
+   --  a misspelling of one of the components of the Assoc_List.
+   --  This is called by Resolv_Aggr_Expr after producing
+   --  an invalid component error message.
+
+   procedure Check_Static_Discriminated_Subtype (T : Entity_Id; V : Node_Id);
+   --  An optimization: determine whether a discriminated subtype has a
+   --  static constraint, and contains array components whose length is also
+   --  static, either because they are constrained by the discriminant, or
+   --  because the original component bounds are static.
+
+   -----------------------------------------------------
+   -- Subprograms used for ARRAY AGGREGATE Processing --
+   -----------------------------------------------------
+
+   function Resolve_Array_Aggregate
+     (N              : Node_Id;
+      Index          : Node_Id;
+      Index_Constr   : Node_Id;
+      Component_Typ  : Entity_Id;
+      Others_Allowed : Boolean)
+      return           Boolean;
+   --  This procedure performs the semantic checks for an array aggregate.
+   --  True is returned if the aggregate resolution succeeds.
+   --  The procedure works by recursively checking each nested aggregate.
+   --  Specifically, after checking a sub-aggreate nested at the i-th level
+   --  we recursively check all the subaggregates at the i+1-st level (if any).
+   --  Note that for aggregates analysis and resolution go hand in hand.
+   --  Aggregate analysis has been delayed up to here and it is done while
+   --  resolving the aggregate.
+   --
+   --    N is the current N_Aggregate node to be checked.
+   --
+   --    Index is the index node corresponding to the array sub-aggregate that
+   --    we are currently checking (RM 4.3.3 (8)). Its Etype is the
+   --    corresponding index type (or subtype).
+   --
+   --    Index_Constr is the node giving the applicable index constraint if
+   --    any (RM 4.3.3 (10)). It "is a constraint provided by certain
+   --    contexts [...] that can be used to determine the bounds of the array
+   --    value specified by the aggregate". If Others_Allowed below is False
+   --    there is no applicable index constraint and this node is set to Index.
+   --
+   --    Component_Typ is the array component type.
+   --
+   --    Others_Allowed indicates whether an others choice is allowed
+   --    in the context where the top-level aggregate appeared.
+   --
+   --  The algorithm of Resolve_Array_Aggregate proceeds as follows:
+   --
+   --  1. Make sure that the others choice, if present, is by itself and
+   --     appears last in the sub-aggregate. Check that we do not have
+   --     positional and named components in the array sub-aggregate (unless
+   --     the named association is an others choice). Finally if an others
+   --     choice is present, make sure it is allowed in the aggregate contex.
+   --
+   --  2. If the array sub-aggregate contains discrete_choices:
+   --
+   --     (A) Verify their validity. Specifically verify that:
+   --
+   --        (a) If a null range is present it must be the only possible
+   --            choice in the array aggregate.
+   --
+   --        (b) Ditto for a non static range.
+   --
+   --        (c) Ditto for a non static expression.
+   --
+   --        In addition this step analyzes and resolves each discrete_choice,
+   --        making sure that its type is the type of the corresponding Index.
+   --        If we are not at the lowest array aggregate level (in the case of
+   --        multi-dimensional aggregates) then invoke Resolve_Array_Aggregate
+   --        recursively on each component expression. Otherwise, resolve the
+   --        bottom level component expressions against the expected component
+   --        type ONLY IF the component corresponds to a single discrete choice
+   --        which is not an others choice (to see why read the DELAYED
+   --        COMPONENT RESOLUTION below).
+   --
+   --     (B) Determine the bounds of the sub-aggregate and lowest and
+   --         highest choice values.
+   --
+   --  3. For positional aggregates:
+   --
+   --     (A) Loop over the component expressions either recursively invoking
+   --         Resolve_Array_Aggregate on each of these for multi-dimensional
+   --         array aggregates or resolving the bottom level component
+   --         expressions against the expected component type.
+   --
+   --     (B) Determine the bounds of the positional sub-aggregates.
+   --
+   --  4. Try to determine statically whether the evaluation of the array
+   --     sub-aggregate raises Constraint_Error. If yes emit proper
+   --     warnings. The precise checks are the following:
+   --
+   --     (A) Check that the index range defined by aggregate bounds is
+   --         compatible with corresponding index subtype.
+   --         We also check against the base type. In fact it could be that
+   --         Low/High bounds of the base type are static whereas those of
+   --         the index subtype are not. Thus if we can statically catch
+   --         a problem with respect to the base type we are guaranteed
+   --         that the same problem will arise with the index subtype
+   --
+   --     (B) If we are dealing with a named aggregate containing an others
+   --         choice and at least one discrete choice then make sure the range
+   --         specified by the discrete choices does not overflow the
+   --         aggregate bounds. We also check against the index type and base
+   --         type bounds for the same reasons given in (A).
+   --
+   --     (C) If we are dealing with a positional aggregate with an others
+   --         choice make sure the number of positional elements specified
+   --         does not overflow the aggregate bounds. We also check against
+   --         the index type and base type bounds as mentioned in (A).
+   --
+   --     Finally construct an N_Range node giving the sub-aggregate bounds.
+   --     Set the Aggregate_Bounds field of the sub-aggregate to be this
+   --     N_Range. The routine Array_Aggr_Subtype below uses such N_Ranges
+   --     to build the appropriate aggregate subtype. Aggregate_Bounds
+   --     information is needed during expansion.
+   --
+   --  DELAYED COMPONENT RESOLUTION: The resolution of bottom level component
+   --  expressions in an array aggregate may call Duplicate_Subexpr or some
+   --  other routine that inserts code just outside the outermost aggregate.
+   --  If the array aggregate contains discrete choices or an others choice,
+   --  this may be wrong. Consider for instance the following example.
+   --
+   --    type Rec is record
+   --       V : Integer := 0;
+   --    end record;
+   --
+   --    type Acc_Rec is access Rec;
+   --    Arr : array (1..3) of Acc_Rec := (1 .. 3 => new Rec);
+   --
+   --  Then the transformation of "new Rec" that occurs during resolution
+   --  entails the following code modifications
+   --
+   --    P7b : constant Acc_Rec := new Rec;
+   --    Rec_init_proc (P7b.all);
+   --    Arr : array (1..3) of Acc_Rec := (1 .. 3 => P7b);
+   --
+   --  This code transformation is clearly wrong, since we need to call
+   --  "new Rec" for each of the 3 array elements. To avoid this problem we
+   --  delay resolution of the components of non positional array aggregates
+   --  to the expansion phase. As an optimization, if the discrete choice
+   --  specifies a single value we do not delay resolution.
+
+   function Array_Aggr_Subtype (N : Node_Id; Typ : Node_Id) return Entity_Id;
+   --  This routine returns the type or subtype of an array aggregate.
+   --
+   --    N is the array aggregate node whose type we return.
+   --
+   --    Typ is the context type in which N occurs.
+   --
+   --  This routine creates an implicit array subtype whose bouds are
+   --  those defined by the aggregate. When this routine is invoked
+   --  Resolve_Array_Aggregate has already processed aggregate N. Thus the
+   --  Aggregate_Bounds of each sub-aggregate, is an N_Range node giving the
+   --  sub-aggregate bounds. When building the aggegate itype, this function
+   --  traverses the array aggregate N collecting such Aggregate_Bounds and
+   --  constructs the proper array aggregate itype.
+   --
+   --  Note that in the case of multidimensional aggregates each inner
+   --  sub-aggregate corresponding to a given array dimension, may provide a
+   --  different bounds. If it is possible to determine statically that
+   --  some sub-aggregates corresponding to the same index do not have the
+   --  same bounds, then a warning is emitted. If such check is not possible
+   --  statically (because some sub-aggregate bounds are dynamic expressions)
+   --  then this job is left to the expander. In all cases the particular
+   --  bounds that this function will chose for a given dimension is the first
+   --  N_Range node for a sub-aggregate corresponding to that dimension.
+   --
+   --  Note that the Raises_Constraint_Error flag of an array aggregate
+   --  whose evaluation is determined to raise CE by Resolve_Array_Aggregate,
+   --  is set in Resolve_Array_Aggregate but the aggregate is not
+   --  immediately replaced with a raise CE. In fact, Array_Aggr_Subtype must
+   --  first construct the proper itype for the aggregate (Gigi needs
+   --  this). After constructing the proper itype we will eventually  replace
+   --  the top-level aggregate with a raise CE (done in Resolve_Aggregate).
+   --  Of course in cases such as:
+   --
+   --     type Arr is array (integer range <>) of Integer;
+   --     A : Arr := (positive range -1 .. 2 => 0);
+   --
+   --  The bounds of the aggregate itype are cooked up to look reasonable
+   --  (in this particular case the bounds will be 1 .. 2).
+
+   procedure Aggregate_Constraint_Checks
+     (Exp       : Node_Id;
+      Check_Typ : Entity_Id);
+   --  Checks expression Exp against subtype Check_Typ. If Exp is an
+   --  aggregate and Check_Typ a constrained record type with discriminants,
+   --  we generate the appropriate discriminant checks. If Exp is an array
+   --  aggregate then emit the appropriate length checks. If Exp is a scalar
+   --  type, or a string literal, Exp is changed into Check_Typ'(Exp) to
+   --  ensure that range checks are performed at run time.
+
+   procedure Make_String_Into_Aggregate (N : Node_Id);
+   --  A string literal can appear in  a context in  which a one dimensional
+   --  array of characters is expected. This procedure simply rewrites the
+   --  string as an aggregate, prior to resolution.
+
+   ---------------------------------
+   -- Aggregate_Constraint_Checks --
+   ---------------------------------
+
+   procedure Aggregate_Constraint_Checks
+     (Exp       : Node_Id;
+      Check_Typ : Entity_Id)
+   is
+      Exp_Typ : constant Entity_Id  := Etype (Exp);
+
+   begin
+      if Raises_Constraint_Error (Exp) then
+         return;
+      end if;
+
+      --  This is really expansion activity, so make sure that expansion
+      --  is on and is allowed.
+
+      if not Expander_Active or else In_Default_Expression then
+         return;
+      end if;
+
+      --  First check if we have to insert discriminant checks
+
+      if Has_Discriminants (Exp_Typ) then
+         Apply_Discriminant_Check (Exp, Check_Typ);
+
+      --  Next emit length checks for array aggregates
+
+      elsif Is_Array_Type (Exp_Typ) then
+         Apply_Length_Check (Exp, Check_Typ);
+
+      --  Finally emit scalar and string checks. If we are dealing with a
+      --  scalar literal we need to check by hand because the Etype of
+      --  literals is not necessarily correct.
+
+      elsif Is_Scalar_Type (Exp_Typ)
+        and then Compile_Time_Known_Value (Exp)
+      then
+         if Is_Out_Of_Range (Exp, Base_Type (Check_Typ)) then
+            Apply_Compile_Time_Constraint_Error
+              (Exp, "value not in range of}?",
+               Ent => Base_Type (Check_Typ),
+               Typ => Base_Type (Check_Typ));
+
+         elsif Is_Out_Of_Range (Exp, Check_Typ) then
+            Apply_Compile_Time_Constraint_Error
+              (Exp, "value not in range of}?",
+               Ent => Check_Typ,
+               Typ => Check_Typ);
+
+         elsif not Range_Checks_Suppressed (Check_Typ) then
+            Apply_Scalar_Range_Check (Exp, Check_Typ);
+         end if;
+
+      elsif (Is_Scalar_Type (Exp_Typ)
+             or else Nkind (Exp) = N_String_Literal)
+        and then Exp_Typ /= Check_Typ
+      then
+         if Is_Entity_Name (Exp)
+           and then Ekind (Entity (Exp)) = E_Constant
+         then
+            --  If expression is a constant, it is worthwhile checking whether
+            --  it is a bound of the type.
+
+            if (Is_Entity_Name (Type_Low_Bound (Check_Typ))
+                 and then Entity (Exp) = Entity (Type_Low_Bound (Check_Typ)))
+              or else (Is_Entity_Name (Type_High_Bound (Check_Typ))
+                and then Entity (Exp) = Entity (Type_High_Bound (Check_Typ)))
+            then
+               return;
+
+            else
+               Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp)));
+               Analyze_And_Resolve (Exp, Check_Typ);
+            end if;
+         else
+            Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp)));
+            Analyze_And_Resolve (Exp, Check_Typ);
+         end if;
+
+      end if;
+   end Aggregate_Constraint_Checks;
+
+   ------------------------
+   -- Array_Aggr_Subtype --
+   ------------------------
+
+   function Array_Aggr_Subtype
+     (N    : Node_Id;
+      Typ  : Entity_Id)
+      return Entity_Id
+   is
+      Aggr_Dimension : constant Pos := Number_Dimensions (Typ);
+      --  Number of aggregate index dimensions.
+
+      Aggr_Range : array (1 .. Aggr_Dimension) of Node_Id := (others => Empty);
+      --  Constrained N_Range of each index dimension in our aggregate itype.
+
+      Aggr_Low   : array (1 .. Aggr_Dimension) of Node_Id := (others => Empty);
+      Aggr_High  : array (1 .. Aggr_Dimension) of Node_Id := (others => Empty);
+      --  Low and High bounds for each index dimension in our aggregate itype.
+
+      Is_Fully_Positional : Boolean := True;
+
+      procedure Collect_Aggr_Bounds (N : Node_Id; Dim : Pos);
+      --  N is an array (sub-)aggregate. Dim is the dimension corresponding to
+      --  (sub-)aggregate N. This procedure collects the constrained N_Range
+      --  nodes corresponding to each index dimension of our aggregate itype.
+      --  These N_Range nodes are collected in Aggr_Range above.
+      --  Likewise collect in Aggr_Low & Aggr_High above the low and high
+      --  bounds of each index dimension. If, when collecting, two bounds
+      --  corresponding to the same dimension are static and found to differ,
+      --  then emit a warning, and mark N as raising Constraint_Error.
+
+      -------------------------
+      -- Collect_Aggr_Bounds --
+      -------------------------
+
+      procedure Collect_Aggr_Bounds (N : Node_Id; Dim : Pos) is
+         This_Range : constant Node_Id := Aggregate_Bounds (N);
+         --  The aggregate range node of this specific sub-aggregate.
+
+         This_Low  : constant Node_Id := Low_Bound (Aggregate_Bounds (N));
+         This_High : constant Node_Id := High_Bound (Aggregate_Bounds (N));
+         --  The aggregate bounds of this specific sub-aggregate.
+
+         Assoc : Node_Id;
+         Expr  : Node_Id;
+
+      begin
+         --  Collect the first N_Range for a given dimension that you find.
+         --  For a given dimension they must be all equal anyway.
+
+         if No (Aggr_Range (Dim)) then
+            Aggr_Low (Dim)   := This_Low;
+            Aggr_High (Dim)  := This_High;
+            Aggr_Range (Dim) := This_Range;
+
+         else
+            if Compile_Time_Known_Value (This_Low) then
+               if not Compile_Time_Known_Value (Aggr_Low (Dim)) then
+                  Aggr_Low (Dim)  := This_Low;
+
+               elsif Expr_Value (This_Low) /= Expr_Value (Aggr_Low (Dim)) then
+                  Set_Raises_Constraint_Error (N);
+                  Error_Msg_N ("Sub-aggregate low bound mismatch?", N);
+                  Error_Msg_N ("Constraint_Error will be raised at run-time?",
+                               N);
+               end if;
+            end if;
+
+            if Compile_Time_Known_Value (This_High) then
+               if not Compile_Time_Known_Value (Aggr_High (Dim)) then
+                  Aggr_High (Dim)  := This_High;
+
+               elsif
+                 Expr_Value (This_High) /= Expr_Value (Aggr_High (Dim))
+               then
+                  Set_Raises_Constraint_Error (N);
+                  Error_Msg_N ("Sub-aggregate high bound mismatch?", N);
+                  Error_Msg_N ("Constraint_Error will be raised at run-time?",
+                               N);
+               end if;
+            end if;
+         end if;
+
+         if Dim < Aggr_Dimension then
+
+            --  Process positional components
+
+            if Present (Expressions (N)) then
+               Expr := First (Expressions (N));
+               while Present (Expr) loop
+                  Collect_Aggr_Bounds (Expr, Dim + 1);
+                  Next (Expr);
+               end loop;
+            end if;
+
+            --  Process component associations
+
+            if Present (Component_Associations (N)) then
+               Is_Fully_Positional := False;
+
+               Assoc := First (Component_Associations (N));
+               while Present (Assoc) loop
+                  Expr := Expression (Assoc);
+                  Collect_Aggr_Bounds (Expr, Dim + 1);
+                  Next (Assoc);
+               end loop;
+            end if;
+         end if;
+      end Collect_Aggr_Bounds;
+
+      --  Array_Aggr_Subtype variables
+
+      Itype : Entity_Id;
+      --  the final itype of the overall aggregate
+
+      Index_Constraints : List_Id := New_List;
+      --  The list of index constraints of the aggregate itype.
+
+   --  Start of processing for Array_Aggr_Subtype
+
+   begin
+      --  Make sure that the list of index constraints is properly attached
+      --  to the tree, and then collect the aggregate bounds.
+
+      Set_Parent (Index_Constraints, N);
+      Collect_Aggr_Bounds (N, 1);
+
+      --  Build the list of constrained indices of our aggregate itype.
+
+      for J in 1 .. Aggr_Dimension loop
+         Create_Index : declare
+            Index_Base : Entity_Id := Base_Type (Etype (Aggr_Range (J)));
+            Index_Typ  : Entity_Id;
+
+         begin
+            --  Construct the Index subtype
+
+            Index_Typ := Create_Itype (Subtype_Kind (Ekind (Index_Base)), N);
+
+            Set_Etype (Index_Typ, Index_Base);
+
+            if Is_Character_Type (Index_Base) then
+               Set_Is_Character_Type (Index_Typ);
+            end if;
+
+            Set_Size_Info      (Index_Typ,                (Index_Base));
+            Set_RM_Size        (Index_Typ, RM_Size        (Index_Base));
+            Set_First_Rep_Item (Index_Typ, First_Rep_Item (Index_Base));
+            Set_Scalar_Range   (Index_Typ, Aggr_Range (J));
+
+            if Is_Discrete_Or_Fixed_Point_Type (Index_Typ) then
+               Set_RM_Size (Index_Typ, UI_From_Int (Minimum_Size (Index_Typ)));
+            end if;
+
+            Set_Etype (Aggr_Range (J), Index_Typ);
+
+            Append (Aggr_Range (J), To => Index_Constraints);
+         end Create_Index;
+      end loop;
+
+      --  Now build the Itype
+
+      Itype := Create_Itype (E_Array_Subtype, N);
+
+      Set_First_Rep_Item         (Itype, First_Rep_Item         (Typ));
+      Set_Component_Type         (Itype, Component_Type         (Typ));
+      Set_Convention             (Itype, Convention             (Typ));
+      Set_Depends_On_Private     (Itype, Has_Private_Component  (Typ));
+      Set_Etype                  (Itype, Base_Type              (Typ));
+      Set_Has_Alignment_Clause   (Itype, Has_Alignment_Clause   (Typ));
+      Set_Is_Aliased             (Itype, Is_Aliased             (Typ));
+      Set_Suppress_Index_Checks  (Itype, Suppress_Index_Checks  (Typ));
+      Set_Suppress_Length_Checks (Itype, Suppress_Length_Checks (Typ));
+      Set_Depends_On_Private     (Itype, Depends_On_Private     (Typ));
+
+      Set_First_Index    (Itype, First (Index_Constraints));
+      Set_Is_Constrained (Itype, True);
+      Set_Is_Internal    (Itype, True);
+      Init_Size_Align    (Itype);
+
+      --  A simple optimization: purely positional aggregates of static
+      --  components should be passed to gigi unexpanded whenever possible,
+      --  and regardless of the staticness of the bounds themselves. Subse-
+      --  quent checks in exp_aggr verify that type is not packed, etc.
+
+      Set_Size_Known_At_Compile_Time (Itype,
+         Is_Fully_Positional
+           and then Comes_From_Source (N)
+           and then Size_Known_At_Compile_Time (Component_Type (Typ)));
+
+      --  We always need a freeze node for a packed array subtype, so that
+      --  we can build the Packed_Array_Type corresponding to the subtype.
+      --  If expansion is disabled, the packed array subtype is not built,
+      --  and we must not generate a freeze node for the type, or else it
+      --  will appear incomplete to gigi.
+
+      if Is_Packed (Itype) and then not In_Default_Expression
+        and then Expander_Active
+      then
+         Freeze_Itype (Itype, N);
+      end if;
+
+      return Itype;
+   end Array_Aggr_Subtype;
+
+   --------------------------------
+   -- Check_Misspelled_Component --
+   --------------------------------
+
+   procedure Check_Misspelled_Component
+     (Elements      : Elist_Id;
+      Component     : Node_Id)
+   is
+      Max_Suggestions   : constant := 2;
+
+      Nr_Of_Suggestions : Natural := 0;
+      Suggestion_1      : Entity_Id := Empty;
+      Suggestion_2      : Entity_Id := Empty;
+      Component_Elmt    : Elmt_Id;
+
+   begin
+      --  All the components of List are matched against Component and
+      --  a count is maintained of possible misspellings. When at the
+      --  end of the analysis there are one or two (not more!) possible
+      --  misspellings, these misspellings will be suggested as
+      --  possible correction.
+
+      Get_Name_String (Chars (Component));
+
+      declare
+         S  : constant String (1 .. Name_Len) :=
+                Name_Buffer (1 .. Name_Len);
+
+      begin
+
+         Component_Elmt := First_Elmt (Elements);
+
+         while Nr_Of_Suggestions <= Max_Suggestions
+            and then Present (Component_Elmt)
+         loop
+
+            Get_Name_String (Chars (Node (Component_Elmt)));
+
+            if Is_Bad_Spelling_Of (Name_Buffer (1 .. Name_Len), S) then
+               Nr_Of_Suggestions := Nr_Of_Suggestions + 1;
+
+               case Nr_Of_Suggestions is
+                  when 1      => Suggestion_1 := Node (Component_Elmt);
+                  when 2      => Suggestion_2 := Node (Component_Elmt);
+                  when others => exit;
+               end case;
+            end if;
+
+            Next_Elmt (Component_Elmt);
+         end loop;
+
+         --  Report at most two suggestions
+
+         if Nr_Of_Suggestions = 1 then
+            Error_Msg_NE ("\possible misspelling of&",
+               Component, Suggestion_1);
+
+         elsif Nr_Of_Suggestions = 2 then
+            Error_Msg_Node_2 := Suggestion_2;
+            Error_Msg_NE ("\possible misspelling of& or&",
+              Component, Suggestion_1);
+         end if;
+      end;
+   end Check_Misspelled_Component;
+
+   ----------------------------------------
+   -- Check_Static_Discriminated_Subtype --
+   ----------------------------------------
+
+   procedure Check_Static_Discriminated_Subtype (T : Entity_Id; V : Node_Id) is
+      Disc : constant Entity_Id := First_Discriminant (T);
+      Comp : Entity_Id;
+      Ind  : Entity_Id;
+
+   begin
+      if Has_Record_Rep_Clause (Base_Type (T)) then
+         return;
+
+      elsif Present (Next_Discriminant (Disc)) then
+         return;
+
+      elsif Nkind (V) /= N_Integer_Literal then
+         return;
+      end if;
+
+      Comp := First_Component (T);
+
+      while Present (Comp) loop
+
+         if Is_Scalar_Type (Etype (Comp)) then
+            null;
+
+         elsif Is_Private_Type (Etype (Comp))
+           and then Present (Full_View (Etype (Comp)))
+           and then Is_Scalar_Type (Full_View (Etype (Comp)))
+         then
+            null;
+
+         elsif Is_Array_Type (Etype (Comp)) then
+
+            if Is_Bit_Packed_Array (Etype (Comp)) then
+               return;
+            end if;
+
+            Ind := First_Index (Etype (Comp));
+
+            while Present (Ind) loop
+
+               if Nkind (Ind) /= N_Range
+                 or else Nkind (Low_Bound (Ind)) /= N_Integer_Literal
+                 or else Nkind (High_Bound (Ind)) /= N_Integer_Literal
+               then
+                  return;
+               end if;
+
+               Next_Index (Ind);
+            end loop;
+
+         else
+            return;
+         end if;
+
+         Next_Component (Comp);
+      end loop;
+
+      --  On exit, all components have statically known sizes.
+
+      Set_Size_Known_At_Compile_Time (T);
+   end Check_Static_Discriminated_Subtype;
+
+   --------------------------------
+   -- Make_String_Into_Aggregate --
+   --------------------------------
+
+   procedure Make_String_Into_Aggregate (N : Node_Id) is
+      C      : Char_Code;
+      C_Node : Node_Id;
+      Exprs  : List_Id := New_List;
+      Loc    : constant Source_Ptr := Sloc (N);
+      New_N  : Node_Id;
+      P      : Source_Ptr := Loc + 1;
+      Str    : constant String_Id  := Strval (N);
+      Strlen : constant Nat        := String_Length (Str);
+
+   begin
+      for J in  1 .. Strlen loop
+         C := Get_String_Char (Str, J);
+         Set_Character_Literal_Name (C);
+
+         C_Node :=  Make_Character_Literal (P, Name_Find, C);
+         Set_Etype (C_Node, Any_Character);
+         Set_Analyzed (C_Node);
+         Append_To (Exprs, C_Node);
+
+         P := P + 1;
+         --  something special for wide strings ?
+      end loop;
+
+      New_N := Make_Aggregate (Loc, Expressions => Exprs);
+      Set_Analyzed (New_N);
+      Set_Etype (New_N, Any_Composite);
+
+      Rewrite (N, New_N);
+   end Make_String_Into_Aggregate;
+
+   -----------------------
+   -- Resolve_Aggregate --
+   -----------------------
+
+   procedure Resolve_Aggregate (N : Node_Id; Typ : Entity_Id) is
+      Pkind : constant Node_Kind := Nkind (Parent (N));
+
+      Aggr_Subtyp : Entity_Id;
+      --  The actual aggregate subtype. This is not necessarily the same as Typ
+      --  which is the subtype of the context in which the aggregate was found.
+
+   begin
+      if Is_Limited_Type (Typ) then
+         Error_Msg_N ("aggregate type cannot be limited", N);
+
+      elsif Is_Limited_Composite (Typ) then
+         Error_Msg_N ("aggregate type cannot have limited component", N);
+
+      elsif Is_Class_Wide_Type (Typ) then
+         Error_Msg_N ("type of aggregate cannot be class-wide", N);
+
+      elsif Typ = Any_String
+        or else Typ = Any_Composite
+      then
+         Error_Msg_N ("no unique type for aggregate", N);
+         Set_Etype (N, Any_Composite);
+
+      elsif Is_Array_Type (Typ) and then Null_Record_Present (N) then
+         Error_Msg_N ("null record forbidden in array aggregate", N);
+
+      elsif Is_Record_Type (Typ) then
+         Resolve_Record_Aggregate (N, Typ);
+
+      elsif Is_Array_Type (Typ) then
+
+         --  First a special test, for the case of a positional aggregate
+         --  of characters which can be replaced by a string literal.
+         --  Do not perform this transformation if this was a string literal
+         --  to start with, whose components needed constraint checks, or if
+         --  the component type is non-static, because it will require those
+         --  checks and be transformed back into an aggregate.
+
+         if Number_Dimensions (Typ) = 1
+           and then
+             (Root_Type (Component_Type (Typ)) = Standard_Character
+               or else
+              Root_Type (Component_Type (Typ)) = Standard_Wide_Character)
+           and then No (Component_Associations (N))
+           and then not Is_Limited_Composite (Typ)
+           and then not Is_Private_Composite (Typ)
+           and then not Is_Bit_Packed_Array (Typ)
+           and then Nkind (Original_Node (Parent (N))) /= N_String_Literal
+           and then Is_Static_Subtype (Component_Type (Typ))
+         then
+            declare
+               Expr : Node_Id;
+
+            begin
+               Expr := First (Expressions (N));
+               while Present (Expr) loop
+                  exit when Nkind (Expr) /= N_Character_Literal;
+                  Next (Expr);
+               end loop;
+
+               if No (Expr) then
+                  Start_String;
+
+                  Expr := First (Expressions (N));
+                  while Present (Expr) loop
+                     Store_String_Char (Char_Literal_Value (Expr));
+                     Next (Expr);
+                  end loop;
+
+                  Rewrite (N,
+                    Make_String_Literal (Sloc (N), End_String));
+
+                  Analyze_And_Resolve (N, Typ);
+                  return;
+               end if;
+            end;
+         end if;
+
+         --  Here if we have a real aggregate to deal with
+
+         Array_Aggregate : declare
+            Aggr_Resolved : Boolean;
+            Aggr_Typ      : Entity_Id := Etype (Typ);
+            --  This is the unconstrained array type, which is the type
+            --  against which the aggregate is to be resoved. Typ itself
+            --  is the array type of the context which may not be the same
+            --  subtype as the subtype for the final aggregate.
+
+         begin
+            --  In the following we determine whether an others choice is
+            --  allowed inside the array aggregate. The test checks the context
+            --  in which the array aggregate occurs. If the context does not
+            --  permit it, or the aggregate type is unconstrained, an others
+            --  choice is not allowed.
+            --
+            --  Note that there is no node for Explicit_Actual_Parameter.
+            --  To test for this context we therefore have to test for node
+            --  N_Parameter_Association which itself appears only if there is a
+            --  formal parameter. Consequently we also need to test for
+            --  N_Procedure_Call_Statement or N_Function_Call.
+
+            if Is_Constrained (Typ) and then
+              (Pkind = N_Assignment_Statement      or else
+               Pkind = N_Parameter_Association     or else
+               Pkind = N_Function_Call             or else
+               Pkind = N_Procedure_Call_Statement  or else
+               Pkind = N_Generic_Association       or else
+               Pkind = N_Formal_Object_Declaration or else
+               Pkind = N_Return_Statement          or else
+               Pkind = N_Object_Declaration        or else
+               Pkind = N_Component_Declaration     or else
+               Pkind = N_Parameter_Specification   or else
+               Pkind = N_Qualified_Expression      or else
+               Pkind = N_Aggregate                 or else
+               Pkind = N_Extension_Aggregate       or else
+               Pkind = N_Component_Association)
+            then
+               Aggr_Resolved :=
+                 Resolve_Array_Aggregate
+                   (N,
+                    Index          => First_Index (Aggr_Typ),
+                    Index_Constr   => First_Index (Typ),
+                    Component_Typ  => Component_Type (Typ),
+                    Others_Allowed => True);
+
+            else
+               Aggr_Resolved :=
+                 Resolve_Array_Aggregate
+                   (N,
+                    Index          => First_Index (Aggr_Typ),
+                    Index_Constr   => First_Index (Aggr_Typ),
+                    Component_Typ  => Component_Type (Typ),
+                    Others_Allowed => False);
+            end if;
+
+            if not Aggr_Resolved then
+               Aggr_Subtyp := Any_Composite;
+            else
+               Aggr_Subtyp := Array_Aggr_Subtype (N, Typ);
+            end if;
+
+            Set_Etype (N, Aggr_Subtyp);
+         end Array_Aggregate;
+
+      else
+         Error_Msg_N ("illegal context for aggregate", N);
+
+      end if;
+
+      --  If we can determine statically that the evaluation of the
+      --  aggregate raises Constraint_Error, then replace the
+      --  aggregate with an N_Raise_Constraint_Error node, but set the
+      --  Etype to the right aggregate subtype. Gigi needs this.
+
+      if Raises_Constraint_Error (N) then
+         Aggr_Subtyp := Etype (N);
+         Rewrite (N, Make_Raise_Constraint_Error (Sloc (N)));
+         Set_Raises_Constraint_Error (N);
+         Set_Etype (N, Aggr_Subtyp);
+         Set_Analyzed (N);
+      end if;
+
+   end Resolve_Aggregate;
+
+   -----------------------------
+   -- Resolve_Array_Aggregate --
+   -----------------------------
+
+   function Resolve_Array_Aggregate
+     (N              : Node_Id;
+      Index          : Node_Id;
+      Index_Constr   : Node_Id;
+      Component_Typ  : Entity_Id;
+      Others_Allowed : Boolean)
+      return           Boolean
+   is
+      Loc : constant Source_Ptr := Sloc (N);
+
+      Failure : constant Boolean := False;
+      Success : constant Boolean := True;
+
+      Index_Typ      : constant Entity_Id := Etype (Index);
+      Index_Typ_Low  : constant Node_Id   := Type_Low_Bound  (Index_Typ);
+      Index_Typ_High : constant Node_Id   := Type_High_Bound (Index_Typ);
+      --  The type of the index corresponding to the array sub-aggregate
+      --  along with its low and upper bounds
+
+      Index_Base      : constant Entity_Id := Base_Type (Index_Typ);
+      Index_Base_Low  : constant Node_Id   := Type_Low_Bound (Index_Base);
+      Index_Base_High : constant Node_Id   := Type_High_Bound (Index_Base);
+      --  ditto for the base type
+
+      function Add (Val : Uint; To : Node_Id) return Node_Id;
+      --  Creates a new expression node where Val is added to expression To.
+      --  Tries to constant fold whenever possible. To must be an already
+      --  analyzed expression.
+
+      procedure Check_Bound (BH : Node_Id; AH : in out Node_Id);
+      --  Checks that AH (the upper bound of an array aggregate) is <= BH
+      --  (the upper bound of the index base type). If the check fails a
+      --  warning is emitted, the Raises_Constraint_Error Flag of N is set,
+      --  and AH is replaced with a duplicate of BH.
+
+      procedure Check_Bounds (L, H : Node_Id; AL, AH : Node_Id);
+      --  Checks that range AL .. AH is compatible with range L .. H. Emits a
+      --  warning if not and sets the Raises_Constraint_Error Flag in N.
+
+      procedure Check_Length (L, H : Node_Id; Len : Uint);
+      --  Checks that range L .. H contains at least Len elements. Emits a
+      --  warning if not and sets the Raises_Constraint_Error Flag in N.
+
+      function Dynamic_Or_Null_Range (L, H : Node_Id) return Boolean;
+      --  Returns True if range L .. H is dynamic or null.
+
+      procedure Get (Value : out Uint; From : Node_Id; OK : out Boolean);
+      --  Given expression node From, this routine sets OK to False if it
+      --  cannot statically evaluate From. Otherwise it stores this static
+      --  value into Value.
+
+      function Resolve_Aggr_Expr
+        (Expr        : Node_Id;
+         Single_Elmt : Boolean)
+         return        Boolean;
+      --  Resolves aggregate expression Expr. Returs False if resolution
+      --  fails. If Single_Elmt is set to False, the expression Expr may be
+      --  used to initialize several array aggregate elements (this can
+      --  happen for discrete choices such as "L .. H => Expr" or the others
+      --  choice). In this event we do not resolve Expr unless expansion is
+      --  disabled. To know why, see the DELAYED COMPONENT RESOLUTION
+      --  note above.
+
+      ---------
+      -- Add --
+      ---------
+
+      function Add (Val : Uint; To : Node_Id) return Node_Id is
+         Expr_Pos : Node_Id;
+         Expr     : Node_Id;
+         To_Pos   : Node_Id;
+
+      begin
+         if Raises_Constraint_Error (To) then
+            return To;
+         end if;
+
+         --  First test if we can do constant folding
+
+         if Compile_Time_Known_Value (To)
+           or else Nkind (To) = N_Integer_Literal
+         then
+            Expr_Pos := Make_Integer_Literal (Loc, Expr_Value (To) + Val);
+            Set_Is_Static_Expression (Expr_Pos);
+            Set_Etype (Expr_Pos, Etype (To));
+            Set_Analyzed (Expr_Pos, Analyzed (To));
+
+            if not Is_Enumeration_Type (Index_Typ) then
+               Expr := Expr_Pos;
+
+            --  If we are dealing with enumeration return
+            --     Index_Typ'Val (Expr_Pos)
+
+            else
+               Expr :=
+                 Make_Attribute_Reference
+                   (Loc,
+                    Prefix         => New_Reference_To (Index_Typ, Loc),
+                    Attribute_Name => Name_Val,
+                    Expressions    => New_List (Expr_Pos));
+            end if;
+
+            return Expr;
+         end if;
+
+         --  If we are here no constant folding possible
+
+         if not Is_Enumeration_Type (Index_Base) then
+            Expr :=
+              Make_Op_Add (Loc,
+                           Left_Opnd  => Duplicate_Subexpr (To),
+                           Right_Opnd => Make_Integer_Literal (Loc, Val));
+
+         --  If we are dealing with enumeration return
+         --    Index_Typ'Val (Index_Typ'Pos (To) + Val)
+
+         else
+            To_Pos :=
+              Make_Attribute_Reference
+                (Loc,
+                 Prefix         => New_Reference_To (Index_Typ, Loc),
+                 Attribute_Name => Name_Pos,
+                 Expressions    => New_List (Duplicate_Subexpr (To)));
+
+            Expr_Pos :=
+              Make_Op_Add (Loc,
+                           Left_Opnd  => To_Pos,
+                           Right_Opnd => Make_Integer_Literal (Loc, Val));
+
+            Expr :=
+              Make_Attribute_Reference
+                (Loc,
+                 Prefix         => New_Reference_To (Index_Typ, Loc),
+                 Attribute_Name => Name_Val,
+                 Expressions    => New_List (Expr_Pos));
+         end if;
+
+         return Expr;
+      end Add;
+
+      -----------------
+      -- Check_Bound --
+      -----------------
+
+      procedure Check_Bound (BH : Node_Id; AH : in out Node_Id) is
+         Val_BH : Uint;
+         Val_AH : Uint;
+
+         OK_BH : Boolean;
+         OK_AH : Boolean;
+
+      begin
+         Get (Value => Val_BH, From => BH, OK => OK_BH);
+         Get (Value => Val_AH, From => AH, OK => OK_AH);
+
+         if OK_BH and then OK_AH and then Val_BH < Val_AH then
+            Set_Raises_Constraint_Error (N);
+            Error_Msg_N ("upper bound out of range?", AH);
+            Error_Msg_N ("Constraint_Error will be raised at run-time?", AH);
+
+            --  You need to set AH to BH or else in the case of enumerations
+            --  indices we will not be able to resolve the aggregate bounds.
+
+            AH := Duplicate_Subexpr (BH);
+         end if;
+      end Check_Bound;
+
+      ------------------
+      -- Check_Bounds --
+      ------------------
+
+      procedure Check_Bounds (L, H : Node_Id; AL, AH : Node_Id) is
+         Val_L  : Uint;
+         Val_H  : Uint;
+         Val_AL : Uint;
+         Val_AH : Uint;
+
+         OK_L  : Boolean;
+         OK_H  : Boolean;
+         OK_AL : Boolean;
+         OK_AH : Boolean;
+
+      begin
+         if Raises_Constraint_Error (N)
+           or else Dynamic_Or_Null_Range (AL, AH)
+         then
+            return;
+         end if;
+
+         Get (Value => Val_L, From => L, OK => OK_L);
+         Get (Value => Val_H, From => H, OK => OK_H);
+
+         Get (Value => Val_AL, From => AL, OK => OK_AL);
+         Get (Value => Val_AH, From => AH, OK => OK_AH);
+
+         if OK_L and then Val_L > Val_AL then
+            Set_Raises_Constraint_Error (N);
+            Error_Msg_N ("lower bound of aggregate out of range?", N);
+            Error_Msg_N ("Constraint_Error will be raised at run-time?", N);
+         end if;
+
+         if OK_H and then Val_H < Val_AH then
+            Set_Raises_Constraint_Error (N);
+            Error_Msg_N ("upper bound of aggregate out of range?", N);
+            Error_Msg_N ("Constraint_Error will be raised at run-time?", N);
+         end if;
+      end Check_Bounds;
+
+      ------------------
+      -- Check_Length --
+      ------------------
+
+      procedure Check_Length (L, H : Node_Id; Len : Uint) is
+         Val_L  : Uint;
+         Val_H  : Uint;
+
+         OK_L  : Boolean;
+         OK_H  : Boolean;
+
+         Range_Len : Uint;
+
+      begin
+         if Raises_Constraint_Error (N) then
+            return;
+         end if;
+
+         Get (Value => Val_L, From => L, OK => OK_L);
+         Get (Value => Val_H, From => H, OK => OK_H);
+
+         if not OK_L or else not OK_H then
+            return;
+         end if;
+
+         --  If null range length is zero
+
+         if Val_L > Val_H then
+            Range_Len := Uint_0;
+         else
+            Range_Len := Val_H - Val_L + 1;
+         end if;
+
+         if Range_Len < Len then
+            Set_Raises_Constraint_Error (N);
+            Error_Msg_N ("Too many elements?", N);
+            Error_Msg_N ("Constraint_Error will be raised at run-time?", N);
+         end if;
+      end Check_Length;
+
+      ---------------------------
+      -- Dynamic_Or_Null_Range --
+      ---------------------------
+
+      function Dynamic_Or_Null_Range (L, H : Node_Id) return Boolean is
+         Val_L : Uint;
+         Val_H : Uint;
+
+         OK_L  : Boolean;
+         OK_H  : Boolean;
+
+      begin
+         Get (Value => Val_L, From => L, OK => OK_L);
+         Get (Value => Val_H, From => H, OK => OK_H);
+
+         return not OK_L or else not OK_H
+           or else not Is_OK_Static_Expression (L)
+           or else not Is_OK_Static_Expression (H)
+           or else Val_L > Val_H;
+      end Dynamic_Or_Null_Range;
+
+      ---------
+      -- Get --
+      ---------
+
+      procedure Get (Value : out Uint; From : Node_Id; OK : out Boolean) is
+      begin
+         OK := True;
+
+         if Compile_Time_Known_Value (From) then
+            Value := Expr_Value (From);
+
+         --  If expression From is something like Some_Type'Val (10) then
+         --  Value = 10
+
+         elsif Nkind (From) = N_Attribute_Reference
+           and then Attribute_Name (From) = Name_Val
+           and then Compile_Time_Known_Value (First (Expressions (From)))
+         then
+            Value := Expr_Value (First (Expressions (From)));
+
+         else
+            Value := Uint_0;
+            OK := False;
+         end if;
+      end Get;
+
+      -----------------------
+      -- Resolve_Aggr_Expr --
+      -----------------------
+
+      function Resolve_Aggr_Expr
+        (Expr        : Node_Id;
+         Single_Elmt : Boolean)
+         return        Boolean
+      is
+         Nxt_Ind        : Node_Id := Next_Index (Index);
+         Nxt_Ind_Constr : Node_Id := Next_Index (Index_Constr);
+         --  Index is the current index corresponding to the expresion.
+
+         Resolution_OK : Boolean := True;
+         --  Set to False if resolution of the expression failed.
+
+      begin
+         --  If the array type against which we are resolving the aggregate
+         --  has several dimensions, the expressions nested inside the
+         --  aggregate must be further aggregates (or strings).
+
+         if Present (Nxt_Ind) then
+            if Nkind (Expr) /= N_Aggregate then
+
+               --  A string literal can appear where a one-dimensional array
+               --  of characters is expected. If the literal looks like an
+               --  operator, it is still an operator symbol, which will be
+               --  transformed into a string when analyzed.
+
+               if Is_Character_Type (Component_Typ)
+                 and then No (Next_Index (Nxt_Ind))
+                 and then (Nkind (Expr) = N_String_Literal
+                            or else Nkind (Expr) = N_Operator_Symbol)
+               then
+                  --  A string literal used in a multidimensional array
+                  --  aggregate in place of the final one-dimensional
+                  --  aggregate must not be enclosed in parentheses.
+
+                  if Paren_Count (Expr) /= 0 then
+                     Error_Msg_N ("No parenthesis allowed here", Expr);
+                  end if;
+
+                  Make_String_Into_Aggregate (Expr);
+
+               else
+                  Error_Msg_N ("nested array aggregate expected", Expr);
+                  return Failure;
+               end if;
+            end if;
+
+            Resolution_OK := Resolve_Array_Aggregate
+              (Expr, Nxt_Ind, Nxt_Ind_Constr, Component_Typ, Others_Allowed);
+
+         --  Do not resolve the expressions of discrete or others choices
+         --  unless the expression covers a single component, or the expander
+         --  is inactive.
+
+         elsif Single_Elmt
+           or else not Expander_Active
+           or else In_Default_Expression
+         then
+            Analyze_And_Resolve (Expr, Component_Typ);
+            Check_Non_Static_Context (Expr);
+            Aggregate_Constraint_Checks (Expr, Component_Typ);
+         end if;
+
+         if Raises_Constraint_Error (Expr)
+           and then Nkind (Parent (Expr)) /= N_Component_Association
+         then
+            Set_Raises_Constraint_Error (N);
+         end if;
+
+         return Resolution_OK;
+      end Resolve_Aggr_Expr;
+
+      --  Variables local to Resolve_Array_Aggregate
+
+      Assoc   : Node_Id;
+      Choice  : Node_Id;
+      Expr    : Node_Id;
+
+      Who_Cares : Node_Id;
+
+      Aggr_Low  : Node_Id := Empty;
+      Aggr_High : Node_Id := Empty;
+      --  The actual low and high bounds of this sub-aggegate
+
+      Choices_Low  : Node_Id := Empty;
+      Choices_High : Node_Id := Empty;
+      --  The lowest and highest discrete choices values for a named aggregate
+
+      Nb_Elements : Uint := Uint_0;
+      --  The number of elements in a positional aggegate
+
+      Others_Present : Boolean := False;
+
+      Nb_Choices : Nat := 0;
+      --  Contains the overall number of named choices in this sub-aggregate
+
+      Nb_Discrete_Choices : Nat := 0;
+      --  The overall number of discrete choices (not counting others choice)
+
+      Case_Table_Size : Nat;
+      --  Contains the size of the case table needed to sort aggregate choices
+
+   --  Start of processing for Resolve_Array_Aggregate
+
+   begin
+      --  STEP 1: make sure the aggregate is correctly formatted
+
+      if Present (Component_Associations (N)) then
+         Assoc := First (Component_Associations (N));
+         while Present (Assoc) loop
+            Choice := First (Choices (Assoc));
+            while Present (Choice) loop
+               if Nkind (Choice) = N_Others_Choice then
+                  Others_Present := True;
+
+                  if Choice /= First (Choices (Assoc))
+                    or else Present (Next (Choice))
+                  then
+                     Error_Msg_N
+                       ("OTHERS must appear alone in a choice list", Choice);
+                     return Failure;
+                  end if;
+
+                  if Present (Next (Assoc)) then
+                     Error_Msg_N
+                       ("OTHERS must appear last in an aggregate", Choice);
+                     return Failure;
+                  end if;
+
+                  if Ada_83
+                    and then Assoc /= First (Component_Associations (N))
+                    and then (Nkind (Parent (N)) = N_Assignment_Statement
+                               or else
+                                 Nkind (Parent (N)) = N_Object_Declaration)
+                  then
+                     Error_Msg_N
+                       ("(Ada 83) illegal context for OTHERS choice", N);
+                  end if;
+               end if;
+
+               Nb_Choices := Nb_Choices + 1;
+               Next (Choice);
+            end loop;
+
+            Next (Assoc);
+         end loop;
+      end if;
+
+      --  At this point we know that the others choice, if present, is by
+      --  itself and appears last in the aggregate. Check if we have mixed
+      --  positional and discrete associations (other than the others choice).
+
+      if Present (Expressions (N))
+        and then (Nb_Choices > 1
+                   or else (Nb_Choices = 1 and then not Others_Present))
+      then
+         Error_Msg_N
+           ("named association cannot follow positional association",
+            First (Choices (First (Component_Associations (N)))));
+         return Failure;
+      end if;
+
+      --  Test for the validity of an others choice if present
+
+      if Others_Present and then not Others_Allowed then
+         Error_Msg_N
+           ("OTHERS choice not allowed here",
+            First (Choices (First (Component_Associations (N)))));
+         return Failure;
+      end if;
+
+      --  STEP 2: Process named components
+
+      if No (Expressions (N)) then
+
+         if Others_Present then
+            Case_Table_Size := Nb_Choices - 1;
+         else
+            Case_Table_Size := Nb_Choices;
+         end if;
+
+         Step_2 : declare
+            Low  : Node_Id;
+            High : Node_Id;
+            --  Denote the lowest and highest values in an aggregate choice
+
+            Hi_Val : Uint;
+            Lo_Val : Uint;
+            --  High end of one range and Low end of the next. Should be
+            --  contiguous if there is no hole in the list of values.
+
+            Missing_Values : Boolean;
+            --  Set True if missing index values
+
+            S_Low  : Node_Id := Empty;
+            S_High : Node_Id := Empty;
+            --  if a choice in an aggregate is a subtype indication these
+            --  denote the lowest and highest values of the subtype
+
+            Table : Case_Table_Type (1 .. Case_Table_Size);
+            --  Used to sort all the different choice values
+
+            Single_Choice : Boolean;
+            --  Set to true every time there is a single discrete choice in a
+            --  discrete association
+
+            Prev_Nb_Discrete_Choices : Nat;
+            --  Used to keep track of the number of discrete choices
+            --  in the current association.
+
+         begin
+            --  STEP 2 (A): Check discrete choices validity.
+
+            Assoc := First (Component_Associations (N));
+            while Present (Assoc) loop
+
+               Prev_Nb_Discrete_Choices := Nb_Discrete_Choices;
+               Choice := First (Choices (Assoc));
+               loop
+                  Analyze (Choice);
+
+                  if Nkind (Choice) = N_Others_Choice then
+                     Single_Choice := False;
+                     exit;
+
+                  --  Test for subtype mark without constraint
+
+                  elsif Is_Entity_Name (Choice) and then
+                    Is_Type (Entity (Choice))
+                  then
+                     if Base_Type (Entity (Choice)) /= Index_Base then
+                        Error_Msg_N
+                          ("invalid subtype mark in aggregate choice",
+                           Choice);
+                        return Failure;
+                     end if;
+
+                  elsif Nkind (Choice) = N_Subtype_Indication then
+                     Resolve_Discrete_Subtype_Indication (Choice, Index_Base);
+
+                     --  Does the subtype indication evaluation raise CE ?
+
+                     Get_Index_Bounds (Subtype_Mark (Choice), S_Low, S_High);
+                     Get_Index_Bounds (Choice, Low, High);
+                     Check_Bounds (S_Low, S_High, Low, High);
+
+                  else  --  Choice is a range or an expression
+                     Resolve (Choice, Index_Base);
+                     Check_Non_Static_Context (Choice);
+
+                     --  Do not range check a choice. This check is redundant
+                     --  since this test is already performed when we check
+                     --  that the bounds of the array aggregate are within
+                     --  range.
+
+                     Set_Do_Range_Check (Choice, False);
+                  end if;
+
+                  --  If we could not resolve the discrete choice stop here
+
+                  if Etype (Choice) = Any_Type then
+                     return Failure;
+
+                  --  If the discrete choice raises CE get its original bounds.
+
+                  elsif Nkind (Choice) = N_Raise_Constraint_Error then
+                     Set_Raises_Constraint_Error (N);
+                     Get_Index_Bounds (Original_Node (Choice), Low, High);
+
+                  --  Otherwise get its bounds as usual
+
+                  else
+                     Get_Index_Bounds (Choice, Low, High);
+                  end if;
+
+                  if (Dynamic_Or_Null_Range (Low, High)
+                       or else (Nkind (Choice) = N_Subtype_Indication
+                                 and then
+                                   Dynamic_Or_Null_Range (S_Low, S_High)))
+                    and then Nb_Choices /= 1
+                  then
+                     Error_Msg_N
+                       ("dynamic or empty choice in aggregate " &
+                        "must be the only choice", Choice);
+                     return Failure;
+                  end if;
+
+                  Nb_Discrete_Choices := Nb_Discrete_Choices + 1;
+                  Table (Nb_Discrete_Choices).Choice_Lo := Low;
+                  Table (Nb_Discrete_Choices).Choice_Hi := High;
+
+                  Next (Choice);
+
+                  if No (Choice) then
+                     --  Check if we have a single discrete choice and whether
+                     --  this discrete choice specifies a single value.
+
+                     Single_Choice :=
+                       (Nb_Discrete_Choices = Prev_Nb_Discrete_Choices + 1)
+                         and then (Low = High);
+
+                     exit;
+                  end if;
+               end loop;
+
+               if not
+                 Resolve_Aggr_Expr
+                   (Expression (Assoc), Single_Elmt => Single_Choice)
+               then
+                  return Failure;
+               end if;
+
+               Next (Assoc);
+            end loop;
+
+            --  If aggregate contains more than one choice then these must be
+            --  static. Sort them and check that they are contiguous
+
+            if Nb_Discrete_Choices > 1 then
+               Sort_Case_Table (Table);
+               Missing_Values := False;
+
+               Outer : for J in 1 .. Nb_Discrete_Choices - 1 loop
+                  if Expr_Value (Table (J).Choice_Hi) >=
+                       Expr_Value (Table (J + 1).Choice_Lo)
+                  then
+                     Error_Msg_N
+                       ("duplicate choice values in array aggregate",
+                        Table (J).Choice_Hi);
+                     return Failure;
+
+                  elsif not Others_Present then
+
+                     Hi_Val := Expr_Value (Table (J).Choice_Hi);
+                     Lo_Val := Expr_Value (Table (J + 1).Choice_Lo);
+
+                     --  If missing values, output error messages
+
+                     if Lo_Val - Hi_Val > 1 then
+
+                        --  Header message if not first missing value
+
+                        if not Missing_Values then
+                           Error_Msg_N
+                             ("missing index value(s) in array aggregate", N);
+                           Missing_Values := True;
+                        end if;
+
+                        --  Output values of missing indexes
+
+                        Lo_Val := Lo_Val - 1;
+                        Hi_Val := Hi_Val + 1;
+
+                        --  Enumeration type case
+
+                        if Is_Enumeration_Type (Index_Typ) then
+                           Error_Msg_Name_1 :=
+                             Chars
+                               (Get_Enum_Lit_From_Pos
+                                 (Index_Typ, Hi_Val, Loc));
+
+                           if Lo_Val = Hi_Val then
+                              Error_Msg_N ("\  %", N);
+                           else
+                              Error_Msg_Name_2 :=
+                                Chars
+                                  (Get_Enum_Lit_From_Pos
+                                    (Index_Typ, Lo_Val, Loc));
+                              Error_Msg_N ("\  % .. %", N);
+                           end if;
+
+                        --  Integer types case
+
+                        else
+                           Error_Msg_Uint_1 := Hi_Val;
+
+                           if Lo_Val = Hi_Val then
+                              Error_Msg_N ("\  ^", N);
+                           else
+                              Error_Msg_Uint_2 := Lo_Val;
+                              Error_Msg_N ("\  ^ .. ^", N);
+                           end if;
+                        end if;
+                     end if;
+                  end if;
+               end loop Outer;
+
+               if Missing_Values then
+                  Set_Etype (N, Any_Composite);
+                  return Failure;
+               end if;
+            end if;
+
+            --  STEP 2 (B): Compute aggregate bounds and min/max choices values
+
+            if Nb_Discrete_Choices > 0 then
+               Choices_Low  := Table (1).Choice_Lo;
+               Choices_High := Table (Nb_Discrete_Choices).Choice_Hi;
+            end if;
+
+            if Others_Present then
+               Get_Index_Bounds (Index_Constr, Aggr_Low, Aggr_High);
+
+            else
+               Aggr_Low  := Choices_Low;
+               Aggr_High := Choices_High;
+            end if;
+         end Step_2;
+
+      --  STEP 3: Process positional components
+
+      else
+         --  STEP 3 (A): Process positional elements
+
+         Expr := First (Expressions (N));
+         Nb_Elements := Uint_0;
+         while Present (Expr) loop
+            Nb_Elements := Nb_Elements + 1;
+
+            if not Resolve_Aggr_Expr (Expr, Single_Elmt => True) then
+               return Failure;
+            end if;
+
+            Next (Expr);
+         end loop;
+
+         if Others_Present then
+            Assoc := Last (Component_Associations (N));
+            if not Resolve_Aggr_Expr (Expression (Assoc),
+                                      Single_Elmt => False)
+            then
+               return Failure;
+            end if;
+         end if;
+
+         --  STEP 3 (B): Compute the aggregate bounds
+
+         if Others_Present then
+            Get_Index_Bounds (Index_Constr, Aggr_Low, Aggr_High);
+
+         else
+            if Others_Allowed then
+               Get_Index_Bounds (Index_Constr, Aggr_Low, Who_Cares);
+            else
+               Aggr_Low := Index_Typ_Low;
+            end if;
+
+            Aggr_High := Add (Nb_Elements - 1, To => Aggr_Low);
+            Check_Bound (Index_Base_High, Aggr_High);
+         end if;
+      end if;
+
+      --  STEP 4: Perform static aggregate checks and save the bounds
+
+      --  Check (A)
+
+      Check_Bounds (Index_Typ_Low, Index_Typ_High, Aggr_Low, Aggr_High);
+      Check_Bounds (Index_Base_Low, Index_Base_High, Aggr_Low, Aggr_High);
+
+      --  Check (B)
+
+      if Others_Present and then Nb_Discrete_Choices > 0 then
+         Check_Bounds (Aggr_Low, Aggr_High, Choices_Low, Choices_High);
+         Check_Bounds (Index_Typ_Low, Index_Typ_High,
+                       Choices_Low, Choices_High);
+         Check_Bounds (Index_Base_Low, Index_Base_High,
+                       Choices_Low, Choices_High);
+
+      --  Check (C)
+
+      elsif Others_Present and then Nb_Elements > 0 then
+         Check_Length (Aggr_Low, Aggr_High, Nb_Elements);
+         Check_Length (Index_Typ_Low, Index_Typ_High, Nb_Elements);
+         Check_Length (Index_Base_Low, Index_Base_High, Nb_Elements);
+
+      end if;
+
+      if Raises_Constraint_Error (Aggr_Low)
+        or else Raises_Constraint_Error (Aggr_High)
+      then
+         Set_Raises_Constraint_Error (N);
+      end if;
+
+      Aggr_Low := Duplicate_Subexpr (Aggr_Low);
+
+      --  Do not duplicate Aggr_High if Aggr_High = Aggr_Low + Nb_Elements
+      --  since the addition node returned by Add is not yet analyzed. Attach
+      --  to tree and analyze first. Reset analyzed flag to insure it will get
+      --  analyzed when it is a literal bound whose type must be properly
+      --  set.
+
+      if Others_Present or else Nb_Discrete_Choices > 0 then
+         Aggr_High := Duplicate_Subexpr (Aggr_High);
+
+         if Etype (Aggr_High) = Universal_Integer then
+            Set_Analyzed (Aggr_High, False);
+         end if;
+      end if;
+
+      Set_Aggregate_Bounds
+        (N, Make_Range (Loc, Low_Bound => Aggr_Low, High_Bound => Aggr_High));
+
+      --  The bounds may contain expressions that must be inserted upwards.
+      --  Attach them fully to the tree. After analysis, remove side effects
+      --  from upper bound, if still needed.
+
+      Set_Parent (Aggregate_Bounds (N), N);
+      Analyze_And_Resolve (Aggregate_Bounds (N), Index_Typ);
+
+      if not Others_Present and then Nb_Discrete_Choices = 0 then
+         Set_High_Bound (Aggregate_Bounds (N),
+             Duplicate_Subexpr (High_Bound (Aggregate_Bounds (N))));
+      end if;
+
+      return Success;
+   end Resolve_Array_Aggregate;
+
+   ---------------------------------
+   -- Resolve_Extension_Aggregate --
+   ---------------------------------
+
+   --  There are two cases to consider:
+
+   --  a) If the ancestor part is a type mark, the components needed are
+   --  the difference between the components of the expected type and the
+   --  components of the given type mark.
+
+   --  b) If the ancestor part is an expression, it must be unambiguous,
+   --  and once we have its type we can also compute the needed  components
+   --  as in the previous case. In both cases, if the ancestor type is not
+   --  the immediate ancestor, we have to build this ancestor recursively.
+
+   --  In both cases discriminants of the ancestor type do not play a
+   --  role in the resolution of the needed components, because inherited
+   --  discriminants cannot be used in a type extension. As a result we can
+   --  compute independently the list of components of the ancestor type and
+   --  of the expected type.
+
+   procedure Resolve_Extension_Aggregate (N : Node_Id; Typ : Entity_Id) is
+      A        : constant Node_Id := Ancestor_Part (N);
+      A_Type   : Entity_Id;
+      I        : Interp_Index;
+      It       : Interp;
+      Imm_Type : Entity_Id;
+
+      function Valid_Ancestor_Type return Boolean;
+      --  Verify that the type of the ancestor part is a non-private ancestor
+      --  of the expected type.
+
+      function Valid_Ancestor_Type return Boolean is
+         Imm_Type : Entity_Id;
+
+      begin
+         Imm_Type := Base_Type (Typ);
+         while Is_Derived_Type (Imm_Type)
+           and then Etype (Imm_Type) /= Base_Type (A_Type)
+         loop
+            Imm_Type := Etype (Base_Type (Imm_Type));
+         end loop;
+
+         if Etype (Imm_Type) /= Base_Type (A_Type) then
+            Error_Msg_NE ("expect ancestor type of &", A, Typ);
+            return False;
+         else
+            return True;
+         end if;
+      end Valid_Ancestor_Type;
+
+   --  Start of processing for Resolve_Extension_Aggregate
+
+   begin
+      Analyze (A);
+
+      if not Is_Tagged_Type (Typ) then
+         Error_Msg_N ("type of extension aggregate must be tagged", N);
+         return;
+
+      elsif Is_Limited_Type (Typ) then
+         Error_Msg_N ("aggregate type cannot be limited", N);
+         return;
+
+      elsif Is_Class_Wide_Type (Typ) then
+         Error_Msg_N ("aggregate cannot be of a class-wide type", N);
+         return;
+      end if;
+
+      if Is_Entity_Name (A)
+        and then Is_Type (Entity (A))
+      then
+         A_Type   := Get_Full_View (Entity (A));
+         Imm_Type := Base_Type (Typ);
+
+         if Valid_Ancestor_Type then
+            Set_Entity (A, A_Type);
+            Set_Etype  (A, A_Type);
+
+            Validate_Ancestor_Part (N);
+            Resolve_Record_Aggregate (N, Typ);
+         end if;
+
+      elsif Nkind (A) /= N_Aggregate then
+         if Is_Overloaded (A) then
+            A_Type := Any_Type;
+            Get_First_Interp (A, I, It);
+
+            while Present (It.Typ) loop
+
+               if Is_Tagged_Type (It.Typ)
+                  and then not Is_Limited_Type (It.Typ)
+               then
+                  if A_Type /= Any_Type then
+                     Error_Msg_N ("cannot resolve expression", A);
+                     return;
+                  else
+                     A_Type := It.Typ;
+                  end if;
+               end if;
+
+               Get_Next_Interp (I, It);
+            end loop;
+
+            if A_Type = Any_Type then
+               Error_Msg_N
+                 ("ancestor part must be non-limited tagged type", A);
+               return;
+            end if;
+
+         else
+            A_Type := Etype (A);
+         end if;
+
+         if Valid_Ancestor_Type then
+            Resolve (A, A_Type);
+            Check_Non_Static_Context (A);
+            Resolve_Record_Aggregate (N, Typ);
+         end if;
+
+      else
+         Error_Msg_N (" No unique type for this aggregate",  A);
+      end if;
+
+   end Resolve_Extension_Aggregate;
+
+   ------------------------------
+   -- Resolve_Record_Aggregate --
+   ------------------------------
+
+   procedure Resolve_Record_Aggregate (N : Node_Id; Typ : Entity_Id) is
+      Regular_Aggr    : constant Boolean := Nkind (N) /= N_Extension_Aggregate;
+
+      New_Assoc_List  : List_Id := New_List;
+      New_Assoc       : Node_Id;
+      --  New_Assoc_List is the newly built list of N_Component_Association
+      --  nodes. New_Assoc is one such N_Component_Association node in it.
+      --  Please note that while Assoc and New_Assoc contain the same
+      --  kind of nodes, they are used to iterate over two different
+      --  N_Component_Association lists.
+
+      Others_Etype : Entity_Id := Empty;
+      --  This variable is used to save the Etype of the last record component
+      --  that takes its value from the others choice. Its purpose is:
+      --
+      --    (a) make sure the others choice is useful
+      --
+      --    (b) make sure the type of all the components whose value is
+      --        subsumed by the others choice are the same.
+      --
+      --  This variable is updated as a side effect of function Get_Value
+
+      procedure Add_Association (Component : Entity_Id; Expr : Node_Id);
+      --  Builds a new N_Component_Association node which associates
+      --  Component to expression Expr and adds it to the new association
+      --  list New_Assoc_List being built.
+
+      function Discr_Present (Discr : Entity_Id) return Boolean;
+      --  If aggregate N is a regular aggregate this routine will return True.
+      --  Otherwise, if N is an extension aggreagte, Discr is a discriminant
+      --  whose value may already have been specified by N's ancestor part,
+      --  this routine checks whether this is indeed the case and if so
+      --  returns False, signaling that no value for Discr should appear in the
+      --  N's aggregate part. Also, in this case, the routine appends to
+      --  New_Assoc_List Discr the discriminant value specified in the ancestor
+      --  part.
+
+      function Get_Value
+        (Compon                 : Node_Id;
+         From                   : List_Id;
+         Consider_Others_Choice : Boolean := False)
+         return                   Node_Id;
+      --  Given a record component stored in parameter Compon, the
+      --  following function returns its value as it appears in the list
+      --  From, which is a list of N_Component_Association nodes. If no
+      --  component association has a choice for the searched component,
+      --  the value provided by the others choice is returned, if there
+      --  is  one and Consider_Others_Choice is set to true. Otherwise
+      --  Empty is returned. If there is more than one component association
+      --  giving a value for the searched record component, an error message
+      --  is emitted and the first found value is returned.
+      --
+      --  If Consider_Others_Choice is set and the returned expression comes
+      --  from the others choice, then Others_Etype is set as a side effect.
+      --  An error message is emitted if the components taking their value
+      --  from the others choice do not have same type.
+
+      procedure Resolve_Aggr_Expr (Expr : Node_Id; Component : Node_Id);
+      --  Analyzes and resolves expression Expr against the Etype of the
+      --  Component. This routine also applies all appropiate checks to Expr.
+      --  It finally saves a Expr in the newly created association list that
+      --  will be attached to the final record aggregate. Note that if the
+      --  Parent pointer of Expr is not set then Expr was produced with a
+      --  New_copy_Tree or some such.
+
+      ---------------------
+      -- Add_Association --
+      ---------------------
+
+      procedure Add_Association (Component : Entity_Id; Expr : Node_Id) is
+         New_Assoc   : Node_Id;
+         Choice_List : List_Id := New_List;
+
+      begin
+         Append (New_Occurrence_Of (Component, Sloc (Expr)), Choice_List);
+         New_Assoc :=
+           Make_Component_Association (Sloc (Expr),
+             Choices    => Choice_List,
+             Expression => Expr);
+         Append (New_Assoc, New_Assoc_List);
+      end Add_Association;
+
+      -------------------
+      -- Discr_Present --
+      -------------------
+
+      function Discr_Present (Discr : Entity_Id) return Boolean is
+         Loc : Source_Ptr;
+
+         Ancestor     : Node_Id;
+         Discr_Expr   : Node_Id;
+
+         Ancestor_Typ : Entity_Id;
+         Orig_Discr   : Entity_Id;
+         D            : Entity_Id;
+         D_Val        : Elmt_Id := No_Elmt; -- stop junk warning
+
+         Ancestor_Is_Subtyp : Boolean;
+
+      begin
+         if Regular_Aggr then
+            return True;
+         end if;
+
+         Ancestor     := Ancestor_Part (N);
+         Ancestor_Typ := Etype (Ancestor);
+         Loc          := Sloc (Ancestor);
+
+         Ancestor_Is_Subtyp :=
+           Is_Entity_Name (Ancestor) and then Is_Type (Entity (Ancestor));
+
+         --  If the ancestor part has no discriminants clearly N's aggregate
+         --  part must provide a value for Discr.
+
+         if not Has_Discriminants (Ancestor_Typ) then
+            return True;
+
+         --  If the ancestor part is an unconstrained subtype mark then the
+         --  Discr must be present in N's aggregate part.
+
+         elsif Ancestor_Is_Subtyp
+           and then not Is_Constrained (Entity (Ancestor))
+         then
+            return True;
+         end if;
+
+         --  Now look to see if Discr was specified in the ancestor part.
+
+         Orig_Discr := Original_Record_Component (Discr);
+         D          := First_Discriminant (Ancestor_Typ);
+
+         if Ancestor_Is_Subtyp then
+            D_Val := First_Elmt (Discriminant_Constraint (Entity (Ancestor)));
+         end if;
+
+         while Present (D) loop
+            --  If Ancestor has already specified Disc value than
+            --  insert its value in the final aggregate.
+
+            if Original_Record_Component (D) = Orig_Discr then
+               if Ancestor_Is_Subtyp then
+                  Discr_Expr := New_Copy_Tree (Node (D_Val));
+               else
+                  Discr_Expr :=
+                    Make_Selected_Component (Loc,
+                      Prefix        => Duplicate_Subexpr (Ancestor),
+                      Selector_Name => New_Occurrence_Of (Discr, Loc));
+               end if;
+
+               Resolve_Aggr_Expr (Discr_Expr, Discr);
+               return False;
+            end if;
+
+            Next_Discriminant (D);
+
+            if Ancestor_Is_Subtyp then
+               Next_Elmt (D_Val);
+            end if;
+         end loop;
+
+         return True;
+      end Discr_Present;
+
+      ---------------
+      -- Get_Value --
+      ---------------
+
+      function Get_Value
+        (Compon                 : Node_Id;
+         From                   : List_Id;
+         Consider_Others_Choice : Boolean := False)
+         return                   Node_Id
+      is
+         Assoc         : Node_Id;
+         Expr          : Node_Id := Empty;
+         Selector_Name : Node_Id;
+
+      begin
+         if Present (From) then
+            Assoc := First (From);
+         else
+            return Empty;
+         end if;
+
+         while Present (Assoc) loop
+            Selector_Name := First (Choices (Assoc));
+            while Present (Selector_Name) loop
+               if Nkind (Selector_Name) = N_Others_Choice then
+                  if Consider_Others_Choice and then No (Expr) then
+                     if Present (Others_Etype) and then
+                        Base_Type (Others_Etype) /= Base_Type (Etype (Compon))
+                     then
+                        Error_Msg_N ("components in OTHERS choice must " &
+                                     "have same type", Selector_Name);
+                     end if;
+
+                     Others_Etype := Etype (Compon);
+
+                     --  We need to duplicate the expression for each
+                     --  successive component covered by the others choice.
+                     --  If the expression is itself an array aggregate with
+                     --  "others", its subtype must be obtained from the
+                     --  current component, and therefore it must be (at least
+                     --  partly) reanalyzed.
+
+                     if Analyzed (Expression (Assoc)) then
+                        Expr := New_Copy_Tree (Expression (Assoc));
+
+                        if Nkind (Expr) = N_Aggregate
+                          and then Is_Array_Type (Etype (Expr))
+                          and then No (Expressions (Expr))
+                          and then
+                            Nkind (First (Choices
+                              (First (Component_Associations (Expr)))))
+                                = N_Others_Choice
+                        then
+                           Set_Analyzed (Expr, False);
+                        end if;
+
+                        return Expr;
+
+                     else
+                        return Expression (Assoc);
+                     end if;
+                  end if;
+
+               elsif Chars (Compon) = Chars (Selector_Name) then
+                  if No (Expr) then
+                     --  We need to duplicate the expression when several
+                     --  components are grouped together with a "|" choice.
+                     --  For instance "filed1 | filed2 => Expr"
+
+                     if Present (Next (Selector_Name)) then
+                        Expr := New_Copy_Tree (Expression (Assoc));
+                     else
+                        Expr := Expression (Assoc);
+                     end if;
+
+                  else
+                     Error_Msg_NE
+                       ("more than one value supplied for &",
+                        Selector_Name, Compon);
+
+                  end if;
+               end if;
+
+               Next (Selector_Name);
+            end loop;
+
+            Next (Assoc);
+         end loop;
+
+         return Expr;
+      end Get_Value;
+
+      -----------------------
+      -- Resolve_Aggr_Expr --
+      -----------------------
+
+      procedure Resolve_Aggr_Expr (Expr : Node_Id; Component : Node_Id) is
+         New_C     : Entity_Id := Component;
+         Expr_Type : Entity_Id := Empty;
+
+         function Has_Expansion_Delayed (Expr : Node_Id) return Boolean;
+         --  If the expression is an aggregate (possibly qualified) then its
+         --  expansion is delayed until the enclosing aggregate is expanded
+         --  into assignments. In that case, do not generate checks on the
+         --  expression, because they will be generated later, and will other-
+         --  wise force a copy (to remove side-effects) that would leave a
+         --  dynamic-sized aggregate in the code, something that gigi cannot
+         --  handle.
+
+         Relocate  : Boolean;
+         --  Set to True if the resolved Expr node needs to be relocated
+         --  when attached to the newly created association list. This node
+         --  need not be relocated if its parent pointer is not set.
+         --  In fact in this case Expr is the output of a New_Copy_Tree call.
+         --  if Relocate is True then we have analyzed the expression node
+         --  in the original aggregate and hence it needs to be relocated
+         --  when moved over the new association list.
+
+         function Has_Expansion_Delayed (Expr : Node_Id) return Boolean is
+            Kind : constant Node_Kind := Nkind (Expr);
+
+         begin
+            return ((Kind = N_Aggregate
+                       or else Kind = N_Extension_Aggregate)
+                     and then Present (Etype (Expr))
+                     and then Is_Record_Type (Etype (Expr))
+                     and then Expansion_Delayed (Expr))
+
+              or else (Kind = N_Qualified_Expression
+                        and then Has_Expansion_Delayed (Expression (Expr)));
+         end Has_Expansion_Delayed;
+
+      --  Start of processing for  Resolve_Aggr_Expr
+
+      begin
+         --  If the type of the component is elementary or the type of the
+         --  aggregate does not contain discriminants, use the type of the
+         --  component to resolve Expr.
+
+         if Is_Elementary_Type (Etype (Component))
+           or else not Has_Discriminants (Etype (N))
+         then
+            Expr_Type := Etype (Component);
+
+         --  Otherwise we have to pick up the new type of the component from
+         --  the new costrained subtype of the aggregate. In fact components
+         --  which are of a composite type might be constrained by a
+         --  discriminant, and we want to resolve Expr against the subtype were
+         --  all discriminant occurrences are replaced with their actual value.
+
+         else
+            New_C := First_Component (Etype (N));
+            while Present (New_C) loop
+               if Chars (New_C) = Chars (Component) then
+                  Expr_Type := Etype (New_C);
+                  exit;
+               end if;
+
+               Next_Component (New_C);
+            end loop;
+
+            pragma Assert (Present (Expr_Type));
+
+            --  For each range in an array type where a discriminant has been
+            --  replaced with the constraint, check that this range is within
+            --  the range of the base type. This checks is done in the
+            --  _init_proc for regular objects, but has to be done here for
+            --  aggregates since no _init_proc is called for them.
+
+            if Is_Array_Type (Expr_Type) then
+               declare
+                  Index          : Node_Id := First_Index (Expr_Type);
+                  --  Range of the current constrained index in the array.
+
+                  Orig_Index     : Node_Id := First_Index (Etype (Component));
+                  --  Range corresponding to the range Index above in the
+                  --  original unconstrained record type. The bounds of this
+                  --  range may be governed by discriminants.
+
+                  Unconstr_Index : Node_Id := First_Index (Etype (Expr_Type));
+                  --  Range corresponding to the range Index above for the
+                  --  unconstrained array type. This range is needed to apply
+                  --  range checks.
+
+               begin
+                  while Present (Index) loop
+                     if Depends_On_Discriminant (Orig_Index) then
+                        Apply_Range_Check (Index, Etype (Unconstr_Index));
+                     end if;
+
+                     Next_Index (Index);
+                     Next_Index (Orig_Index);
+                     Next_Index (Unconstr_Index);
+                  end loop;
+               end;
+            end if;
+         end if;
+
+         --  If the Parent pointer of Expr is not set, Expr is an expression
+         --  duplicated by New_Tree_Copy (this happens for record aggregates
+         --  that look like (Field1 | Filed2 => Expr) or (others => Expr)).
+         --  Such a duplicated expression must be attached to the tree
+         --  before analysis and resolution to enforce the rule that a tree
+         --  fragment should never be analyzed or resolved unless it is
+         --  attached to the current compilation unit.
+
+         if No (Parent (Expr)) then
+            Set_Parent (Expr, N);
+            Relocate := False;
+         else
+            Relocate := True;
+         end if;
+
+         Analyze_And_Resolve (Expr, Expr_Type);
+         Check_Non_Static_Context (Expr);
+
+         if not Has_Expansion_Delayed (Expr) then
+            Aggregate_Constraint_Checks (Expr, Expr_Type);
+         end if;
+
+         if Raises_Constraint_Error (Expr) then
+            Set_Raises_Constraint_Error (N);
+         end if;
+
+         if Relocate then
+            Add_Association (New_C, Relocate_Node (Expr));
+         else
+            Add_Association (New_C, Expr);
+         end if;
+
+      end Resolve_Aggr_Expr;
+
+      --  Resolve_Record_Aggregate local variables
+
+      Assoc : Node_Id;
+      --  N_Component_Association node belonging to the input aggregate N
+
+      Expr            : Node_Id;
+      Positional_Expr : Node_Id;
+
+      Component      : Entity_Id;
+      Component_Elmt : Elmt_Id;
+      Components     : Elist_Id := New_Elmt_List;
+      --  Components is the list of the record components whose value must
+      --  be provided in the aggregate. This list does include discriminants.
+
+   --  Start of processing for Resolve_Record_Aggregate
+
+   begin
+      --  We may end up calling Duplicate_Subexpr on expressions that are
+      --  attached to New_Assoc_List. For this reason we need to attach it
+      --  to the tree by setting its parent pointer to N. This parent point
+      --  will change in STEP 8 below.
+
+      Set_Parent (New_Assoc_List, N);
+
+      --  STEP 1: abstract type and null record verification
+
+      if Is_Abstract (Typ) then
+         Error_Msg_N ("type of aggregate cannot be abstract",  N);
+      end if;
+
+      if No (First_Entity (Typ)) and then Null_Record_Present (N) then
+         Set_Etype (N, Typ);
+         return;
+
+      elsif Present (First_Entity (Typ))
+        and then Null_Record_Present (N)
+        and then not Is_Tagged_Type (Typ)
+      then
+         Error_Msg_N ("record aggregate cannot be null", N);
+         return;
+
+      elsif No (First_Entity (Typ)) then
+         Error_Msg_N ("record aggregate must be null", N);
+         return;
+      end if;
+
+      --  STEP 2: Verify aggregate structure
+
+      Step_2 : declare
+         Selector_Name : Node_Id;
+         Bad_Aggregate : Boolean := False;
+
+      begin
+         if Present (Component_Associations (N)) then
+            Assoc := First (Component_Associations (N));
+         else
+            Assoc := Empty;
+         end if;
+
+         while Present (Assoc) loop
+            Selector_Name := First (Choices (Assoc));
+            while Present (Selector_Name) loop
+               if Nkind (Selector_Name) = N_Identifier then
+                  null;
+
+               elsif Nkind (Selector_Name) = N_Others_Choice then
+                  if Selector_Name /= First (Choices (Assoc))
+                    or else Present (Next (Selector_Name))
+                  then
+                     Error_Msg_N ("OTHERS must appear alone in a choice list",
+                                  Selector_Name);
+                     return;
+
+                  elsif Present (Next (Assoc)) then
+                     Error_Msg_N ("OTHERS must appear last in an aggregate",
+                                  Selector_Name);
+                     return;
+                  end if;
+
+               else
+                  Error_Msg_N
+                    ("selector name should be identifier or OTHERS",
+                     Selector_Name);
+                  Bad_Aggregate := True;
+               end if;
+
+               Next (Selector_Name);
+            end loop;
+
+            Next (Assoc);
+         end loop;
+
+         if Bad_Aggregate then
+            return;
+         end if;
+      end Step_2;
+
+      --  STEP 3: Find discriminant Values
+
+      Step_3 : declare
+         Discrim               : Entity_Id;
+         Missing_Discriminants : Boolean := False;
+
+      begin
+         if Present (Expressions (N)) then
+            Positional_Expr := First (Expressions (N));
+         else
+            Positional_Expr := Empty;
+         end if;
+
+         if Has_Discriminants (Typ) then
+            Discrim := First_Discriminant (Typ);
+         else
+            Discrim := Empty;
+         end if;
+
+         --  First find the discriminant values in the positional components
+
+         while Present (Discrim) and then Present (Positional_Expr) loop
+            if Discr_Present (Discrim) then
+               Resolve_Aggr_Expr (Positional_Expr, Discrim);
+               Next (Positional_Expr);
+            end if;
+
+            if Present (Get_Value (Discrim, Component_Associations (N))) then
+               Error_Msg_NE
+                 ("more than one value supplied for discriminant&",
+                  N, Discrim);
+            end if;
+
+            Next_Discriminant (Discrim);
+         end loop;
+
+         --  Find remaining discriminant values, if any, among named components
+
+         while Present (Discrim) loop
+            Expr := Get_Value (Discrim, Component_Associations (N), True);
+
+            if not Discr_Present (Discrim) then
+               if Present (Expr) then
+                  Error_Msg_NE
+                    ("more than one value supplied for discriminant&",
+                     N, Discrim);
+               end if;
+
+            elsif No (Expr) then
+               Error_Msg_NE
+                 ("no value supplied for discriminant &", N, Discrim);
+               Missing_Discriminants := True;
+
+            else
+               Resolve_Aggr_Expr (Expr, Discrim);
+            end if;
+
+            Next_Discriminant (Discrim);
+         end loop;
+
+         if Missing_Discriminants then
+            return;
+         end if;
+
+         --  At this point and until the beginning of STEP 6, New_Assoc_List
+         --  contains only the discriminants and their values.
+
+      end Step_3;
+
+      --  STEP 4: Set the Etype of the record aggregate
+
+      --  ??? This code is pretty much a copy of Sem_Ch3.Build_Subtype. That
+      --  routine should really be exported in sem_util or some such and used
+      --  in sem_ch3 and here rather than have a copy of the code which is a
+      --  maintenance nightmare.
+
+      --  ??? Performace WARNING. The current implementation creates a new
+      --  itype for all aggregates whose base type is discriminated.
+      --  This means that for record aggregates nested inside an array
+      --  aggregate we will create a new itype for each record aggregate
+      --  if the array cmponent type has discriminants. For large aggregates
+      --  this may be a problem. What should be done in this case is
+      --  to reuse itypes as much as possible.
+
+      if Has_Discriminants (Typ) then
+         Build_Constrained_Itype : declare
+            Loc         : constant Source_Ptr := Sloc (N);
+            Indic       : Node_Id;
+            Subtyp_Decl : Node_Id;
+            Def_Id      : Entity_Id;
+
+            C : List_Id := New_List;
+
+         begin
+            New_Assoc := First (New_Assoc_List);
+            while Present (New_Assoc) loop
+               Append (Duplicate_Subexpr (Expression (New_Assoc)), To => C);
+               Next (New_Assoc);
+            end loop;
+
+            Indic :=
+              Make_Subtype_Indication (Loc,
+                Subtype_Mark => New_Occurrence_Of (Base_Type (Typ), Loc),
+                Constraint  => Make_Index_Or_Discriminant_Constraint (Loc, C));
+
+            Def_Id := Create_Itype (Ekind (Typ), N);
+
+            Subtyp_Decl :=
+              Make_Subtype_Declaration (Loc,
+                Defining_Identifier => Def_Id,
+                Subtype_Indication  => Indic);
+            Set_Parent (Subtyp_Decl, Parent (N));
+
+            --  Itypes must be analyzed with checks off (see itypes.ads).
+
+            Analyze (Subtyp_Decl, Suppress => All_Checks);
+
+            Set_Etype (N, Def_Id);
+            Check_Static_Discriminated_Subtype
+              (Def_Id, Expression (First (New_Assoc_List)));
+         end Build_Constrained_Itype;
+
+      else
+         Set_Etype (N, Typ);
+      end if;
+
+      --  STEP 5: Get remaining components according to discriminant values
+
+      Step_5 : declare
+         Record_Def      : Node_Id;
+         Parent_Typ      : Entity_Id;
+         Root_Typ        : Entity_Id;
+         Parent_Typ_List : Elist_Id;
+         Parent_Elmt     : Elmt_Id;
+         Errors_Found    : Boolean := False;
+         Dnode           : Node_Id;
+
+      begin
+         if Is_Derived_Type (Typ) and then Is_Tagged_Type (Typ) then
+            Parent_Typ_List := New_Elmt_List;
+
+            --  If this is an extension aggregate, the component list must
+            --  include all components that are not in the given ancestor
+            --  type. Otherwise, the component list must include components
+            --  of all ancestors.
+
+            if Nkind (N) = N_Extension_Aggregate then
+               Root_Typ := Base_Type (Etype (Ancestor_Part (N)));
+            else
+               Root_Typ := Root_Type (Typ);
+
+               if Nkind (Parent (Base_Type (Root_Typ)))
+                    = N_Private_Type_Declaration
+               then
+                  Error_Msg_NE
+                    ("type of aggregate has private ancestor&!",
+                     N, Root_Typ);
+                  Error_Msg_N  ("must use extension aggregate!", N);
+                  return;
+               end if;
+
+               Dnode := Declaration_Node (Base_Type (Root_Typ));
+
+               --  If we don't get a full declaration, then we have some
+               --  error which will get signalled later so skip this part.
+
+               if Nkind (Dnode) = N_Full_Type_Declaration then
+                  Record_Def := Type_Definition (Dnode);
+                  Gather_Components (Typ,
+                    Component_List (Record_Def),
+                    Governed_By   => New_Assoc_List,
+                    Into          => Components,
+                    Report_Errors => Errors_Found);
+               end if;
+            end if;
+
+            Parent_Typ  := Base_Type (Typ);
+            while Parent_Typ /= Root_Typ loop
+
+               Prepend_Elmt (Parent_Typ, To => Parent_Typ_List);
+               Parent_Typ := Etype (Parent_Typ);
+
+               if (Nkind (Parent (Base_Type (Parent_Typ))) =
+                                        N_Private_Type_Declaration
+                    or else Nkind (Parent (Base_Type (Parent_Typ))) =
+                                        N_Private_Extension_Declaration)
+               then
+                  if Nkind (N) /= N_Extension_Aggregate then
+                     Error_Msg_NE
+                       ("type of aggregate has private ancestor&!",
+                        N, Parent_Typ);
+                     Error_Msg_N  ("must use extension aggregate!", N);
+                     return;
+
+                  elsif Parent_Typ /= Root_Typ then
+                     Error_Msg_NE
+                       ("ancestor part of aggregate must be private type&",
+                         Ancestor_Part (N), Parent_Typ);
+                     return;
+                  end if;
+               end if;
+            end loop;
+
+            --  Now collect components from all other ancestors.
+
+            Parent_Elmt := First_Elmt (Parent_Typ_List);
+            while Present (Parent_Elmt) loop
+               Parent_Typ := Node (Parent_Elmt);
+               Record_Def := Type_Definition (Parent (Base_Type (Parent_Typ)));
+               Gather_Components (Empty,
+                 Component_List (Record_Extension_Part (Record_Def)),
+                 Governed_By   => New_Assoc_List,
+                 Into          => Components,
+                 Report_Errors => Errors_Found);
+
+               Next_Elmt (Parent_Elmt);
+            end loop;
+
+         else
+            Record_Def := Type_Definition (Parent (Base_Type (Typ)));
+
+            if Null_Present (Record_Def) then
+               null;
+            else
+               Gather_Components (Typ,
+                 Component_List (Record_Def),
+                 Governed_By   => New_Assoc_List,
+                 Into          => Components,
+                 Report_Errors => Errors_Found);
+            end if;
+         end if;
+
+         if Errors_Found then
+            return;
+         end if;
+      end Step_5;
+
+      --  STEP 6: Find component Values
+
+      Component := Empty;
+      Component_Elmt := First_Elmt (Components);
+
+      --  First scan the remaining positional associations in the aggregate.
+      --  Remember that at this point Positional_Expr contains the current
+      --  positional association if any is left after looking for discriminant
+      --  values in step 3.
+
+      while Present (Positional_Expr) and then Present (Component_Elmt) loop
+         Component := Node (Component_Elmt);
+         Resolve_Aggr_Expr (Positional_Expr, Component);
+
+         if Present (Get_Value (Component, Component_Associations (N))) then
+            Error_Msg_NE
+              ("more than one value supplied for Component &", N, Component);
+         end if;
+
+         Next (Positional_Expr);
+         Next_Elmt (Component_Elmt);
+      end loop;
+
+      if Present (Positional_Expr) then
+         Error_Msg_N
+           ("too many components for record aggregate", Positional_Expr);
+      end if;
+
+      --  Now scan for the named arguments of the aggregate
+
+      while Present (Component_Elmt) loop
+         Component := Node (Component_Elmt);
+         Expr := Get_Value (Component, Component_Associations (N), True);
+
+         if No (Expr) then
+            Error_Msg_NE ("no value supplied for component &!", N, Component);
+         else
+            Resolve_Aggr_Expr (Expr, Component);
+         end if;
+
+         Next_Elmt (Component_Elmt);
+      end loop;
+
+      --  STEP 7: check for invalid components + check type in choice list
+
+      Step_7 : declare
+         Selectr : Node_Id;
+         --  Selector name
+
+         Typech  : Entity_Id;
+         --  Type of first component in choice list
+
+      begin
+         if Present (Component_Associations (N)) then
+            Assoc := First (Component_Associations (N));
+         else
+            Assoc := Empty;
+         end if;
+
+         Verification : while Present (Assoc) loop
+            Selectr := First (Choices (Assoc));
+            Typech := Empty;
+
+            if Nkind (Selectr) = N_Others_Choice then
+               if No (Others_Etype) then
+                  Error_Msg_N
+                    ("OTHERS must represent at least one component", Selectr);
+               end if;
+
+               exit Verification;
+            end if;
+
+            while Present (Selectr) loop
+               New_Assoc := First (New_Assoc_List);
+               while Present (New_Assoc) loop
+                  Component := First (Choices (New_Assoc));
+                  exit when Chars (Selectr) = Chars (Component);
+                  Next (New_Assoc);
+               end loop;
+
+               --  If no association, this is not a legal component of
+               --  of the type in question,  except if this is an internal
+               --  component supplied by a previous expansion.
+
+               if No (New_Assoc) then
+
+                  if Chars (Selectr) /= Name_uTag
+                    and then Chars (Selectr) /= Name_uParent
+                    and then Chars (Selectr) /= Name_uController
+                  then
+                     if not Has_Discriminants (Typ) then
+                        Error_Msg_Node_2 := Typ;
+                        Error_Msg_N
+                          ("& is not a component of}",
+                            Selectr);
+                     else
+                        Error_Msg_N
+                          ("& is not a component of the aggregate subtype",
+                            Selectr);
+                     end if;
+
+                     Check_Misspelled_Component (Components, Selectr);
+                  end if;
+
+               elsif No (Typech) then
+                  Typech := Base_Type (Etype (Component));
+
+               elsif Typech /= Base_Type (Etype (Component)) then
+                  Error_Msg_N
+                    ("components in choice list must have same type", Selectr);
+               end if;
+
+               Next (Selectr);
+            end loop;
+
+            Next (Assoc);
+         end loop Verification;
+      end Step_7;
+
+      --  STEP 8: replace the original aggregate
+
+      Step_8 : declare
+         New_Aggregate : Node_Id := New_Copy (N);
+
+      begin
+         Set_Expressions            (New_Aggregate, No_List);
+         Set_Etype                  (New_Aggregate, Etype (N));
+         Set_Component_Associations (New_Aggregate, New_Assoc_List);
+
+         Rewrite (N, New_Aggregate);
+      end Step_8;
+   end Resolve_Record_Aggregate;
+
+   ---------------------
+   -- Sort_Case_Table --
+   ---------------------
+
+   procedure Sort_Case_Table (Case_Table : in out Case_Table_Type) is
+      L : Int := Case_Table'First;
+      U : Int := Case_Table'Last;
+      K : Int;
+      J : Int;
+      T : Case_Bounds;
+
+   begin
+      K := L;
+
+      while K /= U loop
+         T := Case_Table (K + 1);
+         J := K + 1;
+
+         while J /= L
+           and then Expr_Value (Case_Table (J - 1).Choice_Lo) >
+                    Expr_Value (T.Choice_Lo)
+         loop
+            Case_Table (J) := Case_Table (J - 1);
+            J := J - 1;
+         end loop;
+
+         Case_Table (J) := T;
+         K := K + 1;
+      end loop;
+   end Sort_Case_Table;
+
+end Sem_Aggr;
diff --git a/gcc/ada/sem_aggr.ads b/gcc/ada/sem_aggr.ads
new file mode 100644
index 00000000000..41a4bd759ab
--- /dev/null
+++ b/gcc/ada/sem_aggr.ads
@@ -0,0 +1,39 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             S E M _ A G G R                              --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.3 $                              --
+--                                                                          --
+--        Copyright (C) 1992,1993,1994 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 contains the resolution code for aggregates. It is logically
+--  part of Sem_Res, but is split off since the aggregate code is so complex.
+
+with Types; use Types;
+
+package Sem_Aggr is
+
+   procedure Resolve_Aggregate           (N : Node_Id; Typ : Entity_Id);
+   procedure Resolve_Extension_Aggregate (N : Node_Id; Typ : Entity_Id);
+
+end Sem_Aggr;
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
new file mode 100644
index 00000000000..4574315dbff
--- /dev/null
+++ b/gcc/ada/sem_attr.adb
@@ -0,0 +1,6822 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             S E M _ A T T R                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.552 $
+--                                                                          --
+--          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 Ada.Characters.Latin_1; use Ada.Characters.Latin_1;
+
+with Atree;    use Atree;
+with Checks;   use Checks;
+with Einfo;    use Einfo;
+with Errout;   use Errout;
+with Eval_Fat;
+with Exp_Tss;  use Exp_Tss;
+with Exp_Util; use Exp_Util;
+with Expander; use Expander;
+with Freeze;   use Freeze;
+with Lib.Xref; use Lib.Xref;
+with Namet;    use Namet;
+with Nlists;   use Nlists;
+with Nmake;    use Nmake;
+with Opt;      use Opt;
+with Restrict; use Restrict;
+with Rtsfind;  use Rtsfind;
+with Sem;      use Sem;
+with Sem_Cat;  use Sem_Cat;
+with Sem_Ch6;  use Sem_Ch6;
+with Sem_Ch8;  use Sem_Ch8;
+with Sem_Ch13; use Sem_Ch13;
+with Sem_Dist; use Sem_Dist;
+with Sem_Eval; use Sem_Eval;
+with Sem_Res;  use Sem_Res;
+with Sem_Type; use Sem_Type;
+with Sem_Util; use Sem_Util;
+with Stand;    use Stand;
+with Sinfo;    use Sinfo;
+with Sinput;   use Sinput;
+with Snames;   use Snames;
+with Stand;
+with Stringt;  use Stringt;
+with Targparm; use Targparm;
+with Ttypes;   use Ttypes;
+with Ttypef;   use Ttypef;
+with Tbuild;   use Tbuild;
+with Uintp;    use Uintp;
+with Urealp;   use Urealp;
+with Widechar; use Widechar;
+
+package body Sem_Attr is
+
+   True_Value  : constant Uint := Uint_1;
+   False_Value : constant Uint := Uint_0;
+   --  Synonyms to be used when these constants are used as Boolean values
+
+   Bad_Attribute : exception;
+   --  Exception raised if an error is detected during attribute processing,
+   --  used so that we can abandon the processing so we don't run into
+   --  trouble with cascaded errors.
+
+   --  The following array is the list of attributes defined in the Ada 83 RM
+
+   Attribute_83 : Attribute_Class_Array := Attribute_Class_Array'(
+      Attribute_Address           |
+      Attribute_Aft               |
+      Attribute_Alignment         |
+      Attribute_Base              |
+      Attribute_Callable          |
+      Attribute_Constrained       |
+      Attribute_Count             |
+      Attribute_Delta             |
+      Attribute_Digits            |
+      Attribute_Emax              |
+      Attribute_Epsilon           |
+      Attribute_First             |
+      Attribute_First_Bit         |
+      Attribute_Fore              |
+      Attribute_Image             |
+      Attribute_Large             |
+      Attribute_Last              |
+      Attribute_Last_Bit          |
+      Attribute_Leading_Part      |
+      Attribute_Length            |
+      Attribute_Machine_Emax      |
+      Attribute_Machine_Emin      |
+      Attribute_Machine_Mantissa  |
+      Attribute_Machine_Overflows |
+      Attribute_Machine_Radix     |
+      Attribute_Machine_Rounds    |
+      Attribute_Mantissa          |
+      Attribute_Pos               |
+      Attribute_Position          |
+      Attribute_Pred              |
+      Attribute_Range             |
+      Attribute_Safe_Emax         |
+      Attribute_Safe_Large        |
+      Attribute_Safe_Small        |
+      Attribute_Size              |
+      Attribute_Small             |
+      Attribute_Storage_Size      |
+      Attribute_Succ              |
+      Attribute_Terminated        |
+      Attribute_Val               |
+      Attribute_Value             |
+      Attribute_Width             => True,
+      others                      => False);
+
+   -----------------------
+   -- Local_Subprograms --
+   -----------------------
+
+   procedure Eval_Attribute (N : Node_Id);
+   --  Performs compile time evaluation of attributes where possible, leaving
+   --  the Is_Static_Expression/Raises_Constraint_Error flags appropriately
+   --  set, and replacing the node with a literal node if the value can be
+   --  computed at compile time. All static attribute references are folded,
+   --  as well as a number of cases of non-static attributes that can always
+   --  be computed at compile time (e.g. floating-point model attributes that
+   --  are applied to non-static subtypes). Of course in such cases, the
+   --  Is_Static_Expression flag will not be set on the resulting literal.
+   --  Note that the only required action of this procedure is to catch the
+   --  static expression cases as described in the RM. Folding of other cases
+   --  is done where convenient, but some additional non-static folding is in
+   --  N_Expand_Attribute_Reference in cases where this is more convenient.
+
+   function Is_Anonymous_Tagged_Base
+     (Anon : Entity_Id;
+      Typ  : Entity_Id)
+      return Boolean;
+   --  For derived tagged types that constrain parent discriminants we build
+   --  an anonymous unconstrained base type. We need to recognize the relation
+   --  between the two when analyzing an access attribute for a constrained
+   --  component, before the full declaration for Typ has been analyzed, and
+   --  where therefore the prefix of the attribute does not match the enclosing
+   --  scope.
+
+   -----------------------
+   -- Analyze_Attribute --
+   -----------------------
+
+   procedure Analyze_Attribute (N : Node_Id) is
+      Loc     : constant Source_Ptr   := Sloc (N);
+      Aname   : constant Name_Id      := Attribute_Name (N);
+      P       : constant Node_Id      := Prefix (N);
+      Exprs   : constant List_Id      := Expressions (N);
+      Attr_Id : constant Attribute_Id := Get_Attribute_Id (Aname);
+      E1      : Node_Id;
+      E2      : Node_Id;
+
+      P_Type : Entity_Id;
+      --  Type of prefix after analysis
+
+      P_Base_Type : Entity_Id;
+      --  Base type of prefix after analysis
+
+      P_Root_Type : Entity_Id;
+      --  Root type of prefix after analysis
+
+      Unanalyzed  : Node_Id;
+
+      -----------------------
+      -- Local Subprograms --
+      -----------------------
+
+      procedure Access_Attribute;
+      --  Used for Access, Unchecked_Access, Unrestricted_Access attributes.
+      --  Internally, Id distinguishes which of the three cases is involved.
+
+      procedure Check_Array_Or_Scalar_Type;
+      --  Common procedure used by First, Last, Range attribute to check
+      --  that the prefix is a constrained array or scalar type, or a name
+      --  of an array object, and that an argument appears only if appropriate
+      --  (i.e. only in the array case).
+
+      procedure Check_Array_Type;
+      --  Common semantic checks for all array attributes. Checks that the
+      --  prefix is a constrained array type or the name of an array object.
+      --  The error message for non-arrays is specialized appropriately.
+
+      procedure Check_Asm_Attribute;
+      --  Common semantic checks for Asm_Input and Asm_Output attributes
+
+      procedure Check_Component;
+      --  Common processing for Bit_Position, First_Bit, Last_Bit, and
+      --  Position. Checks prefix is an appropriate selected component.
+
+      procedure Check_Decimal_Fixed_Point_Type;
+      --  Check that prefix of attribute N is a decimal fixed-point type
+
+      procedure Check_Dereference;
+      --  If the prefix of attribute is an object of an access type, then
+      --  introduce an explicit deference, and adjust P_Type accordingly.
+
+      procedure Check_Discrete_Type;
+      --  Verify that prefix of attribute N is a discrete type
+
+      procedure Check_E0;
+      --  Check that no attribute arguments are present
+
+      procedure Check_Either_E0_Or_E1;
+      --  Check that there are zero or one attribute arguments present
+
+      procedure Check_E1;
+      --  Check that exactly one attribute argument is present
+
+      procedure Check_E2;
+      --  Check that two attribute arguments are present
+
+      procedure Check_Enum_Image;
+      --  If the prefix type is an enumeration type, set all its literals
+      --  as referenced, since the image function could possibly end up
+      --  referencing any of the literals indirectly.
+
+      procedure Check_Enumeration_Type;
+      --  Verify that prefix of attribute N is an enumeration type
+
+      procedure Check_Fixed_Point_Type;
+      --  Verify that prefix of attribute N is a fixed type
+
+      procedure Check_Fixed_Point_Type_0;
+      --  Verify that prefix of attribute N is a fixed type and that
+      --  no attribute expressions are present
+
+      procedure Check_Floating_Point_Type;
+      --  Verify that prefix of attribute N is a float type
+
+      procedure Check_Floating_Point_Type_0;
+      --  Verify that prefix of attribute N is a float type and that
+      --  no attribute expressions are present
+
+      procedure Check_Floating_Point_Type_1;
+      --  Verify that prefix of attribute N is a float type and that
+      --  exactly one attribute expression is present
+
+      procedure Check_Floating_Point_Type_2;
+      --  Verify that prefix of attribute N is a float type and that
+      --  two attribute expressions are present
+
+      procedure Legal_Formal_Attribute;
+      --  Common processing for attributes Definite, and Has_Discriminants
+
+      procedure Check_Integer_Type;
+      --  Verify that prefix of attribute N is an integer type
+
+      procedure Check_Library_Unit;
+      --  Verify that prefix of attribute N is a library unit
+
+      procedure Check_Not_Incomplete_Type;
+      --  Check that P (the prefix of the attribute) is not an incomplete
+      --  type or a private type for which no full view has been given.
+
+      procedure Check_Object_Reference (P : Node_Id);
+      --  Check that P (the prefix of the attribute) is an object reference
+
+      procedure Check_Program_Unit;
+      --  Verify that prefix of attribute N is a program unit
+
+      procedure Check_Real_Type;
+      --  Verify that prefix of attribute N is fixed or float type
+
+      procedure Check_Scalar_Type;
+      --  Verify that prefix of attribute N is a scalar type
+
+      procedure Check_Standard_Prefix;
+      --  Verify that prefix of attribute N is package Standard
+
+      procedure Check_Stream_Attribute (Nam : Name_Id);
+      --  Validity checking for stream attribute. Nam is the name of the
+      --  corresponding possible defined attribute function (e.g. for the
+      --  Read attribute, Nam will be Name_uRead).
+
+      procedure Check_Task_Prefix;
+      --  Verify that prefix of attribute N is a task or task type
+
+      procedure Check_Type;
+      --  Verify that the prefix of attribute N is a type
+
+      procedure Check_Unit_Name (Nod : Node_Id);
+      --  Check that Nod is of the form of a library unit name, i.e that
+      --  it is an identifier, or a selected component whose prefix is
+      --  itself of the form of a library unit name. Note that this is
+      --  quite different from Check_Program_Unit, since it only checks
+      --  the syntactic form of the name, not the semantic identity. This
+      --  is because it is used with attributes (Elab_Body, Elab_Spec, and
+      --  UET_Address) which can refer to non-visible unit.
+
+      procedure Error_Attr (Msg : String; Error_Node : Node_Id);
+      pragma No_Return (Error_Attr);
+      --  Posts error using Error_Msg_N at given node, sets type of attribute
+      --  node to Any_Type, and then raises Bad_Attribute to avoid any further
+      --  semantic processing. The message typically contains a % insertion
+      --  character which is replaced by the attribute name.
+
+      procedure Standard_Attribute (Val : Int);
+      --  Used to process attributes whose prefix is package Standard which
+      --  yield values of type Universal_Integer. The attribute reference
+      --  node is rewritten with an integer literal of the given value.
+
+      procedure Unexpected_Argument (En : Node_Id);
+      --  Signal unexpected attribute argument (En is the argument)
+
+      procedure Validate_Non_Static_Attribute_Function_Call;
+      --  Called when processing an attribute that is a function call to a
+      --  non-static function, i.e. an attribute function that either takes
+      --  non-scalar arguments or returns a non-scalar result. Verifies that
+      --  such a call does not appear in a preelaborable context.
+
+      ----------------------
+      -- Access_Attribute --
+      ----------------------
+
+      procedure Access_Attribute is
+         Acc_Type : Entity_Id;
+
+         Scop : Entity_Id;
+         Typ  : Entity_Id;
+
+         function Build_Access_Object_Type (DT : Entity_Id) return Entity_Id;
+         --  Build an access-to-object type whose designated type is DT,
+         --  and whose Ekind is appropriate to the attribute type. The
+         --  type that is constructed is returned as the result.
+
+         procedure Build_Access_Subprogram_Type (P : Node_Id);
+         --  Build an access to subprogram whose designated type is
+         --  the type of the prefix. If prefix is overloaded, so it the
+         --  node itself. The result is stored in Acc_Type.
+
+         ------------------------------
+         -- Build_Access_Object_Type --
+         ------------------------------
+
+         function Build_Access_Object_Type (DT : Entity_Id) return Entity_Id is
+            Typ : Entity_Id;
+
+         begin
+            if Aname = Name_Unrestricted_Access then
+               Typ :=
+                 New_Internal_Entity
+                   (E_Allocator_Type, Current_Scope, Loc, 'A');
+            else
+               Typ :=
+                 New_Internal_Entity
+                   (E_Access_Attribute_Type, Current_Scope, Loc, 'A');
+            end if;
+
+            Set_Etype                     (Typ, Typ);
+            Init_Size_Align               (Typ);
+            Set_Is_Itype                  (Typ);
+            Set_Associated_Node_For_Itype (Typ, N);
+            Set_Directly_Designated_Type  (Typ, DT);
+            return Typ;
+         end Build_Access_Object_Type;
+
+         ----------------------------------
+         -- Build_Access_Subprogram_Type --
+         ----------------------------------
+
+         procedure Build_Access_Subprogram_Type (P : Node_Id) is
+            Index    : Interp_Index;
+            It       : Interp;
+
+            function Get_Kind (E : Entity_Id) return Entity_Kind;
+            --  Distinguish between access to regular and protected
+            --  subprograms.
+
+            function Get_Kind (E : Entity_Id) return Entity_Kind is
+            begin
+               if Convention (E) = Convention_Protected then
+                  return E_Access_Protected_Subprogram_Type;
+               else
+                  return E_Access_Subprogram_Type;
+               end if;
+            end Get_Kind;
+
+         --  Start of processing for Build_Access_Subprogram_Type
+
+         begin
+            if not Is_Overloaded (P) then
+               Acc_Type :=
+                 New_Internal_Entity
+                   (Get_Kind (Entity (P)), Current_Scope, Loc, 'A');
+               Set_Etype (Acc_Type, Acc_Type);
+               Set_Directly_Designated_Type (Acc_Type, Entity (P));
+               Set_Etype (N, Acc_Type);
+
+            else
+               Get_First_Interp (P, Index, It);
+               Set_Etype (N, Any_Type);
+
+               while Present (It.Nam) loop
+
+                  if not Is_Intrinsic_Subprogram (It.Nam) then
+                     Acc_Type :=
+                       New_Internal_Entity
+                         (Get_Kind (It.Nam), Current_Scope, Loc, 'A');
+                     Set_Etype (Acc_Type, Acc_Type);
+                     Set_Directly_Designated_Type (Acc_Type, It.Nam);
+                     Add_One_Interp (N, Acc_Type, Acc_Type);
+                  end if;
+
+                  Get_Next_Interp (Index, It);
+               end loop;
+
+               if Etype (N) = Any_Type then
+                  Error_Attr ("prefix of % attribute cannot be intrinsic", P);
+               end if;
+            end if;
+         end Build_Access_Subprogram_Type;
+
+      --  Start of processing for Access_Attribute
+
+      begin
+         Check_E0;
+
+         if Nkind (P) = N_Character_Literal then
+            Error_Attr
+              ("prefix of % attribute cannot be enumeration literal", P);
+
+         --  In the case of an access to subprogram, use the name of the
+         --  subprogram itself as the designated type. Type-checking in
+         --  this case compares the signatures of the designated types.
+
+         elsif Is_Entity_Name (P)
+           and then Is_Overloadable (Entity (P))
+         then
+            Build_Access_Subprogram_Type (P);
+            return;
+
+         --  Component is an operation of a protected type.
+
+         elsif (Nkind (P) = N_Selected_Component
+           and then Is_Overloadable (Entity (Selector_Name (P))))
+         then
+            if Ekind (Entity (Selector_Name (P))) = E_Entry then
+               Error_Attr ("Prefix of % attribute must be subprogram", P);
+            end if;
+
+            Build_Access_Subprogram_Type (Selector_Name (P));
+            return;
+         end if;
+
+         --  Deal with incorrect reference to a type, but note that some
+         --  accesses are allowed (references to the current type instance).
+
+         if Is_Entity_Name (P) then
+            Scop := Current_Scope;
+            Typ := Entity (P);
+
+            if Is_Type (Typ) then
+
+               --  OK if we are within the scope of a limited type
+               --  let's mark the component as having per object constraint
+
+               if Is_Anonymous_Tagged_Base (Scop, Typ) then
+                  Typ := Scop;
+                  Set_Entity (P, Typ);
+                  Set_Etype  (P, Typ);
+               end if;
+
+               if Typ = Scop then
+                  declare
+                     Q : Node_Id := Parent (N);
+
+                  begin
+                     while Present (Q)
+                       and then Nkind (Q) /= N_Component_Declaration
+                     loop
+                        Q := Parent (Q);
+                     end loop;
+                     if Present (Q) then
+                        Set_Has_Per_Object_Constraint (
+                          Defining_Identifier (Q), True);
+                     end if;
+                  end;
+
+                  if Nkind (P) = N_Expanded_Name then
+                     Error_Msg_N
+                       ("current instance prefix must be a direct name", P);
+                  end if;
+
+                  --  If a current instance attribute appears within a
+                  --  a component constraint it must appear alone; other
+                  --  contexts (default expressions, within a task body)
+                  --  are not subject to this restriction.
+
+                  if not In_Default_Expression
+                    and then not Has_Completion (Scop)
+                    and then
+                      Nkind (Parent (N)) /= N_Discriminant_Association
+                    and then
+                      Nkind (Parent (N)) /= N_Index_Or_Discriminant_Constraint
+                  then
+                     Error_Msg_N
+                       ("current instance attribute must appear alone", N);
+                  end if;
+
+               --  OK if we are in initialization procedure for the type
+               --  in question, in which case the reference to the type
+               --  is rewritten as a reference to the current object.
+
+               elsif Ekind (Scop) = E_Procedure
+                 and then Chars (Scop) = Name_uInit_Proc
+                 and then Etype (First_Formal (Scop)) = Typ
+               then
+                  Rewrite (N,
+                    Make_Attribute_Reference (Loc,
+                      Prefix         => Make_Identifier (Loc, Name_uInit),
+                      Attribute_Name => Name_Unrestricted_Access));
+                  Analyze (N);
+                  return;
+
+               --  OK if a task type, this test needs sharpening up ???
+
+               elsif Is_Task_Type (Typ) then
+                  null;
+
+               --  Otherwise we have an error case
+
+               else
+                  Error_Attr ("% attribute cannot be applied to type", P);
+                  return;
+               end if;
+            end if;
+         end if;
+
+         --  If we fall through, we have a normal access to object case.
+         --  Unrestricted_Access is legal wherever an allocator would be
+         --  legal, so its Etype is set to E_Allocator. The expected type
+         --  of the other attributes is a general access type, and therefore
+         --  we label them with E_Access_Attribute_Type.
+
+         if not Is_Overloaded (P) then
+            Acc_Type := Build_Access_Object_Type (P_Type);
+            Set_Etype (N, Acc_Type);
+         else
+            declare
+               Index : Interp_Index;
+               It    : Interp;
+
+            begin
+               Set_Etype (N, Any_Type);
+               Get_First_Interp (P, Index, It);
+
+               while Present (It.Typ) loop
+                  Acc_Type := Build_Access_Object_Type (It.Typ);
+                  Add_One_Interp (N, Acc_Type, Acc_Type);
+                  Get_Next_Interp (Index, It);
+               end loop;
+            end;
+         end if;
+
+         --  Check for aliased view unless unrestricted case. We allow
+         --  a nonaliased prefix when within an instance because the
+         --  prefix may have been a tagged formal object, which is
+         --  defined to be aliased even when the actual might not be
+         --  (other instance cases will have been caught in the generic).
+
+         if Aname /= Name_Unrestricted_Access
+           and then not Is_Aliased_View (P)
+           and then not In_Instance
+         then
+            Error_Attr ("prefix of % attribute must be aliased", P);
+         end if;
+
+      end Access_Attribute;
+
+      --------------------------------
+      -- Check_Array_Or_Scalar_Type --
+      --------------------------------
+
+      procedure Check_Array_Or_Scalar_Type is
+         Index : Entity_Id;
+
+         D : Int;
+         --  Dimension number for array attributes.
+
+      begin
+         --  Case of string literal or string literal subtype. These cases
+         --  cannot arise from legal Ada code, but the expander is allowed
+         --  to generate them. They require special handling because string
+         --  literal subtypes do not have standard bounds (the whole idea
+         --  of these subtypes is to avoid having to generate the bounds)
+
+         if Ekind (P_Type) = E_String_Literal_Subtype then
+            Set_Etype (N, Etype (First_Index (P_Base_Type)));
+            return;
+
+         --  Scalar types
+
+         elsif Is_Scalar_Type (P_Type) then
+            Check_Type;
+
+            if Present (E1) then
+               Error_Attr ("invalid argument in % attribute", E1);
+            else
+               Set_Etype (N, P_Base_Type);
+               return;
+            end if;
+
+         --  The following is a special test to allow 'First to apply to
+         --  private scalar types if the attribute comes from generated
+         --  code. This occurs in the case of Normalize_Scalars code.
+
+         elsif Is_Private_Type (P_Type)
+           and then Present (Full_View (P_Type))
+           and then Is_Scalar_Type (Full_View (P_Type))
+           and then not Comes_From_Source (N)
+         then
+            Set_Etype (N, Implementation_Base_Type (P_Type));
+
+         --  Array types other than string literal subtypes handled above
+
+         else
+            Check_Array_Type;
+
+            --  We know prefix is an array type, or the name of an array
+            --  object, and that the expression, if present, is static
+            --  and within the range of the dimensions of the type.
+
+            if Is_Array_Type (P_Type) then
+               Index := First_Index (P_Base_Type);
+
+            else pragma Assert (Is_Access_Type (P_Type));
+               Index := First_Index (Base_Type (Designated_Type (P_Type)));
+            end if;
+
+            if No (E1) then
+
+               --  First dimension assumed
+
+               Set_Etype (N, Base_Type (Etype (Index)));
+
+            else
+               D := UI_To_Int (Intval (E1));
+
+               for J in 1 .. D - 1 loop
+                  Next_Index (Index);
+               end loop;
+
+               Set_Etype (N, Base_Type (Etype (Index)));
+               Set_Etype (E1, Standard_Integer);
+            end if;
+         end if;
+      end Check_Array_Or_Scalar_Type;
+
+      ----------------------
+      -- Check_Array_Type --
+      ----------------------
+
+      procedure Check_Array_Type is
+         D : Int;
+         --  Dimension number for array attributes.
+
+      begin
+         --  If the type is a string literal type, then this must be generated
+         --  internally, and no further check is required on its legality.
+
+         if Ekind (P_Type) = E_String_Literal_Subtype then
+            return;
+
+         --  If the type is a composite, it is an illegal aggregate, no point
+         --  in going on.
+
+         elsif P_Type = Any_Composite then
+            raise Bad_Attribute;
+         end if;
+
+         --  Normal case of array type or subtype
+
+         Check_Either_E0_Or_E1;
+
+         if Is_Array_Type (P_Type) then
+            if not Is_Constrained (P_Type)
+              and then Is_Entity_Name (P)
+              and then Is_Type (Entity (P))
+            then
+               --  Note: we do not call Error_Attr here, since we prefer to
+               --  continue, using the relevant index type of the array,
+               --  even though it is unconstrained. This gives better error
+               --  recovery behavior.
+
+               Error_Msg_Name_1 := Aname;
+               Error_Msg_N
+                 ("prefix for % attribute must be constrained array", P);
+            end if;
+
+            D := Number_Dimensions (P_Type);
+
+         elsif Is_Access_Type (P_Type)
+           and then Is_Array_Type (Designated_Type (P_Type))
+         then
+            if Is_Entity_Name (P) and then Is_Type (Entity (P)) then
+               Error_Attr ("prefix of % attribute cannot be access type", P);
+            end if;
+
+            D := Number_Dimensions (Designated_Type (P_Type));
+
+            --  If there is an implicit dereference, then we must freeze
+            --  the designated type of the access type, since the type of
+            --  the referenced array is this type (see AI95-00106).
+
+            Freeze_Before (N, Designated_Type (P_Type));
+
+         else
+            if Is_Private_Type (P_Type) then
+               Error_Attr
+                 ("prefix for % attribute may not be private type", P);
+
+            elsif Attr_Id = Attribute_First
+                    or else
+                  Attr_Id = Attribute_Last
+            then
+               Error_Attr ("invalid prefix for % attribute", P);
+
+            else
+               Error_Attr ("prefix for % attribute must be array", P);
+            end if;
+         end if;
+
+         if Present (E1) then
+            Resolve (E1, Any_Integer);
+            Set_Etype (E1, Standard_Integer);
+
+            if not Is_Static_Expression (E1)
+              or else Raises_Constraint_Error (E1)
+            then
+               Error_Attr ("expression for dimension must be static", E1);
+
+            elsif  UI_To_Int (Expr_Value (E1)) > D
+              or else UI_To_Int (Expr_Value (E1)) < 1
+            then
+               Error_Attr ("invalid dimension number for array type", E1);
+            end if;
+         end if;
+      end Check_Array_Type;
+
+      -------------------------
+      -- Check_Asm_Attribute --
+      -------------------------
+
+      procedure Check_Asm_Attribute is
+      begin
+         Check_Type;
+         Check_E2;
+
+         --  Check first argument is static string expression
+
+         Analyze_And_Resolve (E1, Standard_String);
+
+         if Etype (E1) = Any_Type then
+            return;
+
+         elsif not Is_OK_Static_Expression (E1) then
+            Error_Attr
+              ("constraint argument must be static string expression", E1);
+         end if;
+
+         --  Check second argument is right type
+
+         Analyze_And_Resolve (E2, Entity (P));
+
+         --  Note: that is all we need to do, we don't need to check
+         --  that it appears in a correct context. The Ada type system
+         --  will do that for us.
+
+      end Check_Asm_Attribute;
+
+      ---------------------
+      -- Check_Component --
+      ---------------------
+
+      procedure Check_Component is
+      begin
+         Check_E0;
+
+         if Nkind (P) /= N_Selected_Component
+           or else
+             (Ekind (Entity (Selector_Name (P))) /= E_Component
+               and then
+              Ekind (Entity (Selector_Name (P))) /= E_Discriminant)
+         then
+            Error_Attr
+              ("prefix for % attribute must be selected component", P);
+         end if;
+      end Check_Component;
+
+      ------------------------------------
+      -- Check_Decimal_Fixed_Point_Type --
+      ------------------------------------
+
+      procedure Check_Decimal_Fixed_Point_Type is
+      begin
+         Check_Type;
+
+         if not Is_Decimal_Fixed_Point_Type (P_Type) then
+            Error_Attr
+              ("prefix of % attribute must be decimal type", P);
+         end if;
+      end Check_Decimal_Fixed_Point_Type;
+
+      -----------------------
+      -- Check_Dereference --
+      -----------------------
+
+      procedure Check_Dereference is
+      begin
+         if Is_Object_Reference (P)
+           and then Is_Access_Type (P_Type)
+         then
+            Rewrite (P,
+              Make_Explicit_Dereference (Sloc (P),
+                Prefix => Relocate_Node (P)));
+
+            Analyze_And_Resolve (P);
+            P_Type := Etype (P);
+
+            if P_Type = Any_Type then
+               raise Bad_Attribute;
+            end if;
+
+            P_Base_Type := Base_Type (P_Type);
+            P_Root_Type := Root_Type (P_Base_Type);
+         end if;
+      end Check_Dereference;
+
+      -------------------------
+      -- Check_Discrete_Type --
+      -------------------------
+
+      procedure Check_Discrete_Type is
+      begin
+         Check_Type;
+
+         if not Is_Discrete_Type (P_Type) then
+            Error_Attr ("prefix of % attribute must be discrete type", P);
+         end if;
+      end Check_Discrete_Type;
+
+      --------------
+      -- Check_E0 --
+      --------------
+
+      procedure Check_E0 is
+      begin
+         if Present (E1) then
+            Unexpected_Argument (E1);
+         end if;
+      end Check_E0;
+
+      --------------
+      -- Check_E1 --
+      --------------
+
+      procedure Check_E1 is
+      begin
+         Check_Either_E0_Or_E1;
+
+         if No (E1) then
+
+            --  Special-case attributes that are functions and that appear as
+            --  the prefix of another attribute. Error is posted on parent.
+
+            if Nkind (Parent (N)) = N_Attribute_Reference
+              and then (Attribute_Name (Parent (N)) = Name_Address
+                          or else
+                        Attribute_Name (Parent (N)) = Name_Code_Address
+                          or else
+                        Attribute_Name (Parent (N)) = Name_Access)
+            then
+               Error_Msg_Name_1 := Attribute_Name (Parent (N));
+               Error_Msg_N ("illegal prefix for % attribute", Parent (N));
+               Set_Etype (Parent (N), Any_Type);
+               Set_Entity (Parent (N), Any_Type);
+               raise Bad_Attribute;
+
+            else
+               Error_Attr ("missing argument for % attribute", N);
+            end if;
+         end if;
+      end Check_E1;
+
+      --------------
+      -- Check_E2 --
+      --------------
+
+      procedure Check_E2 is
+      begin
+         if No (E1) then
+            Error_Attr ("missing arguments for % attribute (2 required)", N);
+         elsif No (E2) then
+            Error_Attr ("missing argument for % attribute (2 required)", N);
+         end if;
+      end Check_E2;
+
+      ---------------------------
+      -- Check_Either_E0_Or_E1 --
+      ---------------------------
+
+      procedure Check_Either_E0_Or_E1 is
+      begin
+         if Present (E2) then
+            Unexpected_Argument (E2);
+         end if;
+      end Check_Either_E0_Or_E1;
+
+      ----------------------
+      -- Check_Enum_Image --
+      ----------------------
+
+      procedure Check_Enum_Image is
+         Lit : Entity_Id;
+
+      begin
+         if Is_Enumeration_Type (P_Base_Type) then
+            Lit := First_Literal (P_Base_Type);
+            while Present (Lit) loop
+               Set_Referenced (Lit);
+               Next_Literal (Lit);
+            end loop;
+         end if;
+      end Check_Enum_Image;
+
+      ----------------------------
+      -- Check_Enumeration_Type --
+      ----------------------------
+
+      procedure Check_Enumeration_Type is
+      begin
+         Check_Type;
+
+         if not Is_Enumeration_Type (P_Type) then
+            Error_Attr ("prefix of % attribute must be enumeration type", P);
+         end if;
+      end Check_Enumeration_Type;
+
+      ----------------------------
+      -- Check_Fixed_Point_Type --
+      ----------------------------
+
+      procedure Check_Fixed_Point_Type is
+      begin
+         Check_Type;
+
+         if not Is_Fixed_Point_Type (P_Type) then
+            Error_Attr ("prefix of % attribute must be fixed point type", P);
+         end if;
+      end Check_Fixed_Point_Type;
+
+      ------------------------------
+      -- Check_Fixed_Point_Type_0 --
+      ------------------------------
+
+      procedure Check_Fixed_Point_Type_0 is
+      begin
+         Check_Fixed_Point_Type;
+         Check_E0;
+      end Check_Fixed_Point_Type_0;
+
+      -------------------------------
+      -- Check_Floating_Point_Type --
+      -------------------------------
+
+      procedure Check_Floating_Point_Type is
+      begin
+         Check_Type;
+
+         if not Is_Floating_Point_Type (P_Type) then
+            Error_Attr ("prefix of % attribute must be float type", P);
+         end if;
+      end Check_Floating_Point_Type;
+
+      ---------------------------------
+      -- Check_Floating_Point_Type_0 --
+      ---------------------------------
+
+      procedure Check_Floating_Point_Type_0 is
+      begin
+         Check_Floating_Point_Type;
+         Check_E0;
+      end Check_Floating_Point_Type_0;
+
+      ---------------------------------
+      -- Check_Floating_Point_Type_1 --
+      ---------------------------------
+
+      procedure Check_Floating_Point_Type_1 is
+      begin
+         Check_Floating_Point_Type;
+         Check_E1;
+      end Check_Floating_Point_Type_1;
+
+      ---------------------------------
+      -- Check_Floating_Point_Type_2 --
+      ---------------------------------
+
+      procedure Check_Floating_Point_Type_2 is
+      begin
+         Check_Floating_Point_Type;
+         Check_E2;
+      end Check_Floating_Point_Type_2;
+
+      ------------------------
+      -- Check_Integer_Type --
+      ------------------------
+
+      procedure Check_Integer_Type is
+      begin
+         Check_Type;
+
+         if not Is_Integer_Type (P_Type) then
+            Error_Attr ("prefix of % attribute must be integer type", P);
+         end if;
+      end Check_Integer_Type;
+
+      ------------------------
+      -- Check_Library_Unit --
+      ------------------------
+
+      procedure Check_Library_Unit is
+      begin
+         if not Is_Compilation_Unit (Entity (P)) then
+            Error_Attr ("prefix of % attribute must be library unit", P);
+         end if;
+      end Check_Library_Unit;
+
+      -------------------------------
+      -- Check_Not_Incomplete_Type --
+      -------------------------------
+
+      procedure Check_Not_Incomplete_Type is
+      begin
+         if not Is_Entity_Name (P)
+           or else not Is_Type (Entity (P))
+           or else In_Default_Expression
+         then
+            return;
+
+         else
+            Check_Fully_Declared (P_Type, P);
+         end if;
+      end Check_Not_Incomplete_Type;
+
+      ----------------------------
+      -- Check_Object_Reference --
+      ----------------------------
+
+      procedure Check_Object_Reference (P : Node_Id) is
+         Rtyp : Entity_Id;
+
+      begin
+         --  If we need an object, and we have a prefix that is the name of
+         --  a function entity, convert it into a function call.
+
+         if Is_Entity_Name (P)
+           and then Ekind (Entity (P)) = E_Function
+         then
+            Rtyp := Etype (Entity (P));
+
+            Rewrite (P,
+              Make_Function_Call (Sloc (P),
+                Name => Relocate_Node (P)));
+
+            Analyze_And_Resolve (P, Rtyp);
+
+         --  Otherwise we must have an object reference
+
+         elsif not Is_Object_Reference (P) then
+            Error_Attr ("prefix of % attribute must be object", P);
+         end if;
+      end Check_Object_Reference;
+
+      ------------------------
+      -- Check_Program_Unit --
+      ------------------------
+
+      procedure Check_Program_Unit is
+      begin
+         if Is_Entity_Name (P) then
+            declare
+               K : constant Entity_Kind := Ekind (Entity (P));
+               T : constant Entity_Id   := Etype (Entity (P));
+
+            begin
+               if K in Subprogram_Kind
+                 or else K in Task_Kind
+                 or else K in Protected_Kind
+                 or else K = E_Package
+                 or else K in Generic_Unit_Kind
+                 or else (K = E_Variable
+                            and then
+                              (Is_Task_Type (T)
+                                 or else
+                               Is_Protected_Type (T)))
+               then
+                  return;
+               end if;
+            end;
+         end if;
+
+         Error_Attr ("prefix of % attribute must be program unit", P);
+      end Check_Program_Unit;
+
+      ---------------------
+      -- Check_Real_Type --
+      ---------------------
+
+      procedure Check_Real_Type is
+      begin
+         Check_Type;
+
+         if not Is_Real_Type (P_Type) then
+            Error_Attr ("prefix of % attribute must be real type", P);
+         end if;
+      end Check_Real_Type;
+
+      -----------------------
+      -- Check_Scalar_Type --
+      -----------------------
+
+      procedure Check_Scalar_Type is
+      begin
+         Check_Type;
+
+         if not Is_Scalar_Type (P_Type) then
+            Error_Attr ("prefix of % attribute must be scalar type", P);
+         end if;
+      end Check_Scalar_Type;
+
+      ---------------------------
+      -- Check_Standard_Prefix --
+      ---------------------------
+
+      procedure Check_Standard_Prefix is
+      begin
+         Check_E0;
+
+         if Nkind (P) /= N_Identifier
+           or else Chars (P) /= Name_Standard
+         then
+            Error_Attr ("only allowed prefix for % attribute is Standard", P);
+         end if;
+
+      end Check_Standard_Prefix;
+
+      ----------------------------
+      -- Check_Stream_Attribute --
+      ----------------------------
+
+      procedure Check_Stream_Attribute (Nam : Name_Id) is
+         Etyp : Entity_Id;
+         Btyp : Entity_Id;
+
+      begin
+         Validate_Non_Static_Attribute_Function_Call;
+
+         --  With the exception of 'Input, Stream attributes are procedures,
+         --  and can only appear at the position of procedure calls. We check
+         --  for this here, before they are rewritten, to give a more precise
+         --  diagnostic.
+
+         if Nam = Name_uInput then
+            null;
+
+         elsif Is_List_Member (N)
+           and then Nkind (Parent (N)) /= N_Procedure_Call_Statement
+           and then Nkind (Parent (N)) /= N_Aggregate
+         then
+            null;
+
+         else
+            Error_Attr
+              ("invalid context for attribute %, which is a procedure", N);
+         end if;
+
+         Check_Type;
+         Btyp := Implementation_Base_Type (P_Type);
+
+         --  Stream attributes not allowed on limited types unless the
+         --  special OK_For_Stream flag is set.
+
+         if Is_Limited_Type (P_Type)
+           and then Comes_From_Source (N)
+           and then not Present (TSS (Btyp, Nam))
+           and then No (Get_Rep_Pragma (Btyp, Name_Stream_Convert))
+         then
+            --  Special case the message if we are compiling the stub version
+            --  of a remote operation. One error on the type is sufficient.
+
+            if (Is_Remote_Types (Current_Scope)
+                 or else Is_Remote_Call_Interface (Current_Scope))
+              and then not Error_Posted (Btyp)
+            then
+               Error_Msg_Node_2 := Current_Scope;
+               Error_Msg_NE
+                 ("limited type& used in& has no stream attributes", P, Btyp);
+               Set_Error_Posted (Btyp);
+
+            elsif not Error_Posted (Btyp) then
+               Error_Msg_NE
+                 ("limited type& has no stream attributes", P, Btyp);
+            end if;
+         end if;
+
+         --  Here we must check that the first argument is an access type
+         --  that is compatible with Ada.Streams.Root_Stream_Type'Class.
+
+         Analyze_And_Resolve (E1);
+         Etyp := Etype (E1);
+
+         --  Note: the double call to Root_Type here is needed because the
+         --  root type of a class-wide type is the corresponding type (e.g.
+         --  X for X'Class, and we really want to go to the root.
+
+         if not Is_Access_Type (Etyp)
+           or else Root_Type (Root_Type (Designated_Type (Etyp))) /=
+                     RTE (RE_Root_Stream_Type)
+         then
+            Error_Attr
+              ("expected access to Ada.Streams.Root_Stream_Type''Class", E1);
+         end if;
+
+         --  Check that the second argument is of the right type if there is
+         --  one (the Input attribute has only one argument so this is skipped)
+
+         if Present (E2) then
+            Analyze (E2);
+
+            if Nam = Name_uRead
+              and then not Is_OK_Variable_For_Out_Formal (E2)
+            then
+               Error_Attr
+                 ("second argument of % attribute must be a variable", E2);
+            end if;
+
+            Resolve (E2, P_Type);
+         end if;
+      end Check_Stream_Attribute;
+
+      -----------------------
+      -- Check_Task_Prefix --
+      -----------------------
+
+      procedure Check_Task_Prefix is
+      begin
+         Analyze (P);
+
+         if Is_Task_Type (Etype (P))
+           or else (Is_Access_Type (Etype (P))
+              and then Is_Task_Type (Designated_Type (Etype (P))))
+         then
+            Resolve (P, Etype (P));
+         else
+            Error_Attr ("prefix of % attribute must be a task", P);
+         end if;
+      end Check_Task_Prefix;
+
+      ----------------
+      -- Check_Type --
+      ----------------
+
+      --  The possibilities are an entity name denoting a type, or an
+      --  attribute reference that denotes a type (Base or Class). If
+      --  the type is incomplete, replace it with its full view.
+
+      procedure Check_Type is
+      begin
+         if not Is_Entity_Name (P)
+           or else not Is_Type (Entity (P))
+         then
+            Error_Attr ("prefix of % attribute must be a type", P);
+
+         elsif Ekind (Entity (P)) = E_Incomplete_Type
+            and then Present (Full_View (Entity (P)))
+         then
+            P_Type := Full_View (Entity (P));
+            Set_Entity (P, P_Type);
+         end if;
+      end Check_Type;
+
+      ---------------------
+      -- Check_Unit_Name --
+      ---------------------
+
+      procedure Check_Unit_Name (Nod : Node_Id) is
+      begin
+         if Nkind (Nod) = N_Identifier then
+            return;
+
+         elsif Nkind (Nod) = N_Selected_Component then
+            Check_Unit_Name (Prefix (Nod));
+
+            if Nkind (Selector_Name (Nod)) = N_Identifier then
+               return;
+            end if;
+         end if;
+
+         Error_Attr ("argument for % attribute must be unit name", P);
+      end Check_Unit_Name;
+
+      ----------------
+      -- Error_Attr --
+      ----------------
+
+      procedure Error_Attr (Msg : String; Error_Node : Node_Id) is
+      begin
+         Error_Msg_Name_1 := Aname;
+         Error_Msg_N (Msg, Error_Node);
+         Set_Etype (N, Any_Type);
+         Set_Entity (N, Any_Type);
+         raise Bad_Attribute;
+      end Error_Attr;
+
+      ----------------------------
+      -- Legal_Formal_Attribute --
+      ----------------------------
+
+      procedure Legal_Formal_Attribute is
+      begin
+         Check_E0;
+
+         if not Is_Entity_Name (P)
+           or else not Is_Type (Entity (P))
+         then
+            Error_Attr (" prefix of % attribute must be generic type", N);
+
+         elsif Is_Generic_Actual_Type (Entity (P))
+           or In_Instance
+         then
+            null;
+
+         elsif Is_Generic_Type (Entity (P)) then
+            if not Is_Indefinite_Subtype (Entity (P)) then
+               Error_Attr
+                 (" prefix of % attribute must be indefinite generic type", N);
+            end if;
+
+         else
+            Error_Attr
+              (" prefix of % attribute must be indefinite generic type", N);
+         end if;
+
+         Set_Etype (N, Standard_Boolean);
+      end Legal_Formal_Attribute;
+
+      ------------------------
+      -- Standard_Attribute --
+      ------------------------
+
+      procedure Standard_Attribute (Val : Int) is
+      begin
+         Check_Standard_Prefix;
+         Rewrite (N,
+           Make_Integer_Literal (Loc, Val));
+         Analyze (N);
+      end Standard_Attribute;
+
+      -------------------------
+      -- Unexpected Argument --
+      -------------------------
+
+      procedure Unexpected_Argument (En : Node_Id) is
+      begin
+         Error_Attr ("unexpected argument for % attribute", En);
+      end Unexpected_Argument;
+
+      -------------------------------------------------
+      -- Validate_Non_Static_Attribute_Function_Call --
+      -------------------------------------------------
+
+      --  This function should be moved to Sem_Dist ???
+
+      procedure Validate_Non_Static_Attribute_Function_Call is
+      begin
+         if In_Preelaborated_Unit
+           and then not In_Subprogram_Or_Concurrent_Unit
+         then
+            Error_Msg_N ("non-static function call in preelaborated unit", N);
+         end if;
+      end Validate_Non_Static_Attribute_Function_Call;
+
+   -----------------------------------------------
+   -- Start of Processing for Analyze_Attribute --
+   -----------------------------------------------
+
+   begin
+      --  Immediate return if unrecognized attribute (already diagnosed
+      --  by parser, so there is nothing more that we need to do)
+
+      if not Is_Attribute_Name (Aname) then
+         raise Bad_Attribute;
+      end if;
+
+      --  Deal with Ada 83 and Features issues
+
+      if not Attribute_83 (Attr_Id) then
+         if Ada_83 and then Comes_From_Source (N) then
+            Error_Msg_Name_1 := Aname;
+            Error_Msg_N ("(Ada 83) attribute% is not standard?", N);
+         end if;
+
+         if Attribute_Impl_Def (Attr_Id) then
+            Check_Restriction (No_Implementation_Attributes, N);
+         end if;
+      end if;
+
+      --   Remote access to subprogram type access attribute reference needs
+      --   unanalyzed copy for tree transformation. The analyzed copy is used
+      --   for its semantic information (whether prefix is a remote subprogram
+      --   name), the unanalyzed copy is used to construct new subtree rooted
+      --   with N_aggregate which represents a fat pointer aggregate.
+
+      if Aname = Name_Access then
+         Unanalyzed := Copy_Separate_Tree (N);
+      end if;
+
+      --  Analyze prefix and exit if error in analysis. If the prefix is an
+      --  incomplete type, use full view if available. A special case is
+      --  that we never analyze the prefix of an Elab_Body or Elab_Spec
+      --  or UET_Address attribute.
+
+      if Aname /= Name_Elab_Body
+           and then
+         Aname /= Name_Elab_Spec
+           and then
+         Aname /= Name_UET_Address
+      then
+         Analyze (P);
+         P_Type := Etype (P);
+
+         if Is_Entity_Name (P)
+           and then Present (Entity (P))
+           and then Is_Type (Entity (P))
+           and then Ekind (Entity (P)) = E_Incomplete_Type
+         then
+            P_Type := Get_Full_View (P_Type);
+            Set_Entity (P, P_Type);
+            Set_Etype  (P, P_Type);
+         end if;
+
+         if P_Type = Any_Type then
+            raise Bad_Attribute;
+         end if;
+
+         P_Base_Type := Base_Type (P_Type);
+         P_Root_Type := Root_Type (P_Base_Type);
+      end if;
+
+      --  Analyze expressions that may be present, exiting if an error occurs
+
+      if No (Exprs) then
+         E1 := Empty;
+         E2 := Empty;
+
+      else
+         E1 := First (Exprs);
+         Analyze (E1);
+
+         if Etype (E1) = Any_Type then
+            raise Bad_Attribute;
+         end if;
+
+         E2 := Next (E1);
+
+         if Present (E2) then
+            Analyze (E2);
+
+            if Etype (E2) = Any_Type then
+               raise Bad_Attribute;
+            end if;
+
+            if Present (Next (E2)) then
+               Unexpected_Argument (Next (E2));
+            end if;
+         end if;
+      end if;
+
+      if Is_Overloaded (P)
+        and then Aname /= Name_Access
+        and then Aname /= Name_Address
+        and then Aname /= Name_Code_Address
+        and then Aname /= Name_Count
+        and then Aname /= Name_Unchecked_Access
+      then
+         Error_Attr ("ambiguous prefix for % attribute", P);
+      end if;
+
+      --  Remaining processing depends on attribute
+
+      case Attr_Id is
+
+      ------------------
+      -- Abort_Signal --
+      ------------------
+
+      when Attribute_Abort_Signal =>
+         Check_Standard_Prefix;
+         Rewrite (N,
+           New_Reference_To (Stand.Abort_Signal, Loc));
+         Analyze (N);
+
+      ------------
+      -- Access --
+      ------------
+
+      when Attribute_Access =>
+         Access_Attribute;
+
+      -------------
+      -- Address --
+      -------------
+
+      when Attribute_Address =>
+         Check_E0;
+
+         --  Check for some junk cases, where we have to allow the address
+         --  attribute but it does not make much sense, so at least for now
+         --  just replace with Null_Address.
+
+         --  We also do this if the prefix is a reference to the AST_Entry
+         --  attribute. If expansion is active, the attribute will be
+         --  replaced by a function call, and address will work fine and
+         --  get the proper value, but if expansion is not active, then
+         --  the check here allows proper semantic analysis of the reference.
+
+         if (Is_Entity_Name (P)
+           and then
+             (((Ekind (Entity (P)) = E_Task_Type
+                 or else Ekind (Entity (P)) = E_Protected_Type)
+                   and then Etype (Entity (P)) = Base_Type (Entity (P)))
+               or else Ekind (Entity (P)) = E_Package
+               or else Is_Generic_Unit (Entity (P))))
+           or else
+            (Nkind (P) = N_Attribute_Reference
+              and then
+             Attribute_Name (P) = Name_AST_Entry)
+         then
+            Rewrite (N,
+              New_Occurrence_Of (RTE (RE_Null_Address), Sloc (N)));
+
+         --  The following logic is obscure, needs explanation ???
+
+         elsif Nkind (P) = N_Attribute_Reference
+           or else (Is_Entity_Name (P)
+                      and then not Is_Subprogram (Entity (P))
+                      and then not Is_Object (Entity (P))
+                      and then Ekind (Entity (P)) /= E_Label)
+         then
+            Error_Attr ("invalid prefix for % attribute", P);
+
+         elsif Is_Entity_Name (P) then
+            Set_Address_Taken (Entity (P));
+         end if;
+
+         Set_Etype (N, RTE (RE_Address));
+
+      ------------------
+      -- Address_Size --
+      ------------------
+
+      when Attribute_Address_Size =>
+         Standard_Attribute (System_Address_Size);
+
+      --------------
+      -- Adjacent --
+      --------------
+
+      when Attribute_Adjacent =>
+         Check_Floating_Point_Type_2;
+         Set_Etype (N, P_Base_Type);
+         Resolve (E1, P_Base_Type);
+         Resolve (E2, P_Base_Type);
+
+      ---------
+      -- Aft --
+      ---------
+
+      when Attribute_Aft =>
+         Check_Fixed_Point_Type_0;
+         Set_Etype (N, Universal_Integer);
+
+      ---------------
+      -- Alignment --
+      ---------------
+
+      when Attribute_Alignment =>
+
+         --  Don't we need more checking here, cf Size ???
+
+         Check_E0;
+         Check_Not_Incomplete_Type;
+         Set_Etype (N, Universal_Integer);
+
+      ---------------
+      -- Asm_Input --
+      ---------------
+
+      when Attribute_Asm_Input =>
+         Check_Asm_Attribute;
+         Set_Etype (N, RTE (RE_Asm_Input_Operand));
+
+      ----------------
+      -- Asm_Output --
+      ----------------
+
+      when Attribute_Asm_Output =>
+         Check_Asm_Attribute;
+
+         if Etype (E2) = Any_Type then
+            return;
+
+         elsif Aname = Name_Asm_Output then
+            if not Is_Variable (E2) then
+               Error_Attr
+                 ("second argument for Asm_Output is not variable", E2);
+            end if;
+         end if;
+
+         Note_Possible_Modification (E2);
+         Set_Etype (N, RTE (RE_Asm_Output_Operand));
+
+      ---------------
+      -- AST_Entry --
+      ---------------
+
+      when Attribute_AST_Entry => AST_Entry : declare
+         Ent  : Entity_Id;
+         Pref : Node_Id;
+         Ptyp : Entity_Id;
+
+         Indexed : Boolean;
+         --  Indicates if entry family index is present. Note the coding
+         --  here handles the entry family case, but in fact it cannot be
+         --  executed currently, because pragma AST_Entry does not permit
+         --  the specification of an entry family.
+
+         procedure Bad_AST_Entry;
+         --  Signal a bad AST_Entry pragma
+
+         function OK_Entry (E : Entity_Id) return Boolean;
+         --  Checks that E is of an appropriate entity kind for an entry
+         --  (i.e. E_Entry if Index is False, or E_Entry_Family if Index
+         --  is set True for the entry family case). In the True case,
+         --  makes sure that Is_AST_Entry is set on the entry.
+
+         procedure Bad_AST_Entry is
+         begin
+            Error_Attr ("prefix for % attribute must be task entry", P);
+         end Bad_AST_Entry;
+
+         function OK_Entry (E : Entity_Id) return Boolean is
+            Result : Boolean;
+
+         begin
+            if Indexed then
+               Result := (Ekind (E) = E_Entry_Family);
+            else
+               Result := (Ekind (E) = E_Entry);
+            end if;
+
+            if Result then
+               if not Is_AST_Entry (E) then
+                  Error_Msg_Name_2 := Aname;
+                  Error_Attr
+                    ("% attribute requires previous % pragma", P);
+               end if;
+            end if;
+
+            return Result;
+         end OK_Entry;
+
+      --  Start of processing for AST_Entry
+
+      begin
+         Check_VMS (N);
+         Check_E0;
+
+         --  Deal with entry family case
+
+         if Nkind (P) = N_Indexed_Component then
+            Pref := Prefix (P);
+            Indexed := True;
+         else
+            Pref := P;
+            Indexed := False;
+         end if;
+
+         Ptyp := Etype (Pref);
+
+         if Ptyp = Any_Type or else Error_Posted (Pref) then
+            return;
+         end if;
+
+         --  If the prefix is a selected component whose prefix is of an
+         --  access type, then introduce an explicit dereference.
+
+         if Nkind (Pref) = N_Selected_Component
+           and then Is_Access_Type (Ptyp)
+         then
+            Rewrite (Pref,
+              Make_Explicit_Dereference (Sloc (Pref),
+                Relocate_Node (Pref)));
+            Analyze_And_Resolve (Pref, Designated_Type (Ptyp));
+         end if;
+
+         --  Prefix can be of the form a.b, where a is a task object
+         --  and b is one of the entries of the corresponding task type.
+
+         if Nkind (Pref) = N_Selected_Component
+           and then OK_Entry (Entity (Selector_Name (Pref)))
+           and then Is_Object_Reference (Prefix (Pref))
+           and then Is_Task_Type (Etype (Prefix (Pref)))
+         then
+            null;
+
+         --  Otherwise the prefix must be an entry of a containing task,
+         --  or of a variable of the enclosing task type.
+
+         else
+            if Nkind (Pref) = N_Identifier
+              or else Nkind (Pref) = N_Expanded_Name
+            then
+               Ent := Entity (Pref);
+
+               if not OK_Entry (Ent)
+                 or else not In_Open_Scopes (Scope (Ent))
+               then
+                  Bad_AST_Entry;
+               end if;
+
+            else
+               Bad_AST_Entry;
+            end if;
+         end if;
+
+         Set_Etype (N, RTE (RE_AST_Handler));
+      end AST_Entry;
+
+      ----------
+      -- Base --
+      ----------
+
+      when Attribute_Base => Base : declare
+         Typ : Entity_Id;
+
+      begin
+         Check_Either_E0_Or_E1;
+         Find_Type (P);
+         Typ := Entity (P);
+
+         if Sloc (Typ) = Standard_Location
+           and then Base_Type (Typ) = Typ
+           and then Warn_On_Redundant_Constructs
+         then
+            Error_Msg_NE
+              ("?redudant attribute, & is its own base type", N, Typ);
+         end if;
+
+         Set_Etype (N, Base_Type (Entity (P)));
+
+         --  If we have an expression present, then really this is a conversion
+         --  and the tree must be reformed. Note that this is one of the cases
+         --  in which we do a replace rather than a rewrite, because the
+         --  original tree is junk.
+
+         if Present (E1) then
+            Replace (N,
+              Make_Type_Conversion (Loc,
+                Subtype_Mark =>
+                  Make_Attribute_Reference (Loc,
+                    Prefix => Prefix (N),
+                    Attribute_Name => Name_Base),
+                Expression => Relocate_Node (E1)));
+
+            --  E1 may be overloaded, and its interpretations preserved.
+
+            Save_Interps (E1, Expression (N));
+            Analyze (N);
+
+         --  For other cases, set the proper type as the entity of the
+         --  attribute reference, and then rewrite the node to be an
+         --  occurrence of the referenced base type. This way, no one
+         --  else in the compiler has to worry about the base attribute.
+
+         else
+            Set_Entity (N, Base_Type (Entity (P)));
+            Rewrite (N,
+              New_Reference_To (Entity (N), Loc));
+            Analyze (N);
+         end if;
+      end Base;
+
+      ---------
+      -- Bit --
+      ---------
+
+      when Attribute_Bit => Bit :
+      begin
+         Check_E0;
+
+         if not Is_Object_Reference (P) then
+            Error_Attr ("prefix for % attribute must be object", P);
+
+         --  What about the access object cases ???
+
+         else
+            null;
+         end if;
+
+         Set_Etype (N, Universal_Integer);
+      end Bit;
+
+      ---------------
+      -- Bit_Order --
+      ---------------
+
+      when Attribute_Bit_Order => Bit_Order :
+      begin
+         Check_E0;
+         Check_Type;
+
+         if not Is_Record_Type (P_Type) then
+            Error_Attr ("prefix of % attribute must be record type", P);
+         end if;
+
+         if Bytes_Big_Endian xor Reverse_Bit_Order (P_Type) then
+            Rewrite (N,
+              New_Occurrence_Of (RTE (RE_High_Order_First), Loc));
+         else
+            Rewrite (N,
+              New_Occurrence_Of (RTE (RE_Low_Order_First), Loc));
+         end if;
+
+         Set_Etype (N, RTE (RE_Bit_Order));
+         Resolve (N, Etype (N));
+
+         --  Reset incorrect indication of staticness
+
+         Set_Is_Static_Expression (N, False);
+      end Bit_Order;
+
+      ------------------
+      -- Bit_Position --
+      ------------------
+
+      --  Note: in generated code, we can have a Bit_Position attribute
+      --  applied to a (naked) record component (i.e. the prefix is an
+      --  identifier that references an E_Component or E_Discriminant
+      --  entity directly, and this is interpreted as expected by Gigi.
+      --  The following code will not tolerate such usage, but when the
+      --  expander creates this special case, it marks it as analyzed
+      --  immediately and sets an appropriate type.
+
+      when Attribute_Bit_Position =>
+
+         if Comes_From_Source (N) then
+            Check_Component;
+         end if;
+
+         Set_Etype (N, Universal_Integer);
+
+      ------------------
+      -- Body_Version --
+      ------------------
+
+      when Attribute_Body_Version =>
+         Check_E0;
+         Check_Program_Unit;
+         Set_Etype (N, RTE (RE_Version_String));
+
+      --------------
+      -- Callable --
+      --------------
+
+      when Attribute_Callable =>
+         Check_E0;
+         Set_Etype (N, Standard_Boolean);
+         Check_Task_Prefix;
+
+      ------------
+      -- Caller --
+      ------------
+
+      when Attribute_Caller => Caller : declare
+         Ent        : Entity_Id;
+         S          : Entity_Id;
+
+      begin
+         Check_E0;
+
+         if Nkind (P) = N_Identifier
+           or else Nkind (P) = N_Expanded_Name
+         then
+            Ent := Entity (P);
+
+            if not Is_Entry (Ent) then
+               Error_Attr ("invalid entry name", N);
+            end if;
+
+         else
+            Error_Attr ("invalid entry name", N);
+            return;
+         end if;
+
+         for J in reverse 0 .. Scope_Stack.Last loop
+            S := Scope_Stack.Table (J).Entity;
+
+            if S = Scope (Ent) then
+               Error_Attr ("Caller must appear in matching accept or body", N);
+            elsif S = Ent then
+               exit;
+            end if;
+         end loop;
+
+         Set_Etype (N, RTE (RO_AT_Task_ID));
+      end Caller;
+
+      -------------
+      -- Ceiling --
+      -------------
+
+      when Attribute_Ceiling =>
+         Check_Floating_Point_Type_1;
+         Set_Etype (N, P_Base_Type);
+         Resolve (E1, P_Base_Type);
+
+      -----------
+      -- Class --
+      -----------
+
+      when Attribute_Class => Class : declare
+      begin
+         Check_Restriction (No_Dispatch, N);
+         Check_Either_E0_Or_E1;
+
+         --  If we have an expression present, then really this is a conversion
+         --  and the tree must be reformed into a proper conversion. This is a
+         --  Replace rather than a Rewrite, because the original tree is junk.
+         --  If expression is overloaded, propagate interpretations to new one.
+
+         if Present (E1) then
+            Replace (N,
+              Make_Type_Conversion (Loc,
+                Subtype_Mark =>
+                  Make_Attribute_Reference (Loc,
+                    Prefix => Prefix (N),
+                    Attribute_Name => Name_Class),
+                Expression => Relocate_Node (E1)));
+
+            Save_Interps (E1, Expression (N));
+            Analyze (N);
+
+         --  Otherwise we just need to find the proper type
+
+         else
+            Find_Type (N);
+         end if;
+
+      end Class;
+
+      ------------------
+      -- Code_Address --
+      ------------------
+
+      when Attribute_Code_Address =>
+         Check_E0;
+
+         if Nkind (P) = N_Attribute_Reference
+           and then (Attribute_Name (P) = Name_Elab_Body
+                       or else
+                     Attribute_Name (P) = Name_Elab_Spec)
+         then
+            null;
+
+         elsif not Is_Entity_Name (P)
+           or else (Ekind (Entity (P)) /= E_Function
+                      and then
+                    Ekind (Entity (P)) /= E_Procedure)
+         then
+            Error_Attr ("invalid prefix for % attribute", P);
+            Set_Address_Taken (Entity (P));
+         end if;
+
+         Set_Etype (N, RTE (RE_Address));
+
+      --------------------
+      -- Component_Size --
+      --------------------
+
+      when Attribute_Component_Size =>
+         Check_E0;
+         Set_Etype (N, Universal_Integer);
+
+         --  Note: unlike other array attributes, unconstrained arrays are OK
+
+         if Is_Array_Type (P_Type) and then not Is_Constrained (P_Type) then
+            null;
+         else
+            Check_Array_Type;
+         end if;
+
+      -------------
+      -- Compose --
+      -------------
+
+      when Attribute_Compose =>
+         Check_Floating_Point_Type_2;
+         Set_Etype (N, P_Base_Type);
+         Resolve (E1, P_Base_Type);
+         Resolve (E2, Any_Integer);
+
+      -----------------
+      -- Constrained --
+      -----------------
+
+      when Attribute_Constrained =>
+         Check_E0;
+         Set_Etype (N, Standard_Boolean);
+
+         --  Case from RM J.4(2) of constrained applied to private type
+
+         if Is_Entity_Name (P) and then Is_Type (Entity (P)) then
+
+            --  If we are within an instance, the attribute must be legal
+            --  because it was valid in the generic unit.
+
+            if In_Instance then
+               return;
+
+            --  For sure OK if we have a real private type itself, but must
+            --  be completed, cannot apply Constrained to incomplete type.
+
+            elsif Is_Private_Type (Entity (P)) then
+               Check_Not_Incomplete_Type;
+               return;
+            end if;
+
+         else
+            Check_Object_Reference (P);
+
+            --  If N does not come from source, then we allow the
+            --  the attribute prefix to be of a private type whose
+            --  full type has discriminants. This occurs in cases
+            --  involving expanded calls to stream attributes.
+
+            if not Comes_From_Source (N) then
+               P_Type := Underlying_Type (P_Type);
+            end if;
+
+            --  Must have discriminants or be an access type designating
+            --  a type with discriminants. If it is a classwide type is
+            --  has unknown discriminants.
+
+            if Has_Discriminants (P_Type)
+               or else Has_Unknown_Discriminants (P_Type)
+               or else
+                 (Is_Access_Type (P_Type)
+                   and then Has_Discriminants (Designated_Type (P_Type)))
+            then
+               return;
+
+            --  Also allow an object of a generic type if extensions allowed
+            --  and allow this for any type at all.
+
+            elsif (Is_Generic_Type (P_Type)
+                     or else Is_Generic_Actual_Type (P_Type))
+              and then Extensions_Allowed
+            then
+               return;
+            end if;
+         end if;
+
+         --  Fall through if bad prefix
+
+         Error_Attr
+           ("prefix of % attribute must be object of discriminated type", P);
+
+      ---------------
+      -- Copy_Sign --
+      ---------------
+
+      when Attribute_Copy_Sign =>
+         Check_Floating_Point_Type_2;
+         Set_Etype (N, P_Base_Type);
+         Resolve (E1, P_Base_Type);
+         Resolve (E2, P_Base_Type);
+
+      -----------
+      -- Count --
+      -----------
+
+      when Attribute_Count => Count :
+      declare
+         Ent : Entity_Id;
+         S   : Entity_Id;
+         Tsk : Entity_Id;
+
+      begin
+         Check_E0;
+
+         if Nkind (P) = N_Identifier
+           or else Nkind (P) = N_Expanded_Name
+         then
+            Ent := Entity (P);
+
+            if Ekind (Ent) /= E_Entry then
+               Error_Attr ("invalid entry name", N);
+            end if;
+
+         elsif Nkind (P) = N_Indexed_Component then
+            Ent := Entity (Prefix (P));
+
+            if Ekind (Ent) /= E_Entry_Family then
+               Error_Attr ("invalid entry family name", P);
+               return;
+            end if;
+
+         else
+            Error_Attr ("invalid entry name", N);
+            return;
+         end if;
+
+         for J in reverse 0 .. Scope_Stack.Last loop
+            S := Scope_Stack.Table (J).Entity;
+
+            if S = Scope (Ent) then
+               if Nkind (P) = N_Expanded_Name then
+                  Tsk := Entity (Prefix (P));
+
+                  --  The prefix denotes either the task type, or else a
+                  --  single task whose task type is being analyzed.
+
+                  if (Is_Type (Tsk)
+                      and then Tsk = S)
+
+                    or else (not Is_Type (Tsk)
+                      and then Etype (Tsk) = S
+                      and then not (Comes_From_Source (S)))
+                  then
+                     null;
+                  else
+                     Error_Msg_N
+                       ("Count must apply to entry of current task", N);
+                  end if;
+               end if;
+
+               exit;
+
+            elsif Ekind (Scope (Ent)) in Task_Kind
+              and then Ekind (S) /= E_Loop
+              and then Ekind (S) /= E_Block
+              and then Ekind (S) /= E_Entry
+              and then Ekind (S) /= E_Entry_Family
+            then
+               Error_Attr ("Count cannot appear in inner unit", N);
+
+            elsif Ekind (Scope (Ent)) = E_Protected_Type
+              and then not Has_Completion (Scope (Ent))
+            then
+               Error_Attr ("attribute % can only be used inside body", N);
+            end if;
+         end loop;
+
+         if Is_Overloaded (P) then
+            declare
+               Index : Interp_Index;
+               It    : Interp;
+
+            begin
+               Get_First_Interp (P, Index, It);
+
+               while Present (It.Nam) loop
+                  if It.Nam = Ent then
+                     null;
+
+                  elsif Scope (It.Nam) = Scope (Ent) then
+                     Error_Attr ("ambiguous entry name", N);
+
+                  else
+                     --  For now make this into a warning. Will become an
+                     --  error after the 3.15 release.
+
+                     Error_Msg_N
+                       ("ambiguous name, resolved to entry?", N);
+                     Error_Msg_N
+                       ("\(this will become an error in a later release)?", N);
+                  end if;
+
+                  Get_Next_Interp (Index, It);
+               end loop;
+            end;
+         end if;
+
+         Set_Etype (N, Universal_Integer);
+      end Count;
+
+      -----------------------
+      -- Default_Bit_Order --
+      -----------------------
+
+      when Attribute_Default_Bit_Order => Default_Bit_Order :
+      begin
+         Check_Standard_Prefix;
+         Check_E0;
+
+         if Bytes_Big_Endian then
+            Rewrite (N,
+              Make_Integer_Literal (Loc, False_Value));
+         else
+            Rewrite (N,
+              Make_Integer_Literal (Loc, True_Value));
+         end if;
+
+         Set_Etype (N, Universal_Integer);
+         Set_Is_Static_Expression (N);
+      end Default_Bit_Order;
+
+      --------------
+      -- Definite --
+      --------------
+
+      when Attribute_Definite =>
+         Legal_Formal_Attribute;
+
+      -----------
+      -- Delta --
+      -----------
+
+      when Attribute_Delta =>
+         Check_Fixed_Point_Type_0;
+         Set_Etype (N, Universal_Real);
+
+      ------------
+      -- Denorm --
+      ------------
+
+      when Attribute_Denorm =>
+         Check_Floating_Point_Type_0;
+         Set_Etype (N, Standard_Boolean);
+
+      ------------
+      -- Digits --
+      ------------
+
+      when Attribute_Digits =>
+         Check_E0;
+         Check_Type;
+
+         if not Is_Floating_Point_Type (P_Type)
+           and then not Is_Decimal_Fixed_Point_Type (P_Type)
+         then
+            Error_Attr
+              ("prefix of % attribute must be float or decimal type", P);
+         end if;
+
+         Set_Etype (N, Universal_Integer);
+
+      ---------------
+      -- Elab_Body --
+      ---------------
+
+      --  Also handles processing for Elab_Spec
+
+      when Attribute_Elab_Body | Attribute_Elab_Spec =>
+         Check_E0;
+         Check_Unit_Name (P);
+         Set_Etype (N, Standard_Void_Type);
+
+         --  We have to manually call the expander in this case to get
+         --  the necessary expansion (normally attributes that return
+         --  entities are not expanded).
+
+         Expand (N);
+
+      ---------------
+      -- Elab_Spec --
+      ---------------
+
+      --  Shares processing with Elab_Body
+
+      ----------------
+      -- Elaborated --
+      ----------------
+
+      when Attribute_Elaborated =>
+         Check_E0;
+         Check_Library_Unit;
+         Set_Etype (N, Standard_Boolean);
+
+      ----------
+      -- Emax --
+      ----------
+
+      when Attribute_Emax =>
+         Check_Floating_Point_Type_0;
+         Set_Etype (N, Universal_Integer);
+
+      --------------
+      -- Enum_Rep --
+      --------------
+
+      when Attribute_Enum_Rep => Enum_Rep : declare
+      begin
+         if Present (E1) then
+            Check_E1;
+            Check_Discrete_Type;
+            Resolve (E1, P_Base_Type);
+
+         else
+            if not Is_Entity_Name (P)
+              or else (not Is_Object (Entity (P))
+                         and then
+                       Ekind (Entity (P)) /= E_Enumeration_Literal)
+            then
+               Error_Attr
+                 ("prefix of %attribute must be " &
+                  "discrete type/object or enum literal", P);
+            end if;
+         end if;
+
+         Set_Etype (N, Universal_Integer);
+      end Enum_Rep;
+
+      -------------
+      -- Epsilon --
+      -------------
+
+      when Attribute_Epsilon =>
+         Check_Floating_Point_Type_0;
+         Set_Etype (N, Universal_Real);
+
+      --------------
+      -- Exponent --
+      --------------
+
+      when Attribute_Exponent =>
+         Check_Floating_Point_Type_1;
+         Set_Etype (N, Universal_Integer);
+         Resolve (E1, P_Base_Type);
+
+      ------------------
+      -- External_Tag --
+      ------------------
+
+      when Attribute_External_Tag =>
+         Check_E0;
+         Check_Type;
+
+         Set_Etype (N, Standard_String);
+
+         if not Is_Tagged_Type (P_Type) then
+            Error_Attr ("prefix of % attribute must be tagged", P);
+         end if;
+
+      -----------
+      -- First --
+      -----------
+
+      when Attribute_First =>
+         Check_Array_Or_Scalar_Type;
+
+      ---------------
+      -- First_Bit --
+      ---------------
+
+      when Attribute_First_Bit =>
+         Check_Component;
+         Set_Etype (N, Universal_Integer);
+
+      -----------------
+      -- Fixed_Value --
+      -----------------
+
+      when Attribute_Fixed_Value =>
+         Check_E1;
+         Check_Fixed_Point_Type;
+         Resolve (E1, Any_Integer);
+         Set_Etype (N, P_Base_Type);
+
+      -----------
+      -- Floor --
+      -----------
+
+      when Attribute_Floor =>
+         Check_Floating_Point_Type_1;
+         Set_Etype (N, P_Base_Type);
+         Resolve (E1, P_Base_Type);
+
+      ----------
+      -- Fore --
+      ----------
+
+      when Attribute_Fore =>
+         Check_Fixed_Point_Type_0;
+         Set_Etype (N, Universal_Integer);
+
+      --------------
+      -- Fraction --
+      --------------
+
+      when Attribute_Fraction =>
+         Check_Floating_Point_Type_1;
+         Set_Etype (N, P_Base_Type);
+         Resolve (E1, P_Base_Type);
+
+      -----------------------
+      -- Has_Discriminants --
+      -----------------------
+
+      when Attribute_Has_Discriminants =>
+         Legal_Formal_Attribute;
+
+      --------------
+      -- Identity --
+      --------------
+
+      when Attribute_Identity =>
+         Check_E0;
+         Analyze (P);
+
+         if Etype (P) =  Standard_Exception_Type then
+            Set_Etype (N, RTE (RE_Exception_Id));
+
+         elsif Is_Task_Type (Etype (P))
+           or else (Is_Access_Type (Etype (P))
+              and then Is_Task_Type (Designated_Type (Etype (P))))
+         then
+            Resolve (P, Etype (P));
+            Set_Etype (N, RTE (RO_AT_Task_ID));
+
+         else
+            Error_Attr ("prefix of % attribute must be a task or an "
+              & "exception", P);
+         end if;
+
+      -----------
+      -- Image --
+      -----------
+
+      when Attribute_Image => Image :
+      begin
+         Set_Etype (N, Standard_String);
+         Check_Scalar_Type;
+
+         if Is_Real_Type (P_Type) then
+            if Ada_83 and then Comes_From_Source (N) then
+               Error_Msg_Name_1 := Aname;
+               Error_Msg_N
+                 ("(Ada 83) % attribute not allowed for real types", N);
+            end if;
+         end if;
+
+         if Is_Enumeration_Type (P_Type) then
+            Check_Restriction (No_Enumeration_Maps, N);
+         end if;
+
+         Check_E1;
+         Resolve (E1, P_Base_Type);
+         Check_Enum_Image;
+         Validate_Non_Static_Attribute_Function_Call;
+      end Image;
+
+      ---------
+      -- Img --
+      ---------
+
+      when Attribute_Img => Img :
+      begin
+         Set_Etype (N, Standard_String);
+
+         if not Is_Scalar_Type (P_Type)
+           or else (Is_Entity_Name (P) and then Is_Type (Entity (P)))
+         then
+            Error_Attr
+              ("prefix of % attribute must be scalar object name", N);
+         end if;
+
+         Check_Enum_Image;
+      end Img;
+
+      -----------
+      -- Input --
+      -----------
+
+      when Attribute_Input =>
+         Check_E1;
+         Check_Stream_Attribute (Name_uInput);
+         Disallow_In_No_Run_Time_Mode (N);
+         Set_Etype (N, P_Base_Type);
+
+      -------------------
+      -- Integer_Value --
+      -------------------
+
+      when Attribute_Integer_Value =>
+         Check_E1;
+         Check_Integer_Type;
+         Resolve (E1, Any_Fixed);
+         Set_Etype (N, P_Base_Type);
+
+      -----------
+      -- Large --
+      -----------
+
+      when Attribute_Large =>
+         Check_E0;
+         Check_Real_Type;
+         Set_Etype (N, Universal_Real);
+
+      ----------
+      -- Last --
+      ----------
+
+      when Attribute_Last =>
+         Check_Array_Or_Scalar_Type;
+
+      --------------
+      -- Last_Bit --
+      --------------
+
+      when Attribute_Last_Bit =>
+         Check_Component;
+         Set_Etype (N, Universal_Integer);
+
+      ------------------
+      -- Leading_Part --
+      ------------------
+
+      when Attribute_Leading_Part =>
+         Check_Floating_Point_Type_2;
+         Set_Etype (N, P_Base_Type);
+         Resolve (E1, P_Base_Type);
+         Resolve (E2, Any_Integer);
+
+      ------------
+      -- Length --
+      ------------
+
+      when Attribute_Length =>
+         Check_Array_Type;
+         Set_Etype (N, Universal_Integer);
+
+      -------------
+      -- Machine --
+      -------------
+
+      when Attribute_Machine =>
+         Check_Floating_Point_Type_1;
+         Set_Etype (N, P_Base_Type);
+         Resolve (E1, P_Base_Type);
+
+      ------------------
+      -- Machine_Emax --
+      ------------------
+
+      when Attribute_Machine_Emax =>
+         Check_Floating_Point_Type_0;
+         Set_Etype (N, Universal_Integer);
+
+      ------------------
+      -- Machine_Emin --
+      ------------------
+
+      when Attribute_Machine_Emin =>
+         Check_Floating_Point_Type_0;
+         Set_Etype (N, Universal_Integer);
+
+      ----------------------
+      -- Machine_Mantissa --
+      ----------------------
+
+      when Attribute_Machine_Mantissa =>
+         Check_Floating_Point_Type_0;
+         Set_Etype (N, Universal_Integer);
+
+      -----------------------
+      -- Machine_Overflows --
+      -----------------------
+
+      when Attribute_Machine_Overflows =>
+         Check_Real_Type;
+         Check_E0;
+         Set_Etype (N, Standard_Boolean);
+
+      -------------------
+      -- Machine_Radix --
+      -------------------
+
+      when Attribute_Machine_Radix =>
+         Check_Real_Type;
+         Check_E0;
+         Set_Etype (N, Universal_Integer);
+
+      --------------------
+      -- Machine_Rounds --
+      --------------------
+
+      when Attribute_Machine_Rounds =>
+         Check_Real_Type;
+         Check_E0;
+         Set_Etype (N, Standard_Boolean);
+
+      ------------------
+      -- Machine_Size --
+      ------------------
+
+      when Attribute_Machine_Size =>
+         Check_E0;
+         Check_Type;
+         Check_Not_Incomplete_Type;
+         Set_Etype (N, Universal_Integer);
+
+      --------------
+      -- Mantissa --
+      --------------
+
+      when Attribute_Mantissa =>
+         Check_E0;
+         Check_Real_Type;
+         Set_Etype (N, Universal_Integer);
+
+      ---------
+      -- Max --
+      ---------
+
+      when Attribute_Max =>
+         Check_E2;
+         Check_Scalar_Type;
+         Resolve (E1, P_Base_Type);
+         Resolve (E2, P_Base_Type);
+         Set_Etype (N, P_Base_Type);
+
+      ----------------------------
+      -- Max_Interrupt_Priority --
+      ----------------------------
+
+      when Attribute_Max_Interrupt_Priority =>
+         Standard_Attribute
+           (UI_To_Int
+             (Expr_Value
+               (Expression
+                 (Parent (RTE (RE_Max_Interrupt_Priority))))));
+
+      ------------------
+      -- Max_Priority --
+      ------------------
+
+      when Attribute_Max_Priority =>
+         Standard_Attribute
+           (UI_To_Int
+             (Expr_Value
+               (Expression
+                 (Parent (RTE (RE_Max_Priority))))));
+
+      ----------------------------------
+      -- Max_Size_In_Storage_Elements --
+      ----------------------------------
+
+      when Attribute_Max_Size_In_Storage_Elements =>
+         Check_E0;
+         Check_Type;
+         Check_Not_Incomplete_Type;
+         Set_Etype (N, Universal_Integer);
+
+      -----------------------
+      -- Maximum_Alignment --
+      -----------------------
+
+      when Attribute_Maximum_Alignment =>
+         Standard_Attribute (Ttypes.Maximum_Alignment);
+
+      --------------------
+      -- Mechanism_Code --
+      --------------------
+
+      when Attribute_Mechanism_Code =>
+
+         if not Is_Entity_Name (P)
+           or else not Is_Subprogram (Entity (P))
+         then
+            Error_Attr ("prefix of % attribute must be subprogram", P);
+         end if;
+
+         Check_Either_E0_Or_E1;
+
+         if Present (E1) then
+            Resolve (E1, Any_Integer);
+            Set_Etype (E1, Standard_Integer);
+
+            if not Is_Static_Expression (E1) then
+               Error_Attr
+                 ("expression for parameter number must be static", E1);
+
+            elsif UI_To_Int (Intval (E1)) > Number_Formals (Entity (P))
+              or else UI_To_Int (Intval (E1)) < 0
+            then
+               Error_Attr ("invalid parameter number for %attribute", E1);
+            end if;
+         end if;
+
+         Set_Etype (N, Universal_Integer);
+
+      ---------
+      -- Min --
+      ---------
+
+      when Attribute_Min =>
+         Check_E2;
+         Check_Scalar_Type;
+         Resolve (E1, P_Base_Type);
+         Resolve (E2, P_Base_Type);
+         Set_Etype (N, P_Base_Type);
+
+      -----------
+      -- Model --
+      -----------
+
+      when Attribute_Model =>
+         Check_Floating_Point_Type_1;
+         Set_Etype (N, P_Base_Type);
+         Resolve (E1, P_Base_Type);
+
+      ----------------
+      -- Model_Emin --
+      ----------------
+
+      when Attribute_Model_Emin =>
+         Check_Floating_Point_Type_0;
+         Set_Etype (N, Universal_Integer);
+
+      -------------------
+      -- Model_Epsilon --
+      -------------------
+
+      when Attribute_Model_Epsilon =>
+         Check_Floating_Point_Type_0;
+         Set_Etype (N, Universal_Real);
+
+      --------------------
+      -- Model_Mantissa --
+      --------------------
+
+      when Attribute_Model_Mantissa =>
+         Check_Floating_Point_Type_0;
+         Set_Etype (N, Universal_Integer);
+
+      -----------------
+      -- Model_Small --
+      -----------------
+
+      when Attribute_Model_Small =>
+         Check_Floating_Point_Type_0;
+         Set_Etype (N, Universal_Real);
+
+      -------------
+      -- Modulus --
+      -------------
+
+      when Attribute_Modulus =>
+         Check_E0;
+         Check_Type;
+
+         if not Is_Modular_Integer_Type (P_Type) then
+            Error_Attr ("prefix of % attribute must be modular type", P);
+         end if;
+
+         Set_Etype (N, Universal_Integer);
+
+      --------------------
+      -- Null_Parameter --
+      --------------------
+
+      when Attribute_Null_Parameter => Null_Parameter : declare
+         Parnt  : constant Node_Id := Parent (N);
+         GParnt : constant Node_Id := Parent (Parnt);
+
+         procedure Bad_Null_Parameter (Msg : String);
+         --  Used if bad Null parameter attribute node is found. Issues
+         --  given error message, and also sets the type to Any_Type to
+         --  avoid blowups later on from dealing with a junk node.
+
+         procedure Must_Be_Imported (Proc_Ent : Entity_Id);
+         --  Called to check that Proc_Ent is imported subprogram
+
+         ------------------------
+         -- Bad_Null_Parameter --
+         ------------------------
+
+         procedure Bad_Null_Parameter (Msg : String) is
+         begin
+            Error_Msg_N (Msg, N);
+            Set_Etype (N, Any_Type);
+         end Bad_Null_Parameter;
+
+         ----------------------
+         -- Must_Be_Imported --
+         ----------------------
+
+         procedure Must_Be_Imported (Proc_Ent : Entity_Id) is
+            Pent : Entity_Id := Proc_Ent;
+
+         begin
+            while Present (Alias (Pent)) loop
+               Pent := Alias (Pent);
+            end loop;
+
+            --  Ignore check if procedure not frozen yet (we will get
+            --  another chance when the default parameter is reanalyzed)
+
+            if not Is_Frozen (Pent) then
+               return;
+
+            elsif not Is_Imported (Pent) then
+               Bad_Null_Parameter
+                 ("Null_Parameter can only be used with imported subprogram");
+
+            else
+               return;
+            end if;
+         end Must_Be_Imported;
+
+      --  Start of processing for Null_Parameter
+
+      begin
+         Check_Type;
+         Check_E0;
+         Set_Etype (N, P_Type);
+
+         --  Case of attribute used as default expression
+
+         if Nkind (Parnt) = N_Parameter_Specification then
+            Must_Be_Imported (Defining_Entity (GParnt));
+
+         --  Case of attribute used as actual for subprogram (positional)
+
+         elsif (Nkind (Parnt) = N_Procedure_Call_Statement
+                 or else
+                Nkind (Parnt) = N_Function_Call)
+            and then Is_Entity_Name (Name (Parnt))
+         then
+            Must_Be_Imported (Entity (Name (Parnt)));
+
+         --  Case of attribute used as actual for subprogram (named)
+
+         elsif Nkind (Parnt) = N_Parameter_Association
+           and then (Nkind (GParnt) = N_Procedure_Call_Statement
+                       or else
+                     Nkind (GParnt) = N_Function_Call)
+           and then Is_Entity_Name (Name (GParnt))
+         then
+            Must_Be_Imported (Entity (Name (GParnt)));
+
+         --  Not an allowed case
+
+         else
+            Bad_Null_Parameter
+              ("Null_Parameter must be actual or default parameter");
+         end if;
+
+      end Null_Parameter;
+
+      -----------------
+      -- Object_Size --
+      -----------------
+
+      when Attribute_Object_Size =>
+         Check_E0;
+         Check_Type;
+         Check_Not_Incomplete_Type;
+         Set_Etype (N, Universal_Integer);
+
+      ------------
+      -- Output --
+      ------------
+
+      when Attribute_Output =>
+         Check_E2;
+         Check_Stream_Attribute (Name_uInput);
+         Set_Etype (N, Standard_Void_Type);
+         Disallow_In_No_Run_Time_Mode (N);
+         Resolve (N, Standard_Void_Type);
+
+      ------------------
+      -- Partition_ID --
+      ------------------
+
+      when Attribute_Partition_ID =>
+         Check_E0;
+
+         if P_Type /= Any_Type then
+            if not Is_Library_Level_Entity (Entity (P)) then
+               Error_Attr
+                 ("prefix of % attribute must be library-level entity", P);
+
+            --  The defining entity of prefix should not be declared inside
+            --  a Pure unit. RM E.1(8).
+            --  The Is_Pure flag has been set during declaration.
+
+            elsif Is_Entity_Name (P)
+              and then Is_Pure (Entity (P))
+            then
+               Error_Attr
+                 ("prefix of % attribute must not be declared pure", P);
+            end if;
+         end if;
+
+         Set_Etype (N, Universal_Integer);
+
+      -------------------------
+      -- Passed_By_Reference --
+      -------------------------
+
+      when Attribute_Passed_By_Reference =>
+         Check_E0;
+         Check_Type;
+         Set_Etype (N, Standard_Boolean);
+
+      ---------
+      -- Pos --
+      ---------
+
+      when Attribute_Pos =>
+         Check_Discrete_Type;
+         Check_E1;
+         Resolve (E1, P_Base_Type);
+         Set_Etype (N, Universal_Integer);
+
+      --------------
+      -- Position --
+      --------------
+
+      when Attribute_Position =>
+         Check_Component;
+         Set_Etype (N, Universal_Integer);
+
+      ----------
+      -- Pred --
+      ----------
+
+      when Attribute_Pred =>
+         Check_Scalar_Type;
+         Check_E1;
+         Resolve (E1, P_Base_Type);
+         Set_Etype (N, P_Base_Type);
+
+         --  Nothing to do for real type case
+
+         if Is_Real_Type (P_Type) then
+            null;
+
+         --  If not modular type, test for overflow check required
+
+         else
+            if not Is_Modular_Integer_Type (P_Type)
+              and then not Range_Checks_Suppressed (P_Base_Type)
+            then
+               Enable_Range_Check (E1);
+            end if;
+         end if;
+
+      -----------
+      -- Range --
+      -----------
+
+      when Attribute_Range =>
+         Check_Array_Or_Scalar_Type;
+
+         if Ada_83
+           and then Is_Scalar_Type (P_Type)
+           and then Comes_From_Source (N)
+         then
+            Error_Attr
+              ("(Ada 83) % attribute not allowed for scalar type", P);
+         end if;
+
+      ------------------
+      -- Range_Length --
+      ------------------
+
+      when Attribute_Range_Length =>
+         Check_Discrete_Type;
+         Set_Etype (N, Universal_Integer);
+
+      ----------
+      -- Read --
+      ----------
+
+      when Attribute_Read =>
+         Check_E2;
+         Check_Stream_Attribute (Name_uRead);
+         Set_Etype (N, Standard_Void_Type);
+         Resolve (N, Standard_Void_Type);
+         Disallow_In_No_Run_Time_Mode (N);
+         Note_Possible_Modification (E2);
+
+      ---------------
+      -- Remainder --
+      ---------------
+
+      when Attribute_Remainder =>
+         Check_Floating_Point_Type_2;
+         Set_Etype (N, P_Base_Type);
+         Resolve (E1, P_Base_Type);
+         Resolve (E2, P_Base_Type);
+
+      -----------
+      -- Round --
+      -----------
+
+      when Attribute_Round =>
+         Check_E1;
+         Check_Decimal_Fixed_Point_Type;
+         Set_Etype (N, P_Base_Type);
+
+         --  Because the context is universal_real (3.5.10(12)) it is a legal
+         --  context for a universal fixed expression. This is the only
+         --  attribute whose functional description involves U_R.
+
+         if Etype (E1) = Universal_Fixed then
+            declare
+               Conv : constant Node_Id := Make_Type_Conversion (Loc,
+                  Subtype_Mark => New_Occurrence_Of (Universal_Real, Loc),
+                  Expression   => Relocate_Node (E1));
+
+            begin
+               Rewrite (E1, Conv);
+               Analyze (E1);
+            end;
+         end if;
+
+         Resolve (E1, Any_Real);
+
+      --------------
+      -- Rounding --
+      --------------
+
+      when Attribute_Rounding =>
+         Check_Floating_Point_Type_1;
+         Set_Etype (N, P_Base_Type);
+         Resolve (E1, P_Base_Type);
+
+      ---------------
+      -- Safe_Emax --
+      ---------------
+
+      when Attribute_Safe_Emax =>
+         Check_Floating_Point_Type_0;
+         Set_Etype (N, Universal_Integer);
+
+      ----------------
+      -- Safe_First --
+      ----------------
+
+      when Attribute_Safe_First =>
+         Check_Floating_Point_Type_0;
+         Set_Etype (N, Universal_Real);
+
+      ----------------
+      -- Safe_Large --
+      ----------------
+
+      when Attribute_Safe_Large =>
+         Check_E0;
+         Check_Real_Type;
+         Set_Etype (N, Universal_Real);
+
+      ---------------
+      -- Safe_Last --
+      ---------------
+
+      when Attribute_Safe_Last =>
+         Check_Floating_Point_Type_0;
+         Set_Etype (N, Universal_Real);
+
+      ----------------
+      -- Safe_Small --
+      ----------------
+
+      when Attribute_Safe_Small =>
+         Check_E0;
+         Check_Real_Type;
+         Set_Etype (N, Universal_Real);
+
+      -----------
+      -- Scale --
+      -----------
+
+      when Attribute_Scale =>
+         Check_E0;
+         Check_Decimal_Fixed_Point_Type;
+         Set_Etype (N, Universal_Integer);
+
+      -------------
+      -- Scaling --
+      -------------
+
+      when Attribute_Scaling =>
+         Check_Floating_Point_Type_2;
+         Set_Etype (N, P_Base_Type);
+         Resolve (E1, P_Base_Type);
+
+      ------------------
+      -- Signed_Zeros --
+      ------------------
+
+      when Attribute_Signed_Zeros =>
+         Check_Floating_Point_Type_0;
+         Set_Etype (N, Standard_Boolean);
+
+      ----------
+      -- Size --
+      ----------
+
+      when Attribute_Size | Attribute_VADS_Size =>
+         Check_E0;
+
+         if Is_Object_Reference (P)
+           or else (Is_Entity_Name (P)
+                      and then
+                    Ekind (Entity (P)) = E_Function)
+         then
+            Check_Object_Reference (P);
+
+         elsif Nkind (P) = N_Attribute_Reference
+           or else
+             (Nkind (P) = N_Selected_Component
+               and then (Is_Entry (Entity (Selector_Name (P)))
+                           or else
+                         Is_Subprogram (Entity (Selector_Name (P)))))
+           or else
+             (Is_Entity_Name (P)
+               and then not Is_Type (Entity (P))
+               and then not Is_Object (Entity (P)))
+         then
+            Error_Attr ("invalid prefix for % attribute", P);
+         end if;
+
+         Check_Not_Incomplete_Type;
+         Set_Etype (N, Universal_Integer);
+
+      -----------
+      -- Small --
+      -----------
+
+      when Attribute_Small =>
+         Check_E0;
+         Check_Real_Type;
+         Set_Etype (N, Universal_Real);
+
+      ------------------
+      -- Storage_Pool --
+      ------------------
+
+      when Attribute_Storage_Pool =>
+         if Is_Access_Type (P_Type) then
+            Check_E0;
+
+            --  Set appropriate entity
+
+            if Present (Associated_Storage_Pool (Root_Type (P_Type))) then
+               Set_Entity (N, Associated_Storage_Pool (Root_Type (P_Type)));
+            else
+               Set_Entity (N, RTE (RE_Global_Pool_Object));
+            end if;
+
+            Set_Etype (N, Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
+
+            --  Validate_Remote_Access_To_Class_Wide_Type for attribute
+            --  Storage_Pool since this attribute is not defined for such
+            --  types (RM E.2.3(22)).
+
+            Validate_Remote_Access_To_Class_Wide_Type (N);
+
+         else
+            Error_Attr ("prefix of % attribute must be access type", P);
+         end if;
+
+      ------------------
+      -- Storage_Size --
+      ------------------
+
+      when Attribute_Storage_Size =>
+
+         if Is_Task_Type (P_Type) then
+            Check_E0;
+            Set_Etype (N, Universal_Integer);
+
+         elsif Is_Access_Type (P_Type) then
+            if Is_Entity_Name (P)
+              and then Is_Type (Entity (P))
+            then
+               Check_E0;
+               Check_Type;
+               Set_Etype (N, Universal_Integer);
+
+               --   Validate_Remote_Access_To_Class_Wide_Type for attribute
+               --   Storage_Size since this attribute is not defined for
+               --   such types (RM E.2.3(22)).
+
+               Validate_Remote_Access_To_Class_Wide_Type (N);
+
+            --  The prefix is allowed to be an implicit dereference
+            --  of an access value designating a task.
+
+            else
+               Check_E0;
+               Check_Task_Prefix;
+               Set_Etype (N, Universal_Integer);
+            end if;
+
+         else
+            Error_Attr
+              ("prefix of % attribute must be access or task type", P);
+         end if;
+
+      ------------------
+      -- Storage_Unit --
+      ------------------
+
+      when Attribute_Storage_Unit =>
+         Standard_Attribute (Ttypes.System_Storage_Unit);
+
+      ----------
+      -- Succ --
+      ----------
+
+      when Attribute_Succ =>
+         Check_Scalar_Type;
+         Check_E1;
+         Resolve (E1, P_Base_Type);
+         Set_Etype (N, P_Base_Type);
+
+         --  Nothing to do for real type case
+
+         if Is_Real_Type (P_Type) then
+            null;
+
+         --  If not modular type, test for overflow check required.
+
+         else
+            if not Is_Modular_Integer_Type (P_Type)
+              and then not Range_Checks_Suppressed (P_Base_Type)
+            then
+               Enable_Range_Check (E1);
+            end if;
+         end if;
+
+      ---------
+      -- Tag --
+      ---------
+
+      when Attribute_Tag =>
+         Check_E0;
+         Check_Dereference;
+
+         if not Is_Tagged_Type (P_Type) then
+            Error_Attr ("prefix of % attribute must be tagged", P);
+
+         --  Next test does not apply to generated code
+         --  why not, and what does the illegal reference mean???
+
+         elsif Is_Object_Reference (P)
+           and then not Is_Class_Wide_Type (P_Type)
+           and then Comes_From_Source (N)
+         then
+            Error_Attr
+              ("% attribute can only be applied to objects of class-wide type",
+               P);
+         end if;
+
+         Set_Etype (N, RTE (RE_Tag));
+
+      ----------------
+      -- Terminated --
+      ----------------
+
+      when Attribute_Terminated =>
+         Check_E0;
+         Set_Etype (N, Standard_Boolean);
+         Check_Task_Prefix;
+
+      ----------
+      -- Tick --
+      ----------
+
+      when Attribute_Tick =>
+         Check_Standard_Prefix;
+         Rewrite (N,
+           Make_Real_Literal (Loc,
+             UR_From_Components (
+               Num   => UI_From_Int (Ttypes.System_Tick_Nanoseconds),
+               Den   => UI_From_Int (9),
+               Rbase => 10)));
+         Analyze (N);
+
+      ----------------
+      -- To_Address --
+      ----------------
+
+      when Attribute_To_Address =>
+         Check_E1;
+         Analyze (P);
+
+         if Nkind (P) /= N_Identifier
+           or else Chars (P) /= Name_System
+         then
+            Error_Attr ("prefix of %attribute must be System", P);
+         end if;
+
+         Generate_Reference (RTE (RE_Address), P);
+         Analyze_And_Resolve (E1, Any_Integer);
+         Set_Etype (N, RTE (RE_Address));
+
+      ----------------
+      -- Truncation --
+      ----------------
+
+      when Attribute_Truncation =>
+         Check_Floating_Point_Type_1;
+         Resolve (E1, P_Base_Type);
+         Set_Etype (N, P_Base_Type);
+
+      ----------------
+      -- Type_Class --
+      ----------------
+
+      when Attribute_Type_Class =>
+         Check_E0;
+         Check_Type;
+         Check_Not_Incomplete_Type;
+         Set_Etype (N, RTE (RE_Type_Class));
+
+      -----------------
+      -- UET_Address --
+      -----------------
+
+      when Attribute_UET_Address =>
+         Check_E0;
+         Check_Unit_Name (P);
+         Set_Etype (N, RTE (RE_Address));
+
+      -----------------------
+      -- Unbiased_Rounding --
+      -----------------------
+
+      when Attribute_Unbiased_Rounding =>
+         Check_Floating_Point_Type_1;
+         Set_Etype (N, P_Base_Type);
+         Resolve (E1, P_Base_Type);
+
+      ----------------------
+      -- Unchecked_Access --
+      ----------------------
+
+      when Attribute_Unchecked_Access =>
+         if Comes_From_Source (N) then
+            Check_Restriction (No_Unchecked_Access, N);
+         end if;
+
+         Access_Attribute;
+
+      ------------------------------
+      -- Universal_Literal_String --
+      ------------------------------
+
+      --  This is a GNAT specific attribute whose prefix must be a named
+      --  number where the expression is either a single numeric literal,
+      --  or a numeric literal immediately preceded by a minus sign. The
+      --  result is equivalent to a string literal containing the text of
+      --  the literal as it appeared in the source program with a possible
+      --  leading minus sign.
+
+      when Attribute_Universal_Literal_String => Universal_Literal_String :
+      begin
+         Check_E0;
+
+         if not Is_Entity_Name (P)
+           or else Ekind (Entity (P)) not in Named_Kind
+         then
+            Error_Attr ("prefix for % attribute must be named number", P);
+
+         else
+            declare
+               Expr     : Node_Id;
+               Negative : Boolean;
+               S        : Source_Ptr;
+               Src      : Source_Buffer_Ptr;
+
+            begin
+               Expr := Original_Node (Expression (Parent (Entity (P))));
+
+               if Nkind (Expr) = N_Op_Minus then
+                  Negative := True;
+                  Expr := Original_Node (Right_Opnd (Expr));
+               else
+                  Negative := False;
+               end if;
+
+               if Nkind (Expr) /= N_Integer_Literal
+                 and then Nkind (Expr) /= N_Real_Literal
+               then
+                  Error_Attr
+                    ("named number for % attribute must be simple literal", N);
+               end if;
+
+               --  Build string literal corresponding to source literal text
+
+               Start_String;
+
+               if Negative then
+                  Store_String_Char (Get_Char_Code ('-'));
+               end if;
+
+               S := Sloc (Expr);
+               Src := Source_Text (Get_Source_File_Index (S));
+
+               while Src (S) /= ';' and then Src (S) /= ' ' loop
+                  Store_String_Char (Get_Char_Code (Src (S)));
+                  S := S + 1;
+               end loop;
+
+               --  Now we rewrite the attribute with the string literal
+
+               Rewrite (N,
+                 Make_String_Literal (Loc, End_String));
+               Analyze (N);
+            end;
+         end if;
+      end Universal_Literal_String;
+
+      -------------------------
+      -- Unrestricted_Access --
+      -------------------------
+
+      --  This is a GNAT specific attribute which is like Access except that
+      --  all scope checks and checks for aliased views are omitted.
+
+      when Attribute_Unrestricted_Access =>
+         if Comes_From_Source (N) then
+            Check_Restriction (No_Unchecked_Access, N);
+         end if;
+
+         if Is_Entity_Name (P) then
+            Set_Address_Taken (Entity (P));
+         end if;
+
+         Access_Attribute;
+
+      ---------
+      -- Val --
+      ---------
+
+      when Attribute_Val => Val : declare
+      begin
+         Check_E1;
+         Check_Discrete_Type;
+         Resolve (E1, Any_Integer);
+         Set_Etype (N, P_Base_Type);
+
+         --  Note, we need a range check in general, but we wait for the
+         --  Resolve call to do this, since we want to let Eval_Attribute
+         --  have a chance to find an static illegality first!
+      end Val;
+
+      -----------
+      -- Valid --
+      -----------
+
+      when Attribute_Valid =>
+         Check_E0;
+
+         --  Ignore check for object if we have a 'Valid reference generated
+         --  by the expanded code, since in some cases valid checks can occur
+         --  on items that are names, but are not objects (e.g. attributes).
+
+         if Comes_From_Source (N) then
+            Check_Object_Reference (P);
+         end if;
+
+         if not Is_Scalar_Type (P_Type) then
+            Error_Attr ("object for % attribute must be of scalar type", P);
+         end if;
+
+         Set_Etype (N, Standard_Boolean);
+
+      -----------
+      -- Value --
+      -----------
+
+      when Attribute_Value => Value :
+      begin
+         Check_E1;
+         Check_Scalar_Type;
+
+         if Is_Enumeration_Type (P_Type) then
+            Check_Restriction (No_Enumeration_Maps, N);
+         end if;
+
+         --  Set Etype before resolving expression because expansion
+         --  of expression may require enclosing type.
+
+         Set_Etype (N, P_Type);
+         Validate_Non_Static_Attribute_Function_Call;
+      end Value;
+
+      ----------------
+      -- Value_Size --
+      ----------------
+
+      when Attribute_Value_Size =>
+         Check_E0;
+         Check_Type;
+         Check_Not_Incomplete_Type;
+         Set_Etype (N, Universal_Integer);
+
+      -------------
+      -- Version --
+      -------------
+
+      when Attribute_Version =>
+         Check_E0;
+         Check_Program_Unit;
+         Set_Etype (N, RTE (RE_Version_String));
+
+      ------------------
+      -- Wchar_T_Size --
+      ------------------
+
+      when Attribute_Wchar_T_Size =>
+         Standard_Attribute (Interfaces_Wchar_T_Size);
+
+      ----------------
+      -- Wide_Image --
+      ----------------
+
+      when Attribute_Wide_Image => Wide_Image :
+      begin
+         Check_Scalar_Type;
+         Set_Etype (N, Standard_Wide_String);
+         Check_E1;
+         Resolve (E1, P_Base_Type);
+         Validate_Non_Static_Attribute_Function_Call;
+      end Wide_Image;
+
+      ----------------
+      -- Wide_Value --
+      ----------------
+
+      when Attribute_Wide_Value => Wide_Value :
+      begin
+         Check_E1;
+         Check_Scalar_Type;
+
+         --  Set Etype before resolving expression because expansion
+         --  of expression may require enclosing type.
+
+         Set_Etype (N, P_Type);
+         Validate_Non_Static_Attribute_Function_Call;
+      end Wide_Value;
+
+      ----------------
+      -- Wide_Width --
+      ----------------
+
+      when Attribute_Wide_Width =>
+         Check_E0;
+         Check_Scalar_Type;
+         Set_Etype (N, Universal_Integer);
+
+      -----------
+      -- Width --
+      -----------
+
+      when Attribute_Width =>
+         Check_E0;
+         Check_Scalar_Type;
+         Set_Etype (N, Universal_Integer);
+
+      ---------------
+      -- Word_Size --
+      ---------------
+
+      when Attribute_Word_Size =>
+         Standard_Attribute (System_Word_Size);
+
+      -----------
+      -- Write --
+      -----------
+
+      when Attribute_Write =>
+         Check_E2;
+         Check_Stream_Attribute (Name_uWrite);
+         Set_Etype (N, Standard_Void_Type);
+         Disallow_In_No_Run_Time_Mode (N);
+         Resolve (N, Standard_Void_Type);
+
+      end case;
+
+   --  All errors raise Bad_Attribute, so that we get out before any further
+   --  damage occurs when an error is detected (for example, if we check for
+   --  one attribute expression, and the check succeeds, we want to be able
+   --  to proceed securely assuming that an expression is in fact present.
+
+   exception
+      when Bad_Attribute =>
+         Set_Etype (N, Any_Type);
+         return;
+
+   end Analyze_Attribute;
+
+   --------------------
+   -- Eval_Attribute --
+   --------------------
+
+   procedure Eval_Attribute (N : Node_Id) is
+      Loc   : constant Source_Ptr   := Sloc (N);
+      Aname : constant Name_Id      := Attribute_Name (N);
+      Id    : constant Attribute_Id := Get_Attribute_Id (Aname);
+      P     : constant Node_Id      := Prefix (N);
+
+      C_Type : constant Entity_Id := Etype (N);
+      --  The type imposed by the context.
+
+      E1 : Node_Id;
+      --  First expression, or Empty if none
+
+      E2 : Node_Id;
+      --  Second expression, or Empty if none
+
+      P_Entity : Entity_Id;
+      --  Entity denoted by prefix
+
+      P_Type : Entity_Id;
+      --  The type of the prefix
+
+      P_Base_Type : Entity_Id;
+      --  The base type of the prefix type
+
+      P_Root_Type : Entity_Id;
+      --  The root type of the prefix type
+
+      Static : Boolean;
+      --  True if prefix type is static
+
+      Lo_Bound, Hi_Bound : Node_Id;
+      --  Expressions for low and high bounds of type or array index referenced
+      --  by First, Last, or Length attribute for array, set by Set_Bounds.
+
+      CE_Node : Node_Id;
+      --  Constraint error node used if we have an attribute reference has
+      --  an argument that raises a constraint error. In this case we replace
+      --  the attribute with a raise constraint_error node. This is important
+      --  processing, since otherwise gigi might see an attribute which it is
+      --  unprepared to deal with.
+
+      function Aft_Value return Nat;
+      --  Computes Aft value for current attribute prefix (used by Aft itself
+      --  and also by Width for computing the Width of a fixed point type).
+
+      procedure Check_Expressions;
+      --  In case where the attribute is not foldable, the expressions, if
+      --  any, of the attribute, are in a non-static context. This procedure
+      --  performs the required additional checks.
+
+      procedure Float_Attribute_Universal_Integer
+        (IEEES_Val : Int;
+         IEEEL_Val : Int;
+         IEEEX_Val : Int;
+         VAXFF_Val : Int;
+         VAXDF_Val : Int;
+         VAXGF_Val : Int);
+      --  This procedure evaluates a float attribute with no arguments that
+      --  returns a universal integer result. The parameters give the values
+      --  for the possible floating-point root types. See ttypef for details.
+      --  The prefix type is a float type (and is thus not a generic type).
+
+      procedure Float_Attribute_Universal_Real
+        (IEEES_Val : String;
+         IEEEL_Val : String;
+         IEEEX_Val : String;
+         VAXFF_Val : String;
+         VAXDF_Val : String;
+         VAXGF_Val : String);
+      --  This procedure evaluates a float attribute with no arguments that
+      --  returns a universal real result. The parameters give the values
+      --  required for the possible floating-point root types in string
+      --  format as real literals with a possible leading minus sign.
+      --  The prefix type is a float type (and is thus not a generic type).
+
+      function Fore_Value return Nat;
+      --  Computes the Fore value for the current attribute prefix, which is
+      --  known to be a static fixed-point type. Used by Fore and Width.
+
+      function Mantissa return Uint;
+      --  Returns the Mantissa value for the prefix type
+
+      procedure Set_Bounds;
+      --  Used for First, Last and Length attributes applied to an array or
+      --  array subtype. Sets the variables Index_Lo and Index_Hi to the low
+      --  and high bound expressions for the index referenced by the attribute
+      --  designator (i.e. the first index if no expression is present, and
+      --  the N'th index if the value N is present as an expression).
+
+      ---------------
+      -- Aft_Value --
+      ---------------
+
+      function Aft_Value return Nat is
+         Result    : Nat;
+         Delta_Val : Ureal;
+
+      begin
+         Result := 1;
+         Delta_Val := Delta_Value (P_Type);
+
+         while Delta_Val < Ureal_Tenth loop
+            Delta_Val := Delta_Val * Ureal_10;
+            Result := Result + 1;
+         end loop;
+
+         return Result;
+      end Aft_Value;
+
+      -----------------------
+      -- Check_Expressions --
+      -----------------------
+
+      procedure Check_Expressions is
+         E : Node_Id := E1;
+
+      begin
+         while Present (E) loop
+            Check_Non_Static_Context (E);
+            Next (E);
+         end loop;
+      end Check_Expressions;
+
+      ---------------------------------------
+      -- Float_Attribute_Universal_Integer --
+      ---------------------------------------
+
+      procedure Float_Attribute_Universal_Integer
+        (IEEES_Val : Int;
+         IEEEL_Val : Int;
+         IEEEX_Val : Int;
+         VAXFF_Val : Int;
+         VAXDF_Val : Int;
+         VAXGF_Val : Int)
+      is
+         Val  : Int;
+         Digs : constant Nat := UI_To_Int (Digits_Value (P_Base_Type));
+
+      begin
+         if not Vax_Float (P_Base_Type) then
+            if Digs = IEEES_Digits then
+               Val := IEEES_Val;
+            elsif Digs = IEEEL_Digits then
+               Val := IEEEL_Val;
+            else pragma Assert (Digs = IEEEX_Digits);
+               Val := IEEEX_Val;
+            end if;
+
+         else
+            if Digs = VAXFF_Digits then
+               Val := VAXFF_Val;
+            elsif Digs = VAXDF_Digits then
+               Val := VAXDF_Val;
+            else pragma Assert (Digs = VAXGF_Digits);
+               Val := VAXGF_Val;
+            end if;
+         end if;
+
+         Fold_Uint (N, UI_From_Int (Val));
+      end Float_Attribute_Universal_Integer;
+
+      ------------------------------------
+      -- Float_Attribute_Universal_Real --
+      ------------------------------------
+
+      procedure Float_Attribute_Universal_Real
+        (IEEES_Val : String;
+         IEEEL_Val : String;
+         IEEEX_Val : String;
+         VAXFF_Val : String;
+         VAXDF_Val : String;
+         VAXGF_Val : String)
+      is
+         Val  : Node_Id;
+         Digs : constant Nat := UI_To_Int (Digits_Value (P_Base_Type));
+
+      begin
+         if not Vax_Float (P_Base_Type) then
+            if Digs = IEEES_Digits then
+               Val := Real_Convert (IEEES_Val);
+            elsif Digs = IEEEL_Digits then
+               Val := Real_Convert (IEEEL_Val);
+            else pragma Assert (Digs = IEEEX_Digits);
+               Val := Real_Convert (IEEEX_Val);
+            end if;
+
+         else
+            if Digs = VAXFF_Digits then
+               Val := Real_Convert (VAXFF_Val);
+            elsif Digs = VAXDF_Digits then
+               Val := Real_Convert (VAXDF_Val);
+            else pragma Assert (Digs = VAXGF_Digits);
+               Val := Real_Convert (VAXGF_Val);
+            end if;
+         end if;
+
+         Set_Sloc (Val, Loc);
+         Rewrite (N, Val);
+         Analyze_And_Resolve (N, C_Type);
+      end Float_Attribute_Universal_Real;
+
+      ----------------
+      -- Fore_Value --
+      ----------------
+
+      --  Note that the Fore calculation is based on the actual values
+      --  of the bounds, and does not take into account possible rounding.
+
+      function Fore_Value return Nat is
+         Lo      : constant Uint  := Expr_Value (Type_Low_Bound (P_Type));
+         Hi      : constant Uint  := Expr_Value (Type_High_Bound (P_Type));
+         Small   : constant Ureal := Small_Value (P_Type);
+         Lo_Real : constant Ureal := Lo * Small;
+         Hi_Real : constant Ureal := Hi * Small;
+         T       : Ureal;
+         R       : Nat;
+
+      begin
+         --  Bounds are given in terms of small units, so first compute
+         --  proper values as reals.
+
+         T := UR_Max (abs Lo_Real, abs Hi_Real);
+         R := 2;
+
+         --  Loop to compute proper value if more than one digit required
+
+         while T >= Ureal_10 loop
+            R := R + 1;
+            T := T / Ureal_10;
+         end loop;
+
+         return R;
+      end Fore_Value;
+
+      --------------
+      -- Mantissa --
+      --------------
+
+      --  Table of mantissa values accessed by function  Computed using
+      --  the relation:
+
+      --    T'Mantissa = integer next above (D * log(10)/log(2)) + 1)
+
+      --  where D is T'Digits (RM83 3.5.7)
+
+      Mantissa_Value : constant array (Nat range 1 .. 40) of Nat := (
+          1 =>   5,
+          2 =>   8,
+          3 =>  11,
+          4 =>  15,
+          5 =>  18,
+          6 =>  21,
+          7 =>  25,
+          8 =>  28,
+          9 =>  31,
+         10 =>  35,
+         11 =>  38,
+         12 =>  41,
+         13 =>  45,
+         14 =>  48,
+         15 =>  51,
+         16 =>  55,
+         17 =>  58,
+         18 =>  61,
+         19 =>  65,
+         20 =>  68,
+         21 =>  71,
+         22 =>  75,
+         23 =>  78,
+         24 =>  81,
+         25 =>  85,
+         26 =>  88,
+         27 =>  91,
+         28 =>  95,
+         29 =>  98,
+         30 => 101,
+         31 => 104,
+         32 => 108,
+         33 => 111,
+         34 => 114,
+         35 => 118,
+         36 => 121,
+         37 => 124,
+         38 => 128,
+         39 => 131,
+         40 => 134);
+
+      function Mantissa return Uint is
+      begin
+         return
+           UI_From_Int (Mantissa_Value (UI_To_Int (Digits_Value (P_Type))));
+      end Mantissa;
+
+      ----------------
+      -- Set_Bounds --
+      ----------------
+
+      procedure Set_Bounds is
+         Ndim : Nat;
+         Indx : Node_Id;
+         Ityp : Entity_Id;
+
+      begin
+         --  For a string literal subtype, we have to construct the bounds.
+         --  Valid Ada code never applies attributes to string literals, but
+         --  it is convenient to allow the expander to generate attribute
+         --  references of this type (e.g. First and Last applied to a string
+         --  literal).
+
+         --  Note that the whole point of the E_String_Literal_Subtype is to
+         --  avoid this construction of bounds, but the cases in which we
+         --  have to materialize them are rare enough that we don't worry!
+
+         --  The low bound is simply the low bound of the base type. The
+         --  high bound is computed from the length of the string and this
+         --  low bound.
+
+         if Ekind (P_Type) = E_String_Literal_Subtype then
+            Lo_Bound :=
+              Type_Low_Bound (Etype (First_Index (Base_Type (P_Type))));
+
+            Hi_Bound :=
+              Make_Integer_Literal (Sloc (P),
+                Intval =>
+                  Expr_Value (Lo_Bound) + String_Literal_Length (P_Type) - 1);
+
+            Set_Parent (Hi_Bound, P);
+            Analyze_And_Resolve (Hi_Bound, Etype (Lo_Bound));
+            return;
+
+         --  For non-array case, just get bounds of scalar type
+
+         elsif Is_Scalar_Type (P_Type) then
+            Ityp := P_Type;
+
+         --  For array case, get type of proper index
+
+         else
+            if No (E1) then
+               Ndim := 1;
+            else
+               Ndim := UI_To_Int (Expr_Value (E1));
+            end if;
+
+            Indx := First_Index (P_Type);
+            for J in 1 .. Ndim - 1 loop
+               Next_Index (Indx);
+            end loop;
+
+            --  If no index type, get out (some other error occurred, and
+            --  we don't have enough information to complete the job!)
+
+            if No (Indx) then
+               Lo_Bound := Error;
+               Hi_Bound := Error;
+               return;
+            end if;
+
+            Ityp := Etype (Indx);
+         end if;
+
+         --  A discrete range in an index constraint is allowed to be a
+         --  subtype indication. This is syntactically a pain, but should
+         --  not propagate to the entity for the corresponding index subtype.
+         --  After checking that the subtype indication is legal, the range
+         --  of the subtype indication should be transfered to the entity.
+         --  The attributes for the bounds should remain the simple retrievals
+         --  that they are now.
+
+         Lo_Bound := Type_Low_Bound (Ityp);
+         Hi_Bound := Type_High_Bound (Ityp);
+
+      end Set_Bounds;
+
+   --  Start of processing for Eval_Attribute
+
+   begin
+      --  Acquire first two expressions (at the moment, no attributes
+      --  take more than two expressions in any case).
+
+      if Present (Expressions (N)) then
+         E1 := First (Expressions (N));
+         E2 := Next (E1);
+      else
+         E1 := Empty;
+         E2 := Empty;
+      end if;
+
+      --  Special processing for cases where the prefix is an object
+
+      if Is_Object_Reference (P) then
+
+         --  For Component_Size, the prefix is an array object, and we apply
+         --  the attribute to the type of the object. This is allowed for
+         --  both unconstrained and constrained arrays, since the bounds
+         --  have no influence on the value of this attribute.
+
+         if Id = Attribute_Component_Size then
+            P_Entity := Etype (P);
+
+         --  For First and Last, the prefix is an array object, and we apply
+         --  the attribute to the type of the array, but we need a constrained
+         --  type for this, so we use the actual subtype if available.
+
+         elsif Id = Attribute_First
+                 or else
+               Id = Attribute_Last
+                 or else
+               Id = Attribute_Length
+         then
+            declare
+               AS : constant Entity_Id := Get_Actual_Subtype_If_Available (P);
+
+            begin
+               if Present (AS) then
+                  P_Entity := AS;
+
+               --  If no actual subtype, cannot fold
+
+               else
+                  Check_Expressions;
+                  return;
+               end if;
+            end;
+
+         --  For Size, give size of object if available, otherwise we
+         --  cannot fold Size.
+
+         elsif Id = Attribute_Size then
+
+            if Is_Entity_Name (P)
+              and then Known_Esize (Entity (P))
+            then
+               Fold_Uint (N, Esize (Entity (P)));
+               Set_Is_Static_Expression (N, False);
+               return;
+
+            else
+               Check_Expressions;
+               return;
+            end if;
+
+         --  For Alignment, give size of object if available, otherwise we
+         --  cannot fold Alignment.
+
+         elsif Id = Attribute_Alignment then
+
+            if Is_Entity_Name (P)
+              and then Known_Alignment (Entity (P))
+            then
+               Fold_Uint (N, Alignment (Entity (P)));
+               Set_Is_Static_Expression (N, False);
+               return;
+
+            else
+               Check_Expressions;
+               return;
+            end if;
+
+         --  No other attributes for objects are folded
+
+         else
+            Check_Expressions;
+            return;
+         end if;
+
+      --  Cases where P is not an object. Cannot do anything if P is
+      --  not the name of an entity.
+
+      elsif not Is_Entity_Name (P) then
+         Check_Expressions;
+         return;
+
+      --  Otherwise get prefix entity
+
+      else
+         P_Entity := Entity (P);
+      end if;
+
+      --  At this stage P_Entity is the entity to which the attribute
+      --  is to be applied. This is usually simply the entity of the
+      --  prefix, except in some cases of attributes for objects, where
+      --  as described above, we apply the attribute to the object type.
+
+      --  First foldable possibility is a scalar or array type (RM 4.9(7))
+      --  that is not generic (generic types are eliminated by RM 4.9(25)).
+      --  Note we allow non-static non-generic types at this stage as further
+      --  described below.
+
+      if Is_Type (P_Entity)
+        and then (Is_Scalar_Type (P_Entity) or Is_Array_Type (P_Entity))
+        and then (not Is_Generic_Type (P_Entity))
+      then
+         P_Type := P_Entity;
+
+      --  Second foldable possibility is an array object (RM 4.9(8))
+
+      elsif (Ekind (P_Entity) = E_Variable
+               or else
+             Ekind (P_Entity) = E_Constant)
+        and then Is_Array_Type (Etype (P_Entity))
+        and then (not Is_Generic_Type (Etype (P_Entity)))
+      then
+         P_Type := Etype (P_Entity);
+
+         --  If the entity is an array constant with an unconstrained
+         --  nominal subtype then get the type from the initial value.
+         --  If the value has been expanded into assignments, the expression
+         --  is not present and the attribute reference remains dynamic.
+         --  We could do better here and retrieve the type ???
+
+         if Ekind (P_Entity) = E_Constant
+           and then not Is_Constrained (P_Type)
+         then
+            if No (Constant_Value (P_Entity)) then
+               return;
+            else
+               P_Type := Etype (Constant_Value (P_Entity));
+            end if;
+         end if;
+
+      --  Definite must be folded if the prefix is not a generic type,
+      --  that is to say if we are within an instantiation. Same processing
+      --  applies to the GNAT attributes Has_Discriminants and Type_Class
+
+      elsif (Id = Attribute_Definite
+               or else
+             Id = Attribute_Has_Discriminants
+               or else
+             Id = Attribute_Type_Class)
+        and then not Is_Generic_Type (P_Entity)
+      then
+         P_Type := P_Entity;
+
+      --  We can fold 'Size applied to a type if the size is known
+      --  (as happens for a size from an attribute definition clause).
+      --  At this stage, this can happen only for types (e.g. record
+      --  types) for which the size is always non-static. We exclude
+      --  generic types from consideration (since they have bogus
+      --  sizes set within templates).
+
+      elsif Id = Attribute_Size
+        and then Is_Type (P_Entity)
+        and then (not Is_Generic_Type (P_Entity))
+        and then Known_Static_RM_Size (P_Entity)
+      then
+         Fold_Uint (N, RM_Size (P_Entity));
+         Set_Is_Static_Expression (N, False);
+         return;
+
+      --  No other cases are foldable (they certainly aren't static, and at
+      --  the moment we don't try to fold any cases other than the two above)
+
+      else
+         Check_Expressions;
+         return;
+      end if;
+
+      --  If either attribute or the prefix is Any_Type, then propagate
+      --  Any_Type to the result and don't do anything else at all.
+
+      if P_Type = Any_Type
+        or else (Present (E1) and then Etype (E1) = Any_Type)
+        or else (Present (E2) and then Etype (E2) = Any_Type)
+      then
+         Set_Etype (N, Any_Type);
+         return;
+      end if;
+
+      --  Scalar subtype case. We have not yet enforced the static requirement
+      --  of (RM 4.9(7)) and we don't intend to just yet, since there are cases
+      --  of non-static attribute references (e.g. S'Digits for a non-static
+      --  floating-point type, which we can compute at compile time).
+
+      --  Note: this folding of non-static attributes is not simply a case of
+      --  optimization. For many of the attributes affected, Gigi cannot handle
+      --  the attribute and depends on the front end having folded them away.
+
+      --  Note: although we don't require staticness at this stage, we do set
+      --  the Static variable to record the staticness, for easy reference by
+      --  those attributes where it matters (e.g. Succ and Pred), and also to
+      --  be used to ensure that non-static folded things are not marked as
+      --  being static (a check that is done right at the end).
+
+      P_Root_Type := Root_Type (P_Type);
+      P_Base_Type := Base_Type (P_Type);
+
+      --  If the root type or base type is generic, then we cannot fold. This
+      --  test is needed because subtypes of generic types are not always
+      --  marked as being generic themselves (which seems odd???)
+
+      if Is_Generic_Type (P_Root_Type)
+        or else Is_Generic_Type (P_Base_Type)
+      then
+         return;
+      end if;
+
+      if Is_Scalar_Type (P_Type) then
+         Static := Is_OK_Static_Subtype (P_Type);
+
+      --  Array case. We enforce the constrained requirement of (RM 4.9(7-8))
+      --  since we can't do anything with unconstrained arrays. In addition,
+      --  only the First, Last and Length attributes are possibly static.
+      --  In addition Component_Size is possibly foldable, even though it
+      --  can never be static.
+
+      --  Definite, Has_Discriminants and Type_Class are again exceptions,
+      --  because they apply as well to unconstrained types.
+
+      elsif Id = Attribute_Definite
+              or else
+            Id = Attribute_Has_Discriminants
+              or else
+            Id = Attribute_Type_Class
+      then
+         Static := False;
+
+      else
+         if not Is_Constrained (P_Type)
+           or else (Id /= Attribute_Component_Size and then
+                    Id /= Attribute_First          and then
+                    Id /= Attribute_Last           and then
+                    Id /= Attribute_Length)
+         then
+            Check_Expressions;
+            return;
+         end if;
+
+         --  The rules in (RM 4.9(7,8)) require a static array, but as in the
+         --  scalar case, we hold off on enforcing staticness, since there are
+         --  cases which we can fold at compile time even though they are not
+         --  static (e.g. 'Length applied to a static index, even though other
+         --  non-static indexes make the array type non-static). This is only
+         --  ab optimization, but it falls out essentially free, so why not.
+         --  Again we compute the variable Static for easy reference later
+         --  (note that no array attributes are static in Ada 83).
+
+         Static := Ada_95;
+
+         declare
+            N : Node_Id;
+
+         begin
+            N := First_Index (P_Type);
+            while Present (N) loop
+               Static := Static and Is_Static_Subtype (Etype (N));
+               Next_Index (N);
+            end loop;
+         end;
+      end if;
+
+      --  Check any expressions that are present. Note that these expressions,
+      --  depending on the particular attribute type, are either part of the
+      --  attribute designator, or they are arguments in a case where the
+      --  attribute reference returns a function. In the latter case, the
+      --  rule in (RM 4.9(22)) applies and in particular requires the type
+      --  of the expressions to be scalar in order for the attribute to be
+      --  considered to be static.
+
+      declare
+         E : Node_Id;
+
+      begin
+         E := E1;
+         while Present (E) loop
+
+            --  If expression is not static, then the attribute reference
+            --  certainly is neither foldable nor static, so we can quit
+            --  after calling Apply_Range_Check for 'Pos attributes.
+
+            --  We can also quit if the expression is not of a scalar type
+            --  as noted above.
+
+            if not Is_Static_Expression (E)
+              or else not Is_Scalar_Type (Etype (E))
+            then
+               if Id = Attribute_Pos then
+                  if Is_Integer_Type (Etype (E)) then
+                     Apply_Range_Check (E, Etype (N));
+                  end if;
+               end if;
+
+               Check_Expressions;
+               return;
+
+            --  If the expression raises a constraint error, then so does
+            --  the attribute reference. We keep going in this case because
+            --  we are still interested in whether the attribute reference
+            --  is static even if it is not static.
+
+            elsif Raises_Constraint_Error (E) then
+               Set_Raises_Constraint_Error (N);
+            end if;
+
+            Next (E);
+         end loop;
+
+         if Raises_Constraint_Error (Prefix (N)) then
+            return;
+         end if;
+      end;
+
+      --  Deal with the case of a static attribute reference that raises
+      --  constraint error. The Raises_Constraint_Error flag will already
+      --  have been set, and the Static flag shows whether the attribute
+      --  reference is static. In any case we certainly can't fold such an
+      --  attribute reference.
+
+      --  Note that the rewriting of the attribute node with the constraint
+      --  error node is essential in this case, because otherwise Gigi might
+      --  blow up on one of the attributes it never expects to see.
+
+      --  The constraint_error node must have the type imposed by the context,
+      --  to avoid spurious errors in the enclosing expression.
+
+      if Raises_Constraint_Error (N) then
+         CE_Node :=
+           Make_Raise_Constraint_Error (Sloc (N));
+         Set_Etype (CE_Node, Etype (N));
+         Set_Raises_Constraint_Error (CE_Node);
+         Check_Expressions;
+         Rewrite (N, Relocate_Node (CE_Node));
+         Set_Is_Static_Expression (N, Static);
+         return;
+      end if;
+
+      --  At this point we have a potentially foldable attribute reference.
+      --  If Static is set, then the attribute reference definitely obeys
+      --  the requirements in (RM 4.9(7,8,22)), and it definitely can be
+      --  folded. If Static is not set, then the attribute may or may not
+      --  be foldable, and the individual attribute processing routines
+      --  test Static as required in cases where it makes a difference.
+
+      case Id is
+
+      --------------
+      -- Adjacent --
+      --------------
+
+      when Attribute_Adjacent =>
+         if Static then
+            Fold_Ureal (N,
+              Eval_Fat.Adjacent
+                (P_Root_Type, Expr_Value_R (E1), Expr_Value_R (E2)));
+         end if;
+
+      ---------
+      -- Aft --
+      ---------
+
+      when Attribute_Aft =>
+         Fold_Uint (N, UI_From_Int (Aft_Value));
+
+      ---------------
+      -- Alignment --
+      ---------------
+
+      when Attribute_Alignment => Alignment_Block : declare
+         P_TypeA : constant Entity_Id := Underlying_Type (P_Type);
+
+      begin
+         --  Fold if alignment is set and not otherwise
+
+         if Known_Alignment (P_TypeA) then
+            Fold_Uint (N, Alignment (P_TypeA));
+         end if;
+      end Alignment_Block;
+
+      ---------------
+      -- AST_Entry --
+      ---------------
+
+      --  Can only be folded in No_Ast_Handler case
+
+      when Attribute_AST_Entry =>
+         if not Is_AST_Entry (P_Entity) then
+            Rewrite (N,
+              New_Occurrence_Of (RTE (RE_No_AST_Handler), Loc));
+         else
+            null;
+         end if;
+
+      ---------
+      -- Bit --
+      ---------
+
+      --  Bit can never be folded
+
+      when Attribute_Bit =>
+         null;
+
+      ------------------
+      -- Body_Version --
+      ------------------
+
+      --  Body_version can never be static
+
+      when Attribute_Body_Version =>
+         null;
+
+      -------------
+      -- Ceiling --
+      -------------
+
+      when Attribute_Ceiling =>
+         if Static then
+            Fold_Ureal (N,
+              Eval_Fat.Ceiling (P_Root_Type, Expr_Value_R (E1)));
+         end if;
+
+      --------------------
+      -- Component_Size --
+      --------------------
+
+      when Attribute_Component_Size =>
+         if Component_Size (P_Type) /= 0 then
+            Fold_Uint (N, Component_Size (P_Type));
+         end if;
+
+      -------------
+      -- Compose --
+      -------------
+
+      when Attribute_Compose =>
+         if Static then
+            Fold_Ureal (N,
+              Eval_Fat.Compose
+                (P_Root_Type, Expr_Value_R (E1), Expr_Value (E2)));
+         end if;
+
+      -----------------
+      -- Constrained --
+      -----------------
+
+      --  Constrained is never folded for now, there may be cases that
+      --  could be handled at compile time. to be looked at later.
+
+      when Attribute_Constrained =>
+         null;
+
+      ---------------
+      -- Copy_Sign --
+      ---------------
+
+      when Attribute_Copy_Sign =>
+         if Static then
+            Fold_Ureal (N,
+              Eval_Fat.Copy_Sign
+                (P_Root_Type, Expr_Value_R (E1), Expr_Value_R (E2)));
+         end if;
+
+      -----------
+      -- Delta --
+      -----------
+
+      when Attribute_Delta =>
+         Fold_Ureal (N, Delta_Value (P_Type));
+
+      --------------
+      -- Definite --
+      --------------
+
+      when Attribute_Definite =>
+         declare
+            Result : Node_Id;
+
+         begin
+            if Is_Indefinite_Subtype (P_Entity) then
+               Result := New_Occurrence_Of (Standard_False, Loc);
+            else
+               Result := New_Occurrence_Of (Standard_True, Loc);
+            end if;
+
+            Rewrite (N, Result);
+            Analyze_And_Resolve (N, Standard_Boolean);
+         end;
+
+      ------------
+      -- Denorm --
+      ------------
+
+      when Attribute_Denorm =>
+         Fold_Uint
+           (N, UI_From_Int (Boolean'Pos (Denorm_On_Target)));
+
+      ------------
+      -- Digits --
+      ------------
+
+      when Attribute_Digits =>
+         Fold_Uint (N, Digits_Value (P_Type));
+
+      ----------
+      -- Emax --
+      ----------
+
+      when Attribute_Emax =>
+
+         --  Ada 83 attribute is defined as (RM83 3.5.8)
+
+         --    T'Emax = 4 * T'Mantissa
+
+         Fold_Uint (N, 4 * Mantissa);
+
+      --------------
+      -- Enum_Rep --
+      --------------
+
+      when Attribute_Enum_Rep =>
+         if Static then
+
+            --  For an enumeration type with a non-standard representation
+            --  use the Enumeration_Rep field of the proper constant. Note
+            --  that this would not work for types Character/Wide_Character,
+            --  since no real entities are created for the enumeration
+            --  literals, but that does not matter since these two types
+            --  do not have non-standard representations anyway.
+
+            if Is_Enumeration_Type (P_Type)
+              and then Has_Non_Standard_Rep (P_Type)
+            then
+               Fold_Uint (N, Enumeration_Rep (Expr_Value_E (E1)));
+
+            --  For enumeration types with standard representations and all
+            --  other cases (i.e. all integer and modular types), Enum_Rep
+            --  is equivalent to Pos.
+
+            else
+               Fold_Uint (N, Expr_Value (E1));
+            end if;
+         end if;
+
+      -------------
+      -- Epsilon --
+      -------------
+
+      when Attribute_Epsilon =>
+
+         --  Ada 83 attribute is defined as (RM83 3.5.8)
+
+         --    T'Epsilon = 2.0**(1 - T'Mantissa)
+
+         Fold_Ureal (N, Ureal_2 ** (1 - Mantissa));
+
+      --------------
+      -- Exponent --
+      --------------
+
+      when Attribute_Exponent =>
+         if Static then
+            Fold_Uint (N,
+              Eval_Fat.Exponent (P_Root_Type, Expr_Value_R (E1)));
+         end if;
+
+      -----------
+      -- First --
+      -----------
+
+      when Attribute_First => First_Attr :
+      begin
+         Set_Bounds;
+
+         if Compile_Time_Known_Value (Lo_Bound) then
+            if Is_Real_Type (P_Type) then
+               Fold_Ureal (N, Expr_Value_R (Lo_Bound));
+            else
+               Fold_Uint  (N, Expr_Value (Lo_Bound));
+            end if;
+         end if;
+      end First_Attr;
+
+      -----------------
+      -- Fixed_Value --
+      -----------------
+
+      when Attribute_Fixed_Value =>
+         null;
+
+      -----------
+      -- Floor --
+      -----------
+
+      when Attribute_Floor =>
+         if Static then
+            Fold_Ureal (N,
+              Eval_Fat.Floor (P_Root_Type, Expr_Value_R (E1)));
+         end if;
+
+      ----------
+      -- Fore --
+      ----------
+
+      when Attribute_Fore =>
+         if Static then
+            Fold_Uint (N, UI_From_Int (Fore_Value));
+         end if;
+
+      --------------
+      -- Fraction --
+      --------------
+
+      when Attribute_Fraction =>
+         if Static then
+            Fold_Ureal (N,
+              Eval_Fat.Fraction (P_Root_Type, Expr_Value_R (E1)));
+         end if;
+
+      -----------------------
+      -- Has_Discriminants --
+      -----------------------
+
+      when Attribute_Has_Discriminants =>
+         declare
+            Result : Node_Id;
+
+         begin
+            if Has_Discriminants (P_Entity) then
+               Result := New_Occurrence_Of (Standard_True, Loc);
+            else
+               Result := New_Occurrence_Of (Standard_False, Loc);
+            end if;
+
+            Rewrite (N, Result);
+            Analyze_And_Resolve (N, Standard_Boolean);
+         end;
+
+      --------------
+      -- Identity --
+      --------------
+
+      when Attribute_Identity =>
+         null;
+
+      -----------
+      -- Image --
+      -----------
+
+      --  Image is a scalar attribute, but is never static, because it is
+      --  not a static function (having a non-scalar argument (RM 4.9(22))
+
+      when Attribute_Image =>
+         null;
+
+      ---------
+      -- Img --
+      ---------
+
+      --  Img is a scalar attribute, but is never static, because it is
+      --  not a static function (having a non-scalar argument (RM 4.9(22))
+
+      when Attribute_Img =>
+         null;
+
+      -------------------
+      -- Integer_Value --
+      -------------------
+
+      when Attribute_Integer_Value =>
+         null;
+
+      -----------
+      -- Large --
+      -----------
+
+      when Attribute_Large =>
+
+         --  For fixed-point, we use the identity:
+
+         --    T'Large = (2.0**T'Mantissa - 1.0) * T'Small
+
+         if Is_Fixed_Point_Type (P_Type) then
+            Rewrite (N,
+              Make_Op_Multiply (Loc,
+                Left_Opnd =>
+                  Make_Op_Subtract (Loc,
+                    Left_Opnd =>
+                      Make_Op_Expon (Loc,
+                        Left_Opnd =>
+                          Make_Real_Literal (Loc, Ureal_2),
+                        Right_Opnd =>
+                          Make_Attribute_Reference (Loc,
+                            Prefix => P,
+                            Attribute_Name => Name_Mantissa)),
+                    Right_Opnd => Make_Real_Literal (Loc, Ureal_1)),
+
+                Right_Opnd =>
+                  Make_Real_Literal (Loc, Small_Value (Entity (P)))));
+
+            Analyze_And_Resolve (N, C_Type);
+
+         --  Floating-point (Ada 83 compatibility)
+
+         else
+            --  Ada 83 attribute is defined as (RM83 3.5.8)
+
+            --    T'Large = 2.0**T'Emax * (1.0 - 2.0**(-T'Mantissa))
+
+            --  where
+
+            --    T'Emax = 4 * T'Mantissa
+
+            Fold_Ureal (N,
+              Ureal_2 ** (4 * Mantissa) *
+              (Ureal_1 - Ureal_2 ** (-Mantissa)));
+         end if;
+
+      ----------
+      -- Last --
+      ----------
+
+      when Attribute_Last => Last :
+      begin
+         Set_Bounds;
+
+         if Compile_Time_Known_Value (Hi_Bound) then
+            if Is_Real_Type (P_Type) then
+               Fold_Ureal (N, Expr_Value_R (Hi_Bound));
+            else
+               Fold_Uint  (N, Expr_Value (Hi_Bound));
+            end if;
+         end if;
+      end Last;
+
+      ------------------
+      -- Leading_Part --
+      ------------------
+
+      when Attribute_Leading_Part =>
+         if Static then
+            Fold_Ureal (N,
+              Eval_Fat.Leading_Part
+                (P_Root_Type, Expr_Value_R (E1), Expr_Value (E2)));
+         end if;
+
+      ------------
+      -- Length --
+      ------------
+
+      when Attribute_Length => Length :
+      begin
+         Set_Bounds;
+
+         if Compile_Time_Known_Value (Lo_Bound)
+           and then Compile_Time_Known_Value (Hi_Bound)
+         then
+            Fold_Uint (N,
+              UI_Max (0, 1 + (Expr_Value (Hi_Bound) - Expr_Value (Lo_Bound))));
+         end if;
+      end Length;
+
+      -------------
+      -- Machine --
+      -------------
+
+      when Attribute_Machine =>
+         if Static then
+            Fold_Ureal (N,
+              Eval_Fat.Machine (P_Root_Type, Expr_Value_R (E1),
+                Eval_Fat.Round));
+         end if;
+
+      ------------------
+      -- Machine_Emax --
+      ------------------
+
+      when Attribute_Machine_Emax =>
+         Float_Attribute_Universal_Integer (
+           IEEES_Machine_Emax,
+           IEEEL_Machine_Emax,
+           IEEEX_Machine_Emax,
+           VAXFF_Machine_Emax,
+           VAXDF_Machine_Emax,
+           VAXGF_Machine_Emax);
+
+      ------------------
+      -- Machine_Emin --
+      ------------------
+
+      when Attribute_Machine_Emin =>
+         Float_Attribute_Universal_Integer (
+           IEEES_Machine_Emin,
+           IEEEL_Machine_Emin,
+           IEEEX_Machine_Emin,
+           VAXFF_Machine_Emin,
+           VAXDF_Machine_Emin,
+           VAXGF_Machine_Emin);
+
+      ----------------------
+      -- Machine_Mantissa --
+      ----------------------
+
+      when Attribute_Machine_Mantissa =>
+         Float_Attribute_Universal_Integer (
+           IEEES_Machine_Mantissa,
+           IEEEL_Machine_Mantissa,
+           IEEEX_Machine_Mantissa,
+           VAXFF_Machine_Mantissa,
+           VAXDF_Machine_Mantissa,
+           VAXGF_Machine_Mantissa);
+
+      -----------------------
+      -- Machine_Overflows --
+      -----------------------
+
+      when Attribute_Machine_Overflows =>
+
+         --  Always true for fixed-point
+
+         if Is_Fixed_Point_Type (P_Type) then
+            Fold_Uint (N, True_Value);
+
+         --  Floating point case
+
+         else
+            Fold_Uint
+              (N, UI_From_Int (Boolean'Pos (Machine_Overflows_On_Target)));
+         end if;
+
+      -------------------
+      -- Machine_Radix --
+      -------------------
+
+      when Attribute_Machine_Radix =>
+         if Is_Fixed_Point_Type (P_Type) then
+            if Is_Decimal_Fixed_Point_Type (P_Type)
+              and then Machine_Radix_10 (P_Type)
+            then
+               Fold_Uint (N, Uint_10);
+            else
+               Fold_Uint (N, Uint_2);
+            end if;
+
+         --  All floating-point type always have radix 2
+
+         else
+            Fold_Uint (N, Uint_2);
+         end if;
+
+      --------------------
+      -- Machine_Rounds --
+      --------------------
+
+      when Attribute_Machine_Rounds =>
+
+         --  Always False for fixed-point
+
+         if Is_Fixed_Point_Type (P_Type) then
+            Fold_Uint (N, False_Value);
+
+         --  Else yield proper floating-point result
+
+         else
+            Fold_Uint
+              (N, UI_From_Int (Boolean'Pos (Machine_Rounds_On_Target)));
+         end if;
+
+      ------------------
+      -- Machine_Size --
+      ------------------
+
+      --  Note: Machine_Size is identical to Object_Size
+
+      when Attribute_Machine_Size => Machine_Size : declare
+         P_TypeA : constant Entity_Id := Underlying_Type (P_Type);
+
+      begin
+         if Known_Esize (P_TypeA) then
+            Fold_Uint (N, Esize (P_TypeA));
+         end if;
+      end Machine_Size;
+
+      --------------
+      -- Mantissa --
+      --------------
+
+      when Attribute_Mantissa =>
+
+         --  Fixed-point mantissa
+
+         if Is_Fixed_Point_Type (P_Type) then
+
+            --  Compile time foldable case
+
+            if Compile_Time_Known_Value (Type_Low_Bound  (P_Type))
+                 and then
+               Compile_Time_Known_Value (Type_High_Bound (P_Type))
+            then
+               --  The calculation of the obsolete Ada 83 attribute Mantissa
+               --  is annoying, because of AI00143, quoted here:
+
+               --  !question 84-01-10
+
+               --  Consider the model numbers for F:
+
+               --         type F is delta 1.0 range -7.0 .. 8.0;
+
+               --  The wording requires that F'MANTISSA be the SMALLEST
+               --  integer number for which each  bound  of the specified
+               --  range is either a model number or lies at most small
+               --  distant from a model number. This means F'MANTISSA
+               --  is required to be 3 since the range  -7.0 .. 7.0 fits
+               --  in 3 signed bits, and 8 is "at most" 1.0 from a model
+               --  number, namely, 7. Is this analysis correct? Note that
+               --  this implies the upper bound of the range is not
+               --  represented as a model number.
+
+               --  !response 84-03-17
+
+               --  The analysis is correct. The upper and lower bounds for
+               --  a fixed  point type can lie outside the range of model
+               --  numbers.
+
+               declare
+                  Siz     : Uint;
+                  LBound  : Ureal;
+                  UBound  : Ureal;
+                  Bound   : Ureal;
+                  Max_Man : Uint;
+
+               begin
+                  LBound  := Expr_Value_R (Type_Low_Bound  (P_Type));
+                  UBound  := Expr_Value_R (Type_High_Bound (P_Type));
+                  Bound   := UR_Max (UR_Abs (LBound), UR_Abs (UBound));
+                  Max_Man := UR_Trunc (Bound / Small_Value (P_Type));
+
+                  --  If the Bound is exactly a model number, i.e. a multiple
+                  --  of Small, then we back it off by one to get the integer
+                  --  value that must be representable.
+
+                  if Small_Value (P_Type) * Max_Man = Bound then
+                     Max_Man := Max_Man - 1;
+                  end if;
+
+                  --  Now find corresponding size = Mantissa value
+
+                  Siz := Uint_0;
+                  while 2 ** Siz < Max_Man loop
+                     Siz := Siz + 1;
+                  end loop;
+
+                  Fold_Uint (N, Siz);
+               end;
+
+            else
+               --  The case of dynamic bounds cannot be evaluated at compile
+               --  time. Instead we use a runtime routine (see Exp_Attr).
+
+               null;
+            end if;
+
+         --  Floating-point Mantissa
+
+         else
+            Fold_Uint (N, Mantissa);
+         end if;
+
+      ---------
+      -- Max --
+      ---------
+
+      when Attribute_Max => Max :
+      begin
+         if Is_Real_Type (P_Type) then
+            Fold_Ureal (N, UR_Max (Expr_Value_R (E1), Expr_Value_R (E2)));
+         else
+            Fold_Uint (N, UI_Max (Expr_Value (E1), Expr_Value (E2)));
+         end if;
+      end Max;
+
+      ----------------------------------
+      -- Max_Size_In_Storage_Elements --
+      ----------------------------------
+
+      --  Max_Size_In_Storage_Elements is simply the Size rounded up to a
+      --  Storage_Unit boundary. We can fold any cases for which the size
+      --  is known by the front end.
+
+      when Attribute_Max_Size_In_Storage_Elements =>
+         if Known_Esize (P_Type) then
+            Fold_Uint (N,
+              (Esize (P_Type) + System_Storage_Unit - 1) /
+                                          System_Storage_Unit);
+         end if;
+
+      --------------------
+      -- Mechanism_Code --
+      --------------------
+
+      when Attribute_Mechanism_Code =>
+         declare
+            Val    : Int;
+            Formal : Entity_Id;
+            Mech   : Mechanism_Type;
+
+         begin
+            if No (E1) then
+               Mech := Mechanism (P_Entity);
+
+            else
+               Val := UI_To_Int (Expr_Value (E1));
+
+               Formal := First_Formal (P_Entity);
+               for J in 1 .. Val - 1 loop
+                  Next_Formal (Formal);
+               end loop;
+               Mech := Mechanism (Formal);
+            end if;
+
+            if Mech < 0 then
+               Fold_Uint (N, UI_From_Int (Int (-Mech)));
+            end if;
+         end;
+
+      ---------
+      -- Min --
+      ---------
+
+      when Attribute_Min => Min :
+      begin
+         if Is_Real_Type (P_Type) then
+            Fold_Ureal (N, UR_Min (Expr_Value_R (E1), Expr_Value_R (E2)));
+         else
+            Fold_Uint (N, UI_Min (Expr_Value (E1), Expr_Value (E2)));
+         end if;
+      end Min;
+
+      -----------
+      -- Model --
+      -----------
+
+      when Attribute_Model =>
+         if Static then
+            Fold_Ureal (N,
+              Eval_Fat.Model (P_Root_Type, Expr_Value_R (E1)));
+         end if;
+
+      ----------------
+      -- Model_Emin --
+      ----------------
+
+      when Attribute_Model_Emin =>
+         Float_Attribute_Universal_Integer (
+           IEEES_Model_Emin,
+           IEEEL_Model_Emin,
+           IEEEX_Model_Emin,
+           VAXFF_Model_Emin,
+           VAXDF_Model_Emin,
+           VAXGF_Model_Emin);
+
+      -------------------
+      -- Model_Epsilon --
+      -------------------
+
+      when Attribute_Model_Epsilon =>
+         Float_Attribute_Universal_Real (
+           IEEES_Model_Epsilon'Universal_Literal_String,
+           IEEEL_Model_Epsilon'Universal_Literal_String,
+           IEEEX_Model_Epsilon'Universal_Literal_String,
+           VAXFF_Model_Epsilon'Universal_Literal_String,
+           VAXDF_Model_Epsilon'Universal_Literal_String,
+           VAXGF_Model_Epsilon'Universal_Literal_String);
+
+      --------------------
+      -- Model_Mantissa --
+      --------------------
+
+      when Attribute_Model_Mantissa =>
+         Float_Attribute_Universal_Integer (
+           IEEES_Model_Mantissa,
+           IEEEL_Model_Mantissa,
+           IEEEX_Model_Mantissa,
+           VAXFF_Model_Mantissa,
+           VAXDF_Model_Mantissa,
+           VAXGF_Model_Mantissa);
+
+      -----------------
+      -- Model_Small --
+      -----------------
+
+      when Attribute_Model_Small =>
+         Float_Attribute_Universal_Real (
+           IEEES_Model_Small'Universal_Literal_String,
+           IEEEL_Model_Small'Universal_Literal_String,
+           IEEEX_Model_Small'Universal_Literal_String,
+           VAXFF_Model_Small'Universal_Literal_String,
+           VAXDF_Model_Small'Universal_Literal_String,
+           VAXGF_Model_Small'Universal_Literal_String);
+
+      -------------
+      -- Modulus --
+      -------------
+
+      when Attribute_Modulus =>
+         Fold_Uint (N, Modulus (P_Type));
+
+      --------------------
+      -- Null_Parameter --
+      --------------------
+
+      --  Cannot fold, we know the value sort of, but the whole point is
+      --  that there is no way to talk about this imaginary value except
+      --  by using the attribute, so we leave it the way it is.
+
+      when Attribute_Null_Parameter =>
+         null;
+
+      -----------------
+      -- Object_Size --
+      -----------------
+
+      --  The Object_Size attribute for a type returns the Esize of the
+      --  type and can be folded if this value is known.
+
+      when Attribute_Object_Size => Object_Size : declare
+         P_TypeA : constant Entity_Id := Underlying_Type (P_Type);
+
+      begin
+         if Known_Esize (P_TypeA) then
+            Fold_Uint (N, Esize (P_TypeA));
+         end if;
+      end Object_Size;
+
+      -------------------------
+      -- Passed_By_Reference --
+      -------------------------
+
+      --  Scalar types are never passed by reference
+
+      when Attribute_Passed_By_Reference =>
+         Fold_Uint (N, False_Value);
+
+      ---------
+      -- Pos --
+      ---------
+
+      when Attribute_Pos =>
+         Fold_Uint (N, Expr_Value (E1));
+
+      ----------
+      -- Pred --
+      ----------
+
+      when Attribute_Pred => Pred :
+      begin
+         if Static then
+
+            --  Floating-point case. For now, do not fold this, since we
+            --  don't know how to do it right (see fixed bug 3512-001 ???)
+
+            if Is_Floating_Point_Type (P_Type) then
+               Fold_Ureal (N,
+                 Eval_Fat.Pred (P_Root_Type, Expr_Value_R (E1)));
+
+            --  Fixed-point case
+
+            elsif Is_Fixed_Point_Type (P_Type) then
+               Fold_Ureal (N,
+                 Expr_Value_R (E1) - Small_Value (P_Type));
+
+            --  Modular integer case (wraps)
+
+            elsif Is_Modular_Integer_Type (P_Type) then
+               Fold_Uint (N, (Expr_Value (E1) - 1) mod Modulus (P_Type));
+
+            --  Other scalar cases
+
+            else
+               pragma Assert (Is_Scalar_Type (P_Type));
+
+               if Is_Enumeration_Type (P_Type)
+                 and then Expr_Value (E1) =
+                            Expr_Value (Type_Low_Bound (P_Base_Type))
+               then
+                  Apply_Compile_Time_Constraint_Error
+                    (N, "Pred of type''First");
+                  Check_Expressions;
+                  return;
+               end if;
+
+               Fold_Uint (N, Expr_Value (E1) - 1);
+            end if;
+         end if;
+      end Pred;
+
+      -----------
+      -- Range --
+      -----------
+
+      --  No processing required, because by this stage, Range has been
+      --  replaced by First .. Last, so this branch can never be taken.
+
+      when Attribute_Range =>
+         raise Program_Error;
+
+      ------------------
+      -- Range_Length --
+      ------------------
+
+      when Attribute_Range_Length =>
+         Set_Bounds;
+
+         if Compile_Time_Known_Value (Hi_Bound)
+           and then Compile_Time_Known_Value (Lo_Bound)
+         then
+            Fold_Uint (N,
+              UI_Max
+                (0, Expr_Value (Hi_Bound) - Expr_Value (Lo_Bound) + 1));
+         end if;
+
+      ---------------
+      -- Remainder --
+      ---------------
+
+      when Attribute_Remainder =>
+         if Static then
+            Fold_Ureal (N,
+              Eval_Fat.Remainder
+                (P_Root_Type, Expr_Value_R (E1), Expr_Value_R (E2)));
+         end if;
+
+      -----------
+      -- Round --
+      -----------
+
+      when Attribute_Round => Round :
+      declare
+         Sr : Ureal;
+         Si : Uint;
+
+      begin
+         if Static then
+            --  First we get the (exact result) in units of small
+
+            Sr := Expr_Value_R (E1) / Small_Value (C_Type);
+
+            --  Now round that exactly to an integer
+
+            Si := UR_To_Uint (Sr);
+
+            --  Finally the result is obtained by converting back to real
+
+            Fold_Ureal (N, Si * Small_Value (C_Type));
+         end if;
+      end Round;
+
+      --------------
+      -- Rounding --
+      --------------
+
+      when Attribute_Rounding =>
+         if Static then
+            Fold_Ureal (N,
+              Eval_Fat.Rounding (P_Root_Type, Expr_Value_R (E1)));
+         end if;
+
+      ---------------
+      -- Safe_Emax --
+      ---------------
+
+      when Attribute_Safe_Emax =>
+         Float_Attribute_Universal_Integer (
+           IEEES_Safe_Emax,
+           IEEEL_Safe_Emax,
+           IEEEX_Safe_Emax,
+           VAXFF_Safe_Emax,
+           VAXDF_Safe_Emax,
+           VAXGF_Safe_Emax);
+
+      ----------------
+      -- Safe_First --
+      ----------------
+
+      when Attribute_Safe_First =>
+         Float_Attribute_Universal_Real (
+           IEEES_Safe_First'Universal_Literal_String,
+           IEEEL_Safe_First'Universal_Literal_String,
+           IEEEX_Safe_First'Universal_Literal_String,
+           VAXFF_Safe_First'Universal_Literal_String,
+           VAXDF_Safe_First'Universal_Literal_String,
+           VAXGF_Safe_First'Universal_Literal_String);
+
+      ----------------
+      -- Safe_Large --
+      ----------------
+
+      when Attribute_Safe_Large =>
+         if Is_Fixed_Point_Type (P_Type) then
+            Fold_Ureal (N, Expr_Value_R (Type_High_Bound (P_Base_Type)));
+         else
+            Float_Attribute_Universal_Real (
+              IEEES_Safe_Large'Universal_Literal_String,
+              IEEEL_Safe_Large'Universal_Literal_String,
+              IEEEX_Safe_Large'Universal_Literal_String,
+              VAXFF_Safe_Large'Universal_Literal_String,
+              VAXDF_Safe_Large'Universal_Literal_String,
+              VAXGF_Safe_Large'Universal_Literal_String);
+         end if;
+
+      ---------------
+      -- Safe_Last --
+      ---------------
+
+      when Attribute_Safe_Last =>
+         Float_Attribute_Universal_Real (
+           IEEES_Safe_Last'Universal_Literal_String,
+           IEEEL_Safe_Last'Universal_Literal_String,
+           IEEEX_Safe_Last'Universal_Literal_String,
+           VAXFF_Safe_Last'Universal_Literal_String,
+           VAXDF_Safe_Last'Universal_Literal_String,
+           VAXGF_Safe_Last'Universal_Literal_String);
+
+      ----------------
+      -- Safe_Small --
+      ----------------
+
+      when Attribute_Safe_Small =>
+
+         --  In Ada 95, the old Ada 83 attribute Safe_Small is redundant
+         --  for fixed-point, since is the same as Small, but we implement
+         --  it for backwards compatibility.
+
+         if Is_Fixed_Point_Type (P_Type) then
+            Fold_Ureal (N, Small_Value (P_Type));
+
+         --  Ada 83 Safe_Small for floating-point cases
+
+         else
+            Float_Attribute_Universal_Real (
+              IEEES_Safe_Small'Universal_Literal_String,
+              IEEEL_Safe_Small'Universal_Literal_String,
+              IEEEX_Safe_Small'Universal_Literal_String,
+              VAXFF_Safe_Small'Universal_Literal_String,
+              VAXDF_Safe_Small'Universal_Literal_String,
+              VAXGF_Safe_Small'Universal_Literal_String);
+         end if;
+
+      -----------
+      -- Scale --
+      -----------
+
+      when Attribute_Scale =>
+         Fold_Uint (N, Scale_Value (P_Type));
+
+      -------------
+      -- Scaling --
+      -------------
+
+      when Attribute_Scaling =>
+         if Static then
+            Fold_Ureal (N,
+              Eval_Fat.Scaling
+                (P_Root_Type, Expr_Value_R (E1), Expr_Value (E2)));
+         end if;
+
+      ------------------
+      -- Signed_Zeros --
+      ------------------
+
+      when Attribute_Signed_Zeros =>
+         Fold_Uint
+           (N, UI_From_Int (Boolean'Pos (Signed_Zeros_On_Target)));
+
+      ----------
+      -- Size --
+      ----------
+
+      --  Size attribute returns the RM size. All scalar types can be folded,
+      --  as well as any types for which the size is known by the front end,
+      --  including any type for which a size attribute is specified.
+
+      when Attribute_Size | Attribute_VADS_Size => Size : declare
+         P_TypeA : constant Entity_Id := Underlying_Type (P_Type);
+
+      begin
+         if RM_Size (P_TypeA) /= Uint_0 then
+
+            --  VADS_Size case
+
+            if (Id = Attribute_VADS_Size or else Use_VADS_Size) then
+
+               declare
+                  S : constant Node_Id := Size_Clause (P_TypeA);
+
+               begin
+                  --  If a size clause applies, then use the size from it.
+                  --  This is one of the rare cases where we can use the
+                  --  Size_Clause field for a subtype when Has_Size_Clause
+                  --  is False. Consider:
+
+                  --    type x is range 1 .. 64;
+                  --    for x'size use 12;
+                  --    subtype y is x range 0 .. 3;
+
+                  --  Here y has a size clause inherited from x, but normally
+                  --  it does not apply, and y'size is 2. However, y'VADS_Size
+                  --  is indeed 12 and not 2.
+
+                  if Present (S)
+                    and then Is_OK_Static_Expression (Expression (S))
+                  then
+                     Fold_Uint (N, Expr_Value (Expression (S)));
+
+                  --  If no size is specified, then we simply use the object
+                  --  size in the VADS_Size case (e.g. Natural'Size is equal
+                  --  to Integer'Size, not one less).
+
+                  else
+                     Fold_Uint (N, Esize (P_TypeA));
+                  end if;
+               end;
+
+            --  Normal case (Size) in which case we want the RM_Size
+
+            else
+               Fold_Uint (N, RM_Size (P_TypeA));
+            end if;
+         end if;
+      end Size;
+
+      -----------
+      -- Small --
+      -----------
+
+      when Attribute_Small =>
+
+         --  The floating-point case is present only for Ada 83 compatability.
+         --  Note that strictly this is an illegal addition, since we are
+         --  extending an Ada 95 defined attribute, but we anticipate an
+         --  ARG ruling that will permit this.
+
+         if Is_Floating_Point_Type (P_Type) then
+
+            --  Ada 83 attribute is defined as (RM83 3.5.8)
+
+            --    T'Small = 2.0**(-T'Emax - 1)
+
+            --  where
+
+            --    T'Emax = 4 * T'Mantissa
+
+            Fold_Ureal (N, Ureal_2 ** ((-(4 * Mantissa)) - 1));
+
+         --  Normal Ada 95 fixed-point case
+
+         else
+            Fold_Ureal (N, Small_Value (P_Type));
+         end if;
+
+      ----------
+      -- Succ --
+      ----------
+
+      when Attribute_Succ => Succ :
+      begin
+         if Static then
+
+            --  Floating-point case. For now, do not fold this, since we
+            --  don't know how to do it right (see fixed bug 3512-001 ???)
+
+            if Is_Floating_Point_Type (P_Type) then
+               Fold_Ureal (N,
+                 Eval_Fat.Succ (P_Root_Type, Expr_Value_R (E1)));
+
+            --  Fixed-point case
+
+            elsif Is_Fixed_Point_Type (P_Type) then
+               Fold_Ureal (N,
+                 Expr_Value_R (E1) + Small_Value (P_Type));
+
+            --  Modular integer case (wraps)
+
+            elsif Is_Modular_Integer_Type (P_Type) then
+               Fold_Uint (N, (Expr_Value (E1) + 1) mod Modulus (P_Type));
+
+            --  Other scalar cases
+
+            else
+               pragma Assert (Is_Scalar_Type (P_Type));
+
+               if Is_Enumeration_Type (P_Type)
+                 and then Expr_Value (E1) =
+                            Expr_Value (Type_High_Bound (P_Base_Type))
+               then
+                  Apply_Compile_Time_Constraint_Error
+                    (N, "Succ of type''Last");
+                  Check_Expressions;
+                  return;
+               else
+                  Fold_Uint (N, Expr_Value (E1) + 1);
+               end if;
+            end if;
+         end if;
+      end Succ;
+
+      ----------------
+      -- Truncation --
+      ----------------
+
+      when Attribute_Truncation =>
+         if Static then
+            Fold_Ureal (N,
+              Eval_Fat.Truncation (P_Root_Type, Expr_Value_R (E1)));
+         end if;
+
+      ----------------
+      -- Type_Class --
+      ----------------
+
+      when Attribute_Type_Class => Type_Class : declare
+         Typ : constant Entity_Id := Underlying_Type (P_Base_Type);
+         Id  : RE_Id;
+
+      begin
+         if Is_RTE (P_Root_Type, RE_Address) then
+            Id := RE_Type_Class_Address;
+
+         elsif Is_Enumeration_Type (Typ) then
+            Id := RE_Type_Class_Enumeration;
+
+         elsif Is_Integer_Type (Typ) then
+            Id := RE_Type_Class_Integer;
+
+         elsif Is_Fixed_Point_Type (Typ) then
+            Id := RE_Type_Class_Fixed_Point;
+
+         elsif Is_Floating_Point_Type (Typ) then
+            Id := RE_Type_Class_Floating_Point;
+
+         elsif Is_Array_Type (Typ) then
+            Id := RE_Type_Class_Array;
+
+         elsif Is_Record_Type (Typ) then
+            Id := RE_Type_Class_Record;
+
+         elsif Is_Access_Type (Typ) then
+            Id := RE_Type_Class_Access;
+
+         elsif Is_Enumeration_Type (Typ) then
+            Id := RE_Type_Class_Enumeration;
+
+         elsif Is_Task_Type (Typ) then
+            Id := RE_Type_Class_Task;
+
+         --  We treat protected types like task types. It would make more
+         --  sense to have another enumeration value, but after all the
+         --  whole point of this feature is to be exactly DEC compatible,
+         --  and changing the type Type_Clas would not meet this requirement.
+
+         elsif Is_Protected_Type (Typ) then
+            Id := RE_Type_Class_Task;
+
+         --  Not clear if there are any other possibilities, but if there
+         --  are, then we will treat them as the address case.
+
+         else
+            Id := RE_Type_Class_Address;
+         end if;
+
+         Rewrite (N, New_Occurrence_Of (RTE (Id), Loc));
+
+      end Type_Class;
+
+      -----------------------
+      -- Unbiased_Rounding --
+      -----------------------
+
+      when Attribute_Unbiased_Rounding =>
+         if Static then
+            Fold_Ureal (N,
+              Eval_Fat.Unbiased_Rounding (P_Root_Type, Expr_Value_R (E1)));
+         end if;
+
+      ---------------
+      -- VADS_Size --
+      ---------------
+
+      --  Processing is shared with Size
+
+      ---------
+      -- Val --
+      ---------
+
+      when Attribute_Val => Val :
+      begin
+         if Static then
+            if  Expr_Value (E1) < Expr_Value (Type_Low_Bound (P_Base_Type))
+              or else
+                Expr_Value (E1) > Expr_Value (Type_High_Bound (P_Base_Type))
+            then
+               Apply_Compile_Time_Constraint_Error
+                 (N, "Val expression out of range");
+               Check_Expressions;
+               return;
+            else
+               Fold_Uint (N, Expr_Value (E1));
+            end if;
+         end if;
+      end Val;
+
+      ----------------
+      -- Value_Size --
+      ----------------
+
+      --  The Value_Size attribute for a type returns the RM size of the
+      --  type. This an always be folded for scalar types, and can also
+      --  be folded for non-scalar types if the size is set.
+
+      when Attribute_Value_Size => Value_Size : declare
+         P_TypeA : constant Entity_Id := Underlying_Type (P_Type);
+
+      begin
+         if RM_Size (P_TypeA) /= Uint_0 then
+            Fold_Uint (N, RM_Size (P_TypeA));
+         end if;
+
+      end Value_Size;
+
+      -------------
+      -- Version --
+      -------------
+
+      --  Version can never be static
+
+      when Attribute_Version =>
+         null;
+
+      ----------------
+      -- Wide_Image --
+      ----------------
+
+      --  Wide_Image is a scalar attribute, but is never static, because it
+      --  is not a static function (having a non-scalar argument (RM 4.9(22))
+
+      when Attribute_Wide_Image =>
+         null;
+
+      ----------------
+      -- Wide_Width --
+      ----------------
+
+      --  Processing for Wide_Width is combined with Width
+
+      -----------
+      -- Width --
+      -----------
+
+      --  This processing also handles the case of Wide_Width
+
+      when Attribute_Width | Attribute_Wide_Width => Width :
+      begin
+         if Static then
+
+            --  Floating-point types
+
+            if Is_Floating_Point_Type (P_Type) then
+
+               --  Width is zero for a null range (RM 3.5 (38))
+
+               if Expr_Value_R (Type_High_Bound (P_Type)) <
+                  Expr_Value_R (Type_Low_Bound (P_Type))
+               then
+                  Fold_Uint (N, Uint_0);
+
+               else
+                  --  For floating-point, we have +N.dddE+nnn where length
+                  --  of ddd is determined by type'Digits - 1, but is one
+                  --  if Digits is one (RM 3.5 (33)).
+
+                  --  nnn is set to 2 for Short_Float and Float (32 bit
+                  --  floats), and 3 for Long_Float and Long_Long_Float.
+                  --  This is not quite right, but is good enough.
+
+                  declare
+                     Len : Int :=
+                             Int'Max (2, UI_To_Int (Digits_Value (P_Type)));
+
+                  begin
+                     if Esize (P_Type) <= 32 then
+                        Len := Len + 6;
+                     else
+                        Len := Len + 7;
+                     end if;
+
+                     Fold_Uint (N, UI_From_Int (Len));
+                  end;
+               end if;
+
+            --  Fixed-point types
+
+            elsif Is_Fixed_Point_Type (P_Type) then
+
+               --  Width is zero for a null range (RM 3.5 (38))
+
+               if Expr_Value (Type_High_Bound (P_Type)) <
+                  Expr_Value (Type_Low_Bound  (P_Type))
+               then
+                  Fold_Uint (N, Uint_0);
+
+               --  The non-null case depends on the specific real type
+
+               else
+                  --  For fixed-point type width is Fore + 1 + Aft (RM 3.5(34))
+
+                  Fold_Uint (N, UI_From_Int (Fore_Value + 1 + Aft_Value));
+               end if;
+
+            --  Discrete types
+
+            else
+               declare
+                  R  : constant Entity_Id := Root_Type (P_Type);
+                  Lo : constant Uint :=
+                         Expr_Value (Type_Low_Bound (P_Type));
+                  Hi : constant Uint :=
+                         Expr_Value (Type_High_Bound (P_Type));
+                  W  : Nat;
+                  Wt : Nat;
+                  T  : Uint;
+                  L  : Node_Id;
+                  C  : Character;
+
+               begin
+                  --  Empty ranges
+
+                  if Lo > Hi then
+                     W := 0;
+
+                  --  Width for types derived from Standard.Character
+                  --  and Standard.Wide_Character.
+
+                  elsif R = Standard_Character
+                    or else R = Standard_Wide_Character
+                  then
+                     W := 0;
+
+                     --  Set W larger if needed
+
+                     for J in UI_To_Int (Lo) .. UI_To_Int (Hi) loop
+
+                        --  Assume all wide-character escape sequences are
+                        --  same length, so we can quit when we reach one.
+
+                        if J > 255 then
+                           if Id = Attribute_Wide_Width then
+                              W := Int'Max (W, 3);
+                              exit;
+                           else
+                              W := Int'Max (W, Length_Wide);
+                              exit;
+                           end if;
+
+                        else
+                           C := Character'Val (J);
+
+                           --  Test for all cases where Character'Image
+                           --  yields an image that is longer than three
+                           --  characters. First the cases of Reserved_xxx
+                           --  names (length = 12).
+
+                           case C is
+                              when Reserved_128 | Reserved_129 |
+                                   Reserved_132 | Reserved_153
+
+                                => Wt := 12;
+
+                              when BS | HT | LF | VT | FF | CR |
+                                   SO | SI | EM | FS | GS | RS |
+                                   US | RI | MW | ST | PM
+
+                                => Wt := 2;
+
+                              when NUL | SOH | STX | ETX | EOT |
+                                   ENQ | ACK | BEL | DLE | DC1 |
+                                   DC2 | DC3 | DC4 | NAK | SYN |
+                                   ETB | CAN | SUB | ESC | DEL |
+                                   BPH | NBH | NEL | SSA | ESA |
+                                   HTS | HTJ | VTS | PLD | PLU |
+                                   SS2 | SS3 | DCS | PU1 | PU2 |
+                                   STS | CCH | SPA | EPA | SOS |
+                                   SCI | CSI | OSC | APC
+
+                                => Wt := 3;
+
+                              when Space .. Tilde |
+                                   No_Break_Space .. LC_Y_Diaeresis
+
+                                => Wt := 3;
+
+                           end case;
+
+                           W := Int'Max (W, Wt);
+                        end if;
+                     end loop;
+
+                  --  Width for types derived from Standard.Boolean
+
+                  elsif R = Standard_Boolean then
+                     if Lo = 0 then
+                        W := 5; -- FALSE
+                     else
+                        W := 4; -- TRUE
+                     end if;
+
+                  --  Width for integer types
+
+                  elsif Is_Integer_Type (P_Type) then
+                     T := UI_Max (abs Lo, abs Hi);
+
+                     W := 2;
+                     while T >= 10 loop
+                        W := W + 1;
+                        T := T / 10;
+                     end loop;
+
+                  --  Only remaining possibility is user declared enum type
+
+                  else
+                     pragma Assert (Is_Enumeration_Type (P_Type));
+
+                     W := 0;
+                     L := First_Literal (P_Type);
+
+                     while Present (L) loop
+
+                        --  Only pay attention to in range characters
+
+                        if Lo <= Enumeration_Pos (L)
+                          and then Enumeration_Pos (L) <= Hi
+                        then
+                           --  For Width case, use decoded name
+
+                           if Id = Attribute_Width then
+                              Get_Decoded_Name_String (Chars (L));
+                              Wt := Nat (Name_Len);
+
+                           --  For Wide_Width, use encoded name, and then
+                           --  adjust for the encoding.
+
+                           else
+                              Get_Name_String (Chars (L));
+
+                              --  Character literals are always of length 3
+
+                              if Name_Buffer (1) = 'Q' then
+                                 Wt := 3;
+
+                              --  Otherwise loop to adjust for upper/wide chars
+
+                              else
+                                 Wt := Nat (Name_Len);
+
+                                 for J in 1 .. Name_Len loop
+                                    if Name_Buffer (J) = 'U' then
+                                       Wt := Wt - 2;
+                                    elsif Name_Buffer (J) = 'W' then
+                                       Wt := Wt - 4;
+                                    end if;
+                                 end loop;
+                              end if;
+                           end if;
+
+                           W := Int'Max (W, Wt);
+                        end if;
+
+                        Next_Literal (L);
+                     end loop;
+                  end if;
+
+                  Fold_Uint (N, UI_From_Int (W));
+               end;
+            end if;
+         end if;
+      end Width;
+
+      --  The following attributes can never be folded, and furthermore we
+      --  should not even have entered the case statement for any of these.
+      --  Note that in some cases, the values have already been folded as
+      --  a result of the processing in Analyze_Attribute.
+
+      when Attribute_Abort_Signal             |
+           Attribute_Access                   |
+           Attribute_Address                  |
+           Attribute_Address_Size             |
+           Attribute_Asm_Input                |
+           Attribute_Asm_Output               |
+           Attribute_Base                     |
+           Attribute_Bit_Order                |
+           Attribute_Bit_Position             |
+           Attribute_Callable                 |
+           Attribute_Caller                   |
+           Attribute_Class                    |
+           Attribute_Code_Address             |
+           Attribute_Count                    |
+           Attribute_Default_Bit_Order        |
+           Attribute_Elaborated               |
+           Attribute_Elab_Body                |
+           Attribute_Elab_Spec                |
+           Attribute_External_Tag             |
+           Attribute_First_Bit                |
+           Attribute_Input                    |
+           Attribute_Last_Bit                 |
+           Attribute_Max_Interrupt_Priority   |
+           Attribute_Max_Priority             |
+           Attribute_Maximum_Alignment        |
+           Attribute_Output                   |
+           Attribute_Partition_ID             |
+           Attribute_Position                 |
+           Attribute_Read                     |
+           Attribute_Storage_Pool             |
+           Attribute_Storage_Size             |
+           Attribute_Storage_Unit             |
+           Attribute_Tag                      |
+           Attribute_Terminated               |
+           Attribute_Tick                     |
+           Attribute_To_Address               |
+           Attribute_UET_Address              |
+           Attribute_Unchecked_Access         |
+           Attribute_Universal_Literal_String |
+           Attribute_Unrestricted_Access      |
+           Attribute_Valid                    |
+           Attribute_Value                    |
+           Attribute_Wchar_T_Size             |
+           Attribute_Wide_Value               |
+           Attribute_Word_Size                |
+           Attribute_Write                    =>
+
+         raise Program_Error;
+
+      end case;
+
+      --  At the end of the case, one more check. If we did a static evaluation
+      --  so that the result is now a literal, then set Is_Static_Expression
+      --  in the constant only if the prefix type is a static subtype. For
+      --  non-static subtypes, the folding is still OK, but not static.
+
+      if Nkind (N) = N_Integer_Literal
+        or else Nkind (N) = N_Real_Literal
+        or else Nkind (N) = N_Character_Literal
+        or else Nkind (N) = N_String_Literal
+        or else (Is_Entity_Name (N)
+                  and then Ekind (Entity (N)) = E_Enumeration_Literal)
+      then
+         Set_Is_Static_Expression (N, Static);
+
+      --  If this is still an attribute reference, then it has not been folded
+      --  and that means that its expressions are in a non-static context.
+
+      elsif Nkind (N) = N_Attribute_Reference then
+         Check_Expressions;
+
+      --  Note: the else case not covered here are odd cases where the
+      --  processing has transformed the attribute into something other
+      --  than a constant. Nothing more to do in such cases.
+
+      else
+         null;
+      end if;
+
+   end Eval_Attribute;
+
+   ------------------------------
+   -- Is_Anonymous_Tagged_Base --
+   ------------------------------
+
+   function Is_Anonymous_Tagged_Base
+     (Anon : Entity_Id;
+      Typ  : Entity_Id)
+      return Boolean
+   is
+   begin
+      return
+        Anon = Current_Scope
+          and then Is_Itype (Anon)
+          and then Associated_Node_For_Itype (Anon) = Parent (Typ);
+   end Is_Anonymous_Tagged_Base;
+
+   -----------------------
+   -- Resolve_Attribute --
+   -----------------------
+
+   procedure Resolve_Attribute (N : Node_Id; Typ : Entity_Id) is
+      Loc      : constant Source_Ptr   := Sloc (N);
+      P        : constant Node_Id      := Prefix (N);
+      Aname    : constant Name_Id      := Attribute_Name (N);
+      Attr_Id  : constant Attribute_Id := Get_Attribute_Id (Aname);
+      Index    : Interp_Index;
+      It       : Interp;
+      Btyp     : Entity_Id := Base_Type (Typ);
+      Nom_Subt : Entity_Id;
+
+   begin
+      --  If error during analysis, no point in continuing, except for
+      --  array types, where we get  better recovery by using unconstrained
+      --  indices than nothing at all (see Check_Array_Type).
+
+      if Error_Posted (N)
+        and then Attr_Id /= Attribute_First
+        and then Attr_Id /= Attribute_Last
+        and then Attr_Id /= Attribute_Length
+        and then Attr_Id /= Attribute_Range
+      then
+         return;
+      end if;
+
+      --  If attribute was universal type, reset to actual type
+
+      if Etype (N) = Universal_Integer
+        or else Etype (N) = Universal_Real
+      then
+         Set_Etype (N, Typ);
+      end if;
+
+      --  Remaining processing depends on attribute
+
+      case Attr_Id is
+
+         ------------
+         -- Access --
+         ------------
+
+         --  For access attributes, if the prefix denotes an entity, it is
+         --  interpreted as a name, never as a call. It may be overloaded,
+         --  in which case resolution uses the profile of the context type.
+         --  Otherwise prefix must be resolved.
+
+         when Attribute_Access
+            | Attribute_Unchecked_Access
+            | Attribute_Unrestricted_Access =>
+
+            if Is_Variable (P) then
+               Note_Possible_Modification (P);
+            end if;
+
+            if Is_Entity_Name (P) then
+
+               if Is_Overloaded (P) then
+                  Get_First_Interp (P, Index, It);
+
+                  while Present (It.Nam) loop
+
+                     if Type_Conformant (Designated_Type (Typ), It.Nam) then
+                        Set_Entity (P, It.Nam);
+
+                        --  The prefix is definitely NOT overloaded anymore
+                        --  at this point, so we reset the Is_Overloaded
+                        --  flag to avoid any confusion when reanalyzing
+                        --  the node.
+
+                        Set_Is_Overloaded (P, False);
+                        Generate_Reference (Entity (P), P);
+                        exit;
+                     end if;
+
+                     Get_Next_Interp (Index, It);
+                  end loop;
+
+               --  If it is a subprogram name or a type, there is nothing
+               --  to resolve.
+
+               elsif not Is_Overloadable (Entity (P))
+                 and then not Is_Type (Entity (P))
+               then
+                  Resolve (P, Etype (P));
+               end if;
+
+               if not Is_Entity_Name (P) then
+                  null;
+
+               elsif Is_Abstract (Entity (P))
+                 and then Is_Overloadable (Entity (P))
+               then
+                  Error_Msg_Name_1 := Aname;
+                  Error_Msg_N ("prefix of % attribute cannot be abstract", P);
+                  Set_Etype (N, Any_Type);
+
+               elsif Convention (Entity (P)) = Convention_Intrinsic then
+                  Error_Msg_Name_1 := Aname;
+
+                  if Ekind (Entity (P)) = E_Enumeration_Literal then
+                     Error_Msg_N
+                       ("prefix of % attribute cannot be enumeration literal",
+                          P);
+                  else
+                     Error_Msg_N
+                       ("prefix of % attribute cannot be intrinsic", P);
+                  end if;
+
+                  Set_Etype (N, Any_Type);
+               end if;
+
+               --  Assignments, return statements, components of aggregates,
+               --  generic instantiations will require convention checks if
+               --  the type is an access to subprogram. Given that there will
+               --  also be accessibility checks on those, this is where the
+               --  checks can eventually be centralized ???
+
+               if Ekind (Btyp) = E_Access_Subprogram_Type then
+                  if Convention (Btyp) /= Convention (Entity (P)) then
+                     Error_Msg_N
+                      ("subprogram has invalid convention for context", P);
+
+                  else
+                     Check_Subtype_Conformant
+                       (New_Id  => Entity (P),
+                        Old_Id  => Designated_Type (Btyp),
+                        Err_Loc => P);
+                  end if;
+
+                  if Attr_Id = Attribute_Unchecked_Access then
+                     Error_Msg_Name_1 := Aname;
+                     Error_Msg_N
+                       ("attribute% cannot be applied to a subprogram", P);
+
+                  elsif Aname = Name_Unrestricted_Access then
+                     null;  --  Nothing to check
+
+                  --  Check the static accessibility rule of 3.10.2(32)
+
+                  elsif Attr_Id = Attribute_Access
+                    and then Subprogram_Access_Level (Entity (P))
+                      > Type_Access_Level (Btyp)
+                  then
+                     if not In_Instance_Body then
+                        Error_Msg_N
+                          ("subprogram must not be deeper than access type",
+                            P);
+                     else
+                        Warn_On_Instance := True;
+                        Error_Msg_N
+                          ("subprogram must not be deeper than access type?",
+                             P);
+                        Error_Msg_N
+                          ("Constraint_Error will be raised ?", P);
+                        Set_Raises_Constraint_Error (N);
+                        Warn_On_Instance := False;
+                     end if;
+
+                  --  Check the restriction of 3.10.2(32) that disallows
+                  --  the type of the access attribute to be declared
+                  --  outside a generic body when the attribute occurs
+                  --  within that generic body.
+
+                  elsif Enclosing_Generic_Body (Entity (P))
+                    /= Enclosing_Generic_Body (Btyp)
+                  then
+                     Error_Msg_N
+                       ("access type must not be outside generic body", P);
+                  end if;
+               end if;
+
+               --  if this is a renaming, an inherited operation, or a
+               --  subprogram instance, use the original entity.
+
+               if Is_Entity_Name (P)
+                 and then Is_Overloadable (Entity (P))
+                 and then Present (Alias (Entity (P)))
+               then
+                  Rewrite (P,
+                    New_Occurrence_Of (Alias (Entity (P)), Sloc (P)));
+               end if;
+
+            elsif Nkind (P) = N_Selected_Component
+              and then Is_Overloadable (Entity (Selector_Name (P)))
+            then
+               --  Protected operation. If operation is overloaded, must
+               --  disambiguate. Prefix that denotes protected object itself
+               --  is resolved with its own type.
+
+               if Attr_Id = Attribute_Unchecked_Access then
+                  Error_Msg_Name_1 := Aname;
+                  Error_Msg_N
+                    ("attribute% cannot be applied to protected operation", P);
+               end if;
+
+               Resolve (Prefix (P), Etype (Prefix (P)));
+
+            elsif Is_Overloaded (P) then
+
+               --  Use the designated type of the context  to disambiguate.
+               declare
+                  Index : Interp_Index;
+                  It    : Interp;
+               begin
+                  Get_First_Interp (P, Index, It);
+
+                  while Present (It.Typ) loop
+                     if Covers (Designated_Type (Typ), It.Typ) then
+                        Resolve (P, It.Typ);
+                        exit;
+                     end if;
+
+                     Get_Next_Interp (Index, It);
+                  end loop;
+               end;
+            else
+               Resolve (P, Etype (P));
+            end if;
+
+            --  X'Access is illegal if X denotes a constant and the access
+            --  type is access-to-variable. Same for 'Unchecked_Access.
+            --  The rule does not apply to 'Unrestricted_Access.
+
+            if not (Ekind (Btyp) = E_Access_Subprogram_Type
+                     or else (Is_Record_Type (Btyp) and then
+                              Present (Corresponding_Remote_Type (Btyp)))
+                     or else Ekind (Btyp) = E_Access_Protected_Subprogram_Type
+                     or else Is_Access_Constant (Btyp)
+                     or else Is_Variable (P)
+                     or else Attr_Id = Attribute_Unrestricted_Access)
+            then
+               if Comes_From_Source (N) then
+                  Error_Msg_N ("access-to-variable designates constant", P);
+               end if;
+            end if;
+
+            if (Attr_Id = Attribute_Access
+                  or else
+                Attr_Id = Attribute_Unchecked_Access)
+              and then (Ekind (Btyp) = E_General_Access_Type
+                         or else Ekind (Btyp) = E_Anonymous_Access_Type)
+            then
+               if Is_Dependent_Component_Of_Mutable_Object (P) then
+                  Error_Msg_N
+                    ("illegal attribute for discriminant-dependent component",
+                     P);
+               end if;
+
+               --  Check the static matching rule of 3.10.2(27). The
+               --  nominal subtype of the prefix must statically
+               --  match the designated type.
+
+               Nom_Subt := Etype (P);
+
+               if Is_Constr_Subt_For_U_Nominal (Nom_Subt) then
+                  Nom_Subt := Etype (Nom_Subt);
+               end if;
+
+               if Is_Tagged_Type (Designated_Type (Typ)) then
+                  --  If the attribute is in the context of an access
+                  --  parameter, then the prefix is allowed to be of
+                  --  the class-wide type (by AI-127).
+
+                  if Ekind (Typ) = E_Anonymous_Access_Type then
+                     if not Covers (Designated_Type (Typ), Nom_Subt)
+                       and then not Covers (Nom_Subt, Designated_Type (Typ))
+                     then
+                        if Is_Anonymous_Tagged_Base
+                             (Nom_Subt, Etype (Designated_Type (Typ)))
+                        then
+                           null;
+
+                        else
+                           Error_Msg_NE
+                             ("type of prefix: & not compatible", P, Nom_Subt);
+                           Error_Msg_NE
+                             ("\with &, the expected designated type",
+                               P, Designated_Type (Typ));
+                        end if;
+                     end if;
+
+                  elsif not Covers (Designated_Type (Typ), Nom_Subt)
+                    or else
+                      (not Is_Class_Wide_Type (Designated_Type (Typ))
+                        and then Is_Class_Wide_Type (Nom_Subt))
+                  then
+                     Error_Msg_NE
+                       ("type of prefix: & is not covered", P, Nom_Subt);
+                     Error_Msg_NE
+                       ("\by &, the expected designated type" &
+                           " ('R'M 3.10.2 (27))", P, Designated_Type (Typ));
+                  end if;
+
+                  if Is_Class_Wide_Type (Designated_Type (Typ))
+                    and then Has_Discriminants (Etype (Designated_Type (Typ)))
+                    and then Is_Constrained (Etype (Designated_Type (Typ)))
+                    and then Designated_Type (Typ) /= Nom_Subt
+                  then
+                     Apply_Discriminant_Check
+                       (N, Etype (Designated_Type (Typ)));
+                  end if;
+
+               elsif not Subtypes_Statically_Match
+                        (Designated_Type (Typ), Nom_Subt)
+                 and then
+                   not (Has_Discriminants (Designated_Type (Typ))
+                        and then not Is_Constrained (Designated_Type (Typ)))
+               then
+                  Error_Msg_N
+                    ("object subtype must statically match "
+                     & "designated subtype", P);
+
+                  if Is_Entity_Name (P)
+                    and then Is_Array_Type (Designated_Type (Typ))
+                  then
+
+                     declare
+                        D : constant Node_Id := Declaration_Node (Entity (P));
+
+                     begin
+                        Error_Msg_N ("aliased object has explicit bounds?",
+                          D);
+                        Error_Msg_N ("\declare without bounds"
+                          & " (and with explicit initialization)?", D);
+                        Error_Msg_N ("\for use with unconstrained access?", D);
+                     end;
+                  end if;
+               end if;
+
+               --  Check the static accessibility rule of 3.10.2(28).
+               --  Note that this check is not performed for the
+               --  case of an anonymous access type, since the access
+               --  attribute is always legal in such a context.
+
+               if Attr_Id /= Attribute_Unchecked_Access
+                 and then Object_Access_Level (P) > Type_Access_Level (Btyp)
+                 and then Ekind (Btyp) = E_General_Access_Type
+               then
+                  --  In an instance, this is a runtime check, but one we
+                  --  know will fail, so generate an appropriate warning.
+
+                  if In_Instance_Body then
+                     Error_Msg_N
+                       ("?non-local pointer cannot point to local object", P);
+                     Error_Msg_N
+                       ("?Program_Error will be raised at run time", P);
+                     Rewrite (N, Make_Raise_Program_Error (Loc));
+                     Set_Etype (N, Typ);
+                     return;
+
+                  else
+                     Error_Msg_N
+                       ("non-local pointer cannot point to local object", P);
+
+                     if Is_Record_Type (Current_Scope)
+                       and then (Nkind (Parent (N)) =
+                                  N_Discriminant_Association
+                                   or else
+                                 Nkind (Parent (N)) =
+                                   N_Index_Or_Discriminant_Constraint)
+                     then
+                        declare
+                           Indic : Node_Id := Parent (Parent (N));
+
+                        begin
+                           while Present (Indic)
+                             and then Nkind (Indic) /= N_Subtype_Indication
+                           loop
+                              Indic := Parent (Indic);
+                           end loop;
+
+                           if Present (Indic) then
+                              Error_Msg_NE
+                                ("\use an access definition for" &
+                                  " the access discriminant of&", N,
+                                  Entity (Subtype_Mark (Indic)));
+                           end if;
+                        end;
+                     end if;
+                  end if;
+               end if;
+            end if;
+
+            if Ekind (Btyp) = E_Access_Protected_Subprogram_Type
+              and then Is_Entity_Name (P)
+              and then not Is_Protected_Type (Scope (Entity (P)))
+            then
+               Error_Msg_N ("context requires a protected subprogram", P);
+
+            elsif Ekind (Btyp) = E_Access_Subprogram_Type
+              and then Ekind (Etype (N)) = E_Access_Protected_Subprogram_Type
+            then
+               Error_Msg_N ("context requires a non-protected subprogram", P);
+            end if;
+
+            --  The context cannot be a pool-specific type, but this is a
+            --  legality rule, not a resolution rule, so it must be checked
+            --  separately, after possibly disambiguation (see AI-245).
+
+            if Ekind (Btyp) = E_Access_Type
+              and then Attr_Id /= Attribute_Unrestricted_Access
+            then
+               Wrong_Type (N, Typ);
+            end if;
+
+            Set_Etype (N, Typ);
+
+            --  Check for incorrect atomic/volatile reference (RM C.6(12))
+
+            if Attr_Id /= Attribute_Unrestricted_Access then
+               if Is_Atomic_Object (P)
+                 and then not Is_Atomic (Designated_Type (Typ))
+               then
+                  Error_Msg_N
+                    ("access to atomic object cannot yield access-to-" &
+                     "non-atomic type", P);
+
+               elsif Is_Volatile_Object (P)
+                 and then not Is_Volatile (Designated_Type (Typ))
+               then
+                  Error_Msg_N
+                    ("access to volatile object cannot yield access-to-" &
+                     "non-volatile type", P);
+               end if;
+            end if;
+
+         -------------
+         -- Address --
+         -------------
+
+         --  Deal with resolving the type for Address attribute, overloading
+         --  is not permitted here, since there is no context to resolve it.
+
+         when Attribute_Address | Attribute_Code_Address =>
+
+            --  To be safe, assume that if the address of a variable is taken,
+            --  it may be modified via this address, so note modification.
+
+            if Is_Variable (P) then
+               Note_Possible_Modification (P);
+            end if;
+
+            if Nkind (P) in  N_Subexpr
+              and then Is_Overloaded (P)
+            then
+               Get_First_Interp (P, Index, It);
+               Get_Next_Interp (Index, It);
+
+               if Present (It.Nam) then
+                  Error_Msg_Name_1 := Aname;
+                  Error_Msg_N
+                    ("prefix of % attribute cannot be overloaded", N);
+                  return;
+               end if;
+            end if;
+
+            --  Do not permit address to be applied to entry
+
+            if (Is_Entity_Name (P) and then Is_Entry (Entity (P)))
+              or else Nkind (P) = N_Entry_Call_Statement
+
+              or else (Nkind (P) = N_Selected_Component
+                and then Is_Entry (Entity (Selector_Name (P))))
+
+              or else (Nkind (P) = N_Indexed_Component
+                and then Nkind (Prefix (P)) = N_Selected_Component
+                and then Is_Entry (Entity (Selector_Name (Prefix (P)))))
+            then
+               Error_Msg_Name_1 := Aname;
+               Error_Msg_N
+                 ("prefix of % attribute cannot be entry", N);
+               return;
+            end if;
+
+            if not Is_Entity_Name (P)
+               or else not Is_Overloadable (Entity (P))
+            then
+               if not Is_Task_Type (Etype (P))
+                 or else Nkind (P) = N_Explicit_Dereference
+               then
+                  Resolve (P, Etype (P));
+               end if;
+            end if;
+
+            --  If this is the name of a derived subprogram, or that of a
+            --  generic actual, the address is that of the original entity.
+
+            if Is_Entity_Name (P)
+              and then Is_Overloadable (Entity (P))
+              and then Present (Alias (Entity (P)))
+            then
+               Rewrite (P,
+                 New_Occurrence_Of (Alias (Entity (P)), Sloc (P)));
+            end if;
+
+         ---------------
+         -- AST_Entry --
+         ---------------
+
+         --  Prefix of the AST_Entry attribute is an entry name which must
+         --  not be resolved, since this is definitely not an entry call.
+
+         when Attribute_AST_Entry =>
+            null;
+
+         ------------------
+         -- Body_Version --
+         ------------------
+
+         --  Prefix of Body_Version attribute can be a subprogram name which
+         --  must not be resolved, since this is not a call.
+
+         when Attribute_Body_Version =>
+            null;
+
+         ------------
+         -- Caller --
+         ------------
+
+         --  Prefix of Caller attribute is an entry name which must not
+         --  be resolved, since this is definitely not an entry call.
+
+         when Attribute_Caller =>
+            null;
+
+         ------------------
+         -- Code_Address --
+         ------------------
+
+         --  Shares processing with Address attribute
+
+         -----------
+         -- Count --
+         -----------
+
+         --  Prefix of the Count attribute is an entry name which must not
+         --  be resolved, since this is definitely not an entry call.
+
+         when Attribute_Count =>
+            null;
+
+         ----------------
+         -- Elaborated --
+         ----------------
+
+         --  Prefix of the Elaborated attribute is a subprogram name which
+         --  must not be resolved, since this is definitely not a call. Note
+         --  that it is a library unit, so it cannot be overloaded here.
+
+         when Attribute_Elaborated =>
+            null;
+
+         --------------------
+         -- Mechanism_Code --
+         --------------------
+
+         --  Prefix of the Mechanism_Code attribute is a function name
+         --  which must not be resolved. Should we check for overloaded ???
+
+         when Attribute_Mechanism_Code =>
+            null;
+
+         ------------------
+         -- Partition_ID --
+         ------------------
+
+         --  Most processing is done in sem_dist, after determining the
+         --  context type. Node is rewritten as a conversion to a runtime call.
+
+         when Attribute_Partition_ID =>
+            Process_Partition_Id (N);
+            return;
+
+         -----------
+         -- Range --
+         -----------
+
+         --  We replace the Range attribute node with a range expression
+         --  whose bounds are the 'First and 'Last attributes applied to the
+         --  same prefix. The reason that we do this transformation here
+         --  instead of in the expander is that it simplifies other parts of
+         --  the semantic analysis which assume that the Range has been
+         --  replaced; thus it must be done even when in semantic-only mode
+         --  (note that the RM specifically mentions this equivalence, we
+         --  take care that the prefix is only evaluated once).
+
+         when Attribute_Range => Range_Attribute :
+            declare
+               LB   : Node_Id;
+               HB   : Node_Id;
+
+               function Check_Discriminated_Prival
+                 (N    : Node_Id)
+                  return Node_Id;
+               --  The range of a private component constrained by a
+               --  discriminant is rewritten to make the discriminant
+               --  explicit. This solves some complex visibility problems
+               --  related to the use of privals.
+
+               function Check_Discriminated_Prival
+                 (N    : Node_Id)
+                  return Node_Id
+               is
+               begin
+                  if Is_Entity_Name (N)
+                    and then Ekind (Entity (N)) = E_In_Parameter
+                    and then not Within_Init_Proc
+                  then
+                     return Make_Identifier (Sloc (N), Chars (Entity (N)));
+                  else
+                     return Duplicate_Subexpr (N);
+                  end if;
+               end Check_Discriminated_Prival;
+
+            --  Start of processing for Range_Attribute
+
+            begin
+               if not Is_Entity_Name (P)
+                 or else not Is_Type (Entity (P))
+               then
+                  Resolve (P, Etype (P));
+               end if;
+
+               --  Check whether prefix is (renaming of) private component
+               --  of protected type.
+
+               if Is_Entity_Name (P)
+                 and then Comes_From_Source (N)
+                 and then Is_Array_Type (Etype (P))
+                 and then Number_Dimensions (Etype (P)) = 1
+                 and then (Ekind (Scope (Entity (P))) = E_Protected_Type
+                            or else
+                           Ekind (Scope (Scope (Entity (P)))) =
+                                                        E_Protected_Type)
+               then
+                  LB := Check_Discriminated_Prival (
+                    Type_Low_Bound (Etype (First_Index (Etype (P)))));
+
+                  HB := Check_Discriminated_Prival (
+                    Type_High_Bound (Etype (First_Index (Etype (P)))));
+
+               else
+                  HB :=
+                    Make_Attribute_Reference (Loc,
+                      Prefix         => Duplicate_Subexpr (P),
+                      Attribute_Name => Name_Last,
+                      Expressions    => Expressions (N));
+
+                  LB :=
+                    Make_Attribute_Reference (Loc,
+                      Prefix         => P,
+                      Attribute_Name => Name_First,
+                      Expressions    => Expressions (N));
+               end if;
+
+               --  If the original was marked as Must_Not_Freeze (see code
+               --  in Sem_Ch3.Make_Index), then make sure the rewriting
+               --  does not freeze either.
+
+               if Must_Not_Freeze (N) then
+                  Set_Must_Not_Freeze (HB);
+                  Set_Must_Not_Freeze (LB);
+                  Set_Must_Not_Freeze (Prefix (HB));
+                  Set_Must_Not_Freeze (Prefix (LB));
+               end if;
+
+               if Raises_Constraint_Error (Prefix (N)) then
+
+                  --  Preserve Sloc of prefix in the new bounds, so that
+                  --  the posted warning can be removed if we are within
+                  --  unreachable code.
+
+                  Set_Sloc (LB, Sloc (Prefix (N)));
+                  Set_Sloc (HB, Sloc (Prefix (N)));
+               end if;
+
+               Rewrite (N, Make_Range (Loc, LB, HB));
+               Analyze_And_Resolve (N, Typ);
+
+               --  Normally after resolving attribute nodes, Eval_Attribute
+               --  is called to do any possible static evaluation of the node.
+               --  However, here since the Range attribute has just been
+               --  transformed into a range expression it is no longer an
+               --  attribute node and therefore the call needs to be avoided
+               --  and is accomplished by simply returning from the procedure.
+
+               return;
+            end Range_Attribute;
+
+         -----------------
+         -- UET_Address --
+         -----------------
+
+         --  Prefix must not be resolved in this case, since it is not a
+         --  real entity reference. No action of any kind is require!
+
+         when Attribute_UET_Address =>
+            return;
+
+         ----------------------
+         -- Unchecked_Access --
+         ----------------------
+
+         --  Processing is shared with Access
+
+         -------------------------
+         -- Unrestricted_Access --
+         -------------------------
+
+         --  Processing is shared with Access
+
+         ---------
+         -- Val --
+         ---------
+
+         --  Apply range check. Note that we did not do this during the
+         --  analysis phase, since we wanted Eval_Attribute to have a
+         --  chance at finding an illegal out of range value.
+
+         when Attribute_Val =>
+
+            --  Note that we do our own Eval_Attribute call here rather than
+            --  use the common one, because we need to do processing after
+            --  the call, as per above comment.
+
+            Eval_Attribute (N);
+
+            --  Eval_Attribute may replace the node with a raise CE, or
+            --  fold it to a constant. Obviously we only apply a scalar
+            --  range check if this did not happen!
+
+            if Nkind (N) = N_Attribute_Reference
+              and then Attribute_Name (N) = Name_Val
+            then
+               Apply_Scalar_Range_Check (First (Expressions (N)), Btyp);
+            end if;
+
+            return;
+
+         -------------
+         -- Version --
+         -------------
+
+         --  Prefix of Version attribute can be a subprogram name which
+         --  must not be resolved, since this is not a call.
+
+         when Attribute_Version =>
+            null;
+
+         ----------------------
+         -- Other Attributes --
+         ----------------------
+
+         --  For other attributes, resolve prefix unless it is a type. If
+         --  the attribute reference itself is a type name ('Base and 'Class)
+         --  then this is only legal within a task or protected record.
+
+         when others =>
+            if not Is_Entity_Name (P)
+              or else not Is_Type (Entity (P))
+            then
+               Resolve (P, Etype (P));
+            end if;
+
+            --  If the attribute reference itself is a type name ('Base,
+            --  'Class) then this is only legal within a task or protected
+            --  record. What is this all about ???
+
+            if Is_Entity_Name (N)
+              and then Is_Type (Entity (N))
+            then
+               if Is_Concurrent_Type (Entity (N))
+                 and then In_Open_Scopes (Entity (P))
+               then
+                  null;
+               else
+                  Error_Msg_N
+                    ("invalid use of subtype name in expression or call", N);
+               end if;
+            end if;
+
+            --  For attributes whose argument may be a string, complete
+            --  resolution of argument now. This avoids premature expansion
+            --  (and the creation of transient scopes) before the attribute
+            --  reference is resolved.
+
+            case Attr_Id is
+               when Attribute_Value =>
+                  Resolve (First (Expressions (N)), Standard_String);
+
+               when Attribute_Wide_Value =>
+                  Resolve (First (Expressions (N)), Standard_Wide_String);
+
+               when others => null;
+            end case;
+      end case;
+
+      --  Normally the Freezing is done by Resolve but sometimes the Prefix
+      --  is not resolved, in which case the freezing must be done now.
+
+      Freeze_Expression (P);
+
+      --  Finally perform static evaluation on the attribute reference
+
+      Eval_Attribute (N);
+
+   end Resolve_Attribute;
+
+end Sem_Attr;
diff --git a/gcc/ada/sem_attr.ads b/gcc/ada/sem_attr.ads
new file mode 100644
index 00000000000..ccbc3f49d4c
--- /dev/null
+++ b/gcc/ada/sem_attr.ads
@@ -0,0 +1,595 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             S E M _ A T T R                              --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.26 $
+--                                                                          --
+--          Copyright (C) 1992-1999, 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). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  Attribute handling is isolated in a separate package to ease the addition
+--  of implementation defined attributes. Logically this processing belongs
+--  in chapter 4. See Sem_Ch4 for a description of the relation of the
+--  Analyze and Resolve routines for expression components.
+
+--  This spec also documents all GNAT implementation defined pragmas
+
+with Snames; use Snames;
+with Types;  use Types;
+
+package Sem_Attr is
+
+   type Attribute_Class_Array is array (Attribute_Id) of Boolean;
+   --  Type used to build attribute classification flag arrays
+
+   -----------------------------------------
+   -- Implementation Dependent Attributes --
+   -----------------------------------------
+
+   --  This section describes the implementation dependent attributes
+   --  provided in GNAT, as well as constructing an array of flags
+   --  indicating which attributes these are.
+
+   Attribute_Impl_Def : Attribute_Class_Array := Attribute_Class_Array'(
+
+      ------------------
+      -- Abort_Signal --
+      ------------------
+
+      Attribute_Abort_Signal => True,
+      --
+      --  Standard'Abort_Signal (Standard is the only allowed prefix)
+      --  provides the entity for the special exception used to signal
+      --  task abort or asynchronous transfer of control. Normally this
+      --  attribute should only be used in the tasking runtime (it is
+      --  highly peculiar, and completely outside the normal semantics
+      --  of Ada, for a user program to intercept the abort exception).
+
+      ------------------
+      -- Address_Size --
+      ------------------
+
+      Attribute_Address_Size => True,
+      --
+      --  Standard'Address_Size (Standard is the only allowed prefix) is
+      --  a static constant giving the number of bits in an Address. It
+      --  is used primarily for constructing the definition of Memory_Size
+      --  in package Standard, but may be freely used in user programs.
+      --  This is a static attribute.
+
+      ---------------
+      -- Asm_Input --
+      ---------------
+
+      Attribute_Asm_Input => True,
+      --
+      --  Used only in conjunction with the Asm and Asm_Volatile subprograms
+      --  in package Machine_Code to construct machine instructions. See
+      --  documentation in package Machine_Code in file s-maccod.ads.
+
+      ----------------
+      -- Asm_Output --
+      ----------------
+
+      Attribute_Asm_Output => True,
+      --
+      --  Used only in conjunction with the Asm and Asm_Volatile subprograms
+      --  in package Machine_Code to construct machine instructions. See
+      --  documentation in package Machine_Code in file s-maccod.ads.
+
+      ---------------
+      -- AST_Entry --
+      ---------------
+
+      Attribute_AST_Entry => True,
+      --
+      --  E'Ast_Entry, where E is a task entry, yields a value of the
+      --  predefined type System.DEC.AST_Handler, that enables the given
+      --  entry to be called when an AST occurs. If the name to which the
+      --  attribute applies has not been specified with the pragma AST_Entry,
+      --  the attribute returns the value No_Ast_Handler, and no AST occurs.
+      --  If the entry is for a task that is not callable (T'Callable False),
+      --  the exception program error is raised. If an AST occurs for an
+      --  entry of a task that is terminated, the program is erroneous.
+      --
+      --  The attribute AST_Entry is supported only in OpenVMS versions
+      --  of GNAT. It will be rejected as illegal in other GNAT versions.
+
+      ---------
+      -- Bit --
+      ---------
+
+      Attribute_Bit => True,
+      --
+      --  Obj'Bit, where Obj is any object, yields the bit offset within
+      --  the storage unit (byte) that contains the first bit of storage
+      --  allocated for the object. The value of this attribute is of the
+      --  type Universal_Integer, and is always a non-negative number not
+      --  exceeding the value of System.Storage_Unit.
+      --
+      --  For an object that is a variable or a constant allocated in a
+      --  register, the value is zero. (The use of this attribute does not
+      --  force the allocation of a variable to memory).
+      --
+      --  For an object that is a formal parameter, this attribute applies
+      --  to either the matching actual parameter or to a copy of the
+      --  matching actual parameter.
+      --
+      --  For an access object the value is zero. Note that Obj.all'Bit is
+      --  subject to an Access_Check for the designated object. Similarly
+      --  for a record component X.C'Bit is subject to a discriminant check
+      --  and X(I).Bit and X(I1..I2)'Bit are subject to index checks.
+      --
+      --  This attribute is designed to be compatible with the DEC Ada
+      --  definition and implementation of the Bit attribute.
+
+      ------------------
+      -- Code_Address --
+      ------------------
+
+      Attribute_Code_Address => True,
+      --
+      --  subp'Code_Address, where subp is a subprogram entity, gives the
+      --  address of the first generated instruction for a subprogram. This
+      --  is often, but not always the same as the 'Address value, which is
+      --  the address to be used in a call. The differences occur in the case
+      --  of a nested procedure (where Address yields the address of the
+      --  trampoline code used to load the static link), and on some systems
+      --  which use procedure descriptors (in which case Address yields the
+      --  address of the descriptor).
+
+      -----------------------
+      -- Default_Bit_Order --
+      -----------------------
+
+      Attribute_Default_Bit_Order => True,
+      --
+      --  Standard'Default_Bit_Order (Standard is the only permissible prefix),
+      --  provides the value System.Default_Bit_Order as a Pos value (0 for
+      --  High_Order_First, 1 for Low_Order_First). This is used to construct
+      --  the definition of Default_Bit_Order in package System. This is a
+      --  static attribute.
+
+      ---------------
+      -- Elab_Body --
+      ---------------
+
+      Attribute_Elab_Body => True,
+      --
+      --  This attribute can only be applied to a program unit name. It
+      --  returns the entity for the corresponding elaboration procedure
+      --  for elaborating the body of the referenced unit. This is used
+      --  in the main generated elaboration procedure by the binder, and
+      --  is not normally used in any other context, but there may be
+      --  specialized situations in which it is useful to be able to
+      --  call this elaboration procedure from Ada code, e.g. if it
+      --  is necessary to do selective reelaboration to fix some error.
+
+      ---------------
+      -- Elab_Spec --
+      ---------------
+
+      Attribute_Elab_Spec => True,
+      --
+      --  This attribute can only be applied to a program unit name. It
+      --  returns the entity for the corresponding elaboration procedure
+      --  for elaborating the spec of the referenced unit. This is used
+      --  in the main generated elaboration procedure by the binder, and
+      --  is not normally used in any other context, but there may be
+      --  specialized situations in which it is useful to be able to
+      --  call this elaboration procedure from Ada code, e.g. if it
+      --  is necessary to do selective reelaboration to fix some error.
+
+      ----------------
+      -- Elaborated --
+      ----------------
+
+      Attribute_Elaborated => True,
+      --
+      --  Lunit'Elaborated, where Lunit is a library unit, yields a boolean
+      --  value indicating whether or not the body of the designated library
+      --  unit has been elaborated yet.
+
+
+      --------------
+      -- Enum_Rep --
+      --------------
+
+      Attribute_Enum_Rep => True,
+      --
+      --  For every enumeration subtype S, S'Enum_Rep denotes a function
+      --  with the following specification:
+      --
+      --    function S'Enum_Rep (Arg : S'Base) return universal_integer;
+      --
+      --  The function returns the representation value for the given
+      --  enumeration value. This will be equal to the 'Pos value in the
+      --  absence of an enumeration representation clause. This is a static
+      --  attribute (i.e. the result is static if the argument is static).
+
+      -----------------
+      -- Fixed_Value --
+      -----------------
+
+      Attribute_Fixed_Value => True,
+      --
+      --  For every fixed-point type S, S'Fixed_Value denotes a function
+      --  with the following specification:
+      --
+      --    function S'Fixed_Value (Arg : universal_integer) return S;
+      --
+      --  The value returned is the fixed-point value V such that
+      --
+      --    V = Arg * S'Small
+      --
+      --  The effect is thus equivalent to first converting the argument
+      --  to the integer type used to represent S, and then doing an
+      --  unchecked conversion to the fixed-point type. This attribute is
+      --  primarily intended for use in implementation of the input-output
+      --  functions for fixed-point values.
+
+      -----------------------
+      -- Has_Discriminants --
+      -----------------------
+
+      Attribute_Has_Discriminants => True,
+      --
+      --  Gtyp'Has_Discriminants, where Gtyp is a generic formal type, yields
+      --  a Boolean value indicating whether or not the actual instantiation
+      --  type has discriminants.
+
+      ---------
+      -- Img --
+      ---------
+
+      Attribute_Img => True,
+      --
+      --  The 'Img function is defined for any prefix, P, that denotes an
+      --  object of scalar type T. P'Img is equivalent to T'Image (P). This
+      --  is convenient for debugging. For example:
+      --
+      --     Put_Line ("X = " & X'Img);
+      --
+      --  has the same meaning as the more verbose:
+      --
+      --     Put_Line ("X = " & Temperature_Type'Image (X));
+      --
+      --  where Temperature_Type is the subtype of the object X.
+
+      -------------------
+      -- Integer_Value --
+      -------------------
+
+      Attribute_Integer_Value => True,
+      --
+      --  For every integer type S, S'Integer_Value denotes a function
+      --  with the following specification:
+      --
+      --    function S'Integer_Value (Arg : universal_fixed) return S;
+      --
+      --  The value returned is the integer value V, such that
+      --
+      --    Arg = V * fixed-type'Small
+      --
+      --  The effect is thus equivalent to first doing an unchecked convert
+      --  from the fixed-point type to its corresponding implementation type,
+      --  and then converting the result to the target integer type. This
+      --  attribute is primarily intended for use in implementation of the
+      --  standard input-output functions for fixed-point values.
+
+      ------------------
+      -- Machine_Size --
+      ------------------
+
+      Attribute_Machine_Size => True,
+      --
+      --  This attribute is identical to the Object_Size attribute. It is
+      --  provided for compatibility with the DEC attribute of this name.
+
+      ----------------------------
+      -- Max_Interrupt_Priority --
+      ----------------------------
+
+      Attribute_Max_Interrupt_Priority => True,
+      --
+      --  Standard'Max_Interrupt_Priority (Standard is the only permissible
+      --  prefix), provides the value System.Max_Interrupt_Priority, and is
+      --  intended primarily for constructing this definition in package
+      --  System (see note above in Default_Bit_Order description}. This
+      --  is a static attribute.
+
+      ------------------
+      -- Max_Priority --
+      ------------------
+
+      Attribute_Max_Priority => True,
+      --
+      --  Standard'Max_Priority (Standard is the only permissible prefix)
+      --  provides the value System.Max_Priority, and is intended primarily
+      --  for constructing this definition in package System (see note above
+      --  in Default_Bit_Order description). This is a static attribute.
+
+      -----------------------
+      -- Maximum_Alignment --
+      -----------------------
+
+      Attribute_Maximum_Alignment => True,
+      --
+      --  Standard'Maximum_Alignment (Standard is the only permissible prefix)
+      --  provides the maximum useful alignment value for the target. This
+      --  is a static value that can be used to specify the alignment for an
+      --  object, guaranteeing that it is properly aligned in all cases. The
+      --  time this is useful is when an external object is imported and its
+      --  alignment requirements are unknown. This is a static attribute.
+
+      --------------------
+      -- Mechanism_Code --
+      --------------------
+
+      Attribute_Mechanism_Code => True,
+      --
+      --  function'Mechanism_Code yeilds an integer code for the mechanism
+      --  used for the result of function, and subprogram'Mechanism_Code (n)
+      --  yields the mechanism used for formal parameter number n (a static
+      --  integer value, 1 = first parameter). The code returned is:
+      --
+      --     1 = by copy (value)
+      --     2 = by reference
+      --     3 = by descriptor (default descriptor type)
+      --     4 = by descriptor (UBS  unaligned bit string)
+      --     5 = by descriptor (UBSB aligned bit string with arbitrary bounds)
+      --     6 = by descriptor (UBA  unaligned bit array)
+      --     7 = by descriptor (S    string, also scalar access type parameter)
+      --     8 = by descriptor (SB   string with arbitrary bounds)
+      --     9 = by descriptor (A    contiguous array)
+      --    10 = by descriptor (NCA  non-contiguous array)
+
+      --------------------
+      -- Null_Parameter --
+      --------------------
+
+      Attribute_Null_Parameter => True,
+      --
+      --  A reference T'Null_Parameter denotes an (imaginary) object of
+      --  type or subtype T allocated at (machine) address zero. The
+      --  attribute is allowed only as the default expression of a formal
+      --  parameter, or as an actual expression of a subporgram call. In
+      --  either case, the subprogram must be imported.
+      --
+      --  The identity of the object is represented by the address zero
+      --  in the argument list, independent of the passing mechanism
+      --  (explicit or default).
+      --
+      --  The reason that this capability is needed is that for a record
+      --  or other composite object passed by reference, there is no other
+      --  way of specifying that a zero address should be passed.
+
+      -----------------
+      -- Object_Size --
+      -----------------
+
+      Attribute_Object_Size => True,
+      --
+      --  Type'Object_Size is the same as Type'Size for all types except
+      --  fixed-point types and discrete types. For fixed-point types and
+      --  discrete types, this attribute gives the size used for default
+      --  allocation of objects and components of the size. See section
+      --  in Einfo ("Handling of type'Size values") for further details.
+
+      -------------------------
+      -- Passed_By_Reference --
+      -------------------------
+
+      Attribute_Passed_By_Reference => True,
+      --
+      --  T'Passed_By_Reference for any subtype T returns a boolean value
+      --  that is true if the type is normally passed by reference and
+      --  false if the type is normally passed by copy in calls. For scalar
+      --  types, the result is always False and is static. For non-scalar
+      --  types, the result is non-static (since it is computed by Gigi).
+
+      ------------------
+      -- Range_Length --
+      ------------------
+
+      Attribute_Range_Length => True,
+      --
+      --  T'Range_Length for any discrete type T yields the number of
+      --  values represented by the subtype (zero for a null range). The
+      --  result is static for static subtypes. Note that Range_Length
+      --  applied to the index subtype of a one dimensional array always
+      --  gives the same result as Range applied to the array itself.
+      --  The result is of type universal integer.
+
+      ------------------
+      -- Storage_Unit --
+      ------------------
+
+      Attribute_Storage_Unit => True,
+      --
+      --  Standard'Storage_Unit (Standard is the only permissible prefix)
+      --  provides the value System.Storage_Unit, and is intended primarily
+      --  for constructing this definition in package System (see note above
+      --  in Default_Bit_Order description). The is a static attribute.
+
+      ----------
+      -- Tick --
+      ----------
+
+      Attribute_Tick => True,
+      --
+      --  Standard'Tick (Standard is the only permissible prefix) provides
+      --  the value System.Tick, and is intended primarily for constructing
+      --  this definition in package System (see note above in description
+      --  of Default_Bit_Order). This is a static attribute.
+
+      ----------------
+      -- To_Address --
+      ----------------
+
+      Attribute_To_Address => True,
+      --
+      --  System'To_Address (Address is the only permissible prefix)
+      --  is a function that takes any integer value, and converts it into
+      --  an address value. The semantics is to first convert the integer
+      --  value to type Integer_Address according to normal conversion
+      --  rules, and then to convert this to an address using the same
+      --  semantics as the System.Storage_Elements.To_Address function.
+      --  The important difference is that this is a static attribute
+      --  so it can be used in initializations in preealborate packages.
+
+      ----------------
+      -- Type_Class --
+      ----------------
+
+      Attribute_Type_Class => True,
+      --
+      --  T'Type_Class for any type or subtype T yields the value of the
+      --  type class for the full type of T. If T is a generic formal type,
+      --  then the value is the value for the corresponding actual subtype.
+      --  The value of this attribute is of type System.Aux_DEC.Type_Class,
+      --  which has the following definition:
+      --
+      --    type Type_Class is
+      --      (Type_Class_Enumeration,
+      --       Type_Class_Integer,
+      --       Type_Class_Fixed_Point,
+      --       Type_Class_Floating_Point,
+      --       Type_Class_Array,
+      --       Type_Class_Record,
+      --       Type_Class_Access,
+      --       Type_Class_Task,
+      --       Type_Class_Address);
+      --
+      --  Protected types yield the value Type_Class_Task, which thus
+      --  applies to all concurrent types. This attribute is designed to
+      --  be compatible with the DEC Ada attribute of the same name.
+      --
+      --  Note: if pragma Extend_System is used to merge the definitions of
+      --  Aux_DEC into System, then the type Type_Class can be referenced
+      --  as an entity within System, as can its enumeration literals.
+
+      -----------------
+      -- UET_Address --
+      -----------------
+
+      Attribute_UET_Address => True,
+      --
+      --  Unit'UET_Address, where Unit is a program unit, yields the address
+      --  of the unit exception table for the specified unit. This is only
+      --  used in the internal implementation of exception handling. See the
+      --  implementation of unit Ada.Exceptions for details on its use.
+
+      ------------------------------
+      -- Universal_Literal_String --
+      ------------------------------
+
+      Attribute_Universal_Literal_String => True,
+      --
+      --  The prefix of 'Universal_Literal_String must be a named number.
+      --  The static result is the string consisting of the characters of
+      --  the number as defined in the original source. This allows the
+      --  user program to access the actual text of named numbers without
+      --  intermediate conversions and without the need to enclose the
+      --  strings in quotes (which would preclude their use as numbers).
+      --  This is used internally for the construction of values of the
+      --  floating-point attributes from the file ttypef.ads, but may
+      --  also be used by user programs.
+
+      -------------------------
+      -- Unrestricted_Access --
+      -------------------------
+
+      Attribute_Unrestricted_Access => True,
+      --
+      --  The Unrestricted_Access attribute is similar to Access except that
+      --  all accessibility and aliased view checks are omitted. This is very
+      --  much a user-beware attribute. Basically its status is very similar
+      --  to Address, for which it is a desirable replacement where the value
+      --  desired is an access type. In other words, its effect is identical
+      --  to first taking 'Address and then doing an unchecked conversion to
+      --  a desired access type. Note that in GNAT, but not necessarily in
+      --  other implementations, the use of static chains for inner level
+      --  subprograms means that Unrestricted_Access applied to a subprogram
+      --  yields a value that can be called as long as the subprogram is in
+      --  scope (normal Ada 95 accessibility rules restrict this usage).
+
+      ---------------
+      -- VADS_Size --
+      ---------------
+
+      Attribute_VADS_Size => True,
+      --
+      --  Typ'VADS_Size yields the Size value typically yielded by some
+      --  Ada 83 compilers. The differences between VADS_Size and Size
+      --  is that for scalar types for which no Size has been specified,
+      --  VADS_Size yields the Object_Size rather than the Value_Size.
+      --  For example, while Natural'Size is typically 31, the value of
+      --  Natural'VADS_Size is 32. For all other types, Size and VADS_Size
+      --  yield the same value.
+
+      ----------------
+      -- Value_Size --
+      ----------------
+
+      Attribute_Value_Size => True,
+      --
+      --  Type'Value_Size is the number of bits required to represent a
+      --  value of the given subtype. It is the same as Type'Size, but,
+      --  unlike Size, may be set for non-first subtypes. See section
+      --  in Einfo ("Handling of type'Size values") for further details.
+
+      ---------------
+      -- Word_Size --
+      ---------------
+
+      Attribute_Word_Size => True,
+      --
+      --  Standard'Word_Size (Standard is the only permissible prefix)
+      --  provides the value System.Word_Size, and is intended primarily
+      --  for constructing this definition in package System (see note above
+      --  in Default_Bit_Order description). This is a static attribute.
+
+      others => False);
+
+   -----------------
+   -- Subprograms --
+   -----------------
+
+   procedure Analyze_Attribute (N : Node_Id);
+   --  Performs bottom up semantic analysis of an attribute. Note that the
+   --  parser has already checked that type returning attributes appear only
+   --  in appropriate contexts (i.e. in subtype marks, or as prefixes for
+   --  other attributes).
+
+   procedure Resolve_Attribute (N : Node_Id; Typ : Entity_Id);
+   --  Performs type resolution of attribute. If the attribute yields
+   --  a universal value, mark its type as that of the context. On
+   --  the other hand, if the context itself is universal (as in
+   --  T'Val (T'Pos (X)), mark the type as being the largest type of
+   --  that class that can be used at run-time. This is correct since
+   --  either the value gets folded (in which case it doesn't matter
+   --  what type of the class we give if, since the folding uses universal
+   --  arithmetic anyway) or it doesn't get folded (in which case it is
+   --  going to be dealt with at runtime, and the largest type is right).
+
+end Sem_Attr;
diff --git a/gcc/ada/sem_case.adb b/gcc/ada/sem_case.adb
new file mode 100644
index 00000000000..a9326c36384
--- /dev/null
+++ b/gcc/ada/sem_case.adb
@@ -0,0 +1,681 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             S E M _ C A S E                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.13 $
+--                                                                          --
+--          Copyright (C) 1996-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 Einfo;    use Einfo;
+with Errout;   use Errout;
+with Namet;    use Namet;
+with Nlists;   use Nlists;
+with Sem;      use Sem;
+with Sem_Eval; use Sem_Eval;
+with Sem_Res;  use Sem_Res;
+with Sem_Util; use Sem_Util;
+with Sem_Type; use Sem_Type;
+with Snames;   use Snames;
+with Stand;    use Stand;
+with Sinfo;    use Sinfo;
+with Uintp;    use Uintp;
+
+with GNAT.Heap_Sort_A; use GNAT.Heap_Sort_A;
+
+package body Sem_Case is
+
+   -----------------------
+   -- Local Subprograms --
+   -----------------------
+
+   type Sort_Choice_Table_Type is array (Nat range <>) of Choice_Bounds;
+   --  This new array type is used as the actual table type for sorting
+   --  discrete choices. The reason for not using Choice_Table_Type, is that
+   --  in Sort_Choice_Table_Type we reserve entry 0 for the sorting algortim
+   --  (this is not absolutely necessary but it makes the code more
+   --  efficient).
+
+   procedure Check_Choices
+     (Choice_Table   : in out Sort_Choice_Table_Type;
+      Bounds_Type    : Entity_Id;
+      Others_Present : Boolean;
+      Msg_Sloc       : Source_Ptr);
+   --  This is the procedure which verifies that a set of case statement,
+   --  array aggregate or record variant choices has no duplicates, and
+   --  covers the range specified by Bounds_Type. Choice_Table contains the
+   --  discrete choices to check. These must start at position 1.
+   --  Furthermore Choice_Table (0) must exist. This element is used by
+   --  the sorting algorithm as a temporary. Others_Present is a flag
+   --  indicating whether or not an Others choice is present. Finally
+   --  Msg_Sloc gives the source location of the construct containing the
+   --  choices in the Choice_Table.
+
+   function Choice_Image (Value : Uint; Ctype : Entity_Id) return Name_Id;
+   --  Given a Pos value of enumeration type Ctype, returns the name
+   --  ID of an appropriate string to be used in error message output.
+
+   -------------------
+   -- Check_Choices --
+   -------------------
+
+   procedure Check_Choices
+     (Choice_Table   : in out Sort_Choice_Table_Type;
+      Bounds_Type    : Entity_Id;
+      Others_Present : Boolean;
+      Msg_Sloc       : Source_Ptr)
+   is
+
+      function Lt_Choice (C1, C2 : Natural) return Boolean;
+      --  Comparison routine for comparing Choice_Table entries.
+      --  Use the lower bound of each Choice as the key.
+
+      procedure Move_Choice (From : Natural; To : Natural);
+      --  Move routine for sorting the Choice_Table.
+
+      procedure Issue_Msg (Value1 : Node_Id; Value2 : Node_Id);
+      procedure Issue_Msg (Value1 : Node_Id; Value2 : Uint);
+      procedure Issue_Msg (Value1 : Uint;    Value2 : Node_Id);
+      procedure Issue_Msg (Value1 : Uint;    Value2 : Uint);
+      --  Issue an error message indicating that there are missing choices,
+      --  followed by the image of the missing choices themselves which lie
+      --  between Value1 and Value2 inclusive.
+
+      ---------------
+      -- Issue_Msg --
+      ---------------
+
+      procedure Issue_Msg (Value1 : Node_Id; Value2 : Node_Id) is
+      begin
+         Issue_Msg (Expr_Value (Value1), Expr_Value (Value2));
+      end Issue_Msg;
+
+      procedure Issue_Msg (Value1 : Node_Id; Value2 : Uint) is
+      begin
+         Issue_Msg (Expr_Value (Value1), Value2);
+      end Issue_Msg;
+
+      procedure Issue_Msg (Value1 : Uint; Value2 : Node_Id) is
+      begin
+         Issue_Msg (Value1, Expr_Value (Value2));
+      end Issue_Msg;
+
+      procedure Issue_Msg (Value1 : Uint; Value2 : Uint) is
+      begin
+         --  In some situations, we call this with a null range, and
+         --  obviously we don't want to complain in this case!
+
+         if Value1 > Value2 then
+            return;
+         end if;
+
+         --  Case of only one value that is missing
+
+         if Value1 = Value2 then
+            if Is_Integer_Type (Bounds_Type) then
+               Error_Msg_Uint_1 := Value1;
+               Error_Msg ("missing case value: ^!", Msg_Sloc);
+            else
+               Error_Msg_Name_1 := Choice_Image (Value1, Bounds_Type);
+               Error_Msg ("missing case value: %!", Msg_Sloc);
+            end if;
+
+         --  More than one choice value, so print range of values
+
+         else
+            if Is_Integer_Type (Bounds_Type) then
+               Error_Msg_Uint_1 := Value1;
+               Error_Msg_Uint_2 := Value2;
+               Error_Msg ("missing case values: ^ .. ^!", Msg_Sloc);
+            else
+               Error_Msg_Name_1 := Choice_Image (Value1, Bounds_Type);
+               Error_Msg_Name_2 := Choice_Image (Value2, Bounds_Type);
+               Error_Msg ("missing case values: % .. %!", Msg_Sloc);
+            end if;
+         end if;
+      end Issue_Msg;
+
+      ---------------
+      -- Lt_Choice --
+      ---------------
+
+      function Lt_Choice (C1, C2 : Natural) return Boolean is
+      begin
+         return
+           Expr_Value (Choice_Table (Nat (C1)).Lo)
+           <= Expr_Value (Choice_Table (Nat (C2)).Lo);
+      end Lt_Choice;
+
+      -----------------
+      -- Move_Choice --
+      -----------------
+
+      procedure Move_Choice (From : Natural; To : Natural) is
+      begin
+         Choice_Table (Nat (To)) := Choice_Table (Nat (From));
+      end Move_Choice;
+
+      --  Variables local to Check_Choices
+
+      Choice      : Node_Id;
+      Bounds_Lo   : constant Node_Id := Type_Low_Bound (Bounds_Type);
+      Bounds_Hi   : constant Node_Id := Type_High_Bound (Bounds_Type);
+
+      Prev_Choice : Node_Id;
+
+      Hi       : Uint;
+      Lo       : Uint;
+      Prev_Hi  : Uint;
+
+   --  Start processing for Check_Choices
+
+   begin
+
+      --  Choice_Table must start at 0 which is an unused location used
+      --  by the sorting algorithm. However the first valid position for
+      --  a discrete choice is 1.
+
+      pragma Assert (Choice_Table'First = 0);
+
+      if Choice_Table'Last = 0 then
+         if not Others_Present then
+            Issue_Msg (Bounds_Lo, Bounds_Hi);
+         end if;
+         return;
+      end if;
+
+      Sort
+        (Positive (Choice_Table'Last),
+         Move_Choice'Unrestricted_Access,
+         Lt_Choice'Unrestricted_Access);
+
+      Lo      := Expr_Value (Choice_Table (1).Lo);
+      Hi      := Expr_Value (Choice_Table (1).Hi);
+      Prev_Hi := Hi;
+
+      if not Others_Present and then Expr_Value (Bounds_Lo) < Lo then
+         Issue_Msg (Bounds_Lo, Lo - 1);
+      end if;
+
+      for J in 2 .. Choice_Table'Last loop
+         Lo := Expr_Value (Choice_Table (J).Lo);
+         Hi := Expr_Value (Choice_Table (J).Hi);
+
+         if Lo <= Prev_Hi then
+            Prev_Choice := Choice_Table (J - 1).Node;
+            Choice      := Choice_Table (J).Node;
+
+            if Sloc (Prev_Choice) <= Sloc (Choice) then
+               Error_Msg_Sloc := Sloc (Prev_Choice);
+               Error_Msg_N ("duplication of choice value#", Choice);
+            else
+               Error_Msg_Sloc := Sloc (Choice);
+               Error_Msg_N ("duplication of choice value#", Prev_Choice);
+            end if;
+
+         elsif not Others_Present and then Lo /= Prev_Hi + 1 then
+            Issue_Msg (Prev_Hi + 1, Lo - 1);
+         end if;
+
+         Prev_Hi := Hi;
+      end loop;
+
+      if not Others_Present and then Expr_Value (Bounds_Hi) > Hi then
+         Issue_Msg (Hi + 1, Bounds_Hi);
+      end if;
+   end Check_Choices;
+
+   ------------------
+   -- Choice_Image --
+   ------------------
+
+   function Choice_Image (Value : Uint; Ctype : Entity_Id) return Name_Id is
+      Rtp : constant Entity_Id := Root_Type (Ctype);
+      Lit : Entity_Id;
+      C   : Int;
+
+   begin
+      --  For character, or wide character. If we are in 7-bit ASCII graphic
+      --  range, then build and return appropriate character literal name
+
+      if Rtp = Standard_Character
+        or else Rtp = Standard_Wide_Character
+      then
+         C := UI_To_Int (Value);
+
+         if C in 16#20# .. 16#7E# then
+            Name_Buffer (1) := ''';
+            Name_Buffer (2) := Character'Val (C);
+            Name_Buffer (3) := ''';
+            Name_Len := 3;
+            return Name_Find;
+         end if;
+
+      --  For user defined enumeration type, find enum/char literal
+
+      else
+         Lit := First_Literal (Rtp);
+
+         for J in 1 .. UI_To_Int (Value) loop
+            Next_Literal (Lit);
+         end loop;
+
+         --  If enumeration literal, just return its value
+
+         if Nkind (Lit) = N_Defining_Identifier then
+            return Chars (Lit);
+
+         --  For character literal, get the name and use it if it is
+         --  for a 7-bit ASCII graphic character in 16#20#..16#7E#.
+
+         else
+            Get_Decoded_Name_String (Chars (Lit));
+
+            if Name_Len = 3
+              and then Name_Buffer (2) in
+                Character'Val (16#20#) .. Character'Val (16#7E#)
+            then
+               return Chars (Lit);
+            end if;
+         end if;
+      end if;
+
+      --  If we fall through, we have a character literal which is not in
+      --  the 7-bit ASCII graphic set. For such cases, we construct the
+      --  name "type'val(nnn)" where type is the choice type, and nnn is
+      --  the pos value passed as an argument to Choice_Image.
+
+      Get_Name_String (Chars (First_Subtype (Ctype)));
+      Name_Len := Name_Len + 1;
+      Name_Buffer (Name_Len) := ''';
+      Name_Len := Name_Len + 1;
+      Name_Buffer (Name_Len) := 'v';
+      Name_Len := Name_Len + 1;
+      Name_Buffer (Name_Len) := 'a';
+      Name_Len := Name_Len + 1;
+      Name_Buffer (Name_Len) := 'l';
+      Name_Len := Name_Len + 1;
+      Name_Buffer (Name_Len) := '(';
+
+      UI_Image (Value);
+
+      for J in 1 .. UI_Image_Length loop
+         Name_Len := Name_Len + 1;
+         Name_Buffer (Name_Len) := UI_Image_Buffer (J);
+      end loop;
+
+      Name_Len := Name_Len + 1;
+      Name_Buffer (Name_Len) := ')';
+      return Name_Find;
+   end Choice_Image;
+
+   -----------
+   -- No_OP --
+   -----------
+
+   procedure No_OP (C : Node_Id) is
+   begin
+      null;
+   end No_OP;
+
+   --------------------------------
+   -- Generic_Choices_Processing --
+   --------------------------------
+
+   package body Generic_Choices_Processing is
+
+      ---------------------
+      -- Analyze_Choices --
+      ---------------------
+
+      procedure Analyze_Choices
+        (N              : Node_Id;
+         Subtyp         : Entity_Id;
+         Choice_Table   : in out Choice_Table_Type;
+         Last_Choice    : out Nat;
+         Raises_CE      : out Boolean;
+         Others_Present : out Boolean)
+      is
+
+         Nb_Choices        : constant Nat := Choice_Table'Length;
+         Sort_Choice_Table : Sort_Choice_Table_Type (0 .. Nb_Choices);
+
+         Choice_Type : constant Entity_Id := Base_Type (Subtyp);
+         --  The actual type against which the discrete choices are
+         --  resolved.  Note that this type is always the base type not the
+         --  subtype of the ruling expression, index or discriminant.
+
+         Bounds_Type : Entity_Id;
+         --  The type from which are derived the bounds of the values
+         --  covered by th discrete choices (see 3.8.1 (4)). If a discrete
+         --  choice specifies a value outside of these bounds we have an error.
+
+         Bounds_Lo   : Uint;
+         Bounds_Hi   : Uint;
+         --  The actual bounds of the above type.
+
+         Expected_Type : Entity_Id;
+         --  The expected type of each choice. Equal to Choice_Type, except
+         --  if the expression is universal,  in which case the choices can
+         --  be of any integer type.
+
+         procedure Check (Choice : Node_Id; Lo, Hi : Node_Id);
+         --  Checks the validity of the bounds of a choice.  When the bounds
+         --  are static and no error occurred the bounds are entered into
+         --  the choices table so that they can be sorted later on.
+
+         -----------
+         -- Check --
+         -----------
+
+         procedure Check (Choice : Node_Id; Lo, Hi : Node_Id) is
+            Lo_Val : Uint;
+            Hi_Val : Uint;
+
+         begin
+            --  First check if an error was already detected on either bounds
+
+            if Etype (Lo) = Any_Type or else Etype (Hi) = Any_Type then
+               return;
+
+            --  Do not insert non static choices in the table to be sorted
+
+            elsif not Is_Static_Expression (Lo)
+              or else not Is_Static_Expression (Hi)
+            then
+               Process_Non_Static_Choice (Choice);
+               return;
+
+            --  Ignore range which raise constraint error
+
+            elsif Raises_Constraint_Error (Lo)
+              or else Raises_Constraint_Error (Hi)
+            then
+               Raises_CE := True;
+               return;
+
+            --  Otherwise we have an OK static choice
+
+            else
+               Lo_Val := Expr_Value (Lo);
+               Hi_Val := Expr_Value (Hi);
+
+               --  Do not insert null ranges in the choices table
+
+               if Lo_Val > Hi_Val then
+                  Process_Empty_Choice (Choice);
+                  return;
+               end if;
+            end if;
+
+            --  Check for bound out of range.
+
+            if Lo_Val < Bounds_Lo then
+               if Is_Integer_Type (Bounds_Type) then
+                  Error_Msg_Uint_1 := Bounds_Lo;
+                  Error_Msg_N ("minimum allowed choice value is^", Lo);
+               else
+                  Error_Msg_Name_1 := Choice_Image (Bounds_Lo, Bounds_Type);
+                  Error_Msg_N ("minimum allowed choice value is%", Lo);
+               end if;
+
+            elsif Hi_Val > Bounds_Hi then
+               if Is_Integer_Type (Bounds_Type) then
+                  Error_Msg_Uint_1 := Bounds_Hi;
+                  Error_Msg_N ("maximum allowed choice value is^", Hi);
+               else
+                  Error_Msg_Name_1 := Choice_Image (Bounds_Hi, Bounds_Type);
+                  Error_Msg_N ("maximum allowed choice value is%", Hi);
+               end if;
+            end if;
+
+            --  We still store the bounds in the table, even if they are out
+            --  of range, since this may prevent unnecessary cascaded errors
+            --  for values that are covered by such an excessive range.
+
+            Last_Choice := Last_Choice + 1;
+            Sort_Choice_Table (Last_Choice).Lo   := Lo;
+            Sort_Choice_Table (Last_Choice).Hi   := Hi;
+            Sort_Choice_Table (Last_Choice).Node := Choice;
+         end Check;
+
+         --  Variables local to Analyze_Choices
+
+         Alt : Node_Id;
+         --  A case statement alternative, an array aggregate component
+         --  association or a variant in a record type declaration
+
+         Choice : Node_Id;
+         Kind   : Node_Kind;
+         --  The node kind of the current Choice.
+
+         E : Entity_Id;
+
+      --  Start of processing for Analyze_Choices
+
+      begin
+         Last_Choice    := 0;
+         Raises_CE      := False;
+         Others_Present := False;
+
+         --  If Subtyp is not a static subtype Ada 95 requires then we use
+         --  the bounds of its base type to determine the values covered by
+         --  the discrete choices.
+
+         if Is_OK_Static_Subtype (Subtyp) then
+            Bounds_Type := Subtyp;
+         else
+            Bounds_Type := Choice_Type;
+         end if;
+
+         --  Obtain static bounds of type, unless this is a generic formal
+         --  discrete type for which all choices will be non-static.
+
+         if not Is_Generic_Type (Root_Type (Bounds_Type))
+           or else Ekind (Bounds_Type) /= E_Enumeration_Type
+         then
+            Bounds_Lo := Expr_Value (Type_Low_Bound (Bounds_Type));
+            Bounds_Hi := Expr_Value (Type_High_Bound (Bounds_Type));
+         end if;
+
+         if Choice_Type = Universal_Integer then
+            Expected_Type := Any_Integer;
+         else
+            Expected_Type := Choice_Type;
+         end if;
+
+         --  Now loop through the case statement alternatives or array
+         --  aggregate component associations or record variants.
+
+         Alt := First (Get_Alternatives (N));
+         while Present (Alt) loop
+
+            --  If pragma, just analyze it
+
+            if Nkind (Alt) = N_Pragma then
+               Analyze (Alt);
+
+            --  Otherwise check each choice against its base type
+
+            else
+               Choice := First (Get_Choices (Alt));
+
+               while Present (Choice) loop
+                  Analyze (Choice);
+                  Kind := Nkind (Choice);
+
+                  --  Choice is a Range
+
+                  if Kind = N_Range
+                    or else (Kind = N_Attribute_Reference
+                             and then Attribute_Name (Choice) = Name_Range)
+                  then
+                     Resolve (Choice, Expected_Type);
+                     Check (Choice, Low_Bound (Choice), High_Bound (Choice));
+
+                  --  Choice is a subtype name
+
+                  elsif Is_Entity_Name (Choice)
+                    and then Is_Type (Entity (Choice))
+                  then
+                     if not Covers (Expected_Type, Etype (Choice)) then
+                        Wrong_Type (Choice, Choice_Type);
+
+                     else
+                        E := Entity (Choice);
+
+                        if not Is_Static_Subtype (E) then
+                           Process_Non_Static_Choice (Choice);
+                        else
+                           Check
+                             (Choice, Type_Low_Bound (E), Type_High_Bound (E));
+                        end if;
+                     end if;
+
+                  --  Choice is a subtype indication
+
+                  elsif Kind = N_Subtype_Indication then
+                     Resolve_Discrete_Subtype_Indication
+                       (Choice, Expected_Type);
+
+                     if Etype (Choice) /= Any_Type then
+                        declare
+                           C : constant Node_Id := Constraint (Choice);
+                           R : constant Node_Id := Range_Expression (C);
+                           L : constant Node_Id := Low_Bound (R);
+                           H : constant Node_Id := High_Bound (R);
+
+                        begin
+                           E := Entity (Subtype_Mark (Choice));
+
+                           if not Is_Static_Subtype (E) then
+                              Process_Non_Static_Choice (Choice);
+
+                           else
+                              if Is_OK_Static_Expression (L)
+                                and then Is_OK_Static_Expression (H)
+                              then
+                                 if Expr_Value (L) > Expr_Value (H) then
+                                    Process_Empty_Choice (Choice);
+                                 else
+                                    if Is_Out_Of_Range (L, E) then
+                                       Apply_Compile_Time_Constraint_Error
+                                         (L, "static value out of range");
+                                    end if;
+
+                                    if Is_Out_Of_Range (H, E) then
+                                       Apply_Compile_Time_Constraint_Error
+                                         (H, "static value out of range");
+                                    end if;
+                                 end if;
+                              end if;
+
+                              Check (Choice, L, H);
+                           end if;
+                        end;
+                     end if;
+
+                  --  The others choice is only allowed for the last
+                  --  alternative and as its only choice.
+
+                  elsif Kind = N_Others_Choice then
+                     if not (Choice = First (Get_Choices (Alt))
+                             and then Choice = Last (Get_Choices (Alt))
+                             and then Alt = Last (Get_Alternatives (N)))
+                     then
+                        Error_Msg_N
+                          ("the choice OTHERS must appear alone and last",
+                           Choice);
+                        return;
+                     end if;
+
+                     Others_Present := True;
+
+                  --  Only other possibility is an expression
+
+                  else
+                     Resolve (Choice, Expected_Type);
+                     Check (Choice, Choice, Choice);
+                  end if;
+
+                  Next (Choice);
+               end loop;
+
+               Process_Associated_Node (Alt);
+            end if;
+
+            Next (Alt);
+         end loop;
+
+         Check_Choices
+           (Sort_Choice_Table (0 .. Last_Choice),
+            Bounds_Type,
+            Others_Present or else (Choice_Type = Universal_Integer),
+            Sloc (N));
+
+         --  Now copy the sorted discrete choices
+
+         for J in 1 .. Last_Choice loop
+            Choice_Table (Choice_Table'First - 1 + J) := Sort_Choice_Table (J);
+         end loop;
+
+      end Analyze_Choices;
+
+      -----------------------
+      -- Number_Of_Choices --
+      -----------------------
+
+      function Number_Of_Choices (N : Node_Id) return Nat is
+         Alt : Node_Id;
+         --  A case statement alternative, an array aggregate component
+         --  association or a record variant.
+
+         Choice : Node_Id;
+         Count  : Nat := 0;
+
+      begin
+         if not Present (Get_Alternatives (N)) then
+            return 0;
+         end if;
+
+         Alt := First_Non_Pragma (Get_Alternatives (N));
+         while Present (Alt) loop
+
+            Choice := First (Get_Choices (Alt));
+            while Present (Choice) loop
+               if Nkind (Choice) /= N_Others_Choice then
+                  Count := Count + 1;
+               end if;
+
+               Next (Choice);
+            end loop;
+
+            Next_Non_Pragma (Alt);
+         end loop;
+
+         return Count;
+      end Number_Of_Choices;
+
+   end Generic_Choices_Processing;
+
+end Sem_Case;
diff --git a/gcc/ada/sem_case.ads b/gcc/ada/sem_case.ads
new file mode 100644
index 00000000000..192b6b1573f
--- /dev/null
+++ b/gcc/ada/sem_case.ads
@@ -0,0 +1,122 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             S E M _ C A S E                              --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.5 $                              --
+--                                                                          --
+--            Copyright (C) 1996 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 containing all the routines to proces a list of discrete choices.
+--  Such lists can occur in 3 different constructs: case statements, array
+--  aggregates and record variants. We have factorized what used to be 3 very
+--  similar sets of routines here. If you didn't figure it out already Choi
+--  in the package name stands for Choices.
+
+package Sem_Case is
+
+   type Choice_Bounds is record
+     Lo   : Node_Id;
+     Hi   : Node_Id;
+     Node : Node_Id;
+   end record;
+
+   type Choice_Table_Type is array (Pos range <>) of Choice_Bounds;
+   --  Table type used to sort the choices present in a case statement,
+   --  array aggregate or record variant.
+
+   procedure No_OP (C : Node_Id);
+   --  The no-operation routine. Does absolutely nothing. Can be used
+   --  in the following generic for the parameter Proces_Empty_Choice.
+
+   generic
+      with function Get_Alternatives (N : Node_Id) return List_Id;
+      --  Function needed to get to the actual list of case statement
+      --  alternatives, or array aggregate component associations or
+      --  record variants from which we can then access the actual lists
+      --  of discrete choices. N is the node for the original construct
+      --  ie a case statement, an array aggregate or a record variant.
+
+      with function Get_Choices (A : Node_Id) return List_Id;
+      --  Given a case statement alternative, array aggregate component
+      --  association or record variant A we need different access functions
+      --  to get to the actual list of discrete choices.
+
+      with procedure Process_Empty_Choice (Choice : Node_Id);
+      --  Processing to carry out for an empty Choice.
+
+      with procedure Process_Non_Static_Choice (Choice : Node_Id);
+      --  Processing to carry out for a non static Choice.
+
+      with procedure Process_Associated_Node (A : Node_Id);
+      --  Associated to each case alternative, aggregate component
+      --  association or record variant A there is a node or list of nodes
+      --  that need semantic processing. This routine implements that
+      --  processing.
+
+   package Generic_Choices_Processing is
+
+      function Number_Of_Choices (N : Node_Id) return Nat;
+      --  Iterates through the choices of N, (N can be a case statement,
+      --  array aggregate or record variant), counting all the Choice nodes
+      --  except for the Others choice.
+
+      procedure Analyze_Choices
+        (N              : Node_Id;
+         Subtyp         : Entity_Id;
+         Choice_Table   : in out Choice_Table_Type;
+         Last_Choice    : out Nat;
+         Raises_CE      : out Boolean;
+         Others_Present : out Boolean);
+      --  From a case statement, array aggregate or record variant N, this
+      --  routine analyzes the corresponding list of discrete choices.
+      --  Subtyp is the subtype of the discrete choices. The type against
+      --  which the discrete choices must be resolved is its base type.
+      --
+      --  On entry Choice_Table must be big enough to contain all the
+      --  discrete choices encountered.
+      --
+      --  On exit Choice_Table contains all the static and non empty
+      --  discrete choices in sorted order. Last_Choice gives the position
+      --  of the last valid choice in Choice_Table, Choice_Table'First
+      --  contains the first. We can have Last_Choice < Choice_Table'Last
+      --  for one (or several) of the following reasons:
+      --
+      --    (a) The list of choices contained a non static choice
+      --
+      --    (b) The list of choices contained an empty choice
+      --        (something like "1 .. 0 => ")
+      --
+      --    (c) One of the bounds of a discrete choice contains an
+      --        error or raises constraint error.
+      --
+      --  In one of the bounds of a discrete choice raises a constraint
+      --  error the flag Raise_CE is set.
+      --
+      --  Finally Others_Present is set to True if an Others choice is
+      --  present in the list of choices.
+
+   end Generic_Choices_Processing;
+
+end Sem_Case;
diff --git a/gcc/ada/sem_cat.adb b/gcc/ada/sem_cat.adb
new file mode 100644
index 00000000000..29c48a5f1ab
--- /dev/null
+++ b/gcc/ada/sem_cat.adb
@@ -0,0 +1,1804 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              S E M _ C A T                               --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.57 $
+--                                                                          --
+--          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 Debug;    use Debug;
+with Einfo;    use Einfo;
+with Elists;   use Elists;
+with Errout;   use Errout;
+with Exp_Tss;  use Exp_Tss;
+with Fname;    use Fname;
+with Lib;      use Lib;
+with Nlists;   use Nlists;
+with Sem;      use Sem;
+with Sem_Util; use Sem_Util;
+with Sinfo;    use Sinfo;
+with Snames;   use Snames;
+with Stand;    use Stand;
+
+package body Sem_Cat is
+
+   -----------------------
+   -- Local Subprograms --
+   -----------------------
+
+   procedure Check_Categorization_Dependencies
+     (Unit_Entity     : Entity_Id;
+      Depended_Entity : Entity_Id;
+      Info_Node       : Node_Id;
+      Is_Subunit      : Boolean);
+   --  This procedure checks that the categorization of a lib unit and that
+   --  of the depended unit satisfy dependency restrictions.
+   --  The depended_entity can be the entity in a with_clause item, in which
+   --  case Info_Node denotes that item. The depended_entity can also be the
+   --  parent unit of a child unit, in which case Info_Node is the declaration
+   --  of the child unit.  The error message is posted on Info_Node, and is
+   --  specialized if Is_Subunit is true.
+
+   procedure Check_Non_Static_Default_Expr
+     (Type_Def : Node_Id;
+      Obj_Decl : Node_Id);
+   --  Iterate through the component list of a record definition, check
+   --  that no component is declared with a nonstatic default value.
+   --  If a nonstatic default exists, report an error on Obj_Decl.
+
+   --  Iterate through the component list of a record definition, check
+   --  that no component is declared with a non-static default value.
+
+   function Missing_Read_Write_Attributes (E : Entity_Id) return Boolean;
+   --  Return True if the entity or one of its subcomponent is an access
+   --  type which does not have user-defined Read and Write attribute.
+
+   function In_RCI_Declaration (N : Node_Id) return Boolean;
+   --  Determines if a declaration is  within the visible part of  a Remote
+   --  Call Interface compilation unit, for semantic checking purposes only,
+   --  (returns false within an instance and within the package body).
+
+   function In_RT_Declaration return Boolean;
+   --  Determines if current scope is within a Remote Types compilation unit,
+   --  for semantic checking purposes.
+
+   function Is_Non_Remote_Access_Type (E : Entity_Id) return Boolean;
+   --  Returns true if the entity is a non-remote access type
+
+   function In_Shared_Passive_Unit return Boolean;
+   --  Determines if current scope is within a Shared Passive compilation unit
+
+   function Static_Discriminant_Expr (L : List_Id) return Boolean;
+   --  Iterate through the list of discriminants to check if any of them
+   --  contains non-static default expression, which is a violation in
+   --  a preelaborated library unit.
+
+   procedure Validate_Remote_Access_Object_Type_Declaration (T : Entity_Id);
+   --  Check validity of declaration if RCI unit. It should not contain
+   --  the declaration of an access-to-object type unless it is a
+   --  general access type that designates a class-wide limited
+   --  private type. There are also constraints about the primitive
+   --  subprograms of the class-wide type. RM E.2 (9, 13, 14)
+
+   function Is_Recursively_Limited_Private (E : Entity_Id) return Boolean;
+   --  Return True if E is a limited private type, or if E is a private
+   --  extension of a type whose parent verifies this property (hence the
+   --  recursive keyword).
+
+   ---------------------------------------
+   -- Check_Categorization_Dependencies --
+   ---------------------------------------
+
+   procedure Check_Categorization_Dependencies
+     (Unit_Entity     : Entity_Id;
+      Depended_Entity : Entity_Id;
+      Info_Node       : Node_Id;
+      Is_Subunit      : Boolean)
+   is
+      N                  : Node_Id := Info_Node;
+
+      type Categorization is
+         (Pure, Shared_Passive, Remote_Types,
+           Remote_Call_Interface, Pre_Elaborated, Normal);
+
+      Unit_Category : Categorization;
+      With_Category : Categorization;
+
+      function Get_Categorization (E : Entity_Id) return Categorization;
+      --  Check categorization flags from entity, and return in the form
+      --  of a corresponding enumeration value.
+
+      function Get_Categorization (E : Entity_Id) return Categorization is
+      begin
+         if Is_Preelaborated (E) then
+            return Pre_Elaborated;
+         elsif Is_Pure (E) then
+            return Pure;
+         elsif Is_Shared_Passive (E) then
+            return Shared_Passive;
+         elsif Is_Remote_Types (E) then
+            return Remote_Types;
+         elsif Is_Remote_Call_Interface (E) then
+            return Remote_Call_Interface;
+         else
+            return Normal;
+         end if;
+      end Get_Categorization;
+
+   --  Start of processing for Check_Categorization_Dependencies
+
+   begin
+      --  Intrinsic subprograms are preelaborated, so do not impose any
+      --  categorization dependencies.
+
+      if Is_Intrinsic_Subprogram (Depended_Entity) then
+         return;
+      end if;
+
+      Unit_Category := Get_Categorization (Unit_Entity);
+      With_Category := Get_Categorization (Depended_Entity);
+
+      if With_Category > Unit_Category then
+
+         if (Unit_Category = Remote_Types
+                 or else Unit_Category = Remote_Call_Interface)
+           and then In_Package_Body (Unit_Entity)
+         then
+            null;
+
+         elsif Is_Subunit then
+            Error_Msg_NE ("subunit cannot depend on&"
+              & " (parent has wrong categorization)", N, Depended_Entity);
+         else
+            Error_Msg_NE ("current unit cannot depend on&"
+              & " (wrong categorization)", N, Depended_Entity);
+         end if;
+      end if;
+
+   end Check_Categorization_Dependencies;
+
+   -----------------------------------
+   -- Check_Non_Static_Default_Expr --
+   -----------------------------------
+
+   procedure Check_Non_Static_Default_Expr
+     (Type_Def : Node_Id;
+      Obj_Decl : Node_Id)
+   is
+      Recdef         : Node_Id;
+      Component_Decl : Node_Id;
+
+   begin
+      if Nkind (Type_Def) = N_Derived_Type_Definition then
+         Recdef := Record_Extension_Part (Type_Def);
+
+         if No (Recdef) then
+            return;
+         end if;
+
+      else
+         Recdef := Type_Def;
+      end if;
+
+      --  Check that component declarations do not involve:
+
+      --    a. a non-static default expression, where the object is
+      --       declared to be default initialized.
+
+      --    b. a dynamic Itype (discriminants and constraints)
+
+      if Null_Present (Recdef) then
+         return;
+      else
+         Component_Decl := First (Component_Items (Component_List (Recdef)));
+      end if;
+
+      while Present (Component_Decl)
+        and then Nkind (Component_Decl) = N_Component_Declaration
+      loop
+         if Present (Expression (Component_Decl))
+           and then Nkind (Expression (Component_Decl)) /= N_Null
+           and then not Is_Static_Expression (Expression (Component_Decl))
+         then
+            Error_Msg_Sloc := Sloc (Component_Decl);
+            Error_Msg_N
+              ("object in preelaborated unit has nonstatic default#",
+               Obj_Decl);
+
+         --  Fix this later ???
+
+         --  elsif Has_Dynamic_Itype (Component_Decl) then
+         --     Error_Msg_N
+         --       ("dynamic type discriminant," &
+         --        " constraint in preelaborated unit",
+         --        Component_Decl);
+         end if;
+
+         Next (Component_Decl);
+      end loop;
+   end Check_Non_Static_Default_Expr;
+
+   ---------------------------
+   -- In_Preelaborated_Unit --
+   ---------------------------
+
+   function In_Preelaborated_Unit return Boolean is
+      Unit_Entity : constant Entity_Id := Current_Scope;
+      Unit_Kind   : constant Node_Kind :=
+                      Nkind (Unit (Cunit (Current_Sem_Unit)));
+
+   begin
+      --  There are no constraints on body of remote_call_interface or
+      --  remote_types packages..
+
+      return (Unit_Entity /= Standard_Standard)
+        and then (Is_Preelaborated (Unit_Entity)
+                    or else Is_Pure (Unit_Entity)
+                    or else Is_Shared_Passive (Unit_Entity)
+                    or else
+                      ((Is_Remote_Types (Unit_Entity)
+                               or else Is_Remote_Call_Interface (Unit_Entity))
+                         and then Ekind (Unit_Entity) = E_Package
+                         and then Unit_Kind /= N_Package_Body
+                         and then not In_Package_Body (Unit_Entity)
+                         and then not In_Instance));
+   end In_Preelaborated_Unit;
+
+   ------------------
+   -- In_Pure_Unit --
+   ------------------
+
+   function In_Pure_Unit return Boolean is
+   begin
+      return Is_Pure (Current_Scope);
+   end In_Pure_Unit;
+
+   ------------------------
+   -- In_RCI_Declaration --
+   ------------------------
+
+   function In_RCI_Declaration (N : Node_Id) return Boolean is
+      Unit_Entity : constant Entity_Id := Current_Scope;
+      Unit_Kind   : constant Node_Kind :=
+                      Nkind (Unit (Cunit (Current_Sem_Unit)));
+
+   begin
+      --  There are no restrictions on the private part or body
+      --  of an RCI unit.
+
+      return Is_Remote_Call_Interface (Unit_Entity)
+        and then (Ekind (Unit_Entity) = E_Package
+                  or else Ekind (Unit_Entity) = E_Generic_Package)
+        and then Unit_Kind /= N_Package_Body
+        and then List_Containing (N) =
+                  Visible_Declarations
+                    (Specification (Unit_Declaration_Node (Unit_Entity)))
+        and then not In_Package_Body (Unit_Entity)
+        and then not In_Instance;
+   end In_RCI_Declaration;
+
+   -----------------------
+   -- In_RT_Declaration --
+   -----------------------
+
+   function In_RT_Declaration return Boolean is
+      Unit_Entity : constant Entity_Id := Current_Scope;
+      Unit_Kind   : constant Node_Kind :=
+                      Nkind (Unit (Cunit (Current_Sem_Unit)));
+
+   begin
+      --  There are no restrictions on the body of a Remote Types unit.
+
+      return Is_Remote_Types (Unit_Entity)
+        and then (Ekind (Unit_Entity) = E_Package
+                   or else Ekind (Unit_Entity) = E_Generic_Package)
+        and then Unit_Kind /= N_Package_Body
+        and then not In_Package_Body (Unit_Entity)
+        and then not In_Instance;
+   end In_RT_Declaration;
+
+   ----------------------------
+   -- In_Shared_Passive_Unit --
+   ----------------------------
+
+   function In_Shared_Passive_Unit return Boolean is
+      Unit_Entity : constant Entity_Id := Current_Scope;
+
+   begin
+      return Is_Shared_Passive (Unit_Entity);
+   end In_Shared_Passive_Unit;
+
+   ---------------------------------------
+   -- In_Subprogram_Task_Protected_Unit --
+   ---------------------------------------
+
+   function In_Subprogram_Task_Protected_Unit return Boolean is
+      E : Entity_Id;
+      K : Entity_Kind;
+
+   begin
+      --  The following is to verify that a declaration is inside
+      --  subprogram, generic subprogram, task unit, protected unit.
+      --  Used to validate if a lib. unit is Pure. RM 10.2.1(16).
+
+      --  Use scope chain to check successively outer scopes
+
+      E := Current_Scope;
+      loop
+         K := Ekind (E);
+
+         if        K = E_Procedure
+           or else K = E_Function
+           or else K = E_Generic_Procedure
+           or else K = E_Generic_Function
+           or else K = E_Task_Type
+           or else K = E_Task_Subtype
+           or else K = E_Protected_Type
+           or else K = E_Protected_Subtype
+         then
+            return True;
+
+         elsif E = Standard_Standard then
+            return False;
+         end if;
+
+         E := Scope (E);
+      end loop;
+
+   end In_Subprogram_Task_Protected_Unit;
+
+   -------------------------------
+   -- Is_Non_Remote_Access_Type --
+   -------------------------------
+
+   function Is_Non_Remote_Access_Type (E : Entity_Id) return Boolean is
+   begin
+      return Is_Access_Type (E)
+        and then not Is_Remote_Access_To_Class_Wide_Type (E)
+        and then not Is_Remote_Access_To_Subprogram_Type (E);
+   end Is_Non_Remote_Access_Type;
+
+   ------------------------------------
+   -- Is_Recursively_Limited_Private --
+   ------------------------------------
+
+   function Is_Recursively_Limited_Private (E : Entity_Id) return Boolean is
+      P : constant Node_Id := Parent (E);
+
+   begin
+      if Nkind (P) = N_Private_Type_Declaration
+        and then Is_Limited_Record (E)
+      then
+         return True;
+      elsif Nkind (P) = N_Private_Extension_Declaration then
+         return Is_Recursively_Limited_Private (Etype (E));
+      elsif Nkind (P) = N_Formal_Type_Declaration
+        and then Ekind (E) = E_Record_Type_With_Private
+        and then Is_Generic_Type (E)
+        and then Is_Limited_Record (E)
+      then
+         return True;
+      else
+         return False;
+      end if;
+   end Is_Recursively_Limited_Private;
+
+   ----------------------------------
+   -- Missing_Read_Write_Attribute --
+   ----------------------------------
+
+   function Missing_Read_Write_Attributes (E : Entity_Id) return Boolean is
+      Component      : Entity_Id;
+      Component_Type : Entity_Id;
+
+      function Has_Read_Write_Attributes (E : Entity_Id) return Boolean;
+      --  Return True if entity has Read and Write attributes
+
+      -------------------------------
+      -- Has_Read_Write_Attributes --
+      -------------------------------
+
+      function Has_Read_Write_Attributes (E : Entity_Id) return Boolean is
+         Rep_Item        : Node_Id := First_Rep_Item (E);
+         Read_Attribute  : Boolean := False;
+         Write_Attribute : Boolean := False;
+
+      begin
+         --  We start from the declaration node and then loop until the end
+         --  of the list until we find those two attribute definition clauses.
+
+         while Present (Rep_Item) loop
+            if Chars (Rep_Item) = Name_Read then
+               Read_Attribute := True;
+            elsif Chars (Rep_Item) = Name_Write then
+               Write_Attribute := True;
+            end if;
+
+            if Read_Attribute and Write_Attribute then
+               return True;
+            end if;
+
+            Next_Rep_Item (Rep_Item);
+         end loop;
+
+         return False;
+      end Has_Read_Write_Attributes;
+
+   --  Start of processing for Missing_Read_Write_Attributes
+
+   begin
+      if Has_Read_Write_Attributes (E) then
+         return False;
+      elsif Is_Non_Remote_Access_Type (E) then
+         return True;
+      end if;
+
+      if Is_Record_Type (E) then
+         Component := First_Entity (E);
+         while Present (Component) loop
+            Component_Type := Etype (Component);
+
+            if (Is_Non_Remote_Access_Type (Component_Type)
+                or else Is_Record_Type (Component_Type))
+              and then Missing_Read_Write_Attributes (Component_Type)
+            then
+               return True;
+            end if;
+
+            Next_Entity (Component);
+         end loop;
+      end if;
+
+      return False;
+   end Missing_Read_Write_Attributes;
+
+   -------------------------------------
+   -- Set_Categorization_From_Pragmas --
+   -------------------------------------
+
+   procedure Set_Categorization_From_Pragmas (N : Node_Id) is
+      P   : constant Node_Id := Parent (N);
+      S   : constant Entity_Id := Current_Scope;
+
+      procedure Set_Parents (Visibility : Boolean);
+         --  If this is a child instance, the parents are not immediately
+         --  visible during analysis. Make them momentarily visible so that
+         --  the argument of the pragma can be resolved properly, and reset
+         --  afterwards.
+
+      procedure Set_Parents (Visibility : Boolean) is
+         Par : Entity_Id := Scope (S);
+
+      begin
+         while Present (Par) and then Par /= Standard_Standard loop
+            Set_Is_Immediately_Visible (Par, Visibility);
+            Par := Scope (Par);
+         end loop;
+      end Set_Parents;
+
+   begin
+      --  Deal with categorization pragmas in Pragmas of Compilation_Unit.
+      --  The purpose is to set categorization flags before analyzing the
+      --  unit itself, so as to diagnose violations of categorization as
+      --  we process each declaration, even though the pragma appears after
+      --  the unit.
+
+      if Nkind (P) /= N_Compilation_Unit then
+         return;
+      end if;
+
+      declare
+         PN : Node_Id := First (Pragmas_After (Aux_Decls_Node (P)));
+
+      begin
+
+         if Is_Child_Unit (S)
+           and then Is_Generic_Instance (S)
+         then
+            Set_Parents (True);
+         end if;
+
+         while Present (PN) loop
+
+            --  Skip implicit types that may have been introduced by
+            --  previous analysis.
+
+            if Nkind (PN) = N_Pragma then
+
+               case Get_Pragma_Id (Chars (PN)) is
+                  when Pragma_All_Calls_Remote   |
+                    Pragma_Preelaborate          |
+                    Pragma_Pure                  |
+                    Pragma_Remote_Call_Interface |
+                    Pragma_Remote_Types          |
+                    Pragma_Shared_Passive        => Analyze (PN);
+                  when others                    => null;
+               end case;
+            end if;
+
+            Next (PN);
+         end loop;
+         if Is_Child_Unit (S)
+           and then Is_Generic_Instance (S)
+         then
+            Set_Parents (False);
+         end if;
+
+      end;
+   end Set_Categorization_From_Pragmas;
+
+   ------------------------------
+   -- Static_Discriminant_Expr --
+   ------------------------------
+
+   function Static_Discriminant_Expr (L : List_Id) return Boolean is
+      Discriminant_Spec : Node_Id;
+
+   begin
+      Discriminant_Spec := First (L);
+      while Present (Discriminant_Spec) loop
+         if Present (Expression (Discriminant_Spec))
+           and then not Is_Static_Expression (Expression (Discriminant_Spec))
+         then
+            return False;
+         end if;
+
+         Next (Discriminant_Spec);
+      end loop;
+
+      return True;
+   end Static_Discriminant_Expr;
+
+   --------------------------------------
+   -- Validate_Access_Type_Declaration --
+   --------------------------------------
+
+   procedure Validate_Access_Type_Declaration (T : Entity_Id; N : Node_Id) is
+      Def : constant Node_Id := Type_Definition (N);
+
+   begin
+      case Nkind (Def) is
+         when N_Access_To_Subprogram_Definition =>
+
+            --  A pure library_item must not contain the declaration of a
+            --  named access type, except within a subprogram, generic
+            --  subprogram, task unit, or protected unit (RM 10.2.1(16)).
+
+            if Comes_From_Source (T)
+               and then In_Pure_Unit
+               and then not In_Subprogram_Task_Protected_Unit
+            then
+               Error_Msg_N ("named access type not allowed in pure unit", T);
+            end if;
+
+         when N_Access_To_Object_Definition =>
+
+            if Comes_From_Source (T)
+              and then In_Pure_Unit
+              and then not In_Subprogram_Task_Protected_Unit
+            then
+               Error_Msg_N
+                 ("named access type not allowed in pure unit", T);
+            end if;
+
+            --  Check for RCI unit type declaration. It should not contain
+            --  the declaration of an access-to-object type unless it is a
+            --  general access type that designates a class-wide limited
+            --  private type. There are also constraints about the primitive
+            --  subprograms of the class-wide type.
+
+            Validate_Remote_Access_Object_Type_Declaration (T);
+
+            --  Check for shared passive unit type declaration. It should
+            --  not contain the declaration of access to class wide type,
+            --  access to task type and access to protected type with entry.
+
+            Validate_SP_Access_Object_Type_Decl (T);
+
+         when others => null;
+      end case;
+
+      --  Set Categorization flag of package on entity as well, to allow
+      --  easy checks later on for required validations of RCI units. This
+      --  is only done for entities that are in the original source.
+
+      if Comes_From_Source (T) then
+         if Is_Remote_Call_Interface (Scope (T))
+           and then not In_Package_Body (Scope (T))
+         then
+            Set_Is_Remote_Call_Interface (T);
+         end if;
+
+         if Is_Remote_Types (Scope (T))
+           and then not In_Package_Body (Scope (T))
+         then
+            Set_Is_Remote_Types (T);
+         end if;
+      end if;
+   end Validate_Access_Type_Declaration;
+
+   ----------------------------
+   -- Validate_Ancestor_Part --
+   ----------------------------
+
+   procedure Validate_Ancestor_Part (N : Node_Id) is
+      A : constant Node_Id := Ancestor_Part (N);
+      T : Entity_Id        := Entity (A);
+
+   begin
+      if In_Preelaborated_Unit
+        and then not In_Subprogram_Or_Concurrent_Unit
+        and then (not Inside_A_Generic
+                   or else Present (Enclosing_Generic_Body (N)))
+      then
+         --  We relax the restriction of 10.2.1(9) within GNAT
+         --  units to allow packages such as Ada.Strings.Unbounded
+         --  to be implemented (i.p., Null_Unbounded_String).
+         --  (There are ACVC tests that check that the restriction
+         --  is enforced, but note that AI-161, once approved,
+         --  will relax the restriction prohibiting default-
+         --  initialized objects of private and controlled
+         --  types.)
+
+         if Is_Private_Type (T)
+           and then not Is_Internal_File_Name
+                          (Unit_File_Name (Get_Source_Unit (N)))
+         then
+            Error_Msg_N
+              ("private ancestor type not allowed in preelaborated unit", A);
+
+         elsif Is_Record_Type (T) then
+            if Nkind (Parent (T)) = N_Full_Type_Declaration then
+               Check_Non_Static_Default_Expr
+                 (Type_Definition (Parent (T)), A);
+            end if;
+         end if;
+      end if;
+   end Validate_Ancestor_Part;
+
+   ----------------------------------------
+   -- Validate_Categorization_Dependency --
+   ----------------------------------------
+
+   procedure Validate_Categorization_Dependency
+     (N : Node_Id;
+      E : Entity_Id)
+   is
+      K          : constant Node_Kind := Nkind (N);
+      P          : Node_Id            := Parent (N);
+      U          : Entity_Id := E;
+      Is_Subunit : constant Boolean := Nkind (P) = N_Subunit;
+
+   begin
+      --  Only validate library units and subunits. For subunits, checks
+      --  concerning withed units apply to the parent compilation unit.
+
+      if Is_Subunit then
+         P := Parent (P);
+         U := Scope (E);
+
+         while Present (U)
+           and then not Is_Compilation_Unit (U)
+           and then not Is_Child_Unit (U)
+         loop
+            U := Scope (U);
+         end loop;
+
+      end if;
+
+      if Nkind (P) /= N_Compilation_Unit then
+         return;
+      end if;
+
+      --  Body of RCI unit does not need validation.
+
+      if Is_Remote_Call_Interface (E)
+        and then (Nkind (N) = N_Package_Body
+                   or else Nkind (N) = N_Subprogram_Body)
+      then
+         return;
+      end if;
+
+      --  Process with clauses
+
+      declare
+         Item             : Node_Id;
+         Entity_Of_Withed : Entity_Id;
+
+      begin
+         Item := First (Context_Items (P));
+
+         while Present (Item) loop
+            if Nkind (Item) = N_With_Clause
+              and then not Implicit_With (Item)
+            then
+               Entity_Of_Withed := Entity (Name (Item));
+               Check_Categorization_Dependencies
+                (U, Entity_Of_Withed, Item, Is_Subunit);
+            end if;
+
+            Next (Item);
+         end loop;
+      end;
+
+      --  Child depends on parent; therefore parent should also
+      --  be categorized and satify the dependency hierarchy.
+
+      --  Check if N is a child spec.
+
+      if (K in N_Generic_Declaration              or else
+          K in N_Generic_Instantiation            or else
+          K in N_Generic_Renaming_Declaration     or else
+          K =  N_Package_Declaration              or else
+          K =  N_Package_Renaming_Declaration     or else
+          K =  N_Subprogram_Declaration           or else
+          K =  N_Subprogram_Renaming_Declaration)
+        and then Present (Parent_Spec (N))
+      then
+         declare
+            Parent_Lib_U  : constant Node_Id   := Parent_Spec (N);
+            Parent_Kind   : constant Node_Kind :=
+                              Nkind (Unit (Parent_Lib_U));
+            Parent_Entity : Entity_Id;
+
+         begin
+            if        Parent_Kind =  N_Package_Instantiation
+              or else Parent_Kind =  N_Procedure_Instantiation
+              or else Parent_Kind =  N_Function_Instantiation
+              or else Parent_Kind =  N_Package_Renaming_Declaration
+              or else Parent_Kind in N_Generic_Renaming_Declaration
+            then
+               Parent_Entity := Defining_Entity (Unit (Parent_Lib_U));
+
+            else
+               Parent_Entity :=
+                 Defining_Entity (Specification (Unit (Parent_Lib_U)));
+            end if;
+
+            Check_Categorization_Dependencies (E, Parent_Entity, N, False);
+
+            --  Verify that public child of an RCI library unit
+            --  must also be an RCI library unit (RM E.2.3(15)).
+
+            if Is_Remote_Call_Interface (Parent_Entity)
+              and then not Private_Present (P)
+              and then not Is_Remote_Call_Interface (E)
+            then
+               Error_Msg_N
+                 ("public child of rci unit must also be rci unit", N);
+               return;
+            end if;
+         end;
+      end if;
+
+   end Validate_Categorization_Dependency;
+
+   --------------------------------
+   -- Validate_Controlled_Object --
+   --------------------------------
+
+   procedure Validate_Controlled_Object (E : Entity_Id) is
+   begin
+      --  For now, never apply this check for internal GNAT units, since we
+      --  have a number of cases in the library where we are stuck with objects
+      --  of this type, and the RM requires Preelaborate.
+
+      --  For similar reasons, we only do this check for source entities, since
+      --  we generate entities of this type in some situations.
+
+      --  Note that the 10.2.1(9) restrictions are not relevant to us anyway.
+      --  We have to enforce them for RM compatibility, but we have no trouble
+      --  accepting these objects and doing the right thing. Note that there is
+      --  no requirement that Preelaborate not actually generate any code!
+
+      if In_Preelaborated_Unit
+        and then not Debug_Flag_PP
+        and then Comes_From_Source (E)
+        and then not
+          Is_Internal_File_Name (Unit_File_Name (Get_Source_Unit (E)))
+        and then (not Inside_A_Generic
+                   or else Present (Enclosing_Generic_Body (E)))
+        and then not Is_Protected_Type (Etype (E))
+      then
+         Error_Msg_N
+           ("library level controlled object not allowed in " &
+            "preelaborated unit", E);
+      end if;
+   end Validate_Controlled_Object;
+
+   --------------------------------------
+   -- Validate_Null_Statement_Sequence --
+   --------------------------------------
+
+   procedure Validate_Null_Statement_Sequence (N : Node_Id) is
+      Item : Node_Id;
+
+   begin
+      if In_Preelaborated_Unit then
+         Item := First (Statements (Handled_Statement_Sequence (N)));
+
+         while Present (Item) loop
+            if Nkind (Item) /= N_Label
+              and then Nkind (Item) /= N_Null_Statement
+            then
+               Error_Msg_N
+                 ("statements not allowed in preelaborated unit", Item);
+               exit;
+            end if;
+
+            Next (Item);
+         end loop;
+      end if;
+   end Validate_Null_Statement_Sequence;
+
+   ---------------------------------
+   -- Validate_Object_Declaration --
+   ---------------------------------
+
+   procedure Validate_Object_Declaration (N : Node_Id) is
+      Id  : constant Entity_Id  := Defining_Identifier (N);
+      E   : constant Node_Id    := Expression (N);
+      Odf : constant Node_Id    := Object_Definition (N);
+      T   : constant Entity_Id  := Etype (Id);
+
+   begin
+      --  Verify that any access to subprogram object does not have in its
+      --  subprogram profile access type parameters or limited parameters
+      --  without Read and Write attributes (E.2.3(13)).
+
+      Validate_RCI_Subprogram_Declaration (N);
+
+      --  Check that if we are in preelaborated elaboration code, then we
+      --  do not have an instance of a default initialized private, task or
+      --  protected object declaration which would violate (RM 10.2.1(9)).
+      --  Note that constants are never default initialized (and the test
+      --  below also filters out deferred constants). A variable is default
+      --  initialized if it does *not* have an initialization expression.
+
+      --  Filter out cases that are not declaration of a variable from source
+
+      if Nkind (N) /= N_Object_Declaration
+        or else Constant_Present (N)
+        or else not Comes_From_Source (Id)
+      then
+         return;
+      end if;
+
+      --  Exclude generic specs from the checks (this will get rechecked
+      --  on instantiations).
+
+      if Inside_A_Generic
+        and then not Present (Enclosing_Generic_Body (Id))
+      then
+         return;
+      end if;
+
+      --  Required checks for declaration that is in a preelaborated
+      --  package and is not within some subprogram.
+
+      if In_Preelaborated_Unit
+        and then not In_Subprogram_Or_Concurrent_Unit
+      then
+         --  Check for default initialized variable case. Note that in
+         --  accordance with (RM B.1(24)) imported objects are not
+         --  subject to default initialization.
+
+         if No (E) and then not Is_Imported (Id) then
+            declare
+               Ent : Entity_Id := T;
+
+            begin
+               --  An array whose component type is a record with nonstatic
+               --  default expressions is a violation, so we get the array's
+               --  component type.
+
+               if Is_Array_Type (Ent) then
+                  declare
+                     Comp_Type : Entity_Id := Component_Type (Ent);
+
+                  begin
+                     while Is_Array_Type (Comp_Type) loop
+                        Comp_Type := Component_Type (Comp_Type);
+                     end loop;
+
+                     Ent := Comp_Type;
+                  end;
+               end if;
+
+               --  Object decl. that is of record type and has no default expr.
+               --  should check if there is any non-static default expression
+               --  in component decl. of the record type decl.
+
+               if Is_Record_Type (Ent) then
+                  if Nkind (Parent (Ent)) = N_Full_Type_Declaration then
+                     Check_Non_Static_Default_Expr
+                       (Type_Definition (Parent (Ent)), N);
+
+                  elsif Nkind (Odf) = N_Subtype_Indication
+                    and then not Is_Array_Type (T)
+                    and then not Is_Private_Type (T)
+                  then
+                     Check_Non_Static_Default_Expr (Type_Definition
+                       (Parent (Entity (Subtype_Mark (Odf)))), N);
+                  end if;
+               end if;
+
+               --  We relax the restriction of 10.2.1(9) within GNAT
+               --  units. (There are ACVC tests that check that the
+               --  restriction is enforced, but note that AI-161,
+               --  once approved, will relax the restriction prohibiting
+               --  default-initialized objects of private types, and
+               --  will recommend a pragma for marking private types.)
+
+               if (Is_Private_Type (Ent)
+                    or else Depends_On_Private (Ent))
+                 and then not Is_Internal_File_Name
+                                (Unit_File_Name (Get_Source_Unit (N)))
+               then
+                  Error_Msg_N
+                    ("private object not allowed in preelaborated unit", N);
+                  return;
+
+               --  Access to Task or Protected type
+
+               elsif Is_Entity_Name (Odf)
+                 and then Present (Etype (Odf))
+                 and then Is_Access_Type (Etype (Odf))
+               then
+                  Ent := Designated_Type (Etype (Odf));
+
+               elsif Is_Entity_Name (Odf) then
+                  Ent := Entity (Odf);
+
+               elsif Nkind (Odf) = N_Subtype_Indication then
+                  Ent := Etype (Subtype_Mark (Odf));
+
+               elsif
+                  Nkind (Odf) = N_Constrained_Array_Definition
+               then
+                  Ent := Component_Type (T);
+
+               --  else
+               --     return;
+               end if;
+
+               if Is_Task_Type (Ent)
+                 or else (Is_Protected_Type (Ent) and then Has_Entries (Ent))
+               then
+                  Error_Msg_N
+                    ("concurrent object not allowed in preelaborated unit",
+                     N);
+                  return;
+               end if;
+            end;
+         end if;
+
+         --  Non-static discriminant not allowed in preelaborayted unit
+
+         if Is_Record_Type (Etype (Id)) then
+            declare
+               ET  : constant Entity_Id := Etype (Id);
+               EE  : constant Entity_Id := Etype (Etype (Id));
+               PEE : Node_Id;
+
+            begin
+               if Has_Discriminants (ET)
+                 and then Present (EE)
+               then
+                  PEE := Parent (EE);
+
+                  if Nkind (PEE) = N_Full_Type_Declaration
+                    and then not Static_Discriminant_Expr
+                                  (Discriminant_Specifications (PEE))
+                  then
+                     Error_Msg_N
+                       ("non-static discriminant in preelaborated unit",
+                        PEE);
+                  end if;
+               end if;
+            end;
+         end if;
+      end if;
+
+      --  A pure library_item must not contain the declaration of any
+      --  variable except within  a subprogram, generic subprogram, task
+      --  unit or protected unit (RM 10.2.1(16)).
+
+      if In_Pure_Unit
+        and then not In_Subprogram_Task_Protected_Unit
+      then
+         Error_Msg_N ("declaration of variable not allowed in pure unit", N);
+
+      --  The visible part of an RCI library unit must not contain the
+      --  declaration of a variable (RM E.1.3(9))
+
+      elsif In_RCI_Declaration (N) then
+         Error_Msg_N ("declaration of variable not allowed in rci unit", N);
+
+      --  The visible part of a Shared Passive library unit must not contain
+      --  the declaration of a variable (RM E.2.2(7))
+
+      elsif In_RT_Declaration then
+         Error_Msg_N
+           ("variable declaration not allowed in remote types unit", N);
+      end if;
+
+   end Validate_Object_Declaration;
+
+   --------------------------------
+   --  Validate_RCI_Declarations --
+   --------------------------------
+
+   procedure Validate_RCI_Declarations (P : Entity_Id) is
+      E : Entity_Id;
+
+   begin
+      E := First_Entity (P);
+
+      while Present (E) loop
+         if Comes_From_Source (E) then
+
+            if Is_Limited_Type (E) then
+               Error_Msg_N
+                 ("Limited type not allowed in rci unit", Parent (E));
+
+            elsif Ekind (E) = E_Generic_Function
+              or else Ekind (E) = E_Generic_Package
+              or else Ekind (E) = E_Generic_Procedure
+            then
+               Error_Msg_N ("generic declaration not allowed in rci unit",
+                 Parent (E));
+
+            elsif (Ekind (E) = E_Function
+                    or else Ekind (E) = E_Procedure)
+              and then Has_Pragma_Inline (E)
+            then
+               Error_Msg_N
+                 ("inlined subprogram not allowed in rci unit", Parent (E));
+
+            --  Inner packages that are renamings need not be checked.
+            --  Generic RCI packages are subject to the checks, but
+            --  entities that come from formal packages are not part of the
+            --  visible declarations of the package and are not checked.
+
+            elsif Ekind (E) = E_Package then
+               if Present (Renamed_Entity (E)) then
+                  null;
+
+               elsif Ekind (P) /= E_Generic_Package
+                 or else List_Containing (Unit_Declaration_Node (E)) /=
+                           Generic_Formal_Declarations
+                             (Unit_Declaration_Node (P))
+               then
+                  Validate_RCI_Declarations (E);
+               end if;
+            end if;
+         end if;
+
+         Next_Entity (E);
+      end loop;
+   end Validate_RCI_Declarations;
+
+   -----------------------------------------
+   -- Validate_RCI_Subprogram_Declaration --
+   -----------------------------------------
+
+   procedure Validate_RCI_Subprogram_Declaration (N : Node_Id) is
+      K               : Node_Kind := Nkind (N);
+      Profile         : List_Id;
+      Id              : Node_Id;
+      Param_Spec      : Node_Id;
+      Param_Type      : Entity_Id;
+      Base_Param_Type : Entity_Id;
+      Type_Decl       : Node_Id;
+      Error_Node      : Node_Id := N;
+
+   begin
+      --  There are two possible cases in which this procedure is called:
+
+      --    1. called from Analyze_Subprogram_Declaration.
+      --    2. called from Validate_Object_Declaration (access to subprogram).
+
+      if not In_RCI_Declaration (N) then
+         return;
+      end if;
+
+      if K = N_Subprogram_Declaration then
+         Profile := Parameter_Specifications (Specification (N));
+
+      else pragma Assert (K = N_Object_Declaration);
+         Id := Defining_Identifier (N);
+
+         if Nkind (Id) = N_Defining_Identifier
+           and then Nkind (Parent (Etype (Id))) = N_Full_Type_Declaration
+           and then Ekind (Etype (Id)) = E_Access_Subprogram_Type
+         then
+            Profile :=
+              Parameter_Specifications (Type_Definition (Parent (Etype (Id))));
+         else
+            return;
+         end if;
+      end if;
+
+      --  Iterate through the parameter specification list, checking that
+      --  no access parameter and no limited type parameter in the list.
+      --  RM E.2.3 (14)
+
+      if Present (Profile) then
+         Param_Spec := First (Profile);
+
+         while Present (Param_Spec) loop
+            Param_Type := Etype (Defining_Identifier (Param_Spec));
+            Type_Decl  := Parent (Param_Type);
+
+            if Ekind (Param_Type) = E_Anonymous_Access_Type then
+
+               if K = N_Subprogram_Declaration then
+                  Error_Node := Param_Spec;
+               end if;
+
+               --  Report error only if declaration is in source program.
+
+               if Comes_From_Source
+                 (Defining_Entity (Specification (N)))
+               then
+                  Error_Msg_N
+                    ("subprogram in rci unit cannot have access parameter",
+                      Error_Node);
+               end if;
+
+            --  For limited private type parameter, we check only the
+            --  private declaration and ignore full type declaration,
+            --  unless this is the only declaration for the type, eg.
+            --  as a limited record.
+
+            elsif Is_Limited_Type (Param_Type)
+              and then (Nkind (Type_Decl) = N_Private_Type_Declaration
+                         or else
+                        (Nkind (Type_Decl) = N_Full_Type_Declaration
+                          and then not (Has_Private_Declaration (Param_Type))
+                          and then Comes_From_Source (N)))
+            then
+
+               --  A limited parameter is legal only if user-specified
+               --  Read and Write attributes exist for it.
+               --  second part of RM E.2.3 (14)
+
+               if No (Full_View (Param_Type))
+                 and then Ekind (Param_Type) /= E_Record_Type
+               then
+                  --  type does not have completion yet, so if declared in
+                  --  in the current RCI scope it is illegal, and will be
+                  --  flagged subsequently.
+                  return;
+               end if;
+
+               Base_Param_Type := Base_Type (Underlying_Type (Param_Type));
+
+               if No (TSS (Base_Param_Type, Name_uRead))
+                 or else No (TSS (Base_Param_Type, Name_uWrite))
+               then
+
+                  if K = N_Subprogram_Declaration then
+                     Error_Node := Param_Spec;
+                  end if;
+
+                  Error_Msg_N
+                    ("limited parameter in rci unit "
+                       & "must have read/write attributes ", Error_Node);
+               end if;
+            end if;
+
+            Next (Param_Spec);
+         end loop;
+      end if;
+   end Validate_RCI_Subprogram_Declaration;
+
+   ----------------------------------------------------
+   -- Validate_Remote_Access_Object_Type_Declaration --
+   ----------------------------------------------------
+
+   procedure Validate_Remote_Access_Object_Type_Declaration (T : Entity_Id) is
+      Direct_Designated_Type : Entity_Id;
+      Desig_Type             : Entity_Id;
+      Primitive_Subprograms  : Elist_Id;
+      Subprogram             : Elmt_Id;
+      Subprogram_Node        : Node_Id;
+      Profile                : List_Id;
+      Param_Spec             : Node_Id;
+      Param_Type             : Entity_Id;
+      Limited_Type_Decl      : Node_Id;
+
+   begin
+      --  We are called from Analyze_Type_Declaration, and the Nkind
+      --  of the given node is N_Access_To_Object_Definition.
+
+      if not Comes_From_Source (T)
+        or else (not In_RCI_Declaration (Parent (T))
+                   and then not In_RT_Declaration)
+      then
+         return;
+      end if;
+
+      --  An access definition in the private part of a Remote Types package
+      --  may be legal if it has user-defined Read and Write attributes. This
+      --  will be checked at the end of the package spec processing.
+
+      if In_RT_Declaration and then In_Private_Part (Scope (T)) then
+         return;
+      end if;
+
+      --  Check RCI unit type declaration. It should not contain the
+      --  declaration of an access-to-object type unless it is a
+      --  general access type that designates a class-wide limited
+      --  private type. There are also constraints about the primitive
+      --  subprograms of the class-wide type (RM E.2.3(14)).
+
+      if Ekind (T) /= E_General_Access_Type
+        or else Ekind (Designated_Type (T)) /= E_Class_Wide_Type
+      then
+         if In_RCI_Declaration (Parent (T)) then
+            Error_Msg_N
+              ("access type in Remote_Call_Interface unit must be " &
+               "general access", T);
+         else
+            Error_Msg_N ("access type in Remote_Types unit must be " &
+              "general access", T);
+         end if;
+         Error_Msg_N ("\to class-wide type", T);
+         return;
+      end if;
+
+      Direct_Designated_Type := Designated_Type (T);
+
+      Desig_Type := Etype (Direct_Designated_Type);
+
+      if not Is_Recursively_Limited_Private (Desig_Type) then
+         Error_Msg_N
+           ("error in designated type of remote access to class-wide type", T);
+         Error_Msg_N
+           ("\must be tagged limited private or private extension of type", T);
+         return;
+      end if;
+
+      Primitive_Subprograms := Primitive_Operations (Desig_Type);
+      Subprogram            := First_Elmt (Primitive_Subprograms);
+
+      while Subprogram /= No_Elmt loop
+         Subprogram_Node := Node (Subprogram);
+
+         if not Comes_From_Source (Subprogram_Node) then
+            goto Next_Subprogram;
+         end if;
+
+         Profile := Parameter_Specifications (Parent (Subprogram_Node));
+
+         --  Profile must exist, otherwise not primitive operation
+
+         Param_Spec := First (Profile);
+
+         while Present (Param_Spec) loop
+
+            --  Now find out if this parameter is a controlling parameter
+
+            Param_Type := Parameter_Type (Param_Spec);
+
+            if (Nkind (Param_Type) = N_Access_Definition
+                  and then Etype (Subtype_Mark (Param_Type)) = Desig_Type)
+              or else (Nkind (Param_Type) /= N_Access_Definition
+                        and then Etype (Param_Type) = Desig_Type)
+            then
+               --  It is a controlling parameter, so specific checks below
+               --  do not apply.
+
+               null;
+
+            elsif
+              Nkind (Param_Type) = N_Access_Definition
+            then
+               --  From RM E.2.2(14), no access parameter other than
+               --  controlling ones may be used.
+
+               Error_Msg_N
+                 ("non-controlling access parameter", Param_Spec);
+
+            elsif
+              Is_Limited_Type (Etype (Defining_Identifier (Param_Spec)))
+            then
+               --  Not a controlling parameter, so type must have Read
+               --  and Write attributes.
+               --  ??? I suspect this to be dead code because any violation
+               --  should be caught before in sem_attr.adb (with the message
+               --  "limited type ... used in ... has no stream attr.").  ST
+
+               if Nkind (Param_Type) in N_Has_Etype
+                 and then Nkind (Parent (Etype (Param_Type))) =
+                          N_Private_Type_Declaration
+               then
+                  Param_Type := Etype (Param_Type);
+                  Limited_Type_Decl := Parent (Param_Type);
+
+                  if No (TSS (Param_Type, Name_uRead))
+                    or else No (TSS (Param_Type, Name_uWrite))
+                  then
+                     Error_Msg_N
+                       ("limited formal must have Read and Write attributes",
+                         Param_Spec);
+                  end if;
+               end if;
+            end if;
+
+            --  Check next parameter in this subprogram
+
+            Next (Param_Spec);
+         end loop;
+
+         <<Next_Subprogram>>
+            Next_Elmt (Subprogram);
+      end loop;
+
+      --  Now this is an RCI unit access-to-class-wide-limited-private type
+      --  declaration. Set the type entity to be Is_Remote_Call_Interface to
+      --  optimize later checks by avoiding tree traversal to find out if this
+      --  entity is inside an RCI unit.
+
+      Set_Is_Remote_Call_Interface (T);
+
+   end Validate_Remote_Access_Object_Type_Declaration;
+
+   -----------------------------------------------
+   -- Validate_Remote_Access_To_Class_Wide_Type --
+   -----------------------------------------------
+
+   procedure Validate_Remote_Access_To_Class_Wide_Type (N : Node_Id) is
+      K  : constant Node_Kind := Nkind (N);
+      PK : constant Node_Kind := Nkind (Parent (N));
+      E  : Entity_Id;
+
+   begin
+      --  This subprogram enforces the checks in (RM E.2.2(8)) for
+      --  certain uses of class-wide limited private types.
+
+      --    Storage_Pool and Storage_Size are not defined for such types
+      --
+      --    The expected type of allocator must not not be such a type.
+
+      --    The actual parameter of generic instantiation must not
+      --    be such a type if the formal parameter is of an access type.
+
+      --  On entry, there are five cases
+
+      --    1. called from sem_attr Analyze_Attribute where attribute
+      --       name is either Storage_Pool or Storage_Size.
+
+      --    2. called from exp_ch4 Expand_N_Allocator
+
+      --    3. called from sem_ch12 Analyze_Associations
+
+      --    4. called from sem_ch4 Analyze_Explicit_Dereference
+
+      --    5. called from sem_res Resolve_Actuals
+
+      if K = N_Attribute_Reference then
+         E := Etype (Prefix (N));
+
+         if Is_Remote_Access_To_Class_Wide_Type (E) then
+            Error_Msg_N ("incorrect attribute of remote operand", N);
+            return;
+         end if;
+
+      elsif K = N_Allocator then
+         E := Etype (N);
+
+         if Is_Remote_Access_To_Class_Wide_Type (E) then
+            Error_Msg_N ("incorrect expected remote type of allocator", N);
+            return;
+         end if;
+
+      elsif K in N_Has_Entity then
+         E := Entity (N);
+
+         if Is_Remote_Access_To_Class_Wide_Type (E) then
+            Error_Msg_N ("incorrect remote type generic actual", N);
+            return;
+         end if;
+
+      --  This subprogram also enforces the checks in E.2.2(13).
+      --  A value of such type must not be dereferenced unless as a
+      --  controlling operand of a dispatching call.
+
+      elsif K = N_Explicit_Dereference
+        and then (Comes_From_Source (N)
+                    or else (Nkind (Original_Node (N)) = N_Selected_Component
+                               and then Comes_From_Source (Original_Node (N))))
+      then
+         E := Etype (Prefix (N));
+
+         --  If the class-wide type is not a remote one, the restrictions
+         --  do not apply.
+
+         if not Is_Remote_Access_To_Class_Wide_Type (E) then
+            return;
+         end if;
+
+         --  If we have a true dereference that comes from source and that
+         --  is a controlling argument for a dispatching call, accept it.
+
+         if K = N_Explicit_Dereference
+           and then Is_Actual_Parameter (N)
+           and then Is_Controlling_Actual (N)
+         then
+            return;
+         end if;
+
+         --  If we are just within a procedure or function call and the
+         --  dereference has not been analyzed, return because this
+         --  procedure will be called again from sem_res Resolve_Actuals.
+
+         if Is_Actual_Parameter (N)
+           and then not Analyzed (N)
+         then
+            return;
+         end if;
+
+         --  The following is to let the compiler generated tags check
+         --  pass through without error message. This is a bit kludgy
+         --  isn't there some better way of making this exclusion ???
+
+         if (PK = N_Selected_Component
+              and then Present (Parent (Parent (N)))
+              and then Nkind (Parent (Parent (N))) = N_Op_Ne)
+           or else (PK = N_Unchecked_Type_Conversion
+                    and then Present (Parent (Parent (N)))
+                    and then
+                      Nkind (Parent (Parent (N))) = N_Selected_Component)
+         then
+            return;
+         end if;
+
+         --  The following code is needed for expansion of RACW Write
+         --  attribute, since such expressions can appear in the expanded
+         --  code.
+
+         if not Comes_From_Source (N)
+           and then
+           (PK = N_In
+            or else PK = N_Attribute_Reference
+            or else
+              (PK = N_Type_Conversion
+               and then Present (Parent (N))
+               and then Present (Parent (Parent (N)))
+               and then
+                 Nkind (Parent (Parent (N))) = N_Selected_Component))
+         then
+            return;
+         end if;
+
+         Error_Msg_N ("incorrect remote type dereference", N);
+      end if;
+   end Validate_Remote_Access_To_Class_Wide_Type;
+
+   -----------------------------------------------
+   -- Validate_Remote_Access_To_Subprogram_Type --
+   -----------------------------------------------
+
+   procedure Validate_Remote_Access_To_Subprogram_Type (N : Node_Id) is
+      Type_Def          : constant Node_Id := Type_Definition (N);
+      Current_Parameter : Node_Id;
+
+   begin
+      if Present (Parameter_Specifications (Type_Def)) then
+         Current_Parameter := First (Parameter_Specifications (Type_Def));
+         while Present (Current_Parameter) loop
+            if Nkind (Parameter_Type (Current_Parameter)) =
+                                                         N_Access_Definition
+            then
+               Error_Msg_N
+                 ("remote access to subprogram type declaration contains",
+                  Current_Parameter);
+               Error_Msg_N
+                 ("\parameter of an anonymous access type", Current_Parameter);
+            end if;
+
+            Current_Parameter := Next (Current_Parameter);
+         end loop;
+      end if;
+   end Validate_Remote_Access_To_Subprogram_Type;
+
+   ------------------------------------------
+   -- Validate_Remote_Type_Type_Conversion --
+   ------------------------------------------
+
+   procedure Validate_Remote_Type_Type_Conversion (N : Node_Id) is
+      S : constant Entity_Id := Etype (N);
+      E : constant Entity_Id := Etype (Expression (N));
+
+   begin
+      --  This test is required in the case where a conversion appears
+      --  inside a normal package, it does not necessarily have to be
+      --  inside an RCI, Remote_Types unit (RM E.2.2(9,12)).
+
+      if Is_Remote_Access_To_Subprogram_Type (E)
+        and then not Is_Remote_Access_To_Subprogram_Type (S)
+      then
+         Error_Msg_N ("incorrect conversion of remote operand", N);
+         return;
+
+      elsif Is_Remote_Access_To_Class_Wide_Type (E)
+        and then not Is_Remote_Access_To_Class_Wide_Type (S)
+      then
+         Error_Msg_N ("incorrect conversion of remote operand", N);
+         return;
+      end if;
+
+      --  If a local access type is converted into a RACW type, then the
+      --  current unit has a pointer that may now be exported to another
+      --  partition.
+
+      if Is_Remote_Access_To_Class_Wide_Type (S)
+        and then not Is_Remote_Access_To_Class_Wide_Type (E)
+      then
+         Set_Has_RACW (Current_Sem_Unit);
+      end if;
+   end Validate_Remote_Type_Type_Conversion;
+
+   -------------------------------
+   -- Validate_RT_RAT_Component --
+   -------------------------------
+
+   procedure Validate_RT_RAT_Component (N : Node_Id) is
+      Spec            : constant Node_Id   := Specification (N);
+      Name_U          : constant Entity_Id := Defining_Entity (Spec);
+      Typ             : Entity_Id;
+      First_Priv_Ent  : constant Entity_Id := First_Private_Entity (Name_U);
+      In_Visible_Part : Boolean            := True;
+
+   begin
+      if not Is_Remote_Types (Name_U) then
+         return;
+      end if;
+
+      Typ := First_Entity (Name_U);
+      while Present (Typ) loop
+         if In_Visible_Part and then Typ = First_Priv_Ent then
+            In_Visible_Part := False;
+         end if;
+
+         if Comes_From_Source (Typ)
+           and then Is_Type (Typ)
+           and then (In_Visible_Part or else Has_Private_Declaration (Typ))
+         then
+            if Missing_Read_Write_Attributes (Typ) then
+               if Is_Non_Remote_Access_Type (Typ) then
+                  Error_Msg_N
+                    ("non-remote access type without user-defined Read " &
+                     "and Write attributes", Typ);
+               else
+                  Error_Msg_N
+                    ("record type containing a component of a " &
+                     "non-remote access", Typ);
+                  Error_Msg_N
+                    ("\type without Read and Write attributes " &
+                     "('R'M E.2.2(8))", Typ);
+               end if;
+            end if;
+         end if;
+
+         Next_Entity (Typ);
+      end loop;
+   end Validate_RT_RAT_Component;
+
+   -----------------------------------------
+   -- Validate_SP_Access_Object_Type_Decl --
+   -----------------------------------------
+
+   procedure Validate_SP_Access_Object_Type_Decl (T : Entity_Id) is
+      Direct_Designated_Type : Entity_Id;
+
+      function Has_Entry_Declarations (E : Entity_Id) return Boolean;
+      --  Return true if the protected type designated by T has
+      --  entry declarations.
+
+      function Has_Entry_Declarations (E : Entity_Id) return Boolean is
+         Ety : Entity_Id;
+
+      begin
+         if Nkind (Parent (E)) = N_Protected_Type_Declaration then
+            Ety := First_Entity (E);
+            while Present (Ety) loop
+               if Ekind (Ety) = E_Entry then
+                  return True;
+               end if;
+
+               Next_Entity (Ety);
+            end loop;
+         end if;
+
+         return False;
+      end Has_Entry_Declarations;
+
+   --  Start of processing for Validate_SP_Access_Object_Type_Decl
+
+   begin
+      --  We are called from Sem_Ch3.Analyze_Type_Declaration, and the
+      --  Nkind of the given entity is N_Access_To_Object_Definition.
+
+      if not Comes_From_Source (T)
+        or else not In_Shared_Passive_Unit
+        or else In_Subprogram_Task_Protected_Unit
+      then
+         return;
+      end if;
+
+      --  Check Shared Passive unit. It should not contain the declaration
+      --  of an access-to-object type whose designated type is a class-wide
+      --  type, task type or protected type with entry (RM E.2.1(7)).
+
+      Direct_Designated_Type := Designated_Type (T);
+
+      if Ekind (Direct_Designated_Type) = E_Class_Wide_Type then
+         Error_Msg_N
+           ("invalid access-to-class-wide type in shared passive unit", T);
+         return;
+
+      elsif Ekind (Direct_Designated_Type) in Task_Kind then
+         Error_Msg_N
+           ("invalid access-to-task type in shared passive unit", T);
+         return;
+
+      elsif Ekind (Direct_Designated_Type) in Protected_Kind
+        and then Has_Entry_Declarations (Direct_Designated_Type)
+      then
+         Error_Msg_N
+           ("invalid access-to-protected type in shared passive unit", T);
+         return;
+      end if;
+   end Validate_SP_Access_Object_Type_Decl;
+
+   ---------------------------------
+   -- Validate_Static_Object_Name --
+   ---------------------------------
+
+   procedure Validate_Static_Object_Name (N : Node_Id) is
+      E : Entity_Id;
+
+      function Is_Primary (N : Node_Id) return Boolean;
+      --  Determine whether node is syntactically a primary in an expression.
+
+      function Is_Primary (N : Node_Id) return Boolean is
+         K : constant Node_Kind := Nkind (Parent (N));
+
+      begin
+         case K is
+
+            when N_Op | N_In | N_Not_In =>
+               return True;
+
+            when N_Aggregate
+               | N_Component_Association
+               | N_Index_Or_Discriminant_Constraint =>
+               return True;
+
+            when N_Attribute_Reference =>
+               return Attribute_Name (Parent (N)) /= Name_Address
+                 and then Attribute_Name (Parent (N)) /= Name_Access
+                 and then Attribute_Name (Parent (N)) /= Name_Unchecked_Access
+                 and then
+                   Attribute_Name (Parent (N)) /= Name_Unrestricted_Access;
+
+            when N_Indexed_Component =>
+               return (N /= Prefix (Parent (N))
+                 or else Is_Primary (Parent (N)));
+
+            when N_Qualified_Expression | N_Type_Conversion =>
+               return Is_Primary (Parent (N));
+
+            when N_Assignment_Statement | N_Object_Declaration =>
+               return (N = Expression (Parent (N)));
+
+            when N_Selected_Component =>
+               return Is_Primary (Parent (N));
+
+            when others =>
+               return False;
+         end case;
+      end Is_Primary;
+
+   --  Start of processing for Validate_Static_Object_Name
+
+   begin
+      if not In_Preelaborated_Unit
+        or else not Comes_From_Source (N)
+        or else In_Subprogram_Or_Concurrent_Unit
+        or else Ekind (Current_Scope) = E_Block
+      then
+         return;
+
+      --  Filter out cases where primary is default in a component
+      --  declaration, discriminant specification, or actual in a record
+      --  type initialization call.
+
+      --  Initialization call of internal types.
+
+      elsif Nkind (Parent (N)) = N_Procedure_Call_Statement then
+
+         if Present (Parent (Parent (N)))
+           and then Nkind (Parent (Parent (N))) = N_Freeze_Entity
+         then
+            return;
+         end if;
+
+         if Nkind (Name (Parent (N))) = N_Identifier
+           and then not Comes_From_Source (Entity (Name (Parent (N))))
+         then
+            return;
+         end if;
+      end if;
+
+      --  Error if the name is a primary in an expression. The parent must not
+      --  be an operator, or a selected component or an indexed component that
+      --  is itself a primary. Entities that are actuals do not need to be
+      --  checked, because the call itself will be diagnosed.
+
+      if Is_Primary (N)
+        and then (not Inside_A_Generic
+                   or else Present (Enclosing_Generic_Body (N)))
+      then
+         if Ekind (Entity (N)) = E_Variable then
+            Error_Msg_N ("non-static object name in preelaborated unit", N);
+
+         --  We take the view that a constant defined in another preelaborated
+         --  unit is preelaborable, even though it may have a private type and
+         --  thus appear non-static in a client. This must be the intent of
+         --  the language, but currently is an RM gap.
+
+         elsif Ekind (Entity (N)) = E_Constant
+           and then not Is_Static_Expression (N)
+         then
+            E := Entity (N);
+
+            if Is_Internal_File_Name (Unit_File_Name (Get_Source_Unit (N)))
+              and then
+                Enclosing_Lib_Unit_Node (N) /= Enclosing_Lib_Unit_Node (E)
+              and then (Is_Preelaborated (Scope (E))
+                          or else Is_Pure (Scope (E))
+                          or else (Present (Renamed_Object (E))
+                                     and then
+                                       Is_Entity_Name (Renamed_Object (E))
+                                     and then
+                                       (Is_Preelaborated
+                                         (Scope (Renamed_Object (E)))
+                                            or else
+                                              Is_Pure (Scope
+                                                (Renamed_Object (E))))))
+            then
+               null;
+            else
+               Error_Msg_N ("non-static constant in preelaborated unit", N);
+            end if;
+         end if;
+      end if;
+   end Validate_Static_Object_Name;
+
+end Sem_Cat;
diff --git a/gcc/ada/sem_cat.ads b/gcc/ada/sem_cat.ads
new file mode 100644
index 00000000000..3591e746c73
--- /dev/null
+++ b/gcc/ada/sem_cat.ads
@@ -0,0 +1,144 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              S E M _ C A T                               --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.14 $
+--                                                                          --
+--          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). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  This unit contains the routines used for checking for conformance with
+--  the semantic restrictions required for the categorization pragmas:
+--
+--    Preelaborate
+--    Pure,
+--    Remote_Call_Interface
+--    Remote_Types
+--    Shared_Passive
+--
+--  Note that we treat Preelaborate as a categorization pragma, even though
+--  strictly, according to RM E.2(2,3), the term does not apply in this case.
+
+with Types; use Types;
+
+package Sem_Cat is
+
+   function In_Preelaborated_Unit return Boolean;
+   --  Determines if the current scope is within a preelaborated compilation
+   --  unit, that is one to which one of the pragmas Preelaborate, Pure,
+   --  Shared_Passive, Remote_Types, or inside a unit other than a package
+   --  body with pragma Remote_Call_Interface.
+
+   function In_Pure_Unit return Boolean;
+   pragma Inline (In_Pure_Unit);
+   --  Determines if the current scope is within pure compilation unit,
+   --  that is, one to which the pragmas Pure is applied.
+
+   function In_Subprogram_Task_Protected_Unit return Boolean;
+   --  Determines if the current scope is within a subprogram, task
+   --  or protected unit. Used to validate if the library unit is Pure
+   --  (RM 10.2.1(16)).
+
+   procedure Set_Categorization_From_Pragmas (N : Node_Id);
+   --  Since validation of categorization dependency is done during analyze
+   --  so categorization flags from following pragmas should be set before
+   --  validation begin. N is the N_Compilation_Unit node.
+
+   procedure Validate_Access_Type_Declaration (T : Entity_Id; N : Node_Id);
+   --  Validate all constraints against declaration of access types in
+   --  categorized library units. Usually this is a violation in Pure unit,
+   --  Shared_Passive unit. N is the declaration node.
+
+   procedure Validate_Ancestor_Part (N : Node_Id);
+   --  Checks that a type given as the ancestor in an extension aggregate
+   --  satisfies the restriction of 10.2.1(9).
+
+   procedure Validate_Categorization_Dependency (N : Node_Id; E : Entity_Id);
+   --  There are restrictions on lib unit that semantically depends on other
+   --  units (RM E.2(5), 10.2.1(11). This procedure checks the restrictions
+   --  on categorizations. N is the current unit node, and E is the current
+   --  library unit entity.
+
+   procedure Validate_Controlled_Object (E : Entity_Id);
+   --  Given an entity for a library level controlled object, check that it is
+   --  not in a preelaborated unit (prohibited by RM 10.2.1(9)).
+
+   procedure Validate_Null_Statement_Sequence (N : Node_Id);
+   --  Given N, a package body node, check that a handled statement sequence
+   --  in a preelaborable body contains no statements other than labels or
+   --  null statements, as required by RM 10.2.1(6).
+
+   procedure Validate_Object_Declaration (N : Node_Id);
+   --  Given N, an object declaration node, validates all the constraints in
+   --  a preelaborable library unit, including creation of task objects etc.
+   --  Note that this is called when the corresponding object is frozen since
+   --  the checks cannot be made before knowing if the object is imported.
+
+   procedure Validate_RCI_Declarations (P : Entity_Id);
+   --  Apply semantic checks given in  E2.3(10-14).
+
+   procedure Validate_RCI_Subprogram_Declaration (N : Node_Id);
+   --  Check for RCI unit subprogram declarations with respect to
+   --  in-lined subprogram and subprogram with access parameter or
+   --  limited type parameter without Read and Write.
+
+   procedure Validate_Remote_Access_To_Class_Wide_Type (N : Node_Id);
+   --  Checks that Storage_Pool and Storage_Size attribute references are
+   --  not applied to remote access-to-class-wide types. And the expected
+   --  type for an allocator shall not be a remote access-to-class-wide
+   --  type. And a remote access-to-class-wide type shall not be an actual
+   --  parameter for a generic formal access type. RM E.2.3(22).
+
+   procedure Validate_Remote_Access_To_Subprogram_Type (N : Node_Id);
+   --  Checks that a remote access to subprogram type does not have a
+   --  parameter of an access type. This is not strictly forbidden at this
+   --  time, but this is useless, as such a RAS type will not be usable
+   --  per E.2.2(12) and E.2.3(14).
+
+   procedure Validate_RT_RAT_Component (N : Node_Id);
+   --  Given N, the package library unit declaration node, we should check
+   --  against RM:9.95 E.2.2(8): the full view of a type declared in the
+   --  visible part of a Remote Types unit has a part that is of a non-remote
+   --  access type which has no read/write.
+
+   procedure Validate_Remote_Type_Type_Conversion (N : Node_Id);
+   --  Check for remote-type type conversion constraints. First, a value of
+   --  a remote access-to-subprogram type can be converted only to another
+   --  type conformant remote access-to-subprogram type. Secondly, a value
+   --  of a remote access-to-class-wide type can be converted only to another
+   --  remote access-to-class-wide type (RM E.2.3(17,20)).
+
+   procedure Validate_SP_Access_Object_Type_Decl (T : Entity_Id);
+   --  Check validity of declaration if shared passive unit. It should not
+   --  contain the declaration of an access-to-object type whose designated
+   --  type is a class-wide type ,task type or protected type. E.2.1(7).
+   --  T is the entity of the declared type.
+
+   procedure Validate_Static_Object_Name (N : Node_Id);
+   --  In the elaboration code of a preelaborated library unit, check
+   --  that we do not have the evaluation of a primary that is a name of
+   --  an object, unless the name is a static expression (RM 10.2.1(8)).
+   --  Non-static constant and variable are the targets, generic parameters
+   --  are not included because the generic declaration and body are
+   --  preelaborable.
+
+end Sem_Cat;
diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb
new file mode 100644
index 00000000000..2bbe0a50081
--- /dev/null
+++ b/gcc/ada/sem_ch10.adb
@@ -0,0 +1,3072 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             S E M _ C H 1 0                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.402 $
+--                                                                          --
+--          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 Debug;    use Debug;
+with Einfo;    use Einfo;
+with Errout;   use Errout;
+with Exp_Util; use Exp_Util;
+with Fname;    use Fname;
+with Fname.UF; use Fname.UF;
+with Freeze;   use Freeze;
+with Impunit;  use Impunit;
+with Inline;   use Inline;
+with Lib;      use Lib;
+with Lib.Load; use Lib.Load;
+with Lib.Xref; use Lib.Xref;
+with Namet;    use Namet;
+with Nlists;   use Nlists;
+with Nmake;    use Nmake;
+with Opt;      use Opt;
+with Output;   use Output;
+with Restrict; use Restrict;
+with Sem;      use Sem;
+with Sem_Ch6;  use Sem_Ch6;
+with Sem_Ch7;  use Sem_Ch7;
+with Sem_Ch8;  use Sem_Ch8;
+with Sem_Dist; use Sem_Dist;
+with Sem_Prag; use Sem_Prag;
+with Sem_Util; use Sem_Util;
+with Sem_Warn; use Sem_Warn;
+with Stand;    use Stand;
+with Sinfo;    use Sinfo;
+with Sinfo.CN; use Sinfo.CN;
+with Sinput;   use Sinput;
+with Snames;   use Snames;
+with Style;    use Style;
+with Tbuild;   use Tbuild;
+with Ttypes;   use Ttypes;
+with Uname;    use Uname;
+
+package body Sem_Ch10 is
+
+   -----------------------
+   -- Local Subprograms --
+   -----------------------
+
+   procedure Analyze_Context (N : Node_Id);
+   --  Analyzes items in the context clause of compilation unit
+
+   procedure Check_With_Type_Clauses (N : Node_Id);
+   --  If N is a body, verify that any with_type clauses on the spec, or
+   --  on the spec of any parent, have a matching with_clause.
+
+   procedure Check_Private_Child_Unit (N : Node_Id);
+   --  If a with_clause mentions a private child unit, the compilation
+   --  unit must be a member of the same family, as described in 10.1.2 (8).
+
+   procedure Check_Stub_Level (N : Node_Id);
+   --  Verify that a stub is declared immediately within a compilation unit,
+   --  and not in an inner frame.
+
+   procedure Expand_With_Clause (Nam : Node_Id; N : Node_Id);
+   --  When a child unit appears in a context clause, the implicit withs on
+   --  parents are made explicit, and with clauses are inserted in the context
+   --  clause before the one for the child. If a parent in the with_clause
+   --  is a renaming, the implicit with_clause is on the renaming whose name
+   --  is mentioned in the with_clause, and not on the package it renames.
+   --  N is the compilation unit whose list of context items receives the
+   --  implicit with_clauses.
+
+   procedure Implicit_With_On_Parent (Child_Unit : Node_Id; N : Node_Id);
+   --  If the main unit is a child unit, implicit withs are also added for
+   --  all its ancestors.
+
+   procedure Install_Context_Clauses (N : Node_Id);
+   --  Subsidiary to previous one. Process only with_ and use_clauses for
+   --  current unit and its library unit if any.
+
+   procedure Install_Withed_Unit (With_Clause : Node_Id);
+   --  If the unit is not a child unit, make unit immediately visible.
+   --  The caller ensures that the unit is not already currently installed.
+
+   procedure Install_Parents (Lib_Unit : Node_Id; Is_Private : Boolean);
+   --  This procedure establishes the context for the compilation of a child
+   --  unit. If Lib_Unit is a child library spec then the context of the parent
+   --  is installed, and the parent itself made immediately visible, so that
+   --  the child unit is processed in the declarative region of the parent.
+   --  Install_Parents makes a recursive call to itself to ensure that all
+   --  parents are loaded in the nested case. If Lib_Unit is a library body,
+   --  the only effect of Install_Parents is to install the private decls of
+   --  the parents, because the visible parent declarations will have been
+   --  installed as part of the context of the corresponding spec.
+
+   procedure Install_Siblings (U_Name : Entity_Id; N : Node_Id);
+   --  In the compilation of a child unit, a child of any of the  ancestor
+   --  units is directly visible if it is visible, because the parent is in
+   --  an enclosing scope. Iterate over context to find child units of U_Name
+   --  or of some ancestor of it.
+
+   function Is_Child_Spec (Lib_Unit : Node_Id) return Boolean;
+   --  Lib_Unit is a library unit which may be a spec or a body. Is_Child_Spec
+   --  returns True if Lib_Unit is a library spec which is a child spec, i.e.
+   --  a library spec that has a parent. If the call to Is_Child_Spec returns
+   --  True, then Parent_Spec (Lib_Unit) is non-Empty and points to the
+   --  compilation unit for the parent spec.
+   --
+   --  Lib_Unit can also be a subprogram body that acts as its own spec. If
+   --  the Parent_Spec is  non-empty, this is also a child unit.
+
+   procedure Remove_With_Type_Clause (Name : Node_Id);
+   --  Remove imported type and its enclosing package from visibility, and
+   --  remove attributes of imported type so they don't interfere with its
+   --  analysis (should it appear otherwise in the context).
+
+   procedure Remove_Context_Clauses (N : Node_Id);
+   --  Subsidiary of previous one. Remove use_ and with_clauses.
+
+   procedure Remove_Parents (Lib_Unit : Node_Id);
+   --  Remove_Parents checks if Lib_Unit is a child spec. If so then the parent
+   --  contexts established by the corresponding call to Install_Parents are
+   --  removed. Remove_Parents contains a recursive call to itself to ensure
+   --  that all parents are removed in the nested case.
+
+   procedure Remove_Unit_From_Visibility (Unit_Name : Entity_Id);
+   --  Reset all visibility flags on unit after compiling it, either as a
+   --  main unit or as a unit in the context.
+
+   procedure Analyze_Proper_Body (N : Node_Id; Nam : Entity_Id);
+   --  Common processing for all stubs (subprograms, tasks, packages, and
+   --  protected cases). N is the stub to be analyzed. Once the subunit
+   --  name is established, load and analyze. Nam is the non-overloadable
+   --  entity for which the proper body provides a completion. Subprogram
+   --  stubs are handled differently because they can be declarations.
+
+   ------------------------------
+   -- Analyze_Compilation_Unit --
+   ------------------------------
+
+   procedure Analyze_Compilation_Unit (N : Node_Id) is
+      Unit_Node     : constant Node_Id := Unit (N);
+      Lib_Unit      : Node_Id          := Library_Unit (N);
+      Spec_Id       : Node_Id;
+      Main_Cunit    : constant Node_Id := Cunit (Main_Unit);
+      Par_Spec_Name : Unit_Name_Type;
+      Unum          : Unit_Number_Type;
+
+      procedure Generate_Parent_References (N : Node_Id; P_Id : Entity_Id);
+      --  Generate cross-reference information for the parents of child units.
+      --  N is a defining_program_unit_name, and P_Id is the immediate parent.
+
+      --------------------------------
+      -- Generate_Parent_References --
+      --------------------------------
+
+      procedure Generate_Parent_References (N : Node_Id; P_Id : Entity_Id) is
+         Pref   : Node_Id;
+         P_Name : Entity_Id := P_Id;
+
+      begin
+         Pref   := Name (Parent (Defining_Entity (N)));
+
+         if Nkind (Pref) = N_Expanded_Name then
+
+            --  Done already, if the unit has been compiled indirectly as
+            --  part of the closure of its context because of inlining.
+
+            return;
+         end if;
+
+         while Nkind (Pref) = N_Selected_Component loop
+            Change_Selected_Component_To_Expanded_Name (Pref);
+            Set_Entity (Pref, P_Name);
+            Set_Etype (Pref, Etype (P_Name));
+            Generate_Reference (P_Name, Pref, 'r');
+            Pref   := Prefix (Pref);
+            P_Name := Scope (P_Name);
+         end loop;
+
+         --  The guard here on P_Name is to handle the error condition where
+         --  the parent unit is missing because the file was not found.
+
+         if Present (P_Name) then
+            Set_Entity (Pref, P_Name);
+            Set_Etype (Pref, Etype (P_Name));
+            Generate_Reference (P_Name, Pref, 'r');
+            Style.Check_Identifier (Pref, P_Name);
+         end if;
+      end Generate_Parent_References;
+
+   --  Start of processing for Analyze_Compilation_Unit
+
+   begin
+      Process_Compilation_Unit_Pragmas (N);
+
+      --  If the unit is a subunit whose parent has not been analyzed (which
+      --  indicates that the main unit is a subunit, either the current one or
+      --  one of its descendents) then the subunit is compiled as part of the
+      --  analysis of the parent, which we proceed to do. Basically this gets
+      --  handled from the top down and we don't want to do anything at this
+      --  level (i.e. this subunit will be handled on the way down from the
+      --  parent), so at this level we immediately return. If the subunit
+      --  ends up not analyzed, it means that the parent did not contain a
+      --  stub for it, or that there errors were dectected in some ancestor.
+
+      if Nkind (Unit_Node) = N_Subunit
+        and then not Analyzed (Lib_Unit)
+      then
+         Semantics (Lib_Unit);
+
+         if not Analyzed (Proper_Body (Unit_Node)) then
+            if Errors_Detected > 0 then
+               Error_Msg_N ("subunit not analyzed (errors in parent unit)", N);
+            else
+               Error_Msg_N ("missing stub for subunit", N);
+            end if;
+         end if;
+
+         return;
+      end if;
+
+      --  Analyze context (this will call Sem recursively for with'ed units)
+
+      Analyze_Context (N);
+
+      --  If the unit is a package body, the spec is already loaded and must
+      --  be analyzed first, before we analyze the body.
+
+      if Nkind (Unit_Node) = N_Package_Body then
+
+         --  If no Lib_Unit, then there was a serious previous error, so
+         --  just ignore the entire analysis effort
+
+         if No (Lib_Unit) then
+            return;
+
+         else
+            Semantics (Lib_Unit);
+            Check_Unused_Withs (Get_Cunit_Unit_Number (Lib_Unit));
+
+            --  Verify that the library unit is a package declaration.
+
+            if Nkind (Unit (Lib_Unit)) /= N_Package_Declaration
+                 and then
+               Nkind (Unit (Lib_Unit)) /= N_Generic_Package_Declaration
+            then
+               Error_Msg_N
+                 ("no legal package declaration for package body", N);
+               return;
+
+            --  Otherwise, the entity in the declaration is visible. Update
+            --  the version to reflect dependence of this body on the spec.
+
+            else
+               Spec_Id := Defining_Entity (Unit (Lib_Unit));
+               Set_Is_Immediately_Visible (Spec_Id, True);
+               Version_Update (N, Lib_Unit);
+
+               if Nkind (Defining_Unit_Name (Unit_Node))
+                 = N_Defining_Program_Unit_Name
+               then
+                  Generate_Parent_References (Unit_Node, Scope (Spec_Id));
+               end if;
+            end if;
+         end if;
+
+      --  If the unit is a subprogram body, then we similarly need to analyze
+      --  its spec. However, things are a little simpler in this case, because
+      --  here, this analysis is done only for error checking and consistency
+      --  purposes, so there's nothing else to be done.
+
+      elsif Nkind (Unit_Node) = N_Subprogram_Body then
+         if Acts_As_Spec (N) then
+
+            --  If the subprogram body is a child unit, we must create a
+            --  declaration for it, in order to properly load the parent(s).
+            --  After this, the original unit does not acts as a spec, because
+            --  there is an explicit one. If this  unit appears in a context
+            --  clause, then an implicit with on the parent will be added when
+            --  installing the context. If this is the main unit, there is no
+            --  Unit_Table entry for the declaration, (It has the unit number
+            --  of the main unit) and code generation is unaffected.
+
+            Unum := Get_Cunit_Unit_Number (N);
+            Par_Spec_Name := Get_Parent_Spec_Name (Unit_Name (Unum));
+
+            if Par_Spec_Name /= No_Name then
+               Unum :=
+                 Load_Unit
+                   (Load_Name  => Par_Spec_Name,
+                    Required   => True,
+                    Subunit    => False,
+                    Error_Node => N);
+
+               if Unum /= No_Unit then
+
+                  --  Build subprogram declaration and attach parent unit to it
+                  --  This subprogram declaration does not come from source!
+
+                  declare
+                     Loc : constant Source_Ptr := Sloc (N);
+                     SCS : constant Boolean :=
+                             Get_Comes_From_Source_Default;
+
+                  begin
+                     Set_Comes_From_Source_Default (False);
+                     Lib_Unit :=
+                       Make_Compilation_Unit (Loc,
+                         Context_Items => New_Copy_List (Context_Items (N)),
+                         Unit =>
+                           Make_Subprogram_Declaration (Sloc (N),
+                             Specification =>
+                               Copy_Separate_Tree
+                                 (Specification (Unit_Node))),
+                         Aux_Decls_Node =>
+                           Make_Compilation_Unit_Aux (Loc));
+
+                     Set_Library_Unit (N, Lib_Unit);
+                     Set_Parent_Spec (Unit (Lib_Unit), Cunit (Unum));
+                     Semantics (Lib_Unit);
+                     Set_Acts_As_Spec (N, False);
+                     Set_Comes_From_Source_Default (SCS);
+                  end;
+               end if;
+            end if;
+
+         --  Here for subprogram with separate declaration
+
+         else
+            Semantics (Lib_Unit);
+            Check_Unused_Withs (Get_Cunit_Unit_Number (Lib_Unit));
+            Version_Update (N, Lib_Unit);
+         end if;
+
+         if Nkind (Defining_Unit_Name (Specification (Unit_Node))) =
+                                             N_Defining_Program_Unit_Name
+         then
+            Generate_Parent_References (
+              Specification (Unit_Node),
+                Scope (Defining_Entity (Unit (Lib_Unit))));
+         end if;
+      end if;
+
+      --  If it is a child unit, the parent must be elaborated first
+      --  and we update version, since we are dependent on our parent.
+
+      if Is_Child_Spec (Unit_Node) then
+
+         --  The analysis of the parent is done with style checks off
+
+         declare
+            Save_Style_Check : constant Boolean := Opt.Style_Check;
+            Save_C_Restrict  : constant Save_Compilation_Unit_Restrictions :=
+                                 Compilation_Unit_Restrictions_Save;
+
+         begin
+            if not GNAT_Mode then
+               Style_Check := False;
+            end if;
+
+            Semantics (Parent_Spec (Unit_Node));
+            Version_Update (N, Parent_Spec (Unit_Node));
+            Style_Check := Save_Style_Check;
+            Compilation_Unit_Restrictions_Restore (Save_C_Restrict);
+         end;
+      end if;
+
+      --  With the analysis done, install the context. Note that we can't
+      --  install the context from the with clauses as we analyze them,
+      --  because each with clause must be analyzed in a clean visibility
+      --  context, so we have to wait and install them all at once.
+
+      Install_Context (N);
+
+      if Is_Child_Spec (Unit_Node) then
+
+         --  Set the entities of all parents in the program_unit_name.
+
+         Generate_Parent_References (
+           Unit_Node, Defining_Entity (Unit (Parent_Spec (Unit_Node))));
+      end if;
+
+      --  All components of the context: with-clauses, library unit, ancestors
+      --  if any, (and their context)  are analyzed and installed. Now analyze
+      --  the unit itself, which is either a package, subprogram spec or body.
+
+      Analyze (Unit_Node);
+
+      --  The above call might have made Unit_Node an N_Subprogram_Body
+      --  from something else, so propagate any Acts_As_Spec flag.
+
+      if Nkind (Unit_Node) = N_Subprogram_Body
+        and then Acts_As_Spec (Unit_Node)
+      then
+         Set_Acts_As_Spec (N);
+      end if;
+
+      --  Treat compilation unit pragmas that appear after the library unit
+
+      if Present (Pragmas_After (Aux_Decls_Node (N))) then
+         declare
+            Prag_Node : Node_Id := First (Pragmas_After (Aux_Decls_Node (N)));
+
+         begin
+            while Present (Prag_Node) loop
+               Analyze (Prag_Node);
+               Next (Prag_Node);
+            end loop;
+         end;
+      end if;
+
+      --  Generate distribution stub files if requested and no error
+
+      if N = Main_Cunit
+        and then (Distribution_Stub_Mode = Generate_Receiver_Stub_Body
+                    or else
+                  Distribution_Stub_Mode = Generate_Caller_Stub_Body)
+        and then not Fatal_Error (Main_Unit)
+      then
+         if Is_RCI_Pkg_Spec_Or_Body (N) then
+
+            --  Regular RCI package
+
+            Add_Stub_Constructs (N);
+
+         elsif (Nkind (Unit_Node) = N_Package_Declaration
+                 and then Is_Shared_Passive (Defining_Entity
+                                              (Specification (Unit_Node))))
+           or else (Nkind (Unit_Node) = N_Package_Body
+                     and then
+                       Is_Shared_Passive (Corresponding_Spec (Unit_Node)))
+         then
+            --  Shared passive package
+
+            Add_Stub_Constructs (N);
+
+         elsif Nkind (Unit_Node) = N_Package_Instantiation
+           and then
+             Is_Remote_Call_Interface
+               (Defining_Entity (Specification (Instance_Spec (Unit_Node))))
+         then
+            --  Instantiation of a RCI generic package
+
+            Add_Stub_Constructs (N);
+         end if;
+
+         --  Reanalyze the unit with the new constructs
+
+         Analyze (Unit_Node);
+      end if;
+
+      if Nkind (Unit_Node) = N_Package_Declaration
+        or else Nkind (Unit_Node) in N_Generic_Declaration
+        or else Nkind (Unit_Node) = N_Package_Renaming_Declaration
+        or else Nkind (Unit_Node) = N_Subprogram_Declaration
+      then
+         Remove_Unit_From_Visibility (Defining_Entity (Unit_Node));
+
+      elsif Nkind (Unit_Node) = N_Package_Body
+        or else (Nkind (Unit_Node) = N_Subprogram_Body
+                  and then not Acts_As_Spec (Unit_Node))
+      then
+         --  Bodies that are not the main unit are compiled if they
+         --  are generic or contain generic or inlined units. Their
+         --  analysis brings in the context of the corresponding spec
+         --  (unit declaration) which must be removed as well, to
+         --  return the compilation environment to its proper state.
+
+         Remove_Context (Lib_Unit);
+         Set_Is_Immediately_Visible (Defining_Entity (Unit (Lib_Unit)), False);
+      end if;
+
+      --  Last step is to deinstall the context we just installed
+      --  as well as the unit just compiled.
+
+      Remove_Context (N);
+
+      --  If this is the main unit and we are generating code, we must
+      --  check that all generic units in the context have a body if they
+      --  need it, even if they have not been instantiated. In the absence
+      --  of .ali files for generic units, we must force the load of the body,
+      --  just to produce the proper error if the body is absent. We skip this
+      --  verification if the main unit itself is generic.
+
+      if Get_Cunit_Unit_Number (N) = Main_Unit
+        and then Operating_Mode = Generate_Code
+        and then Expander_Active
+      then
+         --  Indicate that the main unit is now analyzed, to catch possible
+         --  circularities between it and generic bodies. Remove main unit
+         --  from visibility. This might seem superfluous, but the main unit
+         --  must not be visible in the generic body expansions that follow.
+
+         Set_Analyzed (N, True);
+         Set_Is_Immediately_Visible (Cunit_Entity (Main_Unit), False);
+
+         declare
+            Item  : Node_Id;
+            Nam   : Entity_Id;
+            Un    : Unit_Number_Type;
+
+            Save_Style_Check : constant Boolean := Opt.Style_Check;
+            Save_C_Restrict  : constant Save_Compilation_Unit_Restrictions :=
+                                 Compilation_Unit_Restrictions_Save;
+
+         begin
+            Item := First (Context_Items (N));
+
+            while Present (Item) loop
+
+               if Nkind (Item) = N_With_Clause
+                  and then not Implicit_With (Item)
+               then
+                  Nam := Entity (Name (Item));
+
+                  if (Ekind (Nam) = E_Generic_Procedure
+                       and then not Is_Intrinsic_Subprogram (Nam))
+                    or else (Ekind (Nam) = E_Generic_Function
+                              and then not Is_Intrinsic_Subprogram (Nam))
+                    or else (Ekind (Nam) = E_Generic_Package
+                              and then Unit_Requires_Body (Nam))
+                  then
+                     Opt.Style_Check := False;
+
+                     if Present (Renamed_Object (Nam)) then
+                        Un :=
+                           Load_Unit
+                             (Load_Name  => Get_Body_Name
+                                              (Get_Unit_Name
+                                                (Unit_Declaration_Node
+                                                  (Renamed_Object (Nam)))),
+                              Required   => False,
+                              Subunit    => False,
+                              Error_Node => N,
+                              Renamings  => True);
+                     else
+                        Un :=
+                          Load_Unit
+                            (Load_Name  => Get_Body_Name
+                                             (Get_Unit_Name (Item)),
+                             Required   => False,
+                             Subunit    => False,
+                             Error_Node => N,
+                             Renamings  => True);
+                     end if;
+
+                     if Un = No_Unit then
+                        Error_Msg_NE
+                          ("body of generic unit& not found", Item, Nam);
+                        exit;
+
+                     elsif not Analyzed (Cunit (Un))
+                       and then Un /= Main_Unit
+                     then
+                        Opt.Style_Check := False;
+                        Semantics (Cunit (Un));
+                     end if;
+                  end if;
+               end if;
+
+               Next (Item);
+            end loop;
+
+            Style_Check := Save_Style_Check;
+            Compilation_Unit_Restrictions_Restore (Save_C_Restrict);
+         end;
+      end if;
+
+      --  Deal with creating elaboration Boolean if needed. We create an
+      --  elaboration boolean only for units that come from source since
+      --  units manufactured by the compiler never need elab checks.
+
+      if Comes_From_Source (N)
+        and then
+          (Nkind (Unit (N)) =  N_Package_Declaration         or else
+           Nkind (Unit (N)) =  N_Generic_Package_Declaration or else
+           Nkind (Unit (N)) =  N_Subprogram_Declaration      or else
+           Nkind (Unit (N)) =  N_Generic_Subprogram_Declaration)
+      then
+         declare
+            Loc  : constant Source_Ptr := Sloc (N);
+            Unum : constant Unit_Number_Type := Get_Source_Unit (Loc);
+
+         begin
+            Spec_Id := Defining_Entity (Unit (N));
+            Generate_Definition (Spec_Id);
+
+            --  See if an elaboration entity is required for possible
+            --  access before elaboration checking. Note that we must
+            --  allow for this even if -gnatE is not set, since a client
+            --  may be compiled in -gnatE mode and reference the entity.
+
+            --  Case of units which do not require elaboration checks
+
+            if
+               --  Pure units do not need checks
+
+                 Is_Pure (Spec_Id)
+
+               --  Preelaborated units do not need checks
+
+                 or else Is_Preelaborated (Spec_Id)
+
+               --  No checks needed if pagma Elaborate_Body present
+
+                 or else Has_Pragma_Elaborate_Body (Spec_Id)
+
+               --  No checks needed if unit does not require a body
+
+                 or else not Unit_Requires_Body (Spec_Id)
+
+               --  No checks needed for predefined files
+
+                 or else Is_Predefined_File_Name (Unit_File_Name (Unum))
+
+               --  No checks required if no separate spec
+
+                 or else Acts_As_Spec (N)
+            then
+               --  This is a case where we only need the entity for
+               --  checking to prevent multiple elaboration checks.
+
+               Set_Elaboration_Entity_Required (Spec_Id, False);
+
+            --  Case of elaboration entity is required for access before
+            --  elaboration checking (so certainly we must build it!)
+
+            else
+               Set_Elaboration_Entity_Required (Spec_Id, True);
+            end if;
+
+            Build_Elaboration_Entity (N, Spec_Id);
+         end;
+      end if;
+
+      --  Finally, freeze the compilation unit entity. This for sure is needed
+      --  because of some warnings that can be output (see Freeze_Subprogram),
+      --  but may in general be required. If freezing actions result, place
+      --  them in the compilation unit actions list, and analyze them.
+
+      declare
+         Loc : constant Source_Ptr := Sloc (N);
+         L   : constant List_Id :=
+                 Freeze_Entity (Cunit_Entity (Current_Sem_Unit), Loc);
+
+      begin
+         while Is_Non_Empty_List (L) loop
+            Insert_Library_Level_Action (Remove_Head (L));
+         end loop;
+      end;
+
+      Set_Analyzed (N);
+
+      if Nkind (Unit_Node) = N_Package_Declaration
+        and then Get_Cunit_Unit_Number (N) /= Main_Unit
+        and then Front_End_Inlining
+        and then Expander_Active
+      then
+         Check_Body_For_Inlining (N, Defining_Entity (Unit_Node));
+      end if;
+   end Analyze_Compilation_Unit;
+
+   ---------------------
+   -- Analyze_Context --
+   ---------------------
+
+   procedure Analyze_Context (N : Node_Id) is
+      Item  : Node_Id;
+
+   begin
+      --  Loop through context items
+
+      Item := First (Context_Items (N));
+      while Present (Item) loop
+
+         --  For with clause, analyze the with clause, and then update
+         --  the version, since we are dependent on a unit that we with.
+
+         if Nkind (Item) = N_With_Clause then
+
+            --  Skip analyzing with clause if no unit, nothing to do (this
+            --  happens for a with that references a non-existant unit)
+
+            if Present (Library_Unit (Item)) then
+               Analyze (Item);
+            end if;
+
+            if not Implicit_With (Item) then
+               Version_Update (N, Library_Unit (Item));
+            end if;
+
+         --  But skip use clauses at this stage, since we don't want to do
+         --  any installing of potentially use visible entities until we
+         --  we actually install the complete context (in Install_Context).
+         --  Otherwise things can get installed in the wrong context.
+         --  Similarly, pragmas are analyzed in Install_Context, after all
+         --  the implicit with's on parent units are generated.
+
+         else
+            null;
+         end if;
+
+         Next (Item);
+      end loop;
+   end Analyze_Context;
+
+   -------------------------------
+   -- Analyze_Package_Body_Stub --
+   -------------------------------
+
+   procedure Analyze_Package_Body_Stub (N : Node_Id) is
+      Id   : constant Entity_Id := Defining_Identifier (N);
+      Nam  : Entity_Id;
+
+   begin
+      --  The package declaration must be in the current declarative part.
+
+      Check_Stub_Level (N);
+      Nam := Current_Entity_In_Scope (Id);
+
+      if No (Nam) or else not Is_Package (Nam) then
+         Error_Msg_N ("missing specification for package stub", N);
+
+      elsif Has_Completion (Nam)
+        and then Present (Corresponding_Body (Unit_Declaration_Node (Nam)))
+      then
+         Error_Msg_N ("duplicate or redundant stub for package", N);
+
+      else
+         --  Indicate that the body of the package exists. If we are doing
+         --  only semantic analysis, the stub stands for the body. If we are
+         --  generating code, the existence of the body will be confirmed
+         --  when we load the proper body.
+
+         Set_Has_Completion (Nam);
+         Set_Scope (Defining_Entity (N), Current_Scope);
+         Analyze_Proper_Body (N, Nam);
+      end if;
+   end Analyze_Package_Body_Stub;
+
+   -------------------------
+   -- Analyze_Proper_Body --
+   -------------------------
+
+   procedure Analyze_Proper_Body (N : Node_Id; Nam : Entity_Id) is
+      Subunit_Name      : constant Unit_Name_Type := Get_Unit_Name (N);
+      Unum              : Unit_Number_Type;
+      Subunit_Not_Found : Boolean := False;
+
+      procedure Optional_Subunit;
+      --  This procedure is called when the main unit is a stub, or when we
+      --  are not generating code. In such a case, we analyze the subunit if
+      --  present, which is user-friendly and in fact required for ASIS, but
+      --  we don't complain if the subunit is missing.
+
+      ----------------------
+      -- Optional_Subunit --
+      ----------------------
+
+      procedure Optional_Subunit is
+         Comp_Unit : Node_Id;
+
+      begin
+         --  Try to load subunit, but ignore any errors that occur during
+         --  the loading of the subunit, by using the special feature in
+         --  Errout to ignore all errors. Note that Fatal_Error will still
+         --  be set, so we will be able to check for this case below.
+
+         Ignore_Errors_Enable := Ignore_Errors_Enable + 1;
+         Unum :=
+           Load_Unit
+             (Load_Name  => Subunit_Name,
+              Required   => False,
+              Subunit    => True,
+              Error_Node => N);
+         Ignore_Errors_Enable := Ignore_Errors_Enable - 1;
+
+         --  All done if we successfully loaded the subunit
+
+         if Unum /= No_Unit and then not Fatal_Error (Unum) then
+            Comp_Unit := Cunit (Unum);
+
+            Set_Corresponding_Stub (Unit (Comp_Unit), N);
+            Analyze_Subunit (Comp_Unit);
+            Set_Library_Unit (N, Comp_Unit);
+
+         elsif Unum = No_Unit
+           and then Present (Nam)
+         then
+            if Is_Protected_Type (Nam) then
+               Set_Corresponding_Body (Parent (Nam), Defining_Identifier (N));
+            else
+               Set_Corresponding_Body (
+                 Unit_Declaration_Node (Nam), Defining_Identifier (N));
+            end if;
+         end if;
+      end Optional_Subunit;
+
+   --  Start of processing for Analyze_Proper_Body
+
+   begin
+      --  If the subunit is already loaded, it means that the main unit
+      --  is a subunit, and that the current unit is one of its parents
+      --  which was being analyzed to provide the needed context for the
+      --  analysis of the subunit. In this case we analyze the subunit and
+      --  continue with the parent, without looking a subsequent subunits.
+
+      if Is_Loaded (Subunit_Name) then
+
+         --  If the proper body is already linked to the stub node,
+         --  the stub is in a generic unit and just needs analyzing.
+
+         if Present (Library_Unit (N)) then
+            Set_Corresponding_Stub (Unit (Library_Unit (N)), N);
+            Analyze_Subunit (Library_Unit (N));
+
+         --  Otherwise we must load the subunit and link to it
+
+         else
+            --  Load the subunit, this must work, since we originally
+            --  loaded the subunit earlier on. So this will not really
+            --  load it, just give access to it.
+
+            Unum :=
+              Load_Unit
+                (Load_Name  => Subunit_Name,
+                 Required   => True,
+                 Subunit    => False,
+                 Error_Node => N);
+
+            --  And analyze the subunit in the parent context (note that we
+            --  do not call Semantics, since that would remove the parent
+            --  context). Because of this, we have to manually reset the
+            --  compiler state to Analyzing since it got destroyed by Load.
+
+            if Unum /= No_Unit then
+               Compiler_State := Analyzing;
+               Set_Corresponding_Stub (Unit (Cunit (Unum)), N);
+               Analyze_Subunit (Cunit (Unum));
+               Set_Library_Unit (N, Cunit (Unum));
+            end if;
+         end if;
+
+      --  If the main unit is a subunit, then we are just performing semantic
+      --  analysis on that subunit, and any other subunits of any parent unit
+      --  should be ignored, except that if we are building trees for ASIS
+      --  usage we want to annotate the stub properly.
+
+      elsif Nkind (Unit (Cunit (Main_Unit))) = N_Subunit
+        and then Subunit_Name /= Unit_Name (Main_Unit)
+      then
+         if Tree_Output then
+            Optional_Subunit;
+         end if;
+
+         --  But before we return, set the flag for unloaded subunits. This
+         --  will suppress junk warnings of variables in the same declarative
+         --  part (or a higher level one) that are in danger of looking unused
+         --  when in fact there might be a declaration in the subunit that we
+         --  do not intend to load.
+
+         Unloaded_Subunits := True;
+         return;
+
+      --  If the subunit is not already loaded, and we are generating code,
+      --  then this is the case where compilation started from the parent,
+      --  and we are generating code for an entire subunit tree. In that
+      --  case we definitely need to load the subunit.
+
+      --  In order to continue the analysis with the rest of the parent,
+      --  and other subunits, we load the unit without requiring its
+      --  presence, and emit a warning if not found, rather than terminating
+      --  the compilation abruptly, as for other missing file problems.
+
+      elsif Operating_Mode = Generate_Code then
+
+         --  If the proper body is already linked to the stub node,
+         --  the stub is in a generic unit and just needs analyzing.
+
+         --  We update the version. Although we are not technically
+         --  semantically dependent on the subunit, given our approach
+         --  of macro substitution of subunits, it makes sense to
+         --  include it in the version identification.
+
+         if Present (Library_Unit (N)) then
+            Set_Corresponding_Stub (Unit (Library_Unit (N)), N);
+            Analyze_Subunit (Library_Unit (N));
+            Version_Update (Cunit (Main_Unit), Library_Unit (N));
+
+         --  Otherwise we must load the subunit and link to it
+
+         else
+            Unum :=
+              Load_Unit
+                (Load_Name  => Subunit_Name,
+                 Required   => False,
+                 Subunit    => True,
+                 Error_Node => N);
+
+            if Operating_Mode = Generate_Code
+              and then Unum = No_Unit
+            then
+               Error_Msg_Name_1 := Subunit_Name;
+               Error_Msg_Name_2 :=
+                 Get_File_Name (Subunit_Name, Subunit => True);
+               Error_Msg_N
+                 ("subunit% in file{ not found!?", N);
+               Subunits_Missing := True;
+               Subunit_Not_Found := True;
+            end if;
+
+            --  Load_Unit may reset Compiler_State, since it may have been
+            --  necessary to parse an additional units, so we make sure
+            --  that we reset it to the Analyzing state.
+
+            Compiler_State := Analyzing;
+
+            if Unum /= No_Unit and then not Fatal_Error (Unum) then
+
+               if Debug_Flag_L then
+                  Write_Str ("*** Loaded subunit from stub. Analyze");
+                  Write_Eol;
+               end if;
+
+               declare
+                  Comp_Unit : constant Node_Id := Cunit (Unum);
+
+               begin
+                  --  Check for child unit instead of subunit
+
+                  if Nkind (Unit (Comp_Unit)) /= N_Subunit then
+                     Error_Msg_N
+                       ("expected SEPARATE subunit, found child unit",
+                        Cunit_Entity (Unum));
+
+                  --  OK, we have a subunit, so go ahead and analyze it,
+                  --  and set Scope of entity in stub, for ASIS use.
+
+                  else
+                     Set_Corresponding_Stub (Unit (Comp_Unit), N);
+                     Analyze_Subunit (Comp_Unit);
+                     Set_Library_Unit (N, Comp_Unit);
+
+                     --  We update the version. Although we are not technically
+                     --  semantically dependent on the subunit, given our
+                     --  approach of macro substitution of subunits, it makes
+                     --  sense to include it in the version identification.
+
+                     Version_Update (Cunit (Main_Unit), Comp_Unit);
+                  end if;
+               end;
+            end if;
+         end if;
+
+         --  The remaining case is when the subunit is not already loaded and
+         --  we are not generating code. In this case we are just performing
+         --  semantic analysis on the parent, and we are not interested in
+         --  the subunit. For subprograms, analyze the stub as a body. For
+         --  other entities the stub has already been marked as completed.
+
+      else
+         Optional_Subunit;
+      end if;
+
+   end Analyze_Proper_Body;
+
+   ----------------------------------
+   -- Analyze_Protected_Body_Stub --
+   ----------------------------------
+
+   procedure Analyze_Protected_Body_Stub (N : Node_Id) is
+      Nam : Entity_Id := Current_Entity_In_Scope (Defining_Identifier (N));
+
+   begin
+      Check_Stub_Level (N);
+
+      --  First occurence of name may have been as an incomplete type.
+
+      if Present (Nam) and then Ekind (Nam) = E_Incomplete_Type then
+         Nam := Full_View (Nam);
+      end if;
+
+      if No (Nam)
+        or else not Is_Protected_Type (Etype (Nam))
+      then
+         Error_Msg_N ("missing specification for Protected body", N);
+      else
+         Set_Scope (Defining_Entity (N), Current_Scope);
+         Set_Has_Completion (Etype (Nam));
+         Analyze_Proper_Body (N, Etype (Nam));
+      end if;
+   end Analyze_Protected_Body_Stub;
+
+   ----------------------------------
+   -- Analyze_Subprogram_Body_Stub --
+   ----------------------------------
+
+   --  A subprogram body stub can appear with or without a previous
+   --  specification. If there is one, the analysis of the body will
+   --  find it and verify conformance.  The formals appearing in the
+   --  specification of the stub play no role, except for requiring an
+   --  additional conformance check. If there is no previous subprogram
+   --  declaration, the stub acts as a spec, and provides the defining
+   --  entity for the subprogram.
+
+   procedure Analyze_Subprogram_Body_Stub (N : Node_Id) is
+      Decl : Node_Id;
+
+   begin
+      Check_Stub_Level (N);
+
+      --  Verify that the identifier for the stub is unique within this
+      --  declarative part.
+
+      if Nkind (Parent (N)) = N_Block_Statement
+        or else Nkind (Parent (N)) = N_Package_Body
+        or else Nkind (Parent (N)) = N_Subprogram_Body
+      then
+         Decl := First (Declarations (Parent (N)));
+
+         while Present (Decl)
+           and then Decl /= N
+         loop
+            if Nkind (Decl) = N_Subprogram_Body_Stub
+              and then (Chars (Defining_Unit_Name (Specification (Decl)))
+                      = Chars (Defining_Unit_Name (Specification (N))))
+            then
+               Error_Msg_N ("identifier for stub is not unique", N);
+            end if;
+
+            Next (Decl);
+         end loop;
+      end if;
+
+      --  Treat stub as a body, which checks conformance if there is a previous
+      --  declaration, or else introduces entity and its signature.
+
+      Analyze_Subprogram_Body (N);
+
+      if Errors_Detected = 0 then
+         Analyze_Proper_Body (N, Empty);
+      end if;
+
+   end Analyze_Subprogram_Body_Stub;
+
+   ---------------------
+   -- Analyze_Subunit --
+   ---------------------
+
+   --  A subunit is compiled either by itself (for semantic checking)
+   --  or as part of compiling the parent (for code generation). In
+   --  either case, by the time we actually process the subunit, the
+   --  parent has already been installed and analyzed. The node N is
+   --  a compilation unit, whose context needs to be treated here,
+   --  because we come directly here from the parent without calling
+   --  Analyze_Compilation_Unit.
+
+   --  The compilation context includes the explicit context of the
+   --  subunit, and the context of the parent, together with the parent
+   --  itself. In order to compile the current context, we remove the
+   --  one inherited from the parent, in order to have a clean visibility
+   --  table. We restore the parent context before analyzing the proper
+   --  body itself. On exit, we remove only the explicit context of the
+   --  subunit.
+
+   procedure Analyze_Subunit (N : Node_Id) is
+      Lib_Unit : constant Node_Id   := Library_Unit (N);
+      Par_Unit : constant Entity_Id := Current_Scope;
+
+      Lib_Spec        : Node_Id := Library_Unit (Lib_Unit);
+      Num_Scopes      : Int := 0;
+      Use_Clauses     : array (1 .. Scope_Stack.Last) of Node_Id;
+      Enclosing_Child : Entity_Id := Empty;
+
+      procedure Analyze_Subunit_Context;
+      --  Capture names in use clauses of the subunit. This must be done
+      --  before re-installing parent declarations, because items in the
+      --  context must not be hidden by declarations local to the parent.
+
+      procedure Re_Install_Parents (L : Node_Id; Scop : Entity_Id);
+      --  Recursive procedure to restore scope of all ancestors of subunit,
+      --  from outermost in. If parent is not a subunit, the call to install
+      --  context installs context of spec and (if parent is a child unit)
+      --  the context of its parents as well. It is confusing that parents
+      --  should be treated differently in both cases, but the semantics are
+      --  just not identical.
+
+      procedure Re_Install_Use_Clauses;
+      --  As part of the removal of the parent scope, the use clauses are
+      --  removed, to be reinstalled when the context of the subunit has
+      --  been analyzed. Use clauses may also have been affected by the
+      --  analysis of the context of the subunit, so they have to be applied
+      --  again, to insure that the compilation environment of the rest of
+      --  the parent unit is identical.
+
+      procedure Remove_Scope;
+      --  Remove current scope from scope stack, and preserve the list
+      --  of use clauses in it, to be reinstalled after context is analyzed.
+
+      ------------------------------
+      --  Analyze_Subunit_Context --
+      ------------------------------
+
+      procedure Analyze_Subunit_Context is
+         Item      :  Node_Id;
+         Nam       :  Node_Id;
+         Unit_Name : Entity_Id;
+
+      begin
+         Analyze_Context (N);
+         Item := First (Context_Items (N));
+
+         --  make withed units immediately visible. If child unit, make the
+         --  ultimate parent immediately visible.
+
+         while Present (Item) loop
+
+            if Nkind (Item) = N_With_Clause then
+               Unit_Name := Entity (Name (Item));
+
+               while Is_Child_Unit (Unit_Name) loop
+                  Set_Is_Visible_Child_Unit (Unit_Name);
+                  Unit_Name := Scope (Unit_Name);
+               end loop;
+
+               if not Is_Immediately_Visible (Unit_Name) then
+                  Set_Is_Immediately_Visible (Unit_Name);
+                  Set_Context_Installed (Item);
+               end if;
+
+            elsif Nkind (Item) = N_Use_Package_Clause then
+               Nam := First (Names (Item));
+
+               while Present (Nam) loop
+                  Analyze (Nam);
+                  Next (Nam);
+               end loop;
+
+            elsif Nkind (Item) = N_Use_Type_Clause then
+               Nam := First (Subtype_Marks (Item));
+
+               while Present (Nam) loop
+                  Analyze (Nam);
+                  Next (Nam);
+               end loop;
+            end if;
+
+            Next (Item);
+         end loop;
+
+         Item := First (Context_Items (N));
+
+         --  reset visibility of withed units. They will be made visible
+         --  again when we install the subunit context.
+
+         while Present (Item) loop
+
+            if Nkind (Item) = N_With_Clause then
+               Unit_Name := Entity (Name (Item));
+
+               while Is_Child_Unit (Unit_Name) loop
+                  Set_Is_Visible_Child_Unit (Unit_Name, False);
+                  Unit_Name := Scope (Unit_Name);
+               end loop;
+
+               if Context_Installed (Item) then
+                  Set_Is_Immediately_Visible (Unit_Name, False);
+                  Set_Context_Installed (Item, False);
+               end if;
+            end if;
+
+            Next (Item);
+         end loop;
+
+      end Analyze_Subunit_Context;
+
+      ------------------------
+      -- Re_Install_Parents --
+      ------------------------
+
+      procedure Re_Install_Parents (L : Node_Id; Scop : Entity_Id) is
+         E : Entity_Id;
+
+      begin
+         if Nkind (Unit (L)) = N_Subunit then
+            Re_Install_Parents (Library_Unit (L), Scope (Scop));
+         end if;
+
+         Install_Context (L);
+
+         --  If the subunit occurs within a child unit, we must restore the
+         --  immediate visibility of any siblings that may occur in context.
+
+         if Present (Enclosing_Child) then
+            Install_Siblings (Enclosing_Child, L);
+         end if;
+
+         New_Scope (Scop);
+
+         if Scop /= Par_Unit then
+            Set_Is_Immediately_Visible (Scop);
+         end if;
+
+         E := First_Entity (Current_Scope);
+
+         while Present (E) loop
+            Set_Is_Immediately_Visible (E);
+            Next_Entity (E);
+         end loop;
+
+         --  A subunit appears within a body, and for a nested subunits
+         --  all the parents are bodies. Restore full visibility of their
+         --  private entities.
+
+         if Ekind (Scop) = E_Package then
+            Set_In_Package_Body (Scop);
+            Install_Private_Declarations (Scop);
+         end if;
+      end Re_Install_Parents;
+
+      ----------------------------
+      -- Re_Install_Use_Clauses --
+      ----------------------------
+
+      procedure Re_Install_Use_Clauses is
+         U  : Node_Id;
+
+      begin
+         for J in reverse 1 .. Num_Scopes loop
+            U := Use_Clauses (J);
+            Scope_Stack.Table (Scope_Stack.Last - J + 1).First_Use_Clause := U;
+            Install_Use_Clauses (U);
+         end loop;
+      end Re_Install_Use_Clauses;
+
+      ------------------
+      -- Remove_Scope --
+      ------------------
+
+      procedure Remove_Scope is
+         E : Entity_Id;
+
+      begin
+         Num_Scopes := Num_Scopes + 1;
+         Use_Clauses (Num_Scopes) :=
+               Scope_Stack.Table (Scope_Stack.Last).First_Use_Clause;
+         E := First_Entity (Current_Scope);
+
+         while Present (E) loop
+            Set_Is_Immediately_Visible (E, False);
+            Next_Entity (E);
+         end loop;
+
+         if Is_Child_Unit (Current_Scope) then
+            Enclosing_Child := Current_Scope;
+         end if;
+
+         Pop_Scope;
+      end Remove_Scope;
+
+   --  Start of processing for Analyze_Subunit
+
+   begin
+      if not Is_Empty_List (Context_Items (N)) then
+
+         --  Save current use clauses.
+
+         Remove_Scope;
+         Remove_Context (Lib_Unit);
+
+         --  Now remove parents and their context, including enclosing
+         --  subunits and the outer parent body which is not a subunit.
+
+         if Present (Lib_Spec) then
+            Remove_Context (Lib_Spec);
+
+            while Nkind (Unit (Lib_Spec)) = N_Subunit loop
+               Lib_Spec := Library_Unit (Lib_Spec);
+               Remove_Scope;
+               Remove_Context (Lib_Spec);
+            end loop;
+
+            if Nkind (Unit (Lib_Unit)) = N_Subunit then
+               Remove_Scope;
+            end if;
+
+            if Nkind (Unit (Lib_Spec)) = N_Package_Body then
+               Remove_Context (Library_Unit (Lib_Spec));
+            end if;
+         end if;
+
+         Analyze_Subunit_Context;
+         Re_Install_Parents (Lib_Unit, Par_Unit);
+
+         --  If the context includes a child unit of the parent of the
+         --  subunit, the parent will have been removed from visibility,
+         --  after compiling that cousin in the context. The visibility
+         --  of the parent must be restored now. This also applies if the
+         --  context includes another subunit of the same parent which in
+         --  turn includes a child unit in its context.
+
+         if Ekind (Par_Unit) = E_Package then
+            if not Is_Immediately_Visible (Par_Unit)
+              or else (Present (First_Entity (Par_Unit))
+                        and then not Is_Immediately_Visible
+                                      (First_Entity (Par_Unit)))
+            then
+               Set_Is_Immediately_Visible   (Par_Unit);
+               Install_Visible_Declarations (Par_Unit);
+               Install_Private_Declarations (Par_Unit);
+            end if;
+         end if;
+
+         Re_Install_Use_Clauses;
+         Install_Context (N);
+
+         --  If the subunit is within a child unit, then siblings of any
+         --  parent unit that appear in the context clause of the subunit
+         --  must also be made immediately visible.
+
+         if Present (Enclosing_Child) then
+            Install_Siblings (Enclosing_Child, N);
+         end if;
+
+      end if;
+
+      Analyze (Proper_Body (Unit (N)));
+      Remove_Context (N);
+
+   end Analyze_Subunit;
+
+   ----------------------------
+   -- Analyze_Task_Body_Stub --
+   ----------------------------
+
+   procedure Analyze_Task_Body_Stub (N : Node_Id) is
+      Nam : Entity_Id := Current_Entity_In_Scope (Defining_Identifier (N));
+      Loc : constant Source_Ptr := Sloc (N);
+
+   begin
+      Check_Stub_Level (N);
+
+      --  First occurence of name may have been as an incomplete type.
+
+      if Present (Nam) and then Ekind (Nam) = E_Incomplete_Type then
+         Nam := Full_View (Nam);
+      end if;
+
+      if No (Nam)
+        or else not Is_Task_Type (Etype (Nam))
+      then
+         Error_Msg_N ("missing specification for task body", N);
+      else
+         Set_Scope (Defining_Entity (N), Current_Scope);
+         Set_Has_Completion (Etype (Nam));
+         Analyze_Proper_Body (N, Etype (Nam));
+
+         --  Set elaboration flag to indicate that entity is callable.
+         --  This cannot be done in the expansion of the body  itself,
+         --  because the proper body is not in a declarative part. This
+         --  is only done if expansion is active, because the context
+         --  may be generic and the flag not defined yet.
+
+         if Expander_Active then
+            Insert_After (N,
+              Make_Assignment_Statement (Loc,
+                Name =>
+                  Make_Identifier (Loc,
+                    New_External_Name (Chars (Etype (Nam)), 'E')),
+                 Expression => New_Reference_To (Standard_True, Loc)));
+         end if;
+
+      end if;
+   end Analyze_Task_Body_Stub;
+
+   -------------------------
+   -- Analyze_With_Clause --
+   -------------------------
+
+   --  Analyze the declaration of a unit in a with clause. At end,
+   --  label the with clause with the defining entity for the unit.
+
+   procedure Analyze_With_Clause (N : Node_Id) is
+      Unit_Kind : constant Node_Kind := Nkind (Unit (Library_Unit (N)));
+      E_Name    : Entity_Id;
+      Par_Name  : Entity_Id;
+      Pref      : Node_Id;
+      U         : Node_Id;
+
+      Intunit : Boolean;
+      --  Set True if the unit currently being compiled is an internal unit
+
+      Save_Style_Check : constant Boolean := Opt.Style_Check;
+      Save_C_Restrict  : constant Save_Compilation_Unit_Restrictions :=
+                           Compilation_Unit_Restrictions_Save;
+
+   begin
+      --  We reset ordinary style checking during the analysis of a with'ed
+      --  unit, but we do NOT reset GNAT special analysis mode (the latter
+      --  definitely *does* apply to with'ed units).
+
+      if not GNAT_Mode then
+         Style_Check := False;
+      end if;
+
+      --  If the library unit is a predefined unit, and we are in no
+      --  run time mode, then temporarily reset No_Run_Time mode for the
+      --  analysis of the with'ed unit. The No_Run_Time pragma does not
+      --  prevent explicit with'ing of run-time units.
+
+      if No_Run_Time
+        and then
+          Is_Predefined_File_Name
+            (Unit_File_Name (Get_Source_Unit (Unit (Library_Unit (N)))))
+      then
+         No_Run_Time := False;
+         Semantics (Library_Unit (N));
+         No_Run_Time := True;
+
+      else
+         Semantics (Library_Unit (N));
+      end if;
+
+      U := Unit (Library_Unit (N));
+      Intunit := Is_Internal_File_Name (Unit_File_Name (Current_Sem_Unit));
+
+      --  Following checks are skipped for dummy packages (those supplied
+      --  for with's where no matching file could be found). Such packages
+      --  are identified by the Sloc value being set to No_Location
+
+      if Sloc (U) /= No_Location then
+
+         --  Check restrictions, except that we skip the check if this
+         --  is an internal unit unless we are compiling the internal
+         --  unit as the main unit. We also skip this for dummy packages.
+
+         if not Intunit or else Current_Sem_Unit = Main_Unit then
+            Check_Restricted_Unit (Unit_Name (Get_Source_Unit (U)), N);
+         end if;
+
+         --  Check for inappropriate with of internal implementation unit
+         --  if we are currently compiling the main unit and the main unit
+         --  is itself not an internal unit.
+
+         if Implementation_Unit_Warnings
+           and then Current_Sem_Unit = Main_Unit
+           and then Implementation_Unit (Get_Source_Unit (U))
+           and then not Intunit
+         then
+            Error_Msg_N ("& is an internal 'G'N'A'T unit?", Name (N));
+            Error_Msg_N
+              ("\use of this unit is non-portable and version-dependent?",
+               Name (N));
+         end if;
+      end if;
+
+      --  Semantic analysis of a generic unit is performed on a copy of
+      --  the original tree. Retrieve the entity on  which semantic info
+      --  actually appears.
+
+      if Unit_Kind in N_Generic_Declaration then
+         E_Name := Defining_Entity (U);
+
+      --  Note: in the following test, Unit_Kind is the original Nkind, but
+      --  in the case of an instantiation, the call to Semantics above will
+      --  have replaced the unit by its instantiated version.
+
+      elsif Unit_Kind = N_Package_Instantiation
+        and then Nkind (U) = N_Package_Body
+      then
+         --  Instantiation node is replaced with body of instance.
+         --  Unit name is defining unit name in corresponding spec.
+
+         E_Name := Corresponding_Spec (U);
+
+      elsif Unit_Kind = N_Package_Instantiation
+        and then Nkind (U) = N_Package_Instantiation
+      then
+         --  If the instance has not been rewritten as a package declaration,
+         --  then it appeared already in a previous with clause. Retrieve
+         --  the entity from the previous instance.
+
+         E_Name := Defining_Entity (Specification (Instance_Spec (U)));
+
+      elsif Unit_Kind = N_Procedure_Instantiation
+        or else Unit_Kind = N_Function_Instantiation
+      then
+         --  Instantiation node is replaced with a package that contains
+         --  renaming declarations and instance itself. The subprogram
+         --  Instance is declared in the visible part of the wrapper package.
+
+         E_Name := First_Entity (Defining_Entity (U));
+
+         while Present (E_Name) loop
+            exit when Is_Subprogram (E_Name)
+              and then Is_Generic_Instance (E_Name);
+            E_Name := Next_Entity (E_Name);
+         end loop;
+
+      elsif Unit_Kind = N_Package_Renaming_Declaration
+        or else Unit_Kind in N_Generic_Renaming_Declaration
+      then
+         E_Name := Defining_Entity (U);
+
+      elsif Unit_Kind = N_Subprogram_Body
+        and then Nkind (Name (N)) = N_Selected_Component
+        and then not Acts_As_Spec (Library_Unit (N))
+      then
+         --  For a child unit that has no spec, one has been created and
+         --  analyzed. The entity required is that of the spec.
+
+         E_Name := Corresponding_Spec (U);
+
+      else
+         E_Name := Defining_Entity (U);
+      end if;
+
+      if Nkind (Name (N)) = N_Selected_Component then
+
+         --  Child unit in a with clause
+
+         Change_Selected_Component_To_Expanded_Name (Name (N));
+      end if;
+
+      --  Restore style checks and restrictions
+
+      Style_Check := Save_Style_Check;
+      Compilation_Unit_Restrictions_Restore (Save_C_Restrict);
+
+      --  Record the reference, but do NOT set the unit as referenced, we
+      --  want to consider the unit as unreferenced if this is the only
+      --  reference that occurs.
+
+      Set_Entity_With_Style_Check (Name (N), E_Name);
+      Generate_Reference (E_Name, Name (N), Set_Ref => False);
+
+      if Is_Child_Unit (E_Name) then
+         Pref     := Prefix (Name (N));
+         Par_Name := Scope (E_Name);
+
+         while Nkind (Pref) = N_Selected_Component loop
+            Change_Selected_Component_To_Expanded_Name (Pref);
+            Set_Entity_With_Style_Check (Pref, Par_Name);
+
+            Generate_Reference (Par_Name, Pref);
+            Pref := Prefix (Pref);
+            Par_Name := Scope (Par_Name);
+         end loop;
+
+         if Present (Entity (Pref))
+           and then not Analyzed (Parent (Parent (Entity (Pref))))
+         then
+            --  If the entity is set without its unit being compiled,
+            --  the original parent is a renaming, and Par_Name is the
+            --  renamed entity. For visibility purposes, we need the
+            --  original entity, which must be analyzed now, because
+            --  Load_Unit retrieves directly the renamed unit, and the
+            --  renaming declaration itself has not been analyzed.
+
+            Analyze (Parent (Parent (Entity (Pref))));
+            pragma Assert (Renamed_Object (Entity (Pref)) = Par_Name);
+            Par_Name := Entity (Pref);
+         end if;
+
+         Set_Entity_With_Style_Check (Pref, Par_Name);
+         Generate_Reference (Par_Name, Pref);
+      end if;
+
+      --  If the withed unit is System, and a system extension pragma is
+      --  present, compile the extension now, rather than waiting for
+      --  a visibility check on a specific entity.
+
+      if Chars (E_Name) = Name_System
+        and then Scope (E_Name) = Standard_Standard
+        and then Present (System_Extend_Pragma_Arg)
+        and then Present_System_Aux (N)
+      then
+         --  If the extension is not present, an error will have been emitted.
+
+         null;
+      end if;
+   end Analyze_With_Clause;
+
+   ------------------------------
+   -- Analyze_With_Type_Clause --
+   ------------------------------
+
+   procedure Analyze_With_Type_Clause (N : Node_Id) is
+      Loc  : constant Source_Ptr := Sloc (N);
+      Nam  : Node_Id := Name (N);
+      Pack : Node_Id;
+      Decl : Node_Id;
+      P    : Entity_Id;
+      Unum : Unit_Number_Type;
+      Sel  : Node_Id;
+
+      procedure Decorate_Tagged_Type (T : Entity_Id; Kind : Entity_Kind);
+      --  Set basic attributes of type, including its class_wide type.
+
+      function In_Chain (E : Entity_Id) return Boolean;
+      --  Check that the imported type is not already in the homonym chain,
+      --  for example through a with_type clause in a parent unit.
+
+      --------------------------
+      -- Decorate_Tagged_Type --
+      --------------------------
+
+      procedure Decorate_Tagged_Type (T : Entity_Id; Kind : Entity_Kind) is
+         CW : Entity_Id;
+
+      begin
+         Set_Ekind (T, E_Record_Type);
+         Set_Is_Tagged_Type (T);
+         Set_Etype (T, T);
+         Set_From_With_Type (T);
+         Set_Scope (T, P);
+
+         if not In_Chain (T) then
+            Set_Homonym (T, Current_Entity (T));
+            Set_Current_Entity (T);
+         end if;
+
+         --  Build bogus class_wide type, if not previously done.
+
+         if No (Class_Wide_Type (T)) then
+            CW := Make_Defining_Identifier (Loc,  New_Internal_Name ('S'));
+
+            Set_Ekind            (CW, E_Class_Wide_Type);
+            Set_Etype            (CW, T);
+            Set_Scope            (CW, P);
+            Set_Is_Tagged_Type   (CW);
+            Set_Is_First_Subtype (CW, True);
+            Init_Size_Align      (CW);
+            Set_Has_Unknown_Discriminants
+                                 (CW, True);
+            Set_Class_Wide_Type  (CW, CW);
+            Set_Equivalent_Type  (CW, Empty);
+            Set_From_With_Type   (CW);
+
+            Set_Class_Wide_Type (T, CW);
+         end if;
+      end Decorate_Tagged_Type;
+
+      --------------
+      -- In_Chain --
+      --------------
+
+      function In_Chain (E : Entity_Id) return Boolean is
+         H : Entity_Id := Current_Entity (E);
+
+      begin
+         while Present (H) loop
+
+            if H = E then
+               return True;
+            else
+               H := Homonym (H);
+            end if;
+         end loop;
+
+         return False;
+      end In_Chain;
+
+   --  Start of processing for Analyze_With_Type_Clause
+
+   begin
+      if Nkind (Nam) = N_Selected_Component then
+         Pack := New_Copy_Tree (Prefix (Nam));
+         Sel  := Selector_Name (Nam);
+
+      else
+         Error_Msg_N ("illegal name for imported type", Nam);
+         return;
+      end if;
+
+      Decl :=
+        Make_Package_Declaration (Loc,
+          Specification =>
+             (Make_Package_Specification (Loc,
+               Defining_Unit_Name   => Pack,
+               Visible_Declarations => New_List,
+               End_Label            => Empty)));
+
+      Unum :=
+        Load_Unit
+          (Load_Name  => Get_Unit_Name (Decl),
+           Required   => True,
+           Subunit    => False,
+           Error_Node => Nam);
+
+      if Unum = No_Unit
+         or else Nkind (Unit (Cunit (Unum))) /= N_Package_Declaration
+      then
+         Error_Msg_N ("imported type must be declared in package", Nam);
+         return;
+
+      elsif Unum = Current_Sem_Unit then
+
+         --  If type is defined in unit being analyzed, then the clause
+         --  is redundant.
+
+         return;
+
+      else
+         P := Cunit_Entity (Unum);
+      end if;
+
+      --  Find declaration for imported type, and set its basic attributes
+      --  if it has not been analyzed (which will be the case if there is
+      --  circular dependence).
+
+      declare
+         Decl : Node_Id;
+         Typ  : Entity_Id;
+
+      begin
+         if not Analyzed (Cunit (Unum))
+           and then not From_With_Type (P)
+         then
+            Set_Ekind (P, E_Package);
+            Set_Etype (P, Standard_Void_Type);
+            Set_From_With_Type (P);
+            Set_Scope (P, Standard_Standard);
+            Set_Homonym (P, Current_Entity (P));
+            Set_Current_Entity (P);
+
+         elsif Analyzed (Cunit (Unum))
+           and then Is_Child_Unit (P)
+         then
+            --  If the child unit is already in scope, indicate that it is
+            --  visible, and remains so after intervening calls to rtsfind.
+
+            Set_Is_Visible_Child_Unit (P);
+         end if;
+
+         if Nkind (Parent (P)) = N_Defining_Program_Unit_Name then
+
+            --  Make parent packages visible.
+
+            declare
+               Parent_Comp : Node_Id;
+               Parent_Id   : Entity_Id;
+               Child       : Entity_Id;
+
+            begin
+               Child   := P;
+               Parent_Comp := Parent_Spec (Unit (Cunit (Unum)));
+
+               loop
+                  Parent_Id := Defining_Entity (Unit (Parent_Comp));
+                  Set_Scope (Child, Parent_Id);
+
+                  --  The type may be imported from a child unit, in which
+                  --  case the current compilation appears in the name. Do
+                  --  not change its visibility here because it will conflict
+                  --  with the subsequent normal processing.
+
+                  if not Analyzed (Unit_Declaration_Node (Parent_Id))
+                    and then Parent_Id /= Cunit_Entity (Current_Sem_Unit)
+                  then
+                     Set_Ekind (Parent_Id, E_Package);
+                     Set_Etype (Parent_Id, Standard_Void_Type);
+
+                     --  The same package may appear is several with_type
+                     --  clauses.
+
+                     if not From_With_Type (Parent_Id) then
+                        Set_Homonym (Parent_Id, Current_Entity (Parent_Id));
+                        Set_Current_Entity (Parent_Id);
+                        Set_From_With_Type (Parent_Id);
+                     end if;
+                  end if;
+
+                  Set_Is_Immediately_Visible (Parent_Id);
+
+                  Child := Parent_Id;
+                  Parent_Comp := Parent_Spec (Unit (Parent_Comp));
+                  exit when No (Parent_Comp);
+               end loop;
+
+               Set_Scope (Parent_Id, Standard_Standard);
+            end;
+         end if;
+
+         --  Even if analyzed, the package may not be currently visible. It
+         --  must be while the with_type clause is active.
+
+         Set_Is_Immediately_Visible (P);
+
+         Decl :=
+           First (Visible_Declarations (Specification (Unit (Cunit (Unum)))));
+
+         while Present (Decl) loop
+
+            if Nkind (Decl) = N_Full_Type_Declaration
+              and then Chars (Defining_Identifier (Decl)) = Chars (Sel)
+            then
+               Typ := Defining_Identifier (Decl);
+
+               if Tagged_Present (N) then
+
+                  --  The declaration must indicate that this is a tagged
+                  --  type or a type extension.
+
+                  if (Nkind (Type_Definition (Decl)) = N_Record_Definition
+                       and then Tagged_Present (Type_Definition (Decl)))
+                    or else
+                      (Nkind (Type_Definition (Decl))
+                          = N_Derived_Type_Definition
+                         and then Present
+                           (Record_Extension_Part (Type_Definition (Decl))))
+                  then
+                     null;
+                  else
+                     Error_Msg_N ("imported type is not a tagged type", Nam);
+                     return;
+                  end if;
+
+                  if not Analyzed (Decl) then
+
+                     --  Unit is not currently visible. Add basic attributes
+                     --  to type and build its class-wide type.
+
+                     Init_Size_Align (Typ);
+                     Decorate_Tagged_Type (Typ, E_Record_Type);
+                  end if;
+
+               else
+                  if Nkind (Type_Definition (Decl))
+                     /= N_Access_To_Object_Definition
+                  then
+                     Error_Msg_N
+                      ("imported type is not an access type", Nam);
+
+                  elsif not Analyzed (Decl) then
+                     Set_Ekind                    (Typ, E_Access_Type);
+                     Set_Etype                    (Typ, Typ);
+                     Set_Scope                    (Typ, P);
+                     Init_Size                    (Typ, System_Address_Size);
+                     Init_Alignment               (Typ);
+                     Set_Directly_Designated_Type (Typ, Standard_Integer);
+                     Set_From_With_Type           (Typ);
+
+                     if not In_Chain (Typ) then
+                        Set_Homonym               (Typ, Current_Entity (Typ));
+                        Set_Current_Entity        (Typ);
+                     end if;
+                  end if;
+               end if;
+
+               Set_Entity (Sel, Typ);
+               return;
+
+            elsif ((Nkind (Decl) = N_Private_Type_Declaration
+                      and then Tagged_Present (Decl))
+                or else (Nkind (Decl) = N_Private_Extension_Declaration))
+              and then Chars (Defining_Identifier (Decl)) = Chars (Sel)
+            then
+               Typ := Defining_Identifier (Decl);
+
+               if not Tagged_Present (N) then
+                  Error_Msg_N ("type must be declared tagged", N);
+
+               elsif not Analyzed (Decl) then
+                  Decorate_Tagged_Type (Typ, E_Private_Type);
+               end if;
+
+               Set_Entity (Sel, Typ);
+               Set_From_With_Type (Typ);
+               return;
+            end if;
+
+            Decl := Next (Decl);
+         end loop;
+
+         Error_Msg_NE ("not a visible access or tagged type in&", Nam, P);
+      end;
+   end Analyze_With_Type_Clause;
+
+   -----------------------------
+   -- Check_With_Type_Clauses --
+   -----------------------------
+
+   procedure Check_With_Type_Clauses (N : Node_Id) is
+      Lib_Unit : constant Node_Id := Unit (N);
+
+      procedure Check_Parent_Context (U : Node_Id);
+      --  Examine context items of parent unit to locate with_type clauses.
+
+      --------------------------
+      -- Check_Parent_Context --
+      --------------------------
+
+      procedure Check_Parent_Context (U : Node_Id) is
+         Item : Node_Id;
+
+      begin
+         Item := First (Context_Items (U));
+         while Present (Item) loop
+            if Nkind (Item) = N_With_Type_Clause
+              and then not Error_Posted (Item)
+              and then
+                From_With_Type (Scope (Entity (Selector_Name (Name (Item)))))
+            then
+               Error_Msg_Sloc := Sloc (Item);
+               Error_Msg_N ("Missing With_Clause for With_Type_Clause#", N);
+            end if;
+
+            Next (Item);
+         end loop;
+      end Check_Parent_Context;
+
+   --  Start of processing for Check_With_Type_Clauses
+
+   begin
+      if Extensions_Allowed
+        and then (Nkind (Lib_Unit) = N_Package_Body
+                   or else Nkind (Lib_Unit) = N_Subprogram_Body)
+      then
+         Check_Parent_Context (Library_Unit (N));
+         if Is_Child_Spec (Unit (Library_Unit (N))) then
+            Check_Parent_Context (Parent_Spec (Unit (Library_Unit (N))));
+         end if;
+      end if;
+   end Check_With_Type_Clauses;
+
+   ------------------------------
+   -- Check_Private_Child_Unit --
+   ------------------------------
+
+   procedure Check_Private_Child_Unit (N : Node_Id) is
+      Lib_Unit   : constant Node_Id := Unit (N);
+      Item       : Node_Id;
+      Curr_Unit  : Entity_Id;
+      Sub_Parent : Node_Id;
+      Priv_Child : Entity_Id;
+      Par_Lib    : Entity_Id;
+      Par_Spec   : Node_Id;
+
+      function Is_Private_Library_Unit (Unit : Entity_Id) return Boolean;
+      --  Returns true if and only if the library unit is declared with
+      --  an explicit designation of private.
+
+      function Is_Private_Library_Unit (Unit : Entity_Id) return Boolean is
+      begin
+         return Private_Present (Parent (Unit_Declaration_Node (Unit)));
+      end Is_Private_Library_Unit;
+
+   --  Start of processing for Check_Private_Child_Unit
+
+   begin
+      if Nkind (Lib_Unit) = N_Package_Body
+        or else Nkind (Lib_Unit) = N_Subprogram_Body
+      then
+         Curr_Unit := Defining_Entity (Unit (Library_Unit (N)));
+         Par_Lib   := Curr_Unit;
+
+      elsif Nkind (Lib_Unit) = N_Subunit then
+
+         --  The parent is itself a body. The parent entity is to be found
+         --  in the corresponding spec.
+
+         Sub_Parent := Library_Unit (N);
+         Curr_Unit  := Defining_Entity (Unit (Library_Unit (Sub_Parent)));
+
+         --  If the parent itself is a subunit, Curr_Unit is the entity
+         --  of the enclosing body, retrieve the spec entity which is
+         --  the proper ancestor we need for the following tests.
+
+         if Ekind (Curr_Unit) = E_Package_Body then
+            Curr_Unit := Spec_Entity (Curr_Unit);
+         end if;
+
+         Par_Lib    := Curr_Unit;
+
+      else
+         Curr_Unit := Defining_Entity (Lib_Unit);
+
+         Par_Lib := Curr_Unit;
+         Par_Spec  := Parent_Spec (Lib_Unit);
+
+         if No (Par_Spec) then
+            Par_Lib := Empty;
+         else
+            Par_Lib := Defining_Entity (Unit (Par_Spec));
+         end if;
+      end if;
+
+      --  Loop through context items
+
+      Item := First (Context_Items (N));
+      while Present (Item) loop
+
+         if Nkind (Item) = N_With_Clause
+            and then not Implicit_With (Item)
+            and then Is_Private_Descendant (Entity (Name (Item)))
+         then
+            Priv_Child := Entity (Name (Item));
+
+            declare
+               Curr_Parent  : Entity_Id := Par_Lib;
+               Child_Parent : Entity_Id := Scope (Priv_Child);
+               Prv_Ancestor : Entity_Id := Child_Parent;
+               Curr_Private : Boolean   := Is_Private_Library_Unit (Curr_Unit);
+
+            begin
+               --  If the child unit is a public child then locate
+               --  the nearest private ancestor; Child_Parent will
+               --  then be set to the parent of that ancestor.
+
+               if not Is_Private_Library_Unit (Priv_Child) then
+                  while Present (Prv_Ancestor)
+                    and then not Is_Private_Library_Unit (Prv_Ancestor)
+                  loop
+                     Prv_Ancestor := Scope (Prv_Ancestor);
+                  end loop;
+
+                  if Present (Prv_Ancestor) then
+                     Child_Parent := Scope (Prv_Ancestor);
+                  end if;
+               end if;
+
+               while Present (Curr_Parent)
+                 and then Curr_Parent /= Standard_Standard
+                 and then Curr_Parent /= Child_Parent
+               loop
+                  Curr_Private :=
+                    Curr_Private or else Is_Private_Library_Unit (Curr_Parent);
+                  Curr_Parent := Scope (Curr_Parent);
+               end loop;
+
+               if not Present (Curr_Parent) then
+                  Curr_Parent := Standard_Standard;
+               end if;
+
+               if Curr_Parent /= Child_Parent then
+
+                  if Ekind (Priv_Child) = E_Generic_Package
+                    and then Chars (Priv_Child) in Text_IO_Package_Name
+                    and then Chars (Scope (Scope (Priv_Child))) = Name_Ada
+                  then
+                     Error_Msg_NE
+                       ("& is a nested package, not a compilation unit",
+                       Name (Item), Priv_Child);
+
+                  else
+                     Error_Msg_N
+                       ("unit in with clause is private child unit!", Item);
+                     Error_Msg_NE
+                       ("current unit must also have parent&!",
+                        Item, Child_Parent);
+                  end if;
+
+               elsif not Curr_Private
+                 and then Nkind (Lib_Unit) /= N_Package_Body
+                 and then Nkind (Lib_Unit) /= N_Subprogram_Body
+                 and then Nkind (Lib_Unit) /= N_Subunit
+               then
+                  Error_Msg_NE
+                    ("current unit must also be private descendant of&",
+                     Item, Child_Parent);
+               end if;
+            end;
+         end if;
+
+         Next (Item);
+      end loop;
+
+   end Check_Private_Child_Unit;
+
+   ----------------------
+   -- Check_Stub_Level --
+   ----------------------
+
+   procedure Check_Stub_Level (N : Node_Id) is
+      Par  : constant Node_Id   := Parent (N);
+      Kind : constant Node_Kind := Nkind (Par);
+
+   begin
+      if (Kind = N_Package_Body
+           or else Kind = N_Subprogram_Body
+           or else Kind = N_Task_Body
+           or else Kind = N_Protected_Body)
+
+        and then (Nkind (Parent (Par)) = N_Compilation_Unit
+                   or else Nkind (Parent (Par)) = N_Subunit)
+      then
+         null;
+
+      --  In an instance, a missing stub appears at any level. A warning
+      --  message will have been emitted already for the missing file.
+
+      elsif not In_Instance then
+         Error_Msg_N ("stub cannot appear in an inner scope", N);
+
+      elsif Expander_Active then
+         Error_Msg_N ("missing proper body", N);
+      end if;
+   end Check_Stub_Level;
+
+   ------------------------
+   -- Expand_With_Clause --
+   ------------------------
+
+   procedure Expand_With_Clause (Nam : Node_Id; N : Node_Id) is
+      Loc   : constant Source_Ptr := Sloc (Nam);
+      Ent   : constant Entity_Id := Entity (Nam);
+      Withn : Node_Id;
+      P     : Node_Id;
+
+      function Build_Unit_Name (Nam : Node_Id) return Node_Id;
+
+      function Build_Unit_Name (Nam : Node_Id) return Node_Id is
+         Result : Node_Id;
+
+      begin
+         if Nkind (Nam) = N_Identifier then
+            return New_Occurrence_Of (Entity (Nam), Loc);
+
+         else
+            Result :=
+              Make_Expanded_Name (Loc,
+                Chars  => Chars (Entity (Nam)),
+                Prefix => Build_Unit_Name (Prefix (Nam)),
+                Selector_Name => New_Occurrence_Of (Entity (Nam), Loc));
+            Set_Entity (Result, Entity (Nam));
+            return Result;
+         end if;
+      end Build_Unit_Name;
+
+   begin
+      New_Nodes_OK := New_Nodes_OK + 1;
+      Withn :=
+        Make_With_Clause (Loc, Name => Build_Unit_Name (Nam));
+
+      P := Parent (Unit_Declaration_Node (Ent));
+      Set_Library_Unit          (Withn, P);
+      Set_Corresponding_Spec    (Withn, Ent);
+      Set_First_Name            (Withn, True);
+      Set_Implicit_With         (Withn, True);
+
+      Prepend (Withn, Context_Items (N));
+      Mark_Rewrite_Insertion (Withn);
+      Install_Withed_Unit (Withn);
+
+      if Nkind (Nam) = N_Expanded_Name then
+         Expand_With_Clause (Prefix (Nam), N);
+      end if;
+
+      New_Nodes_OK := New_Nodes_OK - 1;
+   end Expand_With_Clause;
+
+   -----------------------------
+   -- Implicit_With_On_Parent --
+   -----------------------------
+
+   procedure Implicit_With_On_Parent
+     (Child_Unit : Node_Id;
+      N          : Node_Id)
+   is
+      Loc    : constant Source_Ptr := Sloc (N);
+      P      : constant Node_Id    := Parent_Spec (Child_Unit);
+      P_Unit : constant Node_Id    := Unit (P);
+
+      P_Name : Entity_Id := Defining_Entity (P_Unit);
+      Withn  : Node_Id;
+
+      function Build_Ancestor_Name (P : Node_Id)  return Node_Id;
+      --  Build prefix of child unit name. Recurse if needed.
+
+      function Build_Unit_Name return Node_Id;
+      --  If the unit is a child unit, build qualified name with all
+      --  ancestors.
+
+      -------------------------
+      -- Build_Ancestor_Name --
+      -------------------------
+
+      function Build_Ancestor_Name (P : Node_Id) return Node_Id is
+         P_Ref : Node_Id := New_Reference_To (Defining_Entity (P), Loc);
+
+      begin
+         if No (Parent_Spec (P)) then
+            return P_Ref;
+         else
+            return
+              Make_Selected_Component (Loc,
+                Prefix => Build_Ancestor_Name (Unit (Parent_Spec (P))),
+                Selector_Name => P_Ref);
+         end if;
+      end Build_Ancestor_Name;
+
+      ---------------------
+      -- Build_Unit_Name --
+      ---------------------
+
+      function Build_Unit_Name return Node_Id is
+         Result : Node_Id;
+
+      begin
+         if No (Parent_Spec (P_Unit)) then
+            return New_Reference_To (P_Name, Loc);
+         else
+            Result :=
+              Make_Expanded_Name (Loc,
+                Chars  => Chars (P_Name),
+                Prefix => Build_Ancestor_Name (Unit (Parent_Spec (P_Unit))),
+                Selector_Name => New_Reference_To (P_Name, Loc));
+            Set_Entity (Result, P_Name);
+            return Result;
+         end if;
+      end Build_Unit_Name;
+
+   --  Start of processing for Implicit_With_On_Parent
+
+   begin
+      New_Nodes_OK := New_Nodes_OK + 1;
+      Withn := Make_With_Clause (Loc, Name => Build_Unit_Name);
+
+      Set_Library_Unit          (Withn, P);
+      Set_Corresponding_Spec    (Withn, P_Name);
+      Set_First_Name            (Withn, True);
+      Set_Implicit_With         (Withn, True);
+
+      --  Node is placed at the beginning of the context items, so that
+      --  subsequent use clauses on the parent can be validated.
+
+      Prepend (Withn, Context_Items (N));
+      Mark_Rewrite_Insertion (Withn);
+      Install_Withed_Unit (Withn);
+
+      if Is_Child_Spec (P_Unit) then
+         Implicit_With_On_Parent (P_Unit, N);
+      end if;
+      New_Nodes_OK := New_Nodes_OK - 1;
+   end Implicit_With_On_Parent;
+
+   ---------------------
+   -- Install_Context --
+   ---------------------
+
+   procedure Install_Context (N : Node_Id) is
+      Lib_Unit : Node_Id := Unit (N);
+
+   begin
+      Install_Context_Clauses (N);
+
+      if Is_Child_Spec (Lib_Unit) then
+         Install_Parents (Lib_Unit, Private_Present (Parent (Lib_Unit)));
+      end if;
+
+      Check_With_Type_Clauses (N);
+   end Install_Context;
+
+   -----------------------------
+   -- Install_Context_Clauses --
+   -----------------------------
+
+   procedure Install_Context_Clauses (N : Node_Id) is
+      Lib_Unit      : Node_Id := Unit (N);
+      Item          : Node_Id;
+      Uname_Node    : Entity_Id;
+      Check_Private : Boolean := False;
+      Decl_Node     : Node_Id;
+      Lib_Parent    : Entity_Id;
+
+   begin
+      --  Loop through context clauses to find the with/use clauses
+
+      Item := First (Context_Items (N));
+      while Present (Item) loop
+
+         --  Case of explicit WITH clause
+
+         if Nkind (Item) = N_With_Clause
+           and then not Implicit_With (Item)
+         then
+            --  If Name (Item) is not an entity name, something is wrong, and
+            --  this will be detected in due course, for now ignore the item
+
+            if not Is_Entity_Name (Name (Item)) then
+               goto Continue;
+            end if;
+
+            Uname_Node := Entity (Name (Item));
+
+            if Is_Private_Descendant (Uname_Node) then
+               Check_Private := True;
+            end if;
+
+            Install_Withed_Unit (Item);
+
+            Decl_Node := Unit_Declaration_Node (Uname_Node);
+
+            --  If the unit is a subprogram instance, it appears nested
+            --  within a package that carries the parent information.
+
+            if Is_Generic_Instance (Uname_Node)
+              and then Ekind (Uname_Node) /= E_Package
+            then
+               Decl_Node := Parent (Parent (Decl_Node));
+            end if;
+
+            if Is_Child_Spec (Decl_Node) then
+               if Nkind (Name (Item)) = N_Expanded_Name then
+                  Expand_With_Clause (Prefix (Name (Item)), N);
+               else
+                  --  if not an expanded name, the child unit must be a
+                  --  renaming, nothing to do.
+
+                  null;
+               end if;
+
+            elsif Nkind (Decl_Node) = N_Subprogram_Body
+              and then not Acts_As_Spec (Parent (Decl_Node))
+              and then Is_Child_Spec (Unit (Library_Unit (Parent (Decl_Node))))
+            then
+               Implicit_With_On_Parent
+                 (Unit (Library_Unit (Parent (Decl_Node))), N);
+            end if;
+
+            --  Check license conditions unless this is a dummy unit
+
+            if Sloc (Library_Unit (Item)) /= No_Location then
+               License_Check : declare
+                  Withl : constant License_Type :=
+                            License (Source_Index
+                                       (Get_Source_Unit
+                                         (Library_Unit (Item))));
+
+                  Unitl : constant License_Type :=
+                           License (Source_Index (Current_Sem_Unit));
+
+                  procedure License_Error;
+                  --  Signal error of bad license
+
+                  -------------------
+                  -- License_Error --
+                  -------------------
+
+                  procedure License_Error is
+                  begin
+                     Error_Msg_N
+                       ("?license of with'ed unit & is incompatible",
+                        Name (Item));
+                  end License_Error;
+
+               --  Start of processing for License_Check
+
+               begin
+                  case Unitl is
+                     when Unknown =>
+                        null;
+
+                     when Restricted =>
+                        if Withl = GPL then
+                           License_Error;
+                        end if;
+
+                     when GPL =>
+                        if Withl = Restricted then
+                           License_Error;
+                        end if;
+
+                     when Modified_GPL =>
+                        if Withl = Restricted or else Withl = GPL then
+                           License_Error;
+                        end if;
+
+                     when Unrestricted =>
+                        null;
+                  end case;
+               end License_Check;
+            end if;
+
+         --  Case of USE PACKAGE clause
+
+         elsif Nkind (Item) = N_Use_Package_Clause then
+            Analyze_Use_Package (Item);
+
+         --  Case of USE TYPE clause
+
+         elsif Nkind (Item) = N_Use_Type_Clause then
+            Analyze_Use_Type (Item);
+
+         --  Case of WITH TYPE clause
+
+         --  A With_Type_Clause is processed when installing the context,
+         --  because it is a visibility mechanism and does not create a
+         --  semantic dependence on other units, as a With_Clause does.
+
+         elsif Nkind (Item) = N_With_Type_Clause then
+            Analyze_With_Type_Clause (Item);
+
+         --  case of PRAGMA
+
+         elsif Nkind (Item) = N_Pragma then
+            Analyze (Item);
+         end if;
+
+      <<Continue>>
+         Next (Item);
+      end loop;
+
+      if Is_Child_Spec (Lib_Unit) then
+
+         --  The unit also has implicit withs on its own parents.
+
+         if No (Context_Items (N)) then
+            Set_Context_Items (N, New_List);
+         end if;
+
+         Implicit_With_On_Parent (Lib_Unit, N);
+      end if;
+
+      --  If the unit is a body, the context of the specification must also
+      --  be installed.
+
+      if Nkind (Lib_Unit) = N_Package_Body
+        or else (Nkind (Lib_Unit) = N_Subprogram_Body
+                  and then not Acts_As_Spec (N))
+      then
+         Install_Context (Library_Unit (N));
+
+         if Is_Child_Spec (Unit (Library_Unit (N))) then
+
+            --  If the unit is the body of a public child unit, the private
+            --  declarations of the parent must be made visible. If the child
+            --  unit is private, the private declarations have been installed
+            --  already in the call to Install_Parents for the spec. Installing
+            --  private declarations must be done for all ancestors of public
+            --  child units. In addition, sibling units mentioned in the
+            --  context clause of the body are directly visible.
+
+            declare
+               Lib_Spec : Node_Id := Unit (Library_Unit (N));
+               P        : Node_Id;
+               P_Name   : Entity_Id;
+
+            begin
+               while Is_Child_Spec (Lib_Spec) loop
+                  P := Unit (Parent_Spec (Lib_Spec));
+
+                  if not (Private_Present (Parent (Lib_Spec))) then
+                     P_Name := Defining_Entity (P);
+                     Install_Private_Declarations (P_Name);
+                     Set_Use (Private_Declarations (Specification (P)));
+                  end if;
+
+                  Lib_Spec := P;
+               end loop;
+            end;
+         end if;
+
+         --  For a package body, children in context are immediately visible
+
+         Install_Siblings (Defining_Entity (Unit (Library_Unit (N))), N);
+      end if;
+
+      if Nkind (Lib_Unit) = N_Generic_Package_Declaration
+        or else Nkind (Lib_Unit) = N_Generic_Subprogram_Declaration
+        or else Nkind (Lib_Unit) = N_Package_Declaration
+        or else Nkind (Lib_Unit) = N_Subprogram_Declaration
+      then
+         if Is_Child_Spec (Lib_Unit) then
+            Lib_Parent := Defining_Entity (Unit (Parent_Spec (Lib_Unit)));
+            Set_Is_Private_Descendant
+              (Defining_Entity (Lib_Unit),
+               Is_Private_Descendant (Lib_Parent)
+                 or else Private_Present (Parent (Lib_Unit)));
+
+         else
+            Set_Is_Private_Descendant
+              (Defining_Entity (Lib_Unit),
+               Private_Present (Parent (Lib_Unit)));
+         end if;
+      end if;
+
+      if Check_Private then
+         Check_Private_Child_Unit (N);
+      end if;
+   end Install_Context_Clauses;
+
+   ---------------------
+   -- Install_Parents --
+   ---------------------
+
+   procedure Install_Parents (Lib_Unit : Node_Id; Is_Private : Boolean) is
+      P      : Node_Id;
+      E_Name : Entity_Id;
+      P_Name : Entity_Id;
+      P_Spec : Node_Id;
+
+   begin
+      P := Unit (Parent_Spec (Lib_Unit));
+      P_Name := Defining_Entity (P);
+
+      if Etype (P_Name) = Any_Type then
+         return;
+      end if;
+
+      if Ekind (P_Name) = E_Generic_Package
+        and then Nkind (Lib_Unit) /= N_Generic_Subprogram_Declaration
+        and then Nkind (Lib_Unit) /= N_Generic_Package_Declaration
+        and then Nkind (Lib_Unit) not in N_Generic_Renaming_Declaration
+      then
+         Error_Msg_N
+           ("child of a generic package must be a generic unit", Lib_Unit);
+
+      elsif not Is_Package (P_Name) then
+         Error_Msg_N
+           ("parent unit must be package or generic package", Lib_Unit);
+         raise Unrecoverable_Error;
+
+      elsif Present (Renamed_Object (P_Name)) then
+         Error_Msg_N ("parent unit cannot be a renaming", Lib_Unit);
+         raise Unrecoverable_Error;
+
+      --  Verify that a child of an instance is itself an instance, or
+      --  the renaming of one. Given that an instance that is a unit is
+      --  replaced with a package declaration, check against the original
+      --  node.
+
+      elsif Nkind (Original_Node (P)) = N_Package_Instantiation
+        and then Nkind (Lib_Unit)
+                   not in N_Renaming_Declaration
+        and then Nkind (Original_Node (Lib_Unit))
+                   not in N_Generic_Instantiation
+      then
+         Error_Msg_N
+           ("child of an instance must be an instance or renaming", Lib_Unit);
+      end if;
+
+      --  This is the recursive call that ensures all parents are loaded
+
+      if Is_Child_Spec (P) then
+         Install_Parents (P,
+           Is_Private or else Private_Present (Parent (Lib_Unit)));
+      end if;
+
+      --  Now we can install the context for this parent
+
+      Install_Context_Clauses (Parent_Spec (Lib_Unit));
+      Install_Siblings (P_Name, Parent (Lib_Unit));
+
+      --  The child unit is in the declarative region of the parent. The
+      --  parent must therefore appear in the scope stack and be visible,
+      --  as when compiling the corresponding body. If the child unit is
+      --  private or it is a package body, private declarations must be
+      --  accessible as well. Use declarations in the parent must also
+      --  be installed. Finally, other child units of the same parent that
+      --  are in the context are immediately visible.
+
+      --  Find entity for compilation unit, and set its private descendant
+      --  status as needed.
+
+      E_Name := Defining_Entity (Lib_Unit);
+
+      Set_Is_Child_Unit (E_Name);
+
+      Set_Is_Private_Descendant (E_Name,
+         Is_Private_Descendant (P_Name)
+           or else Private_Present (Parent (Lib_Unit)));
+
+      P_Spec := Specification (Unit_Declaration_Node (P_Name));
+      New_Scope (P_Name);
+
+      --  Save current visibility of unit
+
+      Scope_Stack.Table (Scope_Stack.Last).Previous_Visibility :=
+        Is_Immediately_Visible (P_Name);
+      Set_Is_Immediately_Visible (P_Name);
+      Install_Visible_Declarations (P_Name);
+      Set_Use (Visible_Declarations (P_Spec));
+
+      if Is_Private
+        or else Private_Present (Parent (Lib_Unit))
+      then
+         Install_Private_Declarations (P_Name);
+         Set_Use (Private_Declarations (P_Spec));
+      end if;
+   end Install_Parents;
+
+   ----------------------
+   -- Install_Siblings --
+   ----------------------
+
+   procedure Install_Siblings (U_Name : Entity_Id; N : Node_Id) is
+      Item : Node_Id;
+      Id   : Entity_Id;
+      Prev : Entity_Id;
+
+      function Is_Ancestor (E : Entity_Id) return Boolean;
+      --  Determine whether the scope of a child unit is an ancestor of
+      --  the current unit.
+      --  Shouldn't this be somewhere more general ???
+
+      function Is_Ancestor (E : Entity_Id) return Boolean is
+         Par : Entity_Id;
+
+      begin
+         Par := U_Name;
+
+         while Present (Par)
+           and then Par /= Standard_Standard
+         loop
+
+            if Par = E then
+               return True;
+            end if;
+
+            Par := Scope (Par);
+         end loop;
+
+         return False;
+      end Is_Ancestor;
+
+   --  Start of processing for Install_Siblings
+
+   begin
+      --  Iterate over explicit with clauses, and check whether the
+      --  scope of each entity is an ancestor of the current unit.
+
+      Item := First (Context_Items (N));
+
+      while Present (Item) loop
+
+         if Nkind (Item) = N_With_Clause
+           and then not Implicit_With (Item)
+         then
+            Id := Entity (Name (Item));
+
+            if Is_Child_Unit (Id)
+              and then Is_Ancestor (Scope (Id))
+            then
+               Set_Is_Immediately_Visible (Id);
+               Prev := Current_Entity (Id);
+
+               --  Check for the presence of another unit in the context,
+               --  that may be inadvertently hidden by the child.
+
+               if Present (Prev)
+                 and then Is_Immediately_Visible (Prev)
+                 and then not Is_Child_Unit (Prev)
+               then
+                  declare
+                     Clause : Node_Id;
+
+                  begin
+                     Clause := First (Context_Items (N));
+
+                     while Present (Clause) loop
+                        if Nkind (Clause) = N_With_Clause
+                          and then Entity (Name (Clause)) = Prev
+                        then
+                           Error_Msg_NE
+                              ("child unit& hides compilation unit " &
+                               "with the same name?",
+                                 Name (Item), Id);
+                           exit;
+                        end if;
+
+                        Next (Clause);
+                     end loop;
+                  end;
+               end if;
+
+            --  the With_Clause may be on a grand-child, which makes
+            --  the child immediately visible.
+
+            elsif Is_Child_Unit (Scope (Id))
+              and then Is_Ancestor (Scope (Scope (Id)))
+            then
+               Set_Is_Immediately_Visible (Scope (Id));
+            end if;
+         end if;
+
+         Next (Item);
+      end loop;
+   end Install_Siblings;
+
+   -------------------------
+   -- Install_Withed_Unit --
+   -------------------------
+
+   procedure Install_Withed_Unit (With_Clause : Node_Id) is
+      Uname : constant Entity_Id := Entity (Name (With_Clause));
+      P     : constant Entity_Id := Scope (Uname);
+
+   begin
+      --  We do not apply the restrictions to an internal unit unless
+      --  we are compiling the internal unit as a main unit. This check
+      --  is also skipped for dummy units (for missing packages).
+
+      if Sloc (Uname) /= No_Location
+        and then (not Is_Internal_File_Name (Unit_File_Name (Current_Sem_Unit))
+                    or else Current_Sem_Unit = Main_Unit)
+      then
+         Check_Restricted_Unit
+           (Unit_Name (Get_Source_Unit (Uname)), With_Clause);
+      end if;
+
+      if P /= Standard_Standard then
+
+         --  If the unit is not analyzed after analysis of the with clause,
+         --  and it is an instantiation, then it awaits a body and is the main
+         --  unit. Its appearance in the context of some other unit indicates
+         --  a circular dependency (DEC suite perversity).
+
+         if not Analyzed (Uname)
+           and then Nkind (Parent (Uname)) = N_Package_Instantiation
+         then
+            Error_Msg_N
+              ("instantiation depends on itself", Name (With_Clause));
+
+         elsif not Is_Visible_Child_Unit (Uname) then
+            Set_Is_Visible_Child_Unit (Uname);
+
+            if Is_Generic_Instance (Uname)
+              and then Ekind (Uname) in Subprogram_Kind
+            then
+               --  Set flag as well on the visible entity that denotes the
+               --  instance, which renames the current one.
+
+               Set_Is_Visible_Child_Unit
+                 (Related_Instance
+                   (Defining_Entity (Unit (Library_Unit (With_Clause)))));
+               null;
+            end if;
+
+            --  The parent unit may have been installed already, and
+            --  may have appeared in a use clause.
+
+            if In_Use (Scope (Uname)) then
+               Set_Is_Potentially_Use_Visible (Uname);
+            end if;
+
+            Set_Context_Installed (With_Clause);
+         end if;
+
+      elsif not Is_Immediately_Visible (Uname) then
+         Set_Is_Immediately_Visible (Uname);
+         Set_Context_Installed (With_Clause);
+      end if;
+
+      --   A with-clause overrides a with-type clause: there are no restric-
+      --   tions on the use of package entities.
+
+      if Ekind (Uname) = E_Package then
+         Set_From_With_Type (Uname, False);
+      end if;
+   end Install_Withed_Unit;
+
+   -------------------
+   -- Is_Child_Spec --
+   -------------------
+
+   function Is_Child_Spec (Lib_Unit : Node_Id) return Boolean is
+      K : constant Node_Kind := Nkind (Lib_Unit);
+
+   begin
+      return (K in N_Generic_Declaration              or else
+              K in N_Generic_Instantiation            or else
+              K in N_Generic_Renaming_Declaration     or else
+              K =  N_Package_Declaration              or else
+              K =  N_Package_Renaming_Declaration     or else
+              K =  N_Subprogram_Declaration           or else
+              K =  N_Subprogram_Renaming_Declaration)
+        and then Present (Parent_Spec (Lib_Unit));
+   end Is_Child_Spec;
+
+   -----------------------
+   -- Load_Needed_Body --
+   -----------------------
+
+   --  N is a generic unit named in a with clause, or else it is
+   --  a unit that contains a generic unit or an inlined function.
+   --  In order to perform an instantiation, the body of the unit
+   --  must be present. If the unit itself is generic, we assume
+   --  that an instantiation follows, and  load and analyze the body
+   --  unconditionally. This forces analysis of the spec as well.
+
+   --  If the unit is not generic, but contains a generic unit, it
+   --  is loaded on demand, at the point of instantiation (see ch12).
+
+   procedure Load_Needed_Body (N : Node_Id; OK : out Boolean) is
+      Body_Name : Unit_Name_Type;
+      Unum      : Unit_Number_Type;
+
+      Save_Style_Check : constant Boolean := Opt.Style_Check;
+      --  The loading and analysis is done with style checks off
+
+   begin
+      if not GNAT_Mode then
+         Style_Check := False;
+      end if;
+
+      Body_Name := Get_Body_Name (Get_Unit_Name (Unit (N)));
+      Unum :=
+        Load_Unit
+          (Load_Name  => Body_Name,
+           Required   => False,
+           Subunit    => False,
+           Error_Node => N,
+           Renamings  => True);
+
+      if Unum = No_Unit then
+         OK := False;
+
+      else
+         Compiler_State := Analyzing; -- reset after load
+
+         if not Fatal_Error (Unum) then
+            if Debug_Flag_L then
+               Write_Str ("*** Loaded generic body");
+               Write_Eol;
+            end if;
+
+            Semantics (Cunit (Unum));
+         end if;
+
+         OK := True;
+      end if;
+
+      Style_Check := Save_Style_Check;
+   end Load_Needed_Body;
+
+   --------------------
+   -- Remove_Context --
+   --------------------
+
+   procedure Remove_Context (N : Node_Id) is
+      Lib_Unit : constant Node_Id := Unit (N);
+
+   begin
+      --  If this is a child unit, first remove the parent units.
+
+      if Is_Child_Spec (Lib_Unit) then
+         Remove_Parents (Lib_Unit);
+      end if;
+
+      Remove_Context_Clauses (N);
+   end Remove_Context;
+
+   ----------------------------
+   -- Remove_Context_Clauses --
+   ----------------------------
+
+   procedure Remove_Context_Clauses (N : Node_Id) is
+      Item      : Node_Id;
+      Unit_Name : Entity_Id;
+
+   begin
+
+      --  Loop through context items and undo with_clauses and use_clauses.
+
+      Item := First (Context_Items (N));
+
+      while Present (Item) loop
+
+         --  We are interested only in with clauses which got installed
+         --  on entry, as indicated by their Context_Installed flag set
+
+         if Nkind (Item) = N_With_Clause
+            and then Context_Installed (Item)
+         then
+            --  Remove items from one with'ed unit
+
+            Unit_Name := Entity (Name (Item));
+            Remove_Unit_From_Visibility (Unit_Name);
+            Set_Context_Installed (Item, False);
+
+         elsif Nkind (Item) = N_Use_Package_Clause then
+            End_Use_Package (Item);
+
+         elsif Nkind (Item) = N_Use_Type_Clause then
+            End_Use_Type (Item);
+
+         elsif Nkind (Item) = N_With_Type_Clause then
+            Remove_With_Type_Clause (Name (Item));
+         end if;
+
+         Next (Item);
+      end loop;
+
+   end Remove_Context_Clauses;
+
+   --------------------
+   -- Remove_Parents --
+   --------------------
+
+   procedure Remove_Parents (Lib_Unit : Node_Id) is
+      P      : Node_Id;
+      P_Name : Entity_Id;
+      E      : Entity_Id;
+      Vis    : constant Boolean :=
+                 Scope_Stack.Table (Scope_Stack.Last).Previous_Visibility;
+
+   begin
+      if Is_Child_Spec (Lib_Unit) then
+         P := Unit (Parent_Spec (Lib_Unit));
+         P_Name := Defining_Entity (P);
+
+         Remove_Context_Clauses (Parent_Spec (Lib_Unit));
+         End_Package_Scope (P_Name);
+         Set_Is_Immediately_Visible (P_Name, Vis);
+
+         --  Remove from visibility the siblings as well, which are directly
+         --  visible while the parent is in scope.
+
+         E := First_Entity (P_Name);
+
+         while Present (E) loop
+
+            if Is_Child_Unit (E) then
+               Set_Is_Immediately_Visible (E, False);
+            end if;
+
+            Next_Entity (E);
+         end loop;
+
+         Set_In_Package_Body (P_Name, False);
+
+         --  This is the recursive call to remove the context of any
+         --  higher level parent. This recursion ensures that all parents
+         --  are removed in the reverse order of their installation.
+
+         Remove_Parents (P);
+      end if;
+   end Remove_Parents;
+
+   -----------------------------
+   -- Remove_With_Type_Clause --
+   -----------------------------
+
+   procedure Remove_With_Type_Clause (Name : Node_Id) is
+      Typ : Entity_Id;
+      P   : Entity_Id;
+
+      procedure Unchain (E : Entity_Id);
+      --  Remove entity from visibility list.
+
+      procedure Unchain (E : Entity_Id) is
+         Prev : Entity_Id;
+
+      begin
+         Prev := Current_Entity (E);
+
+         --  Package entity may appear is several with_type_clauses, and
+         --  may have been removed already.
+
+         if No (Prev) then
+            return;
+
+         elsif Prev = E then
+            Set_Name_Entity_Id (Chars (E), Homonym (E));
+
+         else
+            while Present (Prev)
+              and then Homonym (Prev) /= E
+            loop
+               Prev := Homonym (Prev);
+            end loop;
+
+            if (Present (Prev)) then
+               Set_Homonym (Prev, Homonym (E));
+            end if;
+         end if;
+      end Unchain;
+
+   begin
+      if Nkind (Name) = N_Selected_Component then
+         Typ := Entity (Selector_Name (Name));
+
+         if No (Typ) then    --  error in declaration.
+            return;
+         end if;
+      else
+         return;
+      end if;
+
+      P := Scope (Typ);
+
+      --  If the exporting package has been analyzed, it has appeared in the
+      --  context already and should be left alone. Otherwise, remove from
+      --  visibility.
+
+      if not Analyzed (Unit_Declaration_Node (P)) then
+         Unchain (P);
+         Unchain (Typ);
+         Set_Is_Frozen (Typ, False);
+      end if;
+
+      if Ekind (Typ) = E_Record_Type then
+         Set_From_With_Type (Class_Wide_Type (Typ), False);
+         Set_From_With_Type (Typ, False);
+      end if;
+
+      Set_From_With_Type (P, False);
+
+      --  If P is a child unit, remove parents as well.
+
+      P := Scope (P);
+
+      while Present (P)
+        and then P /= Standard_Standard
+      loop
+         Set_From_With_Type (P, False);
+
+         if not Analyzed (Unit_Declaration_Node (P)) then
+            Unchain (P);
+         end if;
+
+         P := Scope (P);
+      end loop;
+
+      --  The back-end needs to know that an access type is imported, so it
+      --  does not need elaboration and can appear in a mutually recursive
+      --  record definition, so the imported flag on an access  type is
+      --  preserved.
+
+   end Remove_With_Type_Clause;
+
+   ---------------------------------
+   -- Remove_Unit_From_Visibility --
+   ---------------------------------
+
+   procedure Remove_Unit_From_Visibility (Unit_Name : Entity_Id) is
+      P : Entity_Id := Scope (Unit_Name);
+
+   begin
+
+      if Debug_Flag_I then
+         Write_Str ("remove withed unit ");
+         Write_Name (Chars (Unit_Name));
+         Write_Eol;
+      end if;
+
+      if P /= Standard_Standard then
+         Set_Is_Visible_Child_Unit (Unit_Name, False);
+      end if;
+
+      Set_Is_Potentially_Use_Visible (Unit_Name, False);
+      Set_Is_Immediately_Visible     (Unit_Name, False);
+
+   end Remove_Unit_From_Visibility;
+
+end Sem_Ch10;
diff --git a/gcc/ada/sem_ch10.ads b/gcc/ada/sem_ch10.ads
new file mode 100644
index 00000000000..4ea1acca4cc
--- /dev/null
+++ b/gcc/ada/sem_ch10.ads
@@ -0,0 +1,60 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             S E M _ C H 1 0                              --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.7 $                              --
+--                                                                          --
+--          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 Sem_Ch10 is
+   procedure Analyze_Compilation_Unit                   (N : Node_Id);
+   procedure Analyze_With_Clause                        (N : Node_Id);
+   procedure Analyze_With_Type_Clause                   (N : Node_Id);
+   procedure Analyze_Subprogram_Body_Stub               (N : Node_Id);
+   procedure Analyze_Package_Body_Stub                  (N : Node_Id);
+   procedure Analyze_Task_Body_Stub                     (N : Node_Id);
+   procedure Analyze_Protected_Body_Stub                (N : Node_Id);
+   procedure Analyze_Subunit                            (N : Node_Id);
+
+   procedure Install_Context (N : Node_Id);
+   --  Installs the entities from the context clause of the given compilation
+   --  unit into the visibility chains. This is done before analyzing a unit.
+   --  For a child unit, install context of parents as well.
+
+   procedure Remove_Context (N : Node_Id);
+   --  Removes the entities from the context clause of the given compilation
+   --  unit from the visibility chains. This is done on exit from a unit as
+   --  part of cleaning up the visibility chains for the caller. A special
+   --  case is that the call from the Main_Unit can be ignored, since at the
+   --  end of the main unit the visibility table won't be needed in any case.
+   --  For a child unit, remove parents and their context as well.
+
+   procedure Load_Needed_Body (N : Node_Id; OK : out Boolean);
+   --  Load and analyze the body of a context unit that is generic, or
+   --  that contains generic units or inlined units. The body becomes
+   --  part of the semantic dependency set of the unit that needs it.
+   --  The returned result in OK is True if the load is successful,
+   --  and False if the requested file cannot be found.
+
+end Sem_Ch10;
diff --git a/gcc/ada/sem_ch11.adb b/gcc/ada/sem_ch11.adb
new file mode 100644
index 00000000000..2a3536b642a
--- /dev/null
+++ b/gcc/ada/sem_ch11.adb
@@ -0,0 +1,387 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             S E M _ C H 1 1                              --
+--                                                                          --
+--                                 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 Einfo;    use Einfo;
+with Errout;   use Errout;
+with Lib;      use Lib;
+with Lib.Xref; use Lib.Xref;
+with Nlists;   use Nlists;
+with Nmake;    use Nmake;
+with Opt;      use Opt;
+with Restrict; use Restrict;
+with Rtsfind;  use Rtsfind;
+with Sem;      use Sem;
+with Sem_Ch5;  use Sem_Ch5;
+with Sem_Ch8;  use Sem_Ch8;
+with Sem_Res;  use Sem_Res;
+with Sem_Util; use Sem_Util;
+with Sinfo;    use Sinfo;
+with Stand;    use Stand;
+with Uintp;    use Uintp;
+
+package body Sem_Ch11 is
+
+   -----------------------------------
+   -- Analyze_Exception_Declaration --
+   -----------------------------------
+
+   procedure Analyze_Exception_Declaration (N : Node_Id) is
+      Id : constant Entity_Id := Defining_Identifier (N);
+      PF : constant Boolean   := Is_Pure (Current_Scope);
+
+   begin
+      Generate_Definition (Id);
+      Enter_Name          (Id);
+      Set_Ekind           (Id, E_Exception);
+      Set_Exception_Code  (Id, Uint_0);
+      Set_Etype           (Id, Standard_Exception_Type);
+
+      Set_Is_Statically_Allocated (Id);
+      Set_Is_Pure (Id, PF);
+
+   end Analyze_Exception_Declaration;
+
+   --------------------------------
+   -- Analyze_Exception_Handlers --
+   --------------------------------
+
+   procedure Analyze_Exception_Handlers (L : List_Id) is
+      Handler : Node_Id;
+      Choice  : Entity_Id;
+      Id      : Node_Id;
+      H_Scope : Entity_Id := Empty;
+
+      procedure Check_Duplication (Id : Node_Id);
+      --  Iterate through the identifiers in each handler to find duplicates
+
+      -----------------------
+      -- Check_Duplication --
+      -----------------------
+
+      procedure Check_Duplication (Id : Node_Id) is
+         Handler : Node_Id;
+         Id1     : Node_Id;
+
+      begin
+         Handler := First_Non_Pragma (L);
+         while Present (Handler) loop
+            Id1 := First (Exception_Choices (Handler));
+
+            while Present (Id1) loop
+
+               --  Only check against the exception choices which precede
+               --  Id in the handler, since the ones that follow Id have not
+               --  been analyzed yet and will be checked in a subsequent call.
+
+               if Id = Id1 then
+                  return;
+
+               elsif Nkind (Id1) /= N_Others_Choice
+                 and then Entity (Id) = Entity (Id1)
+               then
+                  if Handler /= Parent (Id) then
+                     Error_Msg_Sloc := Sloc (Id1);
+                     Error_Msg_NE
+                       ("exception choice duplicates &#", Id, Id1);
+
+                  else
+                     if Ada_83 and then Comes_From_Source (Id) then
+                        Error_Msg_N
+                          ("(Ada 83): duplicate exception choice&", Id);
+                     end if;
+                  end if;
+               end if;
+
+               Next_Non_Pragma (Id1);
+            end loop;
+
+            Next (Handler);
+         end loop;
+      end Check_Duplication;
+
+   --  Start processing for Analyze_Exception_Handlers
+
+   begin
+      Handler := First (L);
+      Check_Restriction (No_Exceptions, Handler);
+      Check_Restriction (No_Exception_Handlers, Handler);
+
+      --  Loop through handlers (which can include pragmas)
+
+      while Present (Handler) loop
+
+         --  If pragma just analyze it
+
+         if Nkind (Handler) = N_Pragma then
+            Analyze (Handler);
+
+         --  Otherwise we have a real exception handler
+
+         else
+            --  Deal with choice parameter. The exception handler is
+            --  a declarative part for it, so it constitutes a scope
+            --  for visibility purposes. We create an entity to denote
+            --  the whole exception part, and use it as the scope of all
+            --  the choices, which may even have the same name without
+            --  conflict. This scope plays no other role in expansion or
+            --  or code generation.
+
+            Choice := Choice_Parameter (Handler);
+
+            if Present (Choice) then
+
+               if No (H_Scope) then
+                  H_Scope := New_Internal_Entity
+                    (E_Block, Current_Scope, Sloc (Choice), 'E');
+               end if;
+
+               New_Scope (H_Scope);
+               Set_Etype (H_Scope, Standard_Void_Type);
+
+               --  Set the Finalization Chain entity to Error means that it
+               --  should not be used at that level but the parent one
+               --  should be used instead.
+
+               --  ??? this usage needs documenting in Einfo/Exp_Ch7 ???
+               --  ??? using Error for this non-error condition is nasty ???
+
+               Set_Finalization_Chain_Entity (H_Scope, Error);
+
+               Enter_Name (Choice);
+               Set_Ekind (Choice, E_Variable);
+               Set_Etype (Choice, RTE (RE_Exception_Occurrence));
+               Generate_Definition (Choice);
+            end if;
+
+            Id := First (Exception_Choices (Handler));
+            while Present (Id) loop
+               if Nkind (Id) = N_Others_Choice then
+                  if Present (Next (Id))
+                    or else Present (Next (Handler))
+                    or else Present (Prev (Id))
+                  then
+                     Error_Msg_N ("OTHERS must appear alone and last", Id);
+                  end if;
+
+               else
+                  Analyze (Id);
+
+                  if not Is_Entity_Name (Id)
+                    or else Ekind (Entity (Id)) /= E_Exception
+                  then
+                     Error_Msg_N ("exception name expected", Id);
+
+                  else
+                     if Present (Renamed_Entity (Entity (Id))) then
+                        Set_Entity (Id, Renamed_Entity (Entity (Id)));
+                     end if;
+
+                     Check_Duplication (Id);
+
+                     --  Check for exception declared within generic formal
+                     --  package (which is illegal, see RM 11.2(8))
+
+                     declare
+                        Ent  : Entity_Id := Entity (Id);
+                        Scop : Entity_Id := Scope (Ent);
+
+                     begin
+                        while Scop /= Standard_Standard
+                          and then Ekind (Scop) = E_Package
+                        loop
+                           --  If the exception is declared in an inner
+                           --  instance, nothing else to check.
+
+                           if Is_Generic_Instance (Scop) then
+                              exit;
+
+                           elsif Nkind (Declaration_Node (Scop)) =
+                                           N_Package_Specification
+                             and then
+                               Nkind (Original_Node (Parent
+                                 (Declaration_Node (Scop)))) =
+                                           N_Formal_Package_Declaration
+                           then
+                              Error_Msg_NE
+                                ("exception& is declared in "  &
+                                 "generic formal package", Id, Ent);
+                              Error_Msg_N
+                                ("\and therefore cannot appear in " &
+                                 "handler ('R'M 11.2(8))", Id);
+                              exit;
+                           end if;
+
+                           Scop := Scope (Scop);
+                        end loop;
+                     end;
+                  end if;
+               end if;
+
+               Next (Id);
+            end loop;
+
+            Analyze_Statements (Statements (Handler));
+
+            if Present (Choice) then
+               End_Scope;
+            end if;
+
+         end if;
+
+         Next (Handler);
+      end loop;
+   end Analyze_Exception_Handlers;
+
+   --------------------------------
+   -- Analyze_Handled_Statements --
+   --------------------------------
+
+   procedure Analyze_Handled_Statements (N : Node_Id) is
+      Handlers : constant List_Id := Exception_Handlers (N);
+
+   begin
+      Analyze_Statements (Statements (N));
+
+      if Present (Handlers) then
+         Analyze_Exception_Handlers (Handlers);
+
+      elsif Present (At_End_Proc (N)) then
+         Analyze (At_End_Proc (N));
+      end if;
+   end Analyze_Handled_Statements;
+
+   -----------------------------
+   -- Analyze_Raise_Statement --
+   -----------------------------
+
+   procedure Analyze_Raise_Statement (N : Node_Id) is
+      Exception_Id   : constant Node_Id := Name (N);
+      Exception_Name : Entity_Id := Empty;
+      P              : Node_Id;
+      Nkind_P        : Node_Kind;
+
+   begin
+      Check_Unreachable_Code (N);
+
+      --  Check exception restrictions on the original source
+
+      if Comes_From_Source (N) then
+         Check_Restriction (No_Exceptions, N);
+      end if;
+
+      --  Reraise statement
+
+      if No (Exception_Id) then
+
+         P := Parent (N);
+         Nkind_P := Nkind (P);
+
+         while Nkind_P /= N_Exception_Handler
+           and then Nkind_P /= N_Subprogram_Body
+           and then Nkind_P /= N_Package_Body
+           and then Nkind_P /= N_Task_Body
+           and then Nkind_P /= N_Entry_Body
+         loop
+            P := Parent (P);
+            Nkind_P := Nkind (P);
+         end loop;
+
+         if Nkind (P) /= N_Exception_Handler then
+            Error_Msg_N
+              ("reraise statement must appear directly in a handler", N);
+         end if;
+
+      --  Normal case with exception id present
+
+      else
+         Analyze (Exception_Id);
+
+         if Is_Entity_Name (Exception_Id) then
+            Exception_Name := Entity (Exception_Id);
+
+            if Present (Renamed_Object (Exception_Name)) then
+               Set_Entity (Exception_Id, Renamed_Object (Exception_Name));
+            end if;
+         end if;
+
+         if No (Exception_Name)
+           or else Ekind (Exception_Name) /= E_Exception
+         then
+            Error_Msg_N
+              ("exception name expected in raise statement", Exception_Id);
+         end if;
+      end if;
+   end Analyze_Raise_Statement;
+
+   -----------------------------
+   -- Analyze_Raise_xxx_Error --
+   -----------------------------
+
+   --  Normally, the Etype is already set (when this node is used within
+   --  an expression, since it is copied from the node which it rewrites).
+   --  If this node is used in a statement context, then we set the type
+   --  Standard_Void_Type. This is used both by Gigi and by the front end
+   --  to distinguish the statement use and the subexpression use.
+
+   --  The only other required processing is to take care of the Condition
+   --  field if one is present.
+
+   procedure Analyze_Raise_xxx_Error (N : Node_Id) is
+   begin
+      if No (Etype (N)) then
+         Set_Etype (N, Standard_Void_Type);
+      end if;
+
+      if Present (Condition (N)) then
+         Analyze_And_Resolve (Condition (N), Standard_Boolean);
+      end if;
+
+      --  Deal with static cases in obvious manner
+
+      if Nkind (Condition (N)) = N_Identifier then
+         if Entity (Condition (N)) = Standard_True then
+            Set_Condition (N, Empty);
+
+         elsif Entity (Condition (N)) = Standard_False then
+            Rewrite (N, Make_Null_Statement (Sloc (N)));
+         end if;
+      end if;
+
+   end Analyze_Raise_xxx_Error;
+
+   -----------------------------
+   -- Analyze_Subprogram_Info --
+   -----------------------------
+
+   procedure Analyze_Subprogram_Info (N : Node_Id) is
+   begin
+      Set_Etype (N, RTE (RE_Code_Loc));
+   end Analyze_Subprogram_Info;
+
+end Sem_Ch11;
diff --git a/gcc/ada/sem_ch11.ads b/gcc/ada/sem_ch11.ads
new file mode 100644
index 00000000000..a56ddee2aa4
--- /dev/null
+++ b/gcc/ada/sem_ch11.ads
@@ -0,0 +1,40 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             S E M _ C H 1 1                              --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.9 $                              --
+--                                                                          --
+--          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). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+with Types; use Types;
+package Sem_Ch11 is
+   procedure Analyze_Exception_Declaration              (N : Node_Id);
+   procedure Analyze_Handled_Statements                 (N : Node_Id);
+   procedure Analyze_Raise_Statement                    (N : Node_Id);
+   procedure Analyze_Raise_xxx_Error                    (N : Node_Id);
+   procedure Analyze_Subprogram_Info                    (N : Node_Id);
+
+   procedure Analyze_Exception_Handlers (L : List_Id);
+   --  Analyze list of exception handlers of a handled statement sequence
+
+end Sem_Ch11;
diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb
new file mode 100644
index 00000000000..3f47a62627c
--- /dev/null
+++ b/gcc/ada/sem_ch12.adb
@@ -0,0 +1,8932 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             S E M _ C H 1 2                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.776 $
+--                                                                          --
+--          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 Einfo;    use Einfo;
+with Elists;   use Elists;
+with Errout;   use Errout;
+with Expander; use Expander;
+with Fname;    use Fname;
+with Fname.UF; use Fname.UF;
+with Freeze;   use Freeze;
+with Hostparm;
+with Inline;   use Inline;
+with Lib;      use Lib;
+with Lib.Load; use Lib.Load;
+with Lib.Xref; use Lib.Xref;
+with Nlists;   use Nlists;
+with Nmake;    use Nmake;
+with Opt;      use Opt;
+with Restrict; use Restrict;
+with Rtsfind;  use Rtsfind;
+with Sem;      use Sem;
+with Sem_Cat;  use Sem_Cat;
+with Sem_Ch3;  use Sem_Ch3;
+with Sem_Ch6;  use Sem_Ch6;
+with Sem_Ch7;  use Sem_Ch7;
+with Sem_Ch8;  use Sem_Ch8;
+with Sem_Ch10; use Sem_Ch10;
+with Sem_Ch13; use Sem_Ch13;
+with Sem_Elab; use Sem_Elab;
+with Sem_Elim; use Sem_Elim;
+with Sem_Eval; use Sem_Eval;
+with Sem_Res;  use Sem_Res;
+with Sem_Type; use Sem_Type;
+with Sem_Util; use Sem_Util;
+with Stand;    use Stand;
+with Sinfo;    use Sinfo;
+with Sinfo.CN; use Sinfo.CN;
+with Sinput;   use Sinput;
+with Sinput.L; use Sinput.L;
+with Snames;   use Snames;
+with Stringt;  use Stringt;
+with Uname;    use Uname;
+with Table;
+with Tbuild;   use Tbuild;
+with Uintp;    use Uintp;
+with Urealp;   use Urealp;
+
+with GNAT.HTable;
+
+package body Sem_Ch12 is
+
+   use Atree.Unchecked_Access;
+   --  This package performs untyped traversals of the tree, therefore it
+   --  needs direct access to the fields of a node.
+
+   ----------------------------------------------------------
+   -- Implementation of Generic Analysis and Instantiation --
+   -----------------------------------------------------------
+
+   --  GNAT implements generics by macro expansion. No attempt is made to
+   --  share generic instantiations (for now). Analysis of a generic definition
+   --  does not perform any expansion action, but the expander must be called
+   --  on the tree for each instantiation, because the expansion may of course
+   --  depend on the generic actuals. All of this is best achieved as follows:
+   --
+   --  a) Semantic analysis of a generic unit is performed on a copy of the
+   --  tree for the generic unit. All tree modifications that follow analysis
+   --  do not affect the original tree. Links are kept between the original
+   --  tree and the copy, in order to recognize non-local references within
+   --  the generic, and propagate them to each instance (recall that name
+   --  resolution is done on the generic declaration: generics are not really
+   --  macros!). This is summarized in the following diagram:
+   --
+   --              .-----------.               .----------.
+   --              |  semantic |<--------------|  generic |
+   --              |    copy   |               |    unit  |
+   --              |           |==============>|          |
+   --              |___________|    global     |__________|
+   --                             references     |   |  |
+   --                                            |   |  |
+   --                                          .-----|--|.
+   --                                          |  .-----|---.
+   --                                          |  |  .----------.
+   --                                          |  |  |  generic |
+   --                                          |__|  |          |
+   --                                             |__| instance |
+   --                                                |__________|
+   --
+   --  b) Each instantiation copies the original tree, and inserts into it a
+   --  series of declarations that describe the mapping between generic formals
+   --  and actuals. For example, a generic In OUT parameter is an object
+   --  renaming of the corresponing actual, etc. Generic IN parameters are
+   --  constant declarations.
+   --
+   --  c) In order to give the right visibility for these renamings, we use
+   --  a different scheme for package and subprogram instantiations. For
+   --  packages, the list of renamings is inserted into the package
+   --  specification, before the visible declarations of the package. The
+   --  renamings are analyzed before any of the text of the instance, and are
+   --  thus visible at the right place. Furthermore, outside of the instance,
+   --  the generic parameters are visible and denote their corresponding
+   --  actuals.
+
+   --  For subprograms, we create a container package to hold the renamings
+   --  and the subprogram instance itself. Analysis of the package makes the
+   --  renaming declarations visible to the subprogram. After analyzing the
+   --  package, the defining entity for the subprogram is touched-up so that
+   --  it appears declared in the current scope, and not inside the container
+   --  package.
+
+   --  If the instantiation is a compilation unit, the container package is
+   --  given the same name as the subprogram instance. This ensures that
+   --  the elaboration procedure called by the binder, using the compilation
+   --  unit name, calls in fact the elaboration procedure for the package.
+
+   --  Not surprisingly, private types complicate this approach. By saving in
+   --  the original generic object the non-local references, we guarantee that
+   --  the proper entities are referenced at the point of instantiation.
+   --  However, for private types, this by itself does not insure that the
+   --  proper VIEW of the entity is used (the full type may be visible at the
+   --  point of generic definition, but not at instantiation, or vice-versa).
+   --  In  order to reference the proper view, we special-case any reference
+   --  to private types in the generic object, by saving both views, one in
+   --  the generic and one in the semantic copy. At time of instantiation, we
+   --  check whether the two views are consistent, and exchange declarations if
+   --  necessary, in order to restore the correct visibility. Similarly, if
+   --  the instance view is private when the generic view was not, we perform
+   --  the exchange. After completing the instantiation, we restore the
+   --  current visibility. The flag Has_Private_View marks identifiers in the
+   --  the generic unit that require checking.
+
+   --  Visibility within nested generic units requires special handling.
+   --  Consider the following scheme:
+   --
+   --  type Global is ...         --  outside of generic unit.
+   --  generic ...
+   --  package Outer is
+   --     ...
+   --     type Semi_Global is ... --  global to inner.
+   --
+   --     generic ...                                         -- 1
+   --     procedure inner (X1 : Global;  X2 : Semi_Global);
+   --
+   --     procedure in2 is new inner (...);                   -- 4
+   --  end Outer;
+
+   --  package New_Outer is new Outer (...);                  -- 2
+   --  procedure New_Inner is new New_Outer.Inner (...);      -- 3
+
+   --  The semantic analysis of Outer captures all occurrences of Global.
+   --  The semantic analysis of Inner (at 1) captures both occurrences of
+   --  Global and Semi_Global.
+
+   --  At point 2 (instantiation of Outer), we also produce a generic copy
+   --  of Inner, even though Inner is, at that point, not being instantiated.
+   --  (This is just part of the semantic analysis of New_Outer).
+
+   --  Critically, references to Global within Inner must be preserved, while
+   --  references to Semi_Global should not preserved, because they must now
+   --  resolve to an entity within New_Outer. To distinguish between these, we
+   --  use a global variable, Current_Instantiated_Parent, which is set when
+   --  performing a generic copy during instantiation (at 2). This variable is
+   --  used when performing a generic copy that is not an instantiation, but
+   --  that is nested within one, as the occurrence of 1 within 2. The analysis
+   --  of a nested generic only preserves references that are global to the
+   --  enclosing Current_Instantiated_Parent. We use the Scope_Depth value to
+   --  determine whether a reference is external to the given parent.
+
+   --  The instantiation at point 3 requires no special treatment. The method
+   --  works as well for further nestings of generic units, but of course the
+   --  variable Current_Instantiated_Parent must be stacked because nested
+   --  instantiations can occur, e.g. the occurrence of 4 within 2.
+
+   --  The instantiation of package and subprogram bodies is handled in a
+   --  similar manner, except that it is delayed until after semantic
+   --  analysis is complete. In this fashion complex cross-dependencies
+   --  between several package declarations and bodies containing generics
+   --  can be compiled which otherwise would diagnose spurious circularities.
+
+   --  For example, it is possible to compile two packages A and B that
+   --  have the following structure:
+
+   --    package A is                         package B is
+   --       generic ...                          generic ...
+   --       package G_A is                       package G_B is
+
+   --    with B;                              with A;
+   --    package body A is                    package body B is
+   --       package N_B is new G_B (..)          package N_A is new G_A (..)
+
+   --  The table Pending_Instantiations in package Inline is used to keep
+   --  track of body instantiations that are delayed in this manner. Inline
+   --  handles the actual calls to do the body instantiations. This activity
+   --  is part of Inline, since the processing occurs at the same point, and
+   --  for essentially the same reason, as the handling of inlined routines.
+
+   ----------------------------------------------
+   -- Detection of Instantiation Circularities --
+   ----------------------------------------------
+
+   --  If we have a chain of instantiations that is circular, this is a
+   --  static error which must be detected at compile time. The detection
+   --  of these circularities is carried out at the point that we insert
+   --  a generic instance spec or body. If there is a circularity, then
+   --  the analysis of the offending spec or body will eventually result
+   --  in trying to load the same unit again, and we detect this problem
+   --  as we analyze the package instantiation for the second time.
+
+   --  At least in some cases after we have detected the circularity, we
+   --  get into trouble if we try to keep going. The following flag is
+   --  set if a circularity is detected, and used to abandon compilation
+   --  after the messages have been posted.
+
+   Circularity_Detected : Boolean := False;
+   --  This should really be reset on encountering a new main unit, but in
+   --  practice we are not using multiple main units so it is not critical.
+
+   -----------------------
+   -- Local subprograms --
+   -----------------------
+
+   procedure Abandon_Instantiation (N : Node_Id);
+   pragma No_Return (Abandon_Instantiation);
+   --  Posts an error message "instantiation abandoned" at the indicated
+   --  node and then raises the exception Instantiation_Error to do it.
+
+   procedure Analyze_Formal_Array_Type
+     (T   : in out Entity_Id;
+      Def : Node_Id);
+   --  A formal array type is treated like an array type declaration, and
+   --  invokes Array_Type_Declaration (sem_ch3) whose first parameter is
+   --  in-out, because in the case of an anonymous type the entity is
+   --  actually created in the procedure.
+
+   --  The following procedures treat other kinds of formal parameters.
+
+   procedure Analyze_Formal_Derived_Type
+     (N   : Node_Id;
+      T   : Entity_Id;
+      Def : Node_Id);
+
+   --  All the following need comments???
+
+   procedure Analyze_Formal_Decimal_Fixed_Point_Type
+                                                (T : Entity_Id; Def : Node_Id);
+   procedure Analyze_Formal_Discrete_Type       (T : Entity_Id; Def : Node_Id);
+   procedure Analyze_Formal_Floating_Type       (T : Entity_Id; Def : Node_Id);
+   procedure Analyze_Formal_Signed_Integer_Type (T : Entity_Id; Def : Node_Id);
+   procedure Analyze_Formal_Modular_Type        (T : Entity_Id; Def : Node_Id);
+   procedure Analyze_Formal_Ordinary_Fixed_Point_Type
+                                                (T : Entity_Id; Def : Node_Id);
+
+   procedure Analyze_Formal_Private_Type
+     (N   : Node_Id;
+      T   : Entity_Id;
+      Def : Node_Id);
+   --  This needs comments???
+
+   procedure Analyze_Generic_Formal_Part (N : Node_Id);
+
+   procedure Analyze_Generic_Access_Type (T : Entity_Id; Def : Node_Id);
+   --  This needs comments ???
+
+   function Analyze_Associations
+     (I_Node  : Node_Id;
+      Formals : List_Id;
+      F_Copy  : List_Id)
+      return    List_Id;
+   --  At instantiation time, build the list of associations between formals
+   --  and actuals. Each association becomes a renaming declaration for the
+   --  formal entity. F_Copy is the analyzed list of formals in the generic
+   --  copy. It is used to apply legality checks to the actuals. I_Node is the
+   --  instantiation node itself.
+
+   procedure Analyze_Subprogram_Instantiation
+     (N : Node_Id;
+      K : Entity_Kind);
+
+   procedure Build_Instance_Compilation_Unit_Nodes
+     (N        : Node_Id;
+      Act_Body : Node_Id;
+      Act_Decl : Node_Id);
+   --  This procedure is used in the case where the generic instance of a
+   --  subprogram body or package body is a library unit. In this case, the
+   --  original library unit node for the generic instantiation must be
+   --  replaced by the resulting generic body, and a link made to a new
+   --  compilation unit node for the generic declaration. The argument N is
+   --  the original generic instantiation. Act_Body and Act_Decl are the body
+   --  and declaration of the instance (either package body and declaration
+   --  nodes or subprogram body and declaration nodes depending on the case).
+   --  On return, the node N has been rewritten with the actual body.
+
+   procedure Check_Formal_Packages (P_Id : Entity_Id);
+   --  Apply the following to all formal packages in generic associations.
+
+   procedure Check_Formal_Package_Instance
+     (Formal_Pack : Entity_Id;
+      Actual_Pack : Entity_Id);
+   --  Verify that the actuals of the actual instance match the actuals of
+   --  the template for a formal package that is not declared with a box.
+
+   procedure Check_Forward_Instantiation (N : Node_Id; Decl : Node_Id);
+   --  If the generic is a local entity and the corresponding body has not
+   --  been seen yet, flag enclosing packages to indicate that it will be
+   --  elaborated after the generic body. Subprograms declared in the same
+   --  package cannot be inlined by the front-end because front-end inlining
+   --  requires a strict linear order of elaboration.
+
+   procedure Check_Hidden_Child_Unit
+     (N           : Node_Id;
+      Gen_Unit    : Entity_Id;
+      Act_Decl_Id : Entity_Id);
+   --  If the generic unit is an implicit child instance within a parent
+   --  instance, we need to make an explicit test that it is not hidden by
+   --  a child instance of the same name and parent.
+
+   procedure Check_Private_View (N : Node_Id);
+   --  Check whether the type of a generic entity has a different view between
+   --  the point of generic analysis and the point of instantiation. If the
+   --  view has changed, then at the point of instantiation we restore the
+   --  correct view to perform semantic analysis of the instance, and reset
+   --  the current view after instantiation. The processing is driven by the
+   --  current private status of the type of the node, and Has_Private_View,
+   --  a flag that is set at the point of generic compilation. If view and
+   --  flag are inconsistent then the type is updated appropriately.
+
+   procedure Check_Generic_Actuals
+     (Instance      : Entity_Id;
+      Is_Formal_Box : Boolean);
+   --  Similar to previous one. Check the actuals in the instantiation,
+   --  whose views can change between the point of instantiation and the point
+   --  of instantiation of the body. In addition, mark the generic renamings
+   --  as generic actuals, so that they are not compatible with other actuals.
+   --  Recurse on an actual that is a formal package whose declaration has
+   --  a box.
+
+   function Contains_Instance_Of
+     (Inner : Entity_Id;
+      Outer : Entity_Id;
+      N     : Node_Id)
+      return  Boolean;
+   --  Inner is instantiated within the generic Outer. Check whether Inner
+   --  directly or indirectly contains an instance of Outer or of one of its
+   --  parents, in the case of a subunit. Each generic unit holds a list of
+   --  the entities instantiated within (at any depth). This procedure
+   --  determines whether the set of such lists contains a cycle, i.e. an
+   --  illegal circular instantiation.
+
+   function Denotes_Formal_Package (Pack : Entity_Id) return Boolean;
+   --  Returns True if E is a formal package of an enclosing generic, or
+   --  the actual for such a formal in an enclosing instantiation. Used in
+   --  Restore_Private_Views, to keep the formals of such a package visible
+   --  on exit from an inner instantiation.
+
+   function Find_Actual_Type
+     (Typ       : Entity_Id;
+      Gen_Scope : Entity_Id)
+      return      Entity_Id;
+   --  When validating the actual types of a child instance, check whether
+   --  the formal is a formal type of the parent unit, and retrieve the current
+   --  actual for it. Typ is the entity in the analyzed formal type declaration
+   --  (component or index type of an array type) and Gen_Scope is the scope of
+   --  the analyzed formal array type.
+
+   function Get_Package_Instantiation_Node (A : Entity_Id) return Node_Id;
+   --  Given the entity of a unit that is an instantiation, retrieve the
+   --  original instance node. This is used when loading the instantiations
+   --  of the ancestors of a child generic that is being instantiated.
+
+   function In_Same_Declarative_Part
+     (F_Node : Node_Id;
+      Inst   : Node_Id)
+      return   Boolean;
+   --  True if the instantiation Inst and the given freeze_node F_Node appear
+   --  within the same declarative part, ignoring subunits, but with no inter-
+   --  vening suprograms or concurrent units. If true, the freeze node
+   --  of the instance can be placed after the freeze node of the parent,
+   --  which it itself an instance.
+
+   procedure Set_Instance_Of (A : Entity_Id; B : Entity_Id);
+   --  Associate analyzed generic parameter with corresponding
+   --  instance. Used for semantic checks at instantiation time.
+
+   function Has_Been_Exchanged (E : Entity_Id) return Boolean;
+   --  Traverse the Exchanged_Views list to see if a type was private
+   --  and has already been flipped during this phase of instantiation.
+
+   procedure Hide_Current_Scope;
+   --  When compiling a generic child unit, the parent context must be
+   --  present, but the instance and all entities that may be generated
+   --  must be inserted in the current scope. We leave the current scope
+   --  on the stack, but make its entities invisible to avoid visibility
+   --  problems. This is reversed at the end of instantiations. This is
+   --  not done for the instantiation of the bodies, which only require the
+   --  instances of the generic parents to be in scope.
+
+   procedure Install_Body
+     (Act_Body : Node_Id;
+      N        : Node_Id;
+      Gen_Body : Node_Id;
+      Gen_Decl : Node_Id);
+   --  If the instantiation happens textually before the body of the generic,
+   --  the instantiation of the body must be analyzed after the generic body,
+   --  and not at the point of instantiation. Such early instantiations can
+   --  happen if the generic and the instance appear in  a package declaration
+   --  because the generic body can only appear in the corresponding package
+   --  body. Early instantiations can also appear if generic, instance and
+   --  body are all in the declarative part of a subprogram or entry. Entities
+   --  of packages that are early instantiations are delayed, and their freeze
+   --  node appears after the generic body.
+
+   procedure Insert_After_Last_Decl (N : Node_Id; F_Node : Node_Id);
+   --  Insert freeze node at the end of the declarative part that includes the
+   --  instance node N. If N is in the visible part of an enclosing package
+   --  declaration, the freeze node has to be inserted at the end of the
+   --  private declarations, if any.
+
+   procedure Freeze_Subprogram_Body
+     (Inst_Node : Node_Id;
+      Gen_Body  : Node_Id;
+      Pack_Id   : Entity_Id);
+   --  The generic body may appear textually after the instance, including
+   --  in the proper body of a stub, or within a different package instance.
+   --  Given that the instance can only be elaborated after the generic, we
+   --  place freeze_nodes for the instance and/or for packages that may enclose
+   --  the instance and the generic, so that the back-end can establish the
+   --  proper order of elaboration.
+
+   procedure Install_Parent (P : Entity_Id; In_Body : Boolean := False);
+   --  When compiling an instance of a child unit the parent (which is
+   --  itself an instance) is an enclosing scope that must be made
+   --  immediately visible. This procedure is also used to install the non-
+   --  generic parent of a generic child unit when compiling its body, so that
+   --  full views of types in the parent are made visible.
+
+   procedure Remove_Parent (In_Body : Boolean := False);
+   --  Reverse effect after instantiation of child is complete.
+
+   procedure Inline_Instance_Body
+     (N        : Node_Id;
+      Gen_Unit : Entity_Id;
+      Act_Decl : Node_Id);
+   --  If front-end inlining is requested, instantiate the package body,
+   --  and preserve the visibility of its compilation unit, to insure
+   --  that successive instantiations succeed.
+
+   --  The functions Instantiate_XXX perform various legality checks and build
+   --  the declarations for instantiated generic parameters.
+   --  Need to describe what the parameters are ???
+
+   function Instantiate_Object
+     (Formal          : Node_Id;
+      Actual          : Node_Id;
+      Analyzed_Formal : Node_Id)
+      return            List_Id;
+
+   function Instantiate_Type
+     (Formal          : Node_Id;
+      Actual          : Node_Id;
+      Analyzed_Formal : Node_Id)
+      return            Node_Id;
+
+   function Instantiate_Formal_Subprogram
+     (Formal          : Node_Id;
+      Actual          : Node_Id;
+      Analyzed_Formal : Node_Id)
+      return            Node_Id;
+
+   function Instantiate_Formal_Package
+     (Formal          : Node_Id;
+      Actual          : Node_Id;
+      Analyzed_Formal : Node_Id)
+      return            List_Id;
+   --  If the formal package is declared with a box, special visibility rules
+   --  apply to its formals: they are in the visible part of the package. This
+   --  is true in the declarative region of the formal package, that is to say
+   --  in the enclosing generic or instantiation. For an instantiation, the
+   --  parameters of the formal package are made visible in an explicit step.
+   --  Furthermore, if the actual is a visible use_clause, these formals must
+   --  be made potentially use_visible as well. On exit from the enclosing
+   --  instantiation, the reverse must be done.
+
+   --  For a formal package declared without a box, there are conformance rules
+   --  that apply to the actuals in the generic declaration and the actuals of
+   --  the actual package in the enclosing instantiation. The simplest way to
+   --  apply these rules is to repeat the instantiation of the formal package
+   --  in the context of the enclosing instance, and compare the generic
+   --  associations of this instantiation with those of the actual package.
+
+   function Is_In_Main_Unit (N : Node_Id) return Boolean;
+   --  Test if given node is in the main unit
+
+   procedure Load_Parent_Of_Generic (N : Node_Id; Spec : Node_Id);
+   --  If the generic appears in a separate non-generic library unit,
+   --  load the corresponding body to retrieve the body of the generic.
+   --  N is the node for the generic instantiation, Spec is the generic
+   --  package declaration.
+
+   procedure Inherit_Context (Gen_Decl : Node_Id; Inst : Node_Id);
+   --  Add the context clause of the unit containing a generic unit to
+   --  an instantiation that is a compilation unit.
+
+   function Associated_Node (N : Node_Id) return Node_Id;
+   --  In order to propagate semantic information back from the analyzed
+   --  copy to the original generic, we maintain links between selected nodes
+   --  in the generic and their corresponding copies. At the end of generic
+   --  analysis, the routine Save_Global_References traverses the generic
+   --  tree, examines the semantic information, and preserves the links to
+   --  those nodes that contain global information. At instantiation, the
+   --  information from the associated node is placed on the new copy, so that
+   --  name resolution is not repeated.
+   --  Two kinds of nodes have associated nodes:
+
+   --  a) those that contain entities, that is to say identifiers, expanded_
+   --    names, and operators.
+
+   --  b) aggregates.
+
+   --  For the first class, the associated node preserves the entity if it is
+   --  global. If the generic contains nested instantiations, the associated_
+   --  node itself has been recopied, and a chain of them must be followed.
+
+   --  For aggregates, the associated node allows retrieval of the type, which
+   --  may otherwise not appear in the generic. The view of this type may be
+   --  different between generic and instantiation, and the full view can be
+   --  installed before the instantiation is analyzed. For aggregates of
+   --  type extensions, the same view exchange may have to be performed for
+   --  some of the ancestor types, if their view is private at the point of
+   --  instantiation.
+
+   --  The associated node is stored in Node4, using this field as a free
+   --  union in a fashion that should clearly be under control of sinfo ???
+
+   procedure Move_Freeze_Nodes
+     (Out_Of : Entity_Id;
+      After  : Node_Id;
+      L      : List_Id);
+   --  Freeze nodes can be generated in the analysis of a generic unit, but
+   --  will not be seen by the back-end. It is necessary to move those nodes
+   --  to the enclosing scope if they freeze an outer entity. We place them
+   --  at the end of the enclosing generic package, which is semantically
+   --  neutral.
+
+   procedure Pre_Analyze_Actuals (N : Node_Id);
+   --  Analyze actuals to perform name resolution. Full resolution is done
+   --  later, when the expected types are known, but names have to be captured
+   --  before installing parents of generics, that are not visible for the
+   --  actuals themselves.
+
+   procedure Set_Associated_Node
+     (Gen_Node  : Node_Id;
+      Copy_Node : Node_Id);
+   --  Establish the link between an identifier in the generic unit, and the
+   --  corresponding node in the semantic copy.
+
+   procedure Valid_Default_Attribute (Nam : Entity_Id; Def : Node_Id);
+   --  Verify that an attribute that appears as the default for a formal
+   --  subprogram is a function or procedure with the correct profile.
+
+   -------------------------------------------
+   -- Data Structures for Generic Renamings --
+   -------------------------------------------
+
+   --  The map Generic_Renamings associates generic entities with their
+   --  corresponding actuals. Currently used to validate type instances.
+   --  It will eventually be used for all generic parameters to eliminate
+   --  the need for overload resolution in the instance.
+
+   type Assoc_Ptr is new Int;
+
+   Assoc_Null : constant Assoc_Ptr := -1;
+
+   type Assoc is record
+      Gen_Id         : Entity_Id;
+      Act_Id         : Entity_Id;
+      Next_In_HTable : Assoc_Ptr;
+   end record;
+
+   package Generic_Renamings is new Table.Table
+     (Table_Component_Type => Assoc,
+      Table_Index_Type     => Assoc_Ptr,
+      Table_Low_Bound      => 0,
+      Table_Initial        => 10,
+      Table_Increment      => 100,
+      Table_Name           => "Generic_Renamings");
+
+   --  Variable to hold enclosing instantiation. When the environment is
+   --  saved for a subprogram inlining, the corresponding Act_Id is empty.
+
+   Current_Instantiated_Parent : Assoc := (Empty, Empty, Assoc_Null);
+
+   --  Hash table for associations
+
+   HTable_Size : constant := 37;
+   type HTable_Range is range 0 .. HTable_Size - 1;
+
+   procedure Set_Next_Assoc (E : Assoc_Ptr; Next : Assoc_Ptr);
+   function  Next_Assoc     (E : Assoc_Ptr) return Assoc_Ptr;
+   function Get_Gen_Id      (E : Assoc_Ptr) return Entity_Id;
+   function Hash            (F : Entity_Id)   return HTable_Range;
+
+   package Generic_Renamings_HTable is new GNAT.HTable.Static_HTable (
+      Header_Num => HTable_Range,
+      Element    => Assoc,
+      Elmt_Ptr   => Assoc_Ptr,
+      Null_Ptr   => Assoc_Null,
+      Set_Next   => Set_Next_Assoc,
+      Next       => Next_Assoc,
+      Key        => Entity_Id,
+      Get_Key    => Get_Gen_Id,
+      Hash       => Hash,
+      Equal      => "=");
+
+   Exchanged_Views : Elist_Id;
+   --  This list holds the private views that have been exchanged during
+   --  instantiation to restore the visibility of the generic declaration.
+   --  (see comments above). After instantiation, the current visibility is
+   --  reestablished by means of a traversal of this list.
+
+   Hidden_Entities : Elist_Id;
+   --  This list holds the entities of the current scope that are removed
+   --  from immediate visibility when instantiating a child unit. Their
+   --  visibility is restored in Remove_Parent.
+
+   --  Because instantiations can be recursive, the following must be saved
+   --  on entry and restored on exit from an instantiation (spec or body).
+   --  This is done by the two procedures Save_Env and Restore_Env.
+
+   type Instance_Env is record
+      Ada_83              : Boolean;
+      Instantiated_Parent : Assoc;
+      Exchanged_Views     : Elist_Id;
+      Hidden_Entities     : Elist_Id;
+      Current_Sem_Unit    : Unit_Number_Type;
+   end record;
+
+   package Instance_Envs is new Table.Table (
+     Table_Component_Type => Instance_Env,
+     Table_Index_Type     => Int,
+     Table_Low_Bound      => 0,
+     Table_Initial        => 32,
+     Table_Increment      => 100,
+     Table_Name           => "Instance_Envs");
+
+   procedure Restore_Private_Views
+     (Pack_Id    : Entity_Id;
+      Is_Package : Boolean := True);
+   --  Restore the private views of external types, and unmark the generic
+   --  renamings of actuals, so that they become comptible subtypes again.
+   --  For subprograms, Pack_Id is the package constructed to hold the
+   --  renamings.
+
+   procedure Switch_View (T : Entity_Id);
+   --  Switch the partial and full views of a type and its private
+   --  dependents (i.e. its subtypes and derived types).
+
+   ------------------------------------
+   -- Structures for Error Reporting --
+   ------------------------------------
+
+   Instantiation_Node : Node_Id;
+   --  Used by subprograms that validate instantiation of formal parameters
+   --  where there might be no actual on which to place the error message.
+   --  Also used to locate the instantiation node for generic subunits.
+
+   Instantiation_Error : exception;
+   --  When there is a semantic error in the generic parameter matching,
+   --  there is no point in continuing the instantiation, because the
+   --  number of cascaded errors is unpredictable. This exception aborts
+   --  the instantiation process altogether.
+
+   S_Adjustment : Sloc_Adjustment;
+   --  Offset created for each node in an instantiation, in order to keep
+   --  track of the source position of the instantiation in each of its nodes.
+   --  A subsequent semantic error or warning on a construct of the instance
+   --  points to both places: the original generic node, and the point of
+   --  instantiation. See Sinput and Sinput.L for additional details.
+
+   ------------------------------------------------------------
+   -- Data structure for keeping track when inside a Generic --
+   ------------------------------------------------------------
+
+   --  The following table is used to save values of the Inside_A_Generic
+   --  flag (see spec of Sem) when they are saved by Start_Generic.
+
+   package Generic_Flags is new Table.Table (
+     Table_Component_Type => Boolean,
+     Table_Index_Type     => Int,
+     Table_Low_Bound      => 0,
+     Table_Initial        => 32,
+     Table_Increment      => 200,
+     Table_Name           => "Generic_Flags");
+
+   ---------------------------
+   -- Abandon_Instantiation --
+   ---------------------------
+
+   procedure Abandon_Instantiation (N : Node_Id) is
+   begin
+      Error_Msg_N ("instantiation abandoned!", N);
+      raise Instantiation_Error;
+   end Abandon_Instantiation;
+
+   --------------------------
+   -- Analyze_Associations --
+   --------------------------
+
+   function Analyze_Associations
+     (I_Node  : Node_Id;
+      Formals : List_Id;
+      F_Copy  : List_Id)
+      return    List_Id
+   is
+      Actuals         : List_Id := Generic_Associations (I_Node);
+      Actual          : Node_Id;
+      Actual_Types    : Elist_Id := New_Elmt_List;
+      Assoc           : List_Id  := New_List;
+      Formal          : Node_Id;
+      Next_Formal     : Node_Id;
+      Temp_Formal     : Node_Id;
+      Analyzed_Formal : Node_Id;
+      Defaults        : Elist_Id := New_Elmt_List;
+      Match           : Node_Id;
+      Named           : Node_Id;
+      First_Named     : Node_Id := Empty;
+      Found_Assoc     : Node_Id;
+      Is_Named_Assoc  : Boolean;
+      Num_Matched     : Int := 0;
+      Num_Actuals     : Int := 0;
+
+      function Matching_Actual
+        (F    : Entity_Id;
+         A_F  : Entity_Id)
+         return Node_Id;
+      --  Find actual that corresponds to a given a formal parameter. If the
+      --  actuals are positional, return the next one, if any. If the actuals
+      --  are named, scan the parameter associations to find the right one.
+      --  A_F is the corresponding entity in the analyzed generic,which is
+      --  placed on the selector name for ASIS use.
+
+      procedure Set_Analyzed_Formal;
+      --  Find the node in the generic copy that corresponds to a given formal.
+      --  The semantic information on this node is used to perform legality
+      --  checks on the actuals. Because semantic analysis can introduce some
+      --  anonymous entities or modify the declaration node itself, the
+      --  correspondence between the two lists is not one-one. In addition to
+      --  anonymous types, the presence a formal equality will introduce an
+      --  implicit declaration for the corresponding inequality.
+
+      ---------------------
+      -- Matching_Actual --
+      ---------------------
+
+      function Matching_Actual
+        (F    : Entity_Id;
+         A_F  : Entity_Id)
+         return Node_Id
+      is
+         Found : Node_Id;
+         Prev  : Node_Id;
+
+      begin
+         Is_Named_Assoc := False;
+
+         --  End of list of purely positional parameters
+
+         if No (Actual) then
+            Found := Empty;
+
+         --  Case of positional parameter corresponding to current formal
+
+         elsif No (Selector_Name (Actual)) then
+            Found := Explicit_Generic_Actual_Parameter (Actual);
+            Found_Assoc := Actual;
+            Num_Matched := Num_Matched + 1;
+            Next (Actual);
+
+         --  Otherwise scan list of named actuals to find the one with the
+         --  desired name. All remaining actuals have explicit names.
+
+         else
+            Is_Named_Assoc := True;
+            Found := Empty;
+            Prev  := Empty;
+
+            while Present (Actual) loop
+               if Chars (Selector_Name (Actual)) = Chars (F) then
+                  Found := Explicit_Generic_Actual_Parameter (Actual);
+                  Set_Entity (Selector_Name (Actual), A_F);
+                  Set_Etype  (Selector_Name (Actual), Etype (A_F));
+                  Found_Assoc := Actual;
+                  Num_Matched := Num_Matched + 1;
+                  exit;
+               end if;
+
+               Prev := Actual;
+               Next (Actual);
+            end loop;
+
+            --  Reset for subsequent searches. In most cases the named
+            --  associations are in order. If they are not, we reorder them
+            --  to avoid scanning twice the same actual. This is not just a
+            --  question of efficiency: there may be multiple defaults with
+            --  boxes that have the same name. In a nested instantiation we
+            --  insert actuals for those defaults, and cannot rely on their
+            --  names to disambiguate them.
+
+            if Actual = First_Named  then
+               Next (First_Named);
+
+            elsif Present (Actual) then
+               Insert_Before (First_Named, Remove_Next (Prev));
+            end if;
+
+            Actual := First_Named;
+         end if;
+
+         return Found;
+      end Matching_Actual;
+
+      -------------------------
+      -- Set_Analyzed_Formal --
+      -------------------------
+
+      procedure Set_Analyzed_Formal is
+         Kind : Node_Kind;
+      begin
+         while Present (Analyzed_Formal) loop
+            Kind := Nkind (Analyzed_Formal);
+
+            case Nkind (Formal) is
+
+               when N_Formal_Subprogram_Declaration =>
+                  exit when Kind = N_Formal_Subprogram_Declaration
+                    and then
+                      Chars
+                        (Defining_Unit_Name (Specification (Formal))) =
+                      Chars
+                        (Defining_Unit_Name (Specification (Analyzed_Formal)));
+
+               when N_Formal_Package_Declaration =>
+                  exit when
+                    Kind = N_Formal_Package_Declaration
+                      or else
+                    Kind = N_Generic_Package_Declaration;
+
+               when N_Use_Package_Clause | N_Use_Type_Clause => exit;
+
+               when others =>
+
+                  --  Skip freeze nodes, and nodes inserted to replace
+                  --  unrecognized pragmas.
+
+                  exit when
+                    Kind /= N_Formal_Subprogram_Declaration
+                      and then Kind /= N_Subprogram_Declaration
+                      and then Kind /= N_Freeze_Entity
+                      and then Kind /= N_Null_Statement
+                      and then Kind /= N_Itype_Reference
+                      and then Chars (Defining_Identifier (Formal)) =
+                               Chars (Defining_Identifier (Analyzed_Formal));
+            end case;
+
+            Next (Analyzed_Formal);
+         end loop;
+
+      end Set_Analyzed_Formal;
+
+   --  Start of processing for Analyze_Associations
+
+   begin
+      --  If named associations are present, save the first named association
+      --  (it may of course be Empty) to facilitate subsequent name search.
+
+      if Present (Actuals) then
+         First_Named := First (Actuals);
+
+         while Present (First_Named)
+           and then No (Selector_Name (First_Named))
+         loop
+            Num_Actuals := Num_Actuals + 1;
+            Next (First_Named);
+         end loop;
+      end if;
+
+      Named := First_Named;
+      while Present (Named) loop
+         if No (Selector_Name (Named)) then
+            Error_Msg_N ("invalid positional actual after named one", Named);
+            Abandon_Instantiation (Named);
+         end if;
+
+         Num_Actuals := Num_Actuals + 1;
+         Next (Named);
+      end loop;
+
+      if Present (Formals) then
+         Formal := First_Non_Pragma (Formals);
+         Analyzed_Formal := First_Non_Pragma (F_Copy);
+
+         if Present (Actuals) then
+            Actual := First (Actuals);
+
+         --  All formals should have default values
+
+         else
+            Actual := Empty;
+         end if;
+
+         while Present (Formal) loop
+            Set_Analyzed_Formal;
+            Next_Formal := Next_Non_Pragma (Formal);
+
+            case Nkind (Formal) is
+               when N_Formal_Object_Declaration =>
+                  Match :=
+                    Matching_Actual (
+                      Defining_Identifier (Formal),
+                      Defining_Identifier (Analyzed_Formal));
+
+                  Append_List
+                    (Instantiate_Object (Formal, Match, Analyzed_Formal),
+                     Assoc);
+
+               when N_Formal_Type_Declaration =>
+                  Match :=
+                    Matching_Actual (
+                      Defining_Identifier (Formal),
+                      Defining_Identifier (Analyzed_Formal));
+
+                  if No (Match) then
+                     Error_Msg_NE ("missing actual for instantiation of &",
+                        Instantiation_Node, Defining_Identifier (Formal));
+                     Abandon_Instantiation (Instantiation_Node);
+
+                  else
+                     Analyze (Match);
+                     Append_To (Assoc,
+                       Instantiate_Type (Formal, Match, Analyzed_Formal));
+
+                     --  an instantiation is a freeze point for the actuals,
+                     --  unless this is a rewritten formal package.
+
+                     if Nkind (I_Node) /= N_Formal_Package_Declaration then
+                        Append_Elmt (Entity (Match), Actual_Types);
+                     end if;
+                  end if;
+
+                  --  A remote access-to-class-wide type must not be an
+                  --  actual parameter for a generic formal of an access
+                  --  type (E.2.2 (17)).
+
+                  if Nkind (Analyzed_Formal) = N_Formal_Type_Declaration
+                    and then
+                      Nkind (Formal_Type_Definition (Analyzed_Formal)) =
+                                            N_Access_To_Object_Definition
+                  then
+                     Validate_Remote_Access_To_Class_Wide_Type (Match);
+                  end if;
+
+               when N_Formal_Subprogram_Declaration =>
+                  Match :=
+                    Matching_Actual (
+                      Defining_Unit_Name (Specification (Formal)),
+                      Defining_Unit_Name (Specification (Analyzed_Formal)));
+
+                  --  If the formal subprogram has the same name as
+                  --  another formal subprogram of the generic, then
+                  --  a named association is illegal (12.3(9)). Exclude
+                  --  named associations that are generated for a nested
+                  --  instance.
+
+                  if Present (Match)
+                    and then Is_Named_Assoc
+                    and then Comes_From_Source (Found_Assoc)
+                  then
+                     Temp_Formal := First (Formals);
+                     while Present (Temp_Formal) loop
+                        if Nkind (Temp_Formal) =
+                             N_Formal_Subprogram_Declaration
+                          and then Temp_Formal /= Formal
+                          and then
+                            Chars (Selector_Name (Found_Assoc)) =
+                              Chars (Defining_Unit_Name
+                                       (Specification (Temp_Formal)))
+                        then
+                           Error_Msg_N
+                             ("name not allowed for overloaded formal",
+                              Found_Assoc);
+                           Abandon_Instantiation (Instantiation_Node);
+                        end if;
+
+                        Next (Temp_Formal);
+                     end loop;
+                  end if;
+
+                  Append_To (Assoc,
+                    Instantiate_Formal_Subprogram
+                      (Formal, Match, Analyzed_Formal));
+
+                  if No (Match)
+                    and then Box_Present (Formal)
+                  then
+                     Append_Elmt
+                       (Defining_Unit_Name (Specification (Last (Assoc))),
+                         Defaults);
+                  end if;
+
+               when N_Formal_Package_Declaration =>
+                  Match :=
+                    Matching_Actual (
+                      Defining_Identifier (Formal),
+                      Defining_Identifier (Original_Node (Analyzed_Formal)));
+
+                  if No (Match) then
+                     Error_Msg_NE
+                       ("missing actual for instantiation of&",
+                        Instantiation_Node,
+                        Defining_Identifier (Formal));
+
+                     Abandon_Instantiation (Instantiation_Node);
+
+                  else
+                     Analyze (Match);
+                     Append_List
+                       (Instantiate_Formal_Package
+                         (Formal, Match, Analyzed_Formal),
+                        Assoc);
+                  end if;
+
+               --  For use type and use package appearing in the context
+               --  clause, we have already copied them, so we can just
+               --  move them where they belong (we mustn't recopy them
+               --  since this would mess up the Sloc values).
+
+               when N_Use_Package_Clause |
+                    N_Use_Type_Clause    =>
+                  Remove (Formal);
+                  Append (Formal, Assoc);
+
+               when others =>
+                  raise Program_Error;
+
+            end case;
+
+            Formal := Next_Formal;
+            Next_Non_Pragma (Analyzed_Formal);
+         end loop;
+
+         if Num_Actuals > Num_Matched then
+            Error_Msg_N
+              ("unmatched actuals in instantiation", Instantiation_Node);
+         end if;
+
+      elsif Present (Actuals) then
+         Error_Msg_N
+           ("too many actuals in generic instantiation", Instantiation_Node);
+      end if;
+
+      declare
+         Elmt : Elmt_Id := First_Elmt (Actual_Types);
+
+      begin
+         while Present (Elmt) loop
+            Freeze_Before (I_Node, Node (Elmt));
+            Next_Elmt (Elmt);
+         end loop;
+      end;
+
+      --  If there are default subprograms, normalize the tree by adding
+      --  explicit associations for them. This is required if the instance
+      --  appears within a generic.
+
+      declare
+         Elmt  : Elmt_Id;
+         Subp  : Entity_Id;
+         New_D : Node_Id;
+
+      begin
+         Elmt := First_Elmt (Defaults);
+         while Present (Elmt) loop
+            if No (Actuals) then
+               Actuals := New_List;
+               Set_Generic_Associations (I_Node, Actuals);
+            end if;
+
+            Subp := Node (Elmt);
+            New_D :=
+              Make_Generic_Association (Sloc (Subp),
+                Selector_Name => New_Occurrence_Of (Subp, Sloc (Subp)),
+                  Explicit_Generic_Actual_Parameter =>
+                    New_Occurrence_Of (Subp, Sloc (Subp)));
+            Mark_Rewrite_Insertion (New_D);
+            Append_To (Actuals, New_D);
+            Next_Elmt (Elmt);
+         end loop;
+      end;
+
+      return Assoc;
+   end Analyze_Associations;
+
+   -------------------------------
+   -- Analyze_Formal_Array_Type --
+   -------------------------------
+
+   procedure Analyze_Formal_Array_Type
+     (T   : in out Entity_Id;
+      Def : Node_Id)
+   is
+      DSS : Node_Id;
+
+   begin
+      --  Treated like a non-generic array declaration, with
+      --  additional semantic checks.
+
+      Enter_Name (T);
+
+      if Nkind (Def) = N_Constrained_Array_Definition then
+         DSS := First (Discrete_Subtype_Definitions (Def));
+         while Present (DSS) loop
+            if Nkind (DSS) = N_Subtype_Indication
+              or else Nkind (DSS) = N_Range
+              or else Nkind (DSS) = N_Attribute_Reference
+            then
+               Error_Msg_N ("only a subtype mark is allowed in a formal", DSS);
+            end if;
+
+            Next (DSS);
+         end loop;
+      end if;
+
+      Array_Type_Declaration (T, Def);
+      Set_Is_Generic_Type (Base_Type (T));
+
+      if Ekind (Component_Type (T)) = E_Incomplete_Type
+        and then No (Full_View (Component_Type (T)))
+      then
+         Error_Msg_N ("premature usage of incomplete type", Def);
+
+      elsif Is_Internal (Component_Type (T))
+        and then Nkind (Original_Node (Subtype_Indication (Def)))
+          /= N_Attribute_Reference
+      then
+         Error_Msg_N
+           ("only a subtype mark is allowed in a formal",
+              Subtype_Indication (Def));
+      end if;
+
+   end Analyze_Formal_Array_Type;
+
+   ---------------------------------------------
+   -- Analyze_Formal_Decimal_Fixed_Point_Type --
+   ---------------------------------------------
+
+   --  As for other generic types, we create a valid type representation
+   --  with legal but arbitrary attributes, whose values are never considered
+   --  static. For all scalar types we introduce an anonymous base type, with
+   --  the same attributes. We choose the corresponding integer type to be
+   --  Standard_Integer.
+
+   procedure Analyze_Formal_Decimal_Fixed_Point_Type
+     (T   : Entity_Id;
+      Def : Node_Id)
+   is
+      Loc       : constant Source_Ptr := Sloc (Def);
+      Base      : constant Entity_Id :=
+                    New_Internal_Entity
+                      (E_Decimal_Fixed_Point_Type,
+                       Current_Scope, Sloc (Def), 'G');
+      Int_Base  : constant Entity_Id := Standard_Integer;
+      Delta_Val : constant Ureal := Ureal_1;
+      Digs_Val  : constant Uint  := Uint_6;
+
+   begin
+      Enter_Name (T);
+
+      Set_Etype          (Base, Base);
+      Set_Size_Info      (Base, Int_Base);
+      Set_RM_Size        (Base, RM_Size (Int_Base));
+      Set_First_Rep_Item (Base, First_Rep_Item (Int_Base));
+      Set_Digits_Value   (Base, Digs_Val);
+      Set_Delta_Value    (Base, Delta_Val);
+      Set_Small_Value    (Base, Delta_Val);
+      Set_Scalar_Range   (Base,
+        Make_Range (Loc,
+          Low_Bound  => Make_Real_Literal (Loc, Ureal_1),
+          High_Bound => Make_Real_Literal (Loc, Ureal_1)));
+
+      Set_Is_Generic_Type (Base);
+      Set_Parent          (Base, Parent (Def));
+
+      Set_Ekind          (T, E_Decimal_Fixed_Point_Subtype);
+      Set_Etype          (T, Base);
+      Set_Size_Info      (T, Int_Base);
+      Set_RM_Size        (T, RM_Size (Int_Base));
+      Set_First_Rep_Item (T, First_Rep_Item (Int_Base));
+      Set_Digits_Value   (T, Digs_Val);
+      Set_Delta_Value    (T, Delta_Val);
+      Set_Small_Value    (T, Delta_Val);
+      Set_Scalar_Range   (T, Scalar_Range (Base));
+
+   end Analyze_Formal_Decimal_Fixed_Point_Type;
+
+   ---------------------------------
+   -- Analyze_Formal_Derived_Type --
+   ---------------------------------
+
+   procedure Analyze_Formal_Derived_Type
+     (N   : Node_Id;
+      T   : Entity_Id;
+      Def : Node_Id)
+   is
+      Loc      : constant Source_Ptr := Sloc (Def);
+      New_N    : Node_Id;
+      Unk_Disc : Boolean := Unknown_Discriminants_Present (N);
+
+   begin
+      Set_Is_Generic_Type (T);
+
+      if Private_Present (Def) then
+         New_N :=
+           Make_Private_Extension_Declaration (Loc,
+             Defining_Identifier           => T,
+             Discriminant_Specifications   => Discriminant_Specifications (N),
+             Unknown_Discriminants_Present => Unk_Disc,
+             Subtype_Indication            => Subtype_Mark (Def));
+
+         Set_Abstract_Present (New_N, Abstract_Present (Def));
+
+      else
+         New_N :=
+           Make_Full_Type_Declaration (Loc,
+             Defining_Identifier => T,
+             Discriminant_Specifications =>
+               Discriminant_Specifications (Parent (T)),
+              Type_Definition =>
+                Make_Derived_Type_Definition (Loc,
+                  Subtype_Indication => Subtype_Mark (Def)));
+
+         Set_Abstract_Present
+           (Type_Definition (New_N), Abstract_Present (Def));
+      end if;
+
+      Rewrite (N, New_N);
+      Analyze (N);
+
+      if Unk_Disc then
+         if not Is_Composite_Type (T) then
+            Error_Msg_N
+              ("unknown discriminants not allowed for elementary types", N);
+         else
+            Set_Has_Unknown_Discriminants (T);
+            Set_Is_Constrained (T, False);
+         end if;
+      end if;
+
+      --  If the parent type has a known size, so does the formal, which
+      --  makes legal representation clauses that involve the formal.
+
+      Set_Size_Known_At_Compile_Time
+        (T, Size_Known_At_Compile_Time (Entity (Subtype_Mark (Def))));
+
+   end Analyze_Formal_Derived_Type;
+
+   ----------------------------------
+   -- Analyze_Formal_Discrete_Type --
+   ----------------------------------
+
+   --  The operations defined for a discrete types are those of an
+   --  enumeration type. The size is set to an arbitrary value, for use
+   --  in analyzing the generic unit.
+
+   procedure Analyze_Formal_Discrete_Type (T : Entity_Id; Def : Node_Id) is
+      Loc : constant Source_Ptr := Sloc (Def);
+      Lo  : Node_Id;
+      Hi  : Node_Id;
+
+   begin
+      Enter_Name     (T);
+      Set_Ekind      (T, E_Enumeration_Type);
+      Set_Etype      (T, T);
+      Init_Size      (T, 8);
+      Init_Alignment (T);
+
+      --  For semantic analysis, the bounds of the type must be set to some
+      --  non-static value. The simplest is to create attribute nodes for
+      --  those bounds, that refer to the type itself. These bounds are never
+      --  analyzed but serve as place-holders.
+
+      Lo :=
+        Make_Attribute_Reference (Loc,
+          Attribute_Name => Name_First,
+          Prefix => New_Reference_To (T, Loc));
+      Set_Etype (Lo, T);
+
+      Hi :=
+        Make_Attribute_Reference (Loc,
+          Attribute_Name => Name_Last,
+          Prefix => New_Reference_To (T, Loc));
+      Set_Etype (Hi, T);
+
+      Set_Scalar_Range (T,
+        Make_Range (Loc,
+          Low_Bound => Lo,
+          High_Bound => Hi));
+
+   end Analyze_Formal_Discrete_Type;
+
+   ----------------------------------
+   -- Analyze_Formal_Floating_Type --
+   ---------------------------------
+
+   procedure Analyze_Formal_Floating_Type (T : Entity_Id; Def : Node_Id) is
+      Base : constant Entity_Id :=
+               New_Internal_Entity
+                 (E_Floating_Point_Type, Current_Scope, Sloc (Def), 'G');
+
+   begin
+      --  The various semantic attributes are taken from the predefined type
+      --  Float, just so that all of them are initialized. Their values are
+      --  never used because no constant folding or expansion takes place in
+      --  the generic itself.
+
+      Enter_Name (T);
+      Set_Ekind        (T, E_Floating_Point_Subtype);
+      Set_Etype        (T, Base);
+      Set_Size_Info    (T,              (Standard_Float));
+      Set_RM_Size      (T, RM_Size      (Standard_Float));
+      Set_Digits_Value (T, Digits_Value (Standard_Float));
+      Set_Scalar_Range (T, Scalar_Range (Standard_Float));
+
+      Set_Is_Generic_Type (Base);
+      Set_Etype           (Base, Base);
+      Set_Size_Info       (Base,              (Standard_Float));
+      Set_RM_Size         (Base, RM_Size      (Standard_Float));
+      Set_Digits_Value    (Base, Digits_Value (Standard_Float));
+      Set_Scalar_Range    (Base, Scalar_Range (Standard_Float));
+      Set_Parent          (Base, Parent (Def));
+   end Analyze_Formal_Floating_Type;
+
+   ---------------------------------
+   -- Analyze_Formal_Modular_Type --
+   ---------------------------------
+
+   procedure Analyze_Formal_Modular_Type (T : Entity_Id; Def : Node_Id) is
+   begin
+      --  Apart from their entity kind, generic modular types are treated
+      --  like signed integer types, and have the same attributes.
+
+      Analyze_Formal_Signed_Integer_Type (T, Def);
+      Set_Ekind (T, E_Modular_Integer_Subtype);
+      Set_Ekind (Etype (T), E_Modular_Integer_Type);
+
+   end Analyze_Formal_Modular_Type;
+
+   ---------------------------------------
+   -- Analyze_Formal_Object_Declaration --
+   ---------------------------------------
+
+   procedure Analyze_Formal_Object_Declaration (N : Node_Id) is
+      E  : constant Node_Id := Expression (N);
+      Id : Node_Id := Defining_Identifier (N);
+      K  : Entity_Kind;
+      T  : Node_Id;
+
+   begin
+      Enter_Name (Id);
+
+      --  Determine the mode of the formal object
+
+      if Out_Present (N) then
+         K := E_Generic_In_Out_Parameter;
+
+         if not In_Present (N) then
+            Error_Msg_N ("formal generic objects cannot have mode OUT", N);
+         end if;
+
+      else
+         K := E_Generic_In_Parameter;
+      end if;
+
+      Find_Type (Subtype_Mark (N));
+      T  := Entity (Subtype_Mark (N));
+
+      if Ekind (T) = E_Incomplete_Type then
+         Error_Msg_N ("premature usage of incomplete type", Subtype_Mark (N));
+      end if;
+
+      if K = E_Generic_In_Parameter then
+         if Is_Limited_Type (T) then
+            Error_Msg_N
+              ("generic formal of mode IN must not be of limited type", N);
+         end if;
+
+         if Is_Abstract (T) then
+            Error_Msg_N
+              ("generic formal of mode IN must not be of abstract type", N);
+         end if;
+
+         if Present (E) then
+            Analyze_Default_Expression (E, T);
+         end if;
+
+         Set_Ekind (Id, K);
+         Set_Etype (Id, T);
+
+      --  Case of generic IN OUT parameter.
+
+      else
+         --  If the formal has an unconstrained type, construct its
+         --  actual subtype, as is done for subprogram formals. In this
+         --  fashion, all its uses can refer to specific bounds.
+
+         Set_Ekind (Id, K);
+         Set_Etype (Id, T);
+
+         if (Is_Array_Type (T)
+              and then not Is_Constrained (T))
+           or else
+            (Ekind (T) = E_Record_Type
+              and then Has_Discriminants (T))
+         then
+            declare
+               Non_Freezing_Ref : constant Node_Id :=
+                                    New_Reference_To (Id, Sloc (Id));
+               Decl : Node_Id;
+
+            begin
+               --  Make sure that the actual subtype doesn't generate
+               --  bogus freezing.
+
+               Set_Must_Not_Freeze (Non_Freezing_Ref);
+               Decl := Build_Actual_Subtype (T, Non_Freezing_Ref);
+               Insert_Before_And_Analyze (N, Decl);
+               Set_Actual_Subtype (Id, Defining_Identifier (Decl));
+            end;
+         else
+            Set_Actual_Subtype (Id, T);
+         end if;
+
+         if Present (E) then
+            Error_Msg_N
+              ("initialization not allowed for `IN OUT` formals", N);
+         end if;
+      end if;
+
+   end Analyze_Formal_Object_Declaration;
+
+   ----------------------------------------------
+   -- Analyze_Formal_Ordinary_Fixed_Point_Type --
+   ----------------------------------------------
+
+   procedure Analyze_Formal_Ordinary_Fixed_Point_Type
+     (T   : Entity_Id;
+      Def : Node_Id)
+   is
+      Loc  : constant Source_Ptr := Sloc (Def);
+      Base : constant Entity_Id :=
+               New_Internal_Entity
+                 (E_Ordinary_Fixed_Point_Type, Current_Scope, Sloc (Def), 'G');
+   begin
+      --  The semantic attributes are set for completeness only, their
+      --  values will never be used, because all properties of the type
+      --  are non-static.
+
+      Enter_Name (T);
+      Set_Ekind            (T, E_Ordinary_Fixed_Point_Subtype);
+      Set_Etype            (T, Base);
+      Set_Size_Info        (T, Standard_Integer);
+      Set_RM_Size          (T, RM_Size (Standard_Integer));
+      Set_Small_Value      (T, Ureal_1);
+      Set_Delta_Value      (T, Ureal_1);
+      Set_Scalar_Range     (T,
+        Make_Range (Loc,
+          Low_Bound  => Make_Real_Literal (Loc, Ureal_1),
+          High_Bound => Make_Real_Literal (Loc, Ureal_1)));
+
+      Set_Is_Generic_Type (Base);
+      Set_Etype           (Base, Base);
+      Set_Size_Info       (Base, Standard_Integer);
+      Set_RM_Size         (Base, RM_Size (Standard_Integer));
+      Set_Small_Value     (Base, Ureal_1);
+      Set_Delta_Value     (Base, Ureal_1);
+      Set_Scalar_Range    (Base, Scalar_Range (T));
+      Set_Parent          (Base, Parent (Def));
+   end Analyze_Formal_Ordinary_Fixed_Point_Type;
+
+   ----------------------------
+   -- Analyze_Formal_Package --
+   ----------------------------
+
+   procedure Analyze_Formal_Package (N : Node_Id) is
+      Loc              : constant Source_Ptr := Sloc (N);
+      Formal           : Entity_Id := Defining_Identifier (N);
+      Gen_Id           : constant Node_Id   := Name (N);
+      Gen_Decl         : Node_Id;
+      Gen_Unit         : Entity_Id;
+      New_N            : Node_Id;
+      Parent_Installed : Boolean := False;
+      Renaming         : Node_Id;
+      Parent_Instance  : Entity_Id;
+      Renaming_In_Par  : Entity_Id;
+
+   begin
+      Text_IO_Kludge (Gen_Id);
+
+      Check_Generic_Child_Unit (Gen_Id, Parent_Installed);
+      Gen_Unit := Entity (Gen_Id);
+
+      if Ekind (Gen_Unit) /= E_Generic_Package then
+         Error_Msg_N ("expect generic package name", Gen_Id);
+         return;
+
+      elsif  Gen_Unit = Current_Scope then
+         Error_Msg_N
+           ("generic package cannot be used as a formal package of itself",
+             Gen_Id);
+         return;
+      end if;
+
+      --  Check for a formal package that is a package renaming.
+
+      if Present (Renamed_Object (Gen_Unit)) then
+         Gen_Unit := Renamed_Object (Gen_Unit);
+      end if;
+
+      --  The formal package is treated like a regular instance, but only
+      --  the specification needs to be instantiated, to make entities visible.
+
+      if not Box_Present (N) then
+         Hidden_Entities := New_Elmt_List;
+         Analyze_Package_Instantiation (N);
+
+         if Parent_Installed then
+            Remove_Parent;
+         end if;
+
+      else
+         --  If there are no generic associations, the generic parameters
+         --  appear as local entities and are instantiated like them. We copy
+         --  the generic package declaration as if it were an instantiation,
+         --  and analyze it like a regular package, except that we treat the
+         --  formals as additional visible components.
+
+         Save_Env (Gen_Unit, Formal);
+
+         Gen_Decl := Unit_Declaration_Node (Gen_Unit);
+
+         if In_Extended_Main_Source_Unit (N) then
+            Set_Is_Instantiated (Gen_Unit);
+            Generate_Reference  (Gen_Unit, N);
+         end if;
+
+         New_N :=
+           Copy_Generic_Node
+             (Original_Node (Gen_Decl), Empty, Instantiating => True);
+         Set_Defining_Unit_Name (Specification (New_N), Formal);
+         Rewrite (N, New_N);
+
+         Enter_Name (Formal);
+         Set_Ekind  (Formal, E_Generic_Package);
+         Set_Etype  (Formal, Standard_Void_Type);
+         Set_Inner_Instances (Formal, New_Elmt_List);
+         New_Scope  (Formal);
+
+         --  Within the formal, the name of the generic package is a renaming
+         --  of the formal (as for a regular instantiation).
+
+         Renaming := Make_Package_Renaming_Declaration (Loc,
+             Defining_Unit_Name =>
+               Make_Defining_Identifier (Loc, Chars (Gen_Unit)),
+             Name => New_Reference_To (Formal, Loc));
+
+         if Present (Visible_Declarations (Specification (N))) then
+            Prepend (Renaming, To => Visible_Declarations (Specification (N)));
+         elsif Present (Private_Declarations (Specification (N))) then
+            Prepend (Renaming, To => Private_Declarations (Specification (N)));
+         end if;
+
+         if Is_Child_Unit (Gen_Unit)
+           and then Parent_Installed
+         then
+            --  Similarly, we have to make the name of the formal visible in
+            --  the parent instance, to resolve properly fully qualified names
+            --  that may appear in the generic unit. The parent instance has
+            --  been placed on the scope stack ahead of the current scope.
+
+            Parent_Instance := Scope_Stack.Table (Scope_Stack.Last - 1).Entity;
+
+            Renaming_In_Par :=
+              Make_Defining_Identifier (Loc, Chars (Gen_Unit));
+            Set_Ekind (Renaming_In_Par, E_Package);
+            Set_Etype (Renaming_In_Par, Standard_Void_Type);
+            Set_Scope (Renaming_In_Par, Parent_Instance);
+            Set_Parent (Renaming_In_Par, Parent (Formal));
+            Set_Renamed_Object (Renaming_In_Par, Formal);
+            Append_Entity (Renaming_In_Par, Parent_Instance);
+         end if;
+
+         Analyze_Generic_Formal_Part (N);
+         Analyze (Specification (N));
+         End_Package_Scope (Formal);
+
+         if Parent_Installed then
+            Remove_Parent;
+         end if;
+
+         Restore_Env;
+
+         --  Inside the generic unit, the formal package is a regular
+         --  package, but no body is needed for it. Note that after
+         --  instantiation, the defining_unit_name we need is in the
+         --  new tree and not in the original. (see Package_Instantiation).
+         --  A generic formal package is an instance, and can be used as
+         --  an actual for an inner instance. Mark its generic parent.
+
+         Set_Ekind (Formal, E_Package);
+         Set_Generic_Parent (Specification (N), Gen_Unit);
+         Set_Has_Completion (Formal, True);
+      end if;
+   end Analyze_Formal_Package;
+
+   ---------------------------------
+   -- Analyze_Formal_Private_Type --
+   ---------------------------------
+
+   procedure Analyze_Formal_Private_Type
+     (N   : Node_Id;
+      T   : Entity_Id;
+      Def : Node_Id)
+   is
+   begin
+      New_Private_Type (N, T, Def);
+
+      --  Set the size to an arbitrary but legal value.
+
+      Set_Size_Info (T, Standard_Integer);
+      Set_RM_Size   (T, RM_Size (Standard_Integer));
+   end Analyze_Formal_Private_Type;
+
+   ----------------------------------------
+   -- Analyze_Formal_Signed_Integer_Type --
+   ----------------------------------------
+
+   procedure Analyze_Formal_Signed_Integer_Type
+     (T   : Entity_Id;
+      Def : Node_Id)
+   is
+      Base : constant Entity_Id :=
+               New_Internal_Entity
+                 (E_Signed_Integer_Type, Current_Scope, Sloc (Def), 'G');
+
+   begin
+      Enter_Name (T);
+
+      Set_Ekind        (T, E_Signed_Integer_Subtype);
+      Set_Etype        (T, Base);
+      Set_Size_Info    (T, Standard_Integer);
+      Set_RM_Size      (T, RM_Size (Standard_Integer));
+      Set_Scalar_Range (T, Scalar_Range (Standard_Integer));
+
+      Set_Is_Generic_Type (Base);
+      Set_Size_Info       (Base, Standard_Integer);
+      Set_RM_Size         (Base, RM_Size (Standard_Integer));
+      Set_Etype           (Base, Base);
+      Set_Scalar_Range    (Base, Scalar_Range (Standard_Integer));
+      Set_Parent          (Base, Parent (Def));
+   end Analyze_Formal_Signed_Integer_Type;
+
+   -------------------------------
+   -- Analyze_Formal_Subprogram --
+   -------------------------------
+
+   procedure Analyze_Formal_Subprogram (N : Node_Id) is
+      Spec : constant Node_Id   := Specification (N);
+      Def  : constant Node_Id   := Default_Name (N);
+      Nam  : constant Entity_Id := Defining_Unit_Name (Spec);
+      Subp : Entity_Id;
+
+   begin
+      if Nkind (Nam) = N_Defining_Program_Unit_Name then
+         Error_Msg_N ("name of formal subprogram must be a direct name", Nam);
+         return;
+      end if;
+
+      Analyze_Subprogram_Declaration (N);
+      Set_Is_Formal_Subprogram (Nam);
+      Set_Has_Completion (Nam);
+
+      --  Default name is resolved at the point of instantiation
+
+      if Box_Present (N) then
+         null;
+
+      --  Else default is bound at the point of generic declaration
+
+      elsif Present (Def) then
+         if Nkind (Def) = N_Operator_Symbol then
+            Find_Direct_Name (Def);
+
+         elsif Nkind (Def) /= N_Attribute_Reference then
+            Analyze (Def);
+
+         else
+            --  For an attribute reference, analyze the prefix and verify
+            --  that it has the proper profile for the subprogram.
+
+            Analyze (Prefix (Def));
+            Valid_Default_Attribute (Nam, Def);
+            return;
+         end if;
+
+         --  Default name may be overloaded, in which case the interpretation
+         --  with the correct profile must be  selected, as for a renaming.
+
+         if Etype (Def) = Any_Type then
+            return;
+
+         elsif Nkind (Def) = N_Selected_Component then
+            Subp := Entity (Selector_Name (Def));
+
+            if Ekind (Subp) /= E_Entry then
+               Error_Msg_N ("expect valid subprogram name as default", Def);
+               return;
+            end if;
+
+         elsif Nkind (Def) = N_Indexed_Component then
+
+            if  Nkind (Prefix (Def)) /= N_Selected_Component then
+               Error_Msg_N ("expect valid subprogram name as default", Def);
+               return;
+
+            else
+               Subp := Entity (Selector_Name (Prefix (Def)));
+
+               if Ekind (Subp) /= E_Entry_Family then
+                  Error_Msg_N ("expect valid subprogram name as default", Def);
+                  return;
+               end if;
+            end if;
+
+         elsif Nkind (Def) = N_Character_Literal then
+
+            --  Needs some type checks: subprogram should be parameterless???
+
+            Resolve (Def, (Etype (Nam)));
+
+         elsif (not Is_Entity_Name (Def)
+           or else not Is_Overloadable (Entity (Def)))
+         then
+            Error_Msg_N ("expect valid subprogram name as default", Def);
+            return;
+
+         elsif not Is_Overloaded (Def) then
+            Subp := Entity (Def);
+
+            if Subp = Nam then
+               Error_Msg_N ("premature usage of formal subprogram", Def);
+
+            elsif not Entity_Matches_Spec (Subp, Nam) then
+               Error_Msg_N ("no visible entity matches specification", Def);
+            end if;
+
+         else
+            declare
+               I   : Interp_Index;
+               I1  : Interp_Index := 0;
+               It  : Interp;
+               It1 : Interp;
+
+            begin
+               Subp := Any_Id;
+               Get_First_Interp (Def, I, It);
+               while Present (It.Nam) loop
+
+                  if Entity_Matches_Spec (It.Nam, Nam) then
+                     if Subp /= Any_Id then
+                        It1 := Disambiguate (Def, I1, I, Etype (Subp));
+
+                        if It1 = No_Interp then
+                           Error_Msg_N ("ambiguous default subprogram", Def);
+                        else
+                           Subp := It1.Nam;
+                        end if;
+
+                        exit;
+
+                     else
+                        I1  := I;
+                        Subp := It.Nam;
+                     end if;
+                  end if;
+
+                  Get_Next_Interp (I, It);
+               end loop;
+            end;
+
+            if Subp /= Any_Id then
+               Set_Entity (Def, Subp);
+
+               if Subp = Nam then
+                  Error_Msg_N ("premature usage of formal subprogram", Def);
+
+               elsif Ekind (Subp) /= E_Operator then
+                  Check_Mode_Conformant (Subp, Nam);
+               end if;
+
+            else
+               Error_Msg_N ("no visible subprogram matches specification", N);
+            end if;
+         end if;
+      end if;
+   end Analyze_Formal_Subprogram;
+
+   -------------------------------------
+   -- Analyze_Formal_Type_Declaration --
+   -------------------------------------
+
+   procedure Analyze_Formal_Type_Declaration (N : Node_Id) is
+      Def : constant Node_Id := Formal_Type_Definition (N);
+      T   : Entity_Id;
+
+   begin
+      T := Defining_Identifier (N);
+
+      if Present (Discriminant_Specifications (N))
+        and then Nkind (Def) /= N_Formal_Private_Type_Definition
+      then
+         Error_Msg_N
+           ("discriminants not allowed for this formal type",
+            Defining_Identifier (First (Discriminant_Specifications (N))));
+      end if;
+
+      --  Enter the new name, and branch to specific routine.
+
+      case Nkind (Def) is
+         when N_Formal_Private_Type_Definition
+                        => Analyze_Formal_Private_Type (N, T, Def);
+
+         when N_Formal_Derived_Type_Definition
+                        => Analyze_Formal_Derived_Type (N, T, Def);
+
+         when N_Formal_Discrete_Type_Definition
+                        => Analyze_Formal_Discrete_Type (T, Def);
+
+         when N_Formal_Signed_Integer_Type_Definition
+                        => Analyze_Formal_Signed_Integer_Type (T, Def);
+
+         when N_Formal_Modular_Type_Definition
+                        => Analyze_Formal_Modular_Type (T, Def);
+
+         when N_Formal_Floating_Point_Definition
+                        => Analyze_Formal_Floating_Type (T, Def);
+
+         when N_Formal_Ordinary_Fixed_Point_Definition
+                        => Analyze_Formal_Ordinary_Fixed_Point_Type (T, Def);
+
+         when N_Formal_Decimal_Fixed_Point_Definition
+                        => Analyze_Formal_Decimal_Fixed_Point_Type (T, Def);
+
+         when N_Array_Type_Definition
+                        => Analyze_Formal_Array_Type (T, Def);
+
+         when N_Access_To_Object_Definition |
+              N_Access_Function_Definition  |
+              N_Access_Procedure_Definition
+                        => Analyze_Generic_Access_Type (T, Def);
+
+         when others =>
+            raise Program_Error;
+
+      end case;
+
+      Set_Is_Generic_Type (T);
+
+   end Analyze_Formal_Type_Declaration;
+
+   ------------------------------------
+   -- Analyze_Function_Instantiation --
+   ------------------------------------
+
+   procedure Analyze_Function_Instantiation (N : Node_Id) is
+   begin
+      Analyze_Subprogram_Instantiation (N, E_Function);
+   end Analyze_Function_Instantiation;
+
+   ---------------------------------
+   -- Analyze_Generic_Access_Type --
+   ---------------------------------
+
+   procedure Analyze_Generic_Access_Type (T : Entity_Id; Def : Node_Id) is
+   begin
+      Enter_Name (T);
+
+      if Nkind (Def) = N_Access_To_Object_Definition then
+         Access_Type_Declaration (T, Def);
+
+         if Is_Incomplete_Or_Private_Type (Designated_Type (T))
+           and then No (Full_View (Designated_Type (T)))
+           and then not Is_Generic_Type (Designated_Type (T))
+         then
+            Error_Msg_N ("premature usage of incomplete type", Def);
+
+         elsif Is_Internal (Designated_Type (T)) then
+            Error_Msg_N
+              ("only a subtype mark is allowed in a formal", Def);
+         end if;
+
+      else
+         Access_Subprogram_Declaration (T, Def);
+      end if;
+   end Analyze_Generic_Access_Type;
+
+   ---------------------------------
+   -- Analyze_Generic_Formal_Part --
+   ---------------------------------
+
+   procedure Analyze_Generic_Formal_Part (N : Node_Id) is
+      Gen_Parm_Decl : Node_Id;
+
+   begin
+      --  The generic formals are processed in the scope of the generic
+      --  unit, where they are immediately visible. The scope is installed
+      --  by the caller.
+
+      Gen_Parm_Decl := First (Generic_Formal_Declarations (N));
+
+      while Present (Gen_Parm_Decl) loop
+         Analyze (Gen_Parm_Decl);
+         Next (Gen_Parm_Decl);
+      end loop;
+   end Analyze_Generic_Formal_Part;
+
+   ------------------------------------------
+   -- Analyze_Generic_Package_Declaration  --
+   ------------------------------------------
+
+   procedure Analyze_Generic_Package_Declaration (N : Node_Id) is
+      Id          : Entity_Id;
+      New_N       : Node_Id;
+      Save_Parent : Node_Id;
+
+   begin
+      --  Create copy of generic unit, and save for instantiation.
+      --  If the unit is a child unit, do not copy the specifications
+      --  for the parent, which are not part of the generic tree.
+
+      Save_Parent := Parent_Spec (N);
+      Set_Parent_Spec (N, Empty);
+
+      New_N := Copy_Generic_Node (N, Empty, Instantiating => False);
+      Set_Parent_Spec (New_N, Save_Parent);
+      Rewrite (N, New_N);
+      Id := Defining_Entity (N);
+      Generate_Definition (Id);
+
+      --  Expansion is not applied to generic units.
+
+      Start_Generic;
+
+      Enter_Name (Id);
+      Set_Ekind (Id, E_Generic_Package);
+      Set_Etype (Id, Standard_Void_Type);
+      New_Scope (Id);
+      Enter_Generic_Scope (Id);
+      Set_Inner_Instances (Id, New_Elmt_List);
+
+      Set_Categorization_From_Pragmas (N);
+      Set_Is_Pure (Id, Is_Pure (Current_Scope));
+
+      --  For a library unit, we have reconstructed the entity for the
+      --  unit, and must reset it in the library tables.
+
+      if Nkind (Parent (N)) = N_Compilation_Unit then
+         Set_Cunit_Entity (Current_Sem_Unit, Id);
+      end if;
+
+      Analyze_Generic_Formal_Part (N);
+
+      --  After processing the generic formals, analysis proceeds
+      --  as for a non-generic package.
+
+      Analyze (Specification (N));
+
+      Validate_Categorization_Dependency (N, Id);
+
+      End_Generic;
+
+      End_Package_Scope (Id);
+      Exit_Generic_Scope (Id);
+
+      if Nkind (Parent (N)) /= N_Compilation_Unit then
+         Move_Freeze_Nodes (Id, N, Visible_Declarations (Specification (N)));
+         Move_Freeze_Nodes (Id, N, Private_Declarations (Specification (N)));
+         Move_Freeze_Nodes (Id, N, Generic_Formal_Declarations (N));
+
+      else
+         Set_Body_Required (Parent (N), Unit_Requires_Body (Id));
+         Validate_RT_RAT_Component (N);
+      end if;
+
+   end Analyze_Generic_Package_Declaration;
+
+   --------------------------------------------
+   -- Analyze_Generic_Subprogram_Declaration --
+   --------------------------------------------
+
+   procedure Analyze_Generic_Subprogram_Declaration (N : Node_Id) is
+      Spec        : Node_Id;
+      Id          : Entity_Id;
+      Formals     : List_Id;
+      New_N       : Node_Id;
+      Save_Parent : Node_Id;
+
+   begin
+      --  Create copy of generic unit,and save for instantiation.
+      --  If the unit is a child unit, do not copy the specifications
+      --  for the parent, which are not part of the generic tree.
+
+      Save_Parent := Parent_Spec (N);
+      Set_Parent_Spec (N, Empty);
+
+      New_N := Copy_Generic_Node (N, Empty, Instantiating => False);
+      Set_Parent_Spec (New_N, Save_Parent);
+      Rewrite (N, New_N);
+
+      Spec := Specification (N);
+      Id := Defining_Entity (Spec);
+      Generate_Definition (Id);
+
+      if Nkind (Id) = N_Defining_Operator_Symbol then
+         Error_Msg_N
+           ("operator symbol not allowed for generic subprogram", Id);
+      end if;
+
+      Start_Generic;
+
+      Enter_Name (Id);
+
+      New_Scope (Id);
+      Set_Inner_Instances (Id, New_Elmt_List);
+      Set_Is_Pure (Id, Is_Pure (Current_Scope));
+
+      Analyze_Generic_Formal_Part (N);
+
+      Formals := Parameter_Specifications (Spec);
+
+      if Present (Formals) then
+         Process_Formals (Id, Formals, Spec);
+      end if;
+
+      if Nkind (Spec) = N_Function_Specification then
+         Set_Ekind (Id, E_Generic_Function);
+         Find_Type (Subtype_Mark (Spec));
+         Set_Etype (Id, Entity (Subtype_Mark (Spec)));
+      else
+         Set_Ekind (Id, E_Generic_Procedure);
+         Set_Etype (Id, Standard_Void_Type);
+      end if;
+
+      --  For a library unit, we have reconstructed the entity for the
+      --  unit, and must reset it in the library tables. We also need
+      --  to make sure that Body_Required is set properly in the original
+      --  compilation unit node.
+
+      if Nkind (Parent (N)) = N_Compilation_Unit then
+         Set_Cunit_Entity (Current_Sem_Unit, Id);
+         Set_Body_Required (Parent (N), Unit_Requires_Body (Id));
+      end if;
+
+      Set_Categorization_From_Pragmas (N);
+      Validate_Categorization_Dependency (N, Id);
+
+      Save_Global_References (Original_Node (N));
+
+      End_Generic;
+      End_Scope;
+
+   end Analyze_Generic_Subprogram_Declaration;
+
+   -----------------------------------
+   -- Analyze_Package_Instantiation --
+   -----------------------------------
+
+   --  Note: this procedure is also used for formal package declarations,
+   --  in which case the argument N is an N_Formal_Package_Declaration
+   --  node. This should really be noted in the spec! ???
+
+   procedure Analyze_Package_Instantiation (N : Node_Id) is
+      Loc     : constant Source_Ptr := Sloc (N);
+      Gen_Id  : constant Node_Id    := Name (N);
+
+      Act_Decl      : Node_Id;
+      Act_Decl_Name : Node_Id;
+      Act_Decl_Id   : Entity_Id;
+      Act_Spec      : Node_Id;
+      Act_Tree      : Node_Id;
+
+      Gen_Decl : Node_Id;
+      Gen_Unit : Entity_Id;
+
+      Is_Actual_Pack   : Boolean := Is_Internal (Defining_Entity (N));
+      Parent_Installed : Boolean := False;
+      Renaming_List    : List_Id;
+      Unit_Renaming    : Node_Id;
+      Needs_Body       : Boolean;
+      Inline_Now       : Boolean := False;
+
+      procedure Delay_Descriptors (E : Entity_Id);
+      --  Delay generation of subprogram descriptors for given entity
+
+      function Might_Inline_Subp return Boolean;
+      --  If inlining is active and the generic contains inlined subprograms,
+      --  we instantiate the body. This may cause superfluous instantiations,
+      --  but it is simpler than detecting the need for the body at the point
+      --  of inlining, when the context of the instance is not available.
+
+      -----------------------
+      -- Delay_Descriptors --
+      -----------------------
+
+      procedure Delay_Descriptors (E : Entity_Id) is
+      begin
+         if not Delay_Subprogram_Descriptors (E) then
+            Set_Delay_Subprogram_Descriptors (E);
+            Pending_Descriptor.Increment_Last;
+            Pending_Descriptor.Table (Pending_Descriptor.Last) := E;
+         end if;
+      end Delay_Descriptors;
+
+      -----------------------
+      -- Might_Inline_Subp --
+      -----------------------
+
+      function Might_Inline_Subp return Boolean is
+         E : Entity_Id;
+
+      begin
+         if not Inline_Processing_Required then
+            return False;
+
+         else
+            E := First_Entity (Gen_Unit);
+
+            while Present (E) loop
+
+               if Is_Subprogram (E)
+                 and then Is_Inlined (E)
+               then
+                  return True;
+               end if;
+
+               Next_Entity (E);
+            end loop;
+         end if;
+
+         return False;
+      end Might_Inline_Subp;
+
+   --  Start of processing for Analyze_Package_Instantiation
+
+   begin
+      --  Very first thing: apply the special kludge for Text_IO processing
+      --  in case we are instantiating one of the children of [Wide_]Text_IO.
+
+      Text_IO_Kludge (Name (N));
+
+      --  Make node global for error reporting.
+
+      Instantiation_Node := N;
+
+      --  Case of instantiation of a generic package
+
+      if Nkind (N) = N_Package_Instantiation then
+         Act_Decl_Id := New_Copy (Defining_Entity (N));
+         Set_Comes_From_Source (Act_Decl_Id, True);
+
+         if Nkind (Defining_Unit_Name (N)) = N_Defining_Program_Unit_Name then
+            Act_Decl_Name :=
+              Make_Defining_Program_Unit_Name (Loc,
+                Name => New_Copy_Tree (Name (Defining_Unit_Name (N))),
+                Defining_Identifier => Act_Decl_Id);
+         else
+            Act_Decl_Name :=  Act_Decl_Id;
+         end if;
+
+      --  Case of instantiation of a formal package
+
+      else
+         Act_Decl_Id   := Defining_Identifier (N);
+         Act_Decl_Name := Act_Decl_Id;
+      end if;
+
+      Generate_Definition (Act_Decl_Id);
+      Pre_Analyze_Actuals (N);
+
+      Check_Generic_Child_Unit (Gen_Id, Parent_Installed);
+      Gen_Unit := Entity (Gen_Id);
+
+      --  Verify that it is the name of a generic package
+
+      if Etype (Gen_Unit) = Any_Type then
+         return;
+
+      elsif Ekind (Gen_Unit) /= E_Generic_Package then
+         Error_Msg_N
+           ("expect name of generic package in instantiation", Gen_Id);
+         return;
+      end if;
+
+      if In_Extended_Main_Source_Unit (N) then
+         Set_Is_Instantiated (Gen_Unit);
+         Generate_Reference  (Gen_Unit, N);
+
+         if Present (Renamed_Object (Gen_Unit)) then
+            Set_Is_Instantiated (Renamed_Object (Gen_Unit));
+            Generate_Reference  (Renamed_Object (Gen_Unit), N);
+         end if;
+      end if;
+
+      if Nkind (Gen_Id) = N_Identifier
+        and then Chars (Gen_Unit) = Chars (Defining_Entity (N))
+      then
+         Error_Msg_NE
+           ("& is hidden within declaration of instance", Gen_Id, Gen_Unit);
+
+      elsif Nkind (Gen_Id) = N_Expanded_Name
+        and then Is_Child_Unit (Gen_Unit)
+        and then Nkind (Prefix (Gen_Id)) = N_Identifier
+        and then Chars (Act_Decl_Id) = Chars (Prefix (Gen_Id))
+      then
+         Error_Msg_N
+           ("& is hidden within declaration of instance ", Prefix (Gen_Id));
+      end if;
+
+      --  If renaming, indicate this is an instantiation of renamed unit.
+
+      if Present (Renamed_Object (Gen_Unit))
+        and then Ekind (Renamed_Object (Gen_Unit)) = E_Generic_Package
+      then
+         Gen_Unit := Renamed_Object (Gen_Unit);
+         Set_Entity (Gen_Id, Gen_Unit);
+      end if;
+
+      --  Verify that there are no circular instantiations.
+
+      if In_Open_Scopes (Gen_Unit) then
+         Error_Msg_NE ("instantiation of & within itself", N, Gen_Unit);
+         return;
+
+      elsif Contains_Instance_Of (Gen_Unit, Current_Scope, Gen_Id) then
+         Error_Msg_Node_2 := Current_Scope;
+         Error_Msg_NE
+           ("circular Instantiation: & instantiated in &!", N, Gen_Unit);
+         Circularity_Detected := True;
+         return;
+
+      else
+         Save_Env (Gen_Unit, Act_Decl_Id);
+         Gen_Decl := Unit_Declaration_Node (Gen_Unit);
+
+         --  Initialize renamings map, for error checking, and the list
+         --  that holds private entities whose views have changed between
+         --  generic definition and instantiation. If this is the instance
+         --  created to validate an actual package, the instantiation
+         --  environment is that of the enclosing instance.
+
+         Generic_Renamings.Set_Last (0);
+         Generic_Renamings_HTable.Reset;
+
+         Create_Instantiation_Source (N, Gen_Unit, S_Adjustment);
+
+         --  Copy original generic tree, to produce text for instantiation.
+
+         Act_Tree :=
+           Copy_Generic_Node
+             (Original_Node (Gen_Decl), Empty, Instantiating => True);
+
+         Act_Spec := Specification (Act_Tree);
+
+         --  If this is the instance created to validate an actual package,
+         --  only the formals matter, do not examine the package spec itself.
+
+         if Is_Actual_Pack then
+            Set_Visible_Declarations (Act_Spec, New_List);
+            Set_Private_Declarations (Act_Spec, New_List);
+         end if;
+
+         Renaming_List :=
+           Analyze_Associations
+             (N,
+              Generic_Formal_Declarations (Act_Tree),
+              Generic_Formal_Declarations (Gen_Decl));
+
+         Set_Defining_Unit_Name (Act_Spec, Act_Decl_Name);
+         Set_Is_Generic_Instance (Act_Decl_Id);
+
+         Set_Generic_Parent (Act_Spec, Gen_Unit);
+
+         --  References to the generic in its own declaration or its body
+         --  are references to the instance. Add a renaming declaration for
+         --  the generic unit itself. This declaration, as well as the renaming
+         --  declarations for the generic formals, must remain private to the
+         --  unit: the formals, because this is the language semantics, and
+         --  the unit because its use is an artifact of the implementation.
+
+         Unit_Renaming :=
+           Make_Package_Renaming_Declaration (Loc,
+             Defining_Unit_Name =>
+               Make_Defining_Identifier (Loc, Chars (Gen_Unit)),
+             Name => New_Reference_To (Act_Decl_Id, Loc));
+
+         Append (Unit_Renaming, Renaming_List);
+
+         --  The renaming declarations are the first local declarations of
+         --  the new unit.
+
+         if Is_Non_Empty_List (Visible_Declarations (Act_Spec)) then
+            Insert_List_Before
+              (First (Visible_Declarations (Act_Spec)), Renaming_List);
+         else
+            Set_Visible_Declarations (Act_Spec, Renaming_List);
+         end if;
+
+         Act_Decl :=
+           Make_Package_Declaration (Loc,
+             Specification => Act_Spec);
+
+         --  Save the instantiation node, for subsequent instantiation
+         --  of the body, if there is one and we are generating code for
+         --  the current unit. Mark the unit as having a body, to avoid
+         --  a premature error message.
+
+         --  We instantiate the body if we are generating code, if we are
+         --  generating cross-reference information, or if we are building
+         --  trees for ASIS use.
+
+         declare
+            Enclosing_Body_Present : Boolean := False;
+            Scop : Entity_Id;
+
+         begin
+            if Scope (Gen_Unit) /= Standard_Standard
+              and then not Is_Child_Unit (Gen_Unit)
+            then
+               Scop := Scope (Gen_Unit);
+
+               while Present (Scop)
+                 and then Scop /= Standard_Standard
+               loop
+                  if Unit_Requires_Body (Scop) then
+                     Enclosing_Body_Present := True;
+                     exit;
+                  end if;
+
+                  Scop := Scope (Scop);
+               end loop;
+            end if;
+
+            --  If front-end inlining is enabled, and this is a unit for which
+            --  code will be generated, we instantiate the body at once.
+            --  This is done if the instance is not the main unit, and if the
+            --  generic is not a child unit, to avoid scope problems.
+
+            if Front_End_Inlining
+              and then Expander_Active
+              and then not Is_Child_Unit (Gen_Unit)
+              and then Is_In_Main_Unit (N)
+              and then Nkind (Parent (N)) /= N_Compilation_Unit
+              and then Might_Inline_Subp
+            then
+               Inline_Now := True;
+            end if;
+
+            Needs_Body :=
+              (Unit_Requires_Body (Gen_Unit)
+                  or else Enclosing_Body_Present
+                  or else Present (Corresponding_Body (Gen_Decl)))
+                and then (Is_In_Main_Unit (N)
+                           or else Might_Inline_Subp)
+                and then not Is_Actual_Pack
+                and then not Inline_Now
+
+                and then (Operating_Mode = Generate_Code
+                            or else (Operating_Mode = Check_Semantics
+                                      and then Tree_Output));
+
+            --  If front_end_inlining is enabled, do not instantiate a
+            --  body if within a generic context.
+
+            if Front_End_Inlining
+              and then not Expander_Active
+            then
+               Needs_Body := False;
+            end if;
+
+         end;
+
+         --  If we are generating the calling stubs from the instantiation
+         --  of a generic RCI package, we will not use the body of the
+         --  generic package.
+
+         if Distribution_Stub_Mode = Generate_Caller_Stub_Body
+           and then Is_Compilation_Unit (Defining_Entity (N))
+         then
+            Needs_Body := False;
+         end if;
+
+         if Needs_Body then
+
+            --  Here is a defence against a ludicrous number of instantiations
+            --  caused by a circular set of instantiation attempts.
+
+            if Pending_Instantiations.Last >
+                 Hostparm.Max_Instantiations
+            then
+               Error_Msg_N ("too many instantiations", N);
+               raise Unrecoverable_Error;
+            end if;
+
+            --  Indicate that the enclosing scopes contain an instantiation,
+            --  and that cleanup actions should be delayed until after the
+            --  instance body is expanded.
+
+            Check_Forward_Instantiation (N, Gen_Decl);
+            if Nkind (N) = N_Package_Instantiation then
+               declare
+                  Enclosing_Master : Entity_Id := Current_Scope;
+
+               begin
+                  while Enclosing_Master /= Standard_Standard loop
+
+                     if Ekind (Enclosing_Master) = E_Package then
+                        if Is_Compilation_Unit (Enclosing_Master) then
+                           if In_Package_Body (Enclosing_Master) then
+                              Delay_Descriptors
+                                (Body_Entity (Enclosing_Master));
+                           else
+                              Delay_Descriptors
+                                (Enclosing_Master);
+                           end if;
+
+                           exit;
+
+                        else
+                           Enclosing_Master := Scope (Enclosing_Master);
+                        end if;
+
+                     elsif Ekind (Enclosing_Master) = E_Generic_Package then
+                        Enclosing_Master := Scope (Enclosing_Master);
+
+                     elsif Ekind (Enclosing_Master) = E_Generic_Function
+                       or else Ekind (Enclosing_Master) = E_Generic_Procedure
+                       or else Ekind (Enclosing_Master) = E_Void
+                     then
+                        --  Cleanup actions will eventually be performed on
+                        --  the enclosing instance, if any. enclosing scope
+                        --  is void in the formal part of a generic subp.
+
+                        exit;
+
+                     else
+                        if Ekind (Enclosing_Master) = E_Entry
+                          and then
+                            Ekind (Scope (Enclosing_Master)) = E_Protected_Type
+                        then
+                           Enclosing_Master :=
+                             Protected_Body_Subprogram (Enclosing_Master);
+                        end if;
+
+                        Set_Delay_Cleanups (Enclosing_Master);
+
+                        while Ekind (Enclosing_Master) = E_Block loop
+                           Enclosing_Master := Scope (Enclosing_Master);
+                        end loop;
+
+                        if Is_Subprogram (Enclosing_Master) then
+                           Delay_Descriptors (Enclosing_Master);
+
+                        elsif Is_Task_Type (Enclosing_Master) then
+                           declare
+                              TBP : constant Node_Id :=
+                                      Get_Task_Body_Procedure
+                                        (Enclosing_Master);
+
+                           begin
+                              if Present (TBP) then
+                                 Delay_Descriptors  (TBP);
+                                 Set_Delay_Cleanups (TBP);
+                              end if;
+                           end;
+                        end if;
+
+                        exit;
+                     end if;
+                  end loop;
+               end;
+
+               --  Make entry in table
+
+               Pending_Instantiations.Increment_Last;
+               Pending_Instantiations.Table (Pending_Instantiations.Last) :=
+                 (N, Act_Decl, Expander_Active, Current_Sem_Unit);
+            end if;
+         end if;
+
+         Set_Categorization_From_Pragmas (Act_Decl);
+
+         if Parent_Installed then
+            Hide_Current_Scope;
+         end if;
+
+         Set_Instance_Spec (N, Act_Decl);
+
+         --  Case of not a compilation unit
+
+         if Nkind (Parent (N)) /= N_Compilation_Unit then
+            Mark_Rewrite_Insertion (Act_Decl);
+            Insert_Before (N, Act_Decl);
+            Analyze (Act_Decl);
+
+         --  Case of compilation unit that is generic instantiation
+
+         --  Place declaration on current node so context is complete
+         --  for analysis (including nested instantiations).
+
+         else
+            if Cunit_Entity (Current_Sem_Unit) = Defining_Entity (N) then
+
+               --  The entity for the current unit is the newly created one,
+               --  and all semantic information is attached to it.
+
+               Set_Cunit_Entity (Current_Sem_Unit, Act_Decl_Id);
+
+               --  If this is the main unit, replace the main entity as well.
+
+               if Current_Sem_Unit = Main_Unit then
+                  Main_Unit_Entity := Act_Decl_Id;
+               end if;
+            end if;
+
+            Set_Unit (Parent (N), Act_Decl);
+            Set_Parent_Spec (Act_Decl, Parent_Spec (N));
+            Analyze (Act_Decl);
+            Set_Unit (Parent (N), N);
+            Set_Body_Required (Parent (N), False);
+
+            --  We never need elaboration checks on instantiations, since
+            --  by definition, the body instantiation is elaborated at the
+            --  same time as the spec instantiation.
+
+            Set_Suppress_Elaboration_Warnings (Act_Decl_Id);
+            Set_Suppress_Elaboration_Checks   (Act_Decl_Id);
+         end if;
+
+         Check_Elab_Instantiation (N);
+
+         if ABE_Is_Certain (N) and then Needs_Body then
+            Pending_Instantiations.Decrement_Last;
+         end if;
+         Check_Hidden_Child_Unit (N, Gen_Unit, Act_Decl_Id);
+
+         Set_First_Private_Entity (Defining_Unit_Name (Unit_Renaming),
+           First_Private_Entity (Act_Decl_Id));
+
+         if Nkind (Parent (N)) = N_Compilation_Unit
+           and  then not Needs_Body
+         then
+            Rewrite (N, Act_Decl);
+         end if;
+
+         if Present (Corresponding_Body (Gen_Decl))
+           or else Unit_Requires_Body (Gen_Unit)
+         then
+            Set_Has_Completion (Act_Decl_Id);
+         end if;
+
+         Check_Formal_Packages (Act_Decl_Id);
+
+         Restore_Private_Views (Act_Decl_Id);
+
+         if not Generic_Separately_Compiled (Gen_Unit) then
+            Inherit_Context (Gen_Decl, N);
+         end if;
+
+         if Parent_Installed then
+            Remove_Parent;
+         end if;
+
+         Restore_Env;
+      end if;
+
+      Validate_Categorization_Dependency (N, Act_Decl_Id);
+
+      --  Check restriction, but skip this if something went wrong in
+      --  the above analysis, indicated by Act_Decl_Id being void.
+
+      if Ekind (Act_Decl_Id) /= E_Void
+        and then not Is_Library_Level_Entity (Act_Decl_Id)
+      then
+         Check_Restriction (No_Local_Allocators, N);
+      end if;
+
+      if Inline_Now then
+         Inline_Instance_Body (N, Gen_Unit, Act_Decl);
+      end if;
+
+   exception
+      when Instantiation_Error =>
+         if Parent_Installed then
+            Remove_Parent;
+         end if;
+
+   end Analyze_Package_Instantiation;
+
+   ---------------------------
+   --  Inline_Instance_Body --
+   ---------------------------
+
+   procedure Inline_Instance_Body
+     (N        : Node_Id;
+      Gen_Unit : Entity_Id;
+      Act_Decl : Node_Id)
+   is
+      Vis          : Boolean;
+      Gen_Comp     : constant Entity_Id :=
+                      Cunit_Entity (Get_Source_Unit (Gen_Unit));
+      Curr_Comp    : constant Node_Id := Cunit (Current_Sem_Unit);
+      Curr_Scope   : Entity_Id := Empty;
+      Curr_Unit    : constant Entity_Id :=
+                       Cunit_Entity (Current_Sem_Unit);
+      Removed      : Boolean := False;
+      Num_Scopes   : Int := 0;
+      Use_Clauses  : array (1 .. Scope_Stack.Last) of Node_Id;
+      Instances    : array (1 .. Scope_Stack.Last) of Entity_Id;
+      Inner_Scopes : array (1 .. Scope_Stack.Last) of Entity_Id;
+      Num_Inner    : Int := 0;
+      N_Instances  : Int := 0;
+      S            : Entity_Id;
+
+   begin
+      --  Case of generic unit defined in another unit
+
+      if Gen_Comp /= Cunit_Entity (Current_Sem_Unit) then
+         Vis := Is_Immediately_Visible (Gen_Comp);
+
+         S := Current_Scope;
+
+         while Present (S)
+           and then S /= Standard_Standard
+         loop
+            Num_Scopes := Num_Scopes + 1;
+
+            Use_Clauses (Num_Scopes) :=
+              (Scope_Stack.Table
+                 (Scope_Stack.Last - Num_Scopes + 1).
+                    First_Use_Clause);
+            End_Use_Clauses (Use_Clauses (Num_Scopes));
+
+            exit when Is_Generic_Instance (S)
+              and then (In_Package_Body (S)
+                          or else Ekind (S) = E_Procedure
+                          or else Ekind (S) = E_Function);
+            S := Scope (S);
+         end loop;
+
+         --  Find and save all enclosing instances.
+
+         S := Current_Scope;
+
+         while Present (S)
+           and then S /= Standard_Standard
+         loop
+            if Is_Generic_Instance (S) then
+               N_Instances := N_Instances + 1;
+               Instances (N_Instances) := S;
+            end if;
+
+            S := Scope (S);
+         end loop;
+
+         --  Remove context of current compilation unit, unless we
+         --  are within a nested package instantiation, in which case
+         --  the context has been removed previously.
+         --  If current scope is the body of a child unit, remove context
+         --  of spec as well.
+
+         S := Current_Scope;
+
+         while Present (S)
+           and then S /= Standard_Standard
+         loop
+            exit when Is_Generic_Instance (S)
+                 and then In_Package_Body (S);
+
+            if S = Curr_Unit
+              or else (Ekind (Curr_Unit) = E_Package_Body
+                        and then S = Spec_Entity (Curr_Unit))
+            then
+               Removed := True;
+
+               if Is_Child_Unit (S) then
+                  --  Remove child unit from stack, as well as inner scopes.
+                  --  Removing its context of child unit will remove parent
+                  --  units as well.
+
+                  while Current_Scope /= S loop
+                     Num_Inner := Num_Inner + 1;
+                     Inner_Scopes (Num_Inner) := Current_Scope;
+                     Pop_Scope;
+                  end loop;
+
+                  Pop_Scope;
+                  Remove_Context (Curr_Comp);
+                  Curr_Scope := S;
+
+               else
+                  Remove_Context (Curr_Comp);
+               end if;
+
+               if Ekind (Curr_Unit) = E_Package_Body then
+                  Remove_Context (Library_Unit (Curr_Comp));
+               end if;
+            end if;
+
+            S := Scope (S);
+         end loop;
+
+         Instantiate_Package_Body
+           ((N, Act_Decl, Expander_Active, Current_Sem_Unit));
+
+         --  Restore context.
+
+         Set_Is_Immediately_Visible (Gen_Comp, Vis);
+
+         --  Reset Generic_Instance flag so that use clauses can be installed
+         --  in the proper order. (See Use_One_Package for effect of enclosing
+         --  instances on processing of use clauses).
+
+         for J in 1 .. N_Instances loop
+            Set_Is_Generic_Instance (Instances (J), False);
+         end loop;
+
+         if Removed then
+            --  Make local entities not visible, so that when the context of
+            --  unit is restored, there are not spurious hidings of use-
+            --  visible entities (which appear in the environment before the
+            --  current scope).
+
+            if Current_Scope /= Standard_Standard then
+               S := First_Entity (Current_Scope);
+
+               while Present (S) loop
+                  if Is_Overloadable (S) then
+                     Set_Is_Immediately_Visible (S, False);
+                  end if;
+
+                  Next_Entity (S);
+               end loop;
+            end if;
+
+            Install_Context (Curr_Comp);
+
+            if Current_Scope /= Standard_Standard then
+               S := First_Entity (Current_Scope);
+
+               while Present (S) loop
+                  if Is_Overloadable (S) then
+                     Set_Is_Immediately_Visible (S);
+                  end if;
+
+                  Next_Entity (S);
+               end loop;
+            end if;
+
+            if Present (Curr_Scope)
+              and then Is_Child_Unit (Curr_Scope)
+            then
+               New_Scope (Curr_Scope);
+               Set_Is_Immediately_Visible (Curr_Scope);
+
+               --  Finally, restore inner scopes as well.
+
+               for J in reverse 1 .. Num_Inner loop
+                  New_Scope (Inner_Scopes (J));
+               end loop;
+            end if;
+         end if;
+
+         for J in reverse 1 .. Num_Scopes loop
+            Install_Use_Clauses (Use_Clauses (J));
+         end  loop;
+
+         for J in 1 .. N_Instances loop
+            Set_Is_Generic_Instance (Instances (J), True);
+         end loop;
+
+      --  If generic unit is in current unit, current context is correct.
+
+      else
+         Instantiate_Package_Body
+           ((N, Act_Decl, Expander_Active, Current_Sem_Unit));
+      end if;
+   end Inline_Instance_Body;
+
+   -------------------------------------
+   -- Analyze_Procedure_Instantiation --
+   -------------------------------------
+
+   procedure Analyze_Procedure_Instantiation (N : Node_Id) is
+   begin
+      Analyze_Subprogram_Instantiation (N, E_Procedure);
+   end Analyze_Procedure_Instantiation;
+
+   --------------------------------------
+   -- Analyze_Subprogram_Instantiation --
+   --------------------------------------
+
+   procedure Analyze_Subprogram_Instantiation
+     (N : Node_Id;
+      K : Entity_Kind)
+   is
+      Loc              : constant Source_Ptr := Sloc (N);
+      Gen_Id           : constant Node_Id    := Name (N);
+
+      Act_Decl_Id      : Entity_Id;
+      Anon_Id          : Entity_Id :=
+                           Make_Defining_Identifier
+                             (Sloc (Defining_Entity (N)),
+                             New_External_Name
+                               (Chars (Defining_Entity (N)), 'R'));
+      Act_Decl         : Node_Id;
+      Act_Spec         : Node_Id;
+      Act_Tree         : Node_Id;
+
+      Gen_Unit         : Entity_Id;
+      Gen_Decl         : Node_Id;
+      Pack_Id          : Entity_Id;
+      Parent_Installed : Boolean := False;
+      Renaming_List    : List_Id;
+      Spec             : Node_Id;
+
+      procedure Analyze_Instance_And_Renamings;
+      --  The instance must be analyzed in a context that includes the
+      --  mappings of generic parameters into actuals. We create a package
+      --  declaration for this purpose, and a subprogram with an internal
+      --  name within the package. The subprogram instance is simply an
+      --  alias for the internal subprogram, declared in the current scope.
+
+      ------------------------------------
+      -- Analyze_Instance_And_Renamings --
+      ------------------------------------
+
+      procedure Analyze_Instance_And_Renamings is
+         Def_Ent   : constant Entity_Id := Defining_Entity (N);
+         Pack_Decl : Node_Id;
+
+      begin
+         if Nkind (Parent (N)) = N_Compilation_Unit then
+
+            --  For the case of a compilation unit, the container package
+            --  has the same name as the instantiation, to insure that the
+            --  binder calls the elaboration procedure with the right name.
+            --  Copy the entity of the instance, which may have compilation
+            --  level flags (eg. is_child_unit) set.
+
+            Pack_Id := New_Copy (Def_Ent);
+
+         else
+            --  Otherwise we use the name of the instantiation concatenated
+            --  with its source position to ensure uniqueness if there are
+            --  several instantiations with the same name.
+
+            Pack_Id :=
+              Make_Defining_Identifier (Loc,
+                Chars => New_External_Name
+                           (Related_Id   => Chars (Def_Ent),
+                            Suffix       => "GP",
+                            Suffix_Index => Source_Offset (Sloc (Def_Ent))));
+         end if;
+
+         Pack_Decl := Make_Package_Declaration (Loc,
+           Specification => Make_Package_Specification (Loc,
+             Defining_Unit_Name   => Pack_Id,
+             Visible_Declarations => Renaming_List,
+             End_Label            => Empty));
+
+         Set_Instance_Spec (N, Pack_Decl);
+         Set_Is_Generic_Instance (Pack_Id);
+
+         --  Case of not a compilation unit
+
+         if Nkind (Parent (N)) /= N_Compilation_Unit then
+            Mark_Rewrite_Insertion (Pack_Decl);
+            Insert_Before (N, Pack_Decl);
+            Set_Has_Completion (Pack_Id);
+
+         --  Case of an instantiation that is a compilation unit
+
+         --  Place declaration on current node so context is complete
+         --  for analysis (including nested instantiations), and for
+         --  use in a context_clause (see Analyze_With_Clause).
+
+         else
+            Set_Unit (Parent (N), Pack_Decl);
+            Set_Parent_Spec (Pack_Decl, Parent_Spec (N));
+         end if;
+
+         Analyze (Pack_Decl);
+         Check_Formal_Packages (Pack_Id);
+         Set_Is_Generic_Instance (Pack_Id, False);
+
+         --  Body of the enclosing package is supplied when instantiating
+         --  the subprogram body, after semantic  analysis is completed.
+
+         if Nkind (Parent (N)) = N_Compilation_Unit then
+
+            --  Remove package itself from visibility, so it does not
+            --  conflict with subprogram.
+
+            Set_Name_Entity_Id (Chars (Pack_Id), Homonym (Pack_Id));
+
+            --  Set name and scope of internal subprogram so that the
+            --  proper external name will be generated. The proper scope
+            --  is the scope of the wrapper package.
+
+            Set_Chars (Anon_Id, Chars (Defining_Entity (N)));
+            Set_Scope (Anon_Id, Scope (Pack_Id));
+         end if;
+
+         Set_Is_Generic_Instance (Anon_Id);
+         Act_Decl_Id := New_Copy (Anon_Id);
+
+         Set_Parent            (Act_Decl_Id, Parent (Anon_Id));
+         Set_Chars             (Act_Decl_Id, Chars (Defining_Entity (N)));
+         Set_Sloc              (Act_Decl_Id, Sloc (Defining_Entity (N)));
+         Set_Comes_From_Source (Act_Decl_Id, True);
+
+         --  The signature may involve types that are not frozen yet, but
+         --  the subprogram will be frozen at the point the wrapper package
+         --  is frozen, so it does not need its own freeze node. In fact, if
+         --  one is created, it might conflict with the freezing actions from
+         --  the wrapper package (see 7206-013).
+
+         Set_Has_Delayed_Freeze (Anon_Id, False);
+
+         --  If the instance is a child unit, mark the Id accordingly. Mark
+         --  the anonymous entity as well, which is the real subprogram and
+         --  which is used when the instance appears in a context clause.
+
+         Set_Is_Child_Unit (Act_Decl_Id, Is_Child_Unit (Defining_Entity (N)));
+         Set_Is_Child_Unit (Anon_Id, Is_Child_Unit (Defining_Entity (N)));
+         New_Overloaded_Entity (Act_Decl_Id);
+         Check_Eliminated  (Act_Decl_Id);
+
+         --  In compilation unit case, kill elaboration checks on the
+         --  instantiation, since they are never needed -- the body is
+         --  instantiated at the same point as the spec.
+
+         if Nkind (Parent (N)) = N_Compilation_Unit then
+            Set_Suppress_Elaboration_Warnings (Act_Decl_Id);
+            Set_Suppress_Elaboration_Checks   (Act_Decl_Id);
+            Set_Is_Compilation_Unit (Anon_Id);
+
+            Set_Cunit_Entity (Current_Sem_Unit, Pack_Id);
+         end if;
+
+         --  The instance is not a freezing point for the new subprogram.
+
+         Set_Is_Frozen (Act_Decl_Id, False);
+
+         if Nkind (Defining_Entity (N)) = N_Defining_Operator_Symbol then
+            Valid_Operator_Definition (Act_Decl_Id);
+         end if;
+
+         Set_Alias  (Act_Decl_Id, Anon_Id);
+         Set_Parent (Act_Decl_Id, Parent (Anon_Id));
+         Set_Has_Completion (Act_Decl_Id);
+         Set_Related_Instance (Pack_Id, Act_Decl_Id);
+
+         if Nkind (Parent (N)) = N_Compilation_Unit then
+            Set_Body_Required (Parent (N), False);
+         end if;
+
+      end Analyze_Instance_And_Renamings;
+
+   --  Start of processing for Analyze_Subprogram_Instantiation
+
+   begin
+      --  Very first thing: apply the special kludge for Text_IO processing
+      --  in case we are instantiating one of the children of [Wide_]Text_IO.
+      --  Of course such an instantiation is bogus (these are packages, not
+      --  subprograms), but we get a better error message if we do this.
+
+      Text_IO_Kludge (Gen_Id);
+
+      --  Make node global for error reporting.
+
+      Instantiation_Node := N;
+      Pre_Analyze_Actuals (N);
+
+      Check_Generic_Child_Unit (Gen_Id, Parent_Installed);
+      Gen_Unit := Entity (Gen_Id);
+
+      Generate_Reference (Gen_Unit, Gen_Id);
+
+      if Nkind (Gen_Id) = N_Identifier
+        and then Chars (Gen_Unit) = Chars (Defining_Entity (N))
+      then
+         Error_Msg_NE
+           ("& is hidden within declaration of instance", Gen_Id, Gen_Unit);
+      end if;
+
+      if Etype (Gen_Unit) = Any_Type then return; end if;
+
+      --  Verify that it is a generic subprogram of the right kind, and that
+      --  it does not lead to a circular instantiation.
+
+      if Ekind (Gen_Unit) /= E_Generic_Procedure
+        and then Ekind (Gen_Unit) /= E_Generic_Function
+      then
+         Error_Msg_N ("expect generic subprogram in instantiation", Gen_Id);
+
+      elsif In_Open_Scopes (Gen_Unit) then
+         Error_Msg_NE ("instantiation of & within itself", N, Gen_Unit);
+
+      elsif Contains_Instance_Of (Gen_Unit, Current_Scope, Gen_Id) then
+         Error_Msg_Node_2 := Current_Scope;
+         Error_Msg_NE
+           ("circular Instantiation: & instantiated in &!", N, Gen_Unit);
+         Circularity_Detected := True;
+
+      elsif K = E_Procedure
+        and then Ekind (Gen_Unit) /= E_Generic_Procedure
+      then
+         if Ekind (Gen_Unit) = E_Generic_Function then
+            Error_Msg_N
+              ("cannot instantiate generic function as procedure", Gen_Id);
+         else
+            Error_Msg_N
+              ("expect name of generic procedure in instantiation", Gen_Id);
+         end if;
+
+      elsif K = E_Function
+        and then Ekind (Gen_Unit) /= E_Generic_Function
+      then
+         if Ekind (Gen_Unit) = E_Generic_Procedure then
+            Error_Msg_N
+              ("cannot instantiate generic procedure as function", Gen_Id);
+         else
+            Error_Msg_N
+              ("expect name of generic function in instantiation", Gen_Id);
+         end if;
+
+      else
+         --  If renaming, indicate that this is instantiation of renamed unit
+
+         if Present (Renamed_Object (Gen_Unit))
+           and then (Ekind (Renamed_Object (Gen_Unit)) = E_Generic_Procedure
+                       or else
+                     Ekind (Renamed_Object (Gen_Unit)) = E_Generic_Function)
+         then
+            Gen_Unit := Renamed_Object (Gen_Unit);
+            Set_Entity (Gen_Id, Gen_Unit);
+         end if;
+
+         if In_Extended_Main_Source_Unit (N) then
+            Set_Is_Instantiated (Gen_Unit);
+            Generate_Reference  (Gen_Unit, N);
+         end if;
+
+         Gen_Decl := Unit_Declaration_Node (Gen_Unit);
+         Spec     := Specification (Gen_Decl);
+
+         --  The subprogram itself cannot contain a nested instance, so
+         --  the current parent is left empty.
+
+         Save_Env (Gen_Unit, Empty);
+
+         --  Initialize renamings map, for error checking.
+
+         Generic_Renamings.Set_Last (0);
+         Generic_Renamings_HTable.Reset;
+
+         Create_Instantiation_Source (N, Gen_Unit, S_Adjustment);
+
+         --  Copy original generic tree, to produce text for instantiation.
+
+         Act_Tree :=
+           Copy_Generic_Node
+             (Original_Node (Gen_Decl), Empty, Instantiating => True);
+
+         Act_Spec := Specification (Act_Tree);
+         Renaming_List :=
+           Analyze_Associations
+             (N,
+              Generic_Formal_Declarations (Act_Tree),
+              Generic_Formal_Declarations (Gen_Decl));
+
+         --  Build the subprogram declaration, which does not appear
+         --  in the generic template, and give it a sloc consistent
+         --  with that of the template.
+
+         Set_Defining_Unit_Name (Act_Spec, Anon_Id);
+         Set_Generic_Parent (Act_Spec, Gen_Unit);
+         Act_Decl :=
+           Make_Subprogram_Declaration (Sloc (Act_Spec),
+             Specification => Act_Spec);
+
+         Set_Categorization_From_Pragmas (Act_Decl);
+
+         if Parent_Installed then
+            Hide_Current_Scope;
+         end if;
+
+         Append (Act_Decl, Renaming_List);
+         Analyze_Instance_And_Renamings;
+
+         --  If the generic is marked Import (Intrinsic), then so is the
+         --  instance. This indicates that there is no body to instantiate.
+         --  If generic is marked inline, so it the instance, and the
+         --  anonymous subprogram it renames. If inlined, or else if inlining
+         --  is enabled for the compilation, we generate the instance body
+         --  even if it is not within the main unit.
+
+         --  Any other  pragmas might also be inherited ???
+
+         if Is_Intrinsic_Subprogram (Gen_Unit) then
+            Set_Is_Intrinsic_Subprogram (Anon_Id);
+            Set_Is_Intrinsic_Subprogram (Act_Decl_Id);
+
+            if Chars (Gen_Unit) = Name_Unchecked_Conversion then
+               Validate_Unchecked_Conversion (N, Act_Decl_Id);
+            end if;
+         end if;
+
+         Generate_Definition (Act_Decl_Id);
+
+         Set_Is_Inlined (Act_Decl_Id, Is_Inlined (Gen_Unit));
+         Set_Is_Inlined (Anon_Id,     Is_Inlined (Gen_Unit));
+
+         Check_Elab_Instantiation (N);
+         Check_Hidden_Child_Unit (N, Gen_Unit, Act_Decl_Id);
+
+         --  Subject to change, pending on if other pragmas are inherited ???
+
+         Validate_Categorization_Dependency (N, Act_Decl_Id);
+
+         if not Is_Intrinsic_Subprogram (Act_Decl_Id) then
+
+            if not Generic_Separately_Compiled (Gen_Unit) then
+               Inherit_Context (Gen_Decl, N);
+            end if;
+
+            Restore_Private_Views (Pack_Id, False);
+
+            --  If the context requires a full instantiation, mark node for
+            --  subsequent construction of the body.
+
+            if (Is_In_Main_Unit (N)
+                  or else Is_Inlined (Act_Decl_Id))
+              and then (Operating_Mode = Generate_Code
+                          or else (Operating_Mode = Check_Semantics
+                                    and then Tree_Output))
+              and then (Expander_Active or else Tree_Output)
+              and then not ABE_Is_Certain (N)
+              and then not Is_Eliminated (Act_Decl_Id)
+            then
+               Pending_Instantiations.Increment_Last;
+               Pending_Instantiations.Table (Pending_Instantiations.Last) :=
+                 (N, Act_Decl, Expander_Active, Current_Sem_Unit);
+               Check_Forward_Instantiation (N, Gen_Decl);
+
+               --  The wrapper package is always delayed, because it does
+               --  not constitute a freeze point, but to insure that the
+               --  freeze node is placed properly, it is created directly
+               --  when instantiating the body (otherwise the freeze node
+               --  might appear to early for nested instantiations).
+
+            elsif Nkind (Parent (N)) = N_Compilation_Unit then
+
+               --  For ASIS purposes, indicate that the wrapper package has
+               --  replaced the instantiation node.
+
+               Rewrite (N, Unit (Parent (N)));
+               Set_Unit (Parent (N), N);
+            end if;
+
+         elsif Nkind (Parent (N)) = N_Compilation_Unit then
+
+               --  Replace instance node for library-level instantiations
+               --  of intrinsic subprograms, for ASIS use.
+
+               Rewrite (N, Unit (Parent (N)));
+               Set_Unit (Parent (N), N);
+         end if;
+
+         if Parent_Installed then
+            Remove_Parent;
+         end if;
+
+         Restore_Env;
+         Generic_Renamings.Set_Last (0);
+         Generic_Renamings_HTable.Reset;
+      end if;
+
+   exception
+      when Instantiation_Error =>
+         if Parent_Installed then
+            Remove_Parent;
+         end if;
+
+   end Analyze_Subprogram_Instantiation;
+
+   ---------------------
+   -- Associated_Node --
+   ---------------------
+
+   function Associated_Node (N : Node_Id) return Node_Id is
+      Assoc : Node_Id := Node4 (N);
+      --  ??? what is Node4 being used for here?
+
+   begin
+      if Nkind (Assoc) /= Nkind (N) then
+         return Assoc;
+
+      elsif Nkind (Assoc) = N_Aggregate
+        or else Nkind (Assoc) = N_Extension_Aggregate
+      then
+         return Assoc;
+      else
+         --  If the node is part of an inner generic, it may itself have been
+         --  remapped into a further generic copy. Node4 is otherwise used for
+         --  the entity of the node, and will be of a different node kind, or
+         --  else N has been rewritten as a literal or function call.
+
+         while Present (Node4 (Assoc))
+           and then Nkind (Node4 (Assoc)) = Nkind (Assoc)
+         loop
+            Assoc := Node4 (Assoc);
+         end loop;
+
+         --  Follow and additional link in case the final node was rewritten.
+         --  This can only happen with nested generic units.
+
+         if (Nkind (Assoc) = N_Identifier or else Nkind (Assoc) in N_Op)
+           and then Present (Node4 (Assoc))
+           and then (Nkind (Node4 (Assoc)) = N_Function_Call
+                       or else Nkind (Node4 (Assoc)) = N_Explicit_Dereference
+                       or else Nkind (Node4 (Assoc)) = N_Integer_Literal
+                       or else Nkind (Node4 (Assoc)) = N_Real_Literal
+                       or else Nkind (Node4 (Assoc)) = N_String_Literal)
+         then
+            Assoc := Node4 (Assoc);
+         end if;
+
+         return Assoc;
+      end if;
+   end Associated_Node;
+
+   -------------------------------------------
+   -- Build_Instance_Compilation_Unit_Nodes --
+   -------------------------------------------
+
+   procedure Build_Instance_Compilation_Unit_Nodes
+     (N        : Node_Id;
+      Act_Body : Node_Id;
+      Act_Decl : Node_Id)
+   is
+      Decl_Cunit : Node_Id;
+      Body_Cunit : Node_Id;
+      Citem      : Node_Id;
+      New_Main   : constant Entity_Id := Defining_Entity (Act_Decl);
+      Old_Main   : constant Entity_Id := Cunit_Entity (Main_Unit);
+
+   begin
+      --  A new compilation unit node is built for the instance declaration
+
+      Decl_Cunit :=
+        Make_Compilation_Unit (Sloc (N),
+          Context_Items  => Empty_List,
+          Unit           => Act_Decl,
+          Aux_Decls_Node =>
+            Make_Compilation_Unit_Aux (Sloc (N)));
+
+      Set_Parent_Spec   (Act_Decl, Parent_Spec (N));
+      Set_Body_Required (Decl_Cunit, True);
+
+      --  We use the original instantiation compilation unit as the resulting
+      --  compilation unit of the instance, since this is the main unit.
+
+      Rewrite (N, Act_Body);
+      Body_Cunit := Parent (N);
+
+      --  The two compilation unit nodes are linked by the Library_Unit field
+
+      Set_Library_Unit  (Decl_Cunit, Body_Cunit);
+      Set_Library_Unit  (Body_Cunit, Decl_Cunit);
+
+      --  The context clause items on the instantiation, which are now
+      --  attached to the body compilation unit (since the body overwrote
+      --  the original instantiation node), semantically belong on the spec,
+      --  so copy them there. It's harmless to leave them on the body as well.
+      --  In fact one could argue that they belong in both places.
+
+      Citem := First (Context_Items (Body_Cunit));
+      while Present (Citem) loop
+         Append (New_Copy (Citem), Context_Items (Decl_Cunit));
+         Next (Citem);
+      end loop;
+
+      --  Propagate categorization flags on packages, so that they appear
+      --  in ali file for the spec of the unit.
+
+      if Ekind (New_Main) = E_Package then
+         Set_Is_Pure           (Old_Main, Is_Pure (New_Main));
+         Set_Is_Preelaborated  (Old_Main, Is_Preelaborated (New_Main));
+         Set_Is_Remote_Types   (Old_Main, Is_Remote_Types (New_Main));
+         Set_Is_Shared_Passive (Old_Main, Is_Shared_Passive (New_Main));
+         Set_Is_Remote_Call_Interface
+           (Old_Main, Is_Remote_Call_Interface (New_Main));
+      end if;
+
+      --  Make entry in Units table, so that binder can generate call to
+      --  elaboration procedure for body, if any.
+
+      Make_Instance_Unit (Body_Cunit);
+      Main_Unit_Entity := New_Main;
+      Set_Cunit_Entity (Main_Unit, Main_Unit_Entity);
+
+      --  Build elaboration entity, since the instance may certainly
+      --  generate elaboration code requiring a flag for protection.
+
+      Build_Elaboration_Entity (Decl_Cunit, New_Main);
+   end Build_Instance_Compilation_Unit_Nodes;
+
+   -----------------------------------
+   -- Check_Formal_Package_Instance --
+   -----------------------------------
+
+   --  If the formal has specific parameters, they must match those of the
+   --  actual. Both of them are instances, and the renaming declarations
+   --  for their formal parameters appear in the same order in both. The
+   --  analyzed formal has been analyzed in the context of the current
+   --  instance.
+
+   procedure Check_Formal_Package_Instance
+     (Formal_Pack : Entity_Id;
+      Actual_Pack : Entity_Id)
+   is
+      E1 : Entity_Id := First_Entity (Actual_Pack);
+      E2 : Entity_Id := First_Entity (Formal_Pack);
+
+      Expr1 : Node_Id;
+      Expr2 : Node_Id;
+
+      procedure Check_Mismatch (B : Boolean);
+      --  Common error routine for mismatch between the parameters of
+      --  the actual instance and those of the formal package.
+
+      procedure Check_Mismatch (B : Boolean) is
+      begin
+         if B then
+            Error_Msg_NE
+              ("actual for & in actual instance does not match formal",
+               Parent (Actual_Pack), E1);
+         end if;
+      end Check_Mismatch;
+
+   --  Start of processing for Check_Formal_Package_Instance
+
+   begin
+      while Present (E1)
+        and then Present (E2)
+      loop
+         exit when Ekind (E1) = E_Package
+           and then Renamed_Entity (E1) = Renamed_Entity (Actual_Pack);
+
+         if Is_Type (E1) then
+
+            --  Subtypes must statically match. E1 and E2 are the
+            --  local entities that are subtypes of the actuals.
+            --  Itypes generated for other parameters need not be checked,
+            --  the check will be performed on the parameters themselves.
+
+            if not Is_Itype (E1)
+              and then not Is_Itype (E2)
+            then
+               Check_Mismatch
+                 (not Is_Type (E2)
+                   or else Etype (E1) /= Etype (E2)
+                   or else not Subtypes_Statically_Match (E1, E2));
+            end if;
+
+         elsif Ekind (E1) = E_Constant then
+
+            --  IN parameters must denote the same static value, or
+            --  the same constant, or the literal null.
+
+            Expr1 := Expression (Parent (E1));
+
+            if Ekind (E2) /= E_Constant then
+               Check_Mismatch (True);
+               goto Next_E;
+            else
+               Expr2 := Expression (Parent (E2));
+            end if;
+
+            if Is_Static_Expression (Expr1) then
+
+               if not Is_Static_Expression (Expr2) then
+                  Check_Mismatch (True);
+
+               elsif Is_Integer_Type (Etype (E1)) then
+
+                  declare
+                     V1 : Uint := Expr_Value (Expr1);
+                     V2 : Uint := Expr_Value (Expr2);
+                  begin
+                     Check_Mismatch (V1 /= V2);
+                  end;
+
+               elsif Is_Real_Type (Etype (E1)) then
+
+                  declare
+                     V1 : Ureal := Expr_Value_R (Expr1);
+                     V2 : Ureal := Expr_Value_R (Expr2);
+                  begin
+                     Check_Mismatch (V1 /= V2);
+                  end;
+
+               elsif Is_String_Type (Etype (E1))
+                 and then Nkind (Expr1) = N_String_Literal
+               then
+
+                  if Nkind (Expr2) /= N_String_Literal then
+                     Check_Mismatch (True);
+                  else
+                     Check_Mismatch
+                       (not String_Equal (Strval (Expr1), Strval (Expr2)));
+                  end if;
+               end if;
+
+            elsif Is_Entity_Name (Expr1) then
+               if Is_Entity_Name (Expr2) then
+                  if Entity (Expr1) = Entity (Expr2) then
+                     null;
+
+                  elsif Ekind (Entity (Expr2)) = E_Constant
+                     and then Is_Entity_Name (Constant_Value (Entity (Expr2)))
+                     and then
+                      Entity (Constant_Value (Entity (Expr2))) = Entity (Expr1)
+                  then
+                     null;
+                  else
+                     Check_Mismatch (True);
+                  end if;
+               else
+                  Check_Mismatch (True);
+               end if;
+
+            elsif Nkind (Expr1) = N_Null then
+               Check_Mismatch (Nkind (Expr1) /= N_Null);
+
+            else
+               Check_Mismatch (True);
+            end if;
+
+         elsif Ekind (E1) = E_Variable
+           or else Ekind (E1) = E_Package
+         then
+            Check_Mismatch
+              (Ekind (E1) /= Ekind (E2)
+                or else Renamed_Object (E1) /= Renamed_Object (E2));
+
+         elsif Is_Overloadable (E1) then
+
+            --  Verify that the names of the  entities match.
+            --  What if actual is an attribute ???
+
+            Check_Mismatch
+              (Ekind (E2) /= Ekind (E1) or else (Alias (E1)) /= Alias (E2));
+
+         else
+            raise Program_Error;
+         end if;
+
+         <<Next_E>>
+            Next_Entity (E1);
+            Next_Entity (E2);
+      end loop;
+   end Check_Formal_Package_Instance;
+
+   ---------------------------
+   -- Check_Formal_Packages --
+   ---------------------------
+
+   procedure Check_Formal_Packages (P_Id : Entity_Id) is
+      E        : Entity_Id;
+      Formal_P : Entity_Id;
+
+   begin
+      --  Iterate through the declarations in the instance, looking for
+      --  package renaming declarations that denote instances of formal
+      --  packages. Stop when we find the renaming of the current package
+      --  itself. The declaration for a formal package without a box is
+      --  followed by an internal entity that repeats the instantiation.
+
+      E := First_Entity (P_Id);
+      while Present (E) loop
+         if Ekind (E) = E_Package then
+            if Renamed_Object (E) = P_Id then
+               exit;
+
+            elsif Nkind (Parent (E)) /= N_Package_Renaming_Declaration then
+               null;
+
+            elsif not Box_Present (Parent (Associated_Formal_Package (E))) then
+               Formal_P := Next_Entity (E);
+               Check_Formal_Package_Instance (Formal_P, E);
+            end if;
+         end if;
+
+         Next_Entity (E);
+      end loop;
+   end Check_Formal_Packages;
+
+   ---------------------------------
+   -- Check_Forward_Instantiation --
+   ---------------------------------
+
+   procedure Check_Forward_Instantiation (N : Node_Id; Decl : Node_Id) is
+      S        : Entity_Id;
+      Gen_Comp : Entity_Id := Cunit_Entity (Get_Source_Unit (Decl));
+
+   begin
+      --  The instantiation appears before the generic body if we are in the
+      --  scope of the unit containing the generic, either in its spec or in
+      --  the package body. and before the generic body.
+
+      if Ekind (Gen_Comp) = E_Package_Body then
+         Gen_Comp := Spec_Entity (Gen_Comp);
+      end if;
+
+      if In_Open_Scopes (Gen_Comp)
+        and then No (Corresponding_Body (Decl))
+      then
+         S := Current_Scope;
+
+         while Present (S)
+           and then not Is_Compilation_Unit (S)
+           and then not Is_Child_Unit (S)
+         loop
+            if Ekind (S) = E_Package then
+               Set_Has_Forward_Instantiation (S);
+            end if;
+
+            S := Scope (S);
+         end loop;
+      end if;
+   end Check_Forward_Instantiation;
+
+   ---------------------------
+   -- Check_Generic_Actuals --
+   ---------------------------
+
+   --  The visibility of the actuals may be different between the
+   --  point of generic instantiation and the instantiation of the body.
+
+   procedure Check_Generic_Actuals
+     (Instance      : Entity_Id;
+      Is_Formal_Box : Boolean)
+   is
+      E      : Entity_Id;
+      Astype : Entity_Id;
+
+   begin
+      E := First_Entity (Instance);
+      while Present (E) loop
+         if Is_Type (E)
+           and then Nkind (Parent (E)) = N_Subtype_Declaration
+           and then Scope (Etype (E)) /= Instance
+           and then Is_Entity_Name (Subtype_Indication (Parent (E)))
+         then
+            Check_Private_View (Subtype_Indication (Parent (E)));
+            Set_Is_Generic_Actual_Type (E, True);
+            Set_Is_Hidden (E, False);
+
+            --  We constructed the generic actual type as a subtype of
+            --  the supplied type. This means that it normally would not
+            --  inherit subtype specific attributes of the actual, which
+            --  is wrong for the generic case.
+
+            Astype := Ancestor_Subtype (E);
+
+            if No (Astype) then
+
+               --  can happen when E is an itype that is the full view of
+               --  a private type completed, e.g. with a constrained array.
+
+               Astype := Base_Type (E);
+            end if;
+
+            Set_Size_Info      (E,                (Astype));
+            Set_RM_Size        (E, RM_Size        (Astype));
+            Set_First_Rep_Item (E, First_Rep_Item (Astype));
+
+            if Is_Discrete_Or_Fixed_Point_Type (E) then
+               Set_RM_Size (E, RM_Size (Astype));
+
+            --  In  nested instances, the base type of an access actual
+            --  may itself be private, and need to be exchanged.
+
+            elsif Is_Access_Type (E)
+              and then Is_Private_Type (Etype (E))
+            then
+               Check_Private_View
+                 (New_Occurrence_Of (Etype (E), Sloc (Instance)));
+            end if;
+
+         elsif Ekind (E) = E_Package then
+
+            --  If this is the renaming for the current instance, we're done.
+            --  Otherwise it is a formal package. If the corresponding formal
+            --  was declared with a box, the (instantiations of the) generic
+            --  formal part are also visible. Otherwise, ignore the entity
+            --  created to validate the actuals.
+
+            if Renamed_Object (E) = Instance then
+               exit;
+
+            elsif Nkind (Parent (E)) /= N_Package_Renaming_Declaration then
+               null;
+
+            --  The visibility of a formal of an enclosing generic is already
+            --  correct.
+
+            elsif Denotes_Formal_Package (E) then
+               null;
+
+            elsif Present (Associated_Formal_Package (E))
+              and then Box_Present (Parent (Associated_Formal_Package (E)))
+            then
+               Check_Generic_Actuals (Renamed_Object (E), True);
+               Set_Is_Hidden (E, False);
+            end if;
+
+         else
+            Set_Is_Hidden (E, not Is_Formal_Box);
+         end if;
+
+         Next_Entity (E);
+      end loop;
+
+   end Check_Generic_Actuals;
+
+   ------------------------------
+   -- Check_Generic_Child_Unit --
+   ------------------------------
+
+   procedure Check_Generic_Child_Unit
+     (Gen_Id           : Node_Id;
+      Parent_Installed : in out Boolean)
+   is
+      Loc      : constant Source_Ptr := Sloc (Gen_Id);
+      Gen_Par  : Entity_Id := Empty;
+      Inst_Par : Entity_Id;
+      E        : Entity_Id;
+      S        : Node_Id;
+
+      function Find_Generic_Child
+        (Scop : Entity_Id;
+         Id   : Node_Id)
+         return Entity_Id;
+      --  Search generic parent for possible child unit.
+
+      function In_Enclosing_Instance return Boolean;
+      --  Within an instance of the parent, the child unit may be denoted
+      --  by a simple name. Examine enclosing scopes to locate a possible
+      --  parent instantiation.
+
+      function Find_Generic_Child
+        (Scop : Entity_Id;
+         Id   : Node_Id)
+         return Entity_Id
+      is
+         E : Entity_Id;
+
+      begin
+         --  If entity of name is already set, instance has already been
+         --  resolved, e.g. in an enclosing instantiation.
+
+         if Present (Entity (Id)) then
+            if Scope (Entity (Id)) = Scop then
+               return Entity (Id);
+            else
+               return Empty;
+            end if;
+
+         else
+            E := First_Entity (Scop);
+            while Present (E) loop
+               if Chars (E) = Chars (Id)
+                 and then Is_Child_Unit (E)
+               then
+                  if Is_Child_Unit (E)
+                    and then not Is_Visible_Child_Unit (E)
+                  then
+                     Error_Msg_NE
+                       ("generic child unit& is not visible", Gen_Id, E);
+                  end if;
+
+                  Set_Entity (Id, E);
+                  return E;
+               end if;
+
+               Next_Entity (E);
+            end loop;
+
+            return Empty;
+         end if;
+      end Find_Generic_Child;
+
+      function In_Enclosing_Instance return Boolean is
+         Enclosing_Instance : Node_Id;
+
+      begin
+         Enclosing_Instance := Current_Scope;
+
+         while Present (Enclosing_Instance) loop
+            exit when Ekind (Enclosing_Instance) = E_Package
+              and then Nkind (Parent (Enclosing_Instance)) =
+                N_Package_Specification
+              and then Present
+                (Generic_Parent (Parent (Enclosing_Instance)));
+
+            Enclosing_Instance := Scope (Enclosing_Instance);
+         end loop;
+
+         if Present (Enclosing_Instance) then
+            E := Find_Generic_Child
+             (Generic_Parent (Parent (Enclosing_Instance)), Gen_Id);
+         else
+            return False;
+         end if;
+
+         if Present (E) then
+            Rewrite (Gen_Id,
+              Make_Expanded_Name (Loc,
+                Chars         => Chars (E),
+                Prefix        => New_Occurrence_Of (Enclosing_Instance, Loc),
+                Selector_Name => New_Occurrence_Of (E, Loc)));
+
+            Set_Entity (Gen_Id, E);
+            Set_Etype  (Gen_Id, Etype (E));
+            Parent_Installed := False;      -- Already in scope.
+            return True;
+         else
+            Analyze (Gen_Id);
+            return False;
+         end if;
+      end In_Enclosing_Instance;
+
+   --  Start of processing for Check_Generic_Child_Unit
+
+   begin
+      --  If the name of the generic is given by a selected component, it
+      --  may be the name of a generic child unit, and the prefix is the name
+      --  of an instance of the parent, in which case the child unit must be
+      --  visible. If this instance is not in scope, it must be placed there
+      --  and removed after instantiation, because what is being instantiated
+      --  is not the original child, but the corresponding child present in
+      --  the instance of the parent.
+
+      --  If the child is instantiated within the parent, it can be given by
+      --  a simple name. In this case the instance is already in scope, but
+      --  the child generic must be recovered from the generic parent as well.
+
+      if Nkind (Gen_Id) = N_Selected_Component then
+         S := Selector_Name (Gen_Id);
+         Analyze (Prefix (Gen_Id));
+         Inst_Par := Entity (Prefix (Gen_Id));
+
+         if Ekind (Inst_Par) = E_Package
+           and then Present (Renamed_Object (Inst_Par))
+         then
+            Inst_Par := Renamed_Object (Inst_Par);
+         end if;
+
+         if Ekind (Inst_Par) = E_Package then
+            if Nkind (Parent (Inst_Par)) = N_Package_Specification then
+               Gen_Par := Generic_Parent (Parent (Inst_Par));
+
+            elsif Nkind (Parent (Inst_Par)) = N_Defining_Program_Unit_Name
+              and then
+                Nkind (Parent (Parent (Inst_Par))) = N_Package_Specification
+            then
+               Gen_Par := Generic_Parent (Parent (Parent (Inst_Par)));
+            end if;
+
+         elsif Ekind (Inst_Par) = E_Generic_Package
+           and then Nkind (Parent (Gen_Id)) = N_Formal_Package_Declaration
+         then
+
+            --  A formal package may be a real child package, and not the
+            --  implicit instance within a parent. In this case the child is
+            --  not visible and has to be retrieved explicitly as well.
+
+            Gen_Par := Inst_Par;
+         end if;
+
+         if Present (Gen_Par) then
+
+            --  The prefix denotes an instantiation. The entity itself
+            --  may be a nested generic, or a child unit.
+
+            E := Find_Generic_Child (Gen_Par, S);
+
+            if Present (E) then
+               Change_Selected_Component_To_Expanded_Name (Gen_Id);
+               Set_Entity (Gen_Id, E);
+               Set_Etype (Gen_Id, Etype (E));
+               Set_Entity (S, E);
+               Set_Etype (S, Etype (E));
+
+               --  Indicate that this is a reference to the parent.
+
+               if In_Extended_Main_Source_Unit (Gen_Id) then
+                  Set_Is_Instantiated (Inst_Par);
+               end if;
+
+               --  A common mistake is to replicate the naming scheme of
+               --  a hierarchy by instantiating a generic child directly,
+               --  rather than the implicit child in a parent instance:
+               --
+               --  generic .. package Gpar is ..
+               --  generic .. package Gpar.Child is ..
+               --  package Par is new Gpar ();
+
+               --  with Gpar.Child;
+               --  package Par.Child is new Gpar.Child ();
+               --                           rather than Par.Child
+               --
+               --  In this case the instantiation is within Par, which is
+               --  an instance, but Gpar does not denote Par because we are
+               --  not IN the instance of Gpar, so this is illegal. The test
+               --  below recognizes this particular case.
+
+               if Is_Child_Unit (E)
+                 and then not Comes_From_Source (Entity (Prefix (Gen_Id)))
+                 and then (not In_Instance
+                             or else Nkind (Parent (Parent (Gen_Id))) =
+                                                         N_Compilation_Unit)
+               then
+                  Error_Msg_N
+                    ("prefix of generic child unit must be instance of parent",
+                      Gen_Id);
+               end if;
+
+               if not In_Open_Scopes (Inst_Par)
+                 and then Nkind (Parent (Gen_Id))
+                   not in N_Generic_Renaming_Declaration
+               then
+                  Install_Parent (Inst_Par);
+                  Parent_Installed := True;
+               end if;
+
+            else
+               --  If the generic parent does not contain an entity that
+               --  corresponds to the selector, the instance doesn't either.
+               --  Analyzing the node will yield the appropriate error message.
+               --  If the entity is not a child unit, then it is an inner
+               --  generic in the parent.
+
+               Analyze (Gen_Id);
+            end if;
+
+         else
+            Analyze (Gen_Id);
+
+            if Is_Child_Unit (Entity (Gen_Id))
+              and then Nkind (Parent (Gen_Id))
+                not in N_Generic_Renaming_Declaration
+              and then not In_Open_Scopes (Inst_Par)
+            then
+               Install_Parent (Inst_Par);
+               Parent_Installed := True;
+            end if;
+         end if;
+
+      elsif Nkind (Gen_Id) = N_Expanded_Name then
+
+         --  Entity already present, analyze prefix, whose meaning may be
+         --  an instance in the current context. If it is an instance of
+         --  a relative within another, the proper parent may still have
+         --  to be installed, if they are not of the same generation.
+
+         Analyze (Prefix (Gen_Id));
+         Inst_Par := Entity (Prefix (Gen_Id));
+
+         if In_Enclosing_Instance then
+            null;
+
+         elsif Present (Entity (Gen_Id))
+           and then Is_Child_Unit (Entity (Gen_Id))
+           and then not In_Open_Scopes (Inst_Par)
+         then
+            Install_Parent (Inst_Par);
+            Parent_Installed := True;
+         end if;
+
+      elsif In_Enclosing_Instance then
+         --  The child unit is found in some enclosing scope.
+         null;
+
+      else
+         Analyze (Gen_Id);
+
+         --  If this is the renaming of the implicit child in a parent
+         --  instance, recover the parent name and install it.
+
+         if Is_Entity_Name (Gen_Id) then
+            E := Entity (Gen_Id);
+
+            if Is_Generic_Unit (E)
+              and then Nkind (Parent (E)) in N_Generic_Renaming_Declaration
+              and then Is_Child_Unit (Renamed_Object (E))
+              and then Is_Generic_Unit (Scope (Renamed_Object (E)))
+              and then Nkind (Name (Parent (E))) = N_Expanded_Name
+            then
+               Rewrite (Gen_Id,
+                 New_Copy_Tree (Name (Parent (E))));
+               Inst_Par := Entity (Prefix (Gen_Id));
+
+               if not In_Open_Scopes (Inst_Par) then
+                  Install_Parent (Inst_Par);
+                  Parent_Installed := True;
+               end if;
+
+            --  If it is a child unit of a non-generic parent, it may be
+            --  use-visible and given by a direct name. Install parent as
+            --  for other cases.
+
+            elsif Is_Generic_Unit (E)
+              and then Is_Child_Unit (E)
+              and then
+                Nkind (Parent (Gen_Id)) not in N_Generic_Renaming_Declaration
+              and then not Is_Generic_Unit (Scope (E))
+            then
+               if not In_Open_Scopes (Scope (E)) then
+                  Install_Parent (Scope (E));
+                  Parent_Installed := True;
+               end if;
+            end if;
+         end if;
+      end if;
+   end Check_Generic_Child_Unit;
+
+   -----------------------------
+   -- Check_Hidden_Child_Unit --
+   -----------------------------
+
+   procedure Check_Hidden_Child_Unit
+     (N           : Node_Id;
+      Gen_Unit    : Entity_Id;
+      Act_Decl_Id : Entity_Id)
+   is
+      Gen_Id : Node_Id := Name (N);
+
+   begin
+      if Is_Child_Unit (Gen_Unit)
+        and then Is_Child_Unit (Act_Decl_Id)
+        and then Nkind (Gen_Id) = N_Expanded_Name
+        and then Entity (Prefix (Gen_Id)) = Scope (Act_Decl_Id)
+        and then Chars (Gen_Unit) = Chars (Act_Decl_Id)
+      then
+         Error_Msg_Node_2 := Scope (Act_Decl_Id);
+         Error_Msg_NE
+           ("generic unit & is implicitly declared in &",
+             Defining_Unit_Name (N), Gen_Unit);
+         Error_Msg_N ("\instance must have different name",
+           Defining_Unit_Name (N));
+      end if;
+   end Check_Hidden_Child_Unit;
+
+   ------------------------
+   -- Check_Private_View --
+   ------------------------
+
+   procedure Check_Private_View (N : Node_Id) is
+      T : constant Entity_Id := Etype (N);
+      BT : Entity_Id;
+
+   begin
+      --  Exchange views if the type was not private in the generic but is
+      --  private at the point of instantiation. Do not exchange views if
+      --  the scope of the type is in scope. This can happen if both generic
+      --  and instance are sibling units, or if type is defined in a parent.
+      --  In this case the visibility of the type will be correct for all
+      --  semantic checks.
+
+      if Present (T) then
+         BT := Base_Type (T);
+
+         if Is_Private_Type (T)
+           and then not Has_Private_View (N)
+           and then Present (Full_View (T))
+           and then not In_Open_Scopes (Scope (T))
+         then
+            --  In the generic, the full type was visible. Save the
+            --  private entity, for subsequent exchange.
+
+            Switch_View (T);
+
+         elsif Has_Private_View (N)
+           and then not Is_Private_Type (T)
+           and then not Has_Been_Exchanged (T)
+           and then Etype (Associated_Node (N)) /= T
+         then
+            --  Only the private declaration was visible in the generic. If
+            --  the type appears in a subtype declaration, the subtype in the
+            --  instance must have a view compatible with that of its parent,
+            --  which must be exchanged (see corresponding code in Restore_
+            --  Private_Views). Otherwise, if the type is defined in a parent
+            --  unit, leave full visibility within instance, which is safe.
+
+            if In_Open_Scopes (Scope (Base_Type (T)))
+              and then not Is_Private_Type (Base_Type (T))
+              and then Comes_From_Source (Base_Type (T))
+            then
+               null;
+
+            elsif Nkind (Parent (N)) = N_Subtype_Declaration
+              or else not In_Private_Part (Scope (Base_Type (T)))
+            then
+               Append_Elmt (T, Exchanged_Views);
+               Exchange_Declarations (Etype (Associated_Node (N)));
+            end if;
+
+         --  For composite types with inconsistent representation
+         --  exchange component types accordingly.
+
+         elsif Is_Access_Type (T)
+           and then Is_Private_Type (Designated_Type (T))
+           and then Present (Full_View (Designated_Type (T)))
+         then
+            Switch_View (Designated_Type (T));
+
+         elsif Is_Array_Type (T)
+           and then Is_Private_Type (Component_Type (T))
+           and then not Has_Private_View (N)
+           and then Present (Full_View (Component_Type (T)))
+         then
+            Switch_View (Component_Type (T));
+
+         elsif Is_Private_Type (T)
+           and then Present (Full_View (T))
+           and then Is_Array_Type (Full_View (T))
+           and then Is_Private_Type (Component_Type (Full_View (T)))
+         then
+            Switch_View (T);
+
+         --  Finally, a non-private subtype may have a private base type,
+         --  which must be exchanged for consistency. This can happen when
+         --  instantiating a package body, when the scope stack is empty but
+         --  in fact the subtype and the base type are declared in an enclosing
+         --  scope.
+
+         elsif not Is_Private_Type (T)
+           and then not Has_Private_View (N)
+           and then Is_Private_Type (Base_Type (T))
+           and then Present (Full_View (BT))
+           and then not Is_Generic_Type (BT)
+           and then not In_Open_Scopes (BT)
+         then
+            Append_Elmt (Full_View (BT), Exchanged_Views);
+            Exchange_Declarations (BT);
+         end if;
+      end if;
+   end Check_Private_View;
+
+   --------------------------
+   -- Contains_Instance_Of --
+   --------------------------
+
+   function Contains_Instance_Of
+     (Inner : Entity_Id;
+      Outer : Entity_Id;
+      N     : Node_Id)
+      return  Boolean
+   is
+      Elmt : Elmt_Id;
+      Scop : Entity_Id;
+
+   begin
+      Scop := Outer;
+
+      --  Verify that there are no circular instantiations. We check whether
+      --  the unit contains an instance of the current scope or some enclosing
+      --  scope (in case one of the instances appears in a subunit). Longer
+      --  circularities involving subunits might seem too pathological to
+      --  consider, but they were not too pathological for the authors of
+      --  DEC bc30vsq, so we loop over all enclosing scopes, and mark all
+      --  enclosing generic scopes as containing an instance.
+
+      loop
+         --  Within a generic subprogram body, the scope is not generic, to
+         --  allow for recursive subprograms. Use the declaration to determine
+         --  whether this is a generic unit.
+
+         if Ekind (Scop) = E_Generic_Package
+           or else (Is_Subprogram (Scop)
+                      and then Nkind (Unit_Declaration_Node (Scop)) =
+                                        N_Generic_Subprogram_Declaration)
+         then
+            Elmt := First_Elmt (Inner_Instances (Inner));
+
+            while Present (Elmt) loop
+               if Node (Elmt) = Scop then
+                  Error_Msg_Node_2 := Inner;
+                  Error_Msg_NE
+                    ("circular Instantiation: & instantiated within &!",
+                       N, Scop);
+                  return True;
+
+               elsif Node (Elmt) = Inner then
+                  return True;
+
+               elsif Contains_Instance_Of (Node (Elmt), Scop, N) then
+                  Error_Msg_Node_2 := Inner;
+                  Error_Msg_NE
+                    ("circular Instantiation: & instantiated within &!",
+                      N, Node (Elmt));
+                  return True;
+               end if;
+
+               Next_Elmt (Elmt);
+            end loop;
+
+            --  Indicate that Inner is being instantiated within  Scop.
+
+            Append_Elmt (Inner, Inner_Instances (Scop));
+         end if;
+
+         if Scop = Standard_Standard then
+            exit;
+         else
+            Scop := Scope (Scop);
+         end if;
+      end loop;
+
+      return False;
+   end Contains_Instance_Of;
+
+   -----------------------
+   -- Copy_Generic_Node --
+   -----------------------
+
+   function Copy_Generic_Node
+     (N             : Node_Id;
+      Parent_Id     : Node_Id;
+      Instantiating : Boolean)
+      return          Node_Id
+   is
+      Ent   : Entity_Id;
+      New_N : Node_Id;
+
+      function Copy_Generic_Descendant (D : Union_Id) return Union_Id;
+      --  Check the given value of one of the Fields referenced by the
+      --  current node to determine whether to copy it recursively. The
+      --  field may hold a Node_Id, a List_Id, or an Elist_Id, or a plain
+      --  value (Sloc, Uint, Char) in which case it need not be copied.
+
+      function Copy_Generic_Elist (E : Elist_Id) return Elist_Id;
+      --  Make copy of element list.
+
+      function Copy_Generic_List
+        (L         : List_Id;
+         Parent_Id : Node_Id)
+         return      List_Id;
+      --  Apply Copy_Node recursively to the members of a node list.
+
+      -----------------------------
+      -- Copy_Generic_Descendant --
+      -----------------------------
+
+      function Copy_Generic_Descendant (D : Union_Id) return Union_Id is
+      begin
+         if D = Union_Id (Empty) then
+            return D;
+
+         elsif D in Node_Range then
+            return Union_Id
+              (Copy_Generic_Node (Node_Id (D), New_N, Instantiating));
+
+         elsif D in List_Range then
+            return Union_Id (Copy_Generic_List (List_Id (D), New_N));
+
+         elsif D in Elist_Range then
+            return Union_Id (Copy_Generic_Elist (Elist_Id (D)));
+
+         --  Nothing else is copyable (e.g. Uint values), return as is
+
+         else
+            return D;
+         end if;
+      end Copy_Generic_Descendant;
+
+      ------------------------
+      -- Copy_Generic_Elist --
+      ------------------------
+
+      function Copy_Generic_Elist (E : Elist_Id) return Elist_Id is
+         M : Elmt_Id;
+         L : Elist_Id;
+
+      begin
+         if Present (E) then
+            L := New_Elmt_List;
+            M := First_Elmt (E);
+            while Present (M) loop
+               Append_Elmt
+                 (Copy_Generic_Node (Node (M), Empty, Instantiating), L);
+               Next_Elmt (M);
+            end loop;
+
+            return L;
+
+         else
+            return No_Elist;
+         end if;
+      end Copy_Generic_Elist;
+
+      -----------------------
+      -- Copy_Generic_List --
+      -----------------------
+
+      function Copy_Generic_List
+        (L         : List_Id;
+         Parent_Id : Node_Id)
+         return      List_Id
+      is
+         N     : Node_Id;
+         New_L : List_Id;
+
+      begin
+         if Present (L) then
+            New_L := New_List;
+            Set_Parent (New_L, Parent_Id);
+
+            N := First (L);
+            while Present (N) loop
+               Append (Copy_Generic_Node (N, Empty, Instantiating), New_L);
+               Next (N);
+            end loop;
+
+            return New_L;
+
+         else
+            return No_List;
+         end if;
+      end Copy_Generic_List;
+
+   --  Start of processing for Copy_Generic_Node
+
+   begin
+      if N = Empty then
+         return N;
+      end if;
+
+      New_N := New_Copy (N);
+
+      if Instantiating then
+         Adjust_Instantiation_Sloc (New_N, S_Adjustment);
+      end if;
+
+      if not Is_List_Member (N) then
+         Set_Parent (New_N, Parent_Id);
+      end if;
+
+      --  If defining identifier, then all fields have been copied already
+
+      if Nkind (New_N) in N_Entity then
+         null;
+
+      --  Special casing for identifiers and other entity names and operators
+
+      elsif    (Nkind (New_N) = N_Identifier
+        or else Nkind (New_N) = N_Character_Literal
+        or else Nkind (New_N) = N_Expanded_Name
+        or else Nkind (New_N) = N_Operator_Symbol
+        or else Nkind (New_N) in N_Op)
+      then
+         if not Instantiating then
+
+            --  Link both nodes in order to assign subsequently the
+            --  entity of the copy to the original node, in case this
+            --  is a global reference.
+
+            Set_Associated_Node (N, New_N);
+
+            --  If we are within an instantiation, this is a nested generic
+            --  that has already been analyzed at the point of definition. We
+            --  must preserve references that were global to the enclosing
+            --  parent at that point. Other occurrences, whether global or
+            --  local to the current generic, must be resolved anew, so we
+            --  reset the entity in the generic copy. A global reference has
+            --  a smaller depth than the parent, or else the same depth in
+            --  case both are distinct compilation units.
+
+            --  It is also possible for Current_Instantiated_Parent to be
+            --  defined, and for this not to be a nested generic, namely
+            --  if the unit is loaded through Rtsfind. In that case, the
+            --  entity of New_N is only a link to the associated node, and
+            --  not a defining occurrence.
+
+            --  The entities for parent units in the defining_program_unit
+            --  of a generic child unit are established when the context of
+            --  the unit is first analyzed, before the generic copy is made.
+            --  They are preserved in the copy for use in ASIS queries.
+
+            Ent := Entity (New_N);
+
+            if No (Current_Instantiated_Parent.Gen_Id) then
+               if No (Ent)
+                 or else Nkind (Ent) /= N_Defining_Identifier
+                 or else Nkind (Parent (N)) /= N_Defining_Program_Unit_Name
+               then
+                  Set_Associated_Node (New_N, Empty);
+               end if;
+
+            elsif No (Ent)
+              or else
+                not (Nkind (Ent) = N_Defining_Identifier
+                       or else
+                     Nkind (Ent) = N_Defining_Character_Literal
+                       or else
+                     Nkind (Ent) = N_Defining_Operator_Symbol)
+              or else No (Scope (Ent))
+              or else Scope (Ent) = Current_Instantiated_Parent.Gen_Id
+              or else (Scope_Depth (Scope (Ent)) >
+                             Scope_Depth (Current_Instantiated_Parent.Gen_Id)
+                         and then
+                       Get_Source_Unit (Ent) =
+                       Get_Source_Unit (Current_Instantiated_Parent.Gen_Id))
+            then
+               Set_Associated_Node (New_N, Empty);
+            end if;
+
+         --  Case of instantiating identifier or some other name or operator
+
+         else
+            --  If the associated node is still defined, the entity in
+            --  it is global, and must be copied to the instance.
+
+            if Present (Associated_Node (N)) then
+               if Nkind (Associated_Node (N)) = Nkind (N) then
+                  Set_Entity (New_N, Entity (Associated_Node (N)));
+                  Check_Private_View (N);
+
+               elsif Nkind (Associated_Node (N)) = N_Function_Call then
+                  Set_Entity (New_N, Entity (Name (Associated_Node (N))));
+
+               else
+                  Set_Entity (New_N, Empty);
+               end if;
+            end if;
+         end if;
+
+         --  For expanded name, we must copy the Prefix and Selector_Name
+
+         if Nkind (N) = N_Expanded_Name then
+
+            Set_Prefix
+              (New_N, Copy_Generic_Node (Prefix (N), New_N, Instantiating));
+
+            Set_Selector_Name (New_N,
+              Copy_Generic_Node (Selector_Name (N), New_N, Instantiating));
+
+         --  For operators, we must copy the right operand
+
+         elsif Nkind (N) in N_Op then
+
+            Set_Right_Opnd (New_N,
+              Copy_Generic_Node (Right_Opnd (N), New_N, Instantiating));
+
+            --  And for binary operators, the left operand as well
+
+            if Nkind (N) in N_Binary_Op then
+               Set_Left_Opnd (New_N,
+                 Copy_Generic_Node (Left_Opnd (N), New_N, Instantiating));
+            end if;
+         end if;
+
+      --  Special casing for stubs
+
+      elsif Nkind (N) in N_Body_Stub then
+
+         --  In any case, we must copy the specification or defining
+         --  identifier as appropriate.
+
+         if Nkind (N) = N_Subprogram_Body_Stub then
+            Set_Specification (New_N,
+              Copy_Generic_Node (Specification (N), New_N, Instantiating));
+
+         else
+            Set_Defining_Identifier (New_N,
+              Copy_Generic_Node
+                (Defining_Identifier (N), New_N, Instantiating));
+         end if;
+
+         --  If we are not instantiating, then this is where we load and
+         --  analyze subunits, i.e. at the point where the stub occurs. A
+         --  more permissivle system might defer this analysis to the point
+         --  of instantiation, but this seems to complicated for now.
+
+         if not Instantiating then
+            declare
+               Subunit_Name : constant Unit_Name_Type := Get_Unit_Name (N);
+               Subunit      : Node_Id;
+               Unum         : Unit_Number_Type;
+               New_Body     : Node_Id;
+
+            begin
+               Unum :=
+                 Load_Unit
+                   (Load_Name  => Subunit_Name,
+                    Required   => False,
+                    Subunit    => True,
+                    Error_Node => N);
+
+               --  If the proper body is not found, a warning message will
+               --  be emitted when analyzing the stub, or later at the the
+               --  point of instantiation. Here we just leave the stub as is.
+
+               if Unum = No_Unit then
+                  Subunits_Missing := True;
+                  goto Subunit_Not_Found;
+               end if;
+
+               Subunit := Cunit (Unum);
+
+               --  We must create a generic copy of the subunit, in order
+               --  to perform semantic analysis on it, and we must replace
+               --  the stub in the original generic unit with the subunit,
+               --  in order to preserve non-local references within.
+
+               --  Only the proper body needs to be copied. Library_Unit and
+               --  context clause are simply inherited by the generic copy.
+               --  Note that the copy (which may be recursive if there are
+               --  nested subunits) must be done first, before attaching it
+               --  to the enclosing generic.
+
+               New_Body :=
+                 Copy_Generic_Node
+                   (Proper_Body (Unit (Subunit)),
+                    Empty, Instantiating => False);
+
+               --  Now place the original proper body in the original
+               --  generic unit.
+
+               Rewrite (N, Proper_Body (Unit (Subunit)));
+               Set_Was_Originally_Stub (N);
+
+               --  Finally replace the body of the subunit with its copy,
+               --  and make this new subunit into the library unit of the
+               --  generic copy, which does not have stubs any longer.
+
+               Set_Proper_Body (Unit (Subunit), New_Body);
+               Set_Library_Unit (New_N, Subunit);
+               Inherit_Context (Unit (Subunit), N);
+
+            end;
+
+         --  If we are instantiating, this must be an error case, since
+         --  otherwise we would have replaced the stub node by the proper
+         --  body that corresponds. So just ignore it in the copy (i.e.
+         --  we have copied it, and that is good enough).
+
+         else
+            null;
+         end if;
+
+         <<Subunit_Not_Found>> null;
+
+      --  If the node is a compilation unit, it is the subunit of a stub,
+      --  which has been loaded already (see code below). In this case,
+      --  the library unit field of N points to the parent unit (which
+      --  is a compilation unit) and need not (and cannot!) be copied.
+
+      --  When the proper body of the stub is analyzed, thie library_unit
+      --  link is used to establish the proper context (see sem_ch10).
+
+      --  The other fields of a compilation unit are copied as usual
+
+      elsif Nkind (N) = N_Compilation_Unit then
+
+         --  This code can only be executed when not instantiating, because
+         --  in the copy made for an instantiation, the compilation unit
+         --  node has disappeared at the point that a stub is replaced by
+         --  its proper body.
+
+         pragma Assert (not Instantiating);
+
+         Set_Context_Items (New_N,
+           Copy_Generic_List (Context_Items (N), New_N));
+
+         Set_Unit (New_N,
+           Copy_Generic_Node (Unit (N), New_N, False));
+
+         Set_First_Inlined_Subprogram (New_N,
+           Copy_Generic_Node
+             (First_Inlined_Subprogram (N), New_N, False));
+
+         Set_Aux_Decls_Node (New_N,
+           Copy_Generic_Node (Aux_Decls_Node (N), New_N, False));
+
+      --  For an assignment node, the assignment is known to be semantically
+      --  legal if we are instantiating the template. This avoids incorrect
+      --  diagnostics in generated code.
+
+      elsif Nkind (N) = N_Assignment_Statement then
+
+         --  Copy name and expression fields in usual manner
+
+         Set_Name (New_N,
+           Copy_Generic_Node (Name (N), New_N, Instantiating));
+
+         Set_Expression (New_N,
+           Copy_Generic_Node (Expression (N), New_N, Instantiating));
+
+         if Instantiating then
+            Set_Assignment_OK (Name (New_N), True);
+         end if;
+
+      elsif Nkind (N) = N_Aggregate
+              or else Nkind (N) = N_Extension_Aggregate
+      then
+
+         if not Instantiating then
+            Set_Associated_Node (N, New_N);
+
+         else
+            if Present (Associated_Node (N))
+              and then Nkind (Associated_Node (N)) = Nkind (N)
+            then
+               --  In the generic the aggregate has some composite type.
+               --  If at the point of instantiation the type has a private
+               --  view, install the full view (and that of its ancestors,
+               --  if any).
+
+               declare
+                  T   : Entity_Id := (Etype (Associated_Node (New_N)));
+                  Rt  : Entity_Id;
+
+               begin
+                  if Present (T)
+                    and then Is_Private_Type (T)
+                  then
+                     Switch_View (T);
+                  end if;
+
+                  if Present (T)
+                    and then Is_Tagged_Type (T)
+                    and then Is_Derived_Type (T)
+                  then
+                     Rt := Root_Type (T);
+
+                     loop
+                        T := Etype (T);
+
+                        if Is_Private_Type (T) then
+                           Switch_View (T);
+                        end if;
+
+                        exit when T = Rt;
+                     end loop;
+                  end if;
+               end;
+            end if;
+         end if;
+
+         Set_Field1 (New_N, Copy_Generic_Descendant (Field1 (N)));
+         Set_Field2 (New_N, Copy_Generic_Descendant (Field2 (N)));
+         Set_Field3 (New_N, Copy_Generic_Descendant (Field3 (N)));
+         Set_Field5 (New_N, Copy_Generic_Descendant (Field5 (N)));
+
+      --  For a proper body, we must catch the case of a proper body that
+      --  replaces a stub. This represents the point at which a separate
+      --  compilation unit, and hence template file, may be referenced, so
+      --  we must make a new source instantiation entry for the template
+      --  of the subunit, and ensure that all nodes in the subunit are
+      --  adjusted using this new source instantiation entry.
+
+      elsif Nkind (N) in N_Proper_Body then
+
+         declare
+            Save_Adjustment : constant Sloc_Adjustment := S_Adjustment;
+
+         begin
+            if Instantiating and then Was_Originally_Stub (N) then
+               Create_Instantiation_Source
+                 (Instantiation_Node, Defining_Entity (N), S_Adjustment);
+            end if;
+
+            --  Now copy the fields of the proper body, using the new
+            --  adjustment factor if one was needed as per test above.
+
+            Set_Field1 (New_N, Copy_Generic_Descendant (Field1 (N)));
+            Set_Field2 (New_N, Copy_Generic_Descendant (Field2 (N)));
+            Set_Field3 (New_N, Copy_Generic_Descendant (Field3 (N)));
+            Set_Field4 (New_N, Copy_Generic_Descendant (Field4 (N)));
+            Set_Field5 (New_N, Copy_Generic_Descendant (Field5 (N)));
+
+            --  Restore the original adjustment factor in case changed
+
+            S_Adjustment := Save_Adjustment;
+         end;
+
+      --  Don't copy Ident or Comment pragmas, since the comment belongs
+      --  to the generic unit, not to the instantiating unit.
+
+      elsif Nkind (N) = N_Pragma
+        and then Instantiating
+      then
+         declare
+            Prag_Id : constant Pragma_Id := Get_Pragma_Id (Chars (N));
+
+         begin
+            if Prag_Id = Pragma_Ident
+              or else Prag_Id = Pragma_Comment
+            then
+               New_N := Make_Null_Statement (Sloc (N));
+
+            else
+               Set_Field1 (New_N, Copy_Generic_Descendant (Field1 (N)));
+               Set_Field2 (New_N, Copy_Generic_Descendant (Field2 (N)));
+               Set_Field3 (New_N, Copy_Generic_Descendant (Field3 (N)));
+               Set_Field4 (New_N, Copy_Generic_Descendant (Field4 (N)));
+               Set_Field5 (New_N, Copy_Generic_Descendant (Field5 (N)));
+            end if;
+         end;
+
+      --  For the remaining nodes, copy recursively their descendants.
+
+      else
+         Set_Field1 (New_N, Copy_Generic_Descendant (Field1 (N)));
+         Set_Field2 (New_N, Copy_Generic_Descendant (Field2 (N)));
+         Set_Field3 (New_N, Copy_Generic_Descendant (Field3 (N)));
+         Set_Field4 (New_N, Copy_Generic_Descendant (Field4 (N)));
+         Set_Field5 (New_N, Copy_Generic_Descendant (Field5 (N)));
+
+         if Instantiating
+           and then Nkind (N) = N_Subprogram_Body
+         then
+            Set_Generic_Parent (Specification (New_N), N);
+         end if;
+      end if;
+
+      return New_N;
+   end Copy_Generic_Node;
+
+   ----------------------------
+   -- Denotes_Formal_Package --
+   ----------------------------
+
+   function Denotes_Formal_Package (Pack : Entity_Id) return Boolean is
+      Par  : constant Entity_Id := Current_Instantiated_Parent.Act_Id;
+      Scop : Entity_Id := Scope (Pack);
+      E    : Entity_Id;
+
+   begin
+      if Ekind (Scop) = E_Generic_Package
+        or else Nkind (Unit_Declaration_Node (Scop))
+          = N_Generic_Subprogram_Declaration
+      then
+         return True;
+
+      elsif Nkind (Parent (Pack)) = N_Formal_Package_Declaration then
+         return True;
+
+      elsif No (Par) then
+         return False;
+
+      else
+         --  Check whether this package is associated with a formal
+         --  package of the enclosing instantiation. Iterate over the
+         --  list of renamings.
+
+         E := First_Entity (Par);
+         while Present (E) loop
+
+            if Ekind (E) /= E_Package
+              or else Nkind (Parent (E)) /= N_Package_Renaming_Declaration
+            then
+               null;
+            elsif Renamed_Object (E) = Par then
+               return False;
+
+            elsif Renamed_Object (E) = Pack then
+               return True;
+            end if;
+
+            Next_Entity (E);
+         end loop;
+
+         return False;
+      end if;
+   end Denotes_Formal_Package;
+
+   -----------------
+   -- End_Generic --
+   -----------------
+
+   procedure End_Generic is
+   begin
+      --  ??? More things could be factored out in this
+      --  routine. Should probably be done at a later stage.
+
+      Inside_A_Generic := Generic_Flags.Table (Generic_Flags.Last);
+      Generic_Flags.Decrement_Last;
+
+      Expander_Mode_Restore;
+   end End_Generic;
+
+   ----------------------
+   -- Find_Actual_Type --
+   ----------------------
+
+   function Find_Actual_Type
+     (Typ       : Entity_Id;
+      Gen_Scope : Entity_Id)
+      return      Entity_Id
+   is
+      T : Entity_Id;
+
+   begin
+      if not Is_Child_Unit (Gen_Scope) then
+         return Get_Instance_Of (Typ);
+
+      elsif not Is_Generic_Type (Typ)
+        or else Scope (Typ) = Gen_Scope
+      then
+         return Get_Instance_Of (Typ);
+
+      else
+         T := Current_Entity (Typ);
+         while Present (T) loop
+            if In_Open_Scopes (Scope (T)) then
+               return T;
+            end if;
+
+            T := Homonym (T);
+         end loop;
+
+         return Typ;
+      end if;
+   end Find_Actual_Type;
+
+   ----------------------------
+   -- Freeze_Subprogram_Body --
+   ----------------------------
+
+   procedure Freeze_Subprogram_Body
+     (Inst_Node : Node_Id;
+      Gen_Body  : Node_Id;
+      Pack_Id   : Entity_Id)
+  is
+      F_Node   : Node_Id;
+      Gen_Unit : constant Entity_Id := Entity (Name (Inst_Node));
+      Par      : constant Entity_Id := Scope (Gen_Unit);
+      Enc_G    : Entity_Id;
+      Enc_I    : Node_Id;
+      E_G_Id   : Entity_Id;
+
+      function Earlier (N1, N2 : Node_Id) return Boolean;
+      --  Yields True if N1 and N2 appear in the same compilation unit,
+      --  ignoring subunits, and if N1 is to the left of N2 in a left-to-right
+      --  traversal of the tree for the unit.
+
+      function Enclosing_Body (N : Node_Id) return Node_Id;
+      --  Find innermost package body that encloses the given node, and which
+      --  is not a compilation unit. Freeze nodes for the instance, or for its
+      --  enclosing body, may be inserted after the enclosing_body of the
+      --  generic unit.
+
+      function Package_Freeze_Node (B : Node_Id) return Node_Id;
+      --  Find entity for given package body, and locate or create a freeze
+      --  node for it.
+
+      function True_Parent (N : Node_Id) return Node_Id;
+      --  For a subunit, return parent of corresponding stub.
+
+      -------------
+      -- Earlier --
+      -------------
+
+      function Earlier (N1, N2 : Node_Id) return Boolean is
+         D1 : Integer := 0;
+         D2 : Integer := 0;
+         P1 : Node_Id := N1;
+         P2 : Node_Id := N2;
+
+         procedure Find_Depth (P : in out Node_Id; D : in out Integer);
+         --  Find distance from given node to enclosing compilation unit.
+
+         procedure Find_Depth (P : in out Node_Id; D : in out Integer) is
+         begin
+            while Present (P)
+              and then Nkind (P) /= N_Compilation_Unit
+            loop
+               P := True_Parent (P);
+               D := D + 1;
+            end loop;
+         end Find_Depth;
+
+      begin
+         Find_Depth (P1, D1);
+         Find_Depth (P2, D2);
+
+         if P1 /= P2 then
+            return False;
+         else
+            P1 := N1;
+            P2 := N2;
+         end if;
+
+         while D1 > D2 loop
+            P1 := True_Parent (P1);
+            D1 := D1 - 1;
+         end loop;
+
+         while D2 > D1 loop
+            P2 := True_Parent (P2);
+            D2 := D2 - 1;
+         end loop;
+
+         --  At this point P1 and P2 are at the same distance from the root.
+         --  We examine their parents until we find a common declarative
+         --  list, at which point we can establish their relative placement
+         --  by comparing their ultimate slocs. If we reach the root,
+         --  N1 and N2 do not descend from the same declarative list (e.g.
+         --  one is nested in the declarative part and the other is in a block
+         --  in the statement part) and the earlier one is already frozen.
+
+         while not Is_List_Member (P1)
+           or else not Is_List_Member (P2)
+           or else List_Containing (P1) /= List_Containing (P2)
+         loop
+            P1 := True_Parent (P1);
+            P2 := True_Parent (P2);
+
+            if Nkind (Parent (P1)) = N_Subunit then
+               P1 := Corresponding_Stub (Parent (P1));
+            end if;
+
+            if Nkind (Parent (P2)) = N_Subunit then
+               P2 := Corresponding_Stub (Parent (P2));
+            end if;
+
+            if P1 = P2 then
+               return False;
+            end if;
+         end loop;
+
+         return
+           Top_Level_Location (Sloc (P1)) < Top_Level_Location (Sloc (P2));
+      end Earlier;
+
+      --------------------
+      -- Enclosing_Body --
+      --------------------
+
+      function Enclosing_Body (N : Node_Id) return Node_Id is
+         P : Node_Id := Parent (N);
+
+      begin
+         while Present (P)
+           and then Nkind (Parent (P)) /= N_Compilation_Unit
+         loop
+            if Nkind (P) = N_Package_Body then
+
+               if Nkind (Parent (P)) = N_Subunit then
+                  return Corresponding_Stub (Parent (P));
+               else
+                  return P;
+               end if;
+            end if;
+
+            P := True_Parent (P);
+         end loop;
+
+         return Empty;
+      end Enclosing_Body;
+
+      -------------------------
+      -- Package_Freeze_Node --
+      -------------------------
+
+      function Package_Freeze_Node (B : Node_Id) return Node_Id is
+         Id : Entity_Id;
+
+      begin
+         if Nkind (B) = N_Package_Body then
+            Id := Corresponding_Spec (B);
+
+         else pragma Assert (Nkind (B) = N_Package_Body_Stub);
+            Id := Corresponding_Spec (Proper_Body (Unit (Library_Unit (B))));
+         end if;
+
+         Ensure_Freeze_Node (Id);
+         return Freeze_Node (Id);
+      end Package_Freeze_Node;
+
+      -----------------
+      -- True_Parent --
+      -----------------
+
+      function True_Parent (N : Node_Id) return Node_Id is
+      begin
+         if Nkind (Parent (N)) = N_Subunit then
+            return Parent (Corresponding_Stub (Parent (N)));
+         else
+            return Parent (N);
+         end if;
+      end True_Parent;
+
+   --  Start of processing of Freeze_Subprogram_Body
+
+   begin
+      --  If the instance and the generic body appear within the same
+      --  unit, and the instance preceeds the generic, the freeze node for
+      --  the instance must appear after that of the generic. If the generic
+      --  is nested within another instance I2, then current instance must
+      --  be frozen after I2. In both cases, the freeze nodes are those of
+      --  enclosing packages. Otherwise, the freeze node is placed at the end
+      --  of the current declarative part.
+
+      Enc_G  := Enclosing_Body (Gen_Body);
+      Enc_I  := Enclosing_Body (Inst_Node);
+      Ensure_Freeze_Node (Pack_Id);
+      F_Node := Freeze_Node (Pack_Id);
+
+      if Is_Generic_Instance (Par)
+        and then Present (Freeze_Node (Par))
+        and then
+          In_Same_Declarative_Part (Freeze_Node (Par), Inst_Node)
+      then
+         Insert_After (Freeze_Node (Par), F_Node);
+
+      --  The body enclosing the instance should be frozen after the body
+      --  that includes the generic, because the body of the instance may
+      --  make references to entities therein. If the two are not in the
+      --  same declarative part, or if the one enclosing the instance is
+      --  frozen already, freeze the instance at the end of the current
+      --  declarative part.
+
+      elsif Is_Generic_Instance (Par)
+        and then Present (Freeze_Node (Par))
+        and then Present (Enc_I)
+      then
+         if In_Same_Declarative_Part (Freeze_Node (Par), Enc_I)
+           or else
+             (Nkind (Enc_I) = N_Package_Body
+               and then
+             In_Same_Declarative_Part (Freeze_Node (Par), Parent (Enc_I)))
+         then
+
+            --  The enclosing package may contain several instances. Rather
+            --  than computing the earliest point at which to insert its
+            --  freeze node, we place it at the end of the declarative part
+            --  of the parent of the generic.
+
+            Insert_After_Last_Decl
+              (Freeze_Node (Par), Package_Freeze_Node (Enc_I));
+         end if;
+
+         Insert_After_Last_Decl (Inst_Node, F_Node);
+
+      elsif Present (Enc_G)
+        and then Present (Enc_I)
+        and then Enc_G /= Enc_I
+        and then Earlier (Inst_Node, Gen_Body)
+      then
+         if Nkind (Enc_G) = N_Package_Body then
+            E_G_Id := Corresponding_Spec (Enc_G);
+         else pragma Assert (Nkind (Enc_G) = N_Package_Body_Stub);
+            E_G_Id :=
+              Corresponding_Spec (Proper_Body (Unit (Library_Unit (Enc_G))));
+         end if;
+
+         --  Freeze package that encloses instance, and place node after
+         --  package that encloses generic. If enclosing package is already
+         --  frozen we have to assume it is at the proper place. This may
+         --  be a potential ABE that requires dynamic checking.
+
+         Insert_After_Last_Decl (Enc_G, Package_Freeze_Node (Enc_I));
+
+         --  Freeze enclosing subunit before instance
+
+         Ensure_Freeze_Node (E_G_Id);
+
+         if not Is_List_Member (Freeze_Node (E_G_Id)) then
+            Insert_After (Enc_G, Freeze_Node (E_G_Id));
+         end if;
+
+         Insert_After_Last_Decl (Inst_Node, F_Node);
+
+      else
+
+         --  If none of the above, insert freeze node at the end of the
+         --  current declarative part.
+
+         Insert_After_Last_Decl (Inst_Node, F_Node);
+      end if;
+   end Freeze_Subprogram_Body;
+
+   ----------------
+   -- Get_Gen_Id --
+   ----------------
+
+   function Get_Gen_Id (E : Assoc_Ptr) return Entity_Id is
+   begin
+      return Generic_Renamings.Table (E).Gen_Id;
+   end Get_Gen_Id;
+
+   ---------------------
+   -- Get_Instance_Of --
+   ---------------------
+
+   function Get_Instance_Of (A : Entity_Id) return Entity_Id is
+      Res : Assoc_Ptr := Generic_Renamings_HTable.Get (A);
+   begin
+      if Res /= Assoc_Null then
+         return Generic_Renamings.Table (Res).Act_Id;
+      else
+         --  On exit, entity is not instantiated: not a generic parameter,
+         --  or else parameter of an inner generic unit.
+
+         return A;
+      end if;
+   end Get_Instance_Of;
+
+   ------------------------------------
+   -- Get_Package_Instantiation_Node --
+   ------------------------------------
+
+   function Get_Package_Instantiation_Node (A : Entity_Id) return Node_Id is
+      Decl : Node_Id := Unit_Declaration_Node (A);
+      Inst : Node_Id;
+
+   begin
+      --  If the instantiation is a compilation unit that does not need a
+      --  body then the instantiation node has been rewritten as a package
+      --  declaration for the instance, and we return the original node.
+      --  If it is a compilation unit and the instance node has not been
+      --  rewritten, then it is still the unit of the compilation.
+      --  Otherwise the instantiation node appears after the declaration.
+      --  If the entity is a formal package, the declaration may have been
+      --  rewritten as a generic declaration (in the case of a formal with a
+      --  box) or left as a formal package declaration if it has actuals, and
+      --  is found with a forward search.
+
+      if Nkind (Parent (Decl)) = N_Compilation_Unit then
+         if Nkind (Original_Node (Decl)) = N_Package_Instantiation then
+            return Original_Node (Decl);
+         else
+            return Unit (Parent (Decl));
+         end if;
+
+      elsif Nkind (Decl) = N_Generic_Package_Declaration
+        and then Nkind (Original_Node (Decl)) = N_Formal_Package_Declaration
+      then
+         return Original_Node (Decl);
+
+      else
+         Inst := Next (Decl);
+         while Nkind (Inst) /= N_Package_Instantiation
+           and then Nkind (Inst) /= N_Formal_Package_Declaration
+         loop
+            Next (Inst);
+         end loop;
+
+         return Inst;
+      end if;
+   end Get_Package_Instantiation_Node;
+
+   ------------------------
+   -- Has_Been_Exchanged --
+   ------------------------
+
+   function Has_Been_Exchanged (E : Entity_Id) return Boolean is
+      Next : Elmt_Id := First_Elmt (Exchanged_Views);
+
+   begin
+      while Present (Next) loop
+         if Full_View (Node (Next)) = E then
+            return True;
+         end if;
+
+         Next_Elmt (Next);
+      end loop;
+
+      return False;
+   end Has_Been_Exchanged;
+
+   ----------
+   -- Hash --
+   ----------
+
+   function Hash (F : Entity_Id) return HTable_Range is
+   begin
+      return HTable_Range (F mod HTable_Size);
+   end Hash;
+
+   ------------------------
+   -- Hide_Current_Scope --
+   ------------------------
+
+   procedure Hide_Current_Scope is
+      C : constant Entity_Id := Current_Scope;
+      E : Entity_Id;
+
+   begin
+      Set_Is_Hidden_Open_Scope (C);
+      E := First_Entity (C);
+
+      while Present (E) loop
+         if Is_Immediately_Visible (E) then
+            Set_Is_Immediately_Visible (E, False);
+            Append_Elmt (E, Hidden_Entities);
+         end if;
+
+         Next_Entity (E);
+      end loop;
+
+      --  Make the scope name invisible as well. This is necessary, but
+      --  might conflict with calls to Rtsfind later on, in case the scope
+      --  is a predefined one. There is no clean solution to this problem, so
+      --  for now we depend on the user not redefining Standard itself in one
+      --  of the parent units.
+
+      if Is_Immediately_Visible (C)
+        and then C /= Standard_Standard
+      then
+         Set_Is_Immediately_Visible (C, False);
+         Append_Elmt (C, Hidden_Entities);
+      end if;
+
+   end Hide_Current_Scope;
+
+   ------------------------------
+   -- In_Same_Declarative_Part --
+   ------------------------------
+
+   function In_Same_Declarative_Part
+     (F_Node : Node_Id;
+      Inst   : Node_Id)
+      return   Boolean
+   is
+      Decls : Node_Id := Parent (F_Node);
+      Nod   : Node_Id := Parent (Inst);
+
+   begin
+      while Present (Nod) loop
+         if Nod = Decls then
+            return True;
+
+         elsif Nkind (Nod) = N_Subprogram_Body
+           or else Nkind (Nod) = N_Package_Body
+           or else Nkind (Nod) = N_Task_Body
+           or else Nkind (Nod) = N_Protected_Body
+           or else Nkind (Nod) = N_Block_Statement
+         then
+            return False;
+
+         elsif Nkind (Nod) = N_Subunit then
+            Nod :=  Corresponding_Stub (Nod);
+
+         elsif Nkind (Nod) = N_Compilation_Unit then
+            return False;
+         else
+            Nod := Parent (Nod);
+         end if;
+      end loop;
+
+      return False;
+   end In_Same_Declarative_Part;
+
+   ---------------------
+   -- Inherit_Context --
+   ---------------------
+
+   procedure Inherit_Context (Gen_Decl : Node_Id; Inst : Node_Id) is
+      Current_Context : List_Id;
+      Current_Unit    : Node_Id;
+      Item            : Node_Id;
+      New_I           : Node_Id;
+
+   begin
+      if Nkind (Parent (Gen_Decl)) = N_Compilation_Unit then
+
+         --  The inherited context is attached to the enclosing compilation
+         --  unit. This is either the main unit, or the declaration for the
+         --  main unit (in case the instantation appears within the package
+         --  declaration and the main unit is its body).
+
+         Current_Unit := Parent (Inst);
+         while Present (Current_Unit)
+           and then Nkind (Current_Unit) /= N_Compilation_Unit
+         loop
+            Current_Unit := Parent (Current_Unit);
+         end loop;
+
+         Current_Context := Context_Items (Current_Unit);
+
+         Item := First (Context_Items (Parent (Gen_Decl)));
+         while Present (Item) loop
+            if Nkind (Item) = N_With_Clause then
+               New_I := New_Copy (Item);
+               Set_Implicit_With (New_I, True);
+               Append (New_I, Current_Context);
+            end if;
+
+            Next (Item);
+         end loop;
+      end if;
+   end Inherit_Context;
+
+   ----------------------------
+   -- Insert_After_Last_Decl --
+   ----------------------------
+
+   procedure Insert_After_Last_Decl (N : Node_Id; F_Node : Node_Id) is
+      L : List_Id := List_Containing (N);
+      P : Node_Id := Parent (L);
+
+   begin
+      if not Is_List_Member (F_Node) then
+         if Nkind (P) = N_Package_Specification
+           and then L = Visible_Declarations (P)
+           and then Present (Private_Declarations (P))
+           and then not Is_Empty_List (Private_Declarations (P))
+         then
+            L := Private_Declarations (P);
+         end if;
+
+         Insert_After (Last (L), F_Node);
+      end if;
+   end Insert_After_Last_Decl;
+
+   ------------------
+   -- Install_Body --
+   ------------------
+
+   procedure Install_Body
+     (Act_Body : Node_Id;
+      N        : Node_Id;
+      Gen_Body : Node_Id;
+      Gen_Decl : Node_Id)
+   is
+      Act_Id    : Entity_Id := Corresponding_Spec (Act_Body);
+      Act_Unit  : constant Node_Id :=
+                    Unit (Cunit (Get_Source_Unit (N)));
+      F_Node    : Node_Id;
+      Gen_Id    : Entity_Id := Corresponding_Spec (Gen_Body);
+      Gen_Unit  : constant Node_Id :=
+                    Unit (Cunit (Get_Source_Unit (Gen_Decl)));
+      Orig_Body : Node_Id := Gen_Body;
+      Par       : constant Entity_Id := Scope (Gen_Id);
+      Body_Unit : Node_Id;
+
+      Must_Delay : Boolean;
+
+      function Enclosing_Subp (Id : Entity_Id) return Entity_Id;
+      --  Find subprogram (if any) that encloses instance and/or generic body.
+
+      function True_Sloc (N : Node_Id) return Source_Ptr;
+      --  If the instance is nested inside a generic unit, the Sloc of the
+      --  instance indicates the place of the original definition, not the
+      --  point of the current enclosing instance. Pending a better usage of
+      --  Slocs to indicate instantiation places, we determine the place of
+      --  origin of a node by finding the maximum sloc of any ancestor node.
+      --  Why is this not equivalent fo Top_Level_Location ???
+
+      function Enclosing_Subp (Id : Entity_Id) return Entity_Id is
+         Scop : Entity_Id := Scope (Id);
+
+      begin
+         while Scop /= Standard_Standard
+           and then not Is_Overloadable (Scop)
+         loop
+            Scop := Scope (Scop);
+         end loop;
+
+         return Scop;
+      end Enclosing_Subp;
+
+      function True_Sloc (N : Node_Id) return Source_Ptr is
+         Res : Source_Ptr;
+         N1  : Node_Id;
+
+      begin
+         Res := Sloc (N);
+         N1 := N;
+         while Present (N1) and then N1 /= Act_Unit loop
+            if Sloc (N1) > Res then
+               Res := Sloc (N1);
+            end if;
+
+            N1 := Parent (N1);
+         end loop;
+
+         return Res;
+      end True_Sloc;
+
+   --  Start of processing for Install_Body
+
+   begin
+      --  If the body is a subunit, the freeze point is the corresponding
+      --  stub in the current compilation, not the subunit itself.
+
+      if Nkind (Parent (Gen_Body)) = N_Subunit then
+         Orig_Body :=  Corresponding_Stub (Parent (Gen_Body));
+      else
+         Orig_Body := Gen_Body;
+      end if;
+
+      Body_Unit := Unit (Cunit (Get_Source_Unit (Orig_Body)));
+
+      --  If the instantiation and the generic definition appear in the
+      --  same package declaration, this is an early instantiation.
+      --  If they appear in the same declarative part, it is an early
+      --  instantiation only if the generic body appears textually later,
+      --  and the generic body is also in the main unit.
+
+      --  If instance is nested within a subprogram, and the generic body is
+      --  not, the instance is delayed because the enclosing body is. If
+      --  instance and body are within the same scope, or the same sub-
+      --  program body, indicate explicitly that the instance is delayed.
+
+      Must_Delay :=
+        (Gen_Unit = Act_Unit
+          and then ((Nkind (Gen_Unit) = N_Package_Declaration)
+                      or else Nkind (Gen_Unit) = N_Generic_Package_Declaration
+                      or else (Gen_Unit = Body_Unit
+                                and then True_Sloc (N) < Sloc (Orig_Body)))
+          and then Is_In_Main_Unit (Gen_Unit)
+          and then (Scope (Act_Id) = Scope (Gen_Id)
+                      or else
+                    Enclosing_Subp (Act_Id) = Enclosing_Subp (Gen_Id)));
+
+      --  If this is an early instantiation, the freeze node is placed after
+      --  the generic body. Otherwise, if the generic appears in an instance,
+      --  we cannot freeze the current instance until the outer one is frozen.
+      --  This is only relevant if the current instance is nested within some
+      --  inner scope not itself within the outer instance. If this scope is
+      --  a package body in the same declarative part as the outer instance,
+      --  then that body needs to be frozen after the outer instance. Finally,
+      --  if no delay is needed, we place the freeze node at the end of the
+      --  current declarative part.
+
+      if Expander_Active then
+         Ensure_Freeze_Node (Act_Id);
+         F_Node := Freeze_Node (Act_Id);
+
+         if Must_Delay then
+            Insert_After (Orig_Body, F_Node);
+
+         elsif Is_Generic_Instance (Par)
+           and then Present (Freeze_Node (Par))
+           and then Scope (Act_Id) /= Par
+         then
+            --  Freeze instance of inner generic after instance of enclosing
+            --  generic.
+
+            if In_Same_Declarative_Part (Freeze_Node (Par), N) then
+               Insert_After (Freeze_Node (Par), F_Node);
+
+            --  Freeze package enclosing instance of inner generic after
+            --  instance of enclosing generic.
+
+            elsif Nkind (Parent (N)) = N_Package_Body
+              and then In_Same_Declarative_Part (Freeze_Node (Par), Parent (N))
+            then
+
+               declare
+                  Enclosing : Entity_Id := Corresponding_Spec (Parent (N));
+
+               begin
+                  Insert_After_Last_Decl (N, F_Node);
+                  Ensure_Freeze_Node (Enclosing);
+
+                  if not Is_List_Member (Freeze_Node (Enclosing)) then
+                     Insert_After (Freeze_Node (Par), Freeze_Node (Enclosing));
+                  end if;
+               end;
+
+            else
+               Insert_After_Last_Decl (N, F_Node);
+            end if;
+
+         else
+            Insert_After_Last_Decl (N, F_Node);
+         end if;
+      end if;
+
+      Set_Is_Frozen (Act_Id);
+      Insert_Before (N, Act_Body);
+      Mark_Rewrite_Insertion (Act_Body);
+   end Install_Body;
+
+   --------------------
+   -- Install_Parent --
+   --------------------
+
+   procedure Install_Parent (P : Entity_Id; In_Body : Boolean := False) is
+      S : Entity_Id := Current_Scope;
+      Inst_Par  : Entity_Id;
+      First_Par : Entity_Id;
+      Inst_Node : Node_Id;
+      Gen_Par   : Entity_Id;
+      First_Gen : Entity_Id;
+      Ancestors : Elist_Id := New_Elmt_List;
+      Elmt      : Elmt_Id;
+
+      procedure Install_Formal_Packages (Par : Entity_Id);
+      --  If any of the formals of the parent are formal packages with box,
+      --  their formal parts are visible in the parent and thus in the child
+      --  unit as well. Analogous to what is done in Check_Generic_Actuals
+      --  for the unit itself.
+
+      procedure Install_Noninstance_Specs (Par : Entity_Id);
+      --  Install the scopes of noninstance parent units ending with Par.
+
+      procedure Install_Spec (Par : Entity_Id);
+      --  The child unit is within the declarative part of the parent, so
+      --  the declarations within the parent are immediately visible.
+
+      -----------------------------
+      -- Install_Formal_Packages --
+      -----------------------------
+
+      procedure Install_Formal_Packages (Par : Entity_Id) is
+         E : Entity_Id;
+
+      begin
+         E := First_Entity (Par);
+
+         while Present (E) loop
+
+            if Ekind (E) = E_Package
+              and then Nkind (Parent (E)) = N_Package_Renaming_Declaration
+            then
+               --  If this is the renaming for the parent instance, done.
+
+               if Renamed_Object (E) = Par then
+                  exit;
+
+               --  The visibility of a formal of an enclosing generic is
+               --  already correct.
+
+               elsif Denotes_Formal_Package (E) then
+                  null;
+
+               elsif Present (Associated_Formal_Package (E))
+                 and then Box_Present (Parent (Associated_Formal_Package (E)))
+               then
+                  Check_Generic_Actuals (Renamed_Object (E), True);
+                  Set_Is_Hidden (E, False);
+               end if;
+            end if;
+
+            Next_Entity (E);
+         end loop;
+      end Install_Formal_Packages;
+
+      -------------------------------
+      -- Install_Noninstance_Specs --
+      -------------------------------
+
+      procedure Install_Noninstance_Specs (Par : Entity_Id) is
+      begin
+         if Present (Par)
+           and then Par /= Standard_Standard
+           and then not In_Open_Scopes (Par)
+         then
+            Install_Noninstance_Specs (Scope (Par));
+            Install_Spec (Par);
+         end if;
+      end Install_Noninstance_Specs;
+
+      ------------------
+      -- Install_Spec --
+      ------------------
+
+      procedure Install_Spec (Par : Entity_Id) is
+         Spec : constant Node_Id :=
+                  Specification (Unit_Declaration_Node (Par));
+
+      begin
+         New_Scope (Par);
+         Set_Is_Immediately_Visible   (Par);
+         Install_Visible_Declarations (Par);
+         Install_Private_Declarations (Par);
+         Set_Use (Visible_Declarations (Spec));
+         Set_Use (Private_Declarations (Spec));
+      end Install_Spec;
+
+   --  Start of processing for Install_Parent
+
+   begin
+      --  We need to install the parent instance to compile the instantiation
+      --  of the child, but the child instance must appear in the current
+      --  scope. Given that we cannot place the parent above the current
+      --  scope in the scope stack, we duplicate the current scope and unstack
+      --  both after the instantiation is complete.
+
+      --  If the parent is itself the instantiation of a child unit, we must
+      --  also stack the instantiation of its parent, and so on. Each such
+      --  ancestor is the prefix of the name in a prior instantiation.
+
+      --  If this is a nested instance, the parent unit itself resolves to
+      --  a renaming of the parent instance, whose declaration we need.
+
+      --  Finally, the parent may be a generic (not an instance) when the
+      --  child unit appears as a formal package.
+
+      Inst_Par := P;
+
+      if Present (Renamed_Entity (Inst_Par)) then
+         Inst_Par := Renamed_Entity (Inst_Par);
+      end if;
+
+      First_Par := Inst_Par;
+
+      Gen_Par :=
+        Generic_Parent (Specification (Unit_Declaration_Node (Inst_Par)));
+
+      First_Gen := Gen_Par;
+
+      while Present (Gen_Par)
+        and then Is_Child_Unit (Gen_Par)
+      loop
+         --  Load grandparent instance as well.
+
+         Inst_Node := Get_Package_Instantiation_Node (Inst_Par);
+
+         if Nkind (Name (Inst_Node)) = N_Expanded_Name then
+            Inst_Par := Entity (Prefix (Name (Inst_Node)));
+
+            if Present (Renamed_Entity (Inst_Par)) then
+               Inst_Par := Renamed_Entity (Inst_Par);
+            end if;
+
+            Gen_Par :=
+              Generic_Parent
+                (Specification (Unit_Declaration_Node (Inst_Par)));
+
+            if Present (Gen_Par) then
+               Prepend_Elmt (Inst_Par, Ancestors);
+
+            else
+               --  Parent is not the name of an instantiation.
+
+               Install_Noninstance_Specs (Inst_Par);
+
+               exit;
+            end if;
+
+         else
+            --  Previous error.
+
+            exit;
+         end if;
+      end loop;
+
+      if Present (First_Gen) then
+         Append_Elmt (First_Par, Ancestors);
+
+      else
+         Install_Noninstance_Specs (First_Par);
+      end if;
+
+      if not Is_Empty_Elmt_List (Ancestors) then
+         Elmt := First_Elmt (Ancestors);
+
+         while Present (Elmt) loop
+            Install_Spec (Node (Elmt));
+            Install_Formal_Packages (Node (Elmt));
+
+            Next_Elmt (Elmt);
+         end loop;
+      end if;
+
+      if not In_Body then
+         New_Scope (S);
+      end if;
+   end Install_Parent;
+
+   --------------------------------
+   -- Instantiate_Formal_Package --
+   --------------------------------
+
+   function Instantiate_Formal_Package
+     (Formal          : Node_Id;
+      Actual          : Node_Id;
+      Analyzed_Formal : Node_Id)
+      return            List_Id
+   is
+      Loc         : constant Source_Ptr := Sloc (Actual);
+      Actual_Pack : Entity_Id;
+      Formal_Pack : Entity_Id;
+      Gen_Parent  : Entity_Id;
+      Decls       : List_Id;
+      Nod         : Node_Id;
+      Parent_Spec : Node_Id;
+
+      function Formal_Entity
+        (F       : Node_Id;
+         Act_Ent : Entity_Id)
+         return    Entity_Id;
+      --  Returns the entity associated with the given formal F. In the
+      --  case where F is a formal package, this function will iterate
+      --  through all of F's formals and enter map associations from the
+      --  actuals occurring in the formal package's corresponding actual
+      --  package (obtained via Act_Ent) to the formal package's formal
+      --  parameters. This function is called recursively for arbitrary
+      --  levels of formal packages.
+
+      procedure Map_Entities (Form : Entity_Id; Act : Entity_Id);
+      --  Within the generic part, entities in the formal package are
+      --  visible. To validate subsequent type declarations, indicate
+      --  the correspondence betwen the entities in the analyzed formal,
+      --  and the entities in  the actual package. There are three packages
+      --  involved in the instantiation of a formal package: the parent
+      --  generic P1 which appears in the generic declaration, the fake
+      --  instantiation P2 which appears in the analyzed generic, and whose
+      --  visible entities may be used in subsequent formals, and the actual
+      --  P3 in the instance. To validate subsequent formals, me indicate
+      --  that the entities in P2 are mapped into those of P3. The mapping of
+      --  entities has to be done recursively for nested packages.
+
+      -------------------
+      -- Formal_Entity --
+      -------------------
+
+      function Formal_Entity
+        (F       : Node_Id;
+         Act_Ent : Entity_Id)
+         return    Entity_Id
+      is
+         Orig_Node : Node_Id := F;
+
+      begin
+         case Nkind (F) is
+            when N_Formal_Object_Declaration =>
+               return Defining_Identifier (F);
+
+            when N_Formal_Type_Declaration =>
+               return Defining_Identifier (F);
+
+            when N_Formal_Subprogram_Declaration =>
+               return Defining_Unit_Name (Specification (F));
+
+            when N_Formal_Package_Declaration |
+                 N_Generic_Package_Declaration =>
+
+               if Nkind (F) = N_Generic_Package_Declaration then
+                  Orig_Node := Original_Node (F);
+               end if;
+
+               declare
+                  Actual_Ent  : Entity_Id := First_Entity (Act_Ent);
+                  Formal_Node : Node_Id;
+                  Formal_Ent  : Entity_Id;
+
+                  Gen_Decl : Node_Id :=
+                               Unit_Declaration_Node
+                                 (Entity (Name (Orig_Node)));
+                  Formals  : List_Id :=
+                               Generic_Formal_Declarations (Gen_Decl);
+
+               begin
+                  if Present (Formals) then
+                     Formal_Node := First_Non_Pragma (Formals);
+                  else
+                     Formal_Node := Empty;
+                  end if;
+
+                  --  As for the loop further below, this loop is making
+                  --  a probably invalid assumption about the correspondence
+                  --  between formals and actuals and eventually needs to
+                  --  corrected to account for cases where the formals are
+                  --  not synchronized and in one-to-one correspondence
+                  --  with actuals. ???
+
+                  --  What is certain is that for a legal program the
+                  --  presence of actual entities guarantees the existing
+                  --  of formal ones.
+
+                  while Present (Actual_Ent)
+                    and then Present (Formal_Node)
+                    and then Actual_Ent /= First_Private_Entity (Act_Ent)
+                  loop
+                     --  ???  Are the following calls also needed here:
+                     --
+                     --  Set_Is_Hidden (Actual_Ent, False);
+                     --  Set_Is_Potentially_Use_Visible
+                     --    (Actual_Ent, In_Use (Act_Ent));
+
+                     Formal_Ent := Formal_Entity (Formal_Node, Actual_Ent);
+                     if Present (Formal_Ent) then
+                        Set_Instance_Of (Formal_Ent, Actual_Ent);
+                     end if;
+                     Next_Non_Pragma (Formal_Node);
+
+                     Next_Entity (Actual_Ent);
+                  end loop;
+               end;
+
+               return Defining_Identifier (Orig_Node);
+
+            when N_Use_Package_Clause =>
+               return Empty;
+
+            when N_Use_Type_Clause =>
+               return Empty;
+
+            --  We return Empty for all other encountered forms of
+            --  declarations because there are some cases of nonformal
+            --  sorts of declaration that can show up (e.g., when array
+            --  formals are present). Since it's not clear what kinds
+            --  can appear among the formals, we won't raise failure here.
+
+            when others =>
+               return Empty;
+
+         end case;
+      end Formal_Entity;
+
+      ------------------
+      -- Map_Entities --
+      ------------------
+
+      procedure Map_Entities (Form : Entity_Id; Act : Entity_Id) is
+         E1 : Entity_Id;
+         E2 : Entity_Id;
+
+      begin
+         Set_Instance_Of (Form, Act);
+
+         E1 := First_Entity (Form);
+         E2 := First_Entity (Act);
+         while Present (E1)
+           and then E1 /= First_Private_Entity (Form)
+         loop
+            if not Is_Internal (E1)
+              and then not Is_Class_Wide_Type (E1)
+            then
+
+               while Present (E2)
+                 and then Chars (E2) /= Chars (E1)
+               loop
+                  Next_Entity (E2);
+               end loop;
+
+               if No (E2) then
+                  exit;
+               else
+                  Set_Instance_Of (E1, E2);
+
+                  if Is_Type (E1)
+                    and then Is_Tagged_Type (E2)
+                  then
+                     Set_Instance_Of
+                       (Class_Wide_Type (E1), Class_Wide_Type (E2));
+                  end if;
+
+                  if Ekind (E1) = E_Package
+                    and then No (Renamed_Object (E1))
+                  then
+                     Map_Entities (E1, E2);
+                  end if;
+               end if;
+            end if;
+
+            Next_Entity (E1);
+         end loop;
+      end Map_Entities;
+
+   --  Start of processing for Instantiate_Formal_Package
+
+   begin
+      Analyze (Actual);
+
+      if not Is_Entity_Name (Actual)
+        or else  Ekind (Entity (Actual)) /= E_Package
+      then
+         Error_Msg_N
+           ("expect package instance to instantiate formal", Actual);
+         Abandon_Instantiation (Actual);
+         raise Program_Error;
+
+      else
+         Actual_Pack := Entity (Actual);
+         Set_Is_Instantiated (Actual_Pack);
+
+         --  The actual may be a renamed package, or an outer generic
+         --  formal package whose instantiation is converted into a renaming.
+
+         if Present (Renamed_Object (Actual_Pack)) then
+            Actual_Pack := Renamed_Object (Actual_Pack);
+         end if;
+
+         if Nkind (Analyzed_Formal) = N_Formal_Package_Declaration then
+            Gen_Parent  := Get_Instance_Of (Entity (Name (Analyzed_Formal)));
+            Formal_Pack := Defining_Identifier (Analyzed_Formal);
+         else
+            Gen_Parent :=
+              Generic_Parent (Specification (Analyzed_Formal));
+            Formal_Pack :=
+              Defining_Unit_Name (Specification (Analyzed_Formal));
+         end if;
+
+         if Nkind (Parent (Actual_Pack)) = N_Defining_Program_Unit_Name then
+            Parent_Spec := Specification (Unit_Declaration_Node (Actual_Pack));
+         else
+            Parent_Spec := Parent (Actual_Pack);
+         end if;
+
+         if Gen_Parent = Any_Id then
+            Error_Msg_N
+              ("previous error in declaration of formal package", Actual);
+            Abandon_Instantiation (Actual);
+
+         elsif
+           Generic_Parent (Parent_Spec) /= Get_Instance_Of (Gen_Parent)
+         then
+            Error_Msg_NE
+              ("actual parameter must be instance of&", Actual, Gen_Parent);
+            Abandon_Instantiation (Actual);
+         end if;
+
+         Set_Instance_Of (Defining_Identifier (Formal), Actual_Pack);
+         Map_Entities (Formal_Pack, Actual_Pack);
+
+         Nod :=
+           Make_Package_Renaming_Declaration (Loc,
+             Defining_Unit_Name => New_Copy (Defining_Identifier (Formal)),
+             Name               => New_Reference_To (Actual_Pack, Loc));
+
+         Set_Associated_Formal_Package (Defining_Unit_Name (Nod),
+           Defining_Identifier (Formal));
+         Decls := New_List (Nod);
+
+         --  If the formal F has a box, then the generic declarations are
+         --  visible in the generic G. In an instance of G, the corresponding
+         --  entities in the actual for F (which are the actuals for the
+         --  instantiation of the generic that F denotes) must also be made
+         --  visible for analysis of the current instance. On exit from the
+         --  current instance, those entities are made private again. If the
+         --  actual is currently in use, these entities are also use-visible.
+
+         --  The loop through the actual entities also steps through the
+         --  formal entities and enters associations from formals to
+         --  actuals into the renaming map. This is necessary to properly
+         --  handle checking of actual parameter associations for later
+         --  formals that depend on actuals declared in the formal package.
+         --
+         --  This processing needs to be reviewed at some point because
+         --  it is probably not entirely correct as written. For example
+         --  there may not be a strict one-to-one correspondence between
+         --  actuals and formals and this loop is currently assuming that
+         --  there is. ???
+
+         if Box_Present (Formal) then
+            declare
+               Actual_Ent  : Entity_Id := First_Entity (Actual_Pack);
+               Formal_Node : Node_Id := Empty;
+               Formal_Ent  : Entity_Id;
+               Gen_Decl    : Node_Id := Unit_Declaration_Node (Gen_Parent);
+               Formals     : List_Id := Generic_Formal_Declarations (Gen_Decl);
+
+            begin
+               if Present (Formals) then
+                  Formal_Node := First_Non_Pragma (Formals);
+               end if;
+
+               while Present (Actual_Ent)
+                 and then Actual_Ent /= First_Private_Entity (Actual_Pack)
+               loop
+                  Set_Is_Hidden (Actual_Ent, False);
+                  Set_Is_Potentially_Use_Visible
+                    (Actual_Ent, In_Use (Actual_Pack));
+
+                  if Present (Formal_Node) then
+                     Formal_Ent := Formal_Entity (Formal_Node, Actual_Ent);
+
+                     if Present (Formal_Ent) then
+                        Set_Instance_Of (Formal_Ent, Actual_Ent);
+                     end if;
+
+                     Next_Non_Pragma (Formal_Node);
+                  end if;
+
+                  Next_Entity (Actual_Ent);
+               end loop;
+            end;
+
+         --  If the formal is not declared with a box, reanalyze it as
+         --  an instantiation, to verify the matching rules of 12.7. The
+         --  actual checks are performed after the generic associations
+         --  been analyzed.
+
+         else
+            declare
+               I_Pack : constant Entity_Id :=
+                          Make_Defining_Identifier (Sloc (Actual),
+                            Chars => New_Internal_Name  ('P'));
+
+            begin
+               Set_Is_Internal (I_Pack);
+
+               Append_To (Decls,
+                 Make_Package_Instantiation (Sloc (Actual),
+                   Defining_Unit_Name => I_Pack,
+                   Name => New_Occurrence_Of (Gen_Parent, Sloc (Actual)),
+                   Generic_Associations =>
+                     Generic_Associations (Formal)));
+            end;
+         end if;
+
+         return Decls;
+      end if;
+
+   end Instantiate_Formal_Package;
+
+   -----------------------------------
+   -- Instantiate_Formal_Subprogram --
+   -----------------------------------
+
+   function Instantiate_Formal_Subprogram
+     (Formal          : Node_Id;
+      Actual          : Node_Id;
+      Analyzed_Formal : Node_Id)
+      return Node_Id
+   is
+      Loc        : Source_Ptr := Sloc (Instantiation_Node);
+      Formal_Sub : constant Entity_Id :=
+                     Defining_Unit_Name (Specification (Formal));
+      Analyzed_S : constant Entity_Id :=
+                     Defining_Unit_Name (Specification (Analyzed_Formal));
+      Decl_Node  : Node_Id;
+      Nam        : Node_Id;
+      New_Spec   : Node_Id;
+
+      function From_Parent_Scope (Subp : Entity_Id) return Boolean;
+      --  If the generic is a child unit, the parent has been installed
+      --  on the scope stack, but a default subprogram cannot resolve to
+      --  something on the parent because that parent is not really part
+      --  of the visible context (it is there to resolve explicit local
+      --  entities). If the default has resolved in this way, we remove
+      --  the entity from immediate visibility and analyze the node again
+      --  to emit an error message or find another visible candidate.
+
+      procedure Valid_Actual_Subprogram (Act : Node_Id);
+      --  Perform legality check and raise exception on failure.
+
+      -----------------------
+      -- From_Parent_Scope --
+      -----------------------
+
+      function From_Parent_Scope (Subp : Entity_Id) return Boolean is
+         Gen_Scope : Node_Id := Scope (Analyzed_S);
+
+      begin
+         while Present (Gen_Scope)
+           and then  Is_Child_Unit (Gen_Scope)
+         loop
+            if Scope (Subp) = Scope (Gen_Scope) then
+               return True;
+            end if;
+
+            Gen_Scope := Scope (Gen_Scope);
+         end loop;
+
+         return False;
+      end From_Parent_Scope;
+
+      -----------------------------
+      -- Valid_Actual_Subprogram --
+      -----------------------------
+
+      procedure Valid_Actual_Subprogram (Act : Node_Id) is
+      begin
+         if not Is_Entity_Name (Act)
+           and then Nkind (Act) /= N_Operator_Symbol
+           and then Nkind (Act) /= N_Attribute_Reference
+           and then Nkind (Act) /= N_Selected_Component
+           and then Nkind (Act) /= N_Indexed_Component
+           and then Nkind (Act) /= N_Character_Literal
+           and then Nkind (Act) /= N_Explicit_Dereference
+         then
+            if Etype (Act) /= Any_Type then
+               Error_Msg_NE
+                 ("Expect subprogram name to instantiate &",
+                  Instantiation_Node, Formal_Sub);
+            end if;
+
+            --  In any case, instantiation cannot continue.
+
+            Abandon_Instantiation (Instantiation_Node);
+         end if;
+      end Valid_Actual_Subprogram;
+
+   --  Start of processing for Instantiate_Formal_Subprogram
+
+   begin
+      New_Spec := New_Copy_Tree (Specification (Formal));
+
+      --  Create new entity for the actual (New_Copy_Tree does not).
+
+      Set_Defining_Unit_Name
+        (New_Spec, Make_Defining_Identifier (Loc, Chars (Formal_Sub)));
+
+      --  Find entity of actual. If the actual is an attribute reference, it
+      --  cannot be resolved here (its formal is missing) but is handled
+      --  instead in Attribute_Renaming. If the actual is overloaded, it is
+      --  fully resolved subsequently, when the renaming declaration for the
+      --  formal is analyzed. If it is an explicit dereference, resolve the
+      --  prefix but not the actual itself, to prevent interpretation as a
+      --  call.
+
+      if Present (Actual) then
+         Loc := Sloc (Actual);
+         Set_Sloc (New_Spec, Loc);
+
+         if Nkind (Actual) = N_Operator_Symbol then
+            Find_Direct_Name (Actual);
+
+         elsif Nkind (Actual) = N_Explicit_Dereference then
+            Analyze (Prefix (Actual));
+
+         elsif Nkind (Actual) /= N_Attribute_Reference then
+            Analyze (Actual);
+         end if;
+
+         Valid_Actual_Subprogram (Actual);
+         Nam := Actual;
+
+      elsif Present (Default_Name (Formal)) then
+
+         if Nkind (Default_Name (Formal)) /= N_Attribute_Reference
+           and then Nkind (Default_Name (Formal)) /= N_Selected_Component
+           and then Nkind (Default_Name (Formal)) /= N_Indexed_Component
+           and then Nkind (Default_Name (Formal)) /= N_Character_Literal
+           and then Present (Entity (Default_Name (Formal)))
+         then
+            Nam := New_Occurrence_Of (Entity (Default_Name (Formal)), Loc);
+         else
+            Nam := New_Copy (Default_Name (Formal));
+            Set_Sloc (Nam, Loc);
+         end if;
+
+      elsif Box_Present (Formal) then
+
+         --  Actual is resolved at the point of instantiation. Create
+         --  an identifier or operator with the same name as the formal.
+
+         if Nkind (Formal_Sub) = N_Defining_Operator_Symbol then
+            Nam := Make_Operator_Symbol (Loc,
+              Chars =>  Chars (Formal_Sub),
+              Strval => No_String);
+         else
+            Nam := Make_Identifier (Loc, Chars (Formal_Sub));
+         end if;
+
+      else
+         Error_Msg_NE
+           ("missing actual for instantiation of &",
+                                 Instantiation_Node, Formal_Sub);
+         Abandon_Instantiation (Instantiation_Node);
+      end if;
+
+      Decl_Node :=
+        Make_Subprogram_Renaming_Declaration (Loc,
+          Specification => New_Spec,
+          Name => Nam);
+
+      --  Gather possible interpretations for the actual before analyzing the
+      --  instance. If overloaded, it will be resolved when analyzing the
+      --  renaming declaration.
+
+      if Box_Present (Formal)
+        and then No (Actual)
+      then
+         Analyze (Nam);
+
+         if Is_Child_Unit (Scope (Analyzed_S))
+           and then Present (Entity (Nam))
+         then
+            if not Is_Overloaded (Nam) then
+
+               if From_Parent_Scope (Entity (Nam)) then
+                  Set_Is_Immediately_Visible (Entity (Nam), False);
+                  Set_Entity (Nam, Empty);
+                  Set_Etype (Nam, Empty);
+
+                  Analyze (Nam);
+
+                  Set_Is_Immediately_Visible (Entity (Nam));
+               end if;
+
+            else
+               declare
+                  I  : Interp_Index;
+                  It : Interp;
+
+               begin
+                  Get_First_Interp (Nam, I, It);
+
+                  while Present (It.Nam) loop
+                     if From_Parent_Scope (It.Nam) then
+                        Remove_Interp (I);
+                     end if;
+
+                     Get_Next_Interp (I, It);
+                  end loop;
+               end;
+            end if;
+         end if;
+      end if;
+
+      --  The generic instantiation freezes the actual. This can only be
+      --  done once the actual is resolved, in the analysis of the renaming
+      --  declaration. To indicate that must be done, we set the corresponding
+      --  spec of the node to point to the formal subprogram declaration.
+
+      Set_Corresponding_Spec (Decl_Node, Analyzed_Formal);
+
+      --  We cannot analyze the renaming declaration, and thus find the
+      --  actual, until the all the actuals are assembled in the instance.
+      --  For subsequent checks of other actuals, indicate the node that
+      --  will hold the instance of this formal.
+
+      Set_Instance_Of (Analyzed_S, Nam);
+
+      if Nkind (Actual) = N_Selected_Component
+        and then Is_Task_Type (Etype (Prefix (Actual)))
+        and then not Is_Frozen (Etype (Prefix (Actual)))
+      then
+         --  The renaming declaration will create a body, which must appear
+         --  outside of the instantiation, We move the renaming declaration
+         --  out of the instance, and create an additional renaming inside,
+         --  to prevent freezing anomalies.
+
+         declare
+            Anon_Id : constant Entity_Id :=
+                        Make_Defining_Identifier
+                          (Loc, New_Internal_Name ('E'));
+         begin
+            Set_Defining_Unit_Name (New_Spec, Anon_Id);
+            Insert_Before (Instantiation_Node, Decl_Node);
+            Analyze (Decl_Node);
+
+            --  Now create renaming within the instance.
+
+            Decl_Node :=
+              Make_Subprogram_Renaming_Declaration (Loc,
+                Specification => New_Copy_Tree (New_Spec),
+                Name => New_Occurrence_Of (Anon_Id, Loc));
+
+            Set_Defining_Unit_Name (Specification (Decl_Node),
+              Make_Defining_Identifier (Loc, Chars (Formal_Sub)));
+         end;
+      end if;
+
+      return Decl_Node;
+   end Instantiate_Formal_Subprogram;
+
+   ------------------------
+   -- Instantiate_Object --
+   ------------------------
+
+   function Instantiate_Object
+     (Formal          : Node_Id;
+      Actual          : Node_Id;
+      Analyzed_Formal : Node_Id)
+      return            List_Id
+   is
+      Formal_Id : constant Entity_Id  := Defining_Identifier (Formal);
+      Type_Id   : constant Node_Id    := Subtype_Mark (Formal);
+      Loc       : constant Source_Ptr := Sloc (Actual);
+      Act_Assoc : constant Node_Id    := Parent (Actual);
+      Orig_Ftyp : constant Entity_Id  :=
+                    Etype (Defining_Identifier (Analyzed_Formal));
+      Ftyp      : Entity_Id;
+      Decl_Node : Node_Id;
+      Subt_Decl : Node_Id := Empty;
+      List      : List_Id := New_List;
+
+   begin
+      if Get_Instance_Of (Formal_Id) /= Formal_Id then
+         Error_Msg_N ("duplicate instantiation of generic parameter", Actual);
+      end if;
+
+      Set_Parent (List, Parent (Actual));
+
+      --  OUT present
+
+      if Out_Present (Formal) then
+
+         --  An IN OUT generic actual must be a name. The instantiation is
+         --  a renaming declaration. The actual is the name being renamed.
+         --  We use the actual directly, rather than a copy, because it is not
+         --  used further in the list of actuals, and because a copy or a use
+         --  of relocate_node is incorrect if the instance is nested within
+         --  a generic. In order to simplify ASIS searches, the Generic_Parent
+         --  field links the declaration to the generic association.
+
+         if No (Actual) then
+            Error_Msg_NE
+              ("missing actual for instantiation of &",
+               Instantiation_Node, Formal_Id);
+            Abandon_Instantiation (Instantiation_Node);
+         end if;
+
+         Decl_Node :=
+           Make_Object_Renaming_Declaration (Loc,
+             Defining_Identifier => New_Copy (Formal_Id),
+             Subtype_Mark        => New_Copy_Tree (Type_Id),
+             Name                => Actual);
+
+         Set_Corresponding_Generic_Association (Decl_Node, Act_Assoc);
+
+         --  The analysis of the actual may produce insert_action nodes, so
+         --  the declaration must have a context in which to attach them.
+
+         Append (Decl_Node, List);
+         Analyze (Actual);
+
+         --  This check is performed here because Analyze_Object_Renaming
+         --  will not check it when Comes_From_Source is False. Note
+         --  though that the check for the actual being the name of an
+         --  object will be performed in Analyze_Object_Renaming.
+
+         if Is_Object_Reference (Actual)
+           and then Is_Dependent_Component_Of_Mutable_Object (Actual)
+         then
+            Error_Msg_N
+              ("illegal discriminant-dependent component for in out parameter",
+               Actual);
+         end if;
+
+         --  The actual has to be resolved in order to check that it is
+         --  a variable (due to cases such as F(1), where F returns
+         --  access to an array, and for overloaded prefixes).
+
+         Ftyp :=
+           Get_Instance_Of (Etype (Defining_Identifier (Analyzed_Formal)));
+
+         if Is_Private_Type (Ftyp)
+           and then not Is_Private_Type (Etype (Actual))
+           and then (Base_Type (Full_View (Ftyp)) = Base_Type (Etype (Actual))
+                      or else Base_Type (Etype (Actual)) = Ftyp)
+         then
+            --  If the actual has the type of the full view of the formal,
+            --  or else a non-private subtype of the formal, then
+            --  the visibility of the formal type has changed. Add to the
+            --  actuals a subtype declaration that will force the exchange
+            --  of views in the body of the instance as well.
+
+            Subt_Decl :=
+              Make_Subtype_Declaration (Loc,
+                 Defining_Identifier =>
+                   Make_Defining_Identifier (Loc, New_Internal_Name ('P')),
+                 Subtype_Indication  => New_Occurrence_Of (Ftyp, Loc));
+
+            Prepend (Subt_Decl, List);
+
+            Append_Elmt (Full_View (Ftyp), Exchanged_Views);
+            Exchange_Declarations (Ftyp);
+         end if;
+
+         Resolve (Actual, Ftyp);
+
+         if not Is_Variable (Actual) or else Paren_Count (Actual) > 0 then
+            Error_Msg_NE
+              ("actual for& must be a variable", Actual, Formal_Id);
+
+         elsif Base_Type (Ftyp) /= Base_Type (Etype (Actual)) then
+            Error_Msg_NE (
+              "type of actual does not match type of&", Actual, Formal_Id);
+
+         end if;
+
+         Note_Possible_Modification (Actual);
+
+         --  Check for instantiation of atomic/volatile actual for
+         --  non-atomic/volatile formal (RM C.6 (12)).
+
+         if Is_Atomic_Object (Actual)
+           and then not Is_Atomic (Orig_Ftyp)
+         then
+            Error_Msg_N
+              ("cannot instantiate non-atomic formal object " &
+               "with atomic actual", Actual);
+
+         elsif Is_Volatile_Object (Actual)
+           and then not Is_Volatile (Orig_Ftyp)
+         then
+            Error_Msg_N
+              ("cannot instantiate non-volatile formal object " &
+               "with volatile actual", Actual);
+         end if;
+
+      --  OUT not present
+
+      else
+         --  The instantiation of a generic formal in-parameter
+         --  is a constant declaration. The actual is the expression for
+         --  that declaration.
+
+         if Present (Actual) then
+
+            Decl_Node := Make_Object_Declaration (Loc,
+              Defining_Identifier => New_Copy (Formal_Id),
+              Constant_Present => True,
+              Object_Definition => New_Copy_Tree (Type_Id),
+              Expression => Actual);
+
+            Set_Corresponding_Generic_Association (Decl_Node, Act_Assoc);
+
+            --  A generic formal object of a tagged type is defined
+            --  to be aliased so the new constant must also be treated
+            --  as aliased.
+
+            if Is_Tagged_Type
+                 (Etype (Defining_Identifier (Analyzed_Formal)))
+            then
+               Set_Aliased_Present (Decl_Node);
+            end if;
+
+            Append (Decl_Node, List);
+            Analyze (Actual);
+
+            declare
+               Typ : Entity_Id
+                      := Get_Instance_Of
+                           (Etype (Defining_Identifier (Analyzed_Formal)));
+            begin
+               Freeze_Before (Instantiation_Node, Typ);
+
+               --  If the actual is an aggregate, perform name resolution
+               --  on its components (the analysis of an aggregate does not
+               --  do it) to capture local names that may be hidden if the
+               --  generic is a child unit.
+
+               if Nkind (Actual) = N_Aggregate then
+                     Pre_Analyze_And_Resolve (Actual, Typ);
+               end if;
+            end;
+
+         elsif Present (Expression (Formal)) then
+
+            --  Use default to construct declaration.
+
+            Decl_Node :=
+              Make_Object_Declaration (Sloc (Formal),
+                Defining_Identifier => New_Copy (Formal_Id),
+                Constant_Present    => True,
+                Object_Definition   => New_Copy (Type_Id),
+                Expression          => New_Copy_Tree (Expression (Formal)));
+
+            Append (Decl_Node, List);
+            Set_Analyzed (Expression (Decl_Node), False);
+
+         else
+            Error_Msg_NE
+              ("missing actual for instantiation of &",
+               Instantiation_Node, Formal_Id);
+            Abandon_Instantiation (Instantiation_Node);
+         end if;
+
+      end if;
+
+      return List;
+   end Instantiate_Object;
+
+   ------------------------------
+   -- Instantiate_Package_Body --
+   ------------------------------
+
+   procedure Instantiate_Package_Body
+     (Body_Info : Pending_Body_Info)
+   is
+      Act_Decl    : constant Node_Id    := Body_Info.Act_Decl;
+      Inst_Node   : constant Node_Id    := Body_Info.Inst_Node;
+      Loc         : constant Source_Ptr := Sloc (Inst_Node);
+
+      Gen_Id      : constant Node_Id    := Name (Inst_Node);
+      Gen_Unit    : constant Entity_Id  := Entity (Name (Inst_Node));
+      Gen_Decl    : constant Node_Id    := Unit_Declaration_Node (Gen_Unit);
+      Act_Spec    : constant Node_Id    := Specification (Act_Decl);
+      Act_Decl_Id : constant Entity_Id  := Defining_Entity (Act_Spec);
+
+      Act_Body_Name : Node_Id;
+      Gen_Body      : Node_Id;
+      Gen_Body_Id   : Node_Id;
+      Act_Body      : Node_Id;
+      Act_Body_Id   : Entity_Id;
+
+      Parent_Installed : Boolean := False;
+      Save_Style_Check : Boolean := Style_Check;
+
+   begin
+      Gen_Body_Id := Corresponding_Body (Gen_Decl);
+      Expander_Mode_Save_And_Set (Body_Info.Expander_Status);
+
+      if No (Gen_Body_Id) then
+         Load_Parent_Of_Generic (Inst_Node, Specification (Gen_Decl));
+         Gen_Body_Id := Corresponding_Body (Gen_Decl);
+      end if;
+
+      --  Establish global variable for sloc adjustment and for error
+      --  recovery.
+
+      Instantiation_Node := Inst_Node;
+
+      if Present (Gen_Body_Id) then
+         Save_Env (Gen_Unit, Act_Decl_Id);
+         Style_Check := False;
+         Current_Sem_Unit := Body_Info.Current_Sem_Unit;
+
+         Gen_Body := Unit_Declaration_Node (Gen_Body_Id);
+
+         Create_Instantiation_Source
+          (Inst_Node, Gen_Body_Id, S_Adjustment);
+
+         Act_Body :=
+           Copy_Generic_Node
+             (Original_Node (Gen_Body), Empty, Instantiating => True);
+
+         --  Build new name (possibly qualified) for body declaration.
+
+         Act_Body_Id := New_Copy (Act_Decl_Id);
+
+         --  Some attributes of the spec entity are not inherited by the
+         --  body entity.
+
+         Set_Handler_Records (Act_Body_Id, No_List);
+
+         if Nkind (Defining_Unit_Name (Act_Spec)) =
+                                           N_Defining_Program_Unit_Name
+         then
+            Act_Body_Name :=
+              Make_Defining_Program_Unit_Name (Loc,
+                Name => New_Copy_Tree (Name (Defining_Unit_Name (Act_Spec))),
+                Defining_Identifier => Act_Body_Id);
+         else
+            Act_Body_Name :=  Act_Body_Id;
+         end if;
+
+         Set_Defining_Unit_Name (Act_Body, Act_Body_Name);
+
+         Set_Corresponding_Spec (Act_Body, Act_Decl_Id);
+         Check_Generic_Actuals (Act_Decl_Id, False);
+
+         --  If it is a child unit, make the parent instance (which is an
+         --  instance of the parent of the generic) visible. The parent
+         --  instance is the prefix of the name of the generic unit.
+
+         if Ekind (Scope (Gen_Unit)) = E_Generic_Package
+           and then Nkind (Gen_Id) = N_Expanded_Name
+         then
+            Install_Parent (Entity (Prefix (Gen_Id)), In_Body => True);
+            Parent_Installed := True;
+
+         elsif Is_Child_Unit (Gen_Unit) then
+            Install_Parent (Scope (Gen_Unit), In_Body => True);
+            Parent_Installed := True;
+         end if;
+
+         --  If the instantiation is a library unit, and this is the main
+         --  unit, then build the resulting compilation unit nodes for the
+         --  instance. If this is a compilation unit but it is not the main
+         --  unit, then it is the body of a unit in the context, that is being
+         --  compiled because it is encloses some inlined unit or another
+         --  generic unit being instantiated. In that case, this body is not
+         --  part of the current compilation, and is not attached to the tree,
+         --  but its parent must be set for analysis.
+
+         if Nkind (Parent (Inst_Node)) = N_Compilation_Unit then
+
+            if Parent (Inst_Node) = Cunit (Main_Unit) then
+               Build_Instance_Compilation_Unit_Nodes
+                 (Inst_Node, Act_Body, Act_Decl);
+               Analyze (Inst_Node);
+
+               --  If the instance is a child unit itself, then set the
+               --  scope of the expanded body to be the parent of the
+               --  instantiation (ensuring that the fully qualified name
+               --  will be generated for the elaboration subprogram).
+
+               if Nkind (Defining_Unit_Name (Act_Spec)) =
+                                              N_Defining_Program_Unit_Name
+               then
+                  Set_Scope
+                    (Defining_Entity (Inst_Node), Scope (Act_Decl_Id));
+               end if;
+
+            else
+               Set_Parent (Act_Body, Parent (Inst_Node));
+               Analyze (Act_Body);
+            end if;
+
+         --  Case where instantiation is not a library unit
+
+         else
+            --  If this is an early instantiation, i.e. appears textually
+            --  before the corresponding body and must be elaborated first,
+            --  indicate that the body instance is to be delayed.
+
+            Install_Body (Act_Body, Inst_Node, Gen_Body, Gen_Decl);
+
+            --  Now analyze the body. We turn off all checks if this is
+            --  an internal unit, since there is no reason to have checks
+            --  on for any predefined run-time library code. All such
+            --  code is designed to be compiled with checks off.
+
+            --  Note that we do NOT apply this criterion to children of
+            --  GNAT (or on VMS, children of DEC). The latter units must
+            --  suppress checks explicitly if this is needed.
+
+            if Is_Predefined_File_Name
+                 (Unit_File_Name (Get_Source_Unit (Gen_Decl)))
+            then
+               Analyze (Act_Body, Suppress => All_Checks);
+            else
+               Analyze (Act_Body);
+            end if;
+         end if;
+
+         if not Generic_Separately_Compiled (Gen_Unit) then
+            Inherit_Context (Gen_Body, Inst_Node);
+         end if;
+
+         Restore_Private_Views (Act_Decl_Id);
+         Restore_Env;
+         Style_Check := Save_Style_Check;
+
+      --  If we have no body, and the unit requires a body, then complain.
+      --  This complaint is suppressed if we have detected other errors
+      --  (since a common reason for missing the body is that it had errors).
+
+      elsif Unit_Requires_Body (Gen_Unit) then
+         if Errors_Detected = 0 then
+            Error_Msg_NE
+              ("cannot find body of generic package &", Inst_Node, Gen_Unit);
+
+         --  Don't attempt to perform any cleanup actions if some other
+         --  error was aready detected, since this can cause blowups.
+
+         else
+            return;
+         end if;
+
+      --  Case of package that does not need a body
+
+      else
+         --  If the instantiation of the declaration is a library unit,
+         --  rewrite the original package instantiation as a package
+         --  declaration in the compilation unit node.
+
+         if Nkind (Parent (Inst_Node)) = N_Compilation_Unit then
+            Set_Parent_Spec (Act_Decl, Parent_Spec (Inst_Node));
+            Rewrite (Inst_Node, Act_Decl);
+
+         --  If the instantiation is not a library unit, then append the
+         --  declaration to the list of implicitly generated entities.
+         --  unless it is already a list member which means that it was
+         --  already processed
+
+         elsif not Is_List_Member (Act_Decl) then
+            Mark_Rewrite_Insertion (Act_Decl);
+            Insert_Before (Inst_Node, Act_Decl);
+         end if;
+      end if;
+
+      Expander_Mode_Restore;
+
+      --  Remove the parent instances if they have been placed on the
+      --  scope stack to compile the body.
+
+      if Parent_Installed then
+         Remove_Parent (In_Body => True);
+      end if;
+   end Instantiate_Package_Body;
+
+   ---------------------------------
+   -- Instantiate_Subprogram_Body --
+   ---------------------------------
+
+   procedure Instantiate_Subprogram_Body
+     (Body_Info : Pending_Body_Info)
+   is
+      Act_Decl      : constant Node_Id    := Body_Info.Act_Decl;
+      Inst_Node     : constant Node_Id    := Body_Info.Inst_Node;
+      Loc           : constant Source_Ptr := Sloc (Inst_Node);
+
+      Decls         : List_Id;
+      Gen_Id        : constant Node_Id   := Name (Inst_Node);
+      Gen_Unit      : constant Entity_Id := Entity (Name (Inst_Node));
+      Gen_Decl      : constant Node_Id   := Unit_Declaration_Node (Gen_Unit);
+      Anon_Id       : constant Entity_Id :=
+                        Defining_Unit_Name (Specification (Act_Decl));
+      Gen_Body      : Node_Id;
+      Gen_Body_Id   : Node_Id;
+      Act_Body      : Node_Id;
+      Act_Body_Id   : Entity_Id;
+      Pack_Id       : Entity_Id := Defining_Unit_Name (Parent (Act_Decl));
+      Pack_Body     : Node_Id;
+      Prev_Formal   : Entity_Id;
+      Unit_Renaming : Node_Id;
+
+      Parent_Installed : Boolean := False;
+      Save_Style_Check : Boolean := Style_Check;
+
+   begin
+      Gen_Body_Id := Corresponding_Body (Gen_Decl);
+
+      Expander_Mode_Save_And_Set (Body_Info.Expander_Status);
+
+      if No (Gen_Body_Id) then
+         Load_Parent_Of_Generic (Inst_Node, Specification (Gen_Decl));
+         Gen_Body_Id := Corresponding_Body (Gen_Decl);
+      end if;
+
+      Instantiation_Node := Inst_Node;
+
+      if Present (Gen_Body_Id) then
+         Gen_Body := Unit_Declaration_Node (Gen_Body_Id);
+
+         if Nkind (Gen_Body) = N_Subprogram_Body_Stub then
+
+            --  Either body is not present, or context is non-expanding, as
+            --  when compiling a subunit. Mark the instance as completed.
+
+            Set_Has_Completion (Anon_Id);
+            return;
+         end if;
+
+         Save_Env (Gen_Unit, Anon_Id);
+         Style_Check := False;
+         Current_Sem_Unit := Body_Info.Current_Sem_Unit;
+         Create_Instantiation_Source (Inst_Node, Gen_Body_Id, S_Adjustment);
+
+         Act_Body :=
+           Copy_Generic_Node
+             (Original_Node (Gen_Body), Empty, Instantiating => True);
+         Act_Body_Id := Defining_Entity (Act_Body);
+         Set_Chars (Act_Body_Id, Chars (Anon_Id));
+         Set_Sloc (Act_Body_Id, Sloc (Defining_Entity (Inst_Node)));
+         Set_Corresponding_Spec (Act_Body, Anon_Id);
+         Set_Has_Completion (Anon_Id);
+         Check_Generic_Actuals (Pack_Id, False);
+
+         --  If it is a child unit, make the parent instance (which is an
+         --  instance of the parent of the generic) visible. The parent
+         --  instance is the prefix of the name of the generic unit.
+
+         if Ekind (Scope (Gen_Unit)) = E_Generic_Package
+           and then Nkind (Gen_Id) = N_Expanded_Name
+         then
+            Install_Parent (Entity (Prefix (Gen_Id)), In_Body => True);
+            Parent_Installed := True;
+
+         elsif Is_Child_Unit (Gen_Unit) then
+            Install_Parent (Scope (Gen_Unit), In_Body => True);
+            Parent_Installed := True;
+         end if;
+
+         --  Inside its body, a reference to the generic unit is a reference
+         --  to the instance. The corresponding renaming is the first
+         --  declaration in the body.
+
+         Unit_Renaming :=
+           Make_Subprogram_Renaming_Declaration (Loc,
+             Specification =>
+               Copy_Generic_Node (
+                 Specification (Original_Node (Gen_Body)),
+                 Empty,
+                 Instantiating => True),
+             Name => New_Occurrence_Of (Anon_Id, Loc));
+
+         --  If there is a formal subprogram with the same name as the
+         --  unit itself, do not add this renaming declaration. This is
+         --  a temporary fix for one ACVC test. ???
+
+         Prev_Formal := First_Entity (Pack_Id);
+         while Present (Prev_Formal) loop
+            if Chars (Prev_Formal) = Chars (Gen_Unit)
+              and then Is_Overloadable (Prev_Formal)
+            then
+               exit;
+            end if;
+
+            Next_Entity (Prev_Formal);
+         end loop;
+
+         if Present (Prev_Formal) then
+            Decls :=  New_List (Act_Body);
+         else
+            Decls :=  New_List (Unit_Renaming, Act_Body);
+         end if;
+
+         --  The subprogram body is placed in the body of a dummy package
+         --  body, whose spec contains the subprogram declaration as well
+         --  as the renaming declarations for the generic parameters.
+
+         Pack_Body := Make_Package_Body (Loc,
+           Defining_Unit_Name => New_Copy (Pack_Id),
+           Declarations       => Decls);
+
+         Set_Corresponding_Spec (Pack_Body, Pack_Id);
+
+         --  If the instantiation is a library unit, then build resulting
+         --  compilation unit nodes for the instance. The declaration of
+         --  the enclosing package is the grandparent of the subprogram
+         --  declaration. First replace the instantiation node as the unit
+         --  of the corresponding compilation.
+
+         if Nkind (Parent (Inst_Node)) = N_Compilation_Unit then
+
+            if Parent (Inst_Node) = Cunit (Main_Unit) then
+               Set_Unit (Parent (Inst_Node), Inst_Node);
+               Build_Instance_Compilation_Unit_Nodes
+                 (Inst_Node, Pack_Body, Parent (Parent (Act_Decl)));
+               Analyze (Inst_Node);
+            else
+               Set_Parent (Pack_Body, Parent (Inst_Node));
+               Analyze (Pack_Body);
+            end if;
+
+         else
+            Insert_Before (Inst_Node, Pack_Body);
+            Mark_Rewrite_Insertion (Pack_Body);
+            Analyze (Pack_Body);
+
+            if Expander_Active then
+               Freeze_Subprogram_Body (Inst_Node, Gen_Body, Pack_Id);
+            end if;
+         end if;
+
+         if not Generic_Separately_Compiled (Gen_Unit) then
+            Inherit_Context (Gen_Body, Inst_Node);
+         end if;
+
+         Restore_Private_Views (Pack_Id, False);
+
+         if Parent_Installed then
+            Remove_Parent (In_Body => True);
+         end if;
+
+         Restore_Env;
+         Style_Check := Save_Style_Check;
+
+      --  Body not found. Error was emitted already. If there were no
+      --  previous errors, this may be an instance whose scope is a premature
+      --  instance. In that case we must insure that the (legal) program does
+      --  raise program error if executed. We generate a subprogram body for
+      --  this purpose. See DEC ac30vso.
+
+      elsif Errors_Detected = 0
+        and then Nkind (Parent (Inst_Node)) /= N_Compilation_Unit
+      then
+         if Ekind (Anon_Id) = E_Procedure then
+            Act_Body :=
+              Make_Subprogram_Body (Loc,
+                 Specification              =>
+                   Make_Procedure_Specification (Loc,
+                     Defining_Unit_Name         => New_Copy (Anon_Id),
+                       Parameter_Specifications =>
+                       New_Copy_List
+                         (Parameter_Specifications (Parent (Anon_Id)))),
+
+                 Declarations               => Empty_List,
+                 Handled_Statement_Sequence =>
+                   Make_Handled_Sequence_Of_Statements (Loc,
+                     Statements =>
+                       New_List (Make_Raise_Program_Error (Loc))));
+         else
+            Act_Body :=
+              Make_Subprogram_Body (Loc,
+                Specification =>
+                  Make_Function_Specification (Loc,
+                     Defining_Unit_Name         => New_Copy (Anon_Id),
+                       Parameter_Specifications =>
+                       New_Copy_List
+                         (Parameter_Specifications (Parent (Anon_Id))),
+                     Subtype_Mark =>
+                       New_Occurrence_Of (Etype (Anon_Id), Loc)),
+
+                  Declarations               => Empty_List,
+                  Handled_Statement_Sequence =>
+                    Make_Handled_Sequence_Of_Statements (Loc,
+                      Statements => New_List (
+                        Make_Return_Statement (Loc,
+                          Expression => Make_Raise_Program_Error (Loc)))));
+         end if;
+
+         Pack_Body := Make_Package_Body (Loc,
+           Defining_Unit_Name => New_Copy (Pack_Id),
+           Declarations       => New_List (Act_Body));
+
+         Insert_After (Inst_Node, Pack_Body);
+         Set_Corresponding_Spec (Pack_Body, Pack_Id);
+         Analyze (Pack_Body);
+      end if;
+
+      Expander_Mode_Restore;
+   end Instantiate_Subprogram_Body;
+
+   ----------------------
+   -- Instantiate_Type --
+   ----------------------
+
+   function Instantiate_Type
+     (Formal          : Node_Id;
+      Actual          : Node_Id;
+      Analyzed_Formal : Node_Id)
+      return            Node_Id
+   is
+      Loc       : constant Source_Ptr := Sloc (Actual);
+      Gen_T     : constant Entity_Id  := Defining_Identifier (Formal);
+      A_Gen_T   : constant Entity_Id  := Defining_Identifier (Analyzed_Formal);
+      Ancestor  : Entity_Id;
+      Def       : constant Node_Id    := Formal_Type_Definition (Formal);
+      Act_T     : Entity_Id;
+      Decl_Node : Node_Id;
+
+      procedure Validate_Array_Type_Instance;
+      procedure Validate_Access_Subprogram_Instance;
+      procedure Validate_Access_Type_Instance;
+      procedure Validate_Derived_Type_Instance;
+      procedure Validate_Private_Type_Instance;
+      --  These procedures perform validation tests for the named case
+
+      function Subtypes_Match (Gen_T, Act_T : Entity_Id) return Boolean;
+      --  Check that base types are the same and that the subtypes match
+      --  statically. Used in several of the above.
+
+      --------------------
+      -- Subtypes_Match --
+      --------------------
+
+      function Subtypes_Match (Gen_T, Act_T : Entity_Id) return Boolean is
+         T : constant Entity_Id := Get_Instance_Of (Gen_T);
+
+      begin
+         return (Base_Type (T) = Base_Type (Act_T)
+--  why is the and then commented out here???
+--                  and then Is_Constrained (T) = Is_Constrained (Act_T)
+                  and then Subtypes_Statically_Match (T, Act_T))
+
+           or else (Is_Class_Wide_Type (Gen_T)
+                     and then Is_Class_Wide_Type (Act_T)
+                     and then
+                       Subtypes_Match (
+                         Get_Instance_Of (Root_Type (Gen_T)),
+                         Root_Type (Act_T)));
+      end Subtypes_Match;
+
+      -----------------------------------------
+      -- Validate_Access_Subprogram_Instance --
+      -----------------------------------------
+
+      procedure Validate_Access_Subprogram_Instance is
+      begin
+         if not Is_Access_Type (Act_T)
+           or else Ekind (Designated_Type (Act_T)) /= E_Subprogram_Type
+         then
+            Error_Msg_NE
+              ("expect access type in instantiation of &", Actual, Gen_T);
+            Abandon_Instantiation (Actual);
+         end if;
+
+         Check_Mode_Conformant
+           (Designated_Type (Act_T),
+            Designated_Type (A_Gen_T),
+            Actual,
+            Get_Inst => True);
+
+         if Ekind (Base_Type (Act_T)) = E_Access_Protected_Subprogram_Type then
+            if Ekind (A_Gen_T) = E_Access_Subprogram_Type then
+               Error_Msg_NE
+                 ("protected access type not allowed for formal &",
+                  Actual, Gen_T);
+            end if;
+
+         elsif Ekind (A_Gen_T) = E_Access_Protected_Subprogram_Type then
+            Error_Msg_NE
+              ("expect protected access type for formal &",
+               Actual, Gen_T);
+         end if;
+      end Validate_Access_Subprogram_Instance;
+
+      -----------------------------------
+      -- Validate_Access_Type_Instance --
+      -----------------------------------
+
+      procedure Validate_Access_Type_Instance is
+         Desig_Type : Entity_Id :=
+           Find_Actual_Type (Designated_Type (A_Gen_T), Scope (A_Gen_T));
+
+      begin
+         if not Is_Access_Type (Act_T) then
+            Error_Msg_NE
+              ("expect access type in instantiation of &", Actual, Gen_T);
+            Abandon_Instantiation (Actual);
+         end if;
+
+         if Is_Access_Constant (A_Gen_T) then
+            if not Is_Access_Constant (Act_T) then
+               Error_Msg_N
+                 ("actual type must be access-to-constant type", Actual);
+               Abandon_Instantiation (Actual);
+            end if;
+         else
+            if Is_Access_Constant (Act_T) then
+               Error_Msg_N
+                 ("actual type must be access-to-variable type", Actual);
+               Abandon_Instantiation (Actual);
+
+            elsif Ekind (A_Gen_T) = E_General_Access_Type
+              and then Ekind (Base_Type (Act_T)) /= E_General_Access_Type
+            then
+               Error_Msg_N ("actual must be general access type!", Actual);
+               Error_Msg_NE ("add ALL to }!", Actual, Act_T);
+               Abandon_Instantiation (Actual);
+            end if;
+         end if;
+
+         --  The designated subtypes, that is to say the subtypes introduced
+         --  by an access type declaration (and not by a subtype declaration)
+         --  must match.
+
+         if not Subtypes_Match
+           (Desig_Type, Designated_Type (Base_Type (Act_T)))
+         then
+            Error_Msg_NE
+              ("designated type of actual does not match that of formal &",
+                 Actual, Gen_T);
+            Abandon_Instantiation (Actual);
+
+         elsif Is_Access_Type (Designated_Type (Act_T))
+           and then Is_Constrained (Designated_Type (Designated_Type (Act_T)))
+                      /=
+                  Is_Constrained (Designated_Type (Desig_Type))
+         then
+            Error_Msg_NE
+              ("designated type of actual does not match that of formal &",
+                 Actual, Gen_T);
+            Abandon_Instantiation (Actual);
+         end if;
+      end Validate_Access_Type_Instance;
+
+      ----------------------------------
+      -- Validate_Array_Type_Instance --
+      ----------------------------------
+
+      procedure Validate_Array_Type_Instance is
+         I1 : Node_Id;
+         I2 : Node_Id;
+         T2 : Entity_Id;
+
+         function Formal_Dimensions return Int;
+         --  Count number of dimensions in array type formal
+
+         function Formal_Dimensions return Int is
+            Num   : Int := 0;
+            Index : Node_Id;
+
+         begin
+            if Nkind (Def) = N_Constrained_Array_Definition then
+               Index := First (Discrete_Subtype_Definitions (Def));
+            else
+               Index := First (Subtype_Marks (Def));
+            end if;
+
+            while Present (Index) loop
+               Num := Num + 1;
+               Next_Index (Index);
+            end loop;
+
+            return Num;
+         end Formal_Dimensions;
+
+      --  Start of processing for Validate_Array_Type_Instance
+
+      begin
+         if not Is_Array_Type (Act_T) then
+            Error_Msg_NE
+              ("expect array type in instantiation of &", Actual, Gen_T);
+            Abandon_Instantiation (Actual);
+
+         elsif Nkind (Def) = N_Constrained_Array_Definition then
+            if not (Is_Constrained (Act_T)) then
+               Error_Msg_NE
+                 ("expect constrained array in instantiation of &",
+                  Actual, Gen_T);
+               Abandon_Instantiation (Actual);
+            end if;
+
+         else
+            if Is_Constrained (Act_T) then
+               Error_Msg_NE
+                 ("expect unconstrained array in instantiation of &",
+                  Actual, Gen_T);
+               Abandon_Instantiation (Actual);
+            end if;
+         end if;
+
+         if Formal_Dimensions /= Number_Dimensions (Act_T) then
+            Error_Msg_NE
+              ("dimensions of actual do not match formal &", Actual, Gen_T);
+            Abandon_Instantiation (Actual);
+         end if;
+
+         I1 := First_Index (A_Gen_T);
+         I2 := First_Index (Act_T);
+         for J in 1 .. Formal_Dimensions loop
+
+            --  If the indices of the actual were given by a subtype_mark,
+            --  the index was transformed into a range attribute. Retrieve
+            --  the original type mark for checking.
+
+            if Is_Entity_Name (Original_Node (I2)) then
+               T2 := Entity (Original_Node (I2));
+            else
+               T2 := Etype (I2);
+            end if;
+
+            if not Subtypes_Match
+              (Find_Actual_Type (Etype (I1), Scope (A_Gen_T)), T2)
+            then
+               Error_Msg_NE
+                 ("index types of actual do not match those of formal &",
+                  Actual, Gen_T);
+               Abandon_Instantiation (Actual);
+            end if;
+
+            Next_Index (I1);
+            Next_Index (I2);
+         end loop;
+
+         if not Subtypes_Match (
+            Find_Actual_Type (Component_Type (A_Gen_T), Scope (A_Gen_T)),
+            Component_Type (Act_T))
+         then
+            Error_Msg_NE
+              ("component subtype of actual does not match that of formal &",
+               Actual, Gen_T);
+            Abandon_Instantiation (Actual);
+         end if;
+
+         if Has_Aliased_Components (A_Gen_T)
+           and then not Has_Aliased_Components (Act_T)
+         then
+            Error_Msg_NE
+              ("actual must have aliased components to match formal type &",
+               Actual, Gen_T);
+         end if;
+
+      end Validate_Array_Type_Instance;
+
+      ------------------------------------
+      -- Validate_Derived_Type_Instance --
+      ------------------------------------
+
+      procedure Validate_Derived_Type_Instance is
+         Actual_Discr   : Entity_Id;
+         Ancestor_Discr : Entity_Id;
+
+      begin
+         --  If the parent type in the generic declaration is itself
+         --  a previous formal type, then it is local to the generic
+         --  and absent from the analyzed generic definition. In  that
+         --  case the ancestor is the instance of the formal (which must
+         --  have been instantiated previously). Otherwise, the analyzed
+         --  generic carries the parent type. If the parent type is defined
+         --  in a previous formal package, then the scope of that formal
+         --  package is that of the generic type itself, and it has already
+         --  been mapped into the corresponding type in the actual package.
+
+         --  Common case: parent type defined outside of the generic.
+
+         if Is_Entity_Name (Subtype_Mark (Def))
+           and then Present (Entity (Subtype_Mark (Def)))
+         then
+            Ancestor := Get_Instance_Of (Entity (Subtype_Mark (Def)));
+
+         --  Check whether parent is defined in a previous formal package.
+
+         elsif
+           Scope (Scope (Base_Type (Etype (A_Gen_T)))) = Scope (A_Gen_T)
+         then
+            Ancestor :=
+              Get_Instance_Of (Base_Type (Etype (A_Gen_T)));
+
+         elsif Is_Derived_Type (Get_Instance_Of (A_Gen_T)) then
+            Ancestor :=
+              Get_Instance_Of (Base_Type (Get_Instance_Of (A_Gen_T)));
+
+         else
+            Ancestor := Get_Instance_Of (Etype (Base_Type (A_Gen_T)));
+         end if;
+
+         if not Is_Ancestor (Base_Type (Ancestor), Act_T) then
+            Error_Msg_NE
+              ("expect type derived from & in instantiation",
+               Actual, First_Subtype (Ancestor));
+            Abandon_Instantiation (Actual);
+         end if;
+
+         --  Perform atomic/volatile checks (RM C.6(12))
+
+         if Is_Atomic (Act_T) and then not Is_Atomic (Ancestor) then
+            Error_Msg_N
+              ("cannot have atomic actual type for non-atomic formal type",
+               Actual);
+
+         elsif Is_Volatile (Act_T)
+           and then not Is_Volatile (Ancestor)
+           and then Is_By_Reference_Type (Ancestor)
+         then
+            Error_Msg_N
+              ("cannot have volatile actual type for non-volatile formal type",
+               Actual);
+         end if;
+
+         --  It should not be necessary to check for unknown discriminants
+         --  on Formal, but for some reason Has_Unknown_Discriminants is
+         --  false for A_Gen_T, so Is_Indefinite_Subtype incorrectly
+         --  returns False. This needs fixing. ???
+
+         if not Is_Indefinite_Subtype (A_Gen_T)
+           and then not Unknown_Discriminants_Present (Formal)
+           and then Is_Indefinite_Subtype (Act_T)
+         then
+            Error_Msg_N
+              ("actual subtype must be constrained", Actual);
+            Abandon_Instantiation (Actual);
+         end if;
+
+         if not Unknown_Discriminants_Present (Formal) then
+            if Is_Constrained (Ancestor) then
+               if not Is_Constrained (Act_T) then
+                  Error_Msg_N
+                    ("actual subtype must be constrained", Actual);
+                  Abandon_Instantiation (Actual);
+               end if;
+
+            --  Ancestor is unconstrained
+
+            elsif Is_Constrained (Act_T) then
+               if Ekind (Ancestor) = E_Access_Type
+                 or else Is_Composite_Type (Ancestor)
+               then
+                  Error_Msg_N
+                    ("actual subtype must be unconstrained", Actual);
+                  Abandon_Instantiation (Actual);
+               end if;
+
+            --  A class-wide type is only allowed if the formal has
+            --  unknown discriminants.
+
+            elsif Is_Class_Wide_Type (Act_T)
+              and then not Has_Unknown_Discriminants (Ancestor)
+            then
+               Error_Msg_NE
+                 ("actual for & cannot be a class-wide type", Actual, Gen_T);
+               Abandon_Instantiation (Actual);
+
+            --  Otherwise, the formal and actual shall have the same
+            --  number of discriminants and each discriminant of the
+            --  actual must correspond to a discriminant of the formal.
+
+            elsif Has_Discriminants (Act_T)
+              and then Has_Discriminants (Ancestor)
+            then
+               Actual_Discr   := First_Discriminant (Act_T);
+               Ancestor_Discr := First_Discriminant (Ancestor);
+               while Present (Actual_Discr)
+                 and then Present (Ancestor_Discr)
+               loop
+                  if Base_Type (Act_T) /= Base_Type (Ancestor) and then
+                    not Present (Corresponding_Discriminant (Actual_Discr))
+                  then
+                     Error_Msg_NE
+                       ("discriminant & does not correspond " &
+                        "to ancestor discriminant", Actual, Actual_Discr);
+                     Abandon_Instantiation (Actual);
+                  end if;
+
+                  Next_Discriminant (Actual_Discr);
+                  Next_Discriminant (Ancestor_Discr);
+               end loop;
+
+               if Present (Actual_Discr) or else Present (Ancestor_Discr) then
+                  Error_Msg_NE
+                    ("actual for & must have same number of discriminants",
+                     Actual, Gen_T);
+                  Abandon_Instantiation (Actual);
+               end if;
+
+            --  This case should be caught by the earlier check for
+            --  for constrainedness, but the check here is added for
+            --  completeness.
+
+            elsif Has_Discriminants (Act_T) then
+               Error_Msg_NE
+                 ("actual for & must not have discriminants", Actual, Gen_T);
+               Abandon_Instantiation (Actual);
+
+            elsif Has_Discriminants (Ancestor) then
+               Error_Msg_NE
+                 ("actual for & must have known discriminants", Actual, Gen_T);
+               Abandon_Instantiation (Actual);
+            end if;
+
+            if not Subtypes_Statically_Compatible (Act_T, Ancestor) then
+               Error_Msg_N
+                 ("constraint on actual is incompatible with formal", Actual);
+               Abandon_Instantiation (Actual);
+            end if;
+         end if;
+
+      end Validate_Derived_Type_Instance;
+
+      ------------------------------------
+      -- Validate_Private_Type_Instance --
+      ------------------------------------
+
+      procedure Validate_Private_Type_Instance is
+         Formal_Discr : Entity_Id;
+         Actual_Discr : Entity_Id;
+         Formal_Subt  : Entity_Id;
+
+      begin
+         if (Is_Limited_Type (Act_T)
+              or else Is_Limited_Composite (Act_T))
+           and then not Is_Limited_Type (A_Gen_T)
+         then
+            Error_Msg_NE
+              ("actual for non-limited  & cannot be a limited type", Actual,
+               Gen_T);
+            Abandon_Instantiation (Actual);
+
+         elsif Is_Indefinite_Subtype (Act_T)
+            and then not Is_Indefinite_Subtype (A_Gen_T)
+            and then Ada_95
+         then
+            Error_Msg_NE
+              ("actual for & must be a definite subtype", Actual, Gen_T);
+
+         elsif not Is_Tagged_Type (Act_T)
+           and then Is_Tagged_Type (A_Gen_T)
+         then
+            Error_Msg_NE
+              ("actual for & must be a tagged type", Actual, Gen_T);
+
+         elsif Has_Discriminants (A_Gen_T) then
+            if not Has_Discriminants (Act_T) then
+               Error_Msg_NE
+                 ("actual for & must have discriminants", Actual, Gen_T);
+               Abandon_Instantiation (Actual);
+
+            elsif Is_Constrained (Act_T) then
+               Error_Msg_NE
+                 ("actual for & must be unconstrained", Actual, Gen_T);
+               Abandon_Instantiation (Actual);
+
+            else
+               Formal_Discr := First_Discriminant (A_Gen_T);
+               Actual_Discr := First_Discriminant (Act_T);
+               while Formal_Discr /= Empty loop
+                  if Actual_Discr = Empty then
+                     Error_Msg_NE
+                       ("discriminants on actual do not match formal",
+                        Actual, Gen_T);
+                     Abandon_Instantiation (Actual);
+                  end if;
+
+                  Formal_Subt := Get_Instance_Of (Etype (Formal_Discr));
+
+                  --  access discriminants match if designated types do.
+
+                  if Ekind (Base_Type (Formal_Subt)) = E_Anonymous_Access_Type
+                    and then (Ekind (Base_Type (Etype (Actual_Discr))))
+                      = E_Anonymous_Access_Type
+                    and then Get_Instance_Of (
+                      Designated_Type (Base_Type (Formal_Subt)))
+                      = Designated_Type (Base_Type (Etype (Actual_Discr)))
+                  then
+                     null;
+
+                  elsif Base_Type (Formal_Subt) /=
+                                       Base_Type (Etype (Actual_Discr))
+                  then
+                     Error_Msg_NE
+                       ("types of actual discriminants must match formal",
+                        Actual, Gen_T);
+                     Abandon_Instantiation (Actual);
+
+                  elsif not Subtypes_Statically_Match
+                              (Formal_Subt, Etype (Actual_Discr))
+                    and then Ada_95
+                  then
+                     Error_Msg_NE
+                       ("subtypes of actual discriminants must match formal",
+                        Actual, Gen_T);
+                     Abandon_Instantiation (Actual);
+                  end if;
+
+                  Next_Discriminant (Formal_Discr);
+                  Next_Discriminant (Actual_Discr);
+               end loop;
+
+               if Actual_Discr /= Empty then
+                  Error_Msg_NE
+                    ("discriminants on actual do not match formal",
+                     Actual, Gen_T);
+                  Abandon_Instantiation (Actual);
+               end if;
+            end if;
+
+         end if;
+
+         Ancestor := Gen_T;
+      end Validate_Private_Type_Instance;
+
+   --  Start of processing for Instantiate_Type
+
+   begin
+      if Get_Instance_Of (A_Gen_T) /= A_Gen_T then
+         Error_Msg_N ("duplicate instantiation of generic type", Actual);
+         return Error;
+
+      elsif not Is_Entity_Name (Actual)
+        or else not Is_Type (Entity (Actual))
+      then
+         Error_Msg_NE
+           ("expect valid subtype mark to instantiate &", Actual, Gen_T);
+         Abandon_Instantiation (Actual);
+
+      else
+         Act_T := Entity (Actual);
+
+         if Ekind (Act_T) = E_Incomplete_Type then
+            if No (Underlying_Type (Act_T)) then
+               Error_Msg_N ("premature use of incomplete type", Actual);
+               Abandon_Instantiation (Actual);
+            else
+               Act_T := Full_View (Act_T);
+               Set_Entity (Actual, Act_T);
+
+               if Has_Private_Component (Act_T) then
+                  Error_Msg_N
+                    ("premature use of type with private component", Actual);
+               end if;
+            end if;
+
+         elsif Is_Private_Type (Act_T)
+           and then Is_Private_Type (Base_Type (Act_T))
+           and then not Is_Generic_Type (Act_T)
+           and then not Is_Derived_Type (Act_T)
+           and then No (Full_View (Root_Type (Act_T)))
+         then
+            Error_Msg_N ("premature use of private type", Actual);
+
+         elsif Has_Private_Component (Act_T) then
+            Error_Msg_N
+              ("premature use of type with private component", Actual);
+         end if;
+
+         Set_Instance_Of (A_Gen_T, Act_T);
+
+         --  If the type is generic, the class-wide type may also be used
+
+         if Is_Tagged_Type (A_Gen_T)
+           and then Is_Tagged_Type (Act_T)
+           and then not Is_Class_Wide_Type (A_Gen_T)
+         then
+            Set_Instance_Of (Class_Wide_Type (A_Gen_T),
+              Class_Wide_Type (Act_T));
+         end if;
+
+         if not Is_Abstract (A_Gen_T)
+           and then Is_Abstract (Act_T)
+         then
+            Error_Msg_N
+              ("actual of non-abstract formal cannot be abstract", Actual);
+         end if;
+
+         if Is_Scalar_Type (Gen_T) then
+            Set_Instance_Of (Etype (A_Gen_T), Etype (Act_T));
+         end if;
+      end if;
+
+      case Nkind (Def) is
+         when N_Formal_Private_Type_Definition =>
+            Validate_Private_Type_Instance;
+
+         when N_Formal_Derived_Type_Definition =>
+            Validate_Derived_Type_Instance;
+
+         when N_Formal_Discrete_Type_Definition =>
+            if not Is_Discrete_Type (Act_T) then
+               Error_Msg_NE
+                 ("expect discrete type in instantiation of&", Actual, Gen_T);
+               Abandon_Instantiation (Actual);
+            end if;
+
+         when N_Formal_Signed_Integer_Type_Definition =>
+            if not Is_Signed_Integer_Type (Act_T) then
+               Error_Msg_NE
+                 ("expect signed integer type in instantiation of&",
+                  Actual, Gen_T);
+               Abandon_Instantiation (Actual);
+            end if;
+
+         when N_Formal_Modular_Type_Definition =>
+            if not Is_Modular_Integer_Type (Act_T) then
+               Error_Msg_NE
+                 ("expect modular type in instantiation of &", Actual, Gen_T);
+               Abandon_Instantiation (Actual);
+            end if;
+
+         when N_Formal_Floating_Point_Definition =>
+            if not Is_Floating_Point_Type (Act_T) then
+               Error_Msg_NE
+                 ("expect float type in instantiation of &", Actual, Gen_T);
+               Abandon_Instantiation (Actual);
+            end if;
+
+         when N_Formal_Ordinary_Fixed_Point_Definition =>
+            if not Is_Ordinary_Fixed_Point_Type (Act_T) then
+               Error_Msg_NE
+                 ("expect ordinary fixed point type in instantiation of &",
+                  Actual, Gen_T);
+               Abandon_Instantiation (Actual);
+            end if;
+
+         when N_Formal_Decimal_Fixed_Point_Definition =>
+            if not Is_Decimal_Fixed_Point_Type (Act_T) then
+               Error_Msg_NE
+                 ("expect decimal type in instantiation of &",
+                  Actual, Gen_T);
+               Abandon_Instantiation (Actual);
+            end if;
+
+         when N_Array_Type_Definition =>
+            Validate_Array_Type_Instance;
+
+         when N_Access_To_Object_Definition =>
+            Validate_Access_Type_Instance;
+
+         when N_Access_Function_Definition |
+              N_Access_Procedure_Definition =>
+            Validate_Access_Subprogram_Instance;
+
+         when others =>
+            raise Program_Error;
+
+      end case;
+
+      Decl_Node :=
+        Make_Subtype_Declaration (Loc,
+          Defining_Identifier => New_Copy (Gen_T),
+          Subtype_Indication  => New_Reference_To (Act_T, Loc));
+
+      if Is_Private_Type (Act_T) then
+         Set_Has_Private_View (Subtype_Indication (Decl_Node));
+      end if;
+
+      --  Flag actual derived types so their elaboration produces the
+      --  appropriate renamings for the primitive operations of the ancestor.
+      --  Flag actual for formal private types as well, to determine whether
+      --  operations in the private part may override inherited operations.
+
+      if Nkind (Def) = N_Formal_Derived_Type_Definition
+        or else Nkind (Def) = N_Formal_Private_Type_Definition
+      then
+         Set_Generic_Parent_Type (Decl_Node, Ancestor);
+      end if;
+
+      return Decl_Node;
+   end Instantiate_Type;
+
+   ---------------------
+   -- Is_In_Main_Unit --
+   ---------------------
+
+   function Is_In_Main_Unit (N : Node_Id) return Boolean is
+      Unum : constant Unit_Number_Type := Get_Source_Unit (N);
+
+      Current_Unit : Node_Id;
+
+   begin
+      if Unum = Main_Unit then
+         return True;
+
+      --  If the current unit is a subunit then it is either the main unit
+      --  or is being compiled as part of the main unit.
+
+      elsif Nkind (N) = N_Compilation_Unit then
+         return Nkind (Unit (N)) = N_Subunit;
+      end if;
+
+      Current_Unit := Parent (N);
+      while Present (Current_Unit)
+        and then Nkind (Current_Unit) /= N_Compilation_Unit
+      loop
+         Current_Unit := Parent (Current_Unit);
+      end loop;
+
+      --  The instantiation node is in the main unit, or else the current
+      --  node (perhaps as the result of nested instantiations) is in the
+      --  main unit, or in the declaration of the main unit, which in this
+      --  last case must be a body.
+
+      return Unum = Main_Unit
+        or else Current_Unit = Cunit (Main_Unit)
+        or else Current_Unit = Library_Unit (Cunit (Main_Unit))
+        or else (Present (Library_Unit (Current_Unit))
+                  and then Is_In_Main_Unit (Library_Unit (Current_Unit)));
+   end Is_In_Main_Unit;
+
+   ----------------------------
+   -- Load_Parent_Of_Generic --
+   ----------------------------
+
+   procedure Load_Parent_Of_Generic (N : Node_Id; Spec : Node_Id) is
+      Comp_Unit        : constant Node_Id := Cunit (Get_Source_Unit (Spec));
+      True_Parent      : Node_Id;
+      Inst_Node        : Node_Id;
+      OK               : Boolean;
+      Save_Style_Check : Boolean := Style_Check;
+
+   begin
+      if not In_Same_Source_Unit (N, Spec)
+        or else Nkind (Unit (Comp_Unit)) = N_Package_Declaration
+        or else (Nkind (Unit (Comp_Unit)) = N_Package_Body
+                   and then not Is_In_Main_Unit (Spec))
+      then
+         --  Find body of parent of spec, and analyze it. A special case
+         --  arises when the parent is an instantiation, that is to say when
+         --  we are currently instantiating a nested generic. In that case,
+         --  there is no separate file for the body of the enclosing instance.
+         --  Instead, the enclosing body must be instantiated as if it were
+         --  a pending instantiation, in order to produce the body for the
+         --  nested generic we require now. Note that in that case the
+         --  generic may be defined in a package body, the instance defined
+         --  in the same package body, and the original enclosing body may not
+         --  be in the main unit.
+
+         True_Parent := Parent (Spec);
+         Inst_Node   := Empty;
+
+         while Present (True_Parent)
+           and then Nkind (True_Parent) /= N_Compilation_Unit
+         loop
+            if Nkind (True_Parent) = N_Package_Declaration
+              and then
+                Nkind (Original_Node (True_Parent)) = N_Package_Instantiation
+            then
+               --  Parent is a compilation unit that is an instantiation.
+               --  Instantiation node has been replaced with package decl.
+
+               Inst_Node := Original_Node (True_Parent);
+               exit;
+
+            elsif Nkind (True_Parent) = N_Package_Declaration
+              and then Present (Generic_Parent (Specification (True_Parent)))
+            then
+               --  Parent is an instantiation within another specification.
+               --  Declaration for instance has been inserted before original
+               --  instantiation node. A direct link would be preferable?
+
+               Inst_Node := Next (True_Parent);
+
+               while Present (Inst_Node)
+                 and then Nkind (Inst_Node) /= N_Package_Instantiation
+               loop
+                  Next (Inst_Node);
+               end loop;
+
+               --  If the instance appears within a generic, and the generic
+               --  unit is defined within a formal package of the enclosing
+               --  generic, there is no generic body available, and none
+               --  needed. A more precise test should be used ???
+
+               if No (Inst_Node) then
+                  return;
+               end if;
+
+               exit;
+            else
+               True_Parent := Parent (True_Parent);
+            end if;
+         end loop;
+
+         if Present (Inst_Node) then
+
+            if Nkind (Parent (True_Parent)) = N_Compilation_Unit then
+
+               --  Instantiation node and declaration of instantiated package
+               --  were exchanged when only the declaration was needed.
+               --  Restore instantiation node before proceeding with body.
+
+               Set_Unit (Parent (True_Parent), Inst_Node);
+            end if;
+
+            --  Now complete instantiation of enclosing body, if it appears
+            --  in some other unit. If it appears in the current unit, the
+            --  body will have been instantiated already.
+
+            if No (Corresponding_Body (Instance_Spec (Inst_Node))) then
+               Instantiate_Package_Body
+                 (Pending_Body_Info'(
+                    Inst_Node, True_Parent, Expander_Active,
+                      Get_Code_Unit (Sloc (Inst_Node))));
+            end if;
+
+         else
+            Opt.Style_Check := False;
+            Load_Needed_Body (Comp_Unit, OK);
+            Opt.Style_Check := Save_Style_Check;
+
+            if not OK
+              and then Unit_Requires_Body (Defining_Entity (Spec))
+            then
+               declare
+                  Bname : constant Unit_Name_Type :=
+                            Get_Body_Name (Get_Unit_Name (Unit (Comp_Unit)));
+
+               begin
+                  Error_Msg_Unit_1 := Bname;
+                  Error_Msg_N ("this instantiation requires$!", N);
+                  Error_Msg_Name_1 :=
+                    Get_File_Name (Bname, Subunit => False);
+                  Error_Msg_N ("\but file{ was not found!", N);
+                  raise Unrecoverable_Error;
+               end;
+            end if;
+         end if;
+      end if;
+
+      --  If loading the parent of the generic caused an instantiation
+      --  circularity, we abandon compilation at this point, because
+      --  otherwise in some cases we get into trouble with infinite
+      --  recursions after this point.
+
+      if Circularity_Detected then
+         raise Unrecoverable_Error;
+      end if;
+
+   end Load_Parent_Of_Generic;
+
+   -----------------------
+   -- Move_Freeze_Nodes --
+   -----------------------
+
+   procedure Move_Freeze_Nodes
+     (Out_Of : Entity_Id;
+      After  : Node_Id;
+      L      : List_Id)
+   is
+      Decl      : Node_Id;
+      Next_Decl : Node_Id;
+      Next_Node : Node_Id := After;
+      Spec      : Node_Id;
+
+      function Is_Outer_Type (T : Entity_Id) return Boolean;
+      --  Check whether entity is declared in a scope external to that
+      --  of the generic unit.
+
+      -------------------
+      -- Is_Outer_Type --
+      -------------------
+
+      function Is_Outer_Type (T : Entity_Id) return Boolean is
+         Scop : Entity_Id := Scope (T);
+
+      begin
+         if Scope_Depth (Scop) < Scope_Depth (Out_Of) then
+            return True;
+
+         else
+            while Scop /= Standard_Standard loop
+
+               if Scop = Out_Of then
+                  return False;
+               else
+                  Scop := Scope (Scop);
+               end if;
+            end loop;
+
+            return True;
+         end if;
+      end Is_Outer_Type;
+
+   --  Start of processing for Move_Freeze_Nodes
+
+   begin
+      if No (L) then
+         return;
+      end if;
+
+      --  First remove the freeze nodes that may appear before all other
+      --  declarations.
+
+      Decl := First (L);
+      while Present (Decl)
+        and then Nkind (Decl) = N_Freeze_Entity
+        and then Is_Outer_Type (Entity (Decl))
+      loop
+         Decl := Remove_Head (L);
+         Insert_After (Next_Node, Decl);
+         Set_Analyzed (Decl, False);
+         Next_Node := Decl;
+         Decl := First (L);
+      end loop;
+
+      --  Next scan the list of declarations and remove each freeze node that
+      --  appears ahead of the current node.
+
+      while Present (Decl) loop
+         while Present (Next (Decl))
+           and then Nkind (Next (Decl)) = N_Freeze_Entity
+           and then Is_Outer_Type (Entity (Next (Decl)))
+         loop
+            Next_Decl := Remove_Next (Decl);
+            Insert_After (Next_Node, Next_Decl);
+            Set_Analyzed (Next_Decl, False);
+            Next_Node := Next_Decl;
+         end loop;
+
+         --  If the declaration is a nested package or concurrent type, then
+         --  recurse. Nested generic packages will have been processed from the
+         --  inside out.
+
+         if Nkind (Decl) = N_Package_Declaration then
+            Spec := Specification (Decl);
+
+         elsif Nkind (Decl) = N_Task_Type_Declaration then
+            Spec := Task_Definition (Decl);
+
+         elsif Nkind (Decl) = N_Protected_Type_Declaration then
+            Spec := Protected_Definition (Decl);
+
+         else
+            Spec := Empty;
+         end if;
+
+         if Present (Spec) then
+            Move_Freeze_Nodes (Out_Of, Next_Node,
+              Visible_Declarations (Spec));
+            Move_Freeze_Nodes (Out_Of, Next_Node,
+              Private_Declarations (Spec));
+         end if;
+
+         Next (Decl);
+      end loop;
+   end Move_Freeze_Nodes;
+
+   ----------------
+   -- Next_Assoc --
+   ----------------
+
+   function Next_Assoc (E : Assoc_Ptr) return Assoc_Ptr is
+   begin
+      return Generic_Renamings.Table (E).Next_In_HTable;
+   end Next_Assoc;
+
+   ------------------------
+   -- Preanalyze_Actuals --
+   ------------------------
+
+   procedure Pre_Analyze_Actuals (N : Node_Id) is
+      Assoc : Node_Id;
+      Act   : Node_Id;
+      Errs  : Int := Errors_Detected;
+
+   begin
+      Assoc := First (Generic_Associations (N));
+
+      while Present (Assoc) loop
+         Act := Explicit_Generic_Actual_Parameter (Assoc);
+
+         --  Within a nested instantiation, a defaulted actual is an
+         --  empty association, so nothing to analyze. If the actual for
+         --  a subprogram is an attribute, analyze prefix only, because
+         --  actual is not a complete attribute reference.
+         --  String literals may be operators, but at this point we do not
+         --  know whether the actual is a formal subprogram or a string.
+
+         if No (Act) then
+            null;
+
+         elsif Nkind (Act) = N_Attribute_Reference then
+            Analyze (Prefix (Act));
+
+         elsif Nkind (Act) = N_Explicit_Dereference then
+            Analyze (Prefix (Act));
+
+         elsif Nkind (Act) /= N_Operator_Symbol then
+            Analyze (Act);
+         end if;
+
+         if Errs /= Errors_Detected then
+            Abandon_Instantiation (Act);
+         end if;
+
+         Next (Assoc);
+      end loop;
+   end Pre_Analyze_Actuals;
+
+   -------------------
+   -- Remove_Parent --
+   -------------------
+
+   procedure Remove_Parent (In_Body : Boolean := False) is
+      S      : Entity_Id := Current_Scope;
+      E      : Entity_Id;
+      P      : Entity_Id;
+      Hidden : Elmt_Id;
+
+   begin
+      --  After child instantiation is complete, remove from scope stack
+      --  the extra copy of the current scope, and then remove parent
+      --  instances.
+
+      if not In_Body then
+         Pop_Scope;
+
+         while Current_Scope /= S loop
+            P := Current_Scope;
+            End_Package_Scope (Current_Scope);
+
+            if In_Open_Scopes (P) then
+               E := First_Entity (P);
+
+               while Present (E) loop
+                  Set_Is_Immediately_Visible (E, True);
+                  Next_Entity (E);
+               end loop;
+
+            elsif not In_Open_Scopes (Scope (P)) then
+               Set_Is_Immediately_Visible (P, False);
+            end if;
+         end loop;
+
+         --  Reset visibility of entities in the enclosing scope.
+
+         Set_Is_Hidden_Open_Scope (Current_Scope, False);
+         Hidden := First_Elmt (Hidden_Entities);
+
+         while Present (Hidden) loop
+            Set_Is_Immediately_Visible (Node (Hidden), True);
+            Next_Elmt (Hidden);
+         end loop;
+
+      else
+         --  Each body is analyzed separately, and there is no context
+         --  that needs preserving from one body instance to the next,
+         --  so remove all parent scopes that have been installed.
+
+         while Present (S) loop
+            End_Package_Scope (S);
+            S := Current_Scope;
+            exit when S = Standard_Standard;
+         end loop;
+      end if;
+
+   end Remove_Parent;
+
+   -----------------
+   -- Restore_Env --
+   -----------------
+
+   procedure Restore_Env is
+      Saved : Instance_Env renames Instance_Envs.Table (Instance_Envs.Last);
+
+   begin
+      Ada_83                       := Saved.Ada_83;
+
+      if No (Current_Instantiated_Parent.Act_Id) then
+
+         --  Restore environment after subprogram inlining
+
+         Restore_Private_Views (Empty);
+      end if;
+
+      Current_Instantiated_Parent  := Saved.Instantiated_Parent;
+      Exchanged_Views              := Saved.Exchanged_Views;
+      Hidden_Entities              := Saved.Hidden_Entities;
+      Current_Sem_Unit             := Saved.Current_Sem_Unit;
+
+      Instance_Envs.Decrement_Last;
+   end Restore_Env;
+
+   ---------------------------
+   -- Restore_Private_Views --
+   ---------------------------
+
+   procedure Restore_Private_Views
+     (Pack_Id    : Entity_Id;
+      Is_Package : Boolean := True)
+   is
+      M        : Elmt_Id;
+      E        : Entity_Id;
+      Typ      : Entity_Id;
+      Dep_Elmt : Elmt_Id;
+      Dep_Typ  : Node_Id;
+
+   begin
+      M := First_Elmt (Exchanged_Views);
+      while Present (M) loop
+         Typ := Node (M);
+
+         --  Subtypes of types whose views have been exchanged, and that
+         --  are defined within the instance, were not on the list of
+         --  Private_Dependents on entry to the instance, so they have to
+         --  be exchanged explicitly now, in order to remain consistent with
+         --  the view of the parent type.
+
+         if Ekind (Typ) = E_Private_Type
+           or else Ekind (Typ) = E_Limited_Private_Type
+           or else Ekind (Typ) = E_Record_Type_With_Private
+         then
+            Dep_Elmt := First_Elmt (Private_Dependents (Typ));
+
+            while Present (Dep_Elmt) loop
+               Dep_Typ := Node (Dep_Elmt);
+
+               if Scope (Dep_Typ) = Pack_Id
+                 and then Present (Full_View (Dep_Typ))
+               then
+                  Replace_Elmt (Dep_Elmt, Full_View (Dep_Typ));
+                  Exchange_Declarations (Dep_Typ);
+               end if;
+
+               Next_Elmt (Dep_Elmt);
+            end loop;
+         end if;
+
+         Exchange_Declarations (Node (M));
+         Next_Elmt (M);
+      end loop;
+
+      if No (Pack_Id) then
+         return;
+      end if;
+
+      --  Make the generic formal parameters private, and make the formal
+      --  types into subtypes of the actuals again.
+
+      E := First_Entity (Pack_Id);
+
+      while Present (E) loop
+         Set_Is_Hidden (E, True);
+
+         if Is_Type (E)
+           and then Nkind (Parent (E)) = N_Subtype_Declaration
+         then
+            Set_Is_Generic_Actual_Type (E, False);
+
+            --  An unusual case of aliasing: the actual may also be directly
+            --  visible in the generic, and be private there, while it is
+            --  fully visible in the context of the instance. The internal
+            --  subtype is private in the instance, but has full visibility
+            --  like its parent in the enclosing scope. This enforces the
+            --  invariant that the privacy status of all private dependents of
+            --  a type coincide with that of the parent type. This can only
+            --  happen when a generic child unit is instantiated within a
+            --  sibling.
+
+            if Is_Private_Type (E)
+              and then not Is_Private_Type (Etype (E))
+            then
+               Exchange_Declarations (E);
+            end if;
+
+         elsif Ekind (E) = E_Package then
+
+            --  The end of the renaming list is the renaming of the generic
+            --  package itself. If the instance is a subprogram, all entities
+            --  in the corresponding package are renamings. If this entity is
+            --  a formal package, make its own formals private as well. The
+            --  actual in this case is itself the renaming of an instantation.
+            --  If the entity is not a package renaming, it is the entity
+            --  created to validate formal package actuals: ignore.
+
+            --  If the actual is itself a formal package for the enclosing
+            --  generic, or the actual for such a formal package, it remains
+            --  visible after the current instance, and therefore nothing
+            --  needs to be done either, except to keep it accessible.
+
+            if Is_Package
+              and then Renamed_Object (E) = Pack_Id
+            then
+               exit;
+
+            elsif Nkind (Parent (E)) /= N_Package_Renaming_Declaration then
+               null;
+
+            elsif Denotes_Formal_Package (Renamed_Object (E)) then
+               Set_Is_Hidden (E, False);
+
+            else
+               declare
+                  Act_P : Entity_Id := Renamed_Object (E);
+                  Id    : Entity_Id := First_Entity (Act_P);
+
+               begin
+                  while Present (Id)
+                    and then Id /= First_Private_Entity (Act_P)
+                  loop
+                     Set_Is_Hidden (Id, True);
+                     Set_Is_Potentially_Use_Visible (Id, In_Use (Act_P));
+                     exit when Ekind (Id) = E_Package
+                                 and then Renamed_Object (Id) = Act_P;
+
+                     Next_Entity (Id);
+                  end loop;
+               end;
+               null;
+            end if;
+         end if;
+
+         Next_Entity (E);
+      end loop;
+   end Restore_Private_Views;
+
+   --------------
+   -- Save_Env --
+   --------------
+
+   procedure Save_Env
+     (Gen_Unit : Entity_Id;
+      Act_Unit : Entity_Id)
+   is
+      Saved : Instance_Env;
+
+   begin
+      Saved.Ada_83              := Ada_83;
+      Saved.Instantiated_Parent := Current_Instantiated_Parent;
+      Saved.Exchanged_Views     := Exchanged_Views;
+      Saved.Hidden_Entities     := Hidden_Entities;
+      Saved.Current_Sem_Unit    := Current_Sem_Unit;
+      Instance_Envs.Increment_Last;
+      Instance_Envs.Table (Instance_Envs.Last) := Saved;
+
+      --  Regardless of the current mode, predefined units are analyzed in
+      --  Ada95 mode, and Ada83 checks don't apply.
+
+      if Is_Internal_File_Name
+          (Fname => Unit_File_Name (Get_Source_Unit (Gen_Unit)),
+           Renamings_Included => True) then
+         Ada_83 := False;
+      end if;
+
+      Current_Instantiated_Parent := (Gen_Unit, Act_Unit, Assoc_Null);
+      Exchanged_Views := New_Elmt_List;
+      Hidden_Entities := New_Elmt_List;
+   end Save_Env;
+
+   ----------------------------
+   -- Save_Global_References --
+   ----------------------------
+
+   procedure Save_Global_References (N : Node_Id) is
+      Gen_Scope : Entity_Id;
+      E         : Entity_Id;
+      N2        : Node_Id;
+
+      function Is_Global (E : Entity_Id) return Boolean;
+      --  Check whether entity is defined outside of generic unit.
+      --  Examine the scope of an entity, and the scope of the scope,
+      --  etc, until we find either Standard, in which case the entity
+      --  is global, or the generic unit itself, which indicates that
+      --  the entity is local. If the entity is the generic unit itself,
+      --  as in the case of a recursive call, or the enclosing generic unit,
+      --  if different from the current scope, then it is local as well,
+      --  because it will be replaced at the point of instantiation. On
+      --  the other hand, if it is a reference to a child unit of a common
+      --  ancestor, which appears in an instantiation, it is global because
+      --  it is used to denote a specific compilation unit at the time the
+      --  instantiations will be analyzed.
+
+      procedure Reset_Entity (N : Node_Id);
+      --  Save semantic information on global entity, so that it is not
+      --  resolved again at instantiation time.
+
+      procedure Save_Global_Defaults (N1, N2 : Node_Id);
+      --  Default actuals in nested instances must be handled specially
+      --  because there is no link to them from the original tree. When an
+      --  actual subprogram is given by a default, we add an explicit generic
+      --  association for it in the instantiation node. When we save the
+      --  global references on the name of the instance, we recover the list
+      --  of generic associations, and add an explicit one to the original
+      --  generic tree, through which a global actual can be preserved.
+      --  Similarly, if a child unit is instantiated within a sibling, in the
+      --  context of the parent, we must preserve the identifier of the parent
+      --  so that it can be properly resolved in a subsequent instantiation.
+
+      procedure Save_Global_Descendant (D : Union_Id);
+      --  Apply Save_Global_References recursively to the descendents of
+      --  current node.
+
+      procedure Save_References (N : Node_Id);
+      --  This is the recursive procedure that does the work, once the
+      --  enclosing generic scope has been established.
+
+      ---------------
+      -- Is_Global --
+      ---------------
+
+      function Is_Global (E : Entity_Id) return Boolean is
+         Se  : Entity_Id := Scope (E);
+
+         function Is_Instance_Node (Decl : Node_Id) return Boolean;
+         --  Determine whether the parent node of a reference to a child unit
+         --  denotes an instantiation or a formal package, in which case the
+         --  reference to the child unit is global, even if it appears within
+         --  the current scope (e.g. when the instance appears within the body
+         --  of an ancestor).
+
+         function Is_Instance_Node (Decl : Node_Id) return Boolean is
+         begin
+            return (Nkind (Decl) in N_Generic_Instantiation
+              or else
+                Nkind (Original_Node (Decl)) = N_Formal_Package_Declaration);
+         end Is_Instance_Node;
+
+      --  Start of processing for Is_Global
+
+      begin
+         if E = Gen_Scope then
+            return False;
+
+         elsif E = Standard_Standard then
+            return True;
+
+         elsif Is_Child_Unit (E)
+           and then (Is_Instance_Node (Parent (N2))
+             or else (Nkind (Parent (N2)) = N_Expanded_Name
+                       and then N2 = Selector_Name (Parent (N2))
+                       and then Is_Instance_Node (Parent (Parent (N2)))))
+         then
+            return True;
+
+         else
+            while Se /= Gen_Scope loop
+               if Se = Standard_Standard then
+                  return True;
+               else
+                  Se := Scope (Se);
+               end if;
+            end loop;
+
+            return False;
+         end if;
+      end Is_Global;
+
+      ------------------
+      -- Reset_Entity --
+      ------------------
+
+      procedure Reset_Entity (N : Node_Id) is
+
+         procedure Set_Global_Type (N : Node_Id; N2 : Node_Id);
+         --  The type of N2 is global to the generic unit. Save the
+         --  type in the generic node.
+
+         procedure Set_Global_Type (N : Node_Id; N2 : Node_Id) is
+            Typ : constant Entity_Id := Etype (N2);
+
+         begin
+            Set_Etype (N, Typ);
+
+            if Entity (N) /= N2
+              and then Has_Private_View (Entity (N))
+            then
+               --  If the entity of N is not the associated node, this is
+               --  a nested generic and it has an associated node as well,
+               --  whose type is already the full view (see below). Indicate
+               --  that the original node has a private view.
+
+               Set_Has_Private_View (N);
+            end if;
+
+            --  If not a private type, nothing else to do
+
+            if not Is_Private_Type (Typ) then
+               if Is_Array_Type (Typ)
+                 and then Is_Private_Type (Component_Type (Typ))
+               then
+                  Set_Has_Private_View (N);
+               end if;
+
+            --  If it is a derivation of a private type in a context where
+            --  no full view is needed, nothing to do either.
+
+            elsif No (Full_View (Typ)) and then Typ /= Etype (Typ) then
+               null;
+
+            --  Otherwise mark the type for flipping and use the full_view
+            --  when available.
+
+            else
+               Set_Has_Private_View (N);
+
+               if Present (Full_View (Typ)) then
+                  Set_Etype (N2, Full_View (Typ));
+               end if;
+            end if;
+         end Set_Global_Type;
+
+      --  Start of processing for Reset_Entity
+
+      begin
+         N2 := Associated_Node (N);
+         E := Entity (N2);
+
+         if Present (E) then
+            if Is_Global (E) then
+               Set_Global_Type (N, N2);
+
+            elsif Nkind (N) = N_Op_Concat
+              and then Is_Generic_Type (Etype (N2))
+              and then
+               (Base_Type (Etype (Right_Opnd (N2))) = Etype (N2)
+                  or else Base_Type (Etype (Left_Opnd (N2))) = Etype (N2))
+              and then Is_Intrinsic_Subprogram (E)
+            then
+               null;
+
+            else
+               --  Entity is local. Mark generic node as unresolved.
+               --  Note that now it does not have an entity.
+
+               Set_Associated_Node (N, Empty);
+               Set_Etype  (N, Empty);
+            end if;
+
+            if (Nkind (Parent (N)) = N_Package_Instantiation
+                 or else Nkind (Parent (N)) = N_Function_Instantiation
+                 or else Nkind (Parent (N)) = N_Procedure_Instantiation)
+              and then N = Name (Parent (N))
+            then
+               Save_Global_Defaults (Parent (N), Parent (N2));
+            end if;
+
+         elsif Nkind (Parent (N)) = N_Selected_Component
+           and then Nkind (Parent (N2)) = N_Expanded_Name
+         then
+
+            if Is_Global (Entity (Parent (N2))) then
+               Change_Selected_Component_To_Expanded_Name (Parent (N));
+               Set_Associated_Node (Parent (N), Parent (N2));
+               Set_Global_Type (Parent (N), Parent (N2));
+
+               Save_Global_Descendant (Field2 (N));
+               Save_Global_Descendant (Field3 (N));
+
+               --  If this is a reference to the current generic entity,
+               --  replace it with a simple name. This is to avoid anomalies
+               --  when the enclosing scope is also a generic unit, in which
+               --  case the selected component will not resolve to the current
+               --  unit within an instance of the outer one. Ditto if the
+               --  entity is an enclosing scope, e.g. a parent unit.
+
+            elsif In_Open_Scopes (Entity (Parent (N2)))
+              and then not Is_Generic_Unit (Entity (Prefix (Parent (N2))))
+            then
+               Rewrite (Parent (N),
+                 Make_Identifier (Sloc (N),
+                   Chars => Chars (Selector_Name (Parent (N2)))));
+            end if;
+
+            if (Nkind (Parent (Parent (N))) = N_Package_Instantiation
+                 or else Nkind (Parent (Parent (N)))
+                   = N_Function_Instantiation
+                 or else Nkind (Parent (Parent (N)))
+                   = N_Procedure_Instantiation)
+              and then Parent (N) = Name (Parent (Parent (N)))
+            then
+               Save_Global_Defaults
+                 (Parent (Parent (N)), Parent (Parent ((N2))));
+            end if;
+
+         --  A selected component may denote a static constant that has
+         --  been folded. Make the same replacement in original tree.
+
+         elsif Nkind (Parent (N)) = N_Selected_Component
+           and then (Nkind (Parent (N2)) = N_Integer_Literal
+                      or else Nkind (Parent (N2)) = N_Real_Literal)
+         then
+            Rewrite (Parent (N),
+              New_Copy (Parent (N2)));
+            Set_Analyzed (Parent (N), False);
+
+         --  a selected component may be transformed into a parameterless
+         --  function call. If the called entity is global, rewrite the
+         --  node appropriately, i.e. as an extended name for the global
+         --  entity.
+
+         elsif Nkind (Parent (N)) = N_Selected_Component
+           and then Nkind (Parent (N2)) = N_Function_Call
+           and then Is_Global (Entity (Name (Parent (N2))))
+         then
+            Change_Selected_Component_To_Expanded_Name (Parent (N));
+            Set_Associated_Node (Parent (N), Name (Parent (N2)));
+            Set_Global_Type (Parent (N), Name (Parent (N2)));
+
+            Save_Global_Descendant (Field2 (N));
+            Save_Global_Descendant (Field3 (N));
+
+         else
+            --  Entity is local. Reset in generic unit, so that node
+            --  is resolved anew at the point of instantiation.
+
+            Set_Associated_Node (N, Empty);
+            Set_Etype (N, Empty);
+         end if;
+      end Reset_Entity;
+
+      --------------------------
+      -- Save_Global_Defaults --
+      --------------------------
+
+      procedure Save_Global_Defaults (N1, N2 : Node_Id) is
+         Loc    : constant Source_Ptr := Sloc (N1);
+         Assoc1 : List_Id := Generic_Associations (N1);
+         Assoc2 : List_Id := Generic_Associations (N2);
+         Act1   : Node_Id;
+         Act2   : Node_Id;
+         Def    : Node_Id;
+         Gen_Id : Entity_Id := Entity (Name (N2));
+         Ndec   : Node_Id;
+         Subp   : Entity_Id;
+         Actual : Entity_Id;
+
+      begin
+         if Present (Assoc1) then
+            Act1 := First (Assoc1);
+         else
+            Act1 := Empty;
+            Set_Generic_Associations (N1, New_List);
+            Assoc1 := Generic_Associations (N1);
+         end if;
+
+         if Present (Assoc2) then
+            Act2 := First (Assoc2);
+         else
+            return;
+         end if;
+
+         while Present (Act1) and then Present (Act2) loop
+            Next (Act1);
+            Next (Act2);
+         end loop;
+
+         --  Find the associations added for default suprograms.
+
+         if Present (Act2) then
+            while Nkind (Act2) /= N_Generic_Association
+              or else No (Entity (Selector_Name (Act2)))
+              or else not Is_Overloadable (Entity (Selector_Name (Act2)))
+            loop
+               Next (Act2);
+            end loop;
+
+            --  Add a similar association if the default is global. The
+            --  renaming declaration for the actual has been analyzed, and
+            --  its alias is the program it renames. Link the actual in the
+            --  original generic tree with the node in the analyzed tree.
+
+            while Present (Act2) loop
+               Subp := Entity (Selector_Name (Act2));
+               Def  := Explicit_Generic_Actual_Parameter (Act2);
+
+               --  Following test is defence against rubbish errors
+
+               if No (Alias (Subp)) then
+                  return;
+               end if;
+
+               --  Retrieve the resolved actual from the renaming declaration
+               --  created for the instantiated formal.
+
+               Actual := Entity (Name (Parent (Parent (Subp))));
+               Set_Entity (Def, Actual);
+               Set_Etype (Def, Etype (Actual));
+
+               if Is_Global (Actual) then
+                  Ndec :=
+                    Make_Generic_Association (Loc,
+                      Selector_Name => New_Occurrence_Of (Subp, Loc),
+                        Explicit_Generic_Actual_Parameter =>
+                          New_Occurrence_Of (Actual, Loc));
+
+                  Set_Associated_Node
+                    (Explicit_Generic_Actual_Parameter (Ndec), Def);
+
+                  Append (Ndec, Assoc1);
+
+               --  If there are other defaults, add a dummy association
+               --  in case there are other defaulted formals with the same
+               --  name.
+
+               elsif Present (Next (Act2)) then
+                  Ndec :=
+                    Make_Generic_Association (Loc,
+                      Selector_Name => New_Occurrence_Of (Subp, Loc),
+                        Explicit_Generic_Actual_Parameter => Empty);
+
+                  Append (Ndec, Assoc1);
+               end if;
+
+               Next (Act2);
+            end loop;
+         end if;
+
+         if Nkind (Name (N1)) = N_Identifier
+           and then Is_Child_Unit (Gen_Id)
+           and then Is_Global (Gen_Id)
+           and then Is_Generic_Unit (Scope (Gen_Id))
+           and then In_Open_Scopes (Scope (Gen_Id))
+         then
+            --  This is an instantiation of a child unit within a sibling,
+            --  so that the generic parent is in scope. An eventual instance
+            --  must occur within the scope of an instance of the parent.
+            --  Make name in instance into an expanded name, to preserve the
+            --  identifier of the parent, so it can be resolved subsequently.
+
+            Rewrite (Name (N2),
+              Make_Expanded_Name (Loc,
+                Chars         => Chars (Gen_Id),
+                Prefix        => New_Occurrence_Of (Scope (Gen_Id), Loc),
+                Selector_Name => New_Occurrence_Of (Gen_Id, Loc)));
+            Set_Entity (Name (N2), Gen_Id);
+
+            Rewrite (Name (N1),
+               Make_Expanded_Name (Loc,
+                Chars         => Chars (Gen_Id),
+                Prefix        => New_Occurrence_Of (Scope (Gen_Id), Loc),
+                Selector_Name => New_Occurrence_Of (Gen_Id, Loc)));
+
+            Set_Associated_Node (Name (N1), Name (N2));
+            Set_Associated_Node (Prefix (Name (N1)), Empty);
+            Set_Associated_Node
+              (Selector_Name (Name (N1)), Selector_Name (Name (N2)));
+            Set_Etype (Name (N1), Etype (Gen_Id));
+         end if;
+
+      end Save_Global_Defaults;
+
+      ----------------------------
+      -- Save_Global_Descendant --
+      ----------------------------
+
+      procedure Save_Global_Descendant (D : Union_Id) is
+         N1 : Node_Id;
+
+      begin
+         if D in Node_Range then
+            if D = Union_Id (Empty) then
+               null;
+
+            elsif Nkind (Node_Id (D)) /= N_Compilation_Unit then
+               Save_References (Node_Id (D));
+            end if;
+
+         elsif D in List_Range then
+            if D = Union_Id (No_List)
+              or else Is_Empty_List (List_Id (D))
+            then
+               null;
+
+            else
+               N1 := First (List_Id (D));
+               while Present (N1) loop
+                  Save_References (N1);
+                  Next (N1);
+               end loop;
+            end if;
+
+         --  Element list or other non-node field, nothing to do
+
+         else
+            null;
+         end if;
+      end Save_Global_Descendant;
+
+      ---------------------
+      -- Save_References --
+      ---------------------
+
+      --  This is the recursive procedure that does the work, once the
+      --  enclosing generic scope has been established. We have to treat
+      --  specially a number of node rewritings that are required by semantic
+      --  processing and which change the kind of nodes in the generic copy:
+      --  typically constant-folding, replacing an operator node by a string
+      --  literal, or a selected component by an expanded name. In  each of
+      --  those cases, the transformation is propagated to the generic unit.
+
+      procedure Save_References (N : Node_Id) is
+      begin
+         if N = Empty then
+            null;
+
+         elsif (Nkind (N) = N_Character_Literal
+                 or else Nkind (N) = N_Operator_Symbol)
+         then
+            if Nkind (N) = Nkind (Associated_Node (N)) then
+               Reset_Entity (N);
+
+            elsif Nkind (N) = N_Operator_Symbol
+              and then Nkind (Associated_Node (N)) = N_String_Literal
+            then
+               Change_Operator_Symbol_To_String_Literal (N);
+            end if;
+
+         elsif Nkind (N) in N_Op then
+
+            if Nkind (N) = Nkind (Associated_Node (N)) then
+
+               if Nkind (N) = N_Op_Concat then
+                  Set_Is_Component_Left_Opnd (N,
+                    Is_Component_Left_Opnd (Associated_Node (N)));
+
+                  Set_Is_Component_Right_Opnd (N,
+                    Is_Component_Right_Opnd (Associated_Node (N)));
+               end if;
+
+               Reset_Entity (N);
+            else
+               --  Node may be transformed into call to a user-defined operator
+
+               N2 := Associated_Node (N);
+
+               if Nkind (N2) = N_Function_Call then
+                  E := Entity (Name (N2));
+
+                  if Present (E)
+                    and then Is_Global (E)
+                  then
+                     Set_Etype (N, Etype (N2));
+                  else
+                     Set_Associated_Node (N, Empty);
+                     Set_Etype (N, Empty);
+                  end if;
+
+               elsif Nkind (N2) = N_Integer_Literal
+                 or else Nkind (N2) = N_Real_Literal
+                 or else Nkind (N2) = N_String_Literal
+                 or else (Nkind (N2) = N_Identifier
+                           and then
+                          Ekind (Entity (N2)) = E_Enumeration_Literal)
+               then
+                  --  Operation was constant-folded, perform the same
+                  --  replacement in generic.
+
+                  --  Note: we do a Replace here rather than a Rewrite,
+                  --  which is a definite violation of the standard rules
+                  --  with regard to retrievability of the original tree,
+                  --  and likely ASIS bugs or at least irregularities are
+                  --  caused by this choice.
+
+                  --  The reason we do this is that the appropriate original
+                  --  nodes are never constructed (we don't go applying the
+                  --  generic instantiation to rewritten nodes in general).
+                  --  We could try to create an appropriate copy but it would
+                  --  be hard work and does not seem worth while, because
+                  --  the original expression is accessible in the generic,
+                  --  and ASIS rules for traversing instances are fuzzy.
+
+                  Replace (N, New_Copy (N2));
+                  Set_Analyzed (N, False);
+               end if;
+            end if;
+
+            --  Complete the check on operands.
+
+            Save_Global_Descendant (Field2 (N));
+            Save_Global_Descendant (Field3 (N));
+
+         elsif Nkind (N) = N_Identifier then
+            if Nkind (N) = Nkind (Associated_Node (N)) then
+
+               --  If this is a discriminant reference, always save it.
+               --  It is used in the instance to find the corresponding
+               --  discriminant positionally rather than  by name.
+
+               Set_Original_Discriminant
+                 (N, Original_Discriminant (Associated_Node (N)));
+               Reset_Entity (N);
+
+            else
+               N2 := Associated_Node (N);
+
+               if Nkind (N2) = N_Function_Call then
+                  E := Entity (Name (N2));
+
+                  --  Name resolves to a call to parameterless function.
+                  --  If original entity is global, mark node as resolved.
+
+                  if Present (E)
+                    and then Is_Global (E)
+                  then
+                     Set_Etype (N, Etype (N2));
+                  else
+                     Set_Associated_Node (N, Empty);
+                     Set_Etype (N, Empty);
+                  end if;
+
+               elsif
+                 Nkind (N2) = N_Integer_Literal or else
+                 Nkind (N2) = N_Real_Literal    or else
+                 Nkind (N2) = N_String_Literal
+               then
+                  --  Name resolves to named number that is constant-folded,
+                  --  or to string literal from concatenation.
+                  --  Perform the same replacement in generic.
+
+                  Rewrite (N, New_Copy (N2));
+                  Set_Analyzed (N, False);
+
+               elsif Nkind (N2) = N_Explicit_Dereference then
+
+                  --  An identifier is rewritten as a dereference if it is
+                  --  the prefix in a selected component, and it denotes an
+                  --  access to a composite type, or a parameterless function
+                  --  call that returns an access type.
+
+                  --  Check whether corresponding entity in prefix is global.
+
+                  if Is_Entity_Name (Prefix (N2))
+                    and then Present (Entity (Prefix (N2)))
+                    and then Is_Global (Entity (Prefix (N2)))
+                  then
+                     Rewrite (N,
+                       Make_Explicit_Dereference (Sloc (N),
+                          Prefix => Make_Identifier (Sloc (N),
+                            Chars => Chars (N))));
+                     Set_Associated_Node (Prefix (N), Prefix (N2));
+
+                  elsif Nkind (Prefix (N2)) = N_Function_Call
+                    and then Is_Global (Entity (Name (Prefix (N2))))
+                  then
+                     Rewrite (N,
+                       Make_Explicit_Dereference (Sloc (N),
+                          Prefix => Make_Function_Call (Sloc (N),
+                            Name  =>
+                              Make_Identifier (Sloc (N),
+                              Chars => Chars (N)))));
+
+                     Set_Associated_Node
+                      (Name (Prefix (N)), Name (Prefix (N2)));
+
+                  else
+                     Set_Associated_Node (N, Empty);
+                     Set_Etype (N, Empty);
+                  end if;
+
+               --  The subtype mark of a nominally unconstrained object
+               --  is rewritten as a subtype indication using the bounds
+               --  of the expression. Recover the original subtype mark.
+
+               elsif Nkind (N2) = N_Subtype_Indication
+                 and then Is_Entity_Name (Original_Node (N2))
+               then
+                  Set_Associated_Node (N, Original_Node (N2));
+                  Reset_Entity (N);
+
+               else
+                  null;
+               end if;
+            end if;
+
+         elsif Nkind (N) in N_Entity then
+            null;
+
+         elsif Nkind (N) = N_Aggregate
+                 or else Nkind (N) = N_Extension_Aggregate
+         then
+            N2 := Associated_Node (N);
+            if No (N2)
+              or else No (Etype (N2))
+              or else not Is_Global (Etype (N2))
+            then
+               Set_Associated_Node (N, Empty);
+            end if;
+
+            Save_Global_Descendant (Field1 (N));
+            Save_Global_Descendant (Field2 (N));
+            Save_Global_Descendant (Field3 (N));
+            Save_Global_Descendant (Field5 (N));
+
+         else
+            Save_Global_Descendant (Field1 (N));
+            Save_Global_Descendant (Field2 (N));
+            Save_Global_Descendant (Field3 (N));
+            Save_Global_Descendant (Field4 (N));
+            Save_Global_Descendant (Field5 (N));
+
+         end if;
+      end Save_References;
+
+   --  Start of processing for Save_Global_References
+
+   begin
+      Gen_Scope := Current_Scope;
+
+      --  If the generic unit is a child unit, references to entities in
+      --  the parent are treated as local, because they will be resolved
+      --  anew in the context of the instance of the parent.
+
+      while Is_Child_Unit (Gen_Scope)
+        and then Ekind (Scope (Gen_Scope)) = E_Generic_Package
+      loop
+         Gen_Scope := Scope (Gen_Scope);
+      end loop;
+
+      Save_References (N);
+   end Save_Global_References;
+
+   -------------------------
+   -- Set_Associated_Node --
+   -------------------------
+
+   --  Note from RBKD: the uncommented use of Set_Node4 below is ugly ???
+
+   procedure Set_Associated_Node
+     (Gen_Node  : Node_Id;
+      Copy_Node : Node_Id)
+   is
+   begin
+      Set_Node4 (Gen_Node, Copy_Node);
+   end Set_Associated_Node;
+
+   ---------------------
+   -- Set_Copied_Sloc --
+   ---------------------
+
+   procedure Set_Copied_Sloc (N : Node_Id; E : Entity_Id) is
+   begin
+      Create_Instantiation_Source (N, E, S_Adjustment);
+   end Set_Copied_Sloc;
+
+   ---------------------
+   -- Set_Instance_Of --
+   ---------------------
+
+   procedure Set_Instance_Of (A : Entity_Id; B : Entity_Id) is
+   begin
+      Generic_Renamings.Table (Generic_Renamings.Last) := (A, B, Assoc_Null);
+      Generic_Renamings_HTable.Set (Generic_Renamings.Last);
+      Generic_Renamings.Increment_Last;
+   end Set_Instance_Of;
+
+   --------------------
+   -- Set_Next_Assoc --
+   --------------------
+
+   procedure Set_Next_Assoc (E : Assoc_Ptr; Next : Assoc_Ptr) is
+   begin
+      Generic_Renamings.Table (E).Next_In_HTable := Next;
+   end Set_Next_Assoc;
+
+   -------------------
+   -- Start_Generic --
+   -------------------
+
+   procedure Start_Generic is
+   begin
+      --  ??? I am sure more things could be factored out in this
+      --  routine. Should probably be done at a later stage.
+
+      Generic_Flags.Increment_Last;
+      Generic_Flags.Table (Generic_Flags.Last) := Inside_A_Generic;
+      Inside_A_Generic := True;
+
+      Expander_Mode_Save_And_Set (False);
+   end Start_Generic;
+
+   -----------------
+   -- Switch_View --
+   -----------------
+
+   procedure Switch_View (T : Entity_Id) is
+      Priv_Elmt : Elmt_Id := No_Elmt;
+      Priv_Sub  : Entity_Id;
+      BT        : Entity_Id := Base_Type (T);
+
+   begin
+      --  T may be private but its base type may have been exchanged through
+      --  some other occurrence, in which case there is nothing to switch.
+
+      if not Is_Private_Type (BT) then
+         return;
+      end if;
+
+      Priv_Elmt := First_Elmt (Private_Dependents (BT));
+
+      if Present (Full_View (BT)) then
+         Append_Elmt (Full_View (BT), Exchanged_Views);
+         Exchange_Declarations (BT);
+      end if;
+
+      while Present (Priv_Elmt) loop
+         Priv_Sub := (Node (Priv_Elmt));
+
+         --  We avoid flipping the subtype if the Etype of its full
+         --  view is private because this would result in a malformed
+         --  subtype. This occurs when the Etype of the subtype full
+         --  view is the full view of the base type (and since the
+         --  base types were just switched, the subtype is pointing
+         --  to the wrong view). This is currently the case for
+         --  tagged record types, access types (maybe more?) and
+         --  needs to be resolved. ???
+
+         if Present (Full_View (Priv_Sub))
+           and then not Is_Private_Type (Etype (Full_View (Priv_Sub)))
+         then
+            Append_Elmt (Full_View (Priv_Sub), Exchanged_Views);
+            Exchange_Declarations (Priv_Sub);
+         end if;
+
+         Next_Elmt (Priv_Elmt);
+      end loop;
+   end Switch_View;
+
+   -----------------------------
+   -- Valid_Default_Attribute --
+   -----------------------------
+
+   procedure Valid_Default_Attribute (Nam : Entity_Id; Def : Node_Id) is
+      Attr_Id : constant Attribute_Id :=
+                  Get_Attribute_Id (Attribute_Name (Def));
+      F       : Entity_Id;
+      Num_F   : Int;
+      T       : Entity_Id := Entity (Prefix (Def));
+      OK      : Boolean;
+      Is_Fun  : constant Boolean := (Ekind (Nam) = E_Function);
+
+   begin
+      if No (T)
+        or else T = Any_Id
+      then
+         return;
+      end if;
+
+      Num_F := 0;
+      F := First_Formal (Nam);
+      while Present (F) loop
+         Num_F := Num_F + 1;
+         Next_Formal (F);
+      end loop;
+
+      case Attr_Id is
+      when Attribute_Adjacent |  Attribute_Ceiling   | Attribute_Copy_Sign |
+           Attribute_Floor    |  Attribute_Fraction  | Attribute_Machine   |
+           Attribute_Model    |  Attribute_Remainder | Attribute_Rounding  |
+           Attribute_Unbiased_Rounding  =>
+         OK := (Is_Fun and then Num_F = 1 and then Is_Floating_Point_Type (T));
+
+      when Attribute_Image    | Attribute_Pred       | Attribute_Succ |
+           Attribute_Value    | Attribute_Wide_Image |
+           Attribute_Wide_Value  =>
+         OK := (Is_Fun and then Num_F = 1 and then Is_Scalar_Type (T));
+
+      when Attribute_Max      |  Attribute_Min  =>
+         OK := (Is_Fun and then Num_F = 2 and then Is_Scalar_Type (T));
+
+      when Attribute_Input =>
+         OK := (Is_Fun and then Num_F = 1);
+
+      when Attribute_Output | Attribute_Read | Attribute_Write =>
+         OK := (not Is_Fun and then Num_F = 2);
+
+      when others => OK := False;
+      end case;
+
+      if not OK then
+         Error_Msg_N ("attribute reference has wrong profile for subprogram",
+           Def);
+      end if;
+   end Valid_Default_Attribute;
+
+end Sem_Ch12;
diff --git a/gcc/ada/sem_ch12.ads b/gcc/ada/sem_ch12.ads
new file mode 100644
index 00000000000..80af1ae6dd0
--- /dev/null
+++ b/gcc/ada/sem_ch12.ads
@@ -0,0 +1,109 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             S E M _ C H 1 2                              --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.19 $
+--                                                                          --
+--          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). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+with Inline; use Inline;
+with Types;  use Types;
+
+package Sem_Ch12 is
+   procedure Analyze_Generic_Package_Declaration        (N : Node_Id);
+   procedure Analyze_Generic_Subprogram_Declaration     (N : Node_Id);
+   procedure Analyze_Package_Instantiation              (N : Node_Id);
+   procedure Analyze_Procedure_Instantiation            (N : Node_Id);
+   procedure Analyze_Function_Instantiation             (N : Node_Id);
+   procedure Analyze_Formal_Object_Declaration          (N : Node_Id);
+   procedure Analyze_Formal_Type_Declaration            (N : Node_Id);
+   procedure Analyze_Formal_Subprogram                  (N : Node_Id);
+   procedure Analyze_Formal_Package                     (N : Node_Id);
+
+   procedure Start_Generic;
+   --  Must be invoked before starting to process a generic spec or body.
+
+   procedure End_Generic;
+   --  Must be invoked just at the end of the end of the processing of a
+   --  generic spec or body.
+
+   procedure Check_Generic_Child_Unit
+     (Gen_Id           : Node_Id;
+      Parent_Installed : in out Boolean);
+   --  If the name of the generic unit in an instantiation or a renaming
+   --  is a selected component, then the prefix may be an instance and the
+   --  selector may  designate a child unit. Retrieve the parent generic
+   --  and search for the child unit that must be declared within. Similarly,
+   --  if this is the name of a generic child unit within an instantiation of
+   --  its own parent, retrieve the parent generic.
+
+   function Copy_Generic_Node
+     (N             : Node_Id;
+      Parent_Id     : Node_Id;
+      Instantiating : Boolean)
+      return          Node_Id;
+   --  Copy the tree for a generic unit or its body. The unit is copied
+   --  repeatedly: once to produce a copy on which semantic analysis of
+   --  the generic is performed, and once for each instantiation. The tree
+   --  being copied is not semantically analyzed, except that references to
+   --  global entities are marked on terminal nodes.
+
+   function Get_Instance_Of (A : Entity_Id) return Entity_Id;
+   --  Retrieve actual associated with given generic parameter.
+   --  If A is uninstantiated or not a generic parameter, return A.
+
+   procedure Instantiate_Package_Body
+     (Body_Info : Pending_Body_Info);
+   --  Called after semantic analysis, to complete the instantiation of
+   --  package instances.
+
+   procedure Instantiate_Subprogram_Body
+     (Body_Info : Pending_Body_Info);
+   --  Called after semantic analysis, to complete the instantiation of
+   --  function and procedure instances.
+
+   procedure Save_Global_References (N : Node_Id);
+   --  Traverse the original generic unit, and capture all references to
+   --  entities that are defined outside of the generic in the analyzed
+   --  tree for the template. These references are copied into the original
+   --  tree, so that they appear automatically in  every instantiation.
+   --  A critical invariant in this approach is that if an id in the generic
+   --  resolves to a local entity, the corresponding id in the instance
+   --  will resolve to the homologous entity in the instance, even though
+   --  the enclosing context for resolution is different, as long as the
+   --  global references have been captured as described here.
+
+   --  Because instantiations can be nested, the environment of the instance,
+   --  involving the actuals and other data-structures, must be saved and
+   --  restored in stack-like fashion. Front-end inlining also uses these
+   --  structures for the management of private/full views.
+
+   procedure Set_Copied_Sloc (N : Node_Id; E : Entity_Id);
+
+   procedure Save_Env
+     (Gen_Unit : Entity_Id;
+      Act_Unit : Entity_Id);
+
+   procedure Restore_Env;
+
+end Sem_Ch12;
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
new file mode 100644
index 00000000000..ae674411d79
--- /dev/null
+++ b/gcc/ada/sem_ch13.adb
@@ -0,0 +1,3912 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             S E M _ C H 1 3                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.390 $
+--                                                                          --
+--          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 Einfo;    use Einfo;
+with Errout;   use Errout;
+with Exp_Tss;  use Exp_Tss;
+with Exp_Util; use Exp_Util;
+with Hostparm; use Hostparm;
+with Lib;      use Lib;
+with Nlists;   use Nlists;
+with Nmake;    use Nmake;
+with Opt;      use Opt;
+with Rtsfind;  use Rtsfind;
+with Sem;      use Sem;
+with Sem_Ch8;  use Sem_Ch8;
+with Sem_Eval; use Sem_Eval;
+with Sem_Res;  use Sem_Res;
+with Sem_Type; use Sem_Type;
+with Sem_Util; use Sem_Util;
+with Stand;    use Stand;
+with Sinfo;    use Sinfo;
+with Snames;   use Snames;
+with Table;
+with Ttypes;   use Ttypes;
+with Tbuild;   use Tbuild;
+with Urealp;   use Urealp;
+
+with GNAT.Heap_Sort_A; use GNAT.Heap_Sort_A;
+
+package body Sem_Ch13 is
+
+   SSU : constant Pos := System_Storage_Unit;
+   --  Convenient short hand for commonly used constant
+
+   -----------------------
+   -- Local Subprograms --
+   -----------------------
+
+   procedure Alignment_Check_For_Esize_Change (Typ : Entity_Id);
+   --  This routine is called after setting the Esize of type entity Typ.
+   --  The purpose is to deal with the situation where an aligment has been
+   --  inherited from a derived type that is no longer appropriate for the
+   --  new Esize value. In this case, we reset the Alignment to unknown.
+
+   procedure Check_Address_Alignment (E : Entity_Id; Expr : Node_Id);
+   --  Given an object entity E, for which the alignment is known, checks
+   --  to see if Expr (the expression from an Address clause) is a known
+   --  at compile time value, and if so posts a warning if the value is
+   --  not consistent with the known alignment requirement. This is not
+   --  an error, but rather leads to erroneous behavior, but we certainly
+   --  may as well give a warning if we detect this situation.
+
+   procedure Check_Component_Overlap (C1_Ent, C2_Ent : Entity_Id);
+   --  Given two entities for record components or discriminants, checks
+   --  if they hav overlapping component clauses and issues errors if so.
+
+   function Get_Alignment_Value (Expr : Node_Id) return Uint;
+   --  Given the expression for an alignment value, returns the corresponding
+   --  Uint value. If the value is inappropriate, then error messages are
+   --  posted as required, and a value of No_Uint is returned.
+
+   function Is_Operational_Item (N : Node_Id) return Boolean;
+   --  A specification for a stream attribute is allowed before the full
+   --  type is declared, as explained in AI-00137 and the corrigendum.
+   --  Attributes that do not specify a representation characteristic are
+   --  operational attributes.
+
+   procedure New_Stream_Function
+     (N    : Node_Id;
+      Ent  : Entity_Id;
+      Subp : Entity_Id;
+      Nam  : Name_Id);
+   --  Create a function renaming of a given stream attribute to the
+   --  designated subprogram and then in the tagged case, provide this as
+   --  a primitive operation, or in the non-tagged case make an appropriate
+   --  TSS entry. Used for Input. This is more properly an expansion activity
+   --  than just semantics, but the presence of user-defined stream functions
+   --  for limited types is a legality check, which is why this takes place
+   --  here rather than in exp_ch13, where it was previously.
+
+   procedure New_Stream_Procedure
+     (N     : Node_Id;
+      Ent   : Entity_Id;
+      Subp  : Entity_Id;
+      Nam   : Name_Id;
+      Out_P : Boolean := False);
+   --  Create a procedure renaming of a given stream attribute to the
+   --  designated subprogram and then in the tagged case, provide this as
+   --  a primitive operation, or in the non-tagged case make an appropriate
+   --  TSS entry. Used for Read, Output, Write.
+
+   procedure Check_Constant_Address_Clause (Expr : Node_Id; U_Ent : Entity_Id);
+   --  Expr is an expression for an address clause. This procedure checks
+   --  that the expression is constant, in the limited sense that it is safe
+   --  to evaluate it at the point the object U_Ent is declared, rather than
+   --  at the point of the address clause. The condition for this to be true
+   --  is that the expression has no variables, no constants declared after
+   --  U_Ent, and no calls to non-pure functions. If this condition is not
+   --  met, then an appropriate error message is posted.
+
+   procedure Warn_Overlay
+     (Expr : Node_Id;
+      Typ  : Entity_Id;
+      Nam  : Node_Id);
+   --  Expr is the expression for an address clause for entity Nam whose type
+   --  is Typ. If Typ has a default initialization, check whether the address
+   --  clause might overlay two entities, and emit a warning on the side effect
+   --  that the initialization will cause.
+
+   ----------------------------------------------
+   -- Table for Validate_Unchecked_Conversions --
+   ----------------------------------------------
+
+   --  The following table collects unchecked conversions for validation.
+   --  Entries are made by Validate_Unchecked_Conversion and then the
+   --  call to Validate_Unchecked_Conversions does the actual error
+   --  checking and posting of warnings. The reason for this delayed
+   --  processing is to take advantage of back-annotations of size and
+   --  alignment values peformed by the back end.
+
+   type UC_Entry is record
+      Enode  : Node_Id;   -- node used for posting warnings
+      Source : Entity_Id; -- source type for unchecked conversion
+      Target : Entity_Id; -- target type for unchecked conversion
+   end record;
+
+   package Unchecked_Conversions is new Table.Table (
+     Table_Component_Type => UC_Entry,
+     Table_Index_Type     => Int,
+     Table_Low_Bound      => 1,
+     Table_Initial        => 50,
+     Table_Increment      => 200,
+     Table_Name           => "Unchecked_Conversions");
+
+   --------------------------------------
+   -- Alignment_Check_For_Esize_Change --
+   --------------------------------------
+
+   procedure Alignment_Check_For_Esize_Change (Typ : Entity_Id) is
+   begin
+      --  If the alignment is known, and not set by a rep clause, and is
+      --  inconsistent with the size being set, then reset it to unknown,
+      --  we assume in this case that the size overrides the inherited
+      --  alignment, and that the alignment must be recomputed.
+
+      if Known_Alignment (Typ)
+        and then not Has_Alignment_Clause (Typ)
+        and then Esize (Typ) mod (Alignment (Typ) * SSU) /= 0
+      then
+         Init_Alignment (Typ);
+      end if;
+   end Alignment_Check_For_Esize_Change;
+
+   -----------------------
+   -- Analyze_At_Clause --
+   -----------------------
+
+   --  An at clause is replaced by the corresponding Address attribute
+   --  definition clause that is the preferred approach in Ada 95.
+
+   procedure Analyze_At_Clause (N : Node_Id) is
+   begin
+      Rewrite (N,
+        Make_Attribute_Definition_Clause (Sloc (N),
+          Name  => Identifier (N),
+          Chars => Name_Address,
+          Expression => Expression (N)));
+      Analyze_Attribute_Definition_Clause (N);
+   end Analyze_At_Clause;
+
+   -----------------------------------------
+   -- Analyze_Attribute_Definition_Clause --
+   -----------------------------------------
+
+   procedure Analyze_Attribute_Definition_Clause (N : Node_Id) is
+      Loc   : constant Source_Ptr   := Sloc (N);
+      Nam   : constant Node_Id      := Name (N);
+      Attr  : constant Name_Id      := Chars (N);
+      Expr  : constant Node_Id      := Expression (N);
+      Id    : constant Attribute_Id := Get_Attribute_Id (Attr);
+      Ent   : Entity_Id;
+      U_Ent : Entity_Id;
+
+      FOnly : Boolean := False;
+      --  Reset to True for subtype specific attribute (Alignment, Size)
+      --  and for stream attributes, i.e. those cases where in the call
+      --  to Rep_Item_Too_Late, FOnly is set True so that only the freezing
+      --  rules are checked. Note that the case of stream attributes is not
+      --  clear from the RM, but see AI95-00137. Also, the RM seems to
+      --  disallow Storage_Size for derived task types, but that is also
+      --  clearly unintentional.
+
+   begin
+      Analyze (Nam);
+      Ent := Entity (Nam);
+
+      if Rep_Item_Too_Early (Ent, N) then
+         return;
+      end if;
+
+      --  Rep clause applies to full view of incomplete type or private type
+      --  if we have one (if not, this is a premature use of the type).
+      --  However, certain semantic checks need to be done on the specified
+      --  entity (i.e. the private view), so we save it in Ent.
+
+      if Is_Private_Type (Ent)
+        and then Is_Derived_Type (Ent)
+        and then not Is_Tagged_Type (Ent)
+        and then No (Full_View (Ent))
+      then
+         --  If this is a private type whose completion is a derivation
+         --  from another private type, there is no full view, and the
+         --  attribute belongs to the type itself, not its underlying parent.
+
+         U_Ent := Ent;
+
+      elsif Ekind (Ent) = E_Incomplete_Type then
+         Ent := Underlying_Type (Ent);
+         U_Ent := Ent;
+      else
+         U_Ent := Underlying_Type (Ent);
+      end if;
+
+      --  Complete other routine error checks
+
+      if Etype (Nam) = Any_Type then
+         return;
+
+      elsif Scope (Ent) /= Current_Scope then
+         Error_Msg_N ("entity must be declared in this scope", Nam);
+         return;
+
+      elsif Is_Type (U_Ent)
+        and then not Is_First_Subtype (U_Ent)
+        and then Id /= Attribute_Object_Size
+        and then Id /= Attribute_Value_Size
+        and then not From_At_Mod (N)
+      then
+         Error_Msg_N ("cannot specify attribute for subtype", Nam);
+         return;
+
+      end if;
+
+      --  Switch on particular attribute
+
+      case Id is
+
+         -------------
+         -- Address --
+         -------------
+
+         --  Address attribute definition clause
+
+         when Attribute_Address => Address : begin
+            Analyze_And_Resolve (Expr, RTE (RE_Address));
+
+            if Present (Address_Clause (U_Ent)) then
+               Error_Msg_N ("address already given for &", Nam);
+
+            --  Case of address clause for subprogram
+
+            elsif Is_Subprogram (U_Ent) then
+
+               if Has_Homonym (U_Ent) then
+                  Error_Msg_N
+                    ("address clause cannot be given " &
+                     "for overloaded subprogram",
+                     Nam);
+               end if;
+
+               --  For subprograms, all address clauses are permitted,
+               --  and we mark the subprogram as having a deferred freeze
+               --  so that Gigi will not elaborate it too soon.
+
+               --  Above needs more comments, what is too soon about???
+
+               Set_Has_Delayed_Freeze (U_Ent);
+
+            --  Case of address clause for entry
+
+            elsif Ekind (U_Ent) = E_Entry then
+
+               if Nkind (Parent (N)) = N_Task_Body then
+                  Error_Msg_N
+                    ("entry address must be specified in task spec", Nam);
+               end if;
+
+               --  For entries, we require a constant address
+
+               Check_Constant_Address_Clause (Expr, U_Ent);
+
+            --  Case of address clause for variable or constant
+
+            elsif
+              Ekind (U_Ent) = E_Variable
+                or else
+              Ekind (U_Ent) = E_Constant
+            then
+               declare
+                  Decl : constant Node_Id   := Declaration_Node (U_Ent);
+                  Expr : constant Node_Id   := Expression (N);
+                  Typ  : constant Entity_Id := Etype (U_Ent);
+
+               begin
+                  --  Exported variables cannot have an address clause,
+                  --  because this cancels the effect of the pragma Export
+
+                  if Is_Exported (U_Ent) then
+                     Error_Msg_N
+                       ("cannot export object with address clause", Nam);
+
+                  --  Imported variables can have an address clause, but then
+                  --  the import is pretty meaningless except to suppress
+                  --  initializations, so we do not need such variables to
+                  --  be statically allocated (and in fact it causes trouble
+                  --  if the address clause is a local value).
+
+                  elsif Is_Imported (U_Ent) then
+                     Set_Is_Statically_Allocated (U_Ent, False);
+                  end if;
+
+                  --  We mark a possible modification of a variable with an
+                  --  address clause, since it is likely aliasing is occurring.
+
+                  Note_Possible_Modification (Nam);
+
+                  --  If we have no initialization of any kind, then we can
+                  --  safely defer the elaboration of the variable to its
+                  --  freezing point, so that the address clause will be
+                  --  computed at the proper point.
+
+                  --  The same processing applies to all initialized scalar
+                  --  types and all access types. Packed bit arrays of size
+                  --  up to 64 are represented using a modular type with an
+                  --  initialization (to zero) and can be processed like
+                  --  other initialized scalar types.
+
+                  if (No (Expression (Decl))
+                       and then not Has_Non_Null_Base_Init_Proc (Typ))
+
+                    or else
+                      (Present (Expression (Decl))
+                        and then Is_Scalar_Type (Typ))
+
+                    or else
+                      Is_Access_Type (Typ)
+
+                    or else
+                      (Is_Bit_Packed_Array (Base_Type (Typ))
+                        and then
+                          Is_Modular_Integer_Type (Packed_Array_Type (Typ)))
+                  then
+                     Set_Has_Delayed_Freeze (U_Ent);
+
+                  --  Otherwise, we require the address clause to be constant
+
+                  else
+                     Check_Constant_Address_Clause (Expr, U_Ent);
+                  end if;
+
+                  if Is_Exported (U_Ent) then
+                     Error_Msg_N
+                       ("& cannot be exported if an address clause is given",
+                        Nam);
+                     Error_Msg_N
+                       ("\define and export a variable " &
+                        "that holds its address instead",
+                        Nam);
+                  end if;
+
+                  if not Error_Posted (Expr) then
+                     Warn_Overlay (Expr, Typ, Nam);
+                  end if;
+
+                  --  Check for bad alignment
+
+                  if Known_Alignment (U_Ent) then
+                     Check_Address_Alignment (U_Ent, Expr);
+                  end if;
+
+                  --  Kill the size check code, since we are not allocating
+                  --  the variable, it is somewhere else.
+
+                  Kill_Size_Check_Code (U_Ent);
+               end;
+
+            --  Not a valid entity for an address clause
+
+            else
+               Error_Msg_N ("address cannot be given for &", Nam);
+            end if;
+         end Address;
+
+         ---------------
+         -- Alignment --
+         ---------------
+
+         --  Alignment attribute definition clause
+
+         when Attribute_Alignment => Alignment_Block : declare
+            Align : Uint := Get_Alignment_Value (Expr);
+
+         begin
+            FOnly := True;
+
+            if not Is_Type (U_Ent)
+              and then Ekind (U_Ent) /= E_Variable
+              and then Ekind (U_Ent) /= E_Constant
+            then
+               Error_Msg_N ("alignment cannot be given for &", Nam);
+
+            elsif Has_Alignment_Clause (U_Ent) then
+               Error_Msg_Sloc := Sloc (Alignment_Clause (U_Ent));
+               Error_Msg_N ("alignment clause previously given#", N);
+
+            elsif Align /= No_Uint then
+               Set_Has_Alignment_Clause (U_Ent);
+               Set_Alignment            (U_Ent, Align);
+            end if;
+         end Alignment_Block;
+
+         ---------------
+         -- Bit_Order --
+         ---------------
+
+         --  Bit_Order attribute definition clause
+
+         when Attribute_Bit_Order => Bit_Order : declare
+         begin
+            if not Is_Record_Type (U_Ent) then
+               Error_Msg_N
+                 ("Bit_Order can only be defined for record type", Nam);
+
+            else
+               Analyze_And_Resolve (Expr, RTE (RE_Bit_Order));
+
+               if Etype (Expr) = Any_Type then
+                  return;
+
+               elsif not Is_Static_Expression (Expr) then
+                  Error_Msg_N ("Bit_Order requires static expression", Expr);
+
+               else
+                  if (Expr_Value (Expr) = 0) /= Bytes_Big_Endian then
+                     Set_Reverse_Bit_Order (U_Ent, True);
+                  end if;
+               end if;
+            end if;
+         end Bit_Order;
+
+         --------------------
+         -- Component_Size --
+         --------------------
+
+         --  Component_Size attribute definition clause
+
+         when Attribute_Component_Size => Component_Size_Case : declare
+            Csize    : constant Uint := Static_Integer (Expr);
+            Btype    : Entity_Id;
+            Biased   : Boolean;
+            New_Ctyp : Entity_Id;
+            Decl     : Node_Id;
+
+         begin
+            if not Is_Array_Type (U_Ent) then
+               Error_Msg_N ("component size requires array type", Nam);
+               return;
+            end if;
+
+            Btype := Base_Type (U_Ent);
+
+            if Has_Component_Size_Clause (Btype) then
+               Error_Msg_N
+                 ("component size clase for& previously given", Nam);
+
+            elsif Csize /= No_Uint then
+               Check_Size (Expr, Component_Type (Btype), Csize, Biased);
+
+               if Has_Aliased_Components (Btype)
+                 and then Csize < 32
+                 and then Csize /= 8
+                 and then Csize /= 16
+               then
+                  Error_Msg_N
+                    ("component size incorrect for aliased components", N);
+                  return;
+               end if;
+
+               --  For the biased case, build a declaration for a subtype
+               --  that will be used to represent the biased subtype that
+               --  reflects the biased representation of components. We need
+               --  this subtype to get proper conversions on referencing
+               --  elements of the array.
+
+               if Biased then
+                  New_Ctyp :=
+                    Make_Defining_Identifier (Loc,
+                      Chars => New_External_Name (Chars (U_Ent), 'C', 0, 'T'));
+
+                  Decl :=
+                    Make_Subtype_Declaration (Loc,
+                      Defining_Identifier => New_Ctyp,
+                      Subtype_Indication  =>
+                        New_Occurrence_Of (Component_Type (Btype), Loc));
+
+                  Set_Parent (Decl, N);
+                  Analyze (Decl, Suppress => All_Checks);
+
+                  Set_Has_Delayed_Freeze        (New_Ctyp, False);
+                  Set_Esize                     (New_Ctyp, Csize);
+                  Set_RM_Size                   (New_Ctyp, Csize);
+                  Init_Alignment                (New_Ctyp);
+                  Set_Has_Biased_Representation (New_Ctyp, True);
+                  Set_Is_Itype                  (New_Ctyp, True);
+                  Set_Associated_Node_For_Itype (New_Ctyp, U_Ent);
+
+                  Set_Component_Type (Btype, New_Ctyp);
+               end if;
+
+               Set_Component_Size            (Btype, Csize);
+               Set_Has_Component_Size_Clause (Btype, True);
+               Set_Has_Non_Standard_Rep      (Btype, True);
+            end if;
+         end Component_Size_Case;
+
+         ------------------
+         -- External_Tag --
+         ------------------
+
+         when Attribute_External_Tag => External_Tag :
+         begin
+            if not Is_Tagged_Type (U_Ent) then
+               Error_Msg_N ("should be a tagged type", Nam);
+            end if;
+
+            Analyze_And_Resolve (Expr, Standard_String);
+
+            if not Is_Static_Expression (Expr) then
+               Error_Msg_N ("must be a static string", Nam);
+            end if;
+
+            Set_Has_External_Tag_Rep_Clause (U_Ent);
+         end External_Tag;
+
+         -----------
+         -- Input --
+         -----------
+
+         when Attribute_Input => Input : declare
+            Subp : Entity_Id := Empty;
+            I    : Interp_Index;
+            It   : Interp;
+            Pnam : Entity_Id;
+
+            function Has_Good_Profile (Subp : Entity_Id) return Boolean;
+            --  Return true if the entity is a function with an appropriate
+            --  profile for the Input attribute.
+
+            function Has_Good_Profile (Subp : Entity_Id) return Boolean is
+               F  : Entity_Id;
+               Ok : Boolean := False;
+
+            begin
+               if Ekind (Subp) = E_Function then
+                  F := First_Formal (Subp);
+
+                  if Present (F) and then No (Next_Formal (F)) then
+                     if Ekind (Etype (F)) = E_Anonymous_Access_Type
+                       and then
+                         Designated_Type (Etype (F)) =
+                           Class_Wide_Type (RTE (RE_Root_Stream_Type))
+                     then
+                        Ok := Base_Type (Etype (Subp)) = Base_Type (Ent);
+                     end if;
+                  end if;
+               end if;
+
+               return Ok;
+            end Has_Good_Profile;
+
+         --  Start of processing for Input attribute definition
+
+         begin
+            FOnly := True;
+
+            if not Is_Type (U_Ent) then
+               Error_Msg_N ("local name must be a subtype", Nam);
+               return;
+
+            else
+               Pnam := TSS (Base_Type (U_Ent), Name_uInput);
+
+               if Present (Pnam)
+                 and then Base_Type (Etype (Pnam)) = Base_Type (U_Ent)
+               then
+                  Error_Msg_Sloc := Sloc (Pnam);
+                  Error_Msg_N ("input attribute already defined #", Nam);
+                  return;
+               end if;
+            end if;
+
+            Analyze (Expr);
+
+            if Is_Entity_Name (Expr) then
+               if not Is_Overloaded (Expr) then
+                  if Has_Good_Profile (Entity (Expr)) then
+                     Subp := Entity (Expr);
+                  end if;
+
+               else
+                  Get_First_Interp (Expr, I, It);
+
+                  while Present (It.Nam) loop
+                     if Has_Good_Profile (It.Nam) then
+                        Subp := It.Nam;
+                        exit;
+                     end if;
+
+                     Get_Next_Interp (I, It);
+                  end loop;
+               end if;
+            end if;
+
+            if Present (Subp) then
+               Set_Entity (Expr, Subp);
+               Set_Etype (Expr, Etype (Subp));
+               New_Stream_Function (N, U_Ent, Subp,  Name_uInput);
+            else
+               Error_Msg_N ("incorrect expression for input attribute", Expr);
+               return;
+            end if;
+         end Input;
+
+         -------------------
+         -- Machine_Radix --
+         -------------------
+
+         --  Machine radix attribute definition clause
+
+         when Attribute_Machine_Radix => Machine_Radix : declare
+            Radix : constant Uint := Static_Integer (Expr);
+
+         begin
+            if not Is_Decimal_Fixed_Point_Type (U_Ent) then
+               Error_Msg_N ("decimal fixed-point type expected for &", Nam);
+
+            elsif Has_Machine_Radix_Clause (U_Ent) then
+               Error_Msg_Sloc := Sloc (Alignment_Clause (U_Ent));
+               Error_Msg_N ("machine radix clause previously given#", N);
+
+            elsif Radix /= No_Uint then
+               Set_Has_Machine_Radix_Clause (U_Ent);
+               Set_Has_Non_Standard_Rep (Base_Type (U_Ent));
+
+               if Radix = 2 then
+                  null;
+               elsif Radix = 10 then
+                  Set_Machine_Radix_10 (U_Ent);
+               else
+                  Error_Msg_N ("machine radix value must be 2 or 10", Expr);
+               end if;
+            end if;
+         end Machine_Radix;
+
+         -----------------
+         -- Object_Size --
+         -----------------
+
+         --  Object_Size attribute definition clause
+
+         when Attribute_Object_Size => Object_Size : declare
+            Size   : constant Uint := Static_Integer (Expr);
+            Biased : Boolean;
+
+         begin
+            if not Is_Type (U_Ent) then
+               Error_Msg_N ("Object_Size cannot be given for &", Nam);
+
+            elsif Has_Object_Size_Clause (U_Ent) then
+               Error_Msg_N ("Object_Size already given for &", Nam);
+
+            else
+               Check_Size (Expr, U_Ent, Size, Biased);
+
+               if Size /= 8
+                    and then
+                  Size /= 16
+                    and then
+                  Size /= 32
+                    and then
+                  UI_Mod (Size, 64) /= 0
+               then
+                  Error_Msg_N
+                    ("Object_Size must be 8, 16, 32, or multiple of 64",
+                     Expr);
+               end if;
+
+               Set_Esize (U_Ent, Size);
+               Set_Has_Object_Size_Clause (U_Ent);
+               Alignment_Check_For_Esize_Change (U_Ent);
+            end if;
+         end Object_Size;
+
+         ------------
+         -- Output --
+         ------------
+
+         when Attribute_Output => Output : declare
+            Subp : Entity_Id := Empty;
+            I    : Interp_Index;
+            It   : Interp;
+            Pnam : Entity_Id;
+
+            function Has_Good_Profile (Subp : Entity_Id) return Boolean;
+            --  Return true if the entity is a procedure with an
+            --  appropriate profile for the output attribute.
+
+            function Has_Good_Profile (Subp : Entity_Id) return Boolean is
+               F  : Entity_Id;
+               Ok : Boolean := False;
+
+            begin
+               if Ekind (Subp) = E_Procedure then
+                  F := First_Formal (Subp);
+
+                  if Present (F) then
+                     if Ekind (Etype (F)) = E_Anonymous_Access_Type
+                       and then
+                         Designated_Type (Etype (F)) =
+                           Class_Wide_Type (RTE (RE_Root_Stream_Type))
+                     then
+                        Next_Formal (F);
+                        Ok :=  Present (F)
+                          and then Parameter_Mode (F) = E_In_Parameter
+                          and then Base_Type (Etype (F)) = Base_Type (Ent)
+                          and then No (Next_Formal (F));
+                     end if;
+                  end if;
+               end if;
+
+               return Ok;
+            end Has_Good_Profile;
+
+         begin
+            FOnly := True;
+
+            if not Is_Type (U_Ent) then
+               Error_Msg_N ("local name must be a subtype", Nam);
+               return;
+
+            else
+               Pnam := TSS (Base_Type (U_Ent), Name_uOutput);
+
+               if Present (Pnam)
+                 and then
+                   Base_Type (Etype (Next_Formal (First_Formal (Pnam))))
+                                                        = Base_Type (U_Ent)
+               then
+                  Error_Msg_Sloc := Sloc (Pnam);
+                  Error_Msg_N ("output attribute already defined #", Nam);
+                  return;
+               end if;
+            end if;
+
+            Analyze (Expr);
+
+            if Is_Entity_Name (Expr) then
+               if not Is_Overloaded (Expr) then
+                  if Has_Good_Profile (Entity (Expr)) then
+                     Subp := Entity (Expr);
+                  end if;
+
+               else
+                  Get_First_Interp (Expr, I, It);
+
+                  while Present (It.Nam) loop
+                     if Has_Good_Profile (It.Nam) then
+                        Subp := It.Nam;
+                        exit;
+                     end if;
+
+                     Get_Next_Interp (I, It);
+                  end loop;
+               end if;
+            end if;
+
+            if Present (Subp) then
+               Set_Entity (Expr, Subp);
+               Set_Etype (Expr, Etype (Subp));
+               New_Stream_Procedure (N, U_Ent, Subp, Name_uOutput);
+            else
+               Error_Msg_N ("incorrect expression for output attribute", Expr);
+               return;
+            end if;
+         end Output;
+
+         ----------
+         -- Read --
+         ----------
+
+         when Attribute_Read => Read : declare
+            Subp : Entity_Id := Empty;
+            I    : Interp_Index;
+            It   : Interp;
+            Pnam : Entity_Id;
+
+            function Has_Good_Profile (Subp : Entity_Id) return Boolean;
+            --  Return true if the entity is a procedure with an appropriate
+            --  profile for the Read attribute.
+
+            function Has_Good_Profile (Subp : Entity_Id) return Boolean is
+               F     : Entity_Id;
+               Ok    : Boolean := False;
+
+            begin
+               if Ekind (Subp) = E_Procedure then
+                  F := First_Formal (Subp);
+
+                  if Present (F) then
+                     if Ekind (Etype (F)) = E_Anonymous_Access_Type
+                       and then
+                         Designated_Type (Etype (F)) =
+                           Class_Wide_Type (RTE (RE_Root_Stream_Type))
+                     then
+                        Next_Formal (F);
+                        Ok :=  Present (F)
+                          and then Parameter_Mode (F) = E_Out_Parameter
+                          and then Base_Type (Etype (F)) = Base_Type (Ent)
+                          and then No (Next_Formal (F));
+                     end if;
+                  end if;
+               end if;
+
+               return Ok;
+            end Has_Good_Profile;
+
+         --  Start of processing for Read attribute definition
+
+         begin
+            FOnly := True;
+
+            if not Is_Type (U_Ent) then
+               Error_Msg_N ("local name must be a subtype", Nam);
+               return;
+
+            else
+               Pnam := TSS (Base_Type (U_Ent), Name_uRead);
+
+               if Present (Pnam)
+                 and then Base_Type (Etype (Next_Formal (First_Formal (Pnam))))
+                   = Base_Type (U_Ent)
+               then
+                  Error_Msg_Sloc := Sloc (Pnam);
+                  Error_Msg_N ("read attribute already defined #", Nam);
+                  return;
+               end if;
+            end if;
+
+            Analyze (Expr);
+
+            if Is_Entity_Name (Expr) then
+               if not Is_Overloaded (Expr) then
+                  if Has_Good_Profile (Entity (Expr)) then
+                     Subp := Entity (Expr);
+                  end if;
+
+               else
+                  Get_First_Interp (Expr, I, It);
+
+                  while Present (It.Nam) loop
+                     if Has_Good_Profile (It.Nam) then
+                        Subp := It.Nam;
+                        exit;
+                     end if;
+
+                     Get_Next_Interp (I, It);
+                  end loop;
+               end if;
+            end if;
+
+            if Present (Subp) then
+               Set_Entity (Expr, Subp);
+               Set_Etype (Expr, Etype (Subp));
+               New_Stream_Procedure (N, U_Ent, Subp, Name_uRead, True);
+            else
+               Error_Msg_N ("incorrect expression for read attribute", Expr);
+               return;
+            end if;
+         end Read;
+
+         ----------
+         -- Size --
+         ----------
+
+         --  Size attribute definition clause
+
+         when Attribute_Size => Size : declare
+            Size   : constant Uint := Static_Integer (Expr);
+            Etyp   : Entity_Id;
+            Biased : Boolean;
+
+         begin
+            FOnly := True;
+
+            if Has_Size_Clause (U_Ent) then
+               Error_Msg_N ("size already given for &", Nam);
+
+            elsif not Is_Type (U_Ent)
+              and then Ekind (U_Ent) /= E_Variable
+              and then Ekind (U_Ent) /= E_Constant
+            then
+               Error_Msg_N ("size cannot be given for &", Nam);
+
+            elsif Is_Array_Type (U_Ent)
+              and then not Is_Constrained (U_Ent)
+            then
+               Error_Msg_N
+                 ("size cannot be given for unconstrained array", Nam);
+
+            elsif Size /= No_Uint then
+
+               if Is_Type (U_Ent) then
+                  Etyp := U_Ent;
+               else
+                  Etyp := Etype (U_Ent);
+               end if;
+
+               --  Check size, note that Gigi is in charge of checking
+               --  that the size of an array or record type is OK. Also
+               --  we do not check the size in the ordinary fixed-point
+               --  case, since it is too early to do so (there may be a
+               --  subsequent small clause that affects the size). We can
+               --  check the size if a small clause has already been given.
+
+               if not Is_Ordinary_Fixed_Point_Type (U_Ent)
+                 or else Has_Small_Clause (U_Ent)
+               then
+                  Check_Size (Expr, Etyp, Size, Biased);
+                  Set_Has_Biased_Representation (U_Ent, Biased);
+               end if;
+
+               --  For types set RM_Size and Esize if possible
+
+               if Is_Type (U_Ent) then
+                  Set_RM_Size (U_Ent, Size);
+
+                  --  For scalar types, increase Object_Size to power of 2,
+                  --  but not less than 8 in any case, i.e. byte addressable.
+
+                  if Is_Scalar_Type (U_Ent) then
+                     if Size <= 8 then
+                        Init_Esize (U_Ent, 8);
+                     elsif Size <= 16 then
+                        Init_Esize (U_Ent, 16);
+                     elsif Size <= 32 then
+                        Init_Esize (U_Ent, 32);
+                     else
+                        Set_Esize  (U_Ent, (Size + 63) / 64 * 64);
+                     end if;
+
+                  --  For all other types, object size = value size. The
+                  --  backend will adjust as needed.
+
+                  else
+                     Set_Esize (U_Ent, Size);
+                  end if;
+
+                  Alignment_Check_For_Esize_Change (U_Ent);
+
+               --  For objects, set Esize only
+
+               else
+                  Set_Esize (U_Ent, Size);
+               end if;
+
+               Set_Has_Size_Clause (U_Ent);
+            end if;
+         end Size;
+
+         -----------
+         -- Small --
+         -----------
+
+         --  Small attribute definition clause
+
+         when Attribute_Small => Small : declare
+            Implicit_Base : constant Entity_Id := Base_Type (U_Ent);
+            Small         : Ureal;
+
+         begin
+            Analyze_And_Resolve (Expr, Any_Real);
+
+            if Etype (Expr) = Any_Type then
+               return;
+
+            elsif not Is_Static_Expression (Expr) then
+               Error_Msg_N ("small requires static expression", Expr);
+               return;
+
+            else
+               Small := Expr_Value_R (Expr);
+
+               if Small <= Ureal_0 then
+                  Error_Msg_N ("small value must be greater than zero", Expr);
+                  return;
+               end if;
+
+            end if;
+
+            if not Is_Ordinary_Fixed_Point_Type (U_Ent) then
+               Error_Msg_N
+                 ("small requires an ordinary fixed point type", Nam);
+
+            elsif Has_Small_Clause (U_Ent) then
+               Error_Msg_N ("small already given for &", Nam);
+
+            elsif Small > Delta_Value (U_Ent) then
+               Error_Msg_N
+                 ("small value must not be greater then delta value", Nam);
+
+            else
+               Set_Small_Value (U_Ent, Small);
+               Set_Small_Value (Implicit_Base, Small);
+               Set_Has_Small_Clause (U_Ent);
+               Set_Has_Small_Clause (Implicit_Base);
+               Set_Has_Non_Standard_Rep (Implicit_Base);
+            end if;
+         end Small;
+
+         ------------------
+         -- Storage_Size --
+         ------------------
+
+         --  Storage_Size attribute definition clause
+
+         when Attribute_Storage_Size => Storage_Size : declare
+            Btype : constant Entity_Id := Base_Type (U_Ent);
+            Sprag : Node_Id;
+
+         begin
+            if Is_Task_Type (U_Ent) then
+               FOnly := True;
+            end if;
+
+            if not Is_Access_Type (U_Ent)
+              and then Ekind (U_Ent) /= E_Task_Type
+            then
+               Error_Msg_N ("storage size cannot be given for &", Nam);
+
+            elsif Is_Access_Type (U_Ent) and Is_Derived_Type (U_Ent) then
+               Error_Msg_N
+                 ("storage size cannot be given for a derived access type",
+                  Nam);
+
+            elsif Has_Storage_Size_Clause (Btype) then
+               Error_Msg_N ("storage size already given for &", Nam);
+
+            else
+               Analyze_And_Resolve (Expr, Any_Integer);
+
+               if Is_Access_Type (U_Ent) then
+
+                  if Present (Associated_Storage_Pool (U_Ent)) then
+                     Error_Msg_N ("storage pool already given for &", Nam);
+                     return;
+                  end if;
+
+                  if Compile_Time_Known_Value (Expr)
+                    and then Expr_Value (Expr) = 0
+                  then
+                     Set_No_Pool_Assigned (Btype);
+                  end if;
+
+               else -- Is_Task_Type (U_Ent)
+                  Sprag := Get_Rep_Pragma (Btype, Name_Storage_Size);
+
+                  if Present (Sprag) then
+                     Error_Msg_Sloc := Sloc (Sprag);
+                     Error_Msg_N
+                       ("Storage_Size already specified#", Nam);
+                     return;
+                  end if;
+               end if;
+
+               Set_Has_Storage_Size_Clause (Btype);
+            end if;
+         end Storage_Size;
+
+         ------------------
+         -- Storage_Pool --
+         ------------------
+
+         --  Storage_Pool attribute definition clause
+
+         when Attribute_Storage_Pool => Storage_Pool : declare
+            Pool : Entity_Id;
+
+         begin
+            if Ekind (U_Ent) /= E_Access_Type
+              and then Ekind (U_Ent) /= E_General_Access_Type
+            then
+               Error_Msg_N (
+                 "storage pool can only be given for access types", Nam);
+               return;
+
+            elsif Is_Derived_Type (U_Ent) then
+               Error_Msg_N
+                 ("storage pool cannot be given for a derived access type",
+                  Nam);
+
+            elsif Has_Storage_Size_Clause (U_Ent) then
+               Error_Msg_N ("storage size already given for &", Nam);
+               return;
+
+            elsif Present (Associated_Storage_Pool (U_Ent)) then
+               Error_Msg_N ("storage pool already given for &", Nam);
+               return;
+            end if;
+
+            Analyze_And_Resolve
+              (Expr, Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
+
+            --  If the argument is a name that is not an entity name, then
+            --  we construct a renaming operation to define an entity of
+            --  type storage pool.
+
+            if not Is_Entity_Name (Expr)
+              and then Is_Object_Reference (Expr)
+            then
+               Pool :=
+                 Make_Defining_Identifier (Loc,
+                   Chars => New_Internal_Name ('P'));
+
+               declare
+                  Rnode : constant Node_Id :=
+                            Make_Object_Renaming_Declaration (Loc,
+                              Defining_Identifier => Pool,
+                              Subtype_Mark        =>
+                                New_Occurrence_Of (Etype (Expr), Loc),
+                              Name => Expr);
+
+               begin
+                  Insert_Before (N, Rnode);
+                  Analyze (Rnode);
+                  Set_Associated_Storage_Pool (U_Ent, Pool);
+               end;
+
+            elsif Is_Entity_Name (Expr) then
+               Pool := Entity (Expr);
+
+               --  If pool is a renamed object, get original one. This can
+               --  happen with an explicit renaming, and within instances.
+
+               while Present (Renamed_Object (Pool))
+                 and then Is_Entity_Name (Renamed_Object (Pool))
+               loop
+                  Pool := Entity (Renamed_Object (Pool));
+               end loop;
+
+               if Present (Renamed_Object (Pool))
+                 and then Nkind (Renamed_Object (Pool)) = N_Type_Conversion
+                 and then Is_Entity_Name (Expression (Renamed_Object (Pool)))
+               then
+                  Pool := Entity (Expression (Renamed_Object (Pool)));
+               end if;
+
+               if Present (Etype (Pool))
+                 and then Etype (Pool) /= RTE (RE_Stack_Bounded_Pool)
+                 and then Etype (Pool) /= RTE (RE_Unbounded_Reclaim_Pool)
+               then
+                  Set_Associated_Storage_Pool (U_Ent, Pool);
+               else
+                  Error_Msg_N ("Non sharable GNAT Pool", Expr);
+               end if;
+
+            --  The pool may be specified as the Storage_Pool of some other
+            --  type. It is rewritten as a class_wide conversion of the
+            --  corresponding pool entity.
+
+            elsif Nkind (Expr) = N_Type_Conversion
+              and then Is_Entity_Name (Expression (Expr))
+              and then Nkind (Original_Node (Expr)) = N_Attribute_Reference
+            then
+               Pool := Entity (Expression (Expr));
+
+               if Present (Etype (Pool))
+                 and then Etype (Pool) /= RTE (RE_Stack_Bounded_Pool)
+                 and then Etype (Pool) /= RTE (RE_Unbounded_Reclaim_Pool)
+               then
+                  Set_Associated_Storage_Pool (U_Ent, Pool);
+               else
+                  Error_Msg_N ("Non sharable GNAT Pool", Expr);
+               end if;
+
+            else
+               Error_Msg_N ("incorrect reference to a Storage Pool", Expr);
+               return;
+            end if;
+         end Storage_Pool;
+
+         ----------------
+         -- Value_Size --
+         ----------------
+
+         --  Value_Size attribute definition clause
+
+         when Attribute_Value_Size => Value_Size : declare
+            Size   : constant Uint := Static_Integer (Expr);
+            Biased : Boolean;
+
+         begin
+            if not Is_Type (U_Ent) then
+               Error_Msg_N ("Value_Size cannot be given for &", Nam);
+
+            elsif Present
+                   (Get_Attribute_Definition_Clause
+                     (U_Ent, Attribute_Value_Size))
+            then
+               Error_Msg_N ("Value_Size already given for &", Nam);
+
+            else
+               if Is_Elementary_Type (U_Ent) then
+                  Check_Size (Expr, U_Ent, Size, Biased);
+                  Set_Has_Biased_Representation (U_Ent, Biased);
+               end if;
+
+               Set_RM_Size (U_Ent, Size);
+            end if;
+         end Value_Size;
+
+         -----------
+         -- Write --
+         -----------
+
+         --  Write attribute definition clause
+         --  check for class-wide case will be performed later
+
+         when Attribute_Write => Write : declare
+            Subp : Entity_Id := Empty;
+            I    : Interp_Index;
+            It   : Interp;
+            Pnam : Entity_Id;
+
+            function Has_Good_Profile (Subp : Entity_Id) return Boolean;
+            --  Return true if the entity is a procedure with an
+            --  appropriate profile for the write attribute.
+
+            function Has_Good_Profile (Subp : Entity_Id) return Boolean is
+               F     : Entity_Id;
+               Ok    : Boolean := False;
+
+            begin
+               if Ekind (Subp) = E_Procedure then
+                  F := First_Formal (Subp);
+
+                  if Present (F) then
+                     if Ekind (Etype (F)) = E_Anonymous_Access_Type
+                       and then
+                         Designated_Type (Etype (F)) =
+                           Class_Wide_Type (RTE (RE_Root_Stream_Type))
+                     then
+                        Next_Formal (F);
+                        Ok :=  Present (F)
+                          and then Parameter_Mode (F) = E_In_Parameter
+                          and then Base_Type (Etype (F)) = Base_Type (Ent)
+                          and then No (Next_Formal (F));
+                     end if;
+                  end if;
+               end if;
+
+               return Ok;
+            end Has_Good_Profile;
+
+         --  Start of processing for Write attribute definition
+
+         begin
+            FOnly := True;
+
+            if not Is_Type (U_Ent) then
+               Error_Msg_N ("local name must be a subtype", Nam);
+               return;
+            end if;
+
+            Pnam := TSS (Base_Type (U_Ent), Name_uWrite);
+
+            if Present (Pnam)
+              and then Base_Type (Etype (Next_Formal (First_Formal (Pnam))))
+                = Base_Type (U_Ent)
+            then
+               Error_Msg_Sloc := Sloc (Pnam);
+               Error_Msg_N ("write attribute already defined #", Nam);
+               return;
+            end if;
+
+            Analyze (Expr);
+
+            if Is_Entity_Name (Expr) then
+               if not Is_Overloaded (Expr) then
+                  if Has_Good_Profile (Entity (Expr)) then
+                     Subp := Entity (Expr);
+                  end if;
+
+               else
+                  Get_First_Interp (Expr, I, It);
+
+                  while Present (It.Nam) loop
+                     if Has_Good_Profile (It.Nam) then
+                        Subp := It.Nam;
+                        exit;
+                     end if;
+
+                     Get_Next_Interp (I, It);
+                  end loop;
+               end if;
+            end if;
+
+            if Present (Subp) then
+               Set_Entity (Expr, Subp);
+               Set_Etype (Expr, Etype (Subp));
+               New_Stream_Procedure (N, U_Ent, Subp, Name_uWrite);
+            else
+               Error_Msg_N ("incorrect expression for write attribute", Expr);
+               return;
+            end if;
+         end Write;
+
+         --  All other attributes cannot be set
+
+         when others =>
+            Error_Msg_N
+              ("attribute& cannot be set with definition clause", N);
+
+      end case;
+
+      --  The test for the type being frozen must be performed after
+      --  any expression the clause has been analyzed since the expression
+      --  itself might cause freezing that makes the clause illegal.
+
+      if Rep_Item_Too_Late (U_Ent, N, FOnly) then
+         return;
+      end if;
+   end Analyze_Attribute_Definition_Clause;
+
+   ----------------------------
+   -- Analyze_Code_Statement --
+   ----------------------------
+
+   procedure Analyze_Code_Statement (N : Node_Id) is
+      HSS   : constant Node_Id   := Parent (N);
+      SBody : constant Node_Id   := Parent (HSS);
+      Subp  : constant Entity_Id := Current_Scope;
+      Stmt  : Node_Id;
+      Decl  : Node_Id;
+      StmtO : Node_Id;
+      DeclO : Node_Id;
+
+   begin
+      --  Analyze and check we get right type, note that this implements the
+      --  requirement (RM 13.8(1)) that Machine_Code be with'ed, since that
+      --  is the only way that Asm_Insn could possibly be visible.
+
+      Analyze_And_Resolve (Expression (N));
+
+      if Etype (Expression (N)) = Any_Type then
+         return;
+      elsif Etype (Expression (N)) /= RTE (RE_Asm_Insn) then
+         Error_Msg_N ("incorrect type for code statement", N);
+         return;
+      end if;
+
+      --  Make sure we appear in the handled statement sequence of a
+      --  subprogram (RM 13.8(3)).
+
+      if Nkind (HSS) /= N_Handled_Sequence_Of_Statements
+        or else Nkind (SBody) /= N_Subprogram_Body
+      then
+         Error_Msg_N
+           ("code statement can only appear in body of subprogram", N);
+         return;
+      end if;
+
+      --  Do remaining checks (RM 13.8(3)) if not already done
+
+      if not Is_Machine_Code_Subprogram (Subp) then
+         Set_Is_Machine_Code_Subprogram (Subp);
+
+         --  No exception handlers allowed
+
+         if Present (Exception_Handlers (HSS)) then
+            Error_Msg_N
+              ("exception handlers not permitted in machine code subprogram",
+               First (Exception_Handlers (HSS)));
+         end if;
+
+         --  No declarations other than use clauses and pragmas (we allow
+         --  certain internally generated declarations as well).
+
+         Decl := First (Declarations (SBody));
+         while Present (Decl) loop
+            DeclO := Original_Node (Decl);
+            if Comes_From_Source (DeclO)
+              and then Nkind (DeclO) /= N_Pragma
+              and then Nkind (DeclO) /= N_Use_Package_Clause
+              and then Nkind (DeclO) /= N_Use_Type_Clause
+              and then Nkind (DeclO) /= N_Implicit_Label_Declaration
+            then
+               Error_Msg_N
+                 ("this declaration not allowed in machine code subprogram",
+                  DeclO);
+            end if;
+
+            Next (Decl);
+         end loop;
+
+         --  No statements other than code statements, pragmas, and labels.
+         --  Again we allow certain internally generated statements.
+
+         Stmt := First (Statements (HSS));
+         while Present (Stmt) loop
+            StmtO := Original_Node (Stmt);
+            if Comes_From_Source (StmtO)
+              and then Nkind (StmtO) /= N_Pragma
+              and then Nkind (StmtO) /= N_Label
+              and then Nkind (StmtO) /= N_Code_Statement
+            then
+               Error_Msg_N
+                 ("this statement is not allowed in machine code subprogram",
+                  StmtO);
+            end if;
+
+            Next (Stmt);
+         end loop;
+      end if;
+
+   end Analyze_Code_Statement;
+
+   -----------------------------------------------
+   -- Analyze_Enumeration_Representation_Clause --
+   -----------------------------------------------
+
+   procedure Analyze_Enumeration_Representation_Clause (N : Node_Id) is
+      Ident    : constant Node_Id    := Identifier (N);
+      Aggr     : constant Node_Id    := Array_Aggregate (N);
+      Enumtype : Entity_Id;
+      Elit     : Entity_Id;
+      Expr     : Node_Id;
+      Assoc    : Node_Id;
+      Choice   : Node_Id;
+      Val      : Uint;
+      Err      : Boolean := False;
+
+      Lo  : constant Uint := Expr_Value (Type_Low_Bound (Universal_Integer));
+      Hi  : constant Uint := Expr_Value (Type_High_Bound (Universal_Integer));
+      Min : Uint;
+      Max : Uint;
+
+   begin
+      --  First some basic error checks
+
+      Find_Type (Ident);
+      Enumtype := Entity (Ident);
+
+      if Enumtype = Any_Type
+        or else Rep_Item_Too_Early (Enumtype, N)
+      then
+         return;
+      else
+         Enumtype := Underlying_Type (Enumtype);
+      end if;
+
+      if not Is_Enumeration_Type (Enumtype) then
+         Error_Msg_NE
+           ("enumeration type required, found}",
+            Ident, First_Subtype (Enumtype));
+         return;
+      end if;
+
+      if Scope (Enumtype) /= Current_Scope then
+         Error_Msg_N ("type must be declared in this scope", Ident);
+         return;
+
+      elsif not Is_First_Subtype (Enumtype) then
+         Error_Msg_N ("cannot give enumeration rep clause for subtype", N);
+         return;
+
+      elsif Has_Enumeration_Rep_Clause (Enumtype) then
+         Error_Msg_N ("duplicate enumeration rep clause ignored", N);
+         return;
+
+      elsif Root_Type (Enumtype) = Standard_Character
+        or else Root_Type (Enumtype) = Standard_Wide_Character
+      then
+         Error_Msg_N ("enumeration rep clause not allowed for this type", N);
+
+      else
+         Set_Has_Enumeration_Rep_Clause (Enumtype);
+         Set_Has_Enumeration_Rep_Clause (Base_Type (Enumtype));
+      end if;
+
+      --  Now we process the aggregate. Note that we don't use the normal
+      --  aggregate code for this purpose, because we don't want any of the
+      --  normal expansion activities, and a number of special semantic
+      --  rules apply (including the component type being any integer type)
+
+      --  Badent signals that we found some incorrect entries processing
+      --  the list. The final checks for completeness and ordering are
+      --  skipped in this case.
+
+      Elit := First_Literal (Enumtype);
+
+      --  First the positional entries if any
+
+      if Present (Expressions (Aggr)) then
+         Expr := First (Expressions (Aggr));
+         while Present (Expr) loop
+            if No (Elit) then
+               Error_Msg_N ("too many entries in aggregate", Expr);
+               return;
+            end if;
+
+            Val := Static_Integer (Expr);
+
+            if Val = No_Uint then
+               Err := True;
+
+            elsif Val < Lo or else Hi < Val then
+               Error_Msg_N ("value outside permitted range", Expr);
+               Err := True;
+            end if;
+
+            Set_Enumeration_Rep (Elit, Val);
+            Set_Enumeration_Rep_Expr (Elit, Expr);
+            Next (Expr);
+            Next (Elit);
+         end loop;
+      end if;
+
+      --  Now process the named entries if present
+
+      if Present (Component_Associations (Aggr)) then
+         Assoc := First (Component_Associations (Aggr));
+         while Present (Assoc) loop
+            Choice := First (Choices (Assoc));
+
+            if Present (Next (Choice)) then
+               Error_Msg_N
+                 ("multiple choice not allowed here", Next (Choice));
+               Err := True;
+            end if;
+
+            if Nkind (Choice) = N_Others_Choice then
+               Error_Msg_N ("others choice not allowed here", Choice);
+               Err := True;
+
+            elsif Nkind (Choice) = N_Range then
+               --  ??? should allow zero/one element range here
+               Error_Msg_N ("range not allowed here", Choice);
+               Err := True;
+
+            else
+               Analyze_And_Resolve (Choice, Enumtype);
+
+               if Is_Entity_Name (Choice)
+                 and then Is_Type (Entity (Choice))
+               then
+                  Error_Msg_N ("subtype name not allowed here", Choice);
+                  Err := True;
+                  --  ??? should allow static subtype with zero/one entry
+
+               elsif Etype (Choice) = Base_Type (Enumtype) then
+                  if not Is_Static_Expression (Choice) then
+                     Error_Msg_N
+                       ("non-static expression used for choice", Choice);
+                     Err := True;
+
+                  else
+                     Elit := Expr_Value_E (Choice);
+
+                     if Present (Enumeration_Rep_Expr (Elit)) then
+                        Error_Msg_Sloc := Sloc (Enumeration_Rep_Expr (Elit));
+                        Error_Msg_NE
+                          ("representation for& previously given#",
+                           Choice, Elit);
+                        Err := True;
+                     end if;
+
+                     Set_Enumeration_Rep_Expr (Elit, Choice);
+
+                     Expr := Expression (Assoc);
+                     Val := Static_Integer (Expr);
+
+                     if Val = No_Uint then
+                        Err := True;
+
+                     elsif Val < Lo or else Hi < Val then
+                        Error_Msg_N ("value outside permitted range", Expr);
+                        Err := True;
+                     end if;
+
+                     Set_Enumeration_Rep (Elit, Val);
+                  end if;
+               end if;
+            end if;
+
+            Next (Assoc);
+         end loop;
+      end if;
+
+      --  Aggregate is fully processed. Now we check that a full set of
+      --  representations was given, and that they are in range and in order.
+      --  These checks are only done if no other errors occurred.
+
+      if not Err then
+         Min  := No_Uint;
+         Max  := No_Uint;
+
+         Elit := First_Literal (Enumtype);
+         while Present (Elit) loop
+            if No (Enumeration_Rep_Expr (Elit)) then
+               Error_Msg_NE ("missing representation for&!", N, Elit);
+
+            else
+               Val := Enumeration_Rep (Elit);
+
+               if Min = No_Uint then
+                  Min := Val;
+               end if;
+
+               if Val /= No_Uint then
+                  if Max /= No_Uint and then Val <= Max then
+                     Error_Msg_NE
+                       ("enumeration value for& not ordered!",
+                                       Enumeration_Rep_Expr (Elit), Elit);
+                  end if;
+
+                  Max := Val;
+               end if;
+
+               --  If there is at least one literal whose representation
+               --  is not equal to the Pos value, then note that this
+               --  enumeration type has a non-standard representation.
+
+               if Val /= Enumeration_Pos (Elit) then
+                  Set_Has_Non_Standard_Rep (Base_Type (Enumtype));
+               end if;
+            end if;
+
+            Next (Elit);
+         end loop;
+
+         --  Now set proper size information
+
+         declare
+            Minsize : Uint := UI_From_Int (Minimum_Size (Enumtype));
+
+         begin
+            if Has_Size_Clause (Enumtype) then
+               if Esize (Enumtype) >= Minsize then
+                  null;
+
+               else
+                  Minsize :=
+                    UI_From_Int (Minimum_Size (Enumtype, Biased => True));
+
+                  if Esize (Enumtype) < Minsize then
+                     Error_Msg_N ("previously given size is too small", N);
+
+                  else
+                     Set_Has_Biased_Representation (Enumtype);
+                  end if;
+               end if;
+
+            else
+               Set_RM_Size    (Enumtype, Minsize);
+               Set_Enum_Esize (Enumtype);
+            end if;
+
+            Set_RM_Size   (Base_Type (Enumtype), RM_Size   (Enumtype));
+            Set_Esize     (Base_Type (Enumtype), Esize     (Enumtype));
+            Set_Alignment (Base_Type (Enumtype), Alignment (Enumtype));
+         end;
+      end if;
+
+      --  We repeat the too late test in case it froze itself!
+
+      if Rep_Item_Too_Late (Enumtype, N) then
+         null;
+      end if;
+
+   end Analyze_Enumeration_Representation_Clause;
+
+   ----------------------------
+   -- Analyze_Free_Statement --
+   ----------------------------
+
+   procedure Analyze_Free_Statement (N : Node_Id) is
+   begin
+      Analyze (Expression (N));
+   end Analyze_Free_Statement;
+
+   ------------------------------------------
+   -- Analyze_Record_Representation_Clause --
+   ------------------------------------------
+
+   procedure Analyze_Record_Representation_Clause (N : Node_Id) is
+      Loc     : constant Source_Ptr := Sloc (N);
+      Ident   : constant Node_Id    := Identifier (N);
+      Rectype : Entity_Id;
+      Fent    : Entity_Id;
+      CC      : Node_Id;
+      Posit   : Uint;
+      Fbit    : Uint;
+      Lbit    : Uint;
+      Hbit    : Uint := Uint_0;
+      Comp    : Entity_Id;
+      Ocomp   : Entity_Id;
+      Biased  : Boolean;
+
+      Max_Bit_So_Far : Uint;
+      --  Records the maximum bit position so far. If all field positoins
+      --  are monotonically increasing, then we can skip the circuit for
+      --  checking for overlap, since no overlap is possible.
+
+      Overlap_Check_Required : Boolean;
+      --  Used to keep track of whether or not an overlap check is required
+
+      Ccount : Natural := 0;
+      --  Number of component clauses in record rep clause
+
+   begin
+      Find_Type (Ident);
+      Rectype := Entity (Ident);
+
+      if Rectype = Any_Type
+        or else Rep_Item_Too_Early (Rectype, N)
+      then
+         return;
+      else
+         Rectype := Underlying_Type (Rectype);
+      end if;
+
+      --  First some basic error checks
+
+      if not Is_Record_Type (Rectype) then
+         Error_Msg_NE
+           ("record type required, found}", Ident, First_Subtype (Rectype));
+         return;
+
+      elsif Is_Unchecked_Union (Rectype) then
+         Error_Msg_N
+           ("record rep clause not allowed for Unchecked_Union", N);
+
+      elsif Scope (Rectype) /= Current_Scope then
+         Error_Msg_N ("type must be declared in this scope", N);
+         return;
+
+      elsif not Is_First_Subtype (Rectype) then
+         Error_Msg_N ("cannot give record rep clause for subtype", N);
+         return;
+
+      elsif Has_Record_Rep_Clause (Rectype) then
+         Error_Msg_N ("duplicate record rep clause ignored", N);
+         return;
+
+      elsif Rep_Item_Too_Late (Rectype, N) then
+         return;
+      end if;
+
+      if Present (Mod_Clause (N)) then
+         declare
+            Loc     : constant Source_Ptr := Sloc (N);
+            M       : constant Node_Id := Mod_Clause (N);
+            P       : constant List_Id := Pragmas_Before (M);
+            Mod_Val : Uint;
+            AtM_Nod : Node_Id;
+
+         begin
+            if Present (P) then
+               Analyze_List (P);
+            end if;
+
+            --  In Tree_Output mode, expansion is disabled, but we must
+            --  convert the Mod clause into an alignment clause anyway, so
+            --  that the back-end can compute and back-annotate properly the
+            --  size and alignment of types that may include this record.
+
+            if Operating_Mode = Check_Semantics
+              and then Tree_Output
+            then
+               AtM_Nod :=
+                 Make_Attribute_Definition_Clause (Loc,
+                   Name       => New_Reference_To (Base_Type (Rectype), Loc),
+                   Chars      => Name_Alignment,
+                   Expression => Relocate_Node (Expression (M)));
+
+               Set_From_At_Mod (AtM_Nod);
+               Insert_After (N, AtM_Nod);
+               Mod_Val := Get_Alignment_Value (Expression (AtM_Nod));
+               Set_Mod_Clause (N, Empty);
+
+            else
+               --  Get the alignment value to perform error checking
+
+               Mod_Val := Get_Alignment_Value (Expression (M));
+
+            end if;
+         end;
+      end if;
+
+      --  Clear any existing component clauses for the type (this happens
+      --  with derived types, where we are now overriding the original)
+
+      Fent := First_Entity (Rectype);
+
+      Comp := Fent;
+      while Present (Comp) loop
+         if Ekind (Comp) = E_Component
+           or else Ekind (Comp) = E_Discriminant
+         then
+            Set_Component_Clause (Comp, Empty);
+         end if;
+
+         Next_Entity (Comp);
+      end loop;
+
+      --  All done if no component clauses
+
+      CC := First (Component_Clauses (N));
+
+      if No (CC) then
+         return;
+      end if;
+
+      --  If a tag is present, then create a component clause that places
+      --  it at the start of the record (otherwise gigi may place it after
+      --  other fields that have rep clauses).
+
+      if Nkind (Fent) = N_Defining_Identifier
+        and then Chars (Fent) = Name_uTag
+      then
+         Set_Component_Bit_Offset    (Fent, Uint_0);
+         Set_Normalized_Position     (Fent, Uint_0);
+         Set_Normalized_First_Bit    (Fent, Uint_0);
+         Set_Normalized_Position_Max (Fent, Uint_0);
+         Init_Esize                  (Fent, System_Address_Size);
+
+         Set_Component_Clause    (Fent,
+           Make_Component_Clause (Loc,
+             Component_Name =>
+               Make_Identifier (Loc,
+                 Chars => Name_uTag),
+
+             Position  =>
+               Make_Integer_Literal (Loc,
+                 Intval => Uint_0),
+
+             First_Bit =>
+               Make_Integer_Literal (Loc,
+                 Intval => Uint_0),
+
+             Last_Bit  =>
+               Make_Integer_Literal (Loc,
+                 UI_From_Int (System_Address_Size))));
+
+         Ccount := Ccount + 1;
+      end if;
+
+      Set_Has_Record_Rep_Clause (Rectype);
+      Set_Has_Specified_Layout  (Rectype);
+
+      --  A representation like this applies to the base type as well
+
+      Set_Has_Record_Rep_Clause (Base_Type (Rectype));
+      Set_Has_Non_Standard_Rep  (Base_Type (Rectype));
+      Set_Has_Specified_Layout  (Base_Type (Rectype));
+
+      Max_Bit_So_Far := Uint_Minus_1;
+      Overlap_Check_Required := False;
+
+      --  Process the component clauses
+
+      while Present (CC) loop
+
+         --  If pragma, just analyze it
+
+         if Nkind (CC) = N_Pragma then
+            Analyze (CC);
+
+         --  Processing for real component clause
+
+         else
+            Ccount := Ccount + 1;
+            Posit := Static_Integer (Position  (CC));
+            Fbit  := Static_Integer (First_Bit (CC));
+            Lbit  := Static_Integer (Last_Bit  (CC));
+
+            if Posit /= No_Uint
+              and then Fbit /= No_Uint
+              and then Lbit /= No_Uint
+            then
+               if Posit < 0 then
+                  Error_Msg_N
+                    ("position cannot be negative", Position (CC));
+
+               elsif Fbit < 0 then
+                  Error_Msg_N
+                    ("first bit cannot be negative", First_Bit (CC));
+
+               --  Values look OK, so find the corresponding record component
+               --  Even though the syntax allows an attribute reference for
+               --  implementation-defined components, GNAT does not allow the
+               --  tag to get an explicit position.
+
+               elsif Nkind (Component_Name (CC)) = N_Attribute_Reference then
+
+                  if Attribute_Name (Component_Name (CC)) = Name_Tag then
+                     Error_Msg_N ("position of tag cannot be specified", CC);
+                  else
+                     Error_Msg_N ("illegal component name", CC);
+                  end if;
+
+               else
+                  Comp := First_Entity (Rectype);
+                  while Present (Comp) loop
+                     exit when Chars (Comp) = Chars (Component_Name (CC));
+                     Next_Entity (Comp);
+                  end loop;
+
+                  if No (Comp) then
+
+                     --  Maybe component of base type that is absent from
+                     --  statically constrained first subtype.
+
+                     Comp := First_Entity (Base_Type (Rectype));
+                     while Present (Comp) loop
+                        exit when Chars (Comp) = Chars (Component_Name (CC));
+                        Next_Entity (Comp);
+                     end loop;
+                  end if;
+
+                  if No (Comp) then
+                     Error_Msg_N
+                       ("component clause is for non-existent field", CC);
+
+                  elsif Present (Component_Clause (Comp)) then
+                     Error_Msg_Sloc := Sloc (Component_Clause (Comp));
+                     Error_Msg_N
+                       ("component clause previously given#", CC);
+
+                  else
+                     --  Update Fbit and Lbit to the actual bit number.
+
+                     Fbit := Fbit + UI_From_Int (SSU) * Posit;
+                     Lbit := Lbit + UI_From_Int (SSU) * Posit;
+
+                     if Fbit <= Max_Bit_So_Far then
+                        Overlap_Check_Required := True;
+                     else
+                        Max_Bit_So_Far := Lbit;
+                     end if;
+
+                     if Has_Size_Clause (Rectype)
+                       and then Esize (Rectype) <= Lbit
+                     then
+                        Error_Msg_N
+                          ("bit number out of range of specified size",
+                           Last_Bit (CC));
+                     else
+                        Set_Component_Clause     (Comp, CC);
+                        Set_Component_Bit_Offset (Comp, Fbit);
+                        Set_Esize                (Comp, 1 + (Lbit - Fbit));
+                        Set_Normalized_First_Bit (Comp, Fbit mod SSU);
+                        Set_Normalized_Position  (Comp, Fbit / SSU);
+
+                        Set_Normalized_Position_Max
+                          (Fent, Normalized_Position (Fent));
+
+                        if Is_Tagged_Type (Rectype)
+                          and then Fbit < System_Address_Size
+                        then
+                           Error_Msg_NE
+                             ("component overlaps tag field of&",
+                              CC, Rectype);
+                        end if;
+
+                        --  Test for large object that is not on a byte
+                        --  boundary, defined as a large packed array not
+                        --  represented by a modular type, or an object for
+                        --  which a size of greater than 64 bits is specified.
+
+                        if Fbit mod SSU /= 0 then
+                           if (Is_Packed_Array_Type (Etype (Comp))
+                                and then Is_Array_Type
+                                     (Packed_Array_Type (Etype (Comp))))
+                             or else Esize (Etype (Comp)) > 64
+                           then
+                              Error_Msg_N
+                                ("large component must be on byte boundary",
+                                 First_Bit (CC));
+                           end if;
+                        end if;
+
+                        --  This information is also set in the
+                        --  corresponding component of the base type,
+                        --  found by accessing the Original_Record_Component
+                        --  link if it is present.
+
+                        Ocomp := Original_Record_Component (Comp);
+
+                        if Hbit < Lbit then
+                           Hbit := Lbit;
+                        end if;
+
+                        Check_Size
+                          (Component_Name (CC),
+                           Etype (Comp),
+                           Esize (Comp),
+                           Biased);
+
+                        Set_Has_Biased_Representation (Comp, Biased);
+
+                        if Present (Ocomp) then
+                           Set_Component_Clause     (Ocomp, CC);
+                           Set_Component_Bit_Offset (Ocomp, Fbit);
+                           Set_Normalized_First_Bit (Ocomp, Fbit mod SSU);
+                           Set_Normalized_Position  (Ocomp, Fbit / SSU);
+                           Set_Esize                (Ocomp, 1 + (Lbit - Fbit));
+
+                           Set_Normalized_Position_Max
+                             (Ocomp, Normalized_Position (Ocomp));
+
+                           Set_Has_Biased_Representation
+                             (Ocomp, Has_Biased_Representation (Comp));
+                        end if;
+
+                        if Esize (Comp) < 0 then
+                           Error_Msg_N ("component size is negative", CC);
+                        end if;
+                     end if;
+                  end if;
+               end if;
+            end if;
+         end if;
+
+         Next (CC);
+      end loop;
+
+      --  Now that we have processed all the component clauses, check for
+      --  overlap. We have to leave this till last, since the components
+      --  can appear in any arbitrary order in the representation clause.
+
+      --  We do not need this check if all specified ranges were monotonic,
+      --  as recorded by Overlap_Check_Required being False at this stage.
+
+      --  This first section checks if there are any overlapping entries
+      --  at all. It does this by sorting all entries and then seeing if
+      --  there are any overlaps. If there are none, then that is decisive,
+      --  but if there are overlaps, they may still be OK (they may result
+      --  from fields in different variants).
+
+      if Overlap_Check_Required then
+         Overlap_Check1 : declare
+
+            OC_Fbit : array (0 .. Ccount) of Uint;
+            --  First-bit values for component clauses, the value is the
+            --  offset of the first bit of the field from start of record.
+            --  The zero entry is for use in sorting.
+
+            OC_Lbit : array (0 .. Ccount) of Uint;
+            --  Last-bit values for component clauses, the value is the
+            --  offset of the last bit of the field from start of record.
+            --  The zero entry is for use in sorting.
+
+            OC_Count : Natural := 0;
+            --  Count of entries in OC_Fbit and OC_Lbit
+
+            function OC_Lt (Op1, Op2 : Natural) return Boolean;
+            --  Compare routine for Sort (See GNAT.Heap_Sort_A)
+
+            procedure OC_Move (From : Natural; To : Natural);
+            --  Move routine for Sort (see GNAT.Heap_Sort_A)
+
+            function OC_Lt (Op1, Op2 : Natural) return Boolean is
+            begin
+               return OC_Fbit (Op1) < OC_Fbit (Op2);
+            end OC_Lt;
+
+            procedure OC_Move (From : Natural; To : Natural) is
+            begin
+               OC_Fbit (To) := OC_Fbit (From);
+               OC_Lbit (To) := OC_Lbit (From);
+            end OC_Move;
+
+         begin
+            CC := First (Component_Clauses (N));
+            while Present (CC) loop
+               if Nkind (CC) /= N_Pragma then
+                  Posit := Static_Integer (Position  (CC));
+                  Fbit  := Static_Integer (First_Bit (CC));
+                  Lbit  := Static_Integer (Last_Bit  (CC));
+
+                  if Posit /= No_Uint
+                    and then Fbit /= No_Uint
+                    and then Lbit /= No_Uint
+                  then
+                     OC_Count := OC_Count + 1;
+                     Posit := Posit * SSU;
+                     OC_Fbit (OC_Count) := Fbit + Posit;
+                     OC_Lbit (OC_Count) := Lbit + Posit;
+                  end if;
+               end if;
+
+               Next (CC);
+            end loop;
+
+            Sort
+              (OC_Count,
+               OC_Move'Unrestricted_Access,
+               OC_Lt'Unrestricted_Access);
+
+            Overlap_Check_Required := False;
+            for J in 1 .. OC_Count - 1 loop
+               if OC_Lbit (J) >= OC_Fbit (J + 1) then
+                  Overlap_Check_Required := True;
+                  exit;
+               end if;
+            end loop;
+         end Overlap_Check1;
+      end if;
+
+      --  If Overlap_Check_Required is still True, then we have to do
+      --  the full scale overlap check, since we have at least two fields
+      --  that do overlap, and we need to know if that is OK since they
+      --  are in the same variant, or whether we have a definite problem
+
+      if Overlap_Check_Required then
+         Overlap_Check2 : declare
+            C1_Ent, C2_Ent : Entity_Id;
+            --  Entities of components being checked for overlap
+
+            Clist : Node_Id;
+            --  Component_List node whose Component_Items are being checked
+
+            Citem : Node_Id;
+            --  Component declaration for component being checked
+
+         begin
+            C1_Ent := First_Entity (Base_Type (Rectype));
+
+            --  Loop through all components in record. For each component check
+            --  for overlap with any of the preceding elements on the component
+            --  list containing the component, and also, if the component is in
+            --  a variant, check against components outside the case structure.
+            --  This latter test is repeated recursively up the variant tree.
+
+            Main_Component_Loop : while Present (C1_Ent) loop
+               if Ekind (C1_Ent) /= E_Component
+                 and then Ekind (C1_Ent) /= E_Discriminant
+               then
+                  goto Continue_Main_Component_Loop;
+               end if;
+
+               --  Skip overlap check if entity has no declaration node. This
+               --  happens with discriminants in constrained derived types.
+               --  Probably we are missing some checks as a result, but that
+               --  does not seem terribly serious ???
+
+               if No (Declaration_Node (C1_Ent)) then
+                  goto Continue_Main_Component_Loop;
+               end if;
+
+               Clist := Parent (List_Containing (Declaration_Node (C1_Ent)));
+
+               --  Loop through component lists that need checking. Check the
+               --  current component list and all lists in variants above us.
+
+               Component_List_Loop : loop
+
+                  --  If derived type definition, go to full declaration
+                  --  If at outer level, check discriminants if there are any
+
+                  if Nkind (Clist) = N_Derived_Type_Definition then
+                     Clist := Parent (Clist);
+                  end if;
+
+                  --  Outer level of record definition, check discriminants
+
+                  if Nkind (Clist) = N_Full_Type_Declaration
+                    or else Nkind (Clist) = N_Private_Type_Declaration
+                  then
+                     if Has_Discriminants (Defining_Identifier (Clist)) then
+                        C2_Ent :=
+                          First_Discriminant (Defining_Identifier (Clist));
+
+                        while Present (C2_Ent) loop
+                           exit when C1_Ent = C2_Ent;
+                           Check_Component_Overlap (C1_Ent, C2_Ent);
+                           Next_Discriminant (C2_Ent);
+                        end loop;
+                     end if;
+
+                  --  Record extension case
+
+                  elsif Nkind (Clist) = N_Derived_Type_Definition then
+                     Clist := Empty;
+
+                  --  Otherwise check one component list
+
+                  else
+                     Citem := First (Component_Items (Clist));
+
+                     while Present (Citem) loop
+                        if Nkind (Citem) = N_Component_Declaration then
+                           C2_Ent := Defining_Identifier (Citem);
+                           exit when C1_Ent = C2_Ent;
+                           Check_Component_Overlap (C1_Ent, C2_Ent);
+                        end if;
+
+                        Next (Citem);
+                     end loop;
+                  end if;
+
+                  --  Check for variants above us (the parent of the Clist can
+                  --  be a variant, in which case its parent is a variant part,
+                  --  and the parent of the variant part is a component list
+                  --  whose components must all be checked against the current
+                  --  component for overlap.
+
+                  if Nkind (Parent (Clist)) = N_Variant then
+                     Clist := Parent (Parent (Parent (Clist)));
+
+                  --  Check for possible discriminant part in record, this is
+                  --  treated essentially as another level in the recursion.
+                  --  For this case we have the parent of the component list
+                  --  is the record definition, and its parent is the full
+                  --  type declaration which contains the discriminant
+                  --  specifications.
+
+                  elsif Nkind (Parent (Clist)) = N_Record_Definition then
+                     Clist := Parent (Parent ((Clist)));
+
+                  --  If neither of these two cases, we are at the top of
+                  --  the tree
+
+                  else
+                     exit Component_List_Loop;
+                  end if;
+               end loop Component_List_Loop;
+
+               <<Continue_Main_Component_Loop>>
+                  Next_Entity (C1_Ent);
+
+            end loop Main_Component_Loop;
+         end Overlap_Check2;
+      end if;
+
+      --  For records that have component clauses for all components, and
+      --  whose size is less than or equal to 32, we need to know the size
+      --  in the front end to activate possible packed array processing
+      --  where the component type is a record.
+
+      --  At this stage Hbit + 1 represents the first unused bit from all
+      --  the component clauses processed, so if the component clauses are
+      --  complete, then this is the length of the record.
+
+      --  For records longer than System.Storage_Unit, and for those where
+      --  not all components have component clauses, the back end determines
+      --  the length (it may for example be appopriate to round up the size
+      --  to some convenient boundary, based on alignment considerations etc).
+
+      if Unknown_RM_Size (Rectype)
+        and then Hbit + 1 <= 32
+      then
+         --  Nothing to do if at least one component with no component clause
+
+         Comp := First_Entity (Rectype);
+         while Present (Comp) loop
+            if Ekind (Comp) = E_Component
+              or else Ekind (Comp) = E_Discriminant
+            then
+               if No (Component_Clause (Comp)) then
+                  return;
+               end if;
+            end if;
+
+            Next_Entity (Comp);
+         end loop;
+
+         --  If we fall out of loop, all components have component clauses
+         --  and so we can set the size to the maximum value.
+
+         Set_RM_Size (Rectype, Hbit + 1);
+      end if;
+
+   end Analyze_Record_Representation_Clause;
+
+   -----------------------------
+   -- Check_Address_Alignment --
+   -----------------------------
+
+   procedure Check_Address_Alignment (E : Entity_Id; Expr : Node_Id) is
+      Arg : Node_Id;
+
+   begin
+      if Nkind (Expr) = N_Unchecked_Type_Conversion then
+         Arg := Expression (Expr);
+
+      elsif Nkind (Expr) = N_Function_Call
+        and then Is_RTE (Entity (Name (Expr)), RE_To_Address)
+      then
+         Arg := First (Parameter_Associations (Expr));
+
+         if Nkind (Arg) = N_Parameter_Association then
+            Arg := Explicit_Actual_Parameter (Arg);
+         end if;
+
+      else
+         return;
+      end if;
+
+      --  Here Arg is the address value
+
+      if Compile_Time_Known_Value (Arg) then
+         if Expr_Value (Arg) mod Alignment (E) /= 0 then
+            Error_Msg_NE
+              ("?specified address for& not consistent with alignment",
+               Arg, E);
+         end if;
+      end if;
+   end Check_Address_Alignment;
+
+   -----------------------------
+   -- Check_Component_Overlap --
+   -----------------------------
+
+   procedure Check_Component_Overlap (C1_Ent, C2_Ent : Entity_Id) is
+   begin
+      if Present (Component_Clause (C1_Ent))
+        and then Present (Component_Clause (C2_Ent))
+      then
+         --  Exclude odd case where we have two tag fields in the same
+         --  record, both at location zero. This seems a bit strange,
+         --  but it seems to happen in some circumstances ???
+
+         if Chars (C1_Ent) = Name_uTag
+           and then Chars (C2_Ent) = Name_uTag
+         then
+            return;
+         end if;
+
+         --  Here we check if the two fields overlap
+
+         declare
+            S1 : constant Uint := Component_Bit_Offset (C1_Ent);
+            S2 : constant Uint := Component_Bit_Offset (C2_Ent);
+            E1 : constant Uint := S1 + Esize (C1_Ent);
+            E2 : constant Uint := S2 + Esize (C2_Ent);
+
+         begin
+            if E2 <= S1 or else E1 <= S2 then
+               null;
+            else
+               Error_Msg_Node_2 :=
+                 Component_Name (Component_Clause (C2_Ent));
+               Error_Msg_Sloc := Sloc (Error_Msg_Node_2);
+               Error_Msg_Node_1 :=
+                 Component_Name (Component_Clause (C1_Ent));
+               Error_Msg_N
+                 ("component& overlaps & #",
+                  Component_Name (Component_Clause (C1_Ent)));
+            end if;
+         end;
+      end if;
+   end Check_Component_Overlap;
+
+   -----------------------------------
+   -- Check_Constant_Address_Clause --
+   -----------------------------------
+
+   procedure Check_Constant_Address_Clause
+     (Expr  : Node_Id;
+      U_Ent : Entity_Id)
+   is
+      procedure Check_At_Constant_Address (Nod : Node_Id);
+      --  Checks that the given node N represents a name whose 'Address
+      --  is constant (in the same sense as OK_Constant_Address_Clause,
+      --  i.e. the address value is the same at the point of declaration
+      --  of U_Ent and at the time of elaboration of the address clause.
+
+      procedure Check_Expr_Constants (Nod : Node_Id);
+      --  Checks that Nod meets the requirements for a constant address
+      --  clause in the sense of the enclosing procedure.
+
+      procedure Check_List_Constants (Lst : List_Id);
+      --  Check that all elements of list Lst meet the requirements for a
+      --  constant address clause in the sense of the enclosing procedure.
+
+      -------------------------------
+      -- Check_At_Constant_Address --
+      -------------------------------
+
+      procedure Check_At_Constant_Address (Nod : Node_Id) is
+      begin
+         if Is_Entity_Name (Nod) then
+            if Present (Address_Clause (Entity ((Nod)))) then
+               Error_Msg_NE
+                 ("invalid address clause for initialized object &!",
+                           Nod, U_Ent);
+               Error_Msg_NE
+                 ("address for& cannot" &
+                    " depend on another address clause! ('R'M 13.1(22))!",
+                  Nod, U_Ent);
+
+            elsif In_Same_Source_Unit (Entity (Nod), U_Ent)
+              and then Sloc (U_Ent) < Sloc (Entity (Nod))
+            then
+               Error_Msg_NE
+                 ("invalid address clause for initialized object &!",
+                  Nod, U_Ent);
+               Error_Msg_Name_1 := Chars (Entity (Nod));
+               Error_Msg_Name_2 := Chars (U_Ent);
+               Error_Msg_N
+                 ("\% must be defined before % ('R'M 13.1(22))!",
+                  Nod);
+            end if;
+
+         elsif Nkind (Nod) = N_Selected_Component then
+            declare
+               T : constant Entity_Id := Etype (Prefix (Nod));
+
+            begin
+               if (Is_Record_Type (T)
+                    and then Has_Discriminants (T))
+                 or else
+                  (Is_Access_Type (T)
+                     and then Is_Record_Type (Designated_Type (T))
+                     and then Has_Discriminants (Designated_Type (T)))
+               then
+                  Error_Msg_NE
+                    ("invalid address clause for initialized object &!",
+                     Nod, U_Ent);
+                  Error_Msg_N
+                    ("\address cannot depend on component" &
+                     " of discriminated record ('R'M 13.1(22))!",
+                     Nod);
+               else
+                  Check_At_Constant_Address (Prefix (Nod));
+               end if;
+            end;
+
+         elsif Nkind (Nod) = N_Indexed_Component then
+            Check_At_Constant_Address (Prefix (Nod));
+            Check_List_Constants (Expressions (Nod));
+
+         else
+            Check_Expr_Constants (Nod);
+         end if;
+      end Check_At_Constant_Address;
+
+      --------------------------
+      -- Check_Expr_Constants --
+      --------------------------
+
+      procedure Check_Expr_Constants (Nod : Node_Id) is
+      begin
+         if Nkind (Nod) in N_Has_Etype
+           and then Etype (Nod) = Any_Type
+         then
+            return;
+         end if;
+
+         case Nkind (Nod) is
+            when N_Empty | N_Error =>
+               return;
+
+            when N_Identifier | N_Expanded_Name =>
+               declare
+                  Ent       : constant Entity_Id  := Entity (Nod);
+                  Loc_Ent   : constant Source_Ptr := Sloc (Ent);
+                  Loc_U_Ent : constant Source_Ptr := Sloc (U_Ent);
+
+               begin
+                  if Ekind (Ent) = E_Named_Integer
+                       or else
+                     Ekind (Ent) = E_Named_Real
+                       or else
+                     Is_Type (Ent)
+                  then
+                     return;
+
+                  elsif
+                     Ekind (Ent) = E_Constant
+                       or else
+                     Ekind (Ent) = E_In_Parameter
+                  then
+                     --  This is the case where we must have Ent defined
+                     --  before U_Ent. Clearly if they are in different
+                     --  units this requirement is met since the unit
+                     --  containing Ent is already processed.
+
+                     if not In_Same_Source_Unit (Ent, U_Ent) then
+                        return;
+
+                     --  Otherwise location of Ent must be before the
+                     --  location of U_Ent, that's what prior defined means.
+
+                     elsif Loc_Ent < Loc_U_Ent then
+                        return;
+
+                     else
+                        Error_Msg_NE
+                          ("invalid address clause for initialized object &!",
+                           Nod, U_Ent);
+                        Error_Msg_Name_1 := Chars (Ent);
+                        Error_Msg_Name_2 := Chars (U_Ent);
+                        Error_Msg_N
+                          ("\% must be defined before % ('R'M 13.1(22))!",
+                           Nod);
+                     end if;
+
+                  elsif Nkind (Original_Node (Nod)) = N_Function_Call then
+                     Check_Expr_Constants (Original_Node (Nod));
+
+                  else
+                     Error_Msg_NE
+                       ("invalid address clause for initialized object &!",
+                        Nod, U_Ent);
+                     Error_Msg_Name_1 := Chars (Ent);
+                     Error_Msg_N
+                       ("\reference to variable% not allowed ('R'M 13.1(22))!",
+                        Nod);
+                  end if;
+               end;
+
+            when N_Integer_Literal   |
+                 N_Real_Literal      |
+                 N_String_Literal    |
+                 N_Character_Literal =>
+               return;
+
+            when N_Range =>
+               Check_Expr_Constants (Low_Bound (Nod));
+               Check_Expr_Constants (High_Bound (Nod));
+
+            when N_Explicit_Dereference =>
+               Check_Expr_Constants (Prefix (Nod));
+
+            when N_Indexed_Component =>
+               Check_Expr_Constants (Prefix (Nod));
+               Check_List_Constants (Expressions (Nod));
+
+            when N_Slice =>
+               Check_Expr_Constants (Prefix (Nod));
+               Check_Expr_Constants (Discrete_Range (Nod));
+
+            when N_Selected_Component =>
+               Check_Expr_Constants (Prefix (Nod));
+
+            when N_Attribute_Reference =>
+
+               if (Attribute_Name (Nod) = Name_Address
+                    or else
+                   Attribute_Name (Nod) = Name_Access
+                    or else
+                   Attribute_Name (Nod) = Name_Unchecked_Access
+                    or else
+                   Attribute_Name (Nod) = Name_Unrestricted_Access)
+               then
+                  Check_At_Constant_Address (Prefix (Nod));
+
+               else
+                  Check_Expr_Constants (Prefix (Nod));
+                  Check_List_Constants (Expressions (Nod));
+               end if;
+
+            when N_Aggregate =>
+               Check_List_Constants (Component_Associations (Nod));
+               Check_List_Constants (Expressions (Nod));
+
+            when N_Component_Association =>
+               Check_Expr_Constants (Expression (Nod));
+
+            when N_Extension_Aggregate =>
+               Check_Expr_Constants (Ancestor_Part (Nod));
+               Check_List_Constants (Component_Associations (Nod));
+               Check_List_Constants (Expressions (Nod));
+
+            when N_Null =>
+               return;
+
+            when N_Binary_Op | N_And_Then | N_Or_Else | N_In | N_Not_In =>
+               Check_Expr_Constants (Left_Opnd (Nod));
+               Check_Expr_Constants (Right_Opnd (Nod));
+
+            when N_Unary_Op =>
+               Check_Expr_Constants (Right_Opnd (Nod));
+
+            when N_Type_Conversion           |
+                 N_Qualified_Expression      |
+                 N_Allocator                 =>
+               Check_Expr_Constants (Expression (Nod));
+
+            when N_Unchecked_Type_Conversion =>
+               Check_Expr_Constants (Expression (Nod));
+
+               --  If this is a rewritten unchecked conversion, subtypes
+               --  in this node are those created within the instance.
+               --  To avoid order of elaboration issues, replace them
+               --  with their base types. Note that address clauses can
+               --  cause order of elaboration problems because they are
+               --  elaborated by the back-end at the point of definition,
+               --  and may mention entities declared in between (as long
+               --  as everything is static). It is user-friendly to allow
+               --  unchecked conversions in this context.
+
+               if Nkind (Original_Node (Nod)) = N_Function_Call then
+                  Set_Etype (Expression (Nod),
+                    Base_Type (Etype (Expression (Nod))));
+                  Set_Etype (Nod, Base_Type (Etype (Nod)));
+               end if;
+
+            when N_Function_Call =>
+               if not Is_Pure (Entity (Name (Nod))) then
+                  Error_Msg_NE
+                    ("invalid address clause for initialized object &!",
+                     Nod, U_Ent);
+
+                  Error_Msg_NE
+                    ("\function & is not pure ('R'M 13.1(22))!",
+                     Nod, Entity (Name (Nod)));
+
+               else
+                  Check_List_Constants (Parameter_Associations (Nod));
+               end if;
+
+            when N_Parameter_Association =>
+               Check_Expr_Constants (Explicit_Actual_Parameter (Nod));
+
+            when others =>
+               Error_Msg_NE
+                 ("invalid address clause for initialized object &!",
+                  Nod, U_Ent);
+               Error_Msg_NE
+                 ("\must be constant defined before& ('R'M 13.1(22))!",
+                  Nod, U_Ent);
+         end case;
+      end Check_Expr_Constants;
+
+      --------------------------
+      -- Check_List_Constants --
+      --------------------------
+
+      procedure Check_List_Constants (Lst : List_Id) is
+         Nod1 : Node_Id;
+
+      begin
+         if Present (Lst) then
+            Nod1 := First (Lst);
+            while Present (Nod1) loop
+               Check_Expr_Constants (Nod1);
+               Next (Nod1);
+            end loop;
+         end if;
+      end Check_List_Constants;
+
+   --  Start of processing for Check_Constant_Address_Clause
+
+   begin
+      Check_Expr_Constants (Expr);
+   end Check_Constant_Address_Clause;
+
+   ----------------
+   -- Check_Size --
+   ----------------
+
+   procedure Check_Size
+     (N      : Node_Id;
+      T      : Entity_Id;
+      Siz    : Uint;
+      Biased : out Boolean)
+   is
+      UT : constant Entity_Id := Underlying_Type (T);
+      M  : Uint;
+
+   begin
+      Biased := False;
+
+      --  Immediate return if size is same as standard size or if composite
+      --  item, or generic type, or type with previous errors.
+
+      if No (UT)
+        or else UT = Any_Type
+        or else Is_Generic_Type (UT)
+        or else Is_Generic_Type (Root_Type (UT))
+        or else Is_Composite_Type (UT)
+        or else (Known_Esize (UT) and then Siz = Esize (UT))
+      then
+         return;
+
+      --  For fixed-point types, don't check minimum if type is not frozen,
+      --  since type is not known till then
+      --  at freeze time.
+
+      elsif Is_Fixed_Point_Type (UT)
+        and then not Is_Frozen (UT)
+      then
+         null;
+
+      --  Cases for which a minimum check is required
+
+      else
+         M := UI_From_Int (Minimum_Size (UT));
+
+         if Siz < M then
+
+            --  Size is less than minimum size, but one possibility remains
+            --  that we can manage with the new size if we bias the type
+
+            M := UI_From_Int (Minimum_Size (UT, Biased => True));
+
+            if Siz < M then
+               Error_Msg_Uint_1 := M;
+               Error_Msg_NE
+                 ("size for& too small, minimum allowed is ^", N, T);
+            else
+               Biased := True;
+            end if;
+         end if;
+      end if;
+   end Check_Size;
+
+   -------------------------
+   -- Get_Alignment_Value --
+   -------------------------
+
+   function Get_Alignment_Value (Expr : Node_Id) return Uint is
+      Align : constant Uint := Static_Integer (Expr);
+
+   begin
+      if Align = No_Uint then
+         return No_Uint;
+
+      elsif Align <= 0 then
+         Error_Msg_N ("alignment value must be positive", Expr);
+         return No_Uint;
+
+      else
+         for J in Int range 0 .. 64 loop
+            declare
+               M : constant Uint := Uint_2 ** J;
+
+            begin
+               exit when M = Align;
+
+               if M > Align then
+                  Error_Msg_N
+                    ("alignment value must be power of 2", Expr);
+                  return No_Uint;
+               end if;
+            end;
+         end loop;
+
+         return Align;
+      end if;
+   end Get_Alignment_Value;
+
+   -------------------------------------
+   -- Get_Attribute_Definition_Clause --
+   -------------------------------------
+
+   function Get_Attribute_Definition_Clause
+     (E    : Entity_Id;
+      Id   : Attribute_Id)
+      return Node_Id
+   is
+      N : Node_Id;
+
+   begin
+      N := First_Rep_Item (E);
+      while Present (N) loop
+         if Nkind (N) = N_Attribute_Definition_Clause
+           and then Get_Attribute_Id (Chars (N)) = Id
+         then
+            return N;
+         else
+            Next_Rep_Item (N);
+         end if;
+      end loop;
+
+      return Empty;
+   end Get_Attribute_Definition_Clause;
+
+   --------------------
+   -- Get_Rep_Pragma --
+   --------------------
+
+   function Get_Rep_Pragma (E : Entity_Id; Nam : Name_Id) return Node_Id is
+      N   : Node_Id;
+      Typ : Entity_Id;
+
+   begin
+      N := First_Rep_Item (E);
+
+      while Present (N) loop
+         if Nkind (N) = N_Pragma and then Chars (N) = Nam then
+
+            if Nam = Name_Stream_Convert then
+
+               --  For tagged types this pragma is not inherited, so we
+               --  must verify that it is defined for the given type and
+               --  not an ancestor.
+
+               Typ := Entity (Expression
+                       (First (Pragma_Argument_Associations (N))));
+
+               if not Is_Tagged_Type (E)
+                 or else E = Typ
+                 or else (Is_Private_Type (Typ)
+                           and then E = Full_View (Typ))
+               then
+                  return N;
+               else
+                  Next_Rep_Item (N);
+               end if;
+
+            else
+               return N;
+            end if;
+         else
+            Next_Rep_Item (N);
+         end if;
+      end loop;
+
+      return Empty;
+   end Get_Rep_Pragma;
+
+   ----------------
+   -- Initialize --
+   ----------------
+
+   procedure Initialize is
+   begin
+      Unchecked_Conversions.Init;
+   end Initialize;
+
+   -------------------------
+   -- Is_Operational_Item --
+   -------------------------
+
+   function Is_Operational_Item (N : Node_Id) return Boolean is
+   begin
+      if Nkind (N) /= N_Attribute_Definition_Clause then
+         return False;
+      else
+         declare
+            Id    : constant Attribute_Id := Get_Attribute_Id (Chars (N));
+
+         begin
+            return Id = Attribute_Input
+              or else Id = Attribute_Output
+              or else Id = Attribute_Read
+              or else Id = Attribute_Write;
+         end;
+      end if;
+   end Is_Operational_Item;
+
+   ------------------
+   -- Minimum_Size --
+   ------------------
+
+   function Minimum_Size
+     (T      : Entity_Id;
+      Biased : Boolean := False)
+      return   Nat
+   is
+      Lo     : Uint    := No_Uint;
+      Hi     : Uint    := No_Uint;
+      LoR    : Ureal   := No_Ureal;
+      HiR    : Ureal   := No_Ureal;
+      LoSet  : Boolean := False;
+      HiSet  : Boolean := False;
+      B      : Uint;
+      S      : Nat;
+      Ancest : Entity_Id;
+
+   begin
+      --  If bad type, return 0
+
+      if T = Any_Type then
+         return 0;
+
+      --  For generic types, just return zero. There cannot be any legitimate
+      --  need to know such a size, but this routine may be called with a
+      --  generic type as part of normal processing.
+
+      elsif Is_Generic_Type (Root_Type (T)) then
+         return 0;
+
+      --  Access types
+
+      elsif Is_Access_Type (T) then
+         return System_Address_Size;
+
+      --  Floating-point types
+
+      elsif Is_Floating_Point_Type (T) then
+         return UI_To_Int (Esize (Root_Type (T)));
+
+      --  Discrete types
+
+      elsif Is_Discrete_Type (T) then
+
+         --  The following loop is looking for the nearest compile time
+         --  known bounds following the ancestor subtype chain. The idea
+         --  is to find the most restrictive known bounds information.
+
+         Ancest := T;
+         loop
+            if Ancest = Any_Type or else Etype (Ancest) = Any_Type then
+               return 0;
+            end if;
+
+            if not LoSet then
+               if Compile_Time_Known_Value (Type_Low_Bound (Ancest)) then
+                  Lo := Expr_Rep_Value (Type_Low_Bound (Ancest));
+                  LoSet := True;
+                  exit when HiSet;
+               end if;
+            end if;
+
+            if not HiSet then
+               if Compile_Time_Known_Value (Type_High_Bound (Ancest)) then
+                  Hi := Expr_Rep_Value (Type_High_Bound (Ancest));
+                  HiSet := True;
+                  exit when LoSet;
+               end if;
+            end if;
+
+            Ancest := Ancestor_Subtype (Ancest);
+
+            if No (Ancest) then
+               Ancest := Base_Type (T);
+
+               if Is_Generic_Type (Ancest) then
+                  return 0;
+               end if;
+            end if;
+         end loop;
+
+      --  Fixed-point types. We can't simply use Expr_Value to get the
+      --  Corresponding_Integer_Value values of the bounds, since these
+      --  do not get set till the type is frozen, and this routine can
+      --  be called before the type is frozen. Similarly the test for
+      --  bounds being static needs to include the case where we have
+      --  unanalyzed real literals for the same reason.
+
+      elsif Is_Fixed_Point_Type (T) then
+
+         --  The following loop is looking for the nearest compile time
+         --  known bounds following the ancestor subtype chain. The idea
+         --  is to find the most restrictive known bounds information.
+
+         Ancest := T;
+         loop
+            if Ancest = Any_Type or else Etype (Ancest) = Any_Type then
+               return 0;
+            end if;
+
+            if not LoSet then
+               if Nkind (Type_Low_Bound (Ancest)) = N_Real_Literal
+                 or else Compile_Time_Known_Value (Type_Low_Bound (Ancest))
+               then
+                  LoR := Expr_Value_R (Type_Low_Bound (Ancest));
+                  LoSet := True;
+                  exit when HiSet;
+               end if;
+            end if;
+
+            if not HiSet then
+               if Nkind (Type_High_Bound (Ancest)) = N_Real_Literal
+                 or else Compile_Time_Known_Value (Type_High_Bound (Ancest))
+               then
+                  HiR := Expr_Value_R (Type_High_Bound (Ancest));
+                  HiSet := True;
+                  exit when LoSet;
+               end if;
+            end if;
+
+            Ancest := Ancestor_Subtype (Ancest);
+
+            if No (Ancest) then
+               Ancest := Base_Type (T);
+
+               if Is_Generic_Type (Ancest) then
+                  return 0;
+               end if;
+            end if;
+         end loop;
+
+         Lo := UR_To_Uint (LoR / Small_Value (T));
+         Hi := UR_To_Uint (HiR / Small_Value (T));
+
+      --  No other types allowed
+
+      else
+         raise Program_Error;
+      end if;
+
+      --  Fall through with Hi and Lo set. Deal with biased case.
+
+      if (Biased and then not Is_Fixed_Point_Type (T))
+        or else Has_Biased_Representation (T)
+      then
+         Hi := Hi - Lo;
+         Lo := Uint_0;
+      end if;
+
+      --  Signed case. Note that we consider types like range 1 .. -1 to be
+      --  signed for the purpose of computing the size, since the bounds
+      --  have to be accomodated in the base type.
+
+      if Lo < 0 or else Hi < 0 then
+         S := 1;
+         B := Uint_1;
+
+         --  S = size, B = 2 ** (size - 1) (can accomodate -B .. +(B - 1))
+         --  Note that we accomodate the case where the bounds cross. This
+         --  can happen either because of the way the bounds are declared
+         --  or because of the algorithm in Freeze_Fixed_Point_Type.
+
+         while Lo < -B
+           or else Hi < -B
+           or else Lo >= B
+           or else Hi >= B
+         loop
+            B := Uint_2 ** S;
+            S := S + 1;
+         end loop;
+
+      --  Unsigned case
+
+      else
+         --  If both bounds are positive, make sure that both are represen-
+         --  table in the case where the bounds are crossed. This can happen
+         --  either because of the way the bounds are declared, or because of
+         --  the algorithm in Freeze_Fixed_Point_Type.
+
+         if Lo > Hi then
+            Hi := Lo;
+         end if;
+
+         --  S = size, (can accomodate 0 .. (2**size - 1))
+
+         S := 0;
+         while Hi >= Uint_2 ** S loop
+            S := S + 1;
+         end loop;
+      end if;
+
+      return S;
+   end Minimum_Size;
+
+   -------------------------
+   -- New_Stream_Function --
+   -------------------------
+
+   procedure New_Stream_Function
+     (N    : Node_Id;
+      Ent  : Entity_Id;
+      Subp : Entity_Id;
+      Nam  : Name_Id)
+   is
+      Loc       : constant Source_Ptr := Sloc (N);
+      Subp_Id   : Entity_Id := Make_Defining_Identifier (Loc, Nam);
+      Subp_Decl : Node_Id;
+      F         : Entity_Id;
+      Etyp      : Entity_Id;
+
+   begin
+      F        := First_Formal (Subp);
+      Etyp     := Etype (Subp);
+
+      Subp_Decl :=
+        Make_Subprogram_Renaming_Declaration (Loc,
+          Specification =>
+
+            Make_Function_Specification (Loc,
+              Defining_Unit_Name => Subp_Id,
+              Parameter_Specifications =>
+                New_List (
+                  Make_Parameter_Specification (Loc,
+                    Defining_Identifier =>
+                      Make_Defining_Identifier (Loc, Name_S),
+                    Parameter_Type =>
+                      Make_Access_Definition (Loc,
+                        Subtype_Mark =>
+                          New_Reference_To (
+                            Designated_Type (Etype (F)), Loc)))),
+
+              Subtype_Mark =>
+                New_Reference_To (Etyp, Loc)),
+
+        Name => New_Reference_To (Subp, Loc));
+
+      if Is_Tagged_Type (Ent) and then not Is_Limited_Type (Ent) then
+         Set_TSS (Base_Type (Ent), Subp_Id);
+      else
+         Insert_Action (N, Subp_Decl);
+         Copy_TSS (Subp_Id, Base_Type (Ent));
+      end if;
+
+   end New_Stream_Function;
+
+   --------------------------
+   -- New_Stream_Procedure --
+   --------------------------
+
+   procedure New_Stream_Procedure
+     (N     : Node_Id;
+      Ent   : Entity_Id;
+      Subp  : Entity_Id;
+      Nam   : Name_Id;
+      Out_P : Boolean := False)
+   is
+      Loc       : constant Source_Ptr := Sloc (N);
+      Subp_Id   : Entity_Id := Make_Defining_Identifier (Loc, Nam);
+      Subp_Decl : Node_Id;
+      F         : Entity_Id;
+      Etyp      : Entity_Id;
+
+   begin
+      F        := First_Formal (Subp);
+      Etyp     := Etype (Next_Formal (F));
+
+      Subp_Decl :=
+        Make_Subprogram_Renaming_Declaration (Loc,
+          Specification =>
+
+            Make_Procedure_Specification (Loc,
+              Defining_Unit_Name => Subp_Id,
+              Parameter_Specifications =>
+                New_List (
+                  Make_Parameter_Specification (Loc,
+                    Defining_Identifier =>
+                      Make_Defining_Identifier (Loc, Name_S),
+                    Parameter_Type =>
+                      Make_Access_Definition (Loc,
+                        Subtype_Mark =>
+                          New_Reference_To (
+                            Designated_Type (Etype (F)), Loc))),
+
+                  Make_Parameter_Specification (Loc,
+                    Defining_Identifier =>
+                      Make_Defining_Identifier (Loc, Name_V),
+                    Out_Present => Out_P,
+                    Parameter_Type =>
+                      New_Reference_To (Etyp, Loc)))),
+        Name => New_Reference_To (Subp, Loc));
+
+      if Is_Tagged_Type (Ent) and then not Is_Limited_Type (Ent) then
+         Set_TSS (Base_Type (Ent), Subp_Id);
+      else
+         Insert_Action (N, Subp_Decl);
+         Copy_TSS (Subp_Id, Base_Type (Ent));
+      end if;
+
+   end New_Stream_Procedure;
+
+   ---------------------
+   -- Record_Rep_Item --
+   ---------------------
+
+   procedure Record_Rep_Item (T : Entity_Id; N : Node_Id) is
+   begin
+      Set_Next_Rep_Item (N, First_Rep_Item (T));
+      Set_First_Rep_Item (T, N);
+   end Record_Rep_Item;
+
+   ------------------------
+   -- Rep_Item_Too_Early --
+   ------------------------
+
+   function Rep_Item_Too_Early
+     (T     : Entity_Id;
+      N     : Node_Id)
+      return  Boolean
+   is
+   begin
+      --  Cannot apply rep items to generic types
+
+      if Is_Type (T)
+        and then Is_Generic_Type (Root_Type (T))
+      then
+         Error_Msg_N
+           ("representation item not allowed for generic type", N);
+         return True;
+      end if;
+
+      --  Otherwise check for incompleted type
+
+      if Is_Incomplete_Or_Private_Type (T)
+        and then No (Underlying_Type (T))
+      then
+         Error_Msg_N
+           ("representation item must be after full type declaration", N);
+         return True;
+
+      --  If the type has incompleted components, a representation clause is
+      --  illegal but stream attributes and Convention pragmas are correct.
+
+      elsif Has_Private_Component (T) then
+         if (Nkind (N) = N_Pragma or else Is_Operational_Item (N)) then
+            return False;
+         else
+            Error_Msg_N
+              ("representation item must appear after type is fully defined",
+                N);
+            return True;
+         end if;
+      else
+         return False;
+      end if;
+   end Rep_Item_Too_Early;
+
+   -----------------------
+   -- Rep_Item_Too_Late --
+   -----------------------
+
+   function Rep_Item_Too_Late
+     (T     : Entity_Id;
+      N     : Node_Id;
+      FOnly : Boolean := False)
+      return  Boolean
+   is
+      S           : Entity_Id;
+      Parent_Type : Entity_Id;
+
+      procedure Too_Late;
+      --  Output the too late message
+
+      procedure Too_Late is
+      begin
+         Error_Msg_N ("representation item appears too late!", N);
+      end Too_Late;
+
+   --  Start of processing for Rep_Item_Too_Late
+
+   begin
+      --  First make sure entity is not frozen (RM 13.1(9)). Exclude imported
+      --  types, which may be frozen if they appear in a representation clause
+      --  for a local type.
+
+      if Is_Frozen (T)
+        and then not From_With_Type (T)
+      then
+         Too_Late;
+         S := First_Subtype (T);
+
+         if Present (Freeze_Node (S)) then
+            Error_Msg_NE
+              ("?no more representation items for }!", Freeze_Node (S), S);
+         end if;
+
+         return True;
+
+      --  Check for case of non-tagged derived type whose parent either has
+      --  primitive operations, or is a by reference type (RM 13.1(10)).
+
+      elsif Is_Type (T)
+        and then not FOnly
+        and then Is_Derived_Type (T)
+        and then not Is_Tagged_Type (T)
+      then
+         Parent_Type := Etype (Base_Type (T));
+
+         if Has_Primitive_Operations (Parent_Type) then
+            Too_Late;
+            Error_Msg_NE
+              ("primitive operations already defined for&!", N, Parent_Type);
+            return True;
+
+         elsif Is_By_Reference_Type (Parent_Type) then
+            Too_Late;
+            Error_Msg_NE
+              ("parent type & is a by reference type!", N, Parent_Type);
+            return True;
+         end if;
+      end if;
+
+      --  No error, link item into head of chain of rep items for the entity
+
+      Record_Rep_Item (T, N);
+      return False;
+   end Rep_Item_Too_Late;
+
+   -------------------------
+   -- Same_Representation --
+   -------------------------
+
+   function Same_Representation (Typ1, Typ2 : Entity_Id) return Boolean is
+      T1 : constant Entity_Id := Underlying_Type (Typ1);
+      T2 : constant Entity_Id := Underlying_Type (Typ2);
+
+   begin
+      --  A quick check, if base types are the same, then we definitely have
+      --  the same representation, because the subtype specific representation
+      --  attributes (Size and Alignment) do not affect representation from
+      --  the point of view of this test.
+
+      if Base_Type (T1) = Base_Type (T2) then
+         return True;
+
+      elsif Is_Private_Type (Base_Type (T2))
+        and then Base_Type (T1) = Full_View (Base_Type (T2))
+      then
+         return True;
+      end if;
+
+      --  Tagged types never have differing representations
+
+      if Is_Tagged_Type (T1) then
+         return True;
+      end if;
+
+      --  Representations are definitely different if conventions differ
+
+      if Convention (T1) /= Convention (T2) then
+         return False;
+      end if;
+
+      --  Representations are different if component alignments differ
+
+      if (Is_Record_Type (T1) or else Is_Array_Type (T1))
+        and then
+         (Is_Record_Type (T2) or else Is_Array_Type (T2))
+        and then Component_Alignment (T1) /= Component_Alignment (T2)
+      then
+         return False;
+      end if;
+
+      --  For arrays, the only real issue is component size. If we know the
+      --  component size for both arrays, and it is the same, then that's
+      --  good enough to know we don't have a change of representation.
+
+      if Is_Array_Type (T1) then
+         if Known_Component_Size (T1)
+           and then Known_Component_Size (T2)
+           and then Component_Size (T1) = Component_Size (T2)
+         then
+            return True;
+         end if;
+      end if;
+
+      --  Types definitely have same representation if neither has non-standard
+      --  representation since default representations are always consistent.
+      --  If only one has non-standard representation, and the other does not,
+      --  then we consider that they do not have the same representation. They
+      --  might, but there is no way of telling early enough.
+
+      if Has_Non_Standard_Rep (T1) then
+         if not Has_Non_Standard_Rep (T2) then
+            return False;
+         end if;
+      else
+         return not Has_Non_Standard_Rep (T2);
+      end if;
+
+      --  Here the two types both have non-standard representation, and we
+      --  need to determine if they have the same non-standard representation
+
+      --  For arrays, we simply need to test if the component sizes are the
+      --  same. Pragma Pack is reflected in modified component sizes, so this
+      --  check also deals with pragma Pack.
+
+      if Is_Array_Type (T1) then
+         return Component_Size (T1) = Component_Size (T2);
+
+      --  Tagged types always have the same representation, because it is not
+      --  possible to specify different representations for common fields.
+
+      elsif Is_Tagged_Type (T1) then
+         return True;
+
+      --  Case of record types
+
+      elsif Is_Record_Type (T1) then
+
+         --  Packed status must conform
+
+         if Is_Packed (T1) /= Is_Packed (T2) then
+            return False;
+
+         --  Otherwise we must check components. Typ2 maybe a constrained
+         --  subtype with fewer components, so we compare the components
+         --  of the base types.
+
+         else
+            Record_Case : declare
+               CD1, CD2 : Entity_Id;
+
+               function Same_Rep return Boolean;
+               --  CD1 and CD2 are either components or discriminants. This
+               --  function tests whether the two have the same representation
+
+               function Same_Rep return Boolean is
+               begin
+                  if No (Component_Clause (CD1)) then
+                     return No (Component_Clause (CD2));
+
+                  else
+                     return
+                        Present (Component_Clause (CD2))
+                          and then
+                        Component_Bit_Offset (CD1) = Component_Bit_Offset (CD2)
+                          and then
+                        Esize (CD1) = Esize (CD2);
+                  end if;
+               end Same_Rep;
+
+            --  Start processing for Record_Case
+
+            begin
+               if Has_Discriminants (T1) then
+                  CD1 := First_Discriminant (T1);
+                  CD2 := First_Discriminant (T2);
+
+                  while Present (CD1) loop
+                     if not Same_Rep then
+                        return False;
+                     else
+                        Next_Discriminant (CD1);
+                        Next_Discriminant (CD2);
+                     end if;
+                  end loop;
+               end if;
+
+               CD1 := First_Component (Underlying_Type (Base_Type (T1)));
+               CD2 := First_Component (Underlying_Type (Base_Type (T2)));
+
+               while Present (CD1) loop
+                  if not Same_Rep then
+                     return False;
+                  else
+                     Next_Component (CD1);
+                     Next_Component (CD2);
+                  end if;
+               end loop;
+
+               return True;
+            end Record_Case;
+         end if;
+
+      --  For enumeration types, we must check each literal to see if the
+      --  representation is the same. Note that we do not permit enumeration
+      --  reprsentation clauses for Character and Wide_Character, so these
+      --  cases were already dealt with.
+
+      elsif Is_Enumeration_Type (T1) then
+
+         Enumeration_Case : declare
+            L1, L2 : Entity_Id;
+
+         begin
+            L1 := First_Literal (T1);
+            L2 := First_Literal (T2);
+
+            while Present (L1) loop
+               if Enumeration_Rep (L1) /= Enumeration_Rep (L2) then
+                  return False;
+               else
+                  Next_Literal (L1);
+                  Next_Literal (L2);
+               end if;
+            end loop;
+
+            return True;
+
+         end Enumeration_Case;
+
+      --  Any other types have the same representation for these purposes
+
+      else
+         return True;
+      end if;
+
+   end Same_Representation;
+
+   --------------------
+   -- Set_Enum_Esize --
+   --------------------
+
+   procedure Set_Enum_Esize (T : Entity_Id) is
+      Lo : Uint;
+      Hi : Uint;
+      Sz : Nat;
+
+   begin
+      Init_Alignment (T);
+
+      --  Find the minimum standard size (8,16,32,64) that fits
+
+      Lo := Enumeration_Rep (Entity (Type_Low_Bound (T)));
+      Hi := Enumeration_Rep (Entity (Type_High_Bound (T)));
+
+      if Lo < 0 then
+         if Lo >= -Uint_2**07 and then Hi < Uint_2**07 then
+            Sz := 8;
+
+         elsif Lo >= -Uint_2**15 and then Hi < Uint_2**15 then
+            Sz := 16;
+
+         elsif Lo >= -Uint_2**31 and then Hi < Uint_2**31 then
+            Sz := 32;
+
+         else pragma Assert (Lo >= -Uint_2**63 and then Hi < Uint_2**63);
+            Sz := 64;
+         end if;
+
+      else
+         if Hi < Uint_2**08 then
+            Sz := 8;
+
+         elsif Hi < Uint_2**16 then
+            Sz := 16;
+
+         elsif Hi < Uint_2**32 then
+            Sz := 32;
+
+         else pragma Assert (Hi < Uint_2**63);
+            Sz := 64;
+         end if;
+      end if;
+
+      --  That minimum is the proper size unless we have a foreign convention
+      --  and the size required is 32 or less, in which case we bump the size
+      --  up to 32. This is required for C and C++ and seems reasonable for
+      --  all other foreign conventions.
+
+      if Has_Foreign_Convention (T)
+        and then Esize (T) < Standard_Integer_Size
+      then
+         Init_Esize (T, Standard_Integer_Size);
+
+      else
+         Init_Esize (T, Sz);
+      end if;
+
+   end Set_Enum_Esize;
+
+   -----------------------------------
+   -- Validate_Unchecked_Conversion --
+   -----------------------------------
+
+   procedure Validate_Unchecked_Conversion
+     (N        : Node_Id;
+      Act_Unit : Entity_Id)
+   is
+      Source : Entity_Id;
+      Target : Entity_Id;
+      Vnode  : Node_Id;
+
+   begin
+      --  Obtain source and target types. Note that we call Ancestor_Subtype
+      --  here because the processing for generic instantiation always makes
+      --  subtypes, and we want the original frozen actual types.
+
+      --  If we are dealing with private types, then do the check on their
+      --  fully declared counterparts if the full declarations have been
+      --  encountered (they don't have to be visible, but they must exist!)
+
+      Source := Ancestor_Subtype (Etype (First_Formal (Act_Unit)));
+
+      if Is_Private_Type (Source)
+        and then Present (Underlying_Type (Source))
+      then
+         Source := Underlying_Type (Source);
+      end if;
+
+      Target := Ancestor_Subtype (Etype (Act_Unit));
+
+      --  If either type is generic, the instantiation happens within a
+      --  generic unit, and there is nothing to check. The proper check
+      --  will happen when the enclosing generic is instantiated.
+
+      if Is_Generic_Type (Source) or else Is_Generic_Type (Target) then
+         return;
+      end if;
+
+      if Is_Private_Type (Target)
+        and then Present (Underlying_Type (Target))
+      then
+         Target := Underlying_Type (Target);
+      end if;
+
+      --  Source may be unconstrained array, but not target
+
+      if Is_Array_Type (Target)
+        and then not Is_Constrained (Target)
+      then
+         Error_Msg_N
+           ("unchecked conversion to unconstrained array not allowed", N);
+         return;
+      end if;
+
+      --  Make entry in unchecked conversion table for later processing
+      --  by Validate_Unchecked_Conversions, which will check sizes and
+      --  alignments (using values set by the back-end where possible).
+
+      Unchecked_Conversions.Append
+        (New_Val => UC_Entry'
+           (Enode  => N,
+            Source => Source,
+            Target => Target));
+
+      --  Generate N_Validate_Unchecked_Conversion node for back end if
+      --  the back end needs to perform special validation checks. At the
+      --  current time, only the JVM version requires such checks.
+
+      if Java_VM then
+         Vnode :=
+           Make_Validate_Unchecked_Conversion (Sloc (N));
+         Set_Source_Type (Vnode, Source);
+         Set_Target_Type (Vnode, Target);
+         Insert_After (N, Vnode);
+      end if;
+   end Validate_Unchecked_Conversion;
+
+   ------------------------------------
+   -- Validate_Unchecked_Conversions --
+   ------------------------------------
+
+   procedure Validate_Unchecked_Conversions is
+   begin
+      for N in Unchecked_Conversions.First .. Unchecked_Conversions.Last loop
+         declare
+            T : UC_Entry renames Unchecked_Conversions.Table (N);
+
+            Enode  : constant Node_Id   := T.Enode;
+            Source : constant Entity_Id := T.Source;
+            Target : constant Entity_Id := T.Target;
+
+            Source_Siz    : Uint;
+            Target_Siz    : Uint;
+
+         begin
+            --  This validation check, which warns if we have unequal sizes
+            --  for unchecked conversion, and thus potentially implementation
+            --  dependent semantics, is one of the few occasions on which we
+            --  use the official RM size instead of Esize. See description
+            --  in Einfo "Handling of Type'Size Values" for details.
+
+            if Errors_Detected = 0
+              and then Known_Static_RM_Size (Source)
+              and then Known_Static_RM_Size (Target)
+            then
+               Source_Siz := RM_Size (Source);
+               Target_Siz := RM_Size (Target);
+
+               if Source_Siz /= Target_Siz then
+                  Warn_On_Instance := True;
+                  Error_Msg_N
+                    ("types for unchecked conversion have different sizes?",
+                     Enode);
+
+                  if All_Errors_Mode then
+                     Error_Msg_Name_1 := Chars (Source);
+                     Error_Msg_Uint_1 := Source_Siz;
+                     Error_Msg_Name_2 := Chars (Target);
+                     Error_Msg_Uint_2 := Target_Siz;
+                     Error_Msg_N
+                       ("\size of % is ^, size of % is ^?", Enode);
+
+                     Error_Msg_Uint_1 := UI_Abs (Source_Siz - Target_Siz);
+
+                     if Is_Discrete_Type (Source)
+                       and then Is_Discrete_Type (Target)
+                     then
+                        if Source_Siz > Target_Siz then
+                           Error_Msg_N
+                             ("\^ high order bits of source will be ignored?",
+                              Enode);
+
+                        elsif Is_Modular_Integer_Type (Source) then
+                           Error_Msg_N
+                             ("\source will be extended with ^ high order " &
+                              "zero bits?", Enode);
+
+                        else
+                           Error_Msg_N
+                             ("\source will be extended with ^ high order " &
+                              "sign bits?",
+                              Enode);
+                        end if;
+
+                     elsif Source_Siz < Target_Siz then
+                        if Is_Discrete_Type (Target) then
+                           if Bytes_Big_Endian then
+                              Error_Msg_N
+                                ("\target value will include ^ undefined " &
+                                 "low order bits?",
+                                 Enode);
+                           else
+                              Error_Msg_N
+                                ("\target value will include ^ undefined " &
+                                 "high order bits?",
+                                 Enode);
+                           end if;
+
+                        else
+                           Error_Msg_N
+                             ("\^ trailing bits of target value will be " &
+                              "undefined?", Enode);
+                        end if;
+
+                     else pragma Assert (Source_Siz > Target_Siz);
+                        Error_Msg_N
+                          ("\^ trailing bits of source will be ignored?",
+                           Enode);
+                     end if;
+                  end if;
+
+                  Warn_On_Instance := False;
+               end if;
+            end if;
+
+            --  If both types are access types, we need to check the alignment.
+            --  If the alignment of both is specified, we can do it here.
+
+            if Errors_Detected = 0
+              and then Ekind (Source) in Access_Kind
+              and then Ekind (Target) in Access_Kind
+              and then Target_Strict_Alignment
+              and then Present (Designated_Type (Source))
+              and then Present (Designated_Type (Target))
+            then
+               declare
+                  D_Source : constant Entity_Id := Designated_Type (Source);
+                  D_Target : constant Entity_Id := Designated_Type (Target);
+
+               begin
+                  if Known_Alignment (D_Source)
+                    and then Known_Alignment (D_Target)
+                  then
+                     declare
+                        Source_Align : constant Uint := Alignment (D_Source);
+                        Target_Align : constant Uint := Alignment (D_Target);
+
+                     begin
+                        if Source_Align < Target_Align
+                          and then not Is_Tagged_Type (D_Source)
+                        then
+                           Warn_On_Instance := True;
+                           Error_Msg_Uint_1 := Target_Align;
+                           Error_Msg_Uint_2 := Source_Align;
+                           Error_Msg_Node_2 := D_Source;
+                           Error_Msg_NE
+                             ("alignment of & (^) is stricter than " &
+                              "alignment of & (^)?", Enode, D_Target);
+
+                           if All_Errors_Mode then
+                              Error_Msg_N
+                                ("\resulting access value may have invalid " &
+                                 "alignment?", Enode);
+                           end if;
+
+                           Warn_On_Instance := False;
+                        end if;
+                     end;
+                  end if;
+               end;
+            end if;
+         end;
+      end loop;
+   end Validate_Unchecked_Conversions;
+
+   ------------------
+   -- Warn_Overlay --
+   ------------------
+
+   procedure Warn_Overlay
+     (Expr : Node_Id;
+      Typ  : Entity_Id;
+      Nam  : Node_Id)
+   is
+      Old  : Entity_Id := Empty;
+      Decl : Node_Id;
+
+   begin
+      if not Address_Clause_Overlay_Warnings then
+         return;
+      end if;
+
+      if Present (Expr)
+        and then (Has_Non_Null_Base_Init_Proc (Typ)
+                    or else Is_Access_Type (Typ))
+        and then not Is_Imported (Entity (Nam))
+      then
+         if Nkind (Expr) = N_Attribute_Reference
+           and then Is_Entity_Name (Prefix (Expr))
+         then
+            Old := Entity (Prefix (Expr));
+
+         elsif Is_Entity_Name (Expr)
+           and then Ekind (Entity (Expr)) = E_Constant
+         then
+            Decl := Declaration_Node (Entity (Expr));
+
+            if Nkind (Decl) = N_Object_Declaration
+              and then Present (Expression (Decl))
+              and then Nkind (Expression (Decl)) = N_Attribute_Reference
+              and then Is_Entity_Name (Prefix (Expression (Decl)))
+            then
+               Old := Entity (Prefix (Expression (Decl)));
+
+            elsif Nkind (Expr) = N_Function_Call then
+               return;
+            end if;
+
+         --  A function call (most likely to To_Address) is probably not
+         --  an overlay, so skip warning. Ditto if the function call was
+         --  inlined and transformed into an entity.
+
+         elsif Nkind (Original_Node (Expr)) = N_Function_Call then
+            return;
+         end if;
+
+         Decl := Next (Parent (Expr));
+
+         --  If a pragma Import follows, we assume that it is for the current
+         --  target of the address clause, and skip the warning.
+
+         if Present (Decl)
+           and then Nkind (Decl) = N_Pragma
+           and then Chars (Decl) = Name_Import
+         then
+            return;
+         end if;
+
+         if Present (Old) then
+            Error_Msg_Node_2 := Old;
+            Error_Msg_N
+              ("default initialization of & may modify &?",
+               Nam);
+         else
+            Error_Msg_N
+              ("default initialization of & may modify overlaid storage?",
+               Nam);
+         end if;
+
+         --  Add friendly warning if initialization comes from a packed array
+         --  component.
+
+         if Is_Record_Type (Typ)  then
+            declare
+               Comp : Entity_Id;
+
+            begin
+               Comp := First_Component (Typ);
+
+               while Present (Comp) loop
+                  if Nkind (Parent (Comp)) = N_Component_Declaration
+                    and then Present (Expression (Parent (Comp)))
+                  then
+                     exit;
+                  elsif Is_Array_Type (Etype (Comp))
+                     and then Present (Packed_Array_Type (Etype (Comp)))
+                  then
+                     Error_Msg_NE
+                       ("packed array component& will be initialized to zero?",
+                          Nam, Comp);
+                     exit;
+                  else
+                     Next_Component (Comp);
+                  end if;
+               end loop;
+            end;
+         end if;
+
+         Error_Msg_N
+           ("use pragma Import for & to " &
+              "suppress initialization ('R'M B.1(24))?",
+             Nam);
+      end if;
+   end Warn_Overlay;
+
+end Sem_Ch13;
diff --git a/gcc/ada/sem_ch13.ads b/gcc/ada/sem_ch13.ads
new file mode 100644
index 00000000000..5afe5adb208
--- /dev/null
+++ b/gcc/ada/sem_ch13.ads
@@ -0,0 +1,171 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             S E M _ C H 1 3                              --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.39 $
+--                                                                          --
+--          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 Snames; use Snames;
+with Types; use Types;
+with Uintp; use Uintp;
+
+package Sem_Ch13 is
+   procedure Analyze_At_Clause                          (N : Node_Id);
+   procedure Analyze_Attribute_Definition_Clause        (N : Node_Id);
+   procedure Analyze_Enumeration_Representation_Clause  (N : Node_Id);
+   procedure Analyze_Free_Statement                     (N : Node_Id);
+   procedure Analyze_Record_Representation_Clause       (N : Node_Id);
+   procedure Analyze_Code_Statement                     (N : Node_Id);
+
+   procedure Initialize;
+   --  Initialize internal tables for new compilation
+
+   procedure Set_Enum_Esize (T : Entity_Id);
+   --  This routine sets the Esize field for an enumeration type T, based
+   --  on the current representation information available for T. Note that
+   --  the setting of the RM_Size field is not affected. This routine also
+   --  initializes the alignment field to zero.
+
+   function Minimum_Size
+     (T      : Entity_Id;
+      Biased : Boolean := False)
+      return   Nat;
+   --  Given a primitive type, determines the minimum number of bits required
+   --  to represent all values of the type. This function may not be called
+   --  with any other types. If the flag Biased is set True, then the minimum
+   --  size calculation that biased representation is used in the case of a
+   --  discrete type, e.g. the range 7..8 gives a minimum size of 4 with
+   --  Biased set to False, and 1 with Biased set to True. Note that the
+   --  biased parameter only has an effect if the type is not biased, it
+   --  causes Minimum_Size to indicate the minimum size of an object with
+   --  the given type, of the size the type would have if it were biased. If
+   --  the type is already biased, then Minimum_Size returns the biased size,
+   --  regardless of the setting of Biased. Also, fixed-point types are never
+   --  biased in the current implementation.
+
+   procedure Check_Size
+     (N      : Node_Id;
+      T      : Entity_Id;
+      Siz    : Uint;
+      Biased : out Boolean);
+   --  Called when size Siz is specified for subtype T. This subprogram checks
+   --  that the size is appropriate, posting errors on node N as required.
+   --  For non-elementary types, a check is only made if an explicit size
+   --  has been given for the type (and the specified size must match). The
+   --  parameter Biased is set False if the size specified did not require
+   --  the use of biased representation, and True if biased representation
+   --  was required to meet the size requirement. Note that Biased is only
+   --  set if the type is not currently biased, but biasing it is the only
+   --  way to meet the requirement. If the type is currently biased, then
+   --  this biased size is used in the initial check, and Biased is False.
+
+   function Get_Rep_Pragma (E : Entity_Id; Nam : Name_Id) return Node_Id;
+   --  Searches the Rep_Item chain for the given entity E, for an instance
+   --  of a representation pragma with the given name Nam. If found then
+   --  the value returned is the N_Pragma node, otherwise Empty is returned.
+
+   function Get_Attribute_Definition_Clause
+     (E    : Entity_Id;
+      Id   : Attribute_Id)
+      return Node_Id;
+   --  Searches the Rep_Item chain for a given entity E, for an instance
+   --  of an attribute definition clause with the given attibute Id Id. If
+   --  found, the value returned is the N_Attribute_Definition_Clause node,
+   --  otherwise Empty is returned.
+
+   procedure Record_Rep_Item (T : Entity_Id; N : Node_Id);
+   --  N is the node for either a representation pragma or an attribute
+   --  definition clause that applies to type T. This procedure links
+   --  the node N onto the Rep_Item chain for the type T.
+
+   function Rep_Item_Too_Early
+     (T     : Entity_Id;
+      N     : Node_Id)
+      return  Boolean;
+   --  Called at the start of processing a representation clause or a
+   --  representation pragma. Used to check that the representation item
+   --  is not being applied to an incompleted type or to a generic formal
+   --  type or a type derived from a generic formal type. Returns False if
+   --  no such error occurs. If this error does occur, appropriate error
+   --  messages are posted on node N, and True is returned.
+
+   function Rep_Item_Too_Late
+     (T     : Entity_Id;
+      N     : Node_Id;
+      FOnly : Boolean := False)
+      return  Boolean;
+   --  Called at the start of processing a representation clause or a
+   --  representation pragma. Used to check that a representation item
+   --  for entity T does not appear too late (according to the rules in
+   --  RM 13.1(9) and RM 13.1(10)). N is the associated node, which in
+   --  the pragma case is the pragma or representation clause itself, used
+   --  for placing error messages if the item is too late.
+   --
+   --  Fonly is a flag that causes only the freezing rule (para 9) to be
+   --  applied, and the tests of para 10 are skipped. This is appropriate
+   --  for both subtype related attributes (Alignment and Size) and for
+   --  stream attributes, which, although certainly not subtype related
+   --  attributes, clearly should not be subject to the para 10 restrictions
+   --  (see AI95-00137). Similarly, we also skip the para 10 restrictions for
+   --  the Storage_Size case where they also clearly do not apply.
+   --
+   --  If the rep item is too late, an appropriate message is output and
+   --  True is returned, which is a signal that the caller should abandon
+   --  processing for the item. If the item is not too late, then False
+   --  is returned, and the caller can continue processing the item.
+   --
+   --  If no error is detected, this call also as a side effect links the
+   --  representation item onto the head of the representation item chain
+   --  (referenced by the First_Rep_Item field of the entity).
+   --
+   --  Note: Rep_Item_Too_Late must be called with the underlying type in
+   --  the case of a private or incomplete type. The protocol is to first
+   --  check for Rep_Item_Too_Early using the initial entity, then take the
+   --  underlying type, then call Rep_Item_Too_Late on the result.
+
+   function Same_Representation (Typ1, Typ2 : Entity_Id) return Boolean;
+   --  Given two types, where the two types are related by possible derivation,
+   --  determines if the two types have the same representation, or different
+   --  representations, requiring the special processing for representation
+   --  change. A False result is possible only for array, enumeration or
+   --  record types.
+
+   procedure Validate_Unchecked_Conversion
+     (N        : Node_Id;
+      Act_Unit : Entity_Id);
+   --  Validate a call to unchecked conversion. N is the node for the actual
+   --  instantiation, which is used only for error messages. Act_Unit is the
+   --  entity for the instantiation, from which the actual types etc for this
+   --  instantiation can be determined. This procedure makes an entry in a
+   --  table and/or generates an N_Validate_Unchecked_Conversion node. The
+   --  actual checking is done in Validate_Unchecked_Conversions or in the
+   --  back end as required.
+
+   procedure Validate_Unchecked_Conversions;
+   --  This routine is called after calling the backend to validate
+   --  unchecked conversions for size and alignment appropriateness.
+   --  The reason it is called that late is to take advantage of any
+   --  back-annotation of size and alignment performed by the backend.
+
+end Sem_Ch13;
diff --git a/gcc/ada/sem_ch2.adb b/gcc/ada/sem_ch2.adb
new file mode 100644
index 00000000000..f8e85b3c02a
--- /dev/null
+++ b/gcc/ada/sem_ch2.adb
@@ -0,0 +1,117 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              S E M _ C H 2                               --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.8 $                              --
+--                                                                          --
+--          Copyright (C) 1992-1999, 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 Opt;      use Opt;
+with Restrict; use Restrict;
+with Sem_Ch8;  use Sem_Ch8;
+with Sinfo;    use Sinfo;
+with Stand;    use Stand;
+
+package body Sem_Ch2 is
+
+   -------------------------------
+   -- Analyze_Character_Literal --
+   -------------------------------
+
+   procedure Analyze_Character_Literal (N : Node_Id) is
+   begin
+
+      --  The type is eventually inherited from the context. If expansion
+      --  has already established the proper type, do not modify it.
+
+      if No (Etype (N)) then
+         Set_Etype (N, Any_Character);
+      end if;
+
+      Set_Is_Static_Expression (N);
+
+      if Comes_From_Source (N)
+        and then not In_Character_Range (Char_Literal_Value (N))
+      then
+         Check_Restriction (No_Wide_Characters, N);
+      end if;
+   end Analyze_Character_Literal;
+
+   ------------------------
+   -- Analyze_Identifier --
+   ------------------------
+
+   procedure Analyze_Identifier (N : Node_Id) is
+   begin
+      Find_Direct_Name (N);
+   end Analyze_Identifier;
+
+   -----------------------------
+   -- Analyze_Integer_Literal --
+   -----------------------------
+
+   procedure Analyze_Integer_Literal (N : Node_Id) is
+   begin
+      Set_Etype (N, Universal_Integer);
+      Set_Is_Static_Expression (N);
+   end Analyze_Integer_Literal;
+
+   --------------------------
+   -- Analyze_Real_Literal --
+   --------------------------
+
+   procedure Analyze_Real_Literal (N : Node_Id) is
+   begin
+      Set_Etype (N, Universal_Real);
+      Set_Is_Static_Expression (N);
+   end Analyze_Real_Literal;
+
+   ----------------------------
+   -- Analyze_String_Literal --
+   ----------------------------
+
+   procedure Analyze_String_Literal (N : Node_Id) is
+   begin
+
+      --  The type is eventually inherited from the context. If expansion
+      --  has already established the proper type, do not modify it.
+
+      if No (Etype (N)) then
+         Set_Etype (N, Any_String);
+      end if;
+
+      --  String literals are static in Ada 95. Note that if the subtype
+      --  turns out to be non-static, then the Is_Static_Expression flag
+      --  will be reset in Eval_String_Literal.
+
+      if Ada_95 then
+         Set_Is_Static_Expression (N);
+      end if;
+
+      if Comes_From_Source (N) and then Has_Wide_Character (N) then
+         Check_Restriction (No_Wide_Characters, N);
+      end if;
+   end Analyze_String_Literal;
+
+end Sem_Ch2;
diff --git a/gcc/ada/sem_ch2.ads b/gcc/ada/sem_ch2.ads
new file mode 100644
index 00000000000..d85de7f8b05
--- /dev/null
+++ b/gcc/ada/sem_ch2.ads
@@ -0,0 +1,46 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              S E M _ C H 2                               --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.3 $                              --
+--                                                                          --
+--          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). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+with Types; use Types;
+
+package Sem_Ch2 is
+
+   procedure Analyze_Character_Literal (N : Node_Id);
+   procedure Analyze_Identifier        (N : Node_Id);
+   procedure Analyze_Integer_Literal   (N : Node_Id);
+   procedure Analyze_Real_Literal      (N : Node_Id);
+   procedure Analyze_String_Literal    (N : Node_Id);
+
+private
+   pragma Inline (Analyze_Character_Literal);
+   pragma Inline (Analyze_Identifier);
+   pragma Inline (Analyze_Integer_Literal);
+   pragma Inline (Analyze_Real_Literal);
+   pragma Inline (Analyze_String_Literal);
+
+end Sem_Ch2;
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
new file mode 100644
index 00000000000..dd9b6b07e73
--- /dev/null
+++ b/gcc/ada/sem_ch3.adb
@@ -0,0 +1,12122 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              S E M _ C H 3                               --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.1354 $
+--                                                                          --
+--          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 Checks;   use Checks;
+with Elists;   use Elists;
+with Einfo;    use Einfo;
+with Errout;   use Errout;
+with Eval_Fat; use Eval_Fat;
+with Exp_Ch3;  use Exp_Ch3;
+with Exp_Dist; use Exp_Dist;
+with Exp_Util; use Exp_Util;
+with Freeze;   use Freeze;
+with Itypes;   use Itypes;
+with Layout;   use Layout;
+with Lib;      use Lib;
+with Lib.Xref; use Lib.Xref;
+with Namet;    use Namet;
+with Nmake;    use Nmake;
+with Opt;      use Opt;
+with Restrict; use Restrict;
+with Rtsfind;  use Rtsfind;
+with Sem;      use Sem;
+with Sem_Case; use Sem_Case;
+with Sem_Cat;  use Sem_Cat;
+with Sem_Ch6;  use Sem_Ch6;
+with Sem_Ch7;  use Sem_Ch7;
+with Sem_Ch8;  use Sem_Ch8;
+with Sem_Ch13; use Sem_Ch13;
+with Sem_Disp; use Sem_Disp;
+with Sem_Dist; use Sem_Dist;
+with Sem_Elim; use Sem_Elim;
+with Sem_Eval; use Sem_Eval;
+with Sem_Mech; use Sem_Mech;
+with Sem_Res;  use Sem_Res;
+with Sem_Smem; use Sem_Smem;
+with Sem_Type; use Sem_Type;
+with Sem_Util; use Sem_Util;
+with Stand;    use Stand;
+with Sinfo;    use Sinfo;
+with Snames;   use Snames;
+with Tbuild;   use Tbuild;
+with Ttypes;   use Ttypes;
+with Uintp;    use Uintp;
+with Urealp;   use Urealp;
+
+package body Sem_Ch3 is
+
+   -----------------------
+   -- Local Subprograms --
+   -----------------------
+
+   procedure Build_Derived_Type
+     (N             : Node_Id;
+      Parent_Type   : Entity_Id;
+      Derived_Type  : Entity_Id;
+      Is_Completion : Boolean;
+      Derive_Subps  : Boolean := True);
+   --  Create and decorate a Derived_Type given the Parent_Type entity.
+   --  N is the N_Full_Type_Declaration node containing the derived type
+   --  definition. Parent_Type is the entity for the parent type in the derived
+   --  type definition and Derived_Type the actual derived type. Is_Completion
+   --  must be set to False if Derived_Type is the N_Defining_Identifier node
+   --  in N (ie Derived_Type = Defining_Identifier (N)). In this case N is not
+   --  the completion of a private type declaration. If Is_Completion is
+   --  set to True, N is the completion of a private type declaration and
+   --  Derived_Type is different from the defining identifier inside N (i.e.
+   --  Derived_Type /= Defining_Identifier (N)). Derive_Subps indicates whether
+   --  the parent subprograms should be derived. The only case where this
+   --  parameter is False is when Build_Derived_Type is recursively called to
+   --  process an implicit derived full type for a type derived from a private
+   --  type (in that case the subprograms must only be derived for the private
+   --  view of the type).
+   --  ??? These flags need a bit of re-examination and re-documentaion:
+   --  ???  are they both necessary (both seem related to the recursion)?
+
+   procedure Build_Derived_Access_Type
+     (N            : Node_Id;
+      Parent_Type  : Entity_Id;
+      Derived_Type : Entity_Id);
+   --  Subsidiary procedure to Build_Derived_Type. For a derived access type,
+   --  create an implicit base if the parent type is constrained or if the
+   --  subtype indication has a constraint.
+
+   procedure Build_Derived_Array_Type
+     (N            : Node_Id;
+      Parent_Type  : Entity_Id;
+      Derived_Type : Entity_Id);
+   --  Subsidiary procedure to Build_Derived_Type. For a derived array type,
+   --  create an implicit base if the parent type is constrained or if the
+   --  subtype indication has a constraint.
+
+   procedure Build_Derived_Concurrent_Type
+     (N            : Node_Id;
+      Parent_Type  : Entity_Id;
+      Derived_Type : Entity_Id);
+   --  Subsidiary procedure to Build_Derived_Type. For a derived task or pro-
+   --  tected type, inherit entries and protected subprograms, check legality
+   --  of discriminant constraints if any.
+
+   procedure Build_Derived_Enumeration_Type
+     (N            : Node_Id;
+      Parent_Type  : Entity_Id;
+      Derived_Type : Entity_Id);
+   --  Subsidiary procedure to Build_Derived_Type. For a derived enumeration
+   --  type, we must create a new list of literals. Types derived from
+   --  Character and Wide_Character are special-cased.
+
+   procedure Build_Derived_Numeric_Type
+     (N            : Node_Id;
+      Parent_Type  : Entity_Id;
+      Derived_Type : Entity_Id);
+   --  Subsidiary procedure to Build_Derived_Type. For numeric types, create
+   --  an anonymous base type, and propagate constraint to subtype if needed.
+
+   procedure Build_Derived_Private_Type
+     (N            : Node_Id;
+      Parent_Type  : Entity_Id;
+      Derived_Type : Entity_Id;
+      Is_Completion : Boolean;
+      Derive_Subps  : Boolean := True);
+   --  Substidiary procedure to Build_Derived_Type. This procedure is complex
+   --  because the parent may or may not have a completion, and the derivation
+   --  may itself be a completion.
+
+   procedure Build_Derived_Record_Type
+     (N            : Node_Id;
+      Parent_Type  : Entity_Id;
+      Derived_Type : Entity_Id;
+      Derive_Subps : Boolean := True);
+   --  Subsidiary procedure to Build_Derived_Type and
+   --  Analyze_Private_Extension_Declaration used for tagged and untagged
+   --  record types. All parameters are as in Build_Derived_Type except that
+   --  N, in addition to being an N_Full_Type_Declaration node, can also be an
+   --  N_Private_Extension_Declaration node. See the definition of this routine
+   --  for much more info. Derive_Subps indicates whether subprograms should
+   --  be derived from the parent type. The only case where Derive_Subps is
+   --  False is for an implicit derived full type for a type derived from a
+   --  private type (see Build_Derived_Type).
+
+   function Inherit_Components
+     (N             : Node_Id;
+      Parent_Base   : Entity_Id;
+      Derived_Base  : Entity_Id;
+      Is_Tagged     : Boolean;
+      Inherit_Discr : Boolean;
+      Discs         : Elist_Id)
+      return          Elist_Id;
+   --  Called from Build_Derived_Record_Type to inherit the components of
+   --  Parent_Base (a base type) into the Derived_Base (the derived base type).
+   --  For more information on derived types and component inheritance please
+   --  consult the comment above the body of Build_Derived_Record_Type.
+   --
+   --  N is the original derived type declaration.
+   --  Is_Tagged is set if we are dealing with tagged types.
+   --  If Inherit_Discr is set, Derived_Base inherits its discriminants from
+   --  Parent_Base, otherwise no discriminants are inherited.
+   --  Discs gives the list of constraints that apply to Parent_Base in the
+   --  derived type declaration. If Discs is set to No_Elist, then we have the
+   --  following situation:
+   --
+   --     type Parent (D1..Dn : ..) is [tagged] record ...;
+   --     type Derived is new Parent [with ...];
+   --
+   --  which gets treated as
+   --
+   --     type Derived (D1..Dn : ..) is new Parent (D1,..,Dn) [with ...];
+   --
+   --  For untagged types the returned value is an association list:
+   --  (Old_Component => New_Component), where Old_Component is the Entity_Id
+   --  of a component in Parent_Base and New_Component is the Entity_Id of the
+   --  corresponding component in Derived_Base. For untagged records, this
+   --  association list is needed when copying the record declaration for the
+   --  derived base. In the tagged case the value returned is irrelevant.
+
+   procedure Build_Discriminal (Discrim : Entity_Id);
+   --  Create the discriminal corresponding to discriminant Discrim, that is
+   --  the parameter corresponding to Discrim to be used in initialization
+   --  procedures for the type where Discrim is a discriminant. Discriminals
+   --  are not used during semantic analysis, and are not fully defined
+   --  entities until expansion. Thus they are not given a scope until
+   --  intialization procedures are built.
+
+   function Build_Discriminant_Constraints
+     (T           : Entity_Id;
+      Def         : Node_Id;
+      Derived_Def : Boolean := False)
+      return        Elist_Id;
+   --  Validate discriminant constraints, and return the list of the
+   --  constraints in order of discriminant declarations. T is the
+   --  discriminated unconstrained type. Def is the N_Subtype_Indication
+   --  node where the discriminants constraints for T are specified.
+   --  Derived_Def is True if we are building the discriminant constraints
+   --  in a derived type definition of the form "type D (...) is new T (xxx)".
+   --  In this case T is the parent type and Def is the constraint "(xxx)" on
+   --  T and this routine sets the Corresponding_Discriminant field of the
+   --  discriminants in the derived type D to point to the corresponding
+   --  discriminants in the parent type T.
+
+   procedure Build_Discriminated_Subtype
+     (T           : Entity_Id;
+      Def_Id      : Entity_Id;
+      Elist       : Elist_Id;
+      Related_Nod : Node_Id;
+      For_Access  : Boolean := False);
+   --  Subsidiary procedure to Constrain_Discriminated_Type and to
+   --  Process_Incomplete_Dependents. Given
+   --
+   --     T (a possibly discriminated base type)
+   --     Def_Id (a very partially built subtype for T),
+   --
+   --  the call completes Def_Id to be the appropriate E_*_Subtype.
+   --
+   --  The Elist is the list of discriminant constraints if any (it is set to
+   --  No_Elist if T is not a discriminated type, and to an empty list if
+   --  T has discriminants but there are no discriminant constraints). The
+   --  Related_Nod is the same as Decl_Node in Create_Constrained_Components.
+   --  The For_Access says whether or not this subtype is really constraining
+   --  an access type. That is its sole purpose is the designated type of an
+   --  access type -- in which case a Private_Subtype Is_For_Access_Subtype
+   --  is built to avoid freezing T when the access subtype is frozen.
+
+   function Build_Scalar_Bound
+     (Bound : Node_Id;
+      Par_T : Entity_Id;
+      Der_T : Entity_Id;
+      Loc   : Source_Ptr)
+      return  Node_Id;
+   --  The bounds of a derived scalar type are conversions of the bounds of
+   --  the parent type. Optimize the representation if the bounds are literals.
+   --  Needs a more complete spec--what are the parameters exactly, and what
+   --  exactly is the returned value, and how is Bound affected???
+
+   procedure Build_Underlying_Full_View
+     (N   : Node_Id;
+      Typ : Entity_Id;
+      Par : Entity_Id);
+   --  If the completion of a private type is itself derived from a private
+   --  type, or if the full view of a private subtype is itself private, the
+   --  back-end has no way to compute the actual size of this type. We build
+   --  an internal subtype declaration of the proper parent type to convey
+   --  this information. This extra mechanism is needed because a full
+   --  view cannot itself have a full view (it would get clobbered during
+   --  view exchanges).
+
+   procedure Check_Access_Discriminant_Requires_Limited
+     (D   : Node_Id;
+      Loc : Node_Id);
+   --  Check the restriction that the type to which an access discriminant
+   --  belongs must be a concurrent type or a descendant of a type with
+   --  the reserved word 'limited' in its declaration.
+
+   procedure Check_Delta_Expression (E : Node_Id);
+   --  Check that the expression represented by E is suitable for use as
+   --  a delta expression, i.e. it is of real type and is static.
+
+   procedure Check_Digits_Expression (E : Node_Id);
+   --  Check that the expression represented by E is suitable for use as
+   --  a digits expression, i.e. it is of integer type, positive and static.
+
+   procedure Check_Incomplete (T : Entity_Id);
+   --  Called to verify that an incomplete type is not used prematurely
+
+   procedure Check_Initialization (T : Entity_Id; Exp : Node_Id);
+   --  Validate the initialization of an object declaration. T is the
+   --  required type, and Exp is the initialization expression.
+
+   procedure Check_Or_Process_Discriminants (N : Node_Id; T : Entity_Id);
+   --  If T is the full declaration of an incomplete or private type, check
+   --  the conformance of the discriminants, otherwise process them.
+
+   procedure Check_Real_Bound (Bound : Node_Id);
+   --  Check given bound for being of real type and static. If not, post an
+   --  appropriate message, and rewrite the bound with the real literal zero.
+
+   procedure Constant_Redeclaration
+     (Id : Entity_Id;
+      N  : Node_Id;
+      T  : out Entity_Id);
+   --  Various checks on legality of full declaration of deferred constant.
+   --  Id is the entity for the redeclaration, N is the N_Object_Declaration,
+   --  node. The caller has not yet set any attributes of this entity.
+
+   procedure Convert_Scalar_Bounds
+     (N            : Node_Id;
+      Parent_Type  : Entity_Id;
+      Derived_Type : Entity_Id;
+      Loc          : Source_Ptr);
+   --  For derived scalar types, convert the bounds in the type definition
+   --  to the derived type, and complete their analysis.
+
+   procedure Copy_Array_Base_Type_Attributes (T1, T2 : Entity_Id);
+   --  Copies attributes from array base type T2 to array base type T1.
+   --  Copies only attributes that apply to base types, but not subtypes.
+
+   procedure Copy_Array_Subtype_Attributes (T1, T2 : Entity_Id);
+   --  Copies attributes from array subtype T2 to array subtype T1. Copies
+   --  attributes that apply to both subtypes and base types.
+
+   procedure Create_Constrained_Components
+     (Subt        : Entity_Id;
+      Decl_Node   : Node_Id;
+      Typ         : Entity_Id;
+      Constraints : Elist_Id);
+   --  Build the list of entities for a constrained discriminated record
+   --  subtype. If a component depends on a discriminant, replace its subtype
+   --  using the discriminant values in the discriminant constraint.
+   --  Subt is the defining identifier for the subtype whose list of
+   --  constrained entities we will create. Decl_Node is the type declaration
+   --  node where we will attach all the itypes created. Typ is the base
+   --  discriminated type for the subtype Subt. Constraints is the list of
+   --  discriminant constraints for Typ.
+
+   function Constrain_Component_Type
+     (Compon_Type     : Entity_Id;
+      Constrained_Typ : Entity_Id;
+      Related_Node    : Node_Id;
+      Typ             : Entity_Id;
+      Constraints     : Elist_Id)
+      return            Entity_Id;
+   --  Given a discriminated base type Typ, a list of discriminant constraint
+   --  Constraints for Typ and the type of a component of Typ, Compon_Type,
+   --  create and return the type corresponding to Compon_type where all
+   --  discriminant references are replaced with the corresponding
+   --  constraint. If no discriminant references occurr in Compon_Typ then
+   --  return it as is. Constrained_Typ is the final constrained subtype to
+   --  which the constrained Compon_Type belongs. Related_Node is the node
+   --  where we will attach all the itypes created.
+
+   procedure Constrain_Access
+     (Def_Id      : in out Entity_Id;
+      S           : Node_Id;
+      Related_Nod : Node_Id);
+   --  Apply a list of constraints to an access type. If Def_Id is empty,
+   --  it is an anonymous type created for a subtype indication. In that
+   --  case it is created in the procedure and attached to Related_Nod.
+
+   procedure Constrain_Array
+     (Def_Id      : in out Entity_Id;
+      SI          : Node_Id;
+      Related_Nod : Node_Id;
+      Related_Id  : Entity_Id;
+      Suffix      : Character);
+   --  Apply a list of index constraints to an unconstrained array type. The
+   --  first parameter is the entity for the resulting subtype. A value of
+   --  Empty for Def_Id indicates that an implicit type must be created, but
+   --  creation is delayed (and must be done by this procedure) because other
+   --  subsidiary implicit types must be created first (which is why Def_Id
+   --  is an in/out parameter). Related_Nod gives the place where this type has
+   --  to be inserted in the tree. The Related_Id and Suffix parameters are
+   --  used to build the associated Implicit type name.
+
+   procedure Constrain_Concurrent
+     (Def_Id      : in out Entity_Id;
+      SI          : Node_Id;
+      Related_Nod : Node_Id;
+      Related_Id  : Entity_Id;
+      Suffix      : Character);
+   --  Apply list of discriminant constraints to an unconstrained concurrent
+   --  type.
+   --
+   --    SI is the N_Subtype_Indication node containing the constraint and
+   --    the unconstrained type to constrain.
+   --
+   --    Def_Id is the entity for the resulting constrained subtype. A
+   --    value of Empty for Def_Id indicates that an implicit type must be
+   --    created, but creation is delayed (and must be done by this procedure)
+   --    because other subsidiary implicit types must be created first (which
+   --    is why Def_Id is an in/out parameter).
+   --
+   --    Related_Nod gives the place where this type has to be inserted
+   --    in the tree
+   --
+   --  The last two arguments are used to create its external name if needed.
+
+   function Constrain_Corresponding_Record
+     (Prot_Subt   : Entity_Id;
+      Corr_Rec    : Entity_Id;
+      Related_Nod : Node_Id;
+      Related_Id  : Entity_Id)
+      return Entity_Id;
+   --  When constraining a protected type or task type with discriminants,
+   --  constrain the corresponding record with the same discriminant values.
+
+   procedure Constrain_Decimal
+     (Def_Id      : Node_Id;
+      S           : Node_Id;
+      Related_Nod : Node_Id);
+   --  Constrain a decimal fixed point type with a digits constraint and/or a
+   --  range constraint, and build E_Decimal_Fixed_Point_Subtype entity.
+
+   procedure Constrain_Discriminated_Type
+     (Def_Id      : Entity_Id;
+      S           : Node_Id;
+      Related_Nod : Node_Id;
+      For_Access  : Boolean := False);
+   --  Process discriminant constraints of composite type. Verify that values
+   --  have been provided for all discriminants, that the original type is
+   --  unconstrained, and that the types of the supplied expressions match
+   --  the discriminant types. The first three parameters are like in routine
+   --  Constrain_Concurrent. See Build_Discrimated_Subtype for an explanation
+   --  of For_Access.
+
+   procedure Constrain_Enumeration
+     (Def_Id      : Node_Id;
+      S           : Node_Id;
+      Related_Nod : Node_Id);
+   --  Constrain an enumeration type with a range constraint. This is
+   --  identical to Constrain_Integer, but for the Ekind of the
+   --  resulting subtype.
+
+   procedure Constrain_Float
+     (Def_Id      : Node_Id;
+      S           : Node_Id;
+      Related_Nod : Node_Id);
+   --  Constrain a floating point type with either a digits constraint
+   --  and/or a range constraint, building a E_Floating_Point_Subtype.
+
+   procedure Constrain_Index
+     (Index        : Node_Id;
+      S            : Node_Id;
+      Related_Nod  : Node_Id;
+      Related_Id   : Entity_Id;
+      Suffix       : Character;
+      Suffix_Index : Nat);
+   --  Process an index constraint in a constrained array declaration.
+   --  The constraint can be a subtype name, or a range with or without
+   --  an explicit subtype mark. The index is the corresponding index of the
+   --  unconstrained array. The Related_Id and Suffix parameters are used to
+   --  build the associated Implicit type name.
+
+   procedure Constrain_Integer
+     (Def_Id      : Node_Id;
+      S           : Node_Id;
+      Related_Nod : Node_Id);
+   --  Build subtype of a signed or modular integer type.
+
+   procedure Constrain_Ordinary_Fixed
+     (Def_Id      : Node_Id;
+      S           : Node_Id;
+      Related_Nod : Node_Id);
+   --  Constrain an ordinary fixed point type with a range constraint, and
+   --  build an E_Ordinary_Fixed_Point_Subtype entity.
+
+   procedure Copy_And_Swap (Privat, Full : Entity_Id);
+   --  Copy the Privat entity into the entity of its full declaration
+   --  then swap the two entities in such a manner that the former private
+   --  type is now seen as a full type.
+
+   procedure Copy_Private_To_Full (Priv, Full : Entity_Id);
+   --  Initialize the full view declaration with the relevant fields
+   --  from the private view.
+
+   procedure Decimal_Fixed_Point_Type_Declaration
+     (T   : Entity_Id;
+      Def : Node_Id);
+   --  Create a new decimal fixed point type, and apply the constraint to
+   --  obtain a subtype of this new type.
+
+   procedure Complete_Private_Subtype
+     (Priv        : Entity_Id;
+      Full        : Entity_Id;
+      Full_Base   : Entity_Id;
+      Related_Nod : Node_Id);
+   --  Complete the implicit full view of a private subtype by setting
+   --  the appropriate semantic fields. If the full view of the parent is
+   --  a record type, build constrained components of subtype.
+
+   procedure Derived_Standard_Character
+     (N             : Node_Id;
+      Parent_Type   : Entity_Id;
+      Derived_Type  : Entity_Id);
+   --  Subsidiary procedure to Build_Derived_Enumeration_Type which handles
+   --  derivations from types Standard.Character and Standard.Wide_Character.
+
+   procedure Derived_Type_Declaration
+     (T             : Entity_Id;
+      N             : Node_Id;
+      Is_Completion : Boolean);
+   --  Process a derived type declaration. This routine will invoke
+   --  Build_Derived_Type to process the actual derived type definition.
+   --  Parameters N and Is_Completion have the same meaning as in
+   --  Build_Derived_Type. T is the N_Defining_Identifier for the entity
+   --  defined in the N_Full_Type_Declaration node N, that is T is the
+   --  derived type.
+
+   function Find_Type_Of_Subtype_Indic (S : Node_Id) return Entity_Id;
+   --  Given a subtype indication S (which is really an N_Subtype_Indication
+   --  node or a plain N_Identifier), find the type of the subtype mark.
+
+   procedure Enumeration_Type_Declaration (T : Entity_Id; Def : Node_Id);
+   --  Insert each literal in symbol table, as an overloadable identifier
+   --  Each enumeration type is mapped into a sequence of integers, and
+   --  each literal is defined as a constant with integer value. If any
+   --  of the literals are character literals, the type is a character
+   --  type, which means that strings are legal aggregates for arrays of
+   --  components of the type.
+
+   procedure Expand_Others_Choice
+     (Case_Table     : Choice_Table_Type;
+      Others_Choice  : Node_Id;
+      Choice_Type    : Entity_Id);
+   --  In the case of a variant part of a record type that has an OTHERS
+   --  choice, this procedure expands the OTHERS into the actual choices
+   --  that it represents. This new list of choice nodes is attached to
+   --  the OTHERS node via the Others_Discrete_Choices field. The Case_Table
+   --  contains all choices that have been given explicitly in the variant.
+
+   function Find_Type_Of_Object
+     (Obj_Def     : Node_Id;
+      Related_Nod : Node_Id)
+      return        Entity_Id;
+   --  Get type entity for object referenced by Obj_Def, attaching the
+   --  implicit types generated to Related_Nod
+
+   procedure Floating_Point_Type_Declaration (T : Entity_Id; Def : Node_Id);
+   --  Create a new float, and apply the constraint to obtain subtype of it
+
+   function Has_Range_Constraint (N : Node_Id) return Boolean;
+   --  Given an N_Subtype_Indication node N, return True if a range constraint
+   --  is present, either directly, or as part of a digits or delta constraint.
+   --  In addition, a digits constraint in the decimal case returns True, since
+   --  it establishes a default range if no explicit range is present.
+
+   function Is_Valid_Constraint_Kind
+     (T_Kind          : Type_Kind;
+      Constraint_Kind : Node_Kind)
+      return Boolean;
+   --  Returns True if it is legal to apply the given kind of constraint
+   --  to the given kind of type (index constraint to an array type,
+   --  for example).
+
+   procedure Modular_Type_Declaration (T : Entity_Id; Def : Node_Id);
+   --  Create new modular type. Verify that modulus is in  bounds and is
+   --  a power of two (implementation restriction).
+
+   procedure New_Binary_Operator (Op_Name : Name_Id; Typ : Entity_Id);
+   --  Create an abbreviated declaration for an operator in order to
+   --  materialize minimally operators on derived types.
+
+   procedure Ordinary_Fixed_Point_Type_Declaration
+     (T   : Entity_Id;
+      Def : Node_Id);
+   --  Create a new ordinary fixed point type, and apply the constraint
+   --  to obtain subtype of it.
+
+   procedure Prepare_Private_Subtype_Completion
+     (Id          : Entity_Id;
+      Related_Nod : Node_Id);
+   --  Id is a subtype of some private type. Creates the full declaration
+   --  associated with Id whenever possible, i.e. when the full declaration
+   --  of the base type is already known. Records each subtype into
+   --  Private_Dependents of the base type.
+
+   procedure Process_Incomplete_Dependents
+     (N      : Node_Id;
+      Full_T : Entity_Id;
+      Inc_T  : Entity_Id);
+   --  Process all entities that depend on an incomplete type. There include
+   --  subtypes, subprogram types that mention the incomplete type in their
+   --  profiles, and subprogram with access parameters that designate the
+   --  incomplete type.
+
+   --  Inc_T is the defining identifier of an incomplete type declaration, its
+   --  Ekind is E_Incomplete_Type.
+   --
+   --    N is the corresponding N_Full_Type_Declaration for Inc_T.
+   --
+   --    Full_T is N's defining identifier.
+   --
+   --  Subtypes of incomplete types with discriminants are completed when the
+   --  parent type is. This is simpler than private subtypes, because they can
+   --  only appear in the same scope, and there is no need to exchange views.
+   --  Similarly, access_to_subprogram types may have a parameter or a return
+   --  type that is an incomplete type, and that must be replaced with the
+   --  full type.
+
+   --  If the full type is tagged, subprogram with access parameters that
+   --  designated the incomplete may be primitive operations of the full type,
+   --  and have to be processed accordingly.
+
+   procedure Process_Real_Range_Specification (Def : Node_Id);
+   --  Given the type definition for a real type, this procedure processes
+   --  and checks the real range specification of this type definition if
+   --  one is present. If errors are found, error messages are posted, and
+   --  the Real_Range_Specification of Def is reset to Empty.
+
+   procedure Record_Type_Declaration (T : Entity_Id; N : Node_Id);
+   --  Process a record type declaration (for both untagged and tagged
+   --  records). Parameters T and N are exactly like in procedure
+   --  Derived_Type_Declaration, except that no flag Is_Completion is
+   --  needed for this routine.
+
+   procedure Record_Type_Definition (Def : Node_Id; T : Entity_Id);
+   --  This routine is used to process the actual record type definition
+   --  (both for untagged and tagged records). Def is a record type
+   --  definition node. This procedure analyzes the components in this
+   --  record type definition. T is the entity for the enclosing record
+   --  type. It is provided so that its Has_Task flag can be set if any of
+   --  the component have Has_Task set.
+
+   procedure Set_Fixed_Range
+     (E   : Entity_Id;
+      Loc : Source_Ptr;
+      Lo  : Ureal;
+      Hi  : Ureal);
+   --  Build a range node with the given bounds and set it as the Scalar_Range
+   --  of the given fixed-point type entity. Loc is the source location used
+   --  for the constructed range. See body for further details.
+
+   procedure Set_Scalar_Range_For_Subtype
+     (Def_Id      : Entity_Id;
+      R           : Node_Id;
+      Subt        : Entity_Id;
+      Related_Nod : Node_Id);
+   --  This routine is used to set the scalar range field for a subtype
+   --  given Def_Id, the entity for the subtype, and R, the range expression
+   --  for the scalar range. Subt provides the parent subtype to be used
+   --  to analyze, resolve, and check the given range.
+
+   procedure Signed_Integer_Type_Declaration (T : Entity_Id; Def : Node_Id);
+   --  Create a new signed integer entity, and apply the constraint to obtain
+   --  the required first named subtype of this type.
+
+   -----------------------
+   -- Access_Definition --
+   -----------------------
+
+   function Access_Definition
+     (Related_Nod : Node_Id;
+      N           : Node_Id)
+      return        Entity_Id
+   is
+      Anon_Type : constant Entity_Id :=
+        Create_Itype (E_Anonymous_Access_Type, Related_Nod,
+          Scope_Id => Scope (Current_Scope));
+      Desig_Type : Entity_Id;
+
+   begin
+      if Is_Entry (Current_Scope)
+        and then Is_Task_Type (Etype (Scope (Current_Scope)))
+      then
+         Error_Msg_N ("task entries cannot have access parameters", N);
+      end if;
+
+      Find_Type (Subtype_Mark (N));
+      Desig_Type := Entity (Subtype_Mark (N));
+
+      Set_Directly_Designated_Type
+                             (Anon_Type, Desig_Type);
+      Set_Etype              (Anon_Type, Anon_Type);
+      Init_Size_Align        (Anon_Type);
+      Set_Depends_On_Private (Anon_Type, Has_Private_Component (Anon_Type));
+
+      --  The anonymous access type is as public as the discriminated type or
+      --  subprogram that defines it. It is imported (for back-end purposes)
+      --  if the designated type is.
+
+      Set_Is_Public          (Anon_Type, Is_Public (Scope (Anon_Type)));
+      Set_From_With_Type     (Anon_Type, From_With_Type (Desig_Type));
+
+      --  The context is either a subprogram declaration or an access
+      --  discriminant, in a private or a full type declaration. In
+      --  the case of a subprogram, If the designated type is incomplete,
+      --  the operation will be a primitive operation of the full type, to
+      --  be updated subsequently.
+
+      if Ekind (Desig_Type) = E_Incomplete_Type
+        and then Is_Overloadable (Current_Scope)
+      then
+         Append_Elmt (Current_Scope, Private_Dependents (Desig_Type));
+         Set_Has_Delayed_Freeze (Current_Scope);
+      end if;
+
+      return Anon_Type;
+   end Access_Definition;
+
+   -----------------------------------
+   -- Access_Subprogram_Declaration --
+   -----------------------------------
+
+   procedure Access_Subprogram_Declaration
+     (T_Name : Entity_Id;
+      T_Def  : Node_Id)
+   is
+      Formals : constant List_Id   := Parameter_Specifications (T_Def);
+      Formal  : Entity_Id;
+      Desig_Type : constant Entity_Id :=
+                   Create_Itype (E_Subprogram_Type, Parent (T_Def));
+
+   begin
+      if Nkind (T_Def) = N_Access_Function_Definition then
+         Analyze (Subtype_Mark (T_Def));
+         Set_Etype (Desig_Type, Entity (Subtype_Mark (T_Def)));
+      else
+         Set_Etype (Desig_Type, Standard_Void_Type);
+      end if;
+
+      if Present (Formals) then
+         New_Scope (Desig_Type);
+         Process_Formals (Desig_Type, Formals, Parent (T_Def));
+
+         --  A bit of a kludge here, End_Scope requires that the parent
+         --  pointer be set to something reasonable, but Itypes don't
+         --  have parent pointers. So we set it and then unset it ???
+         --  If and when Itypes have proper parent pointers to their
+         --  declarations, this kludge can be removed.
+
+         Set_Parent (Desig_Type, T_Name);
+         End_Scope;
+         Set_Parent (Desig_Type, Empty);
+      end if;
+
+      --  The return type and/or any parameter type may be incomplete. Mark
+      --  the subprogram_type as depending on the incomplete type, so that
+      --  it can be updated when the full type declaration is seen.
+
+      if Present (Formals) then
+         Formal := First_Formal (Desig_Type);
+
+         while Present (Formal) loop
+
+            if Ekind (Formal) /= E_In_Parameter
+              and then Nkind (T_Def) = N_Access_Function_Definition
+            then
+               Error_Msg_N ("functions can only have IN parameters", Formal);
+            end if;
+
+            if Ekind (Etype (Formal)) = E_Incomplete_Type then
+               Append_Elmt (Desig_Type, Private_Dependents (Etype (Formal)));
+               Set_Has_Delayed_Freeze (Desig_Type);
+            end if;
+
+            Next_Formal (Formal);
+         end loop;
+      end if;
+
+      if Ekind (Etype (Desig_Type)) = E_Incomplete_Type
+        and then not Has_Delayed_Freeze (Desig_Type)
+      then
+         Append_Elmt (Desig_Type, Private_Dependents (Etype (Desig_Type)));
+         Set_Has_Delayed_Freeze (Desig_Type);
+      end if;
+
+      Check_Delayed_Subprogram (Desig_Type);
+
+      if Protected_Present (T_Def) then
+         Set_Ekind (T_Name, E_Access_Protected_Subprogram_Type);
+         Set_Convention (Desig_Type, Convention_Protected);
+      else
+         Set_Ekind (T_Name, E_Access_Subprogram_Type);
+      end if;
+
+      Set_Etype                    (T_Name, T_Name);
+      Init_Size_Align              (T_Name);
+      Set_Directly_Designated_Type (T_Name, Desig_Type);
+
+      Check_Restriction (No_Access_Subprograms, T_Def);
+   end Access_Subprogram_Declaration;
+
+   ----------------------------
+   -- Access_Type_Declaration --
+   ----------------------------
+
+   procedure Access_Type_Declaration (T : Entity_Id; Def : Node_Id) is
+      S : constant Node_Id := Subtype_Indication (Def);
+      P : constant Node_Id := Parent (Def);
+
+   begin
+      --  Check for permissible use of incomplete type
+
+      if Nkind (S) /= N_Subtype_Indication then
+         Analyze (S);
+
+         if Ekind (Root_Type (Entity (S))) = E_Incomplete_Type then
+            Set_Directly_Designated_Type (T, Entity (S));
+         else
+            Set_Directly_Designated_Type (T,
+              Process_Subtype (S, P, T, 'P'));
+         end if;
+
+      else
+         Set_Directly_Designated_Type (T,
+           Process_Subtype (S, P, T, 'P'));
+      end if;
+
+      if All_Present (Def) or Constant_Present (Def) then
+         Set_Ekind (T, E_General_Access_Type);
+      else
+         Set_Ekind (T, E_Access_Type);
+      end if;
+
+      if Base_Type (Designated_Type (T)) = T then
+         Error_Msg_N ("access type cannot designate itself", S);
+      end if;
+
+      Set_Etype              (T, T);
+
+      --  If the type has appeared already in a with_type clause, it is
+      --  frozen and the pointer size is already set. Else, initialize.
+
+      if not From_With_Type (T) then
+         Init_Size_Align (T);
+      end if;
+
+      Set_Is_Access_Constant (T, Constant_Present (Def));
+
+      --  If designated type is an imported tagged type, indicate that the
+      --  access type is also imported, and therefore restricted in its use.
+      --  The access type may already be imported, so keep setting otherwise.
+
+      if From_With_Type (Designated_Type (T)) then
+         Set_From_With_Type (T);
+      end if;
+
+      --  Note that Has_Task is always false, since the access type itself
+      --  is not a task type. See Einfo for more description on this point.
+      --  Exactly the same consideration applies to Has_Controlled_Component.
+
+      Set_Has_Task (T, False);
+      Set_Has_Controlled_Component (T, False);
+   end Access_Type_Declaration;
+
+   -----------------------------------
+   -- Analyze_Component_Declaration --
+   -----------------------------------
+
+   procedure Analyze_Component_Declaration (N : Node_Id) is
+      Id : constant Entity_Id := Defining_Identifier (N);
+      T  : Entity_Id;
+      P  : Entity_Id;
+
+   begin
+      Generate_Definition (Id);
+      Enter_Name (Id);
+      T := Find_Type_Of_Object (Subtype_Indication (N), N);
+
+      --  If the component declaration includes a default expression, then we
+      --  check that the component is not of a limited type (RM 3.7(5)),
+      --  and do the special preanalysis of the expression (see section on
+      --  "Handling of Default Expressions" in the spec of package Sem).
+
+      if Present (Expression (N)) then
+         Analyze_Default_Expression (Expression (N), T);
+         Check_Initialization (T, Expression (N));
+      end if;
+
+      --  The parent type may be a private view with unknown discriminants,
+      --  and thus unconstrained. Regular components must be constrained.
+
+      if Is_Indefinite_Subtype (T) and then Chars (Id) /= Name_uParent then
+         Error_Msg_N
+           ("unconstrained subtype in component declaration",
+            Subtype_Indication (N));
+
+      --  Components cannot be abstract, except for the special case of
+      --  the _Parent field (case of extending an abstract tagged type)
+
+      elsif Is_Abstract (T) and then Chars (Id) /= Name_uParent then
+         Error_Msg_N ("type of a component cannot be abstract", N);
+      end if;
+
+      Set_Etype (Id, T);
+      Set_Is_Aliased (Id, Aliased_Present (N));
+
+      --  If the this component is private (or depends on a private type),
+      --  flag the record type to indicate that some operations are not
+      --  available.
+
+      P := Private_Component (T);
+
+      if Present (P) then
+         --  Check for circular definitions.
+
+         if P = Any_Type then
+            Set_Etype (Id, Any_Type);
+
+         --  There is a gap in the visibility of operations only if the
+         --  component type is not defined in the scope of the record type.
+
+         elsif Scope (P) = Scope (Current_Scope) then
+            null;
+
+         elsif Is_Limited_Type (P) then
+            Set_Is_Limited_Composite (Current_Scope);
+
+         else
+            Set_Is_Private_Composite (Current_Scope);
+         end if;
+      end if;
+
+      if P /= Any_Type
+        and then Is_Limited_Type (T)
+        and then Chars (Id) /= Name_uParent
+        and then Is_Tagged_Type (Current_Scope)
+      then
+         if Is_Derived_Type (Current_Scope)
+           and then not Is_Limited_Record (Root_Type (Current_Scope))
+         then
+            Error_Msg_N
+              ("extension of nonlimited type cannot have limited components",
+               N);
+            Set_Etype (Id, Any_Type);
+            Set_Is_Limited_Composite (Current_Scope, False);
+
+         elsif not Is_Derived_Type (Current_Scope)
+           and then not Is_Limited_Record (Current_Scope)
+         then
+            Error_Msg_N ("nonlimited type cannot have limited components", N);
+            Set_Etype (Id, Any_Type);
+            Set_Is_Limited_Composite (Current_Scope, False);
+         end if;
+      end if;
+
+      Set_Original_Record_Component (Id, Id);
+   end Analyze_Component_Declaration;
+
+   --------------------------
+   -- Analyze_Declarations --
+   --------------------------
+
+   procedure Analyze_Declarations (L : List_Id) is
+      D           : Node_Id;
+      Next_Node   : Node_Id;
+      Freeze_From : Entity_Id := Empty;
+
+      procedure Adjust_D;
+      --  Adjust D not to include implicit label declarations, since these
+      --  have strange Sloc values that result in elaboration check problems.
+
+      procedure Adjust_D is
+      begin
+         while Present (Prev (D))
+           and then Nkind (D) = N_Implicit_Label_Declaration
+         loop
+            Prev (D);
+         end loop;
+      end Adjust_D;
+
+   --  Start of processing for Analyze_Declarations
+
+   begin
+      D := First (L);
+      while Present (D) loop
+
+         --  Complete analysis of declaration
+
+         Analyze (D);
+         Next_Node := Next (D);
+
+         if No (Freeze_From) then
+            Freeze_From := First_Entity (Current_Scope);
+         end if;
+
+         --  At the end of a declarative part, freeze remaining entities
+         --  declared in it. The end of the visible declarations of a
+         --  package specification is not the end of a declarative part
+         --  if private declarations are present. The end of a package
+         --  declaration is a freezing point only if it a library package.
+         --  A task definition or protected type definition is not a freeze
+         --  point either. Finally, we do not freeze entities in generic
+         --  scopes, because there is no code generated for them and freeze
+         --  nodes will be generated for the instance.
+
+         --  The end of a package instantiation is not a freeze point, but
+         --  for now we make it one, because the generic body is inserted
+         --  (currently) immediately after. Generic instantiations will not
+         --  be a freeze point once delayed freezing of bodies is implemented.
+         --  (This is needed in any case for early instantiations ???).
+
+         if No (Next_Node) then
+            if Nkind (Parent (L)) = N_Component_List
+              or else Nkind (Parent (L)) = N_Task_Definition
+              or else Nkind (Parent (L)) = N_Protected_Definition
+            then
+               null;
+
+            elsif Nkind (Parent (L)) /= N_Package_Specification then
+
+               if Nkind (Parent (L)) = N_Package_Body then
+                  Freeze_From := First_Entity (Current_Scope);
+               end if;
+
+               Adjust_D;
+               Freeze_All (Freeze_From, D);
+               Freeze_From := Last_Entity (Current_Scope);
+
+            elsif Scope (Current_Scope) /= Standard_Standard
+              and then not Is_Child_Unit (Current_Scope)
+              and then No (Generic_Parent (Parent (L)))
+            then
+               null;
+
+            elsif L /= Visible_Declarations (Parent (L))
+               or else No (Private_Declarations (Parent (L)))
+               or else Is_Empty_List (Private_Declarations (Parent (L)))
+            then
+               Adjust_D;
+               Freeze_All (Freeze_From, D);
+               Freeze_From := Last_Entity (Current_Scope);
+            end if;
+
+         --  If next node is a body then freeze all types before the body.
+         --  An exception occurs for expander generated bodies, which can
+         --  be recognized by their already being analyzed. The expander
+         --  ensures that all types needed by these bodies have been frozen
+         --  but it is not necessary to freeze all types (and would be wrong
+         --  since it would not correspond to an RM defined freeze point).
+
+         elsif not Analyzed (Next_Node)
+           and then (Nkind (Next_Node) = N_Subprogram_Body
+             or else Nkind (Next_Node) = N_Entry_Body
+             or else Nkind (Next_Node) = N_Package_Body
+             or else Nkind (Next_Node) = N_Protected_Body
+             or else Nkind (Next_Node) = N_Task_Body
+             or else Nkind (Next_Node) in N_Body_Stub)
+         then
+            Adjust_D;
+            Freeze_All (Freeze_From, D);
+            Freeze_From := Last_Entity (Current_Scope);
+         end if;
+
+         D := Next_Node;
+      end loop;
+
+   end Analyze_Declarations;
+
+   --------------------------------
+   -- Analyze_Default_Expression --
+   --------------------------------
+
+   procedure Analyze_Default_Expression (N : Node_Id; T : Entity_Id) is
+      Save_In_Default_Expression : constant Boolean := In_Default_Expression;
+
+   begin
+      In_Default_Expression := True;
+      Pre_Analyze_And_Resolve (N, T);
+      In_Default_Expression := Save_In_Default_Expression;
+   end Analyze_Default_Expression;
+
+   ----------------------------------
+   -- Analyze_Incomplete_Type_Decl --
+   ----------------------------------
+
+   procedure Analyze_Incomplete_Type_Decl (N : Node_Id) is
+      F : constant Boolean := Is_Pure (Current_Scope);
+      T : Entity_Id;
+
+   begin
+      Generate_Definition (Defining_Identifier (N));
+
+      --  Process an incomplete declaration. The identifier must not have been
+      --  declared already in the scope. However, an incomplete declaration may
+      --  appear in the private part of a package, for a private type that has
+      --  already been declared.
+
+      --  In this case, the discriminants (if any) must match.
+
+      T := Find_Type_Name (N);
+
+      Set_Ekind (T, E_Incomplete_Type);
+      Init_Size_Align (T);
+      Set_Is_First_Subtype (T, True);
+      Set_Etype (T, T);
+      New_Scope (T);
+
+      Set_Girder_Constraint (T, No_Elist);
+
+      if Present (Discriminant_Specifications (N)) then
+         Process_Discriminants (N);
+      end if;
+
+      End_Scope;
+
+      --  If the type has discriminants, non-trivial subtypes may be
+      --  be declared before the full view of the type. The full views
+      --  of those subtypes will be built after the full view of the type.
+
+      Set_Private_Dependents (T, New_Elmt_List);
+      Set_Is_Pure (T, F);
+   end Analyze_Incomplete_Type_Decl;
+
+   -----------------------------
+   -- Analyze_Itype_Reference --
+   -----------------------------
+
+   --  Nothing to do. This node is placed in the tree only for the benefit
+   --  of Gigi processing, and has no effect on the semantic processing.
+
+   procedure Analyze_Itype_Reference (N : Node_Id) is
+   begin
+      pragma Assert (Is_Itype (Itype (N)));
+      null;
+   end Analyze_Itype_Reference;
+
+   --------------------------------
+   -- Analyze_Number_Declaration --
+   --------------------------------
+
+   procedure Analyze_Number_Declaration (N : Node_Id) is
+      Id    : constant Entity_Id := Defining_Identifier (N);
+      E     : constant Node_Id   := Expression (N);
+      T     : Entity_Id;
+      Index : Interp_Index;
+      It    : Interp;
+
+   begin
+      Generate_Definition (Id);
+      Enter_Name (Id);
+
+      --  This is an optimization of a common case of an integer literal
+
+      if Nkind (E) = N_Integer_Literal then
+         Set_Is_Static_Expression (E, True);
+         Set_Etype                (E, Universal_Integer);
+
+         Set_Etype     (Id, Universal_Integer);
+         Set_Ekind     (Id, E_Named_Integer);
+         Set_Is_Frozen (Id, True);
+         return;
+      end if;
+
+      Set_Is_Pure (Id, Is_Pure (Current_Scope));
+
+      Analyze (E);
+
+      --  Verify that the expression is static and numeric. If
+      --  the expression is overloaded, we apply the preference
+      --  rule that favors root numeric types.
+
+      if not Is_Overloaded (E) then
+         T := Etype (E);
+
+      else
+         T := Any_Type;
+         Get_First_Interp (E, Index, It);
+
+         while Present (It.Typ) loop
+            if (Is_Integer_Type (It.Typ)
+                 or else Is_Real_Type (It.Typ))
+              and then (Scope (Base_Type (It.Typ))) = Standard_Standard
+            then
+               if T = Any_Type then
+                  T := It.Typ;
+
+               elsif It.Typ = Universal_Real
+                 or else It.Typ = Universal_Integer
+               then
+                  --  Choose universal interpretation over any other.
+
+                  T := It.Typ;
+                  exit;
+               end if;
+            end if;
+
+            Get_Next_Interp (Index, It);
+         end loop;
+      end if;
+
+      if Is_Integer_Type (T)  then
+         Resolve (E, T);
+         Set_Etype (Id, Universal_Integer);
+         Set_Ekind (Id, E_Named_Integer);
+
+      elsif Is_Real_Type (T) then
+
+         --  Because the real value is converted to universal_real, this
+         --  is a legal context for a universal fixed expression.
+
+         if T = Universal_Fixed then
+            declare
+               Loc  : constant Source_Ptr := Sloc (N);
+               Conv : constant Node_Id := Make_Type_Conversion (Loc,
+                        Subtype_Mark =>
+                          New_Occurrence_Of (Universal_Real, Loc),
+                        Expression => Relocate_Node (E));
+
+            begin
+               Rewrite (E, Conv);
+               Analyze (E);
+            end;
+
+         elsif T = Any_Fixed then
+            Error_Msg_N ("illegal context for mixed mode operation", E);
+
+            --  Expression is of the form : universal_fixed * integer.
+            --  Try to resolve as universal_real.
+
+            T := Universal_Real;
+            Set_Etype (E, T);
+         end if;
+
+         Resolve (E, T);
+         Set_Etype (Id, Universal_Real);
+         Set_Ekind (Id, E_Named_Real);
+
+      else
+         Wrong_Type (E, Any_Numeric);
+         Resolve (E, T);
+         Set_Etype               (Id, T);
+         Set_Ekind               (Id, E_Constant);
+         Set_Not_Source_Assigned (Id, True);
+         Set_Is_True_Constant    (Id, True);
+         return;
+      end if;
+
+      if Nkind (E) = N_Integer_Literal
+        or else Nkind (E) = N_Real_Literal
+      then
+         Set_Etype (E, Etype (Id));
+      end if;
+
+      if not Is_OK_Static_Expression (E) then
+         Error_Msg_N ("non-static expression used in number declaration", E);
+         Rewrite (E, Make_Integer_Literal (Sloc (N), 1));
+         Set_Etype (E, Any_Type);
+      end if;
+
+   end Analyze_Number_Declaration;
+
+   --------------------------------
+   -- Analyze_Object_Declaration --
+   --------------------------------
+
+   procedure Analyze_Object_Declaration (N : Node_Id) is
+      Loc   : constant Source_Ptr := Sloc (N);
+      Id    : constant Entity_Id  := Defining_Identifier (N);
+      T     : Entity_Id;
+      Act_T : Entity_Id;
+
+      E : Node_Id := Expression (N);
+      --  E is set to Expression (N) throughout this routine. When
+      --  Expression (N) is modified, E is changed accordingly.
+
+      Prev_Entity : Entity_Id := Empty;
+
+      function Build_Default_Subtype return Entity_Id;
+      --  If the object is limited or aliased, and if the type is unconstrained
+      --  and there is no expression, the discriminants cannot be modified and
+      --  the subtype of the object is constrained by the defaults, so it is
+      --  worthile building the corresponding subtype.
+
+      ---------------------------
+      -- Build_Default_Subtype --
+      ---------------------------
+
+      function Build_Default_Subtype return Entity_Id is
+         Act         : Entity_Id;
+         Constraints : List_Id := New_List;
+         Decl        : Node_Id;
+         Disc        : Entity_Id;
+
+      begin
+         Disc  := First_Discriminant (T);
+
+         if No (Discriminant_Default_Value (Disc)) then
+            return T;   --   previous error.
+         end if;
+
+         Act := Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
+         while Present (Disc) loop
+            Append (
+              New_Copy_Tree (
+                Discriminant_Default_Value (Disc)), Constraints);
+            Next_Discriminant (Disc);
+         end loop;
+
+         Decl :=
+           Make_Subtype_Declaration (Loc,
+             Defining_Identifier => Act,
+             Subtype_Indication =>
+               Make_Subtype_Indication (Loc,
+                 Subtype_Mark => New_Occurrence_Of (T, Loc),
+                 Constraint =>
+                   Make_Index_Or_Discriminant_Constraint
+                     (Loc, Constraints)));
+
+         Insert_Before (N, Decl);
+         Analyze (Decl);
+         return Act;
+      end Build_Default_Subtype;
+
+   --  Start of processing for Analyze_Object_Declaration
+
+   begin
+      --  There are three kinds of implicit types generated by an
+      --  object declaration:
+
+      --   1. Those for generated by the original Object Definition
+
+      --   2. Those generated by the Expression
+
+      --   3. Those used to constrained the Object Definition with the
+      --       expression constraints when it is unconstrained
+
+      --  They must be generated in this order to avoid order of elaboration
+      --  issues. Thus the first step (after entering the name) is to analyze
+      --  the object definition.
+
+      if Constant_Present (N) then
+         Prev_Entity := Current_Entity_In_Scope (Id);
+
+         --  If homograph is an implicit subprogram, it is overridden by the
+         --  current declaration.
+
+         if Present (Prev_Entity)
+           and then Is_Overloadable (Prev_Entity)
+           and then Is_Inherited_Operation (Prev_Entity)
+         then
+            Prev_Entity := Empty;
+         end if;
+      end if;
+
+      if Present (Prev_Entity) then
+         Constant_Redeclaration (Id, N, T);
+
+         Generate_Reference (Prev_Entity, Id, 'c');
+
+         --  If in main unit, set as referenced, so we do not complain about
+         --  the full declaration being an unreferenced entity.
+
+         if In_Extended_Main_Source_Unit (Id) then
+            Set_Referenced (Id);
+         end if;
+
+         if Error_Posted (N) then
+            --  Type mismatch or illegal redeclaration, Do not analyze
+            --  expression to avoid cascaded errors.
+
+            T := Find_Type_Of_Object (Object_Definition (N), N);
+            Set_Etype (Id, T);
+            Set_Ekind (Id, E_Variable);
+            return;
+         end if;
+
+      --  In the normal case, enter identifier at the start to catch
+      --  premature usage in the initialization expression.
+
+      else
+         Generate_Definition (Id);
+         Enter_Name (Id);
+
+         T := Find_Type_Of_Object (Object_Definition (N), N);
+
+         if Error_Posted (Id) then
+            Set_Etype (Id, T);
+            Set_Ekind (Id, E_Variable);
+            return;
+         end if;
+      end if;
+
+      Set_Is_Pure (Id, Is_Pure (Current_Scope));
+
+      --  If deferred constant, make sure context is appropriate. We detect
+      --  a deferred constant as a constant declaration with no expression.
+
+      if Constant_Present (N)
+        and then No (E)
+      then
+         if not Is_Package (Current_Scope)
+           or else In_Private_Part (Current_Scope)
+         then
+            Error_Msg_N
+              ("invalid context for deferred constant declaration", N);
+            Set_Constant_Present (N, False);
+
+         --  In Ada 83, deferred constant must be of private type
+
+         elsif not Is_Private_Type (T) then
+            if Ada_83 and then Comes_From_Source (N) then
+               Error_Msg_N
+                 ("(Ada 83) deferred constant must be private type", N);
+            end if;
+         end if;
+
+      --  If not a deferred constant, then object declaration freezes its type
+
+      else
+         Check_Fully_Declared (T, N);
+         Freeze_Before (N, T);
+      end if;
+
+      --  If the object was created by a constrained array definition, then
+      --  set the link in both the anonymous base type and anonymous subtype
+      --  that are built to represent the array type to point to the object.
+
+      if Nkind (Object_Definition (Declaration_Node (Id))) =
+                        N_Constrained_Array_Definition
+      then
+         Set_Related_Array_Object (T, Id);
+         Set_Related_Array_Object (Base_Type (T), Id);
+      end if;
+
+      --  Special checks for protected objects not at library level
+
+      if Is_Protected_Type (T)
+        and then not Is_Library_Level_Entity (Id)
+      then
+         Check_Restriction (No_Local_Protected_Objects, Id);
+
+         --  Protected objects with interrupt handlers must be at library level
+
+         if Has_Interrupt_Handler (T) then
+            Error_Msg_N
+              ("interrupt object can only be declared at library level", Id);
+         end if;
+      end if;
+
+      --  The actual subtype of the object is the nominal subtype, unless
+      --  the nominal one is unconstrained and obtained from the expression.
+
+      Act_T := T;
+
+      --  Process initialization expression if present and not in error
+
+      if Present (E) and then E /= Error then
+         Analyze (E);
+
+         if not Assignment_OK (N) then
+            Check_Initialization (T, E);
+         end if;
+
+         Resolve (E, T);
+
+         --  Check for library level object that will require implicit
+         --  heap allocation.
+
+         if Is_Array_Type (T)
+           and then not Size_Known_At_Compile_Time (T)
+           and then Is_Library_Level_Entity (Id)
+         then
+            --  String literals are always allowed
+
+            if T = Standard_String
+              and then Nkind (E) = N_String_Literal
+            then
+               null;
+
+            --  Otherwise we do not allow this since it may cause an
+            --  implicit heap allocation.
+
+            else
+               Check_Restriction
+                 (No_Implicit_Heap_Allocations, Object_Definition (N));
+            end if;
+         end if;
+
+         --  Check incorrect use of dynamically tagged expressions. Note
+         --  the use of Is_Tagged_Type (T) which seems redundant but is in
+         --  fact important to avoid spurious errors due to expanded code
+         --  for dispatching functions over an anonymous access type
+
+         if (Is_Class_Wide_Type (Etype (E)) or else Is_Dynamically_Tagged (E))
+           and then Is_Tagged_Type (T)
+           and then not Is_Class_Wide_Type (T)
+         then
+            Error_Msg_N ("dynamically tagged expression not allowed!", E);
+         end if;
+
+         Apply_Scalar_Range_Check (E, T);
+         Apply_Static_Length_Check (E, T);
+      end if;
+
+      --  Abstract type is never permitted for a variable or constant.
+      --  Note: we inhibit this check for objects that do not come from
+      --  source because there is at least one case (the expansion of
+      --  x'class'input where x is abstract) where we legitimately
+      --  generate an abstract object.
+
+      if Is_Abstract (T) and then Comes_From_Source (N) then
+         Error_Msg_N ("type of object cannot be abstract",
+           Object_Definition (N));
+         if Is_CPP_Class (T) then
+            Error_Msg_NE ("\} may need a cpp_constructor",
+              Object_Definition (N), T);
+         end if;
+
+      --  Case of unconstrained type
+
+      elsif Is_Indefinite_Subtype (T) then
+
+         --  Nothing to do in deferred constant case
+
+         if Constant_Present (N) and then No (E) then
+            null;
+
+         --  Case of no initialization present
+
+         elsif No (E) then
+            if No_Initialization (N) then
+               null;
+
+            elsif Is_Class_Wide_Type (T) then
+               Error_Msg_N
+                 ("initialization required in class-wide declaration ", N);
+
+            else
+               Error_Msg_N
+                 ("unconstrained subtype not allowed (need initialization)",
+                  Object_Definition (N));
+            end if;
+
+         --  Case of initialization present but in error. Set initial
+         --  expression as absent (but do not make above complaints)
+
+         elsif E = Error then
+            Set_Expression (N, Empty);
+            E := Empty;
+
+         --  Case of initialization present
+
+         else
+            --  Not allowed in Ada 83
+
+            if not Constant_Present (N) then
+               if Ada_83
+                 and then Comes_From_Source (Object_Definition (N))
+               then
+                  Error_Msg_N
+                    ("(Ada 83) unconstrained variable not allowed",
+                     Object_Definition (N));
+               end if;
+            end if;
+
+            --  Now we constrain the variable from the initializing expression
+
+            --  If the expression is an aggregate, it has been expanded into
+            --  individual assignments. Retrieve the actual type from the
+            --  expanded construct.
+
+            if Is_Array_Type (T)
+              and then No_Initialization (N)
+              and then Nkind (Original_Node (E)) = N_Aggregate
+            then
+               Act_T := Etype (E);
+
+            else
+               Expand_Subtype_From_Expr (N, T, Object_Definition (N), E);
+               Act_T := Find_Type_Of_Object (Object_Definition (N), N);
+            end if;
+
+            Set_Is_Constr_Subt_For_U_Nominal (Act_T);
+
+            if Aliased_Present (N) then
+               Set_Is_Constr_Subt_For_UN_Aliased (Act_T);
+            end if;
+
+            Freeze_Before (N, Act_T);
+            Freeze_Before (N, T);
+         end if;
+
+      elsif Is_Array_Type (T)
+        and then No_Initialization (N)
+        and then Nkind (Original_Node (E)) = N_Aggregate
+      then
+         if not Is_Entity_Name (Object_Definition (N)) then
+            Act_T := Etype (E);
+
+            if Aliased_Present (N) then
+               Set_Is_Constr_Subt_For_UN_Aliased (Act_T);
+            end if;
+         end if;
+
+         --  When the given object definition and the aggregate are specified
+         --  independently, and their lengths might differ do a length check.
+         --  This cannot happen if the aggregate is of the form (others =>...)
+
+         if not Is_Constrained (T) then
+            null;
+
+         elsif T = Etype (E) then
+            null;
+
+         elsif Nkind (E) = N_Aggregate
+           and then Present (Component_Associations (E))
+           and then Present (Choices (First (Component_Associations (E))))
+           and then Nkind (First
+            (Choices (First (Component_Associations (E))))) = N_Others_Choice
+         then
+            null;
+
+         else
+            Apply_Length_Check (E, T);
+         end if;
+
+      elsif (Is_Limited_Record (T)
+               or else Is_Concurrent_Type (T))
+        and then not Is_Constrained (T)
+        and then Has_Discriminants (T)
+      then
+         Act_T := Build_Default_Subtype;
+         Rewrite (Object_Definition (N), New_Occurrence_Of (Act_T, Loc));
+
+      elsif not Is_Constrained (T)
+        and then Has_Discriminants (T)
+        and then Constant_Present (N)
+        and then Nkind (E) = N_Function_Call
+      then
+         --  The back-end has problems with constants of a discriminated type
+         --  with defaults, if the initial value is a function call. We
+         --  generate an intermediate temporary for the result of the call.
+         --  It is unclear why this should make it acceptable to gcc. ???
+
+         Remove_Side_Effects (E);
+      end if;
+
+      if T = Standard_Wide_Character
+        or else Root_Type (T) = Standard_Wide_String
+      then
+         Check_Restriction (No_Wide_Characters, Object_Definition (N));
+      end if;
+
+      --  Now establish the proper kind and type of the object
+
+      if Constant_Present (N) then
+         Set_Ekind               (Id, E_Constant);
+         Set_Not_Source_Assigned (Id, True);
+         Set_Is_True_Constant    (Id, True);
+
+      else
+         Set_Ekind (Id, E_Variable);
+
+         --  A variable is set as shared passive if it appears in a shared
+         --  passive package, and is at the outer level. This is not done
+         --  for entities generated during expansion, because those are
+         --  always manipulated locally.
+
+         if Is_Shared_Passive (Current_Scope)
+           and then Is_Library_Level_Entity (Id)
+           and then Comes_From_Source (Id)
+         then
+            Set_Is_Shared_Passive (Id);
+            Check_Shared_Var (Id, T, N);
+         end if;
+
+         --  If an initializing expression is present, then the variable
+         --  is potentially a true constant if no further assignments are
+         --  present. The code generator can use this for optimization.
+         --  The flag will be reset if there are any assignments. We only
+         --  set this flag for non library level entities, since for any
+         --  library level entities, assignments could exist in other units.
+
+         if Present (E) then
+            if not Is_Library_Level_Entity (Id) then
+
+               --  For now we omit this, because it seems to cause some
+               --  problems. In particular, if you uncomment this out, then
+               --  test case 4427-002 will fail for unclear reasons ???
+
+               if False then
+                  Set_Is_True_Constant (Id);
+               end if;
+            end if;
+
+         --  Case of no initializing expression present. If the type is not
+         --  fully initialized, then we set Not_Source_Assigned, since this
+         --  is a case of a potentially uninitialized object. Note that we
+         --  do not consider access variables to be fully initialized for
+         --  this purpose, since it still seems dubious if someone declares
+         --  an access variable and never assigns to it.
+
+         else
+            if Is_Access_Type (T)
+              or else not Is_Fully_Initialized_Type (T)
+            then
+               Set_Not_Source_Assigned (Id);
+            end if;
+         end if;
+      end if;
+
+      Init_Alignment (Id);
+      Init_Esize     (Id);
+
+      if Aliased_Present (N) then
+         Set_Is_Aliased (Id);
+
+         if No (E)
+           and then Is_Record_Type (T)
+           and then not Is_Constrained (T)
+           and then Has_Discriminants (T)
+         then
+            Set_Actual_Subtype (Id, Build_Default_Subtype);
+         end if;
+      end if;
+
+      Set_Etype (Id, Act_T);
+
+      if Has_Controlled_Component (Etype (Id))
+        or else Is_Controlled (Etype (Id))
+      then
+         if not Is_Library_Level_Entity (Id) then
+            Check_Restriction (No_Nested_Finalization, N);
+
+         else
+            Validate_Controlled_Object (Id);
+         end if;
+
+         --  Generate a warning when an initialization causes an obvious
+         --  ABE violation. If the init expression is a simple aggregate
+         --  there shouldn't be any initialize/adjust call generated. This
+         --  will be true as soon as aggregates are built in place when
+         --  possible. ??? at the moment we do not generate warnings for
+         --  temporaries created for those aggregates although a
+         --  Program_Error might be generated if compiled with -gnato
+
+         if Is_Controlled (Etype (Id))
+            and then Comes_From_Source (Id)
+         then
+            declare
+               BT            : constant Entity_Id := Base_Type (Etype (Id));
+               Implicit_Call : Entity_Id;
+
+               function Is_Aggr (N : Node_Id) return Boolean;
+               --  Check that N is an aggregate
+
+               function Is_Aggr (N : Node_Id) return Boolean is
+               begin
+                  case Nkind (Original_Node (N)) is
+                     when N_Aggregate | N_Extension_Aggregate =>
+                        return True;
+
+                     when N_Qualified_Expression |
+                          N_Type_Conversion      |
+                          N_Unchecked_Type_Conversion =>
+                        return Is_Aggr (Expression (Original_Node (N)));
+
+                     when others =>
+                        return False;
+                  end case;
+               end Is_Aggr;
+
+            begin
+               --  If no underlying type, we already are in an error situation
+               --  don't try to add a warning since we do not have access
+               --  prim-op list.
+
+               if No (Underlying_Type (BT)) then
+                  Implicit_Call := Empty;
+
+               --  A generic type does not have usable primitive operators.
+               --  Initialization calls are built for instances.
+
+               elsif Is_Generic_Type (BT) then
+                  Implicit_Call := Empty;
+
+               --  if the init expression is not an aggregate, an adjust
+               --  call will be generated
+
+               elsif Present (E) and then not Is_Aggr (E) then
+                  Implicit_Call := Find_Prim_Op (BT, Name_Adjust);
+
+               --  if no init expression and we are not in the deferred
+               --  constant case, an Initialize call will be generated
+
+               elsif No (E) and then not Constant_Present (N) then
+                  Implicit_Call := Find_Prim_Op (BT, Name_Initialize);
+
+               else
+                  Implicit_Call := Empty;
+               end if;
+            end;
+         end if;
+      end if;
+
+      if Has_Task (Etype (Id)) then
+         if not Is_Library_Level_Entity (Id) then
+            Check_Restriction (No_Task_Hierarchy, N);
+            Check_Potentially_Blocking_Operation (N);
+         end if;
+      end if;
+
+      --  Some simple constant-propagation: if the expression is a constant
+      --  string initialized with a literal, share the literal. This avoids
+      --  a run-time copy.
+
+      if Present (E)
+        and then Is_Entity_Name (E)
+        and then Ekind (Entity (E)) = E_Constant
+        and then Base_Type (Etype (E)) = Standard_String
+      then
+         declare
+            Val : constant Node_Id := Constant_Value (Entity (E));
+
+         begin
+            if Present (Val)
+              and then Nkind (Val) = N_String_Literal
+            then
+               Rewrite (E, New_Copy (Val));
+            end if;
+         end;
+      end if;
+
+      --  Another optimization: if the nominal subtype is unconstrained and
+      --  the expression is a function call that returns and unconstrained
+      --  type, rewrite the declararation as a renaming of the result of the
+      --  call. The exceptions below are cases where the copy is expected,
+      --  either by the back end (Aliased case) or by the semantics, as for
+      --  initializing controlled types or copying tags for classwide types.
+
+      if Present (E)
+        and then Nkind (E) = N_Explicit_Dereference
+        and then Nkind (Original_Node (E)) = N_Function_Call
+        and then not Is_Library_Level_Entity (Id)
+        and then not Is_Constrained (T)
+        and then not Is_Aliased (Id)
+        and then not Is_Class_Wide_Type (T)
+        and then not Is_Controlled (T)
+        and then not Has_Controlled_Component (Base_Type (T))
+        and then Expander_Active
+      then
+         Rewrite (N,
+           Make_Object_Renaming_Declaration (Loc,
+             Defining_Identifier => Id,
+             Subtype_Mark        => New_Occurrence_Of
+                                      (Base_Type (Etype (Id)), Loc),
+             Name                => E));
+
+         Set_Renamed_Object (Id, E);
+      end if;
+
+      if Present (Prev_Entity)
+        and then Is_Frozen (Prev_Entity)
+        and then not Error_Posted (Id)
+      then
+         Error_Msg_N ("full constant declaration appears too late", N);
+      end if;
+
+      Check_Eliminated (Id);
+   end Analyze_Object_Declaration;
+
+   ---------------------------
+   -- Analyze_Others_Choice --
+   ---------------------------
+
+   --  Nothing to do for the others choice node itself, the semantic analysis
+   --  of the others choice will occur as part of the processing of the parent
+
+   procedure Analyze_Others_Choice (N : Node_Id) is
+   begin
+      null;
+   end Analyze_Others_Choice;
+
+   -------------------------------------------
+   -- Analyze_Private_Extension_Declaration --
+   -------------------------------------------
+
+   procedure Analyze_Private_Extension_Declaration (N : Node_Id) is
+      T           : Entity_Id        := Defining_Identifier (N);
+      Indic       : constant Node_Id := Subtype_Indication (N);
+      Parent_Type : Entity_Id;
+      Parent_Base : Entity_Id;
+
+   begin
+      Generate_Definition (T);
+      Enter_Name (T);
+
+      Parent_Type := Find_Type_Of_Subtype_Indic (Indic);
+      Parent_Base := Base_Type (Parent_Type);
+
+      if Parent_Type = Any_Type
+        or else Etype (Parent_Type) = Any_Type
+      then
+         Set_Ekind (T, Ekind (Parent_Type));
+         Set_Etype (T, Any_Type);
+         return;
+
+      elsif not Is_Tagged_Type (Parent_Type) then
+         Error_Msg_N
+           ("parent of type extension must be a tagged type ", Indic);
+         return;
+
+      elsif Ekind (Parent_Type) = E_Void
+        or else Ekind (Parent_Type) = E_Incomplete_Type
+      then
+         Error_Msg_N ("premature derivation of incomplete type", Indic);
+         return;
+      end if;
+
+      --  Perhaps the parent type should be changed to the class-wide type's
+      --  specific type in this case to prevent cascading errors ???
+
+      if Is_Class_Wide_Type (Parent_Type) then
+         Error_Msg_N
+           ("parent of type extension must not be a class-wide type", Indic);
+         return;
+      end if;
+
+      if (not Is_Package (Current_Scope)
+           and then Nkind (Parent (N)) /= N_Generic_Subprogram_Declaration)
+        or else In_Private_Part (Current_Scope)
+
+      then
+         Error_Msg_N ("invalid context for private extension", N);
+      end if;
+
+      --  Set common attributes
+
+      Set_Is_Pure          (T, Is_Pure (Current_Scope));
+      Set_Scope            (T, Current_Scope);
+      Set_Ekind            (T, E_Record_Type_With_Private);
+      Init_Size_Align      (T);
+
+      Set_Etype            (T,            Parent_Base);
+      Set_Has_Task         (T, Has_Task  (Parent_Base));
+
+      Set_Convention       (T, Convention     (Parent_Type));
+      Set_First_Rep_Item   (T, First_Rep_Item (Parent_Type));
+      Set_Is_First_Subtype (T);
+      Make_Class_Wide_Type (T);
+
+      Build_Derived_Record_Type (N, Parent_Type, T);
+   end Analyze_Private_Extension_Declaration;
+
+   ---------------------------------
+   -- Analyze_Subtype_Declaration --
+   ---------------------------------
+
+   procedure Analyze_Subtype_Declaration (N : Node_Id) is
+      Id       : constant Entity_Id := Defining_Identifier (N);
+      T        : Entity_Id;
+      R_Checks : Check_Result;
+
+   begin
+      Generate_Definition (Id);
+      Set_Is_Pure (Id, Is_Pure (Current_Scope));
+      Init_Size_Align (Id);
+
+      --  The following guard condition on Enter_Name is to handle cases
+      --  where the defining identifier has already been entered into the
+      --  scope but the declaration as a whole needs to be analyzed.
+
+      --  This case in particular happens for derived enumeration types.
+      --  The derived enumeration type is processed as an inserted enumeration
+      --  type declaration followed by a rewritten subtype declaration. The
+      --  defining identifier, however, is entered into the name scope very
+      --  early in the processing of the original type declaration and
+      --  therefore needs to be avoided here, when the created subtype
+      --  declaration is analyzed. (See Build_Derived_Types)
+
+      --  This also happens when the full view of a private type is a
+      --  derived type with constraints. In this case the entity has been
+      --  introduced in the private declaration.
+
+      if Present (Etype (Id))
+        and then (Is_Private_Type (Etype (Id))
+                   or else Is_Task_Type (Etype (Id))
+                   or else Is_Rewrite_Substitution (N))
+      then
+         null;
+
+      else
+         Enter_Name (Id);
+      end if;
+
+      T := Process_Subtype (Subtype_Indication (N), N, Id, 'P');
+
+      --  Inherit common attributes
+
+      Set_Is_Generic_Type (Id, Is_Generic_Type (Base_Type (T)));
+      Set_Is_Volatile (Id, Is_Volatile (T));
+      Set_Is_Atomic   (Id, Is_Atomic   (T));
+
+      --  In the case where there is no constraint given in the subtype
+      --  indication, Process_Subtype just returns the Subtype_Mark,
+      --  so its semantic attributes must be established here.
+
+      if Nkind (Subtype_Indication (N)) /= N_Subtype_Indication then
+         Set_Etype (Id, Base_Type (T));
+
+         case Ekind (T) is
+            when Array_Kind =>
+               Set_Ekind                (Id, E_Array_Subtype);
+
+               --  Shouldn't we call Copy_Array_Subtype_Attributes here???
+
+               Set_First_Index          (Id, First_Index        (T));
+               Set_Is_Aliased           (Id, Is_Aliased         (T));
+               Set_Is_Constrained       (Id, Is_Constrained     (T));
+
+            when Decimal_Fixed_Point_Kind =>
+               Set_Ekind                (Id, E_Decimal_Fixed_Point_Subtype);
+               Set_Digits_Value         (Id, Digits_Value       (T));
+               Set_Delta_Value          (Id, Delta_Value        (T));
+               Set_Scale_Value          (Id, Scale_Value        (T));
+               Set_Small_Value          (Id, Small_Value        (T));
+               Set_Scalar_Range         (Id, Scalar_Range       (T));
+               Set_Machine_Radix_10     (Id, Machine_Radix_10   (T));
+               Set_Is_Constrained       (Id, Is_Constrained     (T));
+               Set_RM_Size              (Id, RM_Size            (T));
+
+            when Enumeration_Kind =>
+               Set_Ekind                (Id, E_Enumeration_Subtype);
+               Set_First_Literal        (Id, First_Literal (Base_Type (T)));
+               Set_Scalar_Range         (Id, Scalar_Range       (T));
+               Set_Is_Character_Type    (Id, Is_Character_Type  (T));
+               Set_Is_Constrained       (Id, Is_Constrained     (T));
+               Set_RM_Size              (Id, RM_Size            (T));
+
+            when Ordinary_Fixed_Point_Kind =>
+               Set_Ekind                (Id, E_Ordinary_Fixed_Point_Subtype);
+               Set_Scalar_Range         (Id, Scalar_Range       (T));
+               Set_Small_Value          (Id, Small_Value        (T));
+               Set_Delta_Value          (Id, Delta_Value        (T));
+               Set_Is_Constrained       (Id, Is_Constrained     (T));
+               Set_RM_Size              (Id, RM_Size            (T));
+
+            when Float_Kind =>
+               Set_Ekind                (Id, E_Floating_Point_Subtype);
+               Set_Scalar_Range         (Id, Scalar_Range       (T));
+               Set_Digits_Value         (Id, Digits_Value       (T));
+               Set_Is_Constrained       (Id, Is_Constrained     (T));
+
+            when Signed_Integer_Kind =>
+               Set_Ekind                (Id, E_Signed_Integer_Subtype);
+               Set_Scalar_Range         (Id, Scalar_Range       (T));
+               Set_Is_Constrained       (Id, Is_Constrained     (T));
+               Set_RM_Size              (Id, RM_Size            (T));
+
+            when Modular_Integer_Kind =>
+               Set_Ekind                (Id, E_Modular_Integer_Subtype);
+               Set_Scalar_Range         (Id, Scalar_Range       (T));
+               Set_Is_Constrained       (Id, Is_Constrained     (T));
+               Set_RM_Size              (Id, RM_Size            (T));
+
+            when Class_Wide_Kind =>
+               Set_Ekind                (Id, E_Class_Wide_Subtype);
+               Set_First_Entity         (Id, First_Entity       (T));
+               Set_Last_Entity          (Id, Last_Entity        (T));
+               Set_Class_Wide_Type      (Id, Class_Wide_Type    (T));
+               Set_Cloned_Subtype       (Id, T);
+               Set_Is_Tagged_Type       (Id, True);
+               Set_Has_Unknown_Discriminants
+                                        (Id, True);
+
+               if Ekind (T) = E_Class_Wide_Subtype then
+                  Set_Equivalent_Type   (Id, Equivalent_Type    (T));
+               end if;
+
+            when E_Record_Type | E_Record_Subtype =>
+               Set_Ekind                (Id, E_Record_Subtype);
+
+               if Ekind (T) = E_Record_Subtype
+                 and then Present (Cloned_Subtype (T))
+               then
+                  Set_Cloned_Subtype    (Id, Cloned_Subtype (T));
+               else
+                  Set_Cloned_Subtype    (Id, T);
+               end if;
+
+               Set_First_Entity         (Id, First_Entity       (T));
+               Set_Last_Entity          (Id, Last_Entity        (T));
+               Set_Has_Discriminants    (Id, Has_Discriminants  (T));
+               Set_Is_Constrained       (Id, Is_Constrained     (T));
+               Set_Is_Limited_Record    (Id, Is_Limited_Record  (T));
+               Set_Has_Unknown_Discriminants
+                                        (Id, Has_Unknown_Discriminants (T));
+
+               if Has_Discriminants (T) then
+                  Set_Discriminant_Constraint
+                                        (Id, Discriminant_Constraint (T));
+                  Set_Girder_Constraint_From_Discriminant_Constraint (Id);
+
+               elsif Has_Unknown_Discriminants (Id) then
+                  Set_Discriminant_Constraint (Id, No_Elist);
+               end if;
+
+               if Is_Tagged_Type (T) then
+                  Set_Is_Tagged_Type    (Id);
+                  Set_Is_Abstract       (Id, Is_Abstract (T));
+                  Set_Primitive_Operations
+                                        (Id, Primitive_Operations (T));
+                  Set_Class_Wide_Type   (Id, Class_Wide_Type (T));
+               end if;
+
+            when Private_Kind =>
+               Set_Ekind              (Id, Subtype_Kind (Ekind   (T)));
+               Set_Has_Discriminants  (Id, Has_Discriminants     (T));
+               Set_Is_Constrained     (Id, Is_Constrained        (T));
+               Set_First_Entity       (Id, First_Entity          (T));
+               Set_Last_Entity        (Id, Last_Entity           (T));
+               Set_Private_Dependents (Id, New_Elmt_List);
+               Set_Is_Limited_Record  (Id, Is_Limited_Record     (T));
+               Set_Has_Unknown_Discriminants
+                                      (Id, Has_Unknown_Discriminants (T));
+
+               if Is_Tagged_Type (T) then
+                  Set_Is_Tagged_Type  (Id);
+                  Set_Is_Abstract     (Id, Is_Abstract (T));
+                  Set_Class_Wide_Type (Id, Class_Wide_Type (T));
+               end if;
+
+               --  In general the attributes of the subtype of a private
+               --  type are the attributes of the partial view of parent.
+               --  However, the full view may be a discriminated type,
+               --  and the subtype must share the discriminant constraint
+               --  to generate correct calls to initialization procedures.
+
+               if Has_Discriminants (T) then
+                  Set_Discriminant_Constraint
+                                     (Id, Discriminant_Constraint (T));
+                  Set_Girder_Constraint_From_Discriminant_Constraint (Id);
+
+               elsif Present (Full_View (T))
+                 and then Has_Discriminants (Full_View (T))
+               then
+                  Set_Discriminant_Constraint
+                               (Id, Discriminant_Constraint (Full_View (T)));
+                  Set_Girder_Constraint_From_Discriminant_Constraint (Id);
+
+                  --  This would seem semantically correct, but apparently
+                  --  confuses the back-end (4412-009). To be explained ???
+
+                  --  Set_Has_Discriminants (Id);
+               end if;
+
+               Prepare_Private_Subtype_Completion (Id, N);
+
+            when Access_Kind =>
+               Set_Ekind             (Id, E_Access_Subtype);
+               Set_Is_Constrained    (Id, Is_Constrained        (T));
+               Set_Is_Access_Constant
+                                     (Id, Is_Access_Constant    (T));
+               Set_Directly_Designated_Type
+                                     (Id, Designated_Type       (T));
+
+               --  A Pure library_item must not contain the declaration of a
+               --  named access type, except within a subprogram, generic
+               --  subprogram, task unit, or protected unit (RM 10.2.1(16)).
+
+               if Comes_From_Source (Id)
+                 and then In_Pure_Unit
+                 and then not In_Subprogram_Task_Protected_Unit
+               then
+                  Error_Msg_N
+                    ("named access types not allowed in pure unit", N);
+               end if;
+
+            when Concurrent_Kind =>
+
+               Set_Ekind                (Id, Subtype_Kind (Ekind   (T)));
+               Set_Corresponding_Record_Type (Id,
+                                         Corresponding_Record_Type (T));
+               Set_First_Entity         (Id, First_Entity          (T));
+               Set_First_Private_Entity (Id, First_Private_Entity  (T));
+               Set_Has_Discriminants    (Id, Has_Discriminants     (T));
+               Set_Is_Constrained       (Id, Is_Constrained        (T));
+               Set_Last_Entity          (Id, Last_Entity           (T));
+
+               if Has_Discriminants (T) then
+                  Set_Discriminant_Constraint (Id,
+                                           Discriminant_Constraint (T));
+                  Set_Girder_Constraint_From_Discriminant_Constraint (Id);
+               end if;
+
+            --  If the subtype name denotes an incomplete type
+            --  an error was already reported by Process_Subtype.
+
+            when E_Incomplete_Type =>
+               Set_Etype (Id, Any_Type);
+
+            when others =>
+               raise Program_Error;
+         end case;
+      end if;
+
+      if Etype (Id) = Any_Type then
+         return;
+      end if;
+
+      --  Some common processing on all types
+
+      Set_Size_Info      (Id,                 T);
+      Set_First_Rep_Item (Id, First_Rep_Item (T));
+
+      T := Etype (Id);
+
+      Set_Is_Immediately_Visible (Id, True);
+      Set_Depends_On_Private     (Id, Has_Private_Component (T));
+
+      if Present (Generic_Parent_Type (N))
+        and then
+          (Nkind
+             (Parent (Generic_Parent_Type (N))) /= N_Formal_Type_Declaration
+            or else Nkind
+              (Formal_Type_Definition (Parent (Generic_Parent_Type (N))))
+                /=  N_Formal_Private_Type_Definition)
+      then
+         if Is_Tagged_Type (Id) then
+            if Is_Class_Wide_Type (Id) then
+               Derive_Subprograms (Generic_Parent_Type (N), Id, Etype (T));
+            else
+               Derive_Subprograms (Generic_Parent_Type (N), Id, T);
+            end if;
+
+         elsif Scope (Etype (Id)) /= Standard_Standard then
+            Derive_Subprograms (Generic_Parent_Type (N), Id);
+         end if;
+      end if;
+
+      if Is_Private_Type (T)
+        and then Present (Full_View (T))
+      then
+         Conditional_Delay (Id, Full_View (T));
+
+      --  The subtypes of components or subcomponents of protected types
+      --  do not need freeze nodes, which would otherwise appear in the
+      --  wrong scope (before the freeze node for the protected type). The
+      --  proper subtypes are those of the subcomponents of the corresponding
+      --  record.
+
+      elsif Ekind (Scope (Id)) /= E_Protected_Type
+        and then Present (Scope (Scope (Id))) -- error defense!
+        and then Ekind (Scope (Scope (Id))) /= E_Protected_Type
+      then
+         Conditional_Delay (Id, T);
+      end if;
+
+      --  Check that constraint_error is raised for a scalar subtype
+      --  indication when the lower or upper bound of a non-null range
+      --  lies outside the range of the type mark.
+
+      if Nkind (Subtype_Indication (N)) = N_Subtype_Indication then
+         if Is_Scalar_Type (Etype (Id))
+            and then Scalar_Range (Id) /=
+                     Scalar_Range (Etype (Subtype_Mark
+                                           (Subtype_Indication (N))))
+         then
+            Apply_Range_Check
+              (Scalar_Range (Id),
+               Etype (Subtype_Mark (Subtype_Indication (N))));
+
+         elsif Is_Array_Type (Etype (Id))
+           and then Present (First_Index (Id))
+         then
+            --  This really should be a subprogram that finds the indications
+            --  to check???
+
+            if ((Nkind (First_Index (Id)) = N_Identifier
+                   and then Ekind (Entity (First_Index (Id))) in Scalar_Kind)
+                 or else Nkind (First_Index (Id)) = N_Subtype_Indication)
+              and then
+                Nkind (Scalar_Range (Etype (First_Index (Id)))) = N_Range
+            then
+               declare
+                  Target_Typ : Entity_Id :=
+                    Etype
+                      (First_Index
+                        (Etype (Subtype_Mark (Subtype_Indication (N)))));
+               begin
+                  R_Checks :=
+                    Range_Check
+                      (Scalar_Range (Etype (First_Index (Id))),
+                       Target_Typ,
+                       Etype (First_Index (Id)),
+                       Defining_Identifier (N));
+
+                  Insert_Range_Checks
+                    (R_Checks,
+                     N,
+                     Target_Typ,
+                     Sloc (Defining_Identifier (N)));
+               end;
+            end if;
+         end if;
+      end if;
+
+      Check_Eliminated (Id);
+   end Analyze_Subtype_Declaration;
+
+   --------------------------------
+   -- Analyze_Subtype_Indication --
+   --------------------------------
+
+   procedure Analyze_Subtype_Indication (N : Node_Id) is
+      T : constant Entity_Id := Subtype_Mark (N);
+      R : constant Node_Id   := Range_Expression (Constraint (N));
+
+   begin
+      Analyze (T);
+      Analyze (R);
+      Set_Etype (N, Etype (R));
+   end Analyze_Subtype_Indication;
+
+   ------------------------------
+   -- Analyze_Type_Declaration --
+   ------------------------------
+
+   procedure Analyze_Type_Declaration (N : Node_Id) is
+      Def    : constant Node_Id   := Type_Definition (N);
+      Def_Id : constant Entity_Id := Defining_Identifier (N);
+      T      : Entity_Id;
+      Prev   : Entity_Id;
+
+   begin
+      Prev := Find_Type_Name (N);
+
+      if Ekind (Prev) = E_Incomplete_Type then
+         T := Full_View (Prev);
+      else
+         T := Prev;
+      end if;
+
+      Set_Is_Pure (T, Is_Pure (Current_Scope));
+
+      --  We set the flag Is_First_Subtype here. It is needed to set the
+      --  corresponding flag for the Implicit class-wide-type created
+      --  during tagged types processing.
+
+      Set_Is_First_Subtype (T, True);
+
+      --  Only composite types other than array types are allowed to have
+      --  discriminants.
+
+      case Nkind (Def) is
+
+         --  For derived types, the rule will be checked once we've figured
+         --  out the parent type.
+
+         when N_Derived_Type_Definition =>
+            null;
+
+         --  For record types, discriminants are allowed.
+
+         when N_Record_Definition =>
+            null;
+
+         when others =>
+            if Present (Discriminant_Specifications (N)) then
+               Error_Msg_N
+                 ("elementary or array type cannot have discriminants",
+                  Defining_Identifier
+                  (First (Discriminant_Specifications (N))));
+            end if;
+      end case;
+
+      --  Elaborate the type definition according to kind, and generate
+      --  susbsidiary (implicit) subtypes where needed. We skip this if
+      --  it was already done (this happens during the reanalysis that
+      --  follows a call to the high level optimizer).
+
+      if not Analyzed (T) then
+         Set_Analyzed (T);
+
+         case Nkind (Def) is
+
+            when N_Access_To_Subprogram_Definition =>
+               Access_Subprogram_Declaration (T, Def);
+
+               --  If this is a remote access to subprogram, we must create
+               --  the equivalent fat pointer type, and related subprograms.
+
+               if Is_Remote_Types (Current_Scope)
+                 or else Is_Remote_Call_Interface (Current_Scope)
+               then
+                  Validate_Remote_Access_To_Subprogram_Type (N);
+                  Process_Remote_AST_Declaration (N);
+               end if;
+
+               --  Validate categorization rule against access type declaration
+               --  usually a violation in Pure unit, Shared_Passive unit.
+
+               Validate_Access_Type_Declaration (T, N);
+
+            when N_Access_To_Object_Definition =>
+               Access_Type_Declaration (T, Def);
+
+               --  Validate categorization rule against access type declaration
+               --  usually a violation in Pure unit, Shared_Passive unit.
+
+               Validate_Access_Type_Declaration (T, N);
+
+               --  If we are in a Remote_Call_Interface package and define
+               --  a RACW, Read and Write attribute must be added.
+
+               if (Is_Remote_Call_Interface (Current_Scope)
+                     or else Is_Remote_Types (Current_Scope))
+                 and then Is_Remote_Access_To_Class_Wide_Type (Def_Id)
+               then
+                  Add_RACW_Features (Def_Id);
+               end if;
+
+            when N_Array_Type_Definition =>
+               Array_Type_Declaration (T, Def);
+
+            when N_Derived_Type_Definition =>
+               Derived_Type_Declaration (T, N, T /= Def_Id);
+
+            when N_Enumeration_Type_Definition =>
+               Enumeration_Type_Declaration (T, Def);
+
+            when N_Floating_Point_Definition =>
+               Floating_Point_Type_Declaration (T, Def);
+
+            when N_Decimal_Fixed_Point_Definition =>
+               Decimal_Fixed_Point_Type_Declaration (T, Def);
+
+            when N_Ordinary_Fixed_Point_Definition =>
+               Ordinary_Fixed_Point_Type_Declaration (T, Def);
+
+            when N_Signed_Integer_Type_Definition =>
+               Signed_Integer_Type_Declaration (T, Def);
+
+            when N_Modular_Type_Definition =>
+               Modular_Type_Declaration (T, Def);
+
+            when N_Record_Definition =>
+               Record_Type_Declaration (T, N);
+
+            when others =>
+               raise Program_Error;
+
+         end case;
+      end if;
+
+      if Etype (T) = Any_Type then
+         return;
+      end if;
+
+      --  Some common processing for all types
+
+      Set_Depends_On_Private (T, Has_Private_Component (T));
+
+      --  Both the declared entity, and its anonymous base type if one
+      --  was created, need freeze nodes allocated.
+
+      declare
+         B : constant Entity_Id := Base_Type (T);
+
+      begin
+         --  In the case where the base type is different from the first
+         --  subtype, we pre-allocate a freeze node, and set the proper
+         --  link to the first subtype. Freeze_Entity will use this
+         --  preallocated freeze node when it freezes the entity.
+
+         if B /= T then
+            Ensure_Freeze_Node (B);
+            Set_First_Subtype_Link (Freeze_Node (B), T);
+         end if;
+
+         if not From_With_Type (T) then
+            Set_Has_Delayed_Freeze (T);
+         end if;
+      end;
+
+      --  Case of T is the full declaration of some private type which has
+      --  been swapped in Defining_Identifier (N).
+
+      if T /= Def_Id and then Is_Private_Type (Def_Id) then
+         Process_Full_View (N, T, Def_Id);
+
+         --  Record the reference. The form of this is a little strange,
+         --  since the full declaration has been swapped in. So the first
+         --  parameter here represents the entity to which a reference is
+         --  made which is the "real" entity, i.e. the one swapped in,
+         --  and the second parameter provides the reference location.
+
+         Generate_Reference (T, T, 'c');
+
+         --  If in main unit, set as referenced, so we do not complain about
+         --  the full declaration being an unreferenced entity.
+
+         if In_Extended_Main_Source_Unit (Def_Id) then
+            Set_Referenced (Def_Id);
+         end if;
+
+      --  For completion of incomplete type, process incomplete dependents
+      --  and always mark the full type as referenced (it is the incomplete
+      --  type that we get for any real reference).
+
+      elsif Ekind (Prev) = E_Incomplete_Type then
+         Process_Incomplete_Dependents (N, T, Prev);
+         Generate_Reference (Prev, Def_Id, 'c');
+
+         --  If in main unit, set as referenced, so we do not complain about
+         --  the full declaration being an unreferenced entity.
+
+         if In_Extended_Main_Source_Unit (Def_Id) then
+            Set_Referenced (Def_Id);
+         end if;
+
+      --  If not private type or incomplete type completion, this is a real
+      --  definition of a new entity, so record it.
+
+      else
+         Generate_Definition (Def_Id);
+      end if;
+
+      Check_Eliminated (Def_Id);
+   end Analyze_Type_Declaration;
+
+   --------------------------
+   -- Analyze_Variant_Part --
+   --------------------------
+
+   procedure Analyze_Variant_Part (N : Node_Id) is
+
+      procedure Non_Static_Choice_Error (Choice : Node_Id);
+      --  Error routine invoked by the generic instantiation below when
+      --  the variant part has a non static choice.
+
+      procedure Process_Declarations (Variant : Node_Id);
+      --  Analyzes all the declarations associated with a Variant.
+      --  Needed by the generic instantiation below.
+
+      package Variant_Choices_Processing is new
+        Generic_Choices_Processing
+          (Get_Alternatives          => Variants,
+           Get_Choices               => Discrete_Choices,
+           Process_Empty_Choice      => No_OP,
+           Process_Non_Static_Choice => Non_Static_Choice_Error,
+           Process_Associated_Node   => Process_Declarations);
+      use Variant_Choices_Processing;
+      --  Instantiation of the generic choice processing package.
+
+      -----------------------------
+      -- Non_Static_Choice_Error --
+      -----------------------------
+
+      procedure Non_Static_Choice_Error (Choice : Node_Id) is
+      begin
+         Error_Msg_N ("choice given in variant part is not static", Choice);
+      end Non_Static_Choice_Error;
+
+      --------------------------
+      -- Process_Declarations --
+      --------------------------
+
+      procedure Process_Declarations (Variant : Node_Id) is
+      begin
+         if not Null_Present (Component_List (Variant)) then
+            Analyze_Declarations (Component_Items (Component_List (Variant)));
+
+            if Present (Variant_Part (Component_List (Variant))) then
+               Analyze (Variant_Part (Component_List (Variant)));
+            end if;
+         end if;
+      end Process_Declarations;
+
+      --  Variables local to Analyze_Case_Statement.
+
+      Others_Choice : Node_Id;
+
+      Discr_Name : Node_Id;
+      Discr_Type : Entity_Id;
+
+      Case_Table     : Choice_Table_Type (1 .. Number_Of_Choices (N));
+      Last_Choice    : Nat;
+      Dont_Care      : Boolean;
+      Others_Present : Boolean := False;
+
+   --  Start of processing for Analyze_Variant_Part
+
+   begin
+      Discr_Name := Name (N);
+      Analyze (Discr_Name);
+
+      if Ekind (Entity (Discr_Name)) /= E_Discriminant then
+         Error_Msg_N ("invalid discriminant name in variant part", Discr_Name);
+      end if;
+
+      Discr_Type := Etype (Entity (Discr_Name));
+
+      --  Call the instantiated Analyze_Choices which does the rest of the work
+
+      Analyze_Choices
+        (N, Discr_Type, Case_Table, Last_Choice, Dont_Care, Others_Present);
+
+      if Others_Present then
+         --  Fill in Others_Discrete_Choices field of the OTHERS choice
+
+         Others_Choice := First (Discrete_Choices (Last (Variants (N))));
+         Expand_Others_Choice
+           (Case_Table (1 .. Last_Choice), Others_Choice, Discr_Type);
+      end if;
+
+   end Analyze_Variant_Part;
+
+   ----------------------------
+   -- Array_Type_Declaration --
+   ----------------------------
+
+   procedure Array_Type_Declaration (T : in out Entity_Id; Def : Node_Id) is
+      Component_Def : constant Node_Id := Subtype_Indication (Def);
+      Element_Type  : Entity_Id;
+      Implicit_Base : Entity_Id;
+      Index         : Node_Id;
+      Related_Id    : Entity_Id := Empty;
+      Nb_Index      : Nat;
+      P             : constant Node_Id := Parent (Def);
+      Priv          : Entity_Id;
+
+   begin
+      if Nkind (Def) = N_Constrained_Array_Definition then
+
+         Index := First (Discrete_Subtype_Definitions (Def));
+
+         --  Find proper names for the implicit types which may be public.
+         --  in case of anonymous arrays we use the name of the first object
+         --  of that type as prefix.
+
+         if No (T) then
+            Related_Id :=  Defining_Identifier (P);
+         else
+            Related_Id := T;
+         end if;
+
+      else
+         Index := First (Subtype_Marks (Def));
+      end if;
+
+      Nb_Index := 1;
+
+      while Present (Index) loop
+         Analyze (Index);
+         Make_Index (Index, P, Related_Id, Nb_Index);
+         Next_Index (Index);
+         Nb_Index := Nb_Index + 1;
+      end loop;
+
+      Element_Type := Process_Subtype (Component_Def, P, Related_Id, 'C');
+
+      --  Constrained array case
+
+      if No (T) then
+         T := Create_Itype (E_Void, P, Related_Id, 'T');
+      end if;
+
+      if Nkind (Def) = N_Constrained_Array_Definition then
+
+         --  Establish Implicit_Base as unconstrained base type
+
+         Implicit_Base := Create_Itype (E_Array_Type, P, Related_Id, 'B');
+
+         Init_Size_Align        (Implicit_Base);
+         Set_Etype              (Implicit_Base, Implicit_Base);
+         Set_Scope              (Implicit_Base, Current_Scope);
+         Set_Has_Delayed_Freeze (Implicit_Base);
+
+         --  The constrained array type is a subtype of the unconstrained one
+
+         Set_Ekind          (T, E_Array_Subtype);
+         Init_Size_Align    (T);
+         Set_Etype          (T, Implicit_Base);
+         Set_Scope          (T, Current_Scope);
+         Set_Is_Constrained (T, True);
+         Set_First_Index    (T, First (Discrete_Subtype_Definitions (Def)));
+         Set_Has_Delayed_Freeze (T);
+
+         --  Complete setup of implicit base type
+
+         Set_First_Index    (Implicit_Base, First_Index (T));
+         Set_Component_Type (Implicit_Base, Element_Type);
+         Set_Has_Task       (Implicit_Base, Has_Task (Element_Type));
+         Set_Component_Size (Implicit_Base, Uint_0);
+         Set_Has_Controlled_Component (Implicit_Base,
+           Has_Controlled_Component (Element_Type)
+             or else Is_Controlled (Element_Type));
+         Set_Finalize_Storage_Only (Implicit_Base,
+           Finalize_Storage_Only (Element_Type));
+
+      --  Unconstrained array case
+
+      else
+         Set_Ekind                    (T, E_Array_Type);
+         Init_Size_Align              (T);
+         Set_Etype                    (T, T);
+         Set_Scope                    (T, Current_Scope);
+         Set_Component_Size           (T, Uint_0);
+         Set_Is_Constrained           (T, False);
+         Set_First_Index              (T, First (Subtype_Marks (Def)));
+         Set_Has_Delayed_Freeze       (T, True);
+         Set_Has_Task                 (T, Has_Task (Element_Type));
+         Set_Has_Controlled_Component (T,
+           Has_Controlled_Component (Element_Type)
+             or else Is_Controlled (Element_Type));
+         Set_Finalize_Storage_Only (T,
+           Finalize_Storage_Only (Element_Type));
+      end if;
+
+      Set_Component_Type (T, Element_Type);
+
+      if Aliased_Present (Def) then
+         Set_Has_Aliased_Components (Etype (T));
+      end if;
+
+      Priv := Private_Component (Element_Type);
+
+      if Present (Priv) then
+         --  Check for circular definitions.
+
+         if Priv = Any_Type then
+            Set_Component_Type (T, Any_Type);
+            Set_Component_Type (Etype (T), Any_Type);
+
+         --  There is a gap in the visiblity of operations on the composite
+         --  type only if the component type is defined in a different scope.
+
+         elsif Scope (Priv) = Current_Scope then
+            null;
+
+         elsif Is_Limited_Type (Priv) then
+            Set_Is_Limited_Composite (Etype (T));
+            Set_Is_Limited_Composite (T);
+         else
+            Set_Is_Private_Composite (Etype (T));
+            Set_Is_Private_Composite (T);
+         end if;
+      end if;
+
+      --  Create a concatenation operator for the new type. Internal
+      --  array types created for packed entities do not need such, they
+      --  are compatible with the user-defined type.
+
+      if Number_Dimensions (T) = 1
+         and then not Is_Packed_Array_Type (T)
+      then
+         New_Binary_Operator (Name_Op_Concat, T);
+      end if;
+
+      --  In the case of an unconstrained array the parser has already
+      --  verified that all the indices are unconstrained but we still
+      --  need to make sure that the element type is constrained.
+
+      if Is_Indefinite_Subtype (Element_Type) then
+         Error_Msg_N
+           ("unconstrained element type in array declaration ",
+            Component_Def);
+
+      elsif Is_Abstract (Element_Type) then
+         Error_Msg_N ("The type of a component cannot be abstract ",
+              Component_Def);
+      end if;
+
+   end Array_Type_Declaration;
+
+   -------------------------------
+   -- Build_Derived_Access_Type --
+   -------------------------------
+
+   procedure Build_Derived_Access_Type
+     (N            : Node_Id;
+      Parent_Type  : Entity_Id;
+      Derived_Type : Entity_Id)
+   is
+      S : constant Node_Id := Subtype_Indication (Type_Definition (N));
+
+      Desig_Type      : Entity_Id;
+      Discr           : Entity_Id;
+      Discr_Con_Elist : Elist_Id;
+      Discr_Con_El    : Elmt_Id;
+
+      Subt            : Entity_Id;
+
+   begin
+      --  Set the designated type so it is available in case this is
+      --  an access to a self-referential type, e.g. a standard list
+      --  type with a next pointer. Will be reset after subtype is built.
+
+      Set_Directly_Designated_Type (Derived_Type,
+        Designated_Type (Parent_Type));
+
+      Subt := Process_Subtype (S, N);
+
+      if Nkind (S) /= N_Subtype_Indication
+        and then Subt /= Base_Type (Subt)
+      then
+         Set_Ekind (Derived_Type, E_Access_Subtype);
+      end if;
+
+      if Ekind (Derived_Type) = E_Access_Subtype then
+         declare
+            Pbase      : constant Entity_Id := Base_Type (Parent_Type);
+            Ibase      : constant Entity_Id :=
+                           Create_Itype (Ekind (Pbase), N, Derived_Type, 'B');
+            Svg_Chars  : constant Name_Id   := Chars (Ibase);
+            Svg_Next_E : constant Entity_Id := Next_Entity (Ibase);
+
+         begin
+            Copy_Node (Pbase, Ibase);
+
+            Set_Chars       (Ibase, Svg_Chars);
+            Set_Next_Entity (Ibase, Svg_Next_E);
+            Set_Sloc        (Ibase, Sloc (Derived_Type));
+            Set_Scope       (Ibase, Scope (Derived_Type));
+            Set_Freeze_Node (Ibase, Empty);
+            Set_Is_Frozen   (Ibase, False);
+
+            Set_Etype (Ibase, Pbase);
+            Set_Etype (Derived_Type, Ibase);
+         end;
+      end if;
+
+      Set_Directly_Designated_Type
+        (Derived_Type, Designated_Type (Subt));
+
+      Set_Is_Constrained     (Derived_Type, Is_Constrained (Subt));
+      Set_Is_Access_Constant (Derived_Type, Is_Access_Constant (Parent_Type));
+      Set_Size_Info          (Derived_Type,                     Parent_Type);
+      Set_RM_Size            (Derived_Type, RM_Size            (Parent_Type));
+      Set_Depends_On_Private (Derived_Type,
+                              Has_Private_Component (Derived_Type));
+      Conditional_Delay      (Derived_Type, Subt);
+
+      --  Note: we do not copy the Storage_Size_Variable, since
+      --  we always go to the root type for this information.
+
+      --  Apply range checks to discriminants for derived record case
+      --  ??? THIS CODE SHOULD NOT BE HERE REALLY.
+
+      Desig_Type := Designated_Type (Derived_Type);
+      if Is_Composite_Type (Desig_Type)
+        and then (not Is_Array_Type (Desig_Type))
+        and then Has_Discriminants (Desig_Type)
+        and then Base_Type (Desig_Type) /= Desig_Type
+      then
+         Discr_Con_Elist := Discriminant_Constraint (Desig_Type);
+         Discr_Con_El := First_Elmt (Discr_Con_Elist);
+
+         Discr := First_Discriminant (Base_Type (Desig_Type));
+         while Present (Discr_Con_El) loop
+            Apply_Range_Check (Node (Discr_Con_El), Etype (Discr));
+            Next_Elmt (Discr_Con_El);
+            Next_Discriminant (Discr);
+         end loop;
+      end if;
+   end Build_Derived_Access_Type;
+
+   ------------------------------
+   -- Build_Derived_Array_Type --
+   ------------------------------
+
+   procedure Build_Derived_Array_Type
+     (N            : Node_Id;
+      Parent_Type  : Entity_Id;
+      Derived_Type : Entity_Id)
+   is
+      Loc           : constant Source_Ptr := Sloc (N);
+      Tdef          : constant Node_Id    := Type_Definition (N);
+      Indic         : constant Node_Id    := Subtype_Indication (Tdef);
+      Parent_Base   : constant Entity_Id  := Base_Type (Parent_Type);
+      Implicit_Base : Entity_Id;
+      New_Indic     : Node_Id;
+
+      procedure Make_Implicit_Base;
+      --  If the parent subtype is constrained, the derived type is a
+      --  subtype of an implicit base type derived from the parent base.
+
+      ------------------------
+      -- Make_Implicit_Base --
+      ------------------------
+
+      procedure Make_Implicit_Base is
+      begin
+         Implicit_Base :=
+           Create_Itype (Ekind (Parent_Base), N, Derived_Type, 'B');
+
+         Set_Ekind (Implicit_Base, Ekind (Parent_Base));
+         Set_Etype (Implicit_Base, Parent_Base);
+
+         Copy_Array_Subtype_Attributes   (Implicit_Base, Parent_Base);
+         Copy_Array_Base_Type_Attributes (Implicit_Base, Parent_Base);
+
+         Set_Has_Delayed_Freeze (Implicit_Base, True);
+      end Make_Implicit_Base;
+
+   --  Start of processing for Build_Derived_Array_Type
+
+   begin
+      if not Is_Constrained (Parent_Type) then
+         if Nkind (Indic) /= N_Subtype_Indication then
+            Set_Ekind (Derived_Type, E_Array_Type);
+
+            Copy_Array_Subtype_Attributes   (Derived_Type, Parent_Type);
+            Copy_Array_Base_Type_Attributes (Derived_Type, Parent_Type);
+
+            Set_Has_Delayed_Freeze (Derived_Type, True);
+
+         else
+            Make_Implicit_Base;
+            Set_Etype (Derived_Type, Implicit_Base);
+
+            New_Indic :=
+              Make_Subtype_Declaration (Loc,
+                Defining_Identifier => Derived_Type,
+                Subtype_Indication  =>
+                  Make_Subtype_Indication (Loc,
+                    Subtype_Mark => New_Reference_To (Implicit_Base, Loc),
+                    Constraint => Constraint (Indic)));
+
+            Rewrite (N, New_Indic);
+            Analyze (N);
+         end if;
+
+      else
+         if Nkind (Indic) /= N_Subtype_Indication then
+            Make_Implicit_Base;
+
+            Set_Ekind             (Derived_Type, Ekind (Parent_Type));
+            Set_Etype             (Derived_Type, Implicit_Base);
+            Copy_Array_Subtype_Attributes (Derived_Type, Parent_Type);
+
+         else
+            Error_Msg_N ("illegal constraint on constrained type", Indic);
+         end if;
+      end if;
+
+      --  If the parent type is not a derived type itself, and is
+      --  declared in a closed scope (e.g., a subprogram), then we
+      --  need to explicitly introduce the new type's concatenation
+      --  operator since Derive_Subprograms will not inherit the
+      --  parent's operator.
+
+      if Number_Dimensions (Parent_Type) = 1
+        and then not Is_Limited_Type (Parent_Type)
+        and then not Is_Derived_Type (Parent_Type)
+        and then not Is_Package (Scope (Base_Type (Parent_Type)))
+      then
+         New_Binary_Operator (Name_Op_Concat, Derived_Type);
+      end if;
+   end Build_Derived_Array_Type;
+
+   -----------------------------------
+   -- Build_Derived_Concurrent_Type --
+   -----------------------------------
+
+   procedure Build_Derived_Concurrent_Type
+     (N            : Node_Id;
+      Parent_Type  : Entity_Id;
+      Derived_Type : Entity_Id)
+   is
+      D_Constraint : Node_Id;
+      Disc_Spec    : Node_Id;
+      Old_Disc     : Entity_Id;
+      New_Disc     : Entity_Id;
+      Constraint_Present : constant Boolean :=
+         Nkind (Subtype_Indication (Type_Definition (N))) =
+           N_Subtype_Indication;
+
+   begin
+      Set_Girder_Constraint (Derived_Type, No_Elist);
+
+      if Is_Task_Type (Parent_Type) then
+         Set_Storage_Size_Variable (Derived_Type,
+           Storage_Size_Variable (Parent_Type));
+      end if;
+
+      if Present (Discriminant_Specifications (N)) then
+         New_Scope (Derived_Type);
+         Check_Or_Process_Discriminants (N, Derived_Type);
+         End_Scope;
+      end if;
+
+      --  All attributes are inherited from parent. In particular,
+      --  entries and the corresponding record type are the same.
+      --  Discriminants may be renamed, and must be treated separately.
+
+      Set_Has_Discriminants
+                       (Derived_Type, Has_Discriminants (Parent_Type));
+      Set_Corresponding_Record_Type
+                       (Derived_Type, Corresponding_Record_Type
+                                                        (Parent_Type));
+
+      if Constraint_Present then
+
+         if not Has_Discriminants (Parent_Type) then
+            Error_Msg_N ("untagged parent must have discriminants", N);
+
+         elsif Present (Discriminant_Specifications (N)) then
+
+            --  Verify that new discriminants are used to constrain
+            --  the old ones.
+
+            Old_Disc   := First_Discriminant (Parent_Type);
+            New_Disc   := First_Discriminant (Derived_Type);
+            Disc_Spec  := First (Discriminant_Specifications (N));
+            D_Constraint :=
+              First (Constraints (
+                Constraint (Subtype_Indication (Type_Definition (N)))));
+
+            while Present (Old_Disc) and then Present (Disc_Spec) loop
+
+               if Nkind (Discriminant_Type (Disc_Spec)) /=
+                 N_Access_Definition
+               then
+                  Analyze (Discriminant_Type (Disc_Spec));
+                  if not Subtypes_Statically_Compatible (
+                             Etype (Discriminant_Type (Disc_Spec)),
+                               Etype (Old_Disc))
+                  then
+                     Error_Msg_N
+                       ("not statically compatible with parent discriminant",
+                        Discriminant_Type (Disc_Spec));
+                  end if;
+               end if;
+
+               if Nkind (D_Constraint) = N_Identifier
+                 and then Chars (D_Constraint) /=
+                   Chars (Defining_Identifier (Disc_Spec))
+               then
+                  Error_Msg_N ("new discriminants must constrain old ones",
+                    D_Constraint);
+               else
+                  Set_Corresponding_Discriminant (New_Disc, Old_Disc);
+               end if;
+
+               Next_Discriminant (Old_Disc);
+               Next_Discriminant (New_Disc);
+               Next (Disc_Spec);
+            end loop;
+
+            if Present (Old_Disc) or else Present (Disc_Spec) then
+               Error_Msg_N ("discriminant mismatch in derivation", N);
+            end if;
+
+         end if;
+
+      elsif Present (Discriminant_Specifications (N)) then
+         Error_Msg_N
+           ("missing discriminant constraint in untagged derivation",
+            N);
+      end if;
+
+      if Present (Discriminant_Specifications (N)) then
+
+         Old_Disc := First_Discriminant (Parent_Type);
+
+         while Present (Old_Disc) loop
+
+            if No (Next_Entity (Old_Disc))
+              or else Ekind (Next_Entity (Old_Disc)) /= E_Discriminant
+            then
+               Set_Next_Entity (Last_Entity (Derived_Type),
+                                         Next_Entity (Old_Disc));
+               exit;
+            end if;
+
+            Next_Discriminant (Old_Disc);
+         end loop;
+
+      else
+         Set_First_Entity (Derived_Type, First_Entity (Parent_Type));
+      end if;
+
+      Set_Last_Entity  (Derived_Type, Last_Entity  (Parent_Type));
+
+      Set_Has_Completion (Derived_Type);
+   end Build_Derived_Concurrent_Type;
+
+   ------------------------------------
+   -- Build_Derived_Enumeration_Type --
+   ------------------------------------
+
+   procedure Build_Derived_Enumeration_Type
+     (N            : Node_Id;
+      Parent_Type  : Entity_Id;
+      Derived_Type : Entity_Id)
+   is
+      Loc           : constant Source_Ptr := Sloc (N);
+      Def           : constant Node_Id    := Type_Definition (N);
+      Indic         : constant Node_Id    := Subtype_Indication (Def);
+      Implicit_Base : Entity_Id;
+      Literal       : Entity_Id;
+      New_Lit       : Entity_Id;
+      Literals_List : List_Id;
+      Type_Decl     : Node_Id;
+      Hi, Lo        : Node_Id;
+      Rang_Expr     : Node_Id;
+
+   begin
+      --  Since types Standard.Character and Standard.Wide_Character do
+      --  not have explicit literals lists we need to process types derived
+      --  from them specially. This is handled by Derived_Standard_Character.
+      --  If the parent type is a generic type, there are no literals either,
+      --  and we construct the same skeletal representation as for the generic
+      --  parent type.
+
+      if Root_Type (Parent_Type) = Standard_Character
+        or else Root_Type (Parent_Type) = Standard_Wide_Character
+      then
+         Derived_Standard_Character (N, Parent_Type, Derived_Type);
+
+      elsif Is_Generic_Type (Root_Type (Parent_Type)) then
+         declare
+            Lo : Node_Id;
+            Hi : Node_Id;
+
+         begin
+            Lo :=
+               Make_Attribute_Reference (Loc,
+                 Attribute_Name => Name_First,
+                 Prefix => New_Reference_To (Derived_Type, Loc));
+            Set_Etype (Lo, Derived_Type);
+
+            Hi :=
+               Make_Attribute_Reference (Loc,
+                 Attribute_Name => Name_Last,
+                 Prefix => New_Reference_To (Derived_Type, Loc));
+            Set_Etype (Hi, Derived_Type);
+
+            Set_Scalar_Range (Derived_Type,
+               Make_Range (Loc,
+                 Low_Bound => Lo,
+                 High_Bound => Hi));
+         end;
+
+      else
+         --  If a constraint is present, analyze the bounds to catch
+         --  premature usage of the derived literals.
+
+         if Nkind (Indic) = N_Subtype_Indication
+           and then Nkind (Range_Expression (Constraint (Indic))) = N_Range
+         then
+            Analyze (Low_Bound  (Range_Expression (Constraint (Indic))));
+            Analyze (High_Bound (Range_Expression (Constraint (Indic))));
+         end if;
+
+         --  Introduce an implicit base type for the derived type even
+         --  if there is no constraint attached to it, since this seems
+         --  closer to the Ada semantics. Build a full type declaration
+         --  tree for the derived type using the implicit base type as
+         --  the defining identifier. The build a subtype declaration
+         --  tree which applies the constraint (if any) have it replace
+         --  the derived type declaration.
+
+         Literal := First_Literal (Parent_Type);
+         Literals_List := New_List;
+
+         while Present (Literal)
+           and then Ekind (Literal) = E_Enumeration_Literal
+         loop
+            --  Literals of the derived type have the same representation as
+            --  those of the parent type, but this representation can be
+            --  overridden by an explicit representation clause. Indicate
+            --  that there is no explicit representation given yet. These
+            --  derived literals are implicit operations of the new type,
+            --  and can be overriden by explicit ones.
+
+            if Nkind (Literal) = N_Defining_Character_Literal then
+               New_Lit :=
+                 Make_Defining_Character_Literal (Loc, Chars (Literal));
+            else
+               New_Lit := Make_Defining_Identifier (Loc, Chars (Literal));
+            end if;
+
+            Set_Ekind                (New_Lit, E_Enumeration_Literal);
+            Set_Enumeration_Pos      (New_Lit, Enumeration_Pos (Literal));
+            Set_Enumeration_Rep      (New_Lit, Enumeration_Rep (Literal));
+            Set_Enumeration_Rep_Expr (New_Lit, Empty);
+            Set_Alias                (New_Lit, Literal);
+            Set_Is_Known_Valid       (New_Lit, True);
+
+            Append (New_Lit, Literals_List);
+            Next_Literal (Literal);
+         end loop;
+
+         Implicit_Base :=
+           Make_Defining_Identifier (Sloc (Derived_Type),
+             New_External_Name (Chars (Derived_Type), 'B'));
+
+         --  Indicate the proper nature of the derived type. This must
+         --  be done before analysis of the literals, to recognize cases
+         --  when a literal may be hidden by a previous explicit function
+         --  definition (cf. c83031a).
+
+         Set_Ekind (Derived_Type, E_Enumeration_Subtype);
+         Set_Etype (Derived_Type, Implicit_Base);
+
+         Type_Decl :=
+           Make_Full_Type_Declaration (Loc,
+             Defining_Identifier => Implicit_Base,
+             Discriminant_Specifications => No_List,
+             Type_Definition =>
+               Make_Enumeration_Type_Definition (Loc, Literals_List));
+
+         Mark_Rewrite_Insertion (Type_Decl);
+         Insert_Before (N, Type_Decl);
+         Analyze (Type_Decl);
+
+         --  After the implicit base is analyzed its Etype needs to be
+         --  changed to reflect the fact that it is derived from the
+         --  parent type which was ignored during analysis. We also set
+         --  the size at this point.
+
+         Set_Etype (Implicit_Base, Parent_Type);
+
+         Set_Size_Info      (Implicit_Base,                 Parent_Type);
+         Set_RM_Size        (Implicit_Base, RM_Size        (Parent_Type));
+         Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Parent_Type));
+
+         Set_Has_Non_Standard_Rep
+                            (Implicit_Base, Has_Non_Standard_Rep
+                                                           (Parent_Type));
+         Set_Has_Delayed_Freeze (Implicit_Base);
+
+         --  Process the subtype indication including a validation check
+         --  on the constraint, if any. If a constraint is given, its bounds
+         --  must be implicitly converted to the new type.
+
+         if Nkind (Indic) = N_Subtype_Indication then
+
+            declare
+               R   : constant Node_Id :=
+                       Range_Expression (Constraint (Indic));
+
+            begin
+               if Nkind (R) = N_Range then
+                  Hi := Build_Scalar_Bound
+                          (High_Bound (R), Parent_Type, Implicit_Base, Loc);
+                  Lo := Build_Scalar_Bound
+                          (Low_Bound  (R), Parent_Type, Implicit_Base, Loc);
+
+               else
+                  --  Constraint is a Range attribute. Replace with the
+                  --  explicit mention of the bounds of the prefix, which
+                  --  must be a subtype.
+
+                  Analyze (Prefix (R));
+                  Hi :=
+                    Convert_To (Implicit_Base,
+                      Make_Attribute_Reference (Loc,
+                        Attribute_Name => Name_Last,
+                        Prefix =>
+                          New_Occurrence_Of (Entity (Prefix (R)), Loc)));
+
+                  Lo :=
+                    Convert_To (Implicit_Base,
+                      Make_Attribute_Reference (Loc,
+                        Attribute_Name => Name_First,
+                        Prefix =>
+                          New_Occurrence_Of (Entity (Prefix (R)), Loc)));
+               end if;
+
+            end;
+
+         else
+            Hi :=
+              Build_Scalar_Bound
+                (Type_High_Bound (Parent_Type),
+                 Parent_Type, Implicit_Base, Loc);
+            Lo :=
+               Build_Scalar_Bound
+                 (Type_Low_Bound (Parent_Type),
+                  Parent_Type, Implicit_Base, Loc);
+         end if;
+
+         Rang_Expr :=
+           Make_Range (Loc,
+             Low_Bound  => Lo,
+             High_Bound => Hi);
+
+         --  If we constructed a default range for the case where no range
+         --  was given, then the expressions in the range must not freeze
+         --  since they do not correspond to expressions in the source.
+
+         if Nkind (Indic) /= N_Subtype_Indication then
+            Set_Must_Not_Freeze (Lo);
+            Set_Must_Not_Freeze (Hi);
+            Set_Must_Not_Freeze (Rang_Expr);
+         end if;
+
+         Rewrite (N,
+           Make_Subtype_Declaration (Loc,
+             Defining_Identifier => Derived_Type,
+             Subtype_Indication =>
+               Make_Subtype_Indication (Loc,
+                 Subtype_Mark => New_Occurrence_Of (Implicit_Base, Loc),
+                 Constraint =>
+                   Make_Range_Constraint (Loc,
+                     Range_Expression => Rang_Expr))));
+
+         Analyze (N);
+
+         --  If pragma Discard_Names applies on the first subtype
+         --  of the parent type, then it must be applied on this
+         --  subtype as well.
+
+         if Einfo.Discard_Names (First_Subtype (Parent_Type)) then
+            Set_Discard_Names (Derived_Type);
+         end if;
+
+         --  Apply a range check. Since this range expression doesn't
+         --  have an Etype, we have to specifically pass the Source_Typ
+         --  parameter. Is this right???
+
+         if Nkind (Indic) = N_Subtype_Indication then
+            Apply_Range_Check (Range_Expression (Constraint (Indic)),
+                               Parent_Type,
+                               Source_Typ => Entity (Subtype_Mark (Indic)));
+         end if;
+      end if;
+
+   end Build_Derived_Enumeration_Type;
+
+   --------------------------------
+   -- Build_Derived_Numeric_Type --
+   --------------------------------
+
+   procedure Build_Derived_Numeric_Type
+     (N            : Node_Id;
+      Parent_Type  : Entity_Id;
+      Derived_Type : Entity_Id)
+   is
+      Loc           : constant Source_Ptr := Sloc (N);
+      Tdef          : constant Node_Id    := Type_Definition (N);
+      Indic         : constant Node_Id    := Subtype_Indication (Tdef);
+      Parent_Base   : constant Entity_Id  := Base_Type (Parent_Type);
+      No_Constraint : constant Boolean    := Nkind (Indic) /=
+                                                  N_Subtype_Indication;
+      Implicit_Base    : Entity_Id;
+
+      Lo : Node_Id;
+      Hi : Node_Id;
+      T  : Entity_Id;
+
+   begin
+      --  Process the subtype indication including a validation check on
+      --  the constraint if any.
+
+      T := Process_Subtype (Indic, N);
+
+      --  Introduce an implicit base type for the derived type even if
+      --  there is no constraint attached to it, since this seems closer
+      --  to the Ada semantics.
+
+      Implicit_Base :=
+        Create_Itype (Ekind (Parent_Base), N, Derived_Type, 'B');
+
+      Set_Etype          (Implicit_Base, Parent_Base);
+      Set_Ekind          (Implicit_Base, Ekind          (Parent_Base));
+      Set_Size_Info      (Implicit_Base,                 Parent_Base);
+      Set_RM_Size        (Implicit_Base, RM_Size        (Parent_Base));
+      Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Parent_Base));
+      Set_Parent         (Implicit_Base, Parent (Derived_Type));
+
+      if Is_Discrete_Or_Fixed_Point_Type (Parent_Base) then
+         Set_RM_Size (Implicit_Base, RM_Size (Parent_Base));
+      end if;
+
+      Set_Has_Delayed_Freeze (Implicit_Base);
+
+      Lo := New_Copy_Tree (Type_Low_Bound  (Parent_Base));
+      Hi := New_Copy_Tree (Type_High_Bound (Parent_Base));
+
+      Set_Scalar_Range (Implicit_Base,
+        Make_Range (Loc,
+          Low_Bound  => Lo,
+          High_Bound => Hi));
+
+      if Has_Infinities (Parent_Base) then
+         Set_Includes_Infinities (Scalar_Range (Implicit_Base));
+      end if;
+
+      --  The Derived_Type, which is the entity of the declaration, is
+      --  a subtype of the implicit base. Its Ekind is a subtype, even
+      --  in the absence of an explicit constraint.
+
+      Set_Etype (Derived_Type, Implicit_Base);
+
+      --  If we did not have a constraint, then the Ekind is set from the
+      --  parent type (otherwise Process_Subtype has set the bounds)
+
+      if No_Constraint then
+         Set_Ekind (Derived_Type, Subtype_Kind (Ekind (Parent_Type)));
+      end if;
+
+      --  If we did not have a range constraint, then set the range
+      --  from the parent type. Otherwise, the call to Process_Subtype
+      --  has set the bounds.
+
+      if No_Constraint
+        or else not Has_Range_Constraint (Indic)
+      then
+         Set_Scalar_Range (Derived_Type,
+           Make_Range (Loc,
+             Low_Bound  => New_Copy_Tree (Type_Low_Bound  (Parent_Type)),
+             High_Bound => New_Copy_Tree (Type_High_Bound (Parent_Type))));
+         Set_Is_Constrained (Derived_Type, Is_Constrained (Parent_Type));
+
+         if Has_Infinities (Parent_Type) then
+            Set_Includes_Infinities (Scalar_Range (Derived_Type));
+         end if;
+      end if;
+
+      --  Set remaining type-specific fields, depending on numeric type
+
+      if Is_Modular_Integer_Type (Parent_Type) then
+         Set_Modulus (Implicit_Base, Modulus (Parent_Base));
+
+         Set_Non_Binary_Modulus
+           (Implicit_Base, Non_Binary_Modulus (Parent_Base));
+
+      elsif Is_Floating_Point_Type (Parent_Type) then
+
+         --  Digits of base type is always copied from the digits value of
+         --  the parent base type, but the digits of the derived type will
+         --  already have been set if there was a constraint present.
+
+         Set_Digits_Value (Implicit_Base, Digits_Value (Parent_Base));
+         Set_Vax_Float    (Implicit_Base, Vax_Float    (Parent_Base));
+
+         if No_Constraint then
+            Set_Digits_Value (Derived_Type, Digits_Value (Parent_Type));
+         end if;
+
+      elsif Is_Fixed_Point_Type (Parent_Type) then
+
+         --  Small of base type and derived type are always copied from
+         --  the parent base type, since smalls never change. The delta
+         --  of the base type is also copied from the parent base type.
+         --  However the delta of the derived type will have been set
+         --  already if a constraint was present.
+
+         Set_Small_Value (Derived_Type,  Small_Value (Parent_Base));
+         Set_Small_Value (Implicit_Base, Small_Value (Parent_Base));
+         Set_Delta_Value (Implicit_Base, Delta_Value (Parent_Base));
+
+         if No_Constraint then
+            Set_Delta_Value (Derived_Type,  Delta_Value (Parent_Type));
+         end if;
+
+         --  The scale and machine radix in the decimal case are always
+         --  copied from the parent base type.
+
+         if Is_Decimal_Fixed_Point_Type (Parent_Type) then
+            Set_Scale_Value (Derived_Type,  Scale_Value (Parent_Base));
+            Set_Scale_Value (Implicit_Base, Scale_Value (Parent_Base));
+
+            Set_Machine_Radix_10
+              (Derived_Type,  Machine_Radix_10 (Parent_Base));
+            Set_Machine_Radix_10
+              (Implicit_Base, Machine_Radix_10 (Parent_Base));
+
+            Set_Digits_Value (Implicit_Base, Digits_Value (Parent_Base));
+
+            if No_Constraint then
+               Set_Digits_Value (Derived_Type, Digits_Value (Parent_Base));
+
+            else
+               --  the analysis of the subtype_indication sets the
+               --  digits value of the derived type.
+
+               null;
+            end if;
+         end if;
+      end if;
+
+      --  The type of the bounds is that of the parent type, and they
+      --  must be converted to the derived type.
+
+      Convert_Scalar_Bounds (N, Parent_Type, Derived_Type, Loc);
+
+      --  The implicit_base should be frozen when the derived type is frozen,
+      --  but note that it is used in the conversions of the bounds. For
+      --  fixed types we delay the determination of the bounds until the proper
+      --  freezing point. For other numeric types this is rejected by GCC, for
+      --  reasons that are currently unclear (???), so we choose to freeze the
+      --  implicit base now. In the case of integers and floating point types
+      --  this is harmless because subsequent representation clauses cannot
+      --  affect anything, but it is still baffling that we cannot use the
+      --  same mechanism for all derived numeric types.
+
+      if Is_Fixed_Point_Type (Parent_Type) then
+         Conditional_Delay (Implicit_Base, Parent_Type);
+      else
+         Freeze_Before (N, Implicit_Base);
+      end if;
+
+   end Build_Derived_Numeric_Type;
+
+   --------------------------------
+   -- Build_Derived_Private_Type --
+   --------------------------------
+
+   procedure Build_Derived_Private_Type
+     (N            : Node_Id;
+      Parent_Type  : Entity_Id;
+      Derived_Type : Entity_Id;
+      Is_Completion : Boolean;
+      Derive_Subps  : Boolean := True)
+   is
+      Der_Base    : Entity_Id;
+      Discr       : Entity_Id;
+      Full_Decl   : Node_Id := Empty;
+      Full_Der    : Entity_Id;
+      Full_P      : Entity_Id;
+      Last_Discr  : Entity_Id;
+      Par_Scope   : constant Entity_Id := Scope (Base_Type (Parent_Type));
+      Swapped     : Boolean := False;
+
+      procedure Copy_And_Build;
+      --  Copy derived type declaration, replace parent with its full view,
+      --  and analyze new declaration.
+
+      procedure Copy_And_Build is
+         Full_N  : Node_Id;
+
+      begin
+         if Ekind (Parent_Type) in Record_Kind
+           or else (Ekind (Parent_Type) in Enumeration_Kind
+             and then Root_Type (Parent_Type) /= Standard_Character
+             and then Root_Type (Parent_Type) /= Standard_Wide_Character
+             and then not Is_Generic_Type (Root_Type (Parent_Type)))
+         then
+            Full_N := New_Copy_Tree (N);
+            Insert_After (N, Full_N);
+            Build_Derived_Type (
+              Full_N, Parent_Type, Full_Der, True, Derive_Subps => False);
+
+         else
+            Build_Derived_Type (
+              N, Parent_Type, Full_Der, True, Derive_Subps => False);
+         end if;
+      end Copy_And_Build;
+
+   --  Start of processing for Build_Derived_Private_Type
+
+   begin
+      if Is_Tagged_Type (Parent_Type) then
+         Build_Derived_Record_Type
+           (N, Parent_Type, Derived_Type, Derive_Subps);
+         return;
+
+      elsif Has_Discriminants (Parent_Type) then
+
+         if Present (Full_View (Parent_Type)) then
+            if not Is_Completion then
+
+               --  Copy declaration for subsequent analysis.
+
+               Full_Decl := New_Copy_Tree (N);
+               Full_Der  := New_Copy (Derived_Type);
+               Insert_After (N, Full_Decl);
+
+            else
+               --  If this is a completion, the full view being built is
+               --  itself private. We build a subtype of the parent with
+               --  the same constraints as this full view, to convey to the
+               --  back end the constrained components and the size of this
+               --  subtype. If the parent is constrained, its full view can
+               --  serve as the underlying full view of the derived type.
+
+               if No (Discriminant_Specifications (N)) then
+
+                  if Nkind (Subtype_Indication (Type_Definition (N)))
+                    = N_Subtype_Indication
+                  then
+                     Build_Underlying_Full_View (N, Derived_Type, Parent_Type);
+
+                  elsif Is_Constrained (Full_View (Parent_Type)) then
+                     Set_Underlying_Full_View (Derived_Type,
+                       Full_View (Parent_Type));
+                  end if;
+
+               else
+                  --  If there are new discriminants, the parent subtype is
+                  --  constrained by them, but it is not clear how to build
+                  --  the underlying_full_view in this case ???
+
+                  null;
+               end if;
+            end if;
+         end if;
+
+         Build_Derived_Record_Type
+           (N, Parent_Type, Derived_Type, Derive_Subps);
+
+         if Present (Full_View (Parent_Type))
+           and then not Is_Completion
+         then
+            if not In_Open_Scopes (Par_Scope)
+              or else not In_Same_Source_Unit (N, Parent_Type)
+            then
+               --  Swap partial and full views temporarily
+
+               Install_Private_Declarations (Par_Scope);
+               Install_Visible_Declarations (Par_Scope);
+               Swapped := True;
+            end if;
+
+            --  Subprograms have been derived on the private view,
+            --  the completion does not derive them anew.
+
+            Build_Derived_Record_Type
+              (Full_Decl, Parent_Type, Full_Der, False);
+
+            if Swapped then
+               Uninstall_Declarations (Par_Scope);
+
+               if In_Open_Scopes (Par_Scope) then
+                  Install_Visible_Declarations (Par_Scope);
+               end if;
+            end if;
+
+            Der_Base := Base_Type (Derived_Type);
+            Set_Full_View (Derived_Type, Full_Der);
+            Set_Full_View (Der_Base, Base_Type (Full_Der));
+
+            --  Copy the discriminant list from full view to
+            --  the partial views (base type and its subtype).
+            --  Gigi requires that the partial and full views
+            --  have the same discriminants.
+            --  ??? Note that since the partial view is pointing
+            --  to discriminants in the full view, their scope
+            --  will be that of the full view. This might
+            --  cause some front end problems and need
+            --  adustment?
+
+            Discr := First_Discriminant (Base_Type (Full_Der));
+            Set_First_Entity (Der_Base, Discr);
+
+            loop
+               Last_Discr := Discr;
+               Next_Discriminant (Discr);
+               exit when No (Discr);
+            end loop;
+
+            Set_Last_Entity (Der_Base, Last_Discr);
+
+            Set_First_Entity (Derived_Type, First_Entity (Der_Base));
+            Set_Last_Entity  (Derived_Type, Last_Entity  (Der_Base));
+
+         else
+            --  If this is a completion, the derived type stays private
+            --  and there is no need to create a further full view, except
+            --  in the unusual case when the derivation is nested within a
+            --  child unit, see below.
+
+            null;
+         end if;
+
+      elsif Present (Full_View (Parent_Type))
+        and then  Has_Discriminants (Full_View (Parent_Type))
+      then
+         if Has_Unknown_Discriminants (Parent_Type)
+           and then Nkind (Subtype_Indication (Type_Definition (N)))
+             = N_Subtype_Indication
+         then
+            Error_Msg_N
+              ("cannot constrain type with unknown discriminants",
+               Subtype_Indication (Type_Definition (N)));
+            return;
+         end if;
+
+         --  Inherit the discriminants of the full view, but
+         --  keep the proper parent type.
+
+         --  ??? this looks wrong, we are replacing (and thus,
+         --  erasing) the partial view!
+
+         --  In any case, the primitive operations are inherited from
+         --  the parent type, not from the internal full view.
+
+         Build_Derived_Record_Type
+           (N, Full_View (Parent_Type), Derived_Type,
+             Derive_Subps => False);
+         Set_Etype (Base_Type (Derived_Type), Base_Type (Parent_Type));
+
+         if Derive_Subps then
+            Derive_Subprograms (Parent_Type, Derived_Type);
+         end if;
+
+      else
+
+         --  Untagged type, No discriminants on either view.
+
+         if Nkind (Subtype_Indication (Type_Definition (N)))
+           = N_Subtype_Indication
+         then
+            Error_Msg_N
+              ("illegal constraint on type without discriminants", N);
+         end if;
+
+         if Present (Discriminant_Specifications (N))
+           and then Present (Full_View (Parent_Type))
+           and then not Is_Tagged_Type (Full_View (Parent_Type))
+         then
+            Error_Msg_N
+              ("cannot add discriminants to untagged type", N);
+         end if;
+
+         Set_Girder_Constraint (Derived_Type, No_Elist);
+         Set_Is_Constrained (Derived_Type, Is_Constrained (Parent_Type));
+         Set_Is_Controlled  (Derived_Type, Is_Controlled  (Parent_Type));
+         Set_Has_Controlled_Component (Derived_Type,
+           Has_Controlled_Component (Parent_Type));
+
+         --  Direct controlled types do not inherit the Finalize_Storage_Only
+         --  flag.
+
+         if not Is_Controlled  (Parent_Type) then
+            Set_Finalize_Storage_Only (Derived_Type,
+              Finalize_Storage_Only (Parent_Type));
+         end if;
+
+         --  Construct the implicit full view by deriving from full
+         --  view of the parent type. In order to get proper visiblity,
+         --  we install the parent scope and its declarations.
+
+         --  ??? if the parent is untagged private and its
+         --  completion is tagged, this mechanism will not
+         --  work because we cannot derive from the tagged
+         --  full view unless we have an extension
+
+         if Present (Full_View (Parent_Type))
+           and then not Is_Tagged_Type (Full_View (Parent_Type))
+           and then not Is_Completion
+         then
+            Full_Der := Make_Defining_Identifier (Sloc (Derived_Type),
+                                              Chars (Derived_Type));
+            Set_Is_Itype (Full_Der);
+            Set_Has_Private_Declaration (Full_Der);
+            Set_Has_Private_Declaration (Derived_Type);
+            Set_Associated_Node_For_Itype (Full_Der, N);
+            Set_Parent (Full_Der, Parent (Derived_Type));
+            Set_Full_View (Derived_Type, Full_Der);
+
+            if not In_Open_Scopes (Par_Scope) then
+               Install_Private_Declarations (Par_Scope);
+               Install_Visible_Declarations (Par_Scope);
+               Copy_And_Build;
+               Uninstall_Declarations (Par_Scope);
+
+            --  If parent scope is open and in another unit, and
+            --  parent has a completion, then the derivation is taking
+            --  place in the visible part of a child unit. In that
+            --  case retrieve the full view of the parent momentarily.
+
+            elsif not In_Same_Source_Unit (N, Parent_Type) then
+               Full_P := Full_View (Parent_Type);
+               Exchange_Declarations (Parent_Type);
+               Copy_And_Build;
+               Exchange_Declarations (Full_P);
+
+            --  Otherwise it is a local derivation.
+
+            else
+               Copy_And_Build;
+            end if;
+
+            Set_Scope                (Full_Der, Current_Scope);
+            Set_Is_First_Subtype     (Full_Der,
+                                       Is_First_Subtype (Derived_Type));
+            Set_Has_Size_Clause      (Full_Der, False);
+            Set_Has_Alignment_Clause (Full_Der, False);
+            Set_Next_Entity          (Full_Der, Empty);
+            Set_Has_Delayed_Freeze   (Full_Der);
+            Set_Is_Frozen            (Full_Der, False);
+            Set_Freeze_Node          (Full_Der, Empty);
+            Set_Depends_On_Private   (Full_Der,
+                                        Has_Private_Component    (Full_Der));
+         end if;
+      end if;
+
+      Set_Has_Unknown_Discriminants (Derived_Type,
+        Has_Unknown_Discriminants (Parent_Type));
+
+      if Is_Private_Type (Derived_Type) then
+         Set_Private_Dependents (Derived_Type, New_Elmt_List);
+      end if;
+
+      if Is_Private_Type (Parent_Type)
+        and then Base_Type (Parent_Type) = Parent_Type
+        and then In_Open_Scopes (Scope (Parent_Type))
+      then
+         Append_Elmt (Derived_Type, Private_Dependents (Parent_Type));
+
+         if Is_Child_Unit (Scope (Current_Scope))
+           and then Is_Completion
+           and then In_Private_Part (Current_Scope)
+         then
+            --  This is the unusual case where a type completed by a private
+            --  derivation occurs within a package nested in a child unit,
+            --  and the parent is declared in an ancestor. In this case, the
+            --  full view of the parent type will become visible in the body
+            --  of the enclosing child, and only then will the current type
+            --  be possibly non-private. We build a underlying full view that
+            --  will be installed when the enclosing child body is compiled.
+
+            declare
+               IR : constant Node_Id := Make_Itype_Reference (Sloc (N));
+
+            begin
+               Full_Der :=
+                 Make_Defining_Identifier (Sloc (Derived_Type),
+                   Chars (Derived_Type));
+               Set_Is_Itype (Full_Der);
+               Set_Itype (IR, Full_Der);
+               Insert_After (N, IR);
+
+               --  The full view will be used to swap entities on entry/exit
+               --  to the body, and must appear in the entity list for the
+               --  package.
+
+               Append_Entity (Full_Der, Scope (Derived_Type));
+               Set_Has_Private_Declaration (Full_Der);
+               Set_Has_Private_Declaration (Derived_Type);
+               Set_Associated_Node_For_Itype (Full_Der, N);
+               Set_Parent (Full_Der, Parent (Derived_Type));
+               Full_P := Full_View (Parent_Type);
+               Exchange_Declarations (Parent_Type);
+               Copy_And_Build;
+               Exchange_Declarations (Full_P);
+               Set_Underlying_Full_View (Derived_Type, Full_Der);
+            end;
+         end if;
+      end if;
+   end Build_Derived_Private_Type;
+
+   -------------------------------
+   -- Build_Derived_Record_Type --
+   -------------------------------
+
+   --  1. INTRODUCTION.
+
+   --  Ideally we would like to use the same model of type derivation for
+   --  tagged and untagged record types. Unfortunately this is not quite
+   --  possible because the semantics of representation clauses is different
+   --  for tagged and untagged records under inheritance. Consider the
+   --  following:
+
+   --     type R (...) is [tagged] record ... end record;
+   --     type T (...) is new R (...) [with ...];
+
+   --  The representation clauses of T can specify a completely different
+   --  record layout from R's. Hence a same component can be placed in two very
+   --  different positions in objects of type T and R. If R and T are tagged
+   --  types, representation clauses for T can only specify the layout of non
+   --  inherited components, thus components that are common in R and T have
+   --  the same position in objects of type R or T.
+
+   --  This has two implications. The first is that the entire tree for R's
+   --  declaration needs to be copied for T in the untagged case, so that
+   --  T can be viewd as a record type of its own with its own derivation
+   --  clauses. The second implication is the way we handle discriminants.
+   --  Specifically, in the untagged case we need a way to communicate to Gigi
+   --  what are the real discriminants in the record, while for the semantics
+   --  we need to consider those introduced by the user to rename the
+   --  discriminants in the parent type. This is handled by introducing the
+   --  notion of girder discriminants. See below for more.
+
+   --  Fortunately the way regular components are inherited can be handled in
+   --  the same way in tagged and untagged types.
+
+   --  To complicate things a bit more the private view of a private extension
+   --  cannot be handled in the same way as the full view (for one thing the
+   --  semantic rules are somewhat different). We will explain what differs
+   --  below.
+
+   --  2. DISCRIMINANTS UNDER INHERITANCE.
+
+   --  The semantic rules governing the discriminants of derived types are
+   --  quite subtle.
+
+   --   type Derived_Type_Name [KNOWN_DISCRIMINANT_PART] is new
+   --      [abstract]  Parent_Type_Name [CONSTRAINT] [RECORD_EXTENSION_PART]
+
+   --  If parent type has discriminants, then the discriminants that are
+   --  declared in the derived type are [3.4 (11)]:
+
+   --  o The discriminants specified by a new KNOWN_DISCRIMINANT_PART, if
+   --    there is one;
+
+   --  o Otherwise, each discriminant of the parent type (implicitely
+   --    declared in the same order with the same specifications). In this
+   --    case, the discriminants are said to be "inherited", or if unknown in
+   --    the parent are also unknown in the derived type.
+
+   --  Furthermore if a KNOWN_DISCRIMINANT_PART is provided, then [3.7(13-18)]:
+
+   --  o The parent subtype shall be constrained;
+
+   --  o If the parent type is not a tagged type, then each discriminant of
+   --    the derived type shall be used in the constraint defining a parent
+   --    subtype [Implementation note: this ensures that the new discriminant
+   --    can share storage with an existing discriminant.].
+
+   --  For the derived type each discriminant of the parent type is either
+   --  inherited, constrained to equal some new discriminant of the derived
+   --  type, or constrained to the value of an expression.
+
+   --  When inherited or constrained to equal some new discriminant, the
+   --  parent discriminant and the discriminant of the derived type are said
+   --  to "correspond".
+
+   --  If a discriminant of the parent type is constrained to a specific value
+   --  in the derived type definition, then the discriminant is said to be
+   --  "specified" by that derived type definition.
+
+   --  3. DISCRIMINANTS IN DERIVED UNTAGGED RECORD TYPES.
+
+   --  We have spoken about girder discriminants in the point 1 (introduction)
+   --  above. There are two sort of girder discriminants: implicit and
+   --  explicit. As long as the derived type inherits the same discriminants as
+   --  the root record type, girder discriminants are the same as regular
+   --  discriminants, and are said to be implicit. However, if any discriminant
+   --  in the root type was renamed in the derived type, then the derived
+   --  type will contain explicit girder discriminants. Explicit girder
+   --  discriminants are discriminants in addition to the semantically visible
+   --  discriminants defined for the derived type. Girder discriminants are
+   --  used by Gigi to figure out what are the physical discriminants in
+   --  objects of the derived type (see precise definition in einfo.ads).
+   --  As an example, consider the following:
+
+   --           type R  (D1, D2, D3 : Int) is record ... end record;
+   --           type T1 is new R;
+   --           type T2 (X1, X2: Int) is new T1 (X2, 88, X1);
+   --           type T3 is new T2;
+   --           type T4 (Y : Int) is new T3 (Y, 99);
+
+   --  The following table summarizes the discriminants and girder
+   --  discriminants in R and T1 through T4.
+
+   --   Type      Discrim     Girder Discrim  Comment
+   --    R      (D1, D2, D3)   (D1, D2, D3)   Gider discrims are implicit in R
+   --    T1     (D1, D2, D3)   (D1, D2, D3)   Gider discrims are implicit in T1
+   --    T2     (X1, X2)       (D1, D2, D3)   Gider discrims are EXPLICIT in T2
+   --    T3     (X1, X2)       (D1, D2, D3)   Gider discrims are EXPLICIT in T3
+   --    T4     (Y)            (D1, D2, D3)   Gider discrims are EXPLICIT in T4
+
+   --  Field Corresponding_Discriminant (abbreviated CD below) allows to find
+   --  the corresponding discriminant in the parent type, while
+   --  Original_Record_Component (abbreviated ORC below), the actual physical
+   --  component that is renamed. Finally the field Is_Completely_Hidden
+   --  (abbreaviated ICH below) is set for all explicit girder discriminants
+   --  (see einfo.ads for more info). For the above example this gives:
+
+   --                 Discrim     CD        ORC     ICH
+   --                 ^^^^^^^     ^^        ^^^     ^^^
+   --                 D1 in R    empty     itself    no
+   --                 D2 in R    empty     itself    no
+   --                 D3 in R    empty     itself    no
+
+   --                 D1 in T1  D1 in R    itself    no
+   --                 D2 in T1  D2 in R    itself    no
+   --                 D3 in T1  D3 in R    itself    no
+
+   --                 X1 in T2  D3 in T1  D3 in T2   no
+   --                 X2 in T2  D1 in T1  D1 in T2   no
+   --                 D1 in T2   empty    itself    yes
+   --                 D2 in T2   empty    itself    yes
+   --                 D3 in T2   empty    itself    yes
+
+   --                 X1 in T3  X1 in T2  D3 in T3   no
+   --                 X2 in T3  X2 in T2  D1 in T3   no
+   --                 D1 in T3   empty    itself    yes
+   --                 D2 in T3   empty    itself    yes
+   --                 D3 in T3   empty    itself    yes
+
+   --                 Y  in T4  X1 in T3  D3 in T3   no
+   --                 D1 in T3   empty    itself    yes
+   --                 D2 in T3   empty    itself    yes
+   --                 D3 in T3   empty    itself    yes
+
+   --  4. DISCRIMINANTS IN DERIVED TAGGED RECORD TYPES.
+
+   --  Type derivation for tagged types is fairly straightforward. if no
+   --  discriminants are specified by the derived type, these are inherited
+   --  from the parent. No explicit girder discriminants are ever necessary.
+   --  The only manipulation that is done to the tree is that of adding a
+   --  _parent field with parent type and constrained to the same constraint
+   --  specified for the parent in the derived type definition. For instance:
+
+   --           type R  (D1, D2, D3 : Int) is tagged record ... end record;
+   --           type T1 is new R with null record;
+   --           type T2 (X1, X2: Int) is new T1 (X2, 88, X1) with null record;
+
+   --  are changed into :
+
+   --           type T1 (D1, D2, D3 : Int) is new R (D1, D2, D3) with record
+   --              _parent : R (D1, D2, D3);
+   --           end record;
+
+   --           type T2 (X1, X2: Int) is new T1 (X2, 88, X1) with record
+   --              _parent : T1 (X2, 88, X1);
+   --           end record;
+
+   --  The discriminants actually present in R, T1 and T2 as well as their CD,
+   --  ORC and ICH fields are:
+
+   --                 Discrim     CD        ORC     ICH
+   --                 ^^^^^^^     ^^        ^^^     ^^^
+   --                 D1 in R    empty     itself    no
+   --                 D2 in R    empty     itself    no
+   --                 D3 in R    empty     itself    no
+
+   --                 D1 in T1  D1 in R    D1 in R   no
+   --                 D2 in T1  D2 in R    D2 in R   no
+   --                 D3 in T1  D3 in R    D3 in R   no
+
+   --                 X1 in T2  D3 in T1   D3 in R   no
+   --                 X2 in T2  D1 in T1   D1 in R   no
+
+   --  5. FIRST TRANSFORMATION FOR DERIVED RECORDS.
+   --
+   --  Regardless of whether we dealing with a tagged or untagged type
+   --  we will transform all derived type declarations of the form
+   --
+   --               type T is new R (...) [with ...];
+   --  or
+   --               subtype S is R (...);
+   --               type T is new S [with ...];
+   --  into
+   --               type BT is new R [with ...];
+   --               subtype T is BT (...);
+   --
+   --  That is, the base derived type is constrained only if it has no
+   --  discriminants. The reason for doing this is that GNAT's semantic model
+   --  assumes that a base type with discriminants is unconstrained.
+   --
+   --  Note that, strictly speaking, the above transformation is not always
+   --  correct. Consider for instance the following exercpt from ACVC b34011a:
+   --
+   --       procedure B34011A is
+   --          type REC (D : integer := 0) is record
+   --             I : Integer;
+   --          end record;
+
+   --          package P is
+   --             type T6 is new Rec;
+   --             function F return T6;
+   --          end P;
+
+   --          use P;
+   --          package Q6 is
+   --             type U is new T6 (Q6.F.I);                   -- ERROR: Q6.F.
+   --          end Q6;
+   --
+   --  The definition of Q6.U is illegal. However transforming Q6.U into
+
+   --             type BaseU is new T6;
+   --             subtype U is BaseU (Q6.F.I)
+
+   --  turns U into a legal subtype, which is incorrect. To avoid this problem
+   --  we always analyze the constraint (in this case (Q6.F.I)) before applying
+   --  the transformation described above.
+
+   --  There is another instance where the above transformation is incorrect.
+   --  Consider:
+
+   --          package Pack is
+   --             type Base (D : Integer) is tagged null record;
+   --             procedure P (X : Base);
+
+   --             type Der is new Base (2) with null record;
+   --             procedure P (X : Der);
+   --          end Pack;
+
+   --  Then the above transformation turns this into
+
+   --             type Der_Base is new Base with null record;
+   --             --  procedure P (X : Base) is implicitely inherited here
+   --             --  as procedure P (X : Der_Base).
+
+   --             subtype Der is Der_Base (2);
+   --             procedure P (X : Der);
+   --             --  The overriding of P (X : Der_Base) is illegal since we
+   --             --  have a parameter conformance problem.
+
+   --  To get around this problem, after having semantically processed Der_Base
+   --  and the rewritten subtype declaration for Der, we copy Der_Base field
+   --  Discriminant_Constraint from Der so that when parameter conformance is
+   --  checked when P is overridden, no sematic errors are flagged.
+
+   --  6. SECOND TRANSFORMATION FOR DERIVED RECORDS.
+
+   --  Regardless of the fact that we dealing with a tagged or untagged type
+   --  we will transform all derived type declarations of the form
+
+   --               type R (D1, .., Dn : ...) is [tagged] record ...;
+   --               type T is new R [with ...];
+   --  into
+   --               type T (D1, .., Dn : ...) is new R (D1, .., Dn) [with ...];
+
+   --  The reason for such transformation is that it allows us to implement a
+   --  very clean form of component inheritance as explained below.
+
+   --  Note that this transformation is not achieved by direct tree rewriting
+   --  and manipulation, but rather by redoing the semantic actions that the
+   --  above transformation will entail. This is done directly in routine
+   --  Inherit_Components.
+
+   --  7. TYPE DERIVATION AND COMPONENT INHERITANCE.
+
+   --  In both tagged and untagged derived types, regular non discriminant
+   --  components are inherited in the derived type from the parent type. In
+   --  the absence of discriminants component, inheritance is straightforward
+   --  as components can simply be copied from the parent.
+   --  If the parent has discriminants, inheriting components constrained with
+   --  these discriminants requires caution. Consider the following example:
+
+   --      type R  (D1, D2 : Positive) is [tagged] record
+   --         S : String (D1 .. D2);
+   --      end record;
+
+   --      type T1                is new R        [with null record];
+   --      type T2 (X : positive) is new R (1, X) [with null record];
+
+   --  As explained in 6. above, T1 is rewritten as
+
+   --      type T1 (D1, D2 : Positive) is new R (D1, D2) [with null record];
+
+   --  which makes the treatment for T1 and T2 identical.
+
+   --  What we want when inheriting S, is that references to D1 and D2 in R are
+   --  replaced with references to their correct constraints, ie D1 and D2 in
+   --  T1 and 1 and X in T2. So all R's discriminant references are replaced
+   --  with either discriminant references in the derived type or expressions.
+   --  This replacement is acheived as follows: before inheriting R's
+   --  components, a subtype R (D1, D2) for T1 (resp. R (1, X) for T2) is
+   --  created in the scope of T1 (resp. scope of T2) so that discriminants D1
+   --  and D2 of T1 are visible (resp. discriminant X of T2 is visible).
+   --  For T2, for instance, this has the effect of replacing String (D1 .. D2)
+   --  by String (1 .. X).
+
+   --  8. TYPE DERIVATION IN PRIVATE TYPE EXTENSIONS.
+
+   --  We explain here the rules governing private type extensions relevant to
+   --  type derivation. These rules are explained on the following example:
+
+   --      type D [(...)] is new A [(...)] with private;      <-- partial view
+   --      type D [(...)] is new P [(...)] with null record;  <-- full view
+
+   --  Type A is called the ancestor subtype of the private extension.
+   --  Type P is the parent type of the full view of the private extension. It
+   --  must be A or a type derived from A.
+
+   --  The rules concerning the discriminants of private type extensions are
+   --  [7.3(10-13)]:
+
+   --  o If a private extension inherits known discriminants from the ancestor
+   --    subtype, then the full view shall also inherit its discriminants from
+   --    the ancestor subtype and the parent subtype of the full view shall be
+   --    constrained if and only if the ancestor subtype is constrained.
+
+   --  o If a partial view has unknown discriminants, then the full view may
+   --    define a definite or an indefinite subtype, with or without
+   --    discriminants.
+
+   --  o If a partial view has neither known nor unknown discriminants, then
+   --    the full view shall define a definite subtype.
+
+   --  o If the ancestor subtype of a private extension has constrained
+   --    discrimiants, then the parent subtype of the full view shall impose a
+   --    statically matching constraint on those discriminants.
+
+   --  This means that only the following forms of private extensions are
+   --  allowed:
+
+   --      type D is new A with private;      <-- partial view
+   --      type D is new P with null record;  <-- full view
+
+   --  If A has no discriminants than P has no discriminants, otherwise P must
+   --  inherit A's discriminants.
+
+   --      type D is new A (...) with private;      <-- partial view
+   --      type D is new P (:::) with null record;  <-- full view
+
+   --  P must inherit A's discriminants and (...) and (:::) must statically
+   --  match.
+
+   --      subtype A is R (...);
+   --      type D is new A with private;      <-- partial view
+   --      type D is new P with null record;  <-- full view
+
+   --  P must have inherited R's discriminants and must be derived from A or
+   --  any of its subtypes.
+
+   --      type D (..) is new A with private;              <-- partial view
+   --      type D (..) is new P [(:::)] with null record;  <-- full view
+
+   --  No specific constraints on P's discriminants or constraint (:::).
+   --  Note that A can be unconstrained, but the parent subtype P must either
+   --  be constrained or (:::) must be present.
+
+   --      type D (..) is new A [(...)] with private;      <-- partial view
+   --      type D (..) is new P [(:::)] with null record;  <-- full view
+
+   --  P's constraints on A's discriminants must statically match those
+   --  imposed by (...).
+
+   --  9. IMPLEMENTATION OF TYPE DERIVATION FOR PRIVATE EXTENSIONS.
+
+   --  The full view of a private extension is handled exactly as described
+   --  above. The model chose for the private view of a private extension
+   --  is the same for what concerns discriminants (ie they receive the same
+   --  treatment as in the tagged case). However, the private view of the
+   --  private extension always inherits the components of the parent base,
+   --  without replacing any discriminant reference. Strictly speacking this
+   --  is incorrect. However, Gigi never uses this view to generate code so
+   --  this is a purely semantic issue. In theory, a set of transformations
+   --  similar to those given in 5. and 6. above could be applied to private
+   --  views of private extensions to have the same model of component
+   --  inheritance as for non private extensions. However, this is not done
+   --  because it would further complicate private type processing.
+   --  Semantically speaking, this leaves us in an uncomfortable
+   --  situation. As an example consider:
+
+   --          package Pack is
+   --             type R (D : integer) is tagged record
+   --                S : String (1 .. D);
+   --             end record;
+   --             procedure P (X : R);
+   --             type T is new R (1) with private;
+   --          private
+   --             type T is new R (1) with null record;
+   --          end;
+
+   --  This is transformed into:
+
+   --          package Pack is
+   --             type R (D : integer) is tagged record
+   --                S : String (1 .. D);
+   --             end record;
+   --             procedure P (X : R);
+   --             type T is new R (1) with private;
+   --          private
+   --             type BaseT is new R with null record;
+   --             subtype  T is BaseT (1);
+   --          end;
+
+   --  (strictly speaking the above is incorrect Ada).
+
+   --  From the semantic standpoint the private view of private extension T
+   --  should be flagged as constrained since one can clearly have
+   --
+   --             Obj : T;
+   --
+   --  in a unit withing Pack. However, when deriving subprograms for the
+   --  private view of private extension T, T must be seen as unconstrained
+   --  since T has discriminants (this is a constraint of the current
+   --  subprogram derivation model). Thus, when processing the private view of
+   --  a private extension such as T, we first mark T as unconstrained, we
+   --  process it, we perform program derivation and just before returning from
+   --  Build_Derived_Record_Type we mark T as constrained.
+   --  ??? Are there are other unconfortable cases that we will have to
+   --      deal with.
+
+   --  10. RECORD_TYPE_WITH_PRIVATE complications.
+
+   --  Types that are derived from a visible record type and have a private
+   --  extension present other peculiarities. They behave mostly like private
+   --  types, but if they have primitive operations defined, these will not
+   --  have the proper signatures for further inheritance, because other
+   --  primitive operations will use the implicit base that we define for
+   --  private derivations below. This affect subprogram inheritance (see
+   --  Derive_Subprograms for details). We also derive the implicit base from
+   --  the base type of the full view, so that the implicit base is a record
+   --  type and not another private type, This avoids infinite loops.
+
+   procedure Build_Derived_Record_Type
+     (N            : Node_Id;
+      Parent_Type  : Entity_Id;
+      Derived_Type : Entity_Id;
+      Derive_Subps : Boolean := True)
+   is
+      Loc          : constant Source_Ptr := Sloc (N);
+      Parent_Base  : Entity_Id;
+
+      Type_Def     : Node_Id;
+      Indic        : Node_Id;
+
+      Discrim      : Entity_Id;
+      Last_Discrim : Entity_Id;
+      Constrs      : Elist_Id;
+      Discs        : Elist_Id := New_Elmt_List;
+      --  An empty Discs list means that there were no constraints in the
+      --  subtype indication or that there was an error processing it.
+
+      Assoc_List   : Elist_Id;
+      New_Discrs   : Elist_Id;
+
+      New_Base     : Entity_Id;
+      New_Decl     : Node_Id;
+      New_Indic    : Node_Id;
+
+      Is_Tagged          : constant Boolean := Is_Tagged_Type (Parent_Type);
+      Discriminant_Specs : constant Boolean
+        := Present (Discriminant_Specifications (N));
+      Private_Extension  : constant Boolean
+        := (Nkind (N) = N_Private_Extension_Declaration);
+
+      Constraint_Present : Boolean;
+      Inherit_Discrims   : Boolean := False;
+
+      Save_Etype         : Entity_Id;
+      Save_Discr_Constr  : Elist_Id;
+      Save_Next_Entity   : Entity_Id;
+
+   begin
+      if Ekind (Parent_Type) = E_Record_Type_With_Private
+        and then Present (Full_View (Parent_Type))
+        and then Has_Discriminants (Parent_Type)
+      then
+         Parent_Base := Base_Type (Full_View (Parent_Type));
+      else
+         Parent_Base := Base_Type (Parent_Type);
+      end if;
+
+      --  Before we start the previously documented transformations, here is
+      --  a little fix for size and alignment of tagged types. Normally when
+      --  we derive type D from type P, we copy the size and alignment of P
+      --  as the default for D, and in the absence of explicit representation
+      --  clauses for D, the size and alignment are indeed the same as the
+      --  parent.
+
+      --  But this is wrong for tagged types, since fields may be added,
+      --  and the default size may need to be larger, and the default
+      --  alignment may need to be larger.
+
+      --  We therefore reset the size and alignment fields in the tagged
+      --  case. Note that the size and alignment will in any case be at
+      --  least as large as the parent type (since the derived type has
+      --  a copy of the parent type in the _parent field)
+
+      if Is_Tagged then
+         Init_Size_Align (Derived_Type);
+      end if;
+
+      --  STEP 0a: figure out what kind of derived type declaration we have.
+
+      if Private_Extension then
+         Type_Def := N;
+         Set_Ekind (Derived_Type, E_Record_Type_With_Private);
+
+      else
+         Type_Def := Type_Definition (N);
+
+         --  Ekind (Parent_Base) in not necessarily E_Record_Type since
+         --  Parent_Base can be a private type or private extension. However,
+         --  for tagged types with an extension the newly added fields are
+         --  visible and hence the Derived_Type is always an E_Record_Type.
+         --  (except that the parent may have its own private fields).
+         --  For untagged types we preserve the Ekind of the Parent_Base.
+
+         if Present (Record_Extension_Part (Type_Def)) then
+            Set_Ekind (Derived_Type, E_Record_Type);
+         else
+            Set_Ekind (Derived_Type, Ekind (Parent_Base));
+         end if;
+      end if;
+
+      --  Indic can either be an N_Identifier if the subtype indication
+      --  contains no constraint or an N_Subtype_Indication if the subtype
+      --  indication has a constraint.
+
+      Indic := Subtype_Indication (Type_Def);
+      Constraint_Present := (Nkind (Indic) = N_Subtype_Indication);
+
+      if Constraint_Present then
+         if not Has_Discriminants (Parent_Base) then
+            Error_Msg_N
+              ("invalid constraint: type has no discriminant",
+                 Constraint (Indic));
+
+            Constraint_Present := False;
+            Rewrite (Indic, New_Copy_Tree (Subtype_Mark (Indic)));
+
+         elsif Is_Constrained (Parent_Type) then
+            Error_Msg_N
+               ("invalid constraint: parent type is already constrained",
+                  Constraint (Indic));
+
+            Constraint_Present := False;
+            Rewrite (Indic, New_Copy_Tree (Subtype_Mark (Indic)));
+         end if;
+      end if;
+
+      --  STEP 0b: If needed, apply transformation given in point 5. above.
+
+      if not Private_Extension
+        and then Has_Discriminants (Parent_Type)
+        and then not Discriminant_Specs
+        and then (Is_Constrained (Parent_Type) or else Constraint_Present)
+      then
+         --  First, we must analyze the constraint (see comment in point 5.).
+
+         if Constraint_Present then
+            New_Discrs := Build_Discriminant_Constraints (Parent_Type, Indic);
+
+            if Has_Discriminants (Derived_Type)
+              and then Has_Private_Declaration (Derived_Type)
+              and then Present (Discriminant_Constraint (Derived_Type))
+            then
+               --  Verify that constraints of the full view conform to those
+               --  given in partial view.
+
+               declare
+                  C1, C2 : Elmt_Id;
+
+               begin
+                  C1 := First_Elmt (New_Discrs);
+                  C2 := First_Elmt (Discriminant_Constraint (Derived_Type));
+
+                  while Present (C1) and then Present (C2) loop
+                     if not
+                       Fully_Conformant_Expressions (Node (C1), Node (C2))
+                     then
+                        Error_Msg_N (
+                          "constraint not conformant to previous declaration",
+                             Node (C1));
+                     end if;
+                     Next_Elmt (C1);
+                     Next_Elmt (C2);
+                  end loop;
+               end;
+            end if;
+         end if;
+
+         --  Insert and analyze the declaration for the unconstrained base type
+
+         New_Base := Create_Itype (Ekind (Derived_Type), N, Derived_Type, 'B');
+
+         New_Decl :=
+           Make_Full_Type_Declaration (Loc,
+              Defining_Identifier => New_Base,
+              Type_Definition     =>
+                Make_Derived_Type_Definition (Loc,
+                  Abstract_Present      => Abstract_Present (Type_Def),
+                  Subtype_Indication    =>
+                    New_Occurrence_Of (Parent_Base, Loc),
+                  Record_Extension_Part =>
+                    Relocate_Node (Record_Extension_Part (Type_Def))));
+
+         Set_Parent (New_Decl, Parent (N));
+         Mark_Rewrite_Insertion (New_Decl);
+         Insert_Before (N, New_Decl);
+
+         --  Note that this call passes False for the Derive_Subps
+         --  parameter because subprogram derivation is deferred until
+         --  after creating the subtype (see below).
+
+         Build_Derived_Type
+           (New_Decl, Parent_Base, New_Base,
+            Is_Completion => True, Derive_Subps => False);
+
+         --  ??? This needs re-examination to determine whether the
+         --  above call can simply be replaced by a call to Analyze.
+
+         Set_Analyzed (New_Decl);
+
+         --  Insert and analyze the declaration for the constrained subtype
+
+         if Constraint_Present then
+            New_Indic :=
+              Make_Subtype_Indication (Loc,
+                Subtype_Mark => New_Occurrence_Of (New_Base, Loc),
+                Constraint   => Relocate_Node (Constraint (Indic)));
+
+         else
+            declare
+               Expr        : Node_Id;
+               Constr_List : List_Id := New_List;
+               C           : Elmt_Id;
+
+            begin
+               C := First_Elmt (Discriminant_Constraint (Parent_Type));
+               while Present (C) loop
+                  Expr := Node (C);
+
+                  --  It is safe here to call New_Copy_Tree since
+                  --  Force_Evaluation was called on each constraint in
+                  --  Build_Discriminant_Constraints.
+
+                  Append (New_Copy_Tree (Expr), To => Constr_List);
+
+                  Next_Elmt (C);
+               end loop;
+
+               New_Indic :=
+                 Make_Subtype_Indication (Loc,
+                   Subtype_Mark => New_Occurrence_Of (New_Base, Loc),
+                   Constraint   =>
+                     Make_Index_Or_Discriminant_Constraint (Loc, Constr_List));
+            end;
+         end if;
+
+         Rewrite (N,
+           Make_Subtype_Declaration (Loc,
+             Defining_Identifier => Derived_Type,
+             Subtype_Indication  => New_Indic));
+
+         Analyze (N);
+
+         --  Derivation of subprograms must be delayed until the
+         --  full subtype has been established to ensure proper
+         --  overriding of subprograms inherited by full types.
+         --  If the derivations occurred as part of the call to
+         --  Build_Derived_Type above, then the check for type
+         --  conformance would fail because earlier primitive
+         --  subprograms could still refer to the full type prior
+         --  the change to the new subtype and hence wouldn't
+         --  match the new base type created here.
+
+         Derive_Subprograms (Parent_Type, Derived_Type);
+
+         --  For tagged types the Discriminant_Constraint of the new base itype
+         --  is inherited from the first subtype so that no subtype conformance
+         --  problem arise when the first subtype overrides primitive
+         --  operations inherited by the implicit base type.
+
+         if Is_Tagged then
+            Set_Discriminant_Constraint
+              (New_Base, Discriminant_Constraint (Derived_Type));
+         end if;
+
+         return;
+      end if;
+
+      --  If we get here Derived_Type will have no discriminants or it will be
+      --  a discriminated unconstrained base type.
+
+      --  STEP 1a: perform preliminary actions/checks for derived tagged types
+
+      if Is_Tagged then
+         --  The parent type is frozen for non-private extensions (RM 13.14(7))
+
+         if not Private_Extension then
+            Freeze_Before (N, Parent_Type);
+         end if;
+
+         if Type_Access_Level (Derived_Type) /= Type_Access_Level (Parent_Type)
+           and then not Is_Generic_Type (Derived_Type)
+         then
+            if Is_Controlled (Parent_Type) then
+               Error_Msg_N
+                 ("controlled type must be declared at the library level",
+                  Indic);
+            else
+               Error_Msg_N
+                 ("type extension at deeper accessibility level than parent",
+                  Indic);
+            end if;
+
+         else
+            declare
+               GB : constant Node_Id := Enclosing_Generic_Body (Derived_Type);
+
+            begin
+               if Present (GB)
+                 and then GB /= Enclosing_Generic_Body (Parent_Base)
+               then
+                  Error_Msg_N
+                    ("parent type must not be outside generic body",
+                     Indic);
+               end if;
+            end;
+         end if;
+      end if;
+
+      --  STEP 1b : preliminary cleanup of the full view of private types
+
+      --  If the type is already marked as having discriminants, then it's the
+      --  completion of a private type or private extension and we need to
+      --  retain the discriminants from the partial view if the current
+      --  declaration has Discriminant_Specifications so that we can verify
+      --  conformance. However, we must remove any existing components that
+      --  were inherited from the parent (and attached in Copy_Private_To_Full)
+      --  because the full type inherits all appropriate components anyway, and
+      --  we don't want the partial view's components interfering.
+
+      if Has_Discriminants (Derived_Type) and then Discriminant_Specs then
+         Discrim := First_Discriminant (Derived_Type);
+         loop
+            Last_Discrim := Discrim;
+            Next_Discriminant (Discrim);
+            exit when No (Discrim);
+         end loop;
+
+         Set_Last_Entity (Derived_Type, Last_Discrim);
+
+      --  In all other cases wipe out the list of inherited components (even
+      --  inherited discriminants), it will be properly rebuilt here.
+
+      else
+         Set_First_Entity (Derived_Type, Empty);
+         Set_Last_Entity  (Derived_Type, Empty);
+      end if;
+
+      --  STEP 1c: Initialize some flags for the Derived_Type
+
+      --  The following flags must be initialized here so that
+      --  Process_Discriminants can check that discriminants of tagged types
+      --  do not have a default initial value and that access discriminants
+      --  are only specified for limited records. For completeness, these
+      --  flags are also initialized along with all the other flags below.
+
+      Set_Is_Tagged_Type    (Derived_Type, Is_Tagged);
+      Set_Is_Limited_Record (Derived_Type, Is_Limited_Record (Parent_Type));
+
+      --  STEP 2a: process discriminants of derived type if any.
+
+      New_Scope (Derived_Type);
+
+      if Discriminant_Specs then
+         Set_Has_Unknown_Discriminants (Derived_Type, False);
+
+         --  The following call initializes fields Has_Discriminants and
+         --  Discriminant_Constraint, unless we are processing the completion
+         --  of a private type declaration.
+
+         Check_Or_Process_Discriminants (N, Derived_Type);
+
+         --  For non-tagged types the constraint on the Parent_Type must be
+         --  present and is used to rename the discriminants.
+
+         if not Is_Tagged and then not Has_Discriminants (Parent_Type) then
+            Error_Msg_N ("untagged parent must have discriminants", Indic);
+
+         elsif not Is_Tagged and then not Constraint_Present then
+            Error_Msg_N
+              ("discriminant constraint needed for derived untagged records",
+               Indic);
+
+         --  Otherwise the parent subtype must be constrained unless we have a
+         --  private extension.
+
+         elsif not Constraint_Present
+           and then not Private_Extension
+           and then not Is_Constrained (Parent_Type)
+         then
+            Error_Msg_N
+              ("unconstrained type not allowed in this context", Indic);
+
+         elsif Constraint_Present then
+            --  The following call sets the field Corresponding_Discriminant
+            --  for the discriminants in the Derived_Type.
+
+            Discs := Build_Discriminant_Constraints (Parent_Type, Indic, True);
+
+            --  For untagged types all new discriminants must rename
+            --  discriminants in the parent. For private extensions new
+            --  discriminants cannot rename old ones (implied by [7.3(13)]).
+
+            Discrim := First_Discriminant (Derived_Type);
+
+            while Present (Discrim) loop
+               if not Is_Tagged
+                 and then not Present (Corresponding_Discriminant (Discrim))
+               then
+                  Error_Msg_N
+                    ("new discriminants must constrain old ones", Discrim);
+
+               elsif Private_Extension
+                 and then Present (Corresponding_Discriminant (Discrim))
+               then
+                  Error_Msg_N
+                    ("Only static constraints allowed for parent"
+                     & " discriminants in the partial view", Indic);
+
+                  exit;
+               end if;
+
+               --  If a new discriminant is used in the constraint,
+               --  then its subtype must be statically compatible
+               --  with the parent discriminant's subtype (3.7(15)).
+
+               if Present (Corresponding_Discriminant (Discrim))
+                 and then
+                   not Subtypes_Statically_Compatible
+                         (Etype (Discrim),
+                          Etype (Corresponding_Discriminant (Discrim)))
+               then
+                  Error_Msg_N
+                    ("subtype must be compatible with parent discriminant",
+                     Discrim);
+               end if;
+
+               Next_Discriminant (Discrim);
+            end loop;
+         end if;
+
+      --  STEP 2b: No new discriminants, inherit discriminants if any
+
+      else
+         if Private_Extension then
+            Set_Has_Unknown_Discriminants
+              (Derived_Type, Has_Unknown_Discriminants (Parent_Type)
+                             or else Unknown_Discriminants_Present (N));
+         else
+            Set_Has_Unknown_Discriminants
+              (Derived_Type, Has_Unknown_Discriminants (Parent_Type));
+         end if;
+
+         if not Has_Unknown_Discriminants (Derived_Type)
+           and then Has_Discriminants (Parent_Type)
+         then
+            Inherit_Discrims := True;
+            Set_Has_Discriminants
+              (Derived_Type, True);
+            Set_Discriminant_Constraint
+              (Derived_Type, Discriminant_Constraint (Parent_Base));
+         end if;
+
+         --  The following test is true for private types (remember
+         --  transformation 5. is not applied to those) and in an error
+         --  situation.
+
+         if Constraint_Present then
+            Discs := Build_Discriminant_Constraints (Parent_Type, Indic);
+         end if;
+
+         --  For now mark a new derived type as cosntrained only if it has no
+         --  discriminants. At the end of Build_Derived_Record_Type we properly
+         --  set this flag in the case of private extensions. See comments in
+         --  point 9. just before body of Build_Derived_Record_Type.
+
+         Set_Is_Constrained
+           (Derived_Type,
+            not (Inherit_Discrims
+                 or else Has_Unknown_Discriminants (Derived_Type)));
+      end if;
+
+      --  STEP 3: initialize fields of derived type.
+
+      Set_Is_Tagged_Type    (Derived_Type, Is_Tagged);
+      Set_Girder_Constraint (Derived_Type, No_Elist);
+
+      --  Fields inherited from the Parent_Type
+
+      Set_Discard_Names
+        (Derived_Type, Einfo.Discard_Names      (Parent_Type));
+      Set_Has_Specified_Layout
+        (Derived_Type, Has_Specified_Layout     (Parent_Type));
+      Set_Is_Limited_Composite
+        (Derived_Type, Is_Limited_Composite     (Parent_Type));
+      Set_Is_Limited_Record
+        (Derived_Type, Is_Limited_Record        (Parent_Type));
+      Set_Is_Private_Composite
+        (Derived_Type, Is_Private_Composite     (Parent_Type));
+
+      --  Fields inherited from the Parent_Base
+
+      Set_Has_Controlled_Component
+        (Derived_Type, Has_Controlled_Component (Parent_Base));
+      Set_Has_Non_Standard_Rep
+        (Derived_Type, Has_Non_Standard_Rep     (Parent_Base));
+      Set_Has_Primitive_Operations
+        (Derived_Type, Has_Primitive_Operations (Parent_Base));
+
+      --  Direct controlled types do not inherit the Finalize_Storage_Only
+      --  flag.
+
+      if not Is_Controlled  (Parent_Type) then
+         Set_Finalize_Storage_Only (Derived_Type,
+           Finalize_Storage_Only (Parent_Type));
+      end if;
+
+      --  Set fields for private derived types.
+
+      if Is_Private_Type (Derived_Type) then
+         Set_Depends_On_Private (Derived_Type, True);
+         Set_Private_Dependents (Derived_Type, New_Elmt_List);
+
+      --  Inherit fields from non private record types. If this is the
+      --  completion of a derivation from a private type, the parent itself
+      --  is private, and the attributes come from its full view, which must
+      --  be present.
+
+      else
+         if Is_Private_Type (Parent_Base)
+           and then not Is_Record_Type (Parent_Base)
+         then
+            Set_Component_Alignment
+              (Derived_Type, Component_Alignment (Full_View (Parent_Base)));
+            Set_C_Pass_By_Copy
+              (Derived_Type, C_Pass_By_Copy      (Full_View (Parent_Base)));
+         else
+            Set_Component_Alignment
+              (Derived_Type, Component_Alignment (Parent_Base));
+
+            Set_C_Pass_By_Copy
+              (Derived_Type, C_Pass_By_Copy      (Parent_Base));
+         end if;
+      end if;
+
+      --  Set fields for tagged types.
+
+      if Is_Tagged then
+         Set_Primitive_Operations (Derived_Type, New_Elmt_List);
+
+         --  All tagged types defined in Ada.Finalization are controlled
+
+         if Chars (Scope (Derived_Type)) = Name_Finalization
+           and then Chars (Scope (Scope (Derived_Type))) = Name_Ada
+           and then Scope (Scope (Scope (Derived_Type))) = Standard_Standard
+         then
+            Set_Is_Controlled (Derived_Type);
+         else
+            Set_Is_Controlled (Derived_Type, Is_Controlled (Parent_Base));
+         end if;
+
+         Make_Class_Wide_Type (Derived_Type);
+         Set_Is_Abstract      (Derived_Type, Abstract_Present (Type_Def));
+
+         if Has_Discriminants (Derived_Type)
+           and then Constraint_Present
+         then
+            Set_Girder_Constraint
+              (Derived_Type, Expand_To_Girder_Constraint (Parent_Base, Discs));
+         end if;
+
+      else
+         Set_Is_Packed (Derived_Type, Is_Packed (Parent_Base));
+         Set_Has_Non_Standard_Rep
+                       (Derived_Type, Has_Non_Standard_Rep (Parent_Base));
+      end if;
+
+      --  STEP 4: Inherit components from the parent base and constrain them.
+      --          Apply the second transformation described in point 6. above.
+
+      if (not Is_Empty_Elmt_List (Discs) or else Inherit_Discrims)
+        or else not Has_Discriminants (Parent_Type)
+        or else not Is_Constrained (Parent_Type)
+      then
+         Constrs := Discs;
+      else
+         Constrs := Discriminant_Constraint (Parent_Type);
+      end if;
+
+      Assoc_List := Inherit_Components (N,
+        Parent_Base, Derived_Type, Is_Tagged, Inherit_Discrims, Constrs);
+
+      --  STEP 5a: Copy the parent record declaration for untagged types
+
+      if not Is_Tagged then
+
+         --  Discriminant_Constraint (Derived_Type) has been properly
+         --  constructed. Save it and temporarily set it to Empty because we do
+         --  not want the call to New_Copy_Tree below to mess this list.
+
+         if Has_Discriminants (Derived_Type) then
+            Save_Discr_Constr := Discriminant_Constraint (Derived_Type);
+            Set_Discriminant_Constraint (Derived_Type, No_Elist);
+         else
+            Save_Discr_Constr := No_Elist;
+         end if;
+
+         --  Save the Etype field of Derived_Type. It is correctly set now, but
+         --  the call to New_Copy tree may remap it to point to itself, which
+         --  is not what we want. Ditto for the Next_Entity field.
+
+         Save_Etype       := Etype (Derived_Type);
+         Save_Next_Entity := Next_Entity (Derived_Type);
+
+         --  Assoc_List maps all girder discriminants in the Parent_Base to
+         --  girder discriminants in the Derived_Type. It is fundamental that
+         --  no types or itypes with discriminants other than the girder
+         --  discriminants appear in the entities declared inside
+         --  Derived_Type. Gigi won't like it.
+
+         New_Decl :=
+           New_Copy_Tree
+             (Parent (Parent_Base), Map => Assoc_List, New_Sloc => Loc);
+
+         --  Restore the fields saved prior to the New_Copy_Tree call
+         --  and compute the girder constraint.
+
+         Set_Etype       (Derived_Type, Save_Etype);
+         Set_Next_Entity (Derived_Type, Save_Next_Entity);
+
+         if Has_Discriminants (Derived_Type) then
+            Set_Discriminant_Constraint
+              (Derived_Type, Save_Discr_Constr);
+            Set_Girder_Constraint
+              (Derived_Type, Expand_To_Girder_Constraint (Parent_Base, Discs));
+         end if;
+
+         --  Insert the new derived type declaration
+
+         Rewrite (N, New_Decl);
+
+      --  STEP 5b: Complete the processing for record extensions in generics
+
+      --  There is no completion for record extensions declared in the
+      --  parameter part of a generic, so we need to complete processing for
+      --  these generic record extensions here. The call to
+      --  Record_Type_Definition will change the Ekind of the components
+      --  from E_Void to E_Component.
+
+      elsif Private_Extension and then Is_Generic_Type (Derived_Type) then
+         Record_Type_Definition (Empty, Derived_Type);
+
+      --  STEP 5c: Process the record extension for non private tagged types.
+
+      elsif not Private_Extension then
+         --  Add the _parent field in the derived type.
+
+         Expand_Derived_Record (Derived_Type, Type_Def);
+
+         --  Analyze the record extension
+
+         Record_Type_Definition
+           (Record_Extension_Part (Type_Def), Derived_Type);
+      end if;
+
+      End_Scope;
+
+      if Etype (Derived_Type) = Any_Type then
+         return;
+      end if;
+
+      --  Set delayed freeze and then derive subprograms, we need to do
+      --  this in this order so that derived subprograms inherit the
+      --  derived freeze if necessary.
+
+      Set_Has_Delayed_Freeze (Derived_Type);
+      if Derive_Subps then
+         Derive_Subprograms (Parent_Type, Derived_Type);
+      end if;
+
+      --  If we have a private extension which defines a constrained derived
+      --  type mark as constrained here after we have derived subprograms. See
+      --  comment on point 9. just above the body of Build_Derived_Record_Type.
+
+      if Private_Extension and then Inherit_Discrims then
+         if Constraint_Present and then not Is_Empty_Elmt_List (Discs) then
+            Set_Is_Constrained          (Derived_Type, True);
+            Set_Discriminant_Constraint (Derived_Type, Discs);
+
+         elsif Is_Constrained (Parent_Type) then
+            Set_Is_Constrained
+              (Derived_Type, True);
+            Set_Discriminant_Constraint
+              (Derived_Type, Discriminant_Constraint (Parent_Type));
+         end if;
+      end if;
+
+   end Build_Derived_Record_Type;
+
+   ------------------------
+   -- Build_Derived_Type --
+   ------------------------
+
+   procedure Build_Derived_Type
+     (N             : Node_Id;
+      Parent_Type   : Entity_Id;
+      Derived_Type  : Entity_Id;
+      Is_Completion : Boolean;
+      Derive_Subps  : Boolean := True)
+   is
+      Parent_Base : constant Entity_Id := Base_Type (Parent_Type);
+
+   begin
+      --  Set common attributes
+
+      Set_Scope          (Derived_Type, Current_Scope);
+
+      Set_Ekind          (Derived_Type, Ekind     (Parent_Base));
+      Set_Etype          (Derived_Type,            Parent_Base);
+      Set_Has_Task       (Derived_Type, Has_Task  (Parent_Base));
+
+      Set_Size_Info      (Derived_Type,                 Parent_Type);
+      Set_RM_Size        (Derived_Type, RM_Size        (Parent_Type));
+      Set_Convention     (Derived_Type, Convention     (Parent_Type));
+      Set_First_Rep_Item (Derived_Type, First_Rep_Item (Parent_Type));
+
+      case Ekind (Parent_Type) is
+         when Numeric_Kind =>
+            Build_Derived_Numeric_Type (N, Parent_Type, Derived_Type);
+
+         when Array_Kind =>
+            Build_Derived_Array_Type (N, Parent_Type,  Derived_Type);
+
+         when E_Record_Type
+            | E_Record_Subtype
+            | Class_Wide_Kind  =>
+            Build_Derived_Record_Type
+              (N, Parent_Type, Derived_Type, Derive_Subps);
+            return;
+
+         when Enumeration_Kind =>
+            Build_Derived_Enumeration_Type (N, Parent_Type, Derived_Type);
+
+         when Access_Kind =>
+            Build_Derived_Access_Type (N, Parent_Type, Derived_Type);
+
+         when Incomplete_Or_Private_Kind =>
+            Build_Derived_Private_Type
+              (N, Parent_Type, Derived_Type, Is_Completion, Derive_Subps);
+
+            --  For discriminated types, the derivation includes deriving
+            --  primitive operations. For others it is done below.
+
+            if Is_Tagged_Type (Parent_Type)
+              or else Has_Discriminants (Parent_Type)
+              or else (Present (Full_View (Parent_Type))
+                        and then Has_Discriminants (Full_View (Parent_Type)))
+            then
+               return;
+            end if;
+
+         when Concurrent_Kind =>
+            Build_Derived_Concurrent_Type (N, Parent_Type, Derived_Type);
+
+         when others =>
+            raise Program_Error;
+      end case;
+
+      if Etype (Derived_Type) = Any_Type then
+         return;
+      end if;
+
+      --  Set delayed freeze and then derive subprograms, we need to do
+      --  this in this order so that derived subprograms inherit the
+      --  derived freeze if necessary.
+
+      Set_Has_Delayed_Freeze (Derived_Type);
+      if Derive_Subps then
+         Derive_Subprograms (Parent_Type, Derived_Type);
+      end if;
+
+      Set_Has_Primitive_Operations
+        (Base_Type (Derived_Type), Has_Primitive_Operations (Parent_Type));
+   end Build_Derived_Type;
+
+   -----------------------
+   -- Build_Discriminal --
+   -----------------------
+
+   procedure Build_Discriminal (Discrim : Entity_Id) is
+      D_Minal : Entity_Id;
+      CR_Disc : Entity_Id;
+
+   begin
+      --  A discriminal has the same names as the discriminant.
+
+      D_Minal := Make_Defining_Identifier (Sloc (Discrim), Chars (Discrim));
+
+      Set_Ekind     (D_Minal, E_In_Parameter);
+      Set_Mechanism (D_Minal, Default_Mechanism);
+      Set_Etype     (D_Minal, Etype (Discrim));
+
+      Set_Discriminal (Discrim, D_Minal);
+      Set_Discriminal_Link (D_Minal, Discrim);
+
+      --  For task types, build at once the discriminants of the corresponding
+      --  record, which are needed if discriminants are used in entry defaults
+      --  and in family bounds.
+
+      if Is_Concurrent_Type (Current_Scope)
+        or else Is_Limited_Type (Current_Scope)
+      then
+         CR_Disc := Make_Defining_Identifier (Sloc (Discrim), Chars (Discrim));
+
+         Set_Ekind     (CR_Disc, E_In_Parameter);
+         Set_Mechanism (CR_Disc, Default_Mechanism);
+         Set_Etype     (CR_Disc, Etype (Discrim));
+         Set_CR_Discriminant (Discrim, CR_Disc);
+      end if;
+   end Build_Discriminal;
+
+   ------------------------------------
+   -- Build_Discriminant_Constraints --
+   ------------------------------------
+
+   function Build_Discriminant_Constraints
+     (T           : Entity_Id;
+      Def         : Node_Id;
+      Derived_Def : Boolean := False)
+      return        Elist_Id
+   is
+      C          : constant Node_Id := Constraint (Def);
+      Nb_Discr   : constant Nat     := Number_Discriminants (T);
+      Discr_Expr : array (1 .. Nb_Discr) of Node_Id := (others => Empty);
+      --  Saves the expression corresponding to a given discriminant in T.
+
+      function Pos_Of_Discr (T : Entity_Id; D : Entity_Id) return Nat;
+      --  Return the Position number within array Discr_Expr of a discriminant
+      --  D within the discriminant list of the discriminated type T.
+
+      ------------------
+      -- Pos_Of_Discr --
+      ------------------
+
+      function Pos_Of_Discr (T : Entity_Id; D : Entity_Id) return Nat is
+         Disc : Entity_Id;
+
+      begin
+         Disc := First_Discriminant (T);
+         for J in Discr_Expr'Range loop
+            if Disc = D then
+               return J;
+            end if;
+
+            Next_Discriminant (Disc);
+         end loop;
+
+         --  Note: Since this function is called on discriminants that are
+         --  known to belong to the discriminated type, falling through the
+         --  loop with no match signals an internal compiler error.
+
+         raise Program_Error;
+      end Pos_Of_Discr;
+
+      --  Variables local to Build_Discriminant_Constraints
+
+      Discr : Entity_Id;
+      E     : Entity_Id;
+      Elist : Elist_Id := New_Elmt_List;
+
+      Constr    : Node_Id;
+      Expr      : Node_Id;
+      Id        : Node_Id;
+      Position  : Nat;
+      Found     : Boolean;
+
+      Discrim_Present : Boolean := False;
+
+   --  Start of processing for Build_Discriminant_Constraints
+
+   begin
+      --  The following loop will process positional associations only.
+      --  For a positional association, the (single) discriminant is
+      --  implicitly specified by position, in textual order (RM 3.7.2).
+
+      Discr  := First_Discriminant (T);
+      Constr := First (Constraints (C));
+
+      for D in Discr_Expr'Range loop
+         exit when Nkind (Constr) = N_Discriminant_Association;
+
+         if No (Constr) then
+            Error_Msg_N ("too few discriminants given in constraint", C);
+            return New_Elmt_List;
+
+         elsif Nkind (Constr) = N_Range
+           or else (Nkind (Constr) = N_Attribute_Reference
+                     and then
+                    Attribute_Name (Constr) = Name_Range)
+         then
+            Error_Msg_N
+              ("a range is not a valid discriminant constraint", Constr);
+            Discr_Expr (D) := Error;
+
+         else
+            Analyze_And_Resolve (Constr, Base_Type (Etype (Discr)));
+            Discr_Expr (D) := Constr;
+         end if;
+
+         Next_Discriminant (Discr);
+         Next (Constr);
+      end loop;
+
+      if No (Discr) and then Present (Constr) then
+         Error_Msg_N ("too many discriminants given in constraint", Constr);
+         return New_Elmt_List;
+      end if;
+
+      --  Named associations can be given in any order, but if both positional
+      --  and named associations are used in the same discriminant constraint,
+      --  then positional associations must occur first, at their normal
+      --  position. Hence once a named association is used, the rest of the
+      --  discriminant constraint must use only named associations.
+
+      while Present (Constr) loop
+
+         --  Positional association forbidden after a named association.
+
+         if Nkind (Constr) /= N_Discriminant_Association then
+            Error_Msg_N ("positional association follows named one", Constr);
+            return New_Elmt_List;
+
+         --  Otherwise it is a named association
+
+         else
+            --  E records the type of the discriminants in the named
+            --  association. All the discriminants specified in the same name
+            --  association must have the same type.
+
+            E := Empty;
+
+            --  Search the list of discriminants in T to see if the simple name
+            --  given in the constraint matches any of them.
+
+            Id := First (Selector_Names (Constr));
+            while Present (Id) loop
+               Found := False;
+
+               --  If Original_Discriminant is present, we are processing a
+               --  generic instantiation and this is an instance node. We need
+               --  to find the name of the corresponding discriminant in the
+               --  actual record type T and not the name of the discriminant in
+               --  the generic formal. Example:
+               --
+               --    generic
+               --       type G (D : int) is private;
+               --    package P is
+               --       subtype W is G (D => 1);
+               --    end package;
+               --    type Rec (X : int) is record ... end record;
+               --    package Q is new P (G => Rec);
+               --
+               --  At the point of the instantiation, formal type G is Rec
+               --  and therefore when reanalyzing "subtype W is G (D => 1);"
+               --  which really looks like "subtype W is Rec (D => 1);" at
+               --  the point of instantiation, we want to find the discriminant
+               --  that corresponds to D in Rec, ie X.
+
+               if Present (Original_Discriminant (Id)) then
+                  Discr := Find_Corresponding_Discriminant (Id, T);
+                  Found := True;
+
+               else
+                  Discr := First_Discriminant (T);
+                  while Present (Discr) loop
+                     if Chars (Discr) = Chars (Id) then
+                        Found := True;
+                        exit;
+                     end if;
+
+                     Next_Discriminant (Discr);
+                  end loop;
+
+                  if not Found then
+                     Error_Msg_N ("& does not match any discriminant", Id);
+                     return New_Elmt_List;
+
+                  --  The following is only useful for the benefit of generic
+                  --  instances but it does not interfere with other
+                  --  processsing for the non-generic case so we do it in all
+                  --  cases (for generics this statement is executed when
+                  --  processing the generic definition, see comment at the
+                  --  begining of this if statement).
+
+                  else
+                     Set_Original_Discriminant (Id, Discr);
+                  end if;
+               end if;
+
+               Position := Pos_Of_Discr (T, Discr);
+
+               if Present (Discr_Expr (Position)) then
+                  Error_Msg_N ("duplicate constraint for discriminant&", Id);
+
+               else
+                  --  Each discriminant specified in the same named association
+                  --  must be associated with a separate copy of the
+                  --  corresponding expression.
+
+                  if Present (Next (Id)) then
+                     Expr := New_Copy_Tree (Expression (Constr));
+                     Set_Parent (Expr, Parent (Expression (Constr)));
+                  else
+                     Expr := Expression (Constr);
+                  end if;
+
+                  Discr_Expr (Position) := Expr;
+                  Analyze_And_Resolve (Expr, Base_Type (Etype (Discr)));
+               end if;
+
+               --  A discriminant association with more than one discriminant
+               --  name is only allowed if the named discriminants are all of
+               --  the same type (RM 3.7.1(8)).
+
+               if E = Empty then
+                  E := Base_Type (Etype (Discr));
+
+               elsif Base_Type (Etype (Discr)) /= E then
+                  Error_Msg_N
+                    ("all discriminants in an association " &
+                     "must have the same type", Id);
+               end if;
+
+               Next (Id);
+            end loop;
+         end if;
+
+         Next (Constr);
+      end loop;
+
+      --  A discriminant constraint must provide exactly one value for each
+      --  discriminant of the type (RM 3.7.1(8)).
+
+      for J in Discr_Expr'Range loop
+         if No (Discr_Expr (J)) then
+            Error_Msg_N ("too few discriminants given in constraint", C);
+            return New_Elmt_List;
+         end if;
+      end loop;
+
+      --  Determine if there are discriminant expressions in the constraint.
+
+      for J in Discr_Expr'Range loop
+         if Denotes_Discriminant (Discr_Expr (J)) then
+            Discrim_Present := True;
+         end if;
+      end loop;
+
+      --  Build an element list consisting of the expressions given in the
+      --  discriminant constraint and apply the appropriate range
+      --  checks. The list is constructed after resolving any named
+      --  discriminant associations and therefore the expressions appear in
+      --  the textual order of the discriminants.
+
+      Discr := First_Discriminant (T);
+      for J in Discr_Expr'Range loop
+         if Discr_Expr (J) /= Error then
+
+            Append_Elmt (Discr_Expr (J), Elist);
+
+            --  If any of the discriminant constraints is given by a
+            --  discriminant and we are in a derived type declaration we
+            --  have a discriminant renaming. Establish link between new
+            --  and old discriminant.
+
+            if Denotes_Discriminant (Discr_Expr (J)) then
+               if Derived_Def then
+                  Set_Corresponding_Discriminant
+                    (Entity (Discr_Expr (J)), Discr);
+               end if;
+
+            --  Force the evaluation of non-discriminant expressions.
+            --  If we have found a discriminant in the constraint 3.4(26)
+            --  and 3.8(18) demand that no range checks are performed are
+            --  after evaluation. In all other cases perform a range check.
+
+            else
+               if not Discrim_Present then
+                  Apply_Range_Check (Discr_Expr (J), Etype (Discr));
+               end if;
+
+               Force_Evaluation (Discr_Expr (J));
+            end if;
+
+         --  Check that the designated type of an access discriminant's
+         --  expression is not a class-wide type unless the discriminant's
+         --  designated type is also class-wide.
+
+            if Ekind (Etype (Discr)) = E_Anonymous_Access_Type
+              and then not Is_Class_Wide_Type
+                         (Designated_Type (Etype (Discr)))
+              and then Etype (Discr_Expr (J)) /= Any_Type
+              and then Is_Class_Wide_Type
+                         (Designated_Type (Etype (Discr_Expr (J))))
+            then
+               Wrong_Type (Discr_Expr (J), Etype (Discr));
+            end if;
+         end if;
+
+         Next_Discriminant (Discr);
+      end loop;
+
+      return Elist;
+   end Build_Discriminant_Constraints;
+
+   ---------------------------------
+   -- Build_Discriminated_Subtype --
+   ---------------------------------
+
+   procedure Build_Discriminated_Subtype
+     (T           : Entity_Id;
+      Def_Id      : Entity_Id;
+      Elist       : Elist_Id;
+      Related_Nod : Node_Id;
+      For_Access  : Boolean := False)
+   is
+      Has_Discrs  : constant Boolean := Has_Discriminants (T);
+      Constrained : constant Boolean
+                      := (Has_Discrs and then not Is_Empty_Elmt_List (Elist))
+                           or else Is_Constrained (T);
+
+   begin
+      if Ekind (T) = E_Record_Type then
+         if For_Access then
+            Set_Ekind (Def_Id, E_Private_Subtype);
+            Set_Is_For_Access_Subtype (Def_Id, True);
+         else
+            Set_Ekind (Def_Id, E_Record_Subtype);
+         end if;
+
+      elsif Ekind (T) = E_Task_Type then
+         Set_Ekind (Def_Id, E_Task_Subtype);
+
+      elsif Ekind (T) = E_Protected_Type then
+         Set_Ekind (Def_Id, E_Protected_Subtype);
+
+      elsif Is_Private_Type (T) then
+         Set_Ekind (Def_Id, Subtype_Kind (Ekind (T)));
+
+      elsif Is_Class_Wide_Type (T) then
+         Set_Ekind (Def_Id, E_Class_Wide_Subtype);
+
+      else
+         --  Incomplete type. Attach subtype to list of dependents, to be
+         --  completed with full view of parent type.
+
+         Set_Ekind (Def_Id, Ekind (T));
+         Append_Elmt (Def_Id, Private_Dependents (T));
+      end if;
+
+      Set_Etype             (Def_Id, T);
+      Init_Size_Align       (Def_Id);
+      Set_Has_Discriminants (Def_Id, Has_Discrs);
+      Set_Is_Constrained    (Def_Id, Constrained);
+
+      Set_First_Entity      (Def_Id, First_Entity   (T));
+      Set_Last_Entity       (Def_Id, Last_Entity    (T));
+      Set_First_Rep_Item    (Def_Id, First_Rep_Item (T));
+
+      if Is_Tagged_Type (T) then
+         Set_Is_Tagged_Type  (Def_Id);
+         Make_Class_Wide_Type (Def_Id);
+      end if;
+
+      Set_Girder_Constraint (Def_Id, No_Elist);
+
+      if Has_Discrs then
+         Set_Discriminant_Constraint (Def_Id, Elist);
+         Set_Girder_Constraint_From_Discriminant_Constraint (Def_Id);
+      end if;
+
+      if Is_Tagged_Type (T) then
+         Set_Primitive_Operations (Def_Id, Primitive_Operations (T));
+         Set_Is_Abstract (Def_Id, Is_Abstract (T));
+      end if;
+
+      --  Subtypes introduced by component declarations do not need to be
+      --  marked as delayed, and do not get freeze nodes, because the semantics
+      --  verifies that the parents of the subtypes are frozen before the
+      --  enclosing record is frozen.
+
+      if not Is_Type (Scope (Def_Id)) then
+         Set_Depends_On_Private (Def_Id, Depends_On_Private (T));
+
+         if Is_Private_Type (T)
+           and then Present (Full_View (T))
+         then
+            Conditional_Delay (Def_Id, Full_View (T));
+         else
+            Conditional_Delay (Def_Id, T);
+         end if;
+      end if;
+
+      if Is_Record_Type (T) then
+         Set_Is_Limited_Record (Def_Id, Is_Limited_Record (T));
+
+         if Has_Discrs
+            and then not Is_Empty_Elmt_List (Elist)
+            and then not For_Access
+         then
+            Create_Constrained_Components (Def_Id, Related_Nod, T, Elist);
+         elsif not For_Access then
+            Set_Cloned_Subtype (Def_Id, T);
+         end if;
+      end if;
+
+   end Build_Discriminated_Subtype;
+
+   ------------------------
+   -- Build_Scalar_Bound --
+   ------------------------
+
+   function Build_Scalar_Bound
+     (Bound : Node_Id;
+      Par_T : Entity_Id;
+      Der_T : Entity_Id;
+      Loc   : Source_Ptr)
+      return Node_Id
+   is
+      New_Bound : Entity_Id;
+
+   begin
+      --  Note: not clear why this is needed, how can the original bound
+      --  be unanalyzed at this point? and if it is, what business do we
+      --  have messing around with it? and why is the base type of the
+      --  parent type the right type for the resolution. It probably is
+      --  not! It is OK for the new bound we are creating, but not for
+      --  the old one??? Still if it never happens, no problem!
+
+      Analyze_And_Resolve (Bound, Base_Type (Par_T));
+
+      if Nkind (Bound) = N_Integer_Literal
+        or else Nkind (Bound) = N_Real_Literal
+      then
+         New_Bound := New_Copy (Bound);
+         Set_Etype (New_Bound, Der_T);
+         Set_Analyzed (New_Bound);
+
+      elsif Is_Entity_Name (Bound) then
+         New_Bound := OK_Convert_To (Der_T, New_Copy (Bound));
+
+      --  The following is almost certainly wrong. What business do we have
+      --  relocating a node (Bound) that is presumably still attached to
+      --  the tree elsewhere???
+
+      else
+         New_Bound := OK_Convert_To (Der_T, Relocate_Node (Bound));
+      end if;
+
+      Set_Etype (New_Bound, Der_T);
+      return New_Bound;
+   end Build_Scalar_Bound;
+
+   --------------------------------
+   -- Build_Underlying_Full_View --
+   --------------------------------
+
+   procedure Build_Underlying_Full_View
+     (N   : Node_Id;
+      Typ : Entity_Id;
+      Par : Entity_Id)
+   is
+      Loc  : constant Source_Ptr := Sloc (N);
+      Subt : constant Entity_Id :=
+               Make_Defining_Identifier
+                 (Loc, New_External_Name (Chars (Typ), 'S'));
+
+      Constr : Node_Id;
+      Indic  : Node_Id;
+      C      : Node_Id;
+      Id     : Node_Id;
+
+   begin
+      if Nkind (N) = N_Full_Type_Declaration then
+         Constr := Constraint (Subtype_Indication (Type_Definition (N)));
+
+      --  ??? ??? is this assert right, I assume so otherwise Constr
+      --  would not be defined below (this used to be an elsif)
+
+      else pragma Assert (Nkind (N) = N_Subtype_Declaration);
+         Constr := New_Copy_Tree (Constraint (Subtype_Indication (N)));
+      end if;
+
+      --  If the constraint has discriminant associations, the discriminant
+      --  entity is already set, but it denotes a discriminant of the new
+      --  type, not the original parent, so it must be found anew.
+
+      C := First (Constraints (Constr));
+
+      while Present (C) loop
+
+         if Nkind (C) = N_Discriminant_Association then
+            Id := First (Selector_Names (C));
+
+            while Present (Id) loop
+               Set_Original_Discriminant (Id, Empty);
+               Next (Id);
+            end loop;
+         end if;
+
+         Next (C);
+      end loop;
+
+      Indic := Make_Subtype_Declaration (Loc,
+         Defining_Identifier => Subt,
+         Subtype_Indication  =>
+           Make_Subtype_Indication (Loc,
+             Subtype_Mark => New_Reference_To (Par, Loc),
+             Constraint   => New_Copy_Tree (Constr)));
+
+      Insert_Before (N, Indic);
+      Analyze (Indic);
+      Set_Underlying_Full_View (Typ, Full_View (Subt));
+   end Build_Underlying_Full_View;
+
+   -------------------------------
+   -- Check_Abstract_Overriding --
+   -------------------------------
+
+   procedure Check_Abstract_Overriding (T : Entity_Id) is
+      Op_List  : Elist_Id;
+      Elmt     : Elmt_Id;
+      Subp     : Entity_Id;
+      Type_Def : Node_Id;
+
+   begin
+      Op_List := Primitive_Operations (T);
+
+      --  Loop to check primitive operations
+
+      Elmt := First_Elmt (Op_List);
+      while Present (Elmt) loop
+         Subp := Node (Elmt);
+
+         --  Special exception, do not complain about failure to
+         --  override _Input and _Output, since we always provide
+         --  automatic overridings for these subprograms.
+
+         if Is_Abstract (Subp)
+           and then Chars (Subp) /= Name_uInput
+           and then Chars (Subp) /= Name_uOutput
+           and then not Is_Abstract (T)
+         then
+            if Present (Alias (Subp)) then
+               --  Only perform the check for a derived subprogram when
+               --  the type has an explicit record extension. This avoids
+               --  incorrectly flagging abstract subprograms for the case
+               --  of a type without an extension derived from a formal type
+               --  with a tagged actual (can occur within a private part).
+
+               Type_Def := Type_Definition (Parent (T));
+               if Nkind (Type_Def) = N_Derived_Type_Definition
+                 and then Present (Record_Extension_Part (Type_Def))
+               then
+                  Error_Msg_NE
+                    ("type must be declared abstract or & overridden",
+                     T, Subp);
+               end if;
+            else
+               Error_Msg_NE
+                 ("abstract subprogram not allowed for type&",
+                  Subp, T);
+               Error_Msg_NE
+                 ("nonabstract type has abstract subprogram&",
+                  T, Subp);
+            end if;
+         end if;
+
+         Next_Elmt (Elmt);
+      end loop;
+   end Check_Abstract_Overriding;
+
+   ------------------------------------------------
+   -- Check_Access_Discriminant_Requires_Limited --
+   ------------------------------------------------
+
+   procedure Check_Access_Discriminant_Requires_Limited
+     (D   : Node_Id;
+      Loc : Node_Id)
+   is
+   begin
+      --  A discriminant_specification for an access discriminant
+      --  shall appear only in the declaration for a task or protected
+      --  type, or for a type with the reserved word 'limited' in
+      --  its definition or in one of its ancestors. (RM 3.7(10))
+
+      if Nkind (Discriminant_Type (D)) = N_Access_Definition
+        and then not Is_Concurrent_Type (Current_Scope)
+        and then not Is_Concurrent_Record_Type (Current_Scope)
+        and then not Is_Limited_Record (Current_Scope)
+        and then Ekind (Current_Scope) /= E_Limited_Private_Type
+      then
+         Error_Msg_N
+           ("access discriminants allowed only for limited types", Loc);
+      end if;
+   end Check_Access_Discriminant_Requires_Limited;
+
+   -----------------------------------
+   -- Check_Aliased_Component_Types --
+   -----------------------------------
+
+   procedure Check_Aliased_Component_Types (T : Entity_Id) is
+      C : Entity_Id;
+
+   begin
+      --  ??? Also need to check components of record extensions,
+      --  but not components of protected types (which are always
+      --  limited).
+
+      if not Is_Limited_Type (T) then
+         if Ekind (T) = E_Record_Type then
+            C := First_Component (T);
+            while Present (C) loop
+               if Is_Aliased (C)
+                 and then Has_Discriminants (Etype (C))
+                 and then not Is_Constrained (Etype (C))
+                 and then not In_Instance
+               then
+                  Error_Msg_N
+                    ("aliased component must be constrained ('R'M 3.6(11))",
+                      C);
+               end if;
+
+               Next_Component (C);
+            end loop;
+
+         elsif Ekind (T) = E_Array_Type then
+            if Has_Aliased_Components (T)
+              and then Has_Discriminants (Component_Type (T))
+              and then not Is_Constrained (Component_Type (T))
+              and then not In_Instance
+            then
+               Error_Msg_N
+                 ("aliased component type must be constrained ('R'M 3.6(11))",
+                    T);
+            end if;
+         end if;
+      end if;
+   end Check_Aliased_Component_Types;
+
+   ----------------------
+   -- Check_Completion --
+   ----------------------
+
+   procedure Check_Completion (Body_Id : Node_Id := Empty) is
+      E : Entity_Id;
+
+      procedure Post_Error;
+      --  Post error message for lack of completion for entity E
+
+      procedure Post_Error is
+      begin
+         if not Comes_From_Source (E) then
+
+            if (Ekind (E) = E_Task_Type
+              or else Ekind (E) = E_Protected_Type)
+            then
+               --  It may be an anonymous protected type created for a
+               --  single variable. Post error on variable, if present.
+
+               declare
+                  Var : Entity_Id;
+
+               begin
+                  Var := First_Entity (Current_Scope);
+
+                  while Present (Var) loop
+                     exit when Etype (Var) = E
+                       and then Comes_From_Source (Var);
+
+                     Next_Entity (Var);
+                  end loop;
+
+                  if Present (Var) then
+                     E := Var;
+                  end if;
+               end;
+            end if;
+         end if;
+
+         --  If a generated entity has no completion, then either previous
+         --  semantic errors have disabled the expansion phase, or else
+         --  we had missing subunits, or else we are compiling without expan-
+         --  sion, or else something is very wrong.
+
+         if not Comes_From_Source (E) then
+            pragma Assert
+              (Errors_Detected > 0
+                or else Subunits_Missing
+                or else not Expander_Active);
+            return;
+
+         --  Here for source entity
+
+         else
+            --  Here if no body to post the error message, so we post the error
+            --  on the declaration that has no completion. This is not really
+            --  the right place to post it, think about this later ???
+
+            if No (Body_Id) then
+               if Is_Type (E) then
+                  Error_Msg_NE
+                    ("missing full declaration for }", Parent (E), E);
+               else
+                  Error_Msg_NE
+                    ("missing body for &", Parent (E), E);
+               end if;
+
+            --  Package body has no completion for a declaration that appears
+            --  in the corresponding spec. Post error on the body, with a
+            --  reference to the non-completed declaration.
+
+            else
+               Error_Msg_Sloc := Sloc (E);
+
+               if Is_Type (E) then
+                  Error_Msg_NE
+                    ("missing full declaration for }!", Body_Id, E);
+
+               elsif Is_Overloadable (E)
+                 and then Current_Entity_In_Scope (E) /= E
+               then
+                  --  It may be that the completion is mistyped and appears
+                  --  as a  distinct overloading of the entity.
+
+                  declare
+                     Candidate : Entity_Id := Current_Entity_In_Scope (E);
+                     Decl      : Node_Id := Unit_Declaration_Node (Candidate);
+
+                  begin
+                     if Is_Overloadable (Candidate)
+                       and then Ekind (Candidate) = Ekind (E)
+                       and then Nkind (Decl) = N_Subprogram_Body
+                       and then Acts_As_Spec (Decl)
+                     then
+                        Check_Type_Conformant (Candidate, E);
+
+                     else
+                        Error_Msg_NE ("missing body for & declared#!",
+                           Body_Id, E);
+                     end if;
+                  end;
+               else
+                  Error_Msg_NE ("missing body for & declared#!",
+                     Body_Id, E);
+               end if;
+            end if;
+         end if;
+      end Post_Error;
+
+   --  Start processing for Check_Completion
+
+   begin
+      E := First_Entity (Current_Scope);
+      while Present (E) loop
+         if Is_Intrinsic_Subprogram (E) then
+            null;
+
+         --  The following situation requires special handling: a child
+         --  unit that appears in the context clause of the body of its
+         --  parent:
+
+         --    procedure Parent.Child (...);
+         --
+         --    with Parent.Child;
+         --    package body Parent is
+
+         --  Here Parent.Child appears as a local entity, but should not
+         --  be flagged as requiring completion, because it is a
+         --  compilation unit.
+
+         elsif     Ekind (E) = E_Function
+           or else Ekind (E) = E_Procedure
+           or else Ekind (E) = E_Generic_Function
+           or else Ekind (E) = E_Generic_Procedure
+         then
+            if not Has_Completion (E)
+              and then not Is_Abstract (E)
+              and then Nkind (Parent (Unit_Declaration_Node (E))) /=
+                                                       N_Compilation_Unit
+              and then Chars (E) /= Name_uSize
+            then
+               Post_Error;
+            end if;
+
+         elsif Is_Entry (E) then
+            if not Has_Completion (E) and then
+              (Ekind (Scope (E)) = E_Protected_Object
+                or else Ekind (Scope (E)) = E_Protected_Type)
+            then
+               Post_Error;
+            end if;
+
+         elsif Is_Package (E) then
+            if Unit_Requires_Body (E) then
+               if not Has_Completion (E)
+                 and then Nkind (Parent (Unit_Declaration_Node (E))) /=
+                                                       N_Compilation_Unit
+               then
+                  Post_Error;
+               end if;
+
+            elsif not Is_Child_Unit (E) then
+               May_Need_Implicit_Body (E);
+            end if;
+
+         elsif Ekind (E) = E_Incomplete_Type
+           and then No (Underlying_Type (E))
+         then
+            Post_Error;
+
+         elsif (Ekind (E) = E_Task_Type or else
+                Ekind (E) = E_Protected_Type)
+           and then not Has_Completion (E)
+         then
+            Post_Error;
+
+         elsif Ekind (E) = E_Constant
+           and then Ekind (Etype (E)) = E_Task_Type
+           and then not Has_Completion (Etype (E))
+         then
+            Post_Error;
+
+         elsif Ekind (E) = E_Protected_Object
+           and then not Has_Completion (Etype (E))
+         then
+            Post_Error;
+
+         elsif Ekind (E) = E_Record_Type then
+            if Is_Tagged_Type (E) then
+               Check_Abstract_Overriding (E);
+            end if;
+
+            Check_Aliased_Component_Types (E);
+
+         elsif Ekind (E) = E_Array_Type then
+            Check_Aliased_Component_Types (E);
+
+         end if;
+
+         Next_Entity (E);
+      end loop;
+   end Check_Completion;
+
+   ----------------------------
+   -- Check_Delta_Expression --
+   ----------------------------
+
+   procedure Check_Delta_Expression (E : Node_Id) is
+   begin
+      if not (Is_Real_Type (Etype (E))) then
+         Wrong_Type (E, Any_Real);
+
+      elsif not Is_OK_Static_Expression (E) then
+         Error_Msg_N ("non-static expression used for delta value", E);
+
+      elsif not UR_Is_Positive (Expr_Value_R (E)) then
+         Error_Msg_N ("delta expression must be positive", E);
+
+      else
+         return;
+      end if;
+
+      --  If any of above errors occurred, then replace the incorrect
+      --  expression by the real 0.1, which should prevent further errors.
+
+      Rewrite (E,
+        Make_Real_Literal (Sloc (E), Ureal_Tenth));
+      Analyze_And_Resolve (E, Standard_Float);
+
+   end Check_Delta_Expression;
+
+   -----------------------------
+   -- Check_Digits_Expression --
+   -----------------------------
+
+   procedure Check_Digits_Expression (E : Node_Id) is
+   begin
+      if not (Is_Integer_Type (Etype (E))) then
+         Wrong_Type (E, Any_Integer);
+
+      elsif not Is_OK_Static_Expression (E) then
+         Error_Msg_N ("non-static expression used for digits value", E);
+
+      elsif Expr_Value (E) <= 0 then
+         Error_Msg_N ("digits value must be greater than zero", E);
+
+      else
+         return;
+      end if;
+
+      --  If any of above errors occurred, then replace the incorrect
+      --  expression by the integer 1, which should prevent further errors.
+
+      Rewrite (E, Make_Integer_Literal (Sloc (E), 1));
+      Analyze_And_Resolve (E, Standard_Integer);
+
+   end Check_Digits_Expression;
+
+   ----------------------
+   -- Check_Incomplete --
+   ----------------------
+
+   procedure Check_Incomplete (T : Entity_Id) is
+   begin
+      if Ekind (Root_Type (Entity (T))) = E_Incomplete_Type then
+         Error_Msg_N ("invalid use of type before its full declaration", T);
+      end if;
+   end Check_Incomplete;
+
+   --------------------------
+   -- Check_Initialization --
+   --------------------------
+
+   procedure Check_Initialization (T : Entity_Id; Exp : Node_Id) is
+   begin
+      if (Is_Limited_Type (T)
+           or else Is_Limited_Composite (T))
+        and then not In_Instance
+      then
+         Error_Msg_N
+           ("cannot initialize entities of limited type", Exp);
+      end if;
+   end Check_Initialization;
+
+   ------------------------------------
+   -- Check_Or_Process_Discriminants --
+   ------------------------------------
+
+   --  If an incomplete or private type declaration was already given for
+   --  the type, the discriminants may have already been processed if they
+   --  were present on the incomplete declaration. In this case a full
+   --  conformance check is performed otherwise just process them.
+
+   procedure Check_Or_Process_Discriminants (N : Node_Id; T : Entity_Id) is
+   begin
+      if Has_Discriminants (T) then
+
+         --  Make the discriminants visible to component declarations.
+
+         declare
+            D    : Entity_Id := First_Discriminant (T);
+            Prev : Entity_Id;
+
+         begin
+            while Present (D) loop
+               Prev := Current_Entity (D);
+               Set_Current_Entity (D);
+               Set_Is_Immediately_Visible (D);
+               Set_Homonym (D, Prev);
+
+               --  This restriction gets applied to the full type here; it
+               --  has already been applied earlier to the partial view
+
+               Check_Access_Discriminant_Requires_Limited (Parent (D), N);
+
+               Next_Discriminant (D);
+            end loop;
+         end;
+
+      elsif Present (Discriminant_Specifications (N)) then
+         Process_Discriminants (N);
+      end if;
+   end Check_Or_Process_Discriminants;
+
+   ----------------------
+   -- Check_Real_Bound --
+   ----------------------
+
+   procedure Check_Real_Bound (Bound : Node_Id) is
+   begin
+      if not Is_Real_Type (Etype (Bound)) then
+         Error_Msg_N
+           ("bound in real type definition must be of real type", Bound);
+
+      elsif not Is_OK_Static_Expression (Bound) then
+         Error_Msg_N
+           ("non-static expression used for real type bound", Bound);
+
+      else
+         return;
+      end if;
+
+      Rewrite
+        (Bound, Make_Real_Literal (Sloc (Bound), Ureal_0));
+      Analyze (Bound);
+      Resolve (Bound, Standard_Float);
+   end Check_Real_Bound;
+
+   ------------------------------
+   -- Complete_Private_Subtype --
+   ------------------------------
+
+   procedure Complete_Private_Subtype
+     (Priv        : Entity_Id;
+      Full        : Entity_Id;
+      Full_Base   : Entity_Id;
+      Related_Nod : Node_Id)
+   is
+      Save_Next_Entity : Entity_Id;
+      Save_Homonym     : Entity_Id;
+
+   begin
+      --  Set semantic attributes for (implicit) private subtype completion.
+      --  If the full type has no discriminants, then it is a copy of the full
+      --  view of the base. Otherwise, it is a subtype of the base with a
+      --  possible discriminant constraint. Save and restore the original
+      --  Next_Entity field of full to ensure that the calls to Copy_Node
+      --  do not corrupt the entity chain.
+
+      --  Note that the type of the full view is the same entity as the
+      --  type of the partial view. In this fashion, the subtype has
+      --  access to the correct view of the parent.
+
+      Save_Next_Entity := Next_Entity (Full);
+      Save_Homonym     := Homonym (Priv);
+
+      case Ekind (Full_Base) is
+
+         when E_Record_Type    |
+              E_Record_Subtype |
+              Class_Wide_Kind  |
+              Private_Kind     |
+              Task_Kind        |
+              Protected_Kind   =>
+            Copy_Node (Priv, Full);
+
+            Set_Has_Discriminants  (Full, Has_Discriminants (Full_Base));
+            Set_First_Entity       (Full, First_Entity (Full_Base));
+            Set_Last_Entity        (Full, Last_Entity (Full_Base));
+
+         when others =>
+            Copy_Node (Full_Base, Full);
+            Set_Chars          (Full, Chars (Priv));
+            Conditional_Delay  (Full, Priv);
+            Set_Sloc           (Full, Sloc (Priv));
+
+      end case;
+
+      Set_Next_Entity (Full, Save_Next_Entity);
+      Set_Homonym     (Full, Save_Homonym);
+      Set_Associated_Node_For_Itype (Full, Related_Nod);
+
+      --  Set common attributes for all subtypes.
+
+      Set_Ekind (Full, Subtype_Kind (Ekind (Full_Base)));
+
+      --  The Etype of the full view is inconsistent. Gigi needs to see the
+      --  structural full view,  which is what the current scheme gives:
+      --  the Etype of the full view is the etype of the full base. However,
+      --  if the full base is a derived type, the full view then looks like
+      --  a subtype of the parent, not a subtype of the full base. If instead
+      --  we write:
+
+      --       Set_Etype (Full, Full_Base);
+
+      --  then we get inconsistencies in the front-end (confusion between
+      --  views). Several outstanding bugs are related to this.
+
+      Set_Is_First_Subtype (Full, False);
+      Set_Scope            (Full, Scope (Priv));
+      Set_Size_Info        (Full, Full_Base);
+      Set_RM_Size          (Full, RM_Size (Full_Base));
+      Set_Is_Itype         (Full);
+
+      --  A subtype of a private-type-without-discriminants, whose full-view
+      --  has discriminants with default expressions, is not constrained!
+
+      if not Has_Discriminants (Priv) then
+         Set_Is_Constrained (Full, Is_Constrained (Full_Base));
+      end if;
+
+      Set_First_Rep_Item     (Full, First_Rep_Item (Full_Base));
+      Set_Depends_On_Private (Full, Has_Private_Component (Full));
+
+      --  Freeze the private subtype entity if its parent is delayed,
+      --  and not already frozen. We skip this processing if the type
+      --  is an anonymous subtype of a record component, or is the
+      --  corresponding record of a protected type, since ???
+
+      if not Is_Type (Scope (Full)) then
+         Set_Has_Delayed_Freeze (Full,
+           Has_Delayed_Freeze (Full_Base)
+               and then (not Is_Frozen (Full_Base)));
+      end if;
+
+      Set_Freeze_Node (Full, Empty);
+      Set_Is_Frozen (Full, False);
+      Set_Full_View (Priv, Full);
+
+      if Has_Discriminants (Full) then
+         Set_Girder_Constraint_From_Discriminant_Constraint (Full);
+         Set_Girder_Constraint (Priv, Girder_Constraint (Full));
+         if Has_Unknown_Discriminants (Full) then
+            Set_Discriminant_Constraint (Full, No_Elist);
+         end if;
+      end if;
+
+      if Ekind (Full_Base) = E_Record_Type
+        and then Has_Discriminants (Full_Base)
+        and then Has_Discriminants (Priv) -- might not, if errors
+        and then not Is_Empty_Elmt_List (Discriminant_Constraint (Priv))
+      then
+         Create_Constrained_Components
+           (Full, Related_Nod, Full_Base, Discriminant_Constraint (Priv));
+
+      --  If the full base is itself derived from private, build a congruent
+      --  subtype of its underlying type, for use by the back end.
+
+      elsif Ekind (Full_Base) in Private_Kind
+        and then Is_Derived_Type (Full_Base)
+        and then Has_Discriminants (Full_Base)
+        and then
+          Nkind (Subtype_Indication (Parent (Priv))) = N_Subtype_Indication
+      then
+         Build_Underlying_Full_View (Parent (Priv), Full, Etype (Full_Base));
+
+      elsif Is_Record_Type (Full_Base) then
+
+         --  Show Full is simply a renaming of Full_Base.
+
+         Set_Cloned_Subtype (Full, Full_Base);
+      end if;
+
+      --  It is usafe to share to bounds of a scalar type, because the
+      --  Itype is elaborated on demand, and if a bound is non-static
+      --  then different orders of elaboration in different units will
+      --  lead to different external symbols.
+
+      if Is_Scalar_Type (Full_Base) then
+         Set_Scalar_Range (Full,
+           Make_Range (Sloc (Related_Nod),
+             Low_Bound  => Duplicate_Subexpr (Type_Low_Bound  (Full_Base)),
+             High_Bound => Duplicate_Subexpr (Type_High_Bound (Full_Base))));
+      end if;
+
+      --  ??? It seems that a lot of fields are missing that should be
+      --  copied from  Full_Base to Full. Here are some that are introduced
+      --  in a non-disruptive way but a cleanup is necessary.
+
+      if Is_Tagged_Type (Full_Base) then
+         Set_Is_Tagged_Type (Full);
+         Set_Primitive_Operations (Full, Primitive_Operations (Full_Base));
+
+      elsif Is_Concurrent_Type (Full_Base) then
+
+         if Has_Discriminants (Full)
+           and then Present (Corresponding_Record_Type (Full_Base))
+         then
+            Set_Corresponding_Record_Type (Full,
+              Constrain_Corresponding_Record
+                (Full, Corresponding_Record_Type (Full_Base),
+                  Related_Nod, Full_Base));
+
+         else
+            Set_Corresponding_Record_Type (Full,
+              Corresponding_Record_Type (Full_Base));
+         end if;
+      end if;
+
+   end Complete_Private_Subtype;
+
+   ----------------------------
+   -- Constant_Redeclaration --
+   ----------------------------
+
+   procedure Constant_Redeclaration
+     (Id : Entity_Id;
+      N  : Node_Id;
+      T  : out Entity_Id)
+   is
+      Prev    : constant Entity_Id := Current_Entity_In_Scope (Id);
+      Obj_Def : constant Node_Id := Object_Definition (N);
+      New_T   : Entity_Id;
+
+   begin
+      if Nkind (Parent (Prev)) = N_Object_Declaration then
+         if Nkind (Object_Definition
+                     (Parent (Prev))) = N_Subtype_Indication
+         then
+            --  Find type of new declaration. The constraints of the two
+            --  views must match statically, but there is no point in
+            --  creating an itype for the full view.
+
+            if Nkind (Obj_Def) = N_Subtype_Indication then
+               Find_Type (Subtype_Mark (Obj_Def));
+               New_T := Entity (Subtype_Mark (Obj_Def));
+
+            else
+               Find_Type (Obj_Def);
+               New_T := Entity (Obj_Def);
+            end if;
+
+            T := Etype (Prev);
+
+         else
+            --  The full view may impose a constraint, even if the partial
+            --  view does not, so construct the subtype.
+
+            New_T := Find_Type_Of_Object (Obj_Def, N);
+            T     := New_T;
+         end if;
+
+      else
+         --  Current declaration is illegal, diagnosed below in Enter_Name.
+
+         T := Empty;
+         New_T := Any_Type;
+      end if;
+
+      --  If previous full declaration exists, or if a homograph is present,
+      --  let Enter_Name handle it, either with an error, or with the removal
+      --  of an overridden implicit subprogram.
+
+      if Ekind (Prev) /= E_Constant
+        or else Present (Expression (Parent (Prev)))
+      then
+         Enter_Name (Id);
+
+      --  Verify that types of both declarations match.
+
+      elsif Base_Type (Etype (Prev)) /= Base_Type (New_T) then
+         Error_Msg_Sloc := Sloc (Prev);
+         Error_Msg_N ("type does not match declaration#", N);
+         Set_Full_View (Prev, Id);
+         Set_Etype (Id, Any_Type);
+
+      --  If so, process the full constant declaration
+
+      else
+         Set_Full_View (Prev, Id);
+         Set_Is_Public (Id, Is_Public (Prev));
+         Set_Is_Internal (Id);
+         Append_Entity (Id, Current_Scope);
+
+         --  Check ALIASED present if present before (RM 7.4(7))
+
+         if Is_Aliased (Prev)
+           and then not Aliased_Present (N)
+         then
+            Error_Msg_Sloc := Sloc (Prev);
+            Error_Msg_N ("ALIASED required (see declaration#)", N);
+         end if;
+
+         --  Check that placement is in private part
+
+         if Ekind (Current_Scope) = E_Package
+           and then not In_Private_Part (Current_Scope)
+         then
+            Error_Msg_Sloc := Sloc (Prev);
+            Error_Msg_N ("full constant for declaration#"
+                         & " must be in private part", N);
+         end if;
+      end if;
+   end Constant_Redeclaration;
+
+   ----------------------
+   -- Constrain_Access --
+   ----------------------
+
+   procedure Constrain_Access
+     (Def_Id      : in out Entity_Id;
+      S           : Node_Id;
+      Related_Nod : Node_Id)
+   is
+      T             : constant Entity_Id := Entity (Subtype_Mark (S));
+      Desig_Type    : constant Entity_Id := Designated_Type (T);
+      Desig_Subtype : Entity_Id := Create_Itype (E_Void, Related_Nod);
+      Constraint_OK : Boolean := True;
+
+   begin
+      if Is_Array_Type (Desig_Type) then
+         Constrain_Array (Desig_Subtype, S, Related_Nod, Def_Id, 'P');
+
+      elsif (Is_Record_Type (Desig_Type)
+              or else Is_Incomplete_Or_Private_Type (Desig_Type))
+        and then not Is_Constrained (Desig_Type)
+      then
+         --  ??? The following code is a temporary kludge to ignore
+         --  discriminant constraint on access type if
+         --  it is constraining the current record. Avoid creating the
+         --  implicit subtype of the record we are currently compiling
+         --  since right now, we cannot handle these.
+         --  For now, just return the access type itself.
+
+         if Desig_Type = Current_Scope
+           and then No (Def_Id)
+         then
+            Set_Ekind (Desig_Subtype, E_Record_Subtype);
+            Def_Id := Entity (Subtype_Mark (S));
+
+            --  This call added to ensure that the constraint is
+            --  analyzed (needed for a B test). Note that we
+            --  still return early from this procedure to avoid
+            --  recursive processing. ???
+
+            Constrain_Discriminated_Type
+              (Desig_Subtype, S, Related_Nod, For_Access => True);
+
+            return;
+         end if;
+
+         Constrain_Discriminated_Type (Desig_Subtype, S, Related_Nod,
+           For_Access => True);
+
+      elsif (Is_Task_Type (Desig_Type)
+              or else Is_Protected_Type (Desig_Type))
+        and then not Is_Constrained (Desig_Type)
+      then
+         Constrain_Concurrent
+           (Desig_Subtype, S, Related_Nod, Desig_Type, ' ');
+
+      else
+         Error_Msg_N ("invalid constraint on access type", S);
+         Desig_Subtype := Desig_Type; -- Ignore invalid constraint.
+         Constraint_OK := False;
+      end if;
+
+      if No (Def_Id) then
+         Def_Id := Create_Itype (E_Access_Subtype, Related_Nod);
+      else
+         Set_Ekind (Def_Id, E_Access_Subtype);
+      end if;
+
+      if Constraint_OK then
+         Set_Etype (Def_Id, Base_Type (T));
+
+         if Is_Private_Type (Desig_Type) then
+            Prepare_Private_Subtype_Completion (Desig_Subtype, Related_Nod);
+         end if;
+      else
+         Set_Etype (Def_Id, Any_Type);
+      end if;
+
+      Set_Size_Info                (Def_Id, T);
+      Set_Is_Constrained           (Def_Id, Constraint_OK);
+      Set_Directly_Designated_Type (Def_Id, Desig_Subtype);
+      Set_Depends_On_Private       (Def_Id, Has_Private_Component (Def_Id));
+      Set_Is_Access_Constant       (Def_Id, Is_Access_Constant (T));
+
+      --  Itypes created for constrained record components do not receive
+      --  a freeze node, they are elaborated when first seen.
+
+      if not Is_Record_Type (Current_Scope) then
+         Conditional_Delay (Def_Id, T);
+      end if;
+   end Constrain_Access;
+
+   ---------------------
+   -- Constrain_Array --
+   ---------------------
+
+   procedure Constrain_Array
+     (Def_Id      : in out Entity_Id;
+      SI          : Node_Id;
+      Related_Nod : Node_Id;
+      Related_Id  : Entity_Id;
+      Suffix      : Character)
+   is
+      C                     : constant Node_Id := Constraint (SI);
+      Number_Of_Constraints : Nat := 0;
+      Index                 : Node_Id;
+      S, T                  : Entity_Id;
+      Constraint_OK         : Boolean := True;
+
+   begin
+      T := Entity (Subtype_Mark (SI));
+
+      if Ekind (T) in Access_Kind then
+         T := Designated_Type (T);
+      end if;
+
+      --  If an index constraint follows a subtype mark in a subtype indication
+      --  then the type or subtype denoted by the subtype mark must not already
+      --  impose an index constraint. The subtype mark must denote either an
+      --  unconstrained array type or an access type whose designated type
+      --  is such an array type... (RM 3.6.1)
+
+      if Is_Constrained (T) then
+         Error_Msg_N
+           ("array type is already constrained", Subtype_Mark (SI));
+         Constraint_OK := False;
+
+      else
+         S := First (Constraints (C));
+
+         while Present (S) loop
+            Number_Of_Constraints := Number_Of_Constraints + 1;
+            Next (S);
+         end loop;
+
+         --  In either case, the index constraint must provide a discrete
+         --  range for each index of the array type and the type of each
+         --  discrete range must be the same as that of the corresponding
+         --  index. (RM 3.6.1)
+
+         if Number_Of_Constraints /= Number_Dimensions (T) then
+            Error_Msg_NE ("incorrect number of index constraints for }", C, T);
+            Constraint_OK := False;
+
+         else
+            S := First (Constraints (C));
+            Index := First_Index (T);
+            Analyze (Index);
+
+            --  Apply constraints to each index type
+
+            for J in 1 .. Number_Of_Constraints loop
+               Constrain_Index (Index, S, Related_Nod, Related_Id, Suffix, J);
+               Next (Index);
+               Next (S);
+            end loop;
+
+         end if;
+      end if;
+
+      if No (Def_Id) then
+         Def_Id :=
+           Create_Itype (E_Array_Subtype, Related_Nod, Related_Id, Suffix);
+      else
+         Set_Ekind (Def_Id, E_Array_Subtype);
+      end if;
+
+      Set_Size_Info      (Def_Id,                (T));
+      Set_First_Rep_Item (Def_Id, First_Rep_Item (T));
+      Set_Etype          (Def_Id, Base_Type      (T));
+
+      if Constraint_OK then
+         Set_First_Index (Def_Id, First (Constraints (C)));
+      end if;
+
+      Set_Component_Type     (Def_Id, Component_Type (T));
+      Set_Is_Constrained     (Def_Id, True);
+      Set_Is_Aliased         (Def_Id, Is_Aliased (T));
+      Set_Depends_On_Private (Def_Id, Has_Private_Component (Def_Id));
+
+      Set_Is_Private_Composite (Def_Id, Is_Private_Composite (T));
+      Set_Is_Limited_Composite (Def_Id, Is_Limited_Composite (T));
+
+      --  If the subtype is not that of a record component, build a freeze
+      --  node if parent still needs one.
+
+      --  If the subtype is not that of a record component, make sure
+      --  that the Depends_On_Private status is set (explanation ???)
+      --  and also that a conditional delay is set.
+
+      if not Is_Type (Scope (Def_Id)) then
+         Set_Depends_On_Private (Def_Id, Depends_On_Private (T));
+         Conditional_Delay (Def_Id, T);
+      end if;
+
+   end Constrain_Array;
+
+   ------------------------------
+   -- Constrain_Component_Type --
+   ------------------------------
+
+   function Constrain_Component_Type
+     (Compon_Type     : Entity_Id;
+      Constrained_Typ : Entity_Id;
+      Related_Node    : Node_Id;
+      Typ             : Entity_Id;
+      Constraints     : Elist_Id)
+      return            Entity_Id
+   is
+      Loc : constant Source_Ptr := Sloc (Constrained_Typ);
+
+      function Build_Constrained_Array_Type
+        (Old_Type : Entity_Id)
+         return     Entity_Id;
+      --  If Old_Type is an array type, one of whose indices is
+      --  constrained by a discriminant, build an Itype whose constraint
+      --  replaces the discriminant with its value in the constraint.
+
+      function Build_Constrained_Discriminated_Type
+        (Old_Type : Entity_Id)
+         return     Entity_Id;
+      --  Ditto for record components.
+
+      function Build_Constrained_Access_Type
+        (Old_Type : Entity_Id)
+         return     Entity_Id;
+      --  Ditto for access types. Makes use of previous two functions, to
+      --  constrain designated type.
+
+      function Build_Subtype (T : Entity_Id; C : List_Id) return Entity_Id;
+      --  T is an array or discriminated type, C is a list of constraints
+      --  that apply to T. This routine builds the constrained subtype.
+
+      function Is_Discriminant (Expr : Node_Id) return Boolean;
+      --  Returns True if Expr is a discriminant.
+
+      function Get_Value (Discrim : Entity_Id) return Node_Id;
+      --  Find the value of discriminant Discrim in Constraint.
+
+      -----------------------------------
+      -- Build_Constrained_Access_Type --
+      -----------------------------------
+
+      function Build_Constrained_Access_Type
+        (Old_Type : Entity_Id)
+        return      Entity_Id
+      is
+         Desig_Type    : constant Entity_Id := Designated_Type (Old_Type);
+         Itype         : Entity_Id;
+         Desig_Subtype : Entity_Id;
+         Scop          : Entity_Id;
+
+      begin
+         --  if the original access type was not embedded in the enclosing
+         --  type definition, there is no need to produce a new access
+         --  subtype. In fact every access type with an explicit constraint
+         --  generates an itype whose scope is the enclosing record.
+
+         if not Is_Type (Scope (Old_Type)) then
+            return Old_Type;
+
+         elsif Is_Array_Type (Desig_Type) then
+            Desig_Subtype := Build_Constrained_Array_Type (Desig_Type);
+
+         elsif Has_Discriminants (Desig_Type) then
+
+            --  This may be an access type to an enclosing record type for
+            --  which we are constructing the constrained components. Return
+            --  the enclosing record subtype. This is not always correct,
+            --  but avoids infinite recursion. ???
+
+            Desig_Subtype := Any_Type;
+
+            for J in reverse 0 .. Scope_Stack.Last loop
+               Scop := Scope_Stack.Table (J).Entity;
+
+               if Is_Type (Scop)
+                 and then Base_Type (Scop) = Base_Type (Desig_Type)
+               then
+                  Desig_Subtype := Scop;
+               end if;
+
+               exit when not Is_Type (Scop);
+            end loop;
+
+            if Desig_Subtype = Any_Type then
+               Desig_Subtype :=
+                 Build_Constrained_Discriminated_Type (Desig_Type);
+            end if;
+
+         else
+            return Old_Type;
+         end if;
+
+         if Desig_Subtype /= Desig_Type then
+            --  The Related_Node better be here or else we won't be able
+            --  to attach new itypes to a node in the tree.
+
+            pragma Assert (Present (Related_Node));
+
+            Itype := Create_Itype (E_Access_Subtype, Related_Node);
+
+            Set_Etype                    (Itype, Base_Type      (Old_Type));
+            Set_Size_Info                (Itype,                (Old_Type));
+            Set_Directly_Designated_Type (Itype, Desig_Subtype);
+            Set_Depends_On_Private       (Itype, Has_Private_Component
+                                                                (Old_Type));
+            Set_Is_Access_Constant       (Itype, Is_Access_Constant
+                                                                (Old_Type));
+
+            --  The new itype needs freezing when it depends on a not frozen
+            --  type and the enclosing subtype needs freezing.
+
+            if Has_Delayed_Freeze (Constrained_Typ)
+              and then not Is_Frozen (Constrained_Typ)
+            then
+               Conditional_Delay (Itype, Base_Type (Old_Type));
+            end if;
+
+            return Itype;
+
+         else
+            return Old_Type;
+         end if;
+      end Build_Constrained_Access_Type;
+
+      ----------------------------------
+      -- Build_Constrained_Array_Type --
+      ----------------------------------
+
+      function Build_Constrained_Array_Type
+        (Old_Type : Entity_Id)
+         return     Entity_Id
+      is
+         Lo_Expr     : Node_Id;
+         Hi_Expr     : Node_Id;
+         Old_Index   : Node_Id;
+         Range_Node  : Node_Id;
+         Constr_List : List_Id;
+
+         Need_To_Create_Itype : Boolean := False;
+
+      begin
+         Old_Index := First_Index (Old_Type);
+         while Present (Old_Index) loop
+            Get_Index_Bounds (Old_Index, Lo_Expr, Hi_Expr);
+
+            if Is_Discriminant (Lo_Expr)
+              or else Is_Discriminant (Hi_Expr)
+            then
+               Need_To_Create_Itype := True;
+            end if;
+
+            Next_Index (Old_Index);
+         end loop;
+
+         if Need_To_Create_Itype then
+            Constr_List := New_List;
+
+            Old_Index := First_Index (Old_Type);
+            while Present (Old_Index) loop
+               Get_Index_Bounds (Old_Index, Lo_Expr, Hi_Expr);
+
+               if Is_Discriminant (Lo_Expr) then
+                  Lo_Expr := Get_Value (Lo_Expr);
+               end if;
+
+               if Is_Discriminant (Hi_Expr) then
+                  Hi_Expr := Get_Value (Hi_Expr);
+               end if;
+
+               Range_Node :=
+                 Make_Range
+                   (Loc, New_Copy_Tree (Lo_Expr), New_Copy_Tree (Hi_Expr));
+
+               Append (Range_Node, To => Constr_List);
+
+               Next_Index (Old_Index);
+            end loop;
+
+            return Build_Subtype (Old_Type, Constr_List);
+
+         else
+            return Old_Type;
+         end if;
+      end Build_Constrained_Array_Type;
+
+      ------------------------------------------
+      -- Build_Constrained_Discriminated_Type --
+      ------------------------------------------
+
+      function Build_Constrained_Discriminated_Type
+        (Old_Type : Entity_Id)
+         return     Entity_Id
+      is
+         Expr           : Node_Id;
+         Constr_List    : List_Id;
+         Old_Constraint : Elmt_Id;
+
+         Need_To_Create_Itype : Boolean := False;
+
+      begin
+         Old_Constraint := First_Elmt (Discriminant_Constraint (Old_Type));
+         while Present (Old_Constraint) loop
+            Expr := Node (Old_Constraint);
+
+            if Is_Discriminant (Expr) then
+               Need_To_Create_Itype := True;
+            end if;
+
+            Next_Elmt (Old_Constraint);
+         end loop;
+
+         if Need_To_Create_Itype then
+            Constr_List := New_List;
+
+            Old_Constraint := First_Elmt (Discriminant_Constraint (Old_Type));
+            while Present (Old_Constraint) loop
+               Expr := Node (Old_Constraint);
+
+               if Is_Discriminant (Expr) then
+                  Expr := Get_Value (Expr);
+               end if;
+
+               Append (New_Copy_Tree (Expr), To => Constr_List);
+
+               Next_Elmt (Old_Constraint);
+            end loop;
+
+            return Build_Subtype (Old_Type, Constr_List);
+
+         else
+            return Old_Type;
+         end if;
+      end Build_Constrained_Discriminated_Type;
+
+      -------------------
+      -- Build_Subtype --
+      -------------------
+
+      function Build_Subtype (T : Entity_Id; C : List_Id) return Entity_Id is
+         Indic       : Node_Id;
+         Subtyp_Decl : Node_Id;
+         Def_Id      : Entity_Id;
+         Btyp        : Entity_Id := Base_Type (T);
+
+      begin
+         --  The Related_Node better be here or else we won't be able
+         --  to attach new itypes to a node in the tree.
+
+         pragma Assert (Present (Related_Node));
+
+         --  If the view of the component's type is incomplete or private
+         --  with unknown discriminants, then the constraint must be applied
+         --  to the full type.
+
+         if Has_Unknown_Discriminants (Btyp)
+           and then Present (Underlying_Type (Btyp))
+         then
+            Btyp := Underlying_Type (Btyp);
+         end if;
+
+         Indic :=
+           Make_Subtype_Indication (Loc,
+             Subtype_Mark => New_Occurrence_Of (Btyp, Loc),
+             Constraint   => Make_Index_Or_Discriminant_Constraint (Loc, C));
+
+         Def_Id := Create_Itype (Ekind (T), Related_Node);
+
+         Subtyp_Decl :=
+           Make_Subtype_Declaration (Loc,
+             Defining_Identifier => Def_Id,
+             Subtype_Indication  => Indic);
+         Set_Parent (Subtyp_Decl, Parent (Related_Node));
+
+         --  Itypes must be analyzed with checks off (see itypes.ads).
+
+         Analyze (Subtyp_Decl, Suppress => All_Checks);
+
+         return Def_Id;
+      end Build_Subtype;
+
+      ---------------
+      -- Get_Value --
+      ---------------
+
+      function Get_Value (Discrim : Entity_Id) return Node_Id is
+         D : Entity_Id := First_Discriminant (Typ);
+         E : Elmt_Id   := First_Elmt (Constraints);
+
+      begin
+         while Present (D) loop
+
+            --  If we are constraining the subtype of a derived tagged type,
+            --  recover the discriminant of the parent, which appears in
+            --  the constraint of an inherited component.
+
+            if D = Entity (Discrim)
+              or else Corresponding_Discriminant (D) = Entity (Discrim)
+            then
+               return Node (E);
+            end if;
+
+            Next_Discriminant (D);
+            Next_Elmt (E);
+         end loop;
+
+         --  Something is wrong if we did not find the value
+
+         raise Program_Error;
+      end Get_Value;
+
+      ---------------------
+      -- Is_Discriminant --
+      ---------------------
+
+      function Is_Discriminant (Expr : Node_Id) return Boolean is
+         Discrim_Scope : Entity_Id;
+
+      begin
+         if Denotes_Discriminant (Expr) then
+            Discrim_Scope := Scope (Entity (Expr));
+
+            --  Either we have a reference to one of Typ's discriminants,
+
+            pragma Assert (Discrim_Scope = Typ
+
+               --  or to the discriminants of the parent type, in the case
+               --  of a derivation of a tagged type with variants.
+
+               or else Discrim_Scope = Etype (Typ)
+               or else Full_View (Discrim_Scope) = Etype (Typ)
+
+               --  or same as above for the case where the discriminants
+               --  were declared in Typ's private view.
+
+               or else (Is_Private_Type (Discrim_Scope)
+                        and then Chars (Discrim_Scope) = Chars (Typ))
+
+               --  or else we are deriving from the full view and the
+               --  discriminant is declared in the private entity.
+
+               or else (Is_Private_Type (Typ)
+                        and then Chars (Discrim_Scope) = Chars (Typ))
+
+               --  or we have a class-wide type, in which case make sure the
+               --  discriminant found belongs to the root type.
+
+               or else (Is_Class_Wide_Type (Typ)
+                        and then Etype (Typ) = Discrim_Scope));
+
+            return True;
+         end if;
+
+         --  In all other cases we have something wrong.
+
+         return False;
+      end Is_Discriminant;
+
+   --  Start of processing for Constrain_Component_Type
+
+   begin
+      if Is_Array_Type (Compon_Type) then
+         return Build_Constrained_Array_Type (Compon_Type);
+
+      elsif Has_Discriminants (Compon_Type) then
+         return Build_Constrained_Discriminated_Type (Compon_Type);
+
+      elsif Is_Access_Type (Compon_Type) then
+         return Build_Constrained_Access_Type (Compon_Type);
+      end if;
+
+      return Compon_Type;
+   end Constrain_Component_Type;
+
+   --------------------------
+   -- Constrain_Concurrent --
+   --------------------------
+
+   --  For concurrent types, the associated record value type carries the same
+   --  discriminants, so when we constrain a concurrent type, we must constrain
+   --  the value type as well.
+
+   procedure Constrain_Concurrent
+     (Def_Id      : in out Entity_Id;
+      SI          : Node_Id;
+      Related_Nod : Node_Id;
+      Related_Id  : Entity_Id;
+      Suffix      : Character)
+   is
+      T_Ent : Entity_Id := Entity (Subtype_Mark (SI));
+      T_Val : Entity_Id;
+
+   begin
+      if Ekind (T_Ent) in Access_Kind then
+         T_Ent := Designated_Type (T_Ent);
+      end if;
+
+      T_Val := Corresponding_Record_Type (T_Ent);
+
+      if Present (T_Val) then
+
+         if No (Def_Id) then
+            Def_Id := Create_Itype (E_Void, Related_Nod, Related_Id, Suffix);
+         end if;
+
+         Constrain_Discriminated_Type (Def_Id, SI, Related_Nod);
+
+         Set_Depends_On_Private (Def_Id, Has_Private_Component (Def_Id));
+         Set_Corresponding_Record_Type (Def_Id,
+           Constrain_Corresponding_Record
+             (Def_Id, T_Val, Related_Nod, Related_Id));
+
+      else
+         --  If there is no associated record, expansion is disabled and this
+         --  is a generic context. Create a subtype in any case, so that
+         --  semantic analysis can proceed.
+
+         if No (Def_Id) then
+            Def_Id := Create_Itype (E_Void, Related_Nod, Related_Id, Suffix);
+         end if;
+
+         Constrain_Discriminated_Type (Def_Id, SI, Related_Nod);
+      end if;
+   end Constrain_Concurrent;
+
+   ------------------------------------
+   -- Constrain_Corresponding_Record --
+   ------------------------------------
+
+   function Constrain_Corresponding_Record
+     (Prot_Subt   : Entity_Id;
+      Corr_Rec    : Entity_Id;
+      Related_Nod : Node_Id;
+      Related_Id  : Entity_Id)
+      return Entity_Id
+   is
+      T_Sub : constant Entity_Id
+        := Create_Itype (E_Record_Subtype, Related_Nod, Related_Id, 'V');
+
+   begin
+      Set_Etype                   (T_Sub, Corr_Rec);
+      Init_Size_Align             (T_Sub);
+      Set_Has_Discriminants       (T_Sub, Has_Discriminants (Prot_Subt));
+      Set_Is_Constrained          (T_Sub, True);
+      Set_First_Entity            (T_Sub, First_Entity (Corr_Rec));
+      Set_Last_Entity             (T_Sub, Last_Entity  (Corr_Rec));
+
+      Conditional_Delay (T_Sub, Corr_Rec);
+
+      if Has_Discriminants (Prot_Subt) then -- False only if errors.
+         Set_Discriminant_Constraint (T_Sub,
+                                      Discriminant_Constraint (Prot_Subt));
+         Set_Girder_Constraint_From_Discriminant_Constraint (T_Sub);
+         Create_Constrained_Components (T_Sub, Related_Nod, Corr_Rec,
+                                        Discriminant_Constraint (T_Sub));
+      end if;
+
+      Set_Depends_On_Private      (T_Sub, Has_Private_Component (T_Sub));
+
+      return T_Sub;
+   end Constrain_Corresponding_Record;
+
+   -----------------------
+   -- Constrain_Decimal --
+   -----------------------
+
+   procedure Constrain_Decimal
+     (Def_Id      : Node_Id;
+      S           : Node_Id;
+      Related_Nod : Node_Id)
+   is
+      T           : constant Entity_Id  := Entity (Subtype_Mark (S));
+      C           : constant Node_Id    := Constraint (S);
+      Loc         : constant Source_Ptr := Sloc (C);
+      Range_Expr  : Node_Id;
+      Digits_Expr : Node_Id;
+      Digits_Val  : Uint;
+      Bound_Val   : Ureal;
+
+   begin
+      Set_Ekind (Def_Id, E_Decimal_Fixed_Point_Subtype);
+
+      if Nkind (C) = N_Range_Constraint then
+         Range_Expr := Range_Expression (C);
+         Digits_Val := Digits_Value (T);
+
+      else
+         pragma Assert (Nkind (C) = N_Digits_Constraint);
+         Digits_Expr := Digits_Expression (C);
+         Analyze_And_Resolve (Digits_Expr, Any_Integer);
+
+         Check_Digits_Expression (Digits_Expr);
+         Digits_Val := Expr_Value (Digits_Expr);
+
+         if Digits_Val > Digits_Value (T) then
+            Error_Msg_N
+               ("digits expression is incompatible with subtype", C);
+            Digits_Val := Digits_Value (T);
+         end if;
+
+         if Present (Range_Constraint (C)) then
+            Range_Expr := Range_Expression (Range_Constraint (C));
+         else
+            Range_Expr := Empty;
+         end if;
+      end if;
+
+      Set_Etype            (Def_Id, Base_Type        (T));
+      Set_Size_Info        (Def_Id,                  (T));
+      Set_First_Rep_Item   (Def_Id, First_Rep_Item   (T));
+      Set_Delta_Value      (Def_Id, Delta_Value      (T));
+      Set_Scale_Value      (Def_Id, Scale_Value      (T));
+      Set_Small_Value      (Def_Id, Small_Value      (T));
+      Set_Machine_Radix_10 (Def_Id, Machine_Radix_10 (T));
+      Set_Digits_Value     (Def_Id, Digits_Val);
+
+      --  Manufacture range from given digits value if no range present
+
+      if No (Range_Expr) then
+         Bound_Val := (Ureal_10 ** Digits_Val - Ureal_1) * Small_Value (T);
+         Range_Expr :=
+            Make_Range (Loc,
+               Low_Bound =>
+                 Convert_To (T, Make_Real_Literal (Loc, (-Bound_Val))),
+               High_Bound =>
+                 Convert_To (T, Make_Real_Literal (Loc, Bound_Val)));
+
+      end if;
+
+      Set_Scalar_Range_For_Subtype (Def_Id, Range_Expr, T, Related_Nod);
+      Set_Discrete_RM_Size (Def_Id);
+
+      --  Unconditionally delay the freeze, since we cannot set size
+      --  information in all cases correctly until the freeze point.
+
+      Set_Has_Delayed_Freeze (Def_Id);
+   end Constrain_Decimal;
+
+   ----------------------------------
+   -- Constrain_Discriminated_Type --
+   ----------------------------------
+
+   procedure Constrain_Discriminated_Type
+     (Def_Id      : Entity_Id;
+      S           : Node_Id;
+      Related_Nod : Node_Id;
+      For_Access  : Boolean := False)
+   is
+      T     : Entity_Id;
+      C     : Node_Id;
+      Elist : Elist_Id := New_Elmt_List;
+
+      procedure Fixup_Bad_Constraint;
+      --  This is called after finding a bad constraint, and after having
+      --  posted an appropriate error message. The mission is to leave the
+      --  entity T in as reasonable state as possible!
+
+      procedure Fixup_Bad_Constraint is
+      begin
+         --  Set a reasonable Ekind for the entity. For an incomplete type,
+         --  we can't do much, but for other types, we can set the proper
+         --  corresponding subtype kind.
+
+         if Ekind (T) = E_Incomplete_Type then
+            Set_Ekind (Def_Id, Ekind (T));
+         else
+            Set_Ekind (Def_Id, Subtype_Kind (Ekind (T)));
+         end if;
+
+         Set_Etype (Def_Id, Any_Type);
+         Set_Error_Posted (Def_Id);
+      end Fixup_Bad_Constraint;
+
+   --  Start of processing for Constrain_Discriminated_Type
+
+   begin
+      C := Constraint (S);
+
+      --  A discriminant constraint is only allowed in a subtype indication,
+      --  after a subtype mark. This subtype mark must denote either a type
+      --  with discriminants, or an access type whose designated type is a
+      --  type with discriminants. A discriminant constraint specifies the
+      --  values of these discriminants (RM 3.7.2(5)).
+
+      T := Base_Type (Entity (Subtype_Mark (S)));
+
+      if Ekind (T) in Access_Kind then
+         T := Designated_Type (T);
+      end if;
+
+      if not Has_Discriminants (T) then
+         Error_Msg_N ("invalid constraint: type has no discriminant", C);
+         Fixup_Bad_Constraint;
+         return;
+
+      elsif Is_Constrained (Entity (Subtype_Mark (S))) then
+         Error_Msg_N ("type is already constrained", Subtype_Mark (S));
+         Fixup_Bad_Constraint;
+         return;
+      end if;
+
+      --  T may be an unconstrained subtype (e.g. a generic actual).
+      --  Constraint applies to the base type.
+
+      T := Base_Type (T);
+
+      Elist := Build_Discriminant_Constraints (T, S);
+
+      --  If the list returned was empty we had an error in building the
+      --  discriminant constraint. We have also already signalled an error
+      --  in the incomplete type case
+
+      if Is_Empty_Elmt_List (Elist) then
+         Fixup_Bad_Constraint;
+         return;
+      end if;
+
+      Build_Discriminated_Subtype (T, Def_Id, Elist, Related_Nod, For_Access);
+   end Constrain_Discriminated_Type;
+
+   ---------------------------
+   -- Constrain_Enumeration --
+   ---------------------------
+
+   procedure Constrain_Enumeration
+     (Def_Id      : Node_Id;
+      S           : Node_Id;
+      Related_Nod : Node_Id)
+   is
+      T : constant Entity_Id := Entity (Subtype_Mark (S));
+      C : constant Node_Id   := Constraint (S);
+
+   begin
+      Set_Ekind (Def_Id, E_Enumeration_Subtype);
+
+      Set_First_Literal     (Def_Id, First_Literal (Base_Type (T)));
+
+      Set_Etype             (Def_Id, Base_Type         (T));
+      Set_Size_Info         (Def_Id,                   (T));
+      Set_First_Rep_Item    (Def_Id, First_Rep_Item    (T));
+      Set_Is_Character_Type (Def_Id, Is_Character_Type (T));
+
+      Set_Scalar_Range_For_Subtype
+        (Def_Id, Range_Expression (C), T, Related_Nod);
+
+      Set_Discrete_RM_Size (Def_Id);
+
+   end Constrain_Enumeration;
+
+   ----------------------
+   -- Constrain_Float --
+   ----------------------
+
+   procedure Constrain_Float
+     (Def_Id      : Node_Id;
+      S           : Node_Id;
+      Related_Nod : Node_Id)
+   is
+      T    : constant Entity_Id := Entity (Subtype_Mark (S));
+      C    : Node_Id;
+      D    : Node_Id;
+      Rais : Node_Id;
+
+   begin
+      Set_Ekind (Def_Id, E_Floating_Point_Subtype);
+
+      Set_Etype          (Def_Id, Base_Type      (T));
+      Set_Size_Info      (Def_Id,                (T));
+      Set_First_Rep_Item (Def_Id, First_Rep_Item (T));
+
+      --  Process the constraint
+
+      C := Constraint (S);
+
+      --  Digits constraint present
+
+      if Nkind (C) = N_Digits_Constraint then
+         D := Digits_Expression (C);
+         Analyze_And_Resolve (D, Any_Integer);
+         Check_Digits_Expression (D);
+         Set_Digits_Value (Def_Id, Expr_Value (D));
+
+         --  Check that digits value is in range. Obviously we can do this
+         --  at compile time, but it is strictly a runtime check, and of
+         --  course there is an ACVC test that checks this!
+
+         if Digits_Value (Def_Id) > Digits_Value (T) then
+            Error_Msg_Uint_1 := Digits_Value (T);
+            Error_Msg_N ("?digits value is too large, maximum is ^", D);
+            Rais := Make_Raise_Constraint_Error (Sloc (D));
+            Insert_Action (Declaration_Node (Def_Id), Rais);
+         end if;
+
+         C := Range_Constraint (C);
+
+      --  No digits constraint present
+
+      else
+         Set_Digits_Value (Def_Id, Digits_Value (T));
+      end if;
+
+      --  Range constraint present
+
+      if Nkind (C) = N_Range_Constraint then
+         Set_Scalar_Range_For_Subtype
+           (Def_Id, Range_Expression (C), T, Related_Nod);
+
+      --  No range constraint present
+
+      else
+         pragma Assert (No (C));
+         Set_Scalar_Range (Def_Id, Scalar_Range (T));
+      end if;
+
+      Set_Is_Constrained (Def_Id);
+   end Constrain_Float;
+
+   ---------------------
+   -- Constrain_Index --
+   ---------------------
+
+   procedure Constrain_Index
+     (Index        : Node_Id;
+      S            : Node_Id;
+      Related_Nod  : Node_Id;
+      Related_Id   : Entity_Id;
+      Suffix       : Character;
+      Suffix_Index : Nat)
+   is
+      Def_Id     : Entity_Id;
+      R          : Node_Id;
+      Checks_Off : Boolean := False;
+      T          : constant Entity_Id := Etype (Index);
+
+   begin
+      if Nkind (S) = N_Range
+        or else Nkind (S) = N_Attribute_Reference
+      then
+         --  A Range attribute will transformed into N_Range by Resolve.
+
+         Analyze (S);
+         Set_Etype (S, T);
+         R := S;
+
+         --  ??? Why on earth do we turn checks of in this very specific case ?
+
+         --  From the revision history: (Constrain_Index): Call
+         --  Process_Range_Expr_In_Decl with range checking off for range
+         --  bounds that are attributes. This avoids some horrible
+         --  constraint error checks.
+
+         if Nkind (R) = N_Range
+           and then Nkind (Low_Bound (R)) = N_Attribute_Reference
+           and then Nkind (High_Bound (R)) = N_Attribute_Reference
+         then
+            Checks_Off := True;
+         end if;
+
+         Process_Range_Expr_In_Decl
+           (R, T, Related_Nod, Empty_List, Checks_Off);
+
+         if not Error_Posted (S)
+           and then
+             (Nkind (S) /= N_Range
+               or else Base_Type (T) /= Base_Type (Etype (Low_Bound (S)))
+               or else Base_Type (T) /= Base_Type (Etype (High_Bound (S))))
+         then
+            if Base_Type (T) /= Any_Type
+              and then Etype (Low_Bound (S)) /= Any_Type
+              and then Etype (High_Bound (S)) /= Any_Type
+            then
+               Error_Msg_N ("range expected", S);
+            end if;
+         end if;
+
+      elsif Nkind (S) = N_Subtype_Indication then
+         --  the parser has verified that this is a discrete indication.
+
+         Resolve_Discrete_Subtype_Indication (S, T);
+         R := Range_Expression (Constraint (S));
+
+      elsif Nkind (S) = N_Discriminant_Association then
+
+         --  syntactically valid in subtype indication.
+
+         Error_Msg_N ("invalid index constraint", S);
+         Rewrite (S, New_Occurrence_Of (T, Sloc (S)));
+         return;
+
+      --  Subtype_Mark case, no anonymous subtypes to construct
+
+      else
+         Analyze (S);
+
+         if Is_Entity_Name (S) then
+
+            if not Is_Type (Entity (S)) then
+               Error_Msg_N ("expect subtype mark for index constraint", S);
+
+            elsif Base_Type (Entity (S)) /= Base_Type (T) then
+               Wrong_Type (S, Base_Type (T));
+            end if;
+
+            return;
+
+         else
+            Error_Msg_N ("invalid index constraint", S);
+            Rewrite (S, New_Occurrence_Of (T, Sloc (S)));
+            return;
+         end if;
+      end if;
+
+      Def_Id :=
+        Create_Itype (E_Void, Related_Nod, Related_Id, Suffix, Suffix_Index);
+
+      Set_Etype (Def_Id, Base_Type (T));
+
+      if Is_Modular_Integer_Type (T) then
+         Set_Ekind (Def_Id, E_Modular_Integer_Subtype);
+
+      elsif Is_Integer_Type (T) then
+         Set_Ekind (Def_Id, E_Signed_Integer_Subtype);
+
+      else
+         Set_Ekind (Def_Id, E_Enumeration_Subtype);
+         Set_Is_Character_Type (Def_Id, Is_Character_Type (T));
+      end if;
+
+      Set_Size_Info      (Def_Id,                (T));
+      Set_RM_Size        (Def_Id, RM_Size        (T));
+      Set_First_Rep_Item (Def_Id, First_Rep_Item (T));
+
+      --  ??? ??? is R always initialized, not at all obvious why?
+
+      Set_Scalar_Range   (Def_Id, R);
+
+      Set_Etype (S, Def_Id);
+      Set_Discrete_RM_Size (Def_Id);
+   end Constrain_Index;
+
+   -----------------------
+   -- Constrain_Integer --
+   -----------------------
+
+   procedure Constrain_Integer
+     (Def_Id      : Node_Id;
+      S           : Node_Id;
+      Related_Nod : Node_Id)
+   is
+      T : constant Entity_Id := Entity (Subtype_Mark (S));
+      C : constant Node_Id   := Constraint (S);
+
+   begin
+      Set_Scalar_Range_For_Subtype
+        (Def_Id, Range_Expression (C), T, Related_Nod);
+
+      if Is_Modular_Integer_Type (T) then
+         Set_Ekind (Def_Id, E_Modular_Integer_Subtype);
+      else
+         Set_Ekind (Def_Id, E_Signed_Integer_Subtype);
+      end if;
+
+      Set_Etype            (Def_Id, Base_Type        (T));
+      Set_Size_Info        (Def_Id,                  (T));
+      Set_First_Rep_Item   (Def_Id, First_Rep_Item   (T));
+      Set_Discrete_RM_Size (Def_Id);
+
+   end Constrain_Integer;
+
+   ------------------------------
+   -- Constrain_Ordinary_Fixed --
+   ------------------------------
+
+   procedure Constrain_Ordinary_Fixed
+     (Def_Id      : Node_Id;
+      S           : Node_Id;
+      Related_Nod : Node_Id)
+   is
+      T    : constant Entity_Id := Entity (Subtype_Mark (S));
+      C    : Node_Id;
+      D    : Node_Id;
+      Rais : Node_Id;
+
+   begin
+      Set_Ekind          (Def_Id, E_Ordinary_Fixed_Point_Subtype);
+      Set_Etype          (Def_Id, Base_Type        (T));
+      Set_Size_Info      (Def_Id,                  (T));
+      Set_First_Rep_Item (Def_Id, First_Rep_Item   (T));
+      Set_Small_Value    (Def_Id, Small_Value      (T));
+
+      --  Process the constraint
+
+      C := Constraint (S);
+
+      --  Delta constraint present
+
+      if Nkind (C) = N_Delta_Constraint then
+         D := Delta_Expression (C);
+         Analyze_And_Resolve (D, Any_Real);
+         Check_Delta_Expression (D);
+         Set_Delta_Value (Def_Id, Expr_Value_R (D));
+
+         --  Check that delta value is in range. Obviously we can do this
+         --  at compile time, but it is strictly a runtime check, and of
+         --  course there is an ACVC test that checks this!
+
+         if Delta_Value (Def_Id) < Delta_Value (T) then
+            Error_Msg_N ("?delta value is too small", D);
+            Rais := Make_Raise_Constraint_Error (Sloc (D));
+            Insert_Action (Declaration_Node (Def_Id), Rais);
+         end if;
+
+         C := Range_Constraint (C);
+
+      --  No delta constraint present
+
+      else
+         Set_Delta_Value (Def_Id, Delta_Value (T));
+      end if;
+
+      --  Range constraint present
+
+      if Nkind (C) = N_Range_Constraint then
+         Set_Scalar_Range_For_Subtype
+           (Def_Id, Range_Expression (C), T, Related_Nod);
+
+      --  No range constraint present
+
+      else
+         pragma Assert (No (C));
+         Set_Scalar_Range (Def_Id, Scalar_Range (T));
+
+      end if;
+
+      Set_Discrete_RM_Size (Def_Id);
+
+      --  Unconditionally delay the freeze, since we cannot set size
+      --  information in all cases correctly until the freeze point.
+
+      Set_Has_Delayed_Freeze (Def_Id);
+   end Constrain_Ordinary_Fixed;
+
+   ---------------------------
+   -- Convert_Scalar_Bounds --
+   ---------------------------
+
+   procedure Convert_Scalar_Bounds
+     (N            : Node_Id;
+      Parent_Type  : Entity_Id;
+      Derived_Type : Entity_Id;
+      Loc          : Source_Ptr)
+   is
+      Implicit_Base : constant Entity_Id := Base_Type (Derived_Type);
+
+      Lo  : Node_Id;
+      Hi  : Node_Id;
+      Rng : Node_Id;
+
+   begin
+      Lo := Build_Scalar_Bound
+              (Type_Low_Bound (Derived_Type),
+               Parent_Type, Implicit_Base, Loc);
+
+      Hi := Build_Scalar_Bound
+              (Type_High_Bound (Derived_Type),
+               Parent_Type, Implicit_Base, Loc);
+
+      Rng :=
+        Make_Range (Loc,
+          Low_Bound  => Lo,
+          High_Bound => Hi);
+
+      Set_Includes_Infinities (Rng, Has_Infinities (Derived_Type));
+
+      Set_Parent (Rng, N);
+      Set_Scalar_Range (Derived_Type, Rng);
+
+      --  Analyze the bounds
+
+      Analyze_And_Resolve (Lo, Implicit_Base);
+      Analyze_And_Resolve (Hi, Implicit_Base);
+
+      --  Analyze the range itself, except that we do not analyze it if
+      --  the bounds are real literals, and we have a fixed-point type.
+      --  The reason for this is that we delay setting the bounds in this
+      --  case till we know the final Small and Size values (see circuit
+      --  in Freeze.Freeze_Fixed_Point_Type for further details).
+
+      if Is_Fixed_Point_Type (Parent_Type)
+        and then Nkind (Lo) = N_Real_Literal
+        and then Nkind (Hi) = N_Real_Literal
+      then
+         return;
+
+      --  Here we do the analysis of the range.
+
+      --  Note: we do this manually, since if we do a normal Analyze and
+      --  Resolve call, there are problems with the conversions used for
+      --  the derived type range.
+
+      else
+         Set_Etype    (Rng, Implicit_Base);
+         Set_Analyzed (Rng, True);
+      end if;
+   end Convert_Scalar_Bounds;
+
+   -------------------
+   -- Copy_And_Swap --
+   -------------------
+
+   procedure Copy_And_Swap (Privat, Full : Entity_Id) is
+   begin
+      --  Initialize new full declaration entity by copying the pertinent
+      --  fields of the corresponding private declaration entity.
+
+      Copy_Private_To_Full (Privat, Full);
+
+      --  Swap the two entities. Now Privat is the full type entity and
+      --  Full is the private one. They will be swapped back at the end
+      --  of the private part. This swapping ensures that the entity that
+      --  is visible in the private part is the full declaration.
+
+      Exchange_Entities (Privat, Full);
+      Append_Entity (Full, Scope (Full));
+   end Copy_And_Swap;
+
+   -------------------------------------
+   -- Copy_Array_Base_Type_Attributes --
+   -------------------------------------
+
+   procedure Copy_Array_Base_Type_Attributes (T1, T2 : Entity_Id) is
+   begin
+      Set_Component_Alignment      (T1, Component_Alignment      (T2));
+      Set_Component_Type           (T1, Component_Type           (T2));
+      Set_Component_Size           (T1, Component_Size           (T2));
+      Set_Has_Controlled_Component (T1, Has_Controlled_Component (T2));
+      Set_Finalize_Storage_Only    (T1, Finalize_Storage_Only    (T2));
+      Set_Has_Non_Standard_Rep     (T1, Has_Non_Standard_Rep     (T2));
+      Set_Has_Task                 (T1, Has_Task                 (T2));
+      Set_Is_Packed                (T1, Is_Packed                (T2));
+      Set_Has_Aliased_Components   (T1, Has_Aliased_Components   (T2));
+      Set_Has_Atomic_Components    (T1, Has_Atomic_Components    (T2));
+      Set_Has_Volatile_Components  (T1, Has_Volatile_Components  (T2));
+   end Copy_Array_Base_Type_Attributes;
+
+   -----------------------------------
+   -- Copy_Array_Subtype_Attributes --
+   -----------------------------------
+
+   procedure Copy_Array_Subtype_Attributes (T1, T2 : Entity_Id) is
+   begin
+      Set_Size_Info (T1, T2);
+
+      Set_First_Index          (T1, First_Index           (T2));
+      Set_Is_Aliased           (T1, Is_Aliased            (T2));
+      Set_Is_Atomic            (T1, Is_Atomic             (T2));
+      Set_Is_Volatile          (T1, Is_Volatile           (T2));
+      Set_Is_Constrained       (T1, Is_Constrained        (T2));
+      Set_Depends_On_Private   (T1, Has_Private_Component (T2));
+      Set_First_Rep_Item       (T1, First_Rep_Item        (T2));
+      Set_Convention           (T1, Convention            (T2));
+      Set_Is_Limited_Composite (T1, Is_Limited_Composite  (T2));
+      Set_Is_Private_Composite (T1, Is_Private_Composite  (T2));
+   end Copy_Array_Subtype_Attributes;
+
+   --------------------------
+   -- Copy_Private_To_Full --
+   --------------------------
+
+   procedure Copy_Private_To_Full (Priv, Full : Entity_Id) is
+   begin
+      --  We temporarily set Ekind to a value appropriate for a type to
+      --  avoid assert failures in Einfo from checking for setting type
+      --  attributes on something that is not a type. Ekind (Priv) is an
+      --  appropriate choice, since it allowed the attributes to be set
+      --  in the first place. This Ekind value will be modified later.
+
+      Set_Ekind (Full, Ekind (Priv));
+
+      --  Also set Etype temporarily to Any_Type, again, in the absence
+      --  of errors, it will be properly reset, and if there are errors,
+      --  then we want a value of Any_Type to remain.
+
+      Set_Etype (Full, Any_Type);
+
+      --  Now start copying attributes
+
+      Set_Has_Discriminants          (Full, Has_Discriminants       (Priv));
+
+      if Has_Discriminants (Full) then
+         Set_Discriminant_Constraint (Full, Discriminant_Constraint (Priv));
+         Set_Girder_Constraint       (Full, Girder_Constraint       (Priv));
+      end if;
+
+      Set_Homonym                    (Full, Homonym                 (Priv));
+      Set_Is_Immediately_Visible     (Full, Is_Immediately_Visible  (Priv));
+      Set_Is_Public                  (Full, Is_Public               (Priv));
+      Set_Is_Pure                    (Full, Is_Pure                 (Priv));
+      Set_Is_Tagged_Type             (Full, Is_Tagged_Type          (Priv));
+
+      Conditional_Delay              (Full,                          Priv);
+
+      if Is_Tagged_Type (Full) then
+         Set_Primitive_Operations    (Full, Primitive_Operations    (Priv));
+
+         if Priv = Base_Type (Priv) then
+            Set_Class_Wide_Type      (Full, Class_Wide_Type         (Priv));
+         end if;
+      end if;
+
+      Set_Is_Volatile                (Full, Is_Volatile             (Priv));
+      Set_Scope                      (Full, Scope                   (Priv));
+      Set_Next_Entity                (Full, Next_Entity             (Priv));
+      Set_First_Entity               (Full, First_Entity            (Priv));
+      Set_Last_Entity                (Full, Last_Entity             (Priv));
+
+      --  If access types have been recorded for later handling, keep them
+      --  in the full view so that they get handled when the full view freeze
+      --  node is expanded.
+
+      if Present (Freeze_Node (Priv))
+        and then Present (Access_Types_To_Process (Freeze_Node (Priv)))
+      then
+         Ensure_Freeze_Node (Full);
+         Set_Access_Types_To_Process (Freeze_Node (Full),
+           Access_Types_To_Process (Freeze_Node (Priv)));
+      end if;
+   end Copy_Private_To_Full;
+
+   -----------------------------------
+   -- Create_Constrained_Components --
+   -----------------------------------
+
+   procedure Create_Constrained_Components
+     (Subt        : Entity_Id;
+      Decl_Node   : Node_Id;
+      Typ         : Entity_Id;
+      Constraints : Elist_Id)
+   is
+      Loc         : constant Source_Ptr := Sloc (Subt);
+      Assoc_List  : List_Id  := New_List;
+      Comp_List   : Elist_Id := New_Elmt_List;
+      Discr_Val   : Elmt_Id;
+      Errors      : Boolean;
+      New_C       : Entity_Id;
+      Old_C       : Entity_Id;
+      Is_Static   : Boolean := True;
+      Parent_Type : constant Entity_Id := Etype (Typ);
+
+      procedure Collect_Fixed_Components (Typ : Entity_Id);
+      --  Collect components of parent type that do not appear in a variant
+      --  part.
+
+      procedure Create_All_Components;
+      --  Iterate over Comp_List to create the components of the subtype.
+
+      function Create_Component (Old_Compon : Entity_Id) return Entity_Id;
+      --  Creates a new component from Old_Compon, coppying all the fields from
+      --  it, including its Etype, inserts the new component in the Subt entity
+      --  chain and returns the new component.
+
+      function Is_Variant_Record (T : Entity_Id) return Boolean;
+      --  If true, and discriminants are static, collect only components from
+      --  variants selected by discriminant values.
+
+      ------------------------------
+      -- Collect_Fixed_Components --
+      ------------------------------
+
+      procedure Collect_Fixed_Components (Typ : Entity_Id) is
+      begin
+      --   Build association list for discriminants, and find components of
+      --  the variant part selected by the values of the discriminants.
+
+         Old_C := First_Discriminant (Typ);
+         Discr_Val := First_Elmt (Constraints);
+
+         while Present (Old_C) loop
+            Append_To (Assoc_List,
+              Make_Component_Association (Loc,
+                 Choices    => New_List (New_Occurrence_Of (Old_C, Loc)),
+                 Expression => New_Copy (Node (Discr_Val))));
+
+            Next_Elmt (Discr_Val);
+            Next_Discriminant (Old_C);
+         end loop;
+
+         --  The tag, and the possible parent and controller components
+         --  are unconditionally in the subtype.
+
+         if Is_Tagged_Type (Typ)
+           or else Has_Controlled_Component (Typ)
+         then
+            Old_C := First_Component (Typ);
+
+            while Present (Old_C) loop
+               if Chars ((Old_C)) = Name_uTag
+                 or else Chars ((Old_C)) = Name_uParent
+                 or else Chars ((Old_C)) = Name_uController
+               then
+                  Append_Elmt (Old_C, Comp_List);
+               end if;
+
+               Next_Component (Old_C);
+            end loop;
+         end if;
+      end Collect_Fixed_Components;
+
+      ---------------------------
+      -- Create_All_Components --
+      ---------------------------
+
+      procedure Create_All_Components is
+         Comp : Elmt_Id;
+
+      begin
+         Comp := First_Elmt (Comp_List);
+
+         while Present (Comp) loop
+            Old_C := Node (Comp);
+            New_C := Create_Component (Old_C);
+
+            Set_Etype
+              (New_C,
+               Constrain_Component_Type
+                 (Etype (Old_C), Subt, Decl_Node, Typ, Constraints));
+            Set_Is_Public (New_C, Is_Public (Subt));
+
+            Next_Elmt (Comp);
+         end loop;
+      end Create_All_Components;
+
+      ----------------------
+      -- Create_Component --
+      ----------------------
+
+      function Create_Component (Old_Compon : Entity_Id) return Entity_Id is
+         New_Compon : Entity_Id := New_Copy (Old_Compon);
+
+      begin
+         --  Set the parent so we have a proper link for freezing etc. This
+         --  is not a real parent pointer, since of course our parent does
+         --  not own up to us and reference us, we are an illegitimate
+         --  child of the original parent!
+
+         Set_Parent (New_Compon, Parent (Old_Compon));
+
+         --  We do not want this node marked as Comes_From_Source, since
+         --  otherwise it would get first class status and a separate
+         --  cross-reference line would be generated. Illegitimate
+         --  children do not rate such recognition.
+
+         Set_Comes_From_Source (New_Compon, False);
+
+         --  But it is a real entity, and a birth certificate must be
+         --  properly registered by entering it into the entity list.
+
+         Enter_Name (New_Compon);
+         return New_Compon;
+      end Create_Component;
+
+      -----------------------
+      -- Is_Variant_Record --
+      -----------------------
+
+      function Is_Variant_Record (T : Entity_Id) return Boolean is
+      begin
+         return Nkind (Parent (T)) = N_Full_Type_Declaration
+           and then Nkind (Type_Definition (Parent (T))) = N_Record_Definition
+           and then Present (Component_List (Type_Definition (Parent (T))))
+           and then Present (
+             Variant_Part (Component_List (Type_Definition (Parent (T)))));
+      end Is_Variant_Record;
+
+   --  Start of processing for Create_Constrained_Components
+
+   begin
+      pragma Assert (Subt /= Base_Type (Subt));
+      pragma Assert (Typ = Base_Type (Typ));
+
+      Set_First_Entity (Subt, Empty);
+      Set_Last_Entity  (Subt, Empty);
+
+      --  Check whether constraint is fully static, in which case we can
+      --  optimize the list of components.
+
+      Discr_Val := First_Elmt (Constraints);
+
+      while Present (Discr_Val) loop
+
+         if not Is_OK_Static_Expression (Node (Discr_Val)) then
+            Is_Static := False;
+            exit;
+         end if;
+
+         Next_Elmt (Discr_Val);
+      end loop;
+
+      New_Scope (Subt);
+
+      --  Inherit the discriminants of the parent type.
+
+      Old_C := First_Discriminant (Typ);
+
+      while Present (Old_C) loop
+         New_C := Create_Component (Old_C);
+         Set_Is_Public (New_C, Is_Public (Subt));
+         Next_Discriminant (Old_C);
+      end loop;
+
+      if Is_Static
+        and then Is_Variant_Record (Typ)
+      then
+         Collect_Fixed_Components (Typ);
+
+         Gather_Components (
+           Typ,
+           Component_List (Type_Definition (Parent (Typ))),
+           Governed_By   => Assoc_List,
+           Into          => Comp_List,
+           Report_Errors => Errors);
+         pragma Assert (not Errors);
+
+         Create_All_Components;
+
+      --  If the subtype declaration is created for a tagged type derivation
+      --  with constraints, we retrieve the record definition of the parent
+      --  type to select the components of the proper variant.
+
+      elsif Is_Static
+        and then Is_Tagged_Type (Typ)
+        and then Nkind (Parent (Typ)) = N_Full_Type_Declaration
+        and then
+          Nkind (Type_Definition (Parent (Typ))) = N_Derived_Type_Definition
+        and then Is_Variant_Record (Parent_Type)
+      then
+         Collect_Fixed_Components (Typ);
+
+         Gather_Components (
+           Typ,
+           Component_List (Type_Definition (Parent (Parent_Type))),
+           Governed_By   => Assoc_List,
+           Into          => Comp_List,
+           Report_Errors => Errors);
+         pragma Assert (not Errors);
+
+         --  If the tagged derivation has a type extension, collect all the
+         --  new components therein.
+
+         if Present (
+           Record_Extension_Part (Type_Definition (Parent (Typ))))
+         then
+            Old_C := First_Component (Typ);
+
+            while Present (Old_C) loop
+               if Original_Record_Component (Old_C) = Old_C
+                and then Chars (Old_C) /= Name_uTag
+                and then Chars (Old_C) /= Name_uParent
+                and then Chars (Old_C) /= Name_uController
+               then
+                  Append_Elmt (Old_C, Comp_List);
+               end if;
+
+               Next_Component (Old_C);
+            end loop;
+         end if;
+
+         Create_All_Components;
+
+      else
+         --  If the discriminants are not static, or if this is a multi-level
+         --  type extension, we have to include all the components of the
+         --  parent type.
+
+         Old_C := First_Component (Typ);
+
+         while Present (Old_C) loop
+            New_C := Create_Component (Old_C);
+
+            Set_Etype
+              (New_C,
+               Constrain_Component_Type
+                 (Etype (Old_C), Subt, Decl_Node, Typ, Constraints));
+            Set_Is_Public (New_C, Is_Public (Subt));
+
+            Next_Component (Old_C);
+         end loop;
+      end if;
+
+      End_Scope;
+   end Create_Constrained_Components;
+
+   ------------------------------------------
+   -- Decimal_Fixed_Point_Type_Declaration --
+   ------------------------------------------
+
+   procedure Decimal_Fixed_Point_Type_Declaration
+     (T   : Entity_Id;
+      Def : Node_Id)
+   is
+      Loc           : constant Source_Ptr := Sloc (Def);
+      Digs_Expr     : constant Node_Id    := Digits_Expression (Def);
+      Delta_Expr    : constant Node_Id    := Delta_Expression (Def);
+      Implicit_Base : Entity_Id;
+      Digs_Val      : Uint;
+      Delta_Val     : Ureal;
+      Scale_Val     : Uint;
+      Bound_Val     : Ureal;
+
+   --  Start of processing for Decimal_Fixed_Point_Type_Declaration
+
+   begin
+      Check_Restriction (No_Fixed_Point, Def);
+
+      --  Create implicit base type
+
+      Implicit_Base :=
+        Create_Itype (E_Decimal_Fixed_Point_Type, Parent (Def), T, 'B');
+      Set_Etype (Implicit_Base, Implicit_Base);
+
+      --  Analyze and process delta expression
+
+      Analyze_And_Resolve (Delta_Expr, Universal_Real);
+
+      Check_Delta_Expression (Delta_Expr);
+      Delta_Val := Expr_Value_R (Delta_Expr);
+
+      --  Check delta is power of 10, and determine scale value from it
+
+      declare
+         Val : Ureal := Delta_Val;
+
+      begin
+         Scale_Val := Uint_0;
+
+         if Val < Ureal_1 then
+            while Val < Ureal_1 loop
+               Val := Val * Ureal_10;
+               Scale_Val := Scale_Val + 1;
+            end loop;
+
+            if Scale_Val > 18 then
+               Error_Msg_N ("scale exceeds maximum value of 18", Def);
+               Scale_Val := UI_From_Int (+18);
+            end if;
+
+         else
+            while Val > Ureal_1 loop
+               Val := Val / Ureal_10;
+               Scale_Val := Scale_Val - 1;
+            end loop;
+
+            if Scale_Val < -18 then
+               Error_Msg_N ("scale is less than minimum value of -18", Def);
+               Scale_Val := UI_From_Int (-18);
+            end if;
+         end if;
+
+         if Val /= Ureal_1 then
+            Error_Msg_N ("delta expression must be a power of 10", Def);
+            Delta_Val := Ureal_10 ** (-Scale_Val);
+         end if;
+      end;
+
+      --  Set delta, scale and small (small = delta for decimal type)
+
+      Set_Delta_Value (Implicit_Base, Delta_Val);
+      Set_Scale_Value (Implicit_Base, Scale_Val);
+      Set_Small_Value (Implicit_Base, Delta_Val);
+
+      --  Analyze and process digits expression
+
+      Analyze_And_Resolve (Digs_Expr, Any_Integer);
+      Check_Digits_Expression (Digs_Expr);
+      Digs_Val := Expr_Value (Digs_Expr);
+
+      if Digs_Val > 18 then
+         Digs_Val := UI_From_Int (+18);
+         Error_Msg_N ("digits value out of range, maximum is 18", Digs_Expr);
+      end if;
+
+      Set_Digits_Value (Implicit_Base, Digs_Val);
+      Bound_Val := UR_From_Uint (10 ** Digs_Val - 1) * Delta_Val;
+
+      --  Set range of base type from digits value for now. This will be
+      --  expanded to represent the true underlying base range by Freeze.
+
+      Set_Fixed_Range (Implicit_Base, Loc, -Bound_Val, Bound_Val);
+
+      --  Set size to zero for now, size will be set at freeze time. We have
+      --  to do this for ordinary fixed-point, because the size depends on
+      --  the specified small, and we might as well do the same for decimal
+      --  fixed-point.
+
+      Init_Size_Align (Implicit_Base);
+
+      --  Complete entity for first subtype
+
+      Set_Ekind          (T, E_Decimal_Fixed_Point_Subtype);
+      Set_Etype          (T, Implicit_Base);
+      Set_Size_Info      (T, Implicit_Base);
+      Set_First_Rep_Item (T, First_Rep_Item (Implicit_Base));
+      Set_Digits_Value   (T, Digs_Val);
+      Set_Delta_Value    (T, Delta_Val);
+      Set_Small_Value    (T, Delta_Val);
+      Set_Scale_Value    (T, Scale_Val);
+      Set_Is_Constrained (T);
+
+      --  If there are bounds given in the declaration use them as the
+      --  bounds of the first named subtype.
+
+      if Present (Real_Range_Specification (Def)) then
+         declare
+            RRS      : constant Node_Id := Real_Range_Specification (Def);
+            Low      : constant Node_Id := Low_Bound (RRS);
+            High     : constant Node_Id := High_Bound (RRS);
+            Low_Val  : Ureal;
+            High_Val : Ureal;
+
+         begin
+            Analyze_And_Resolve (Low, Any_Real);
+            Analyze_And_Resolve (High, Any_Real);
+            Check_Real_Bound (Low);
+            Check_Real_Bound (High);
+            Low_Val := Expr_Value_R (Low);
+            High_Val := Expr_Value_R (High);
+
+            if Low_Val < (-Bound_Val) then
+               Error_Msg_N
+                 ("range low bound too small for digits value", Low);
+               Low_Val := -Bound_Val;
+            end if;
+
+            if High_Val > Bound_Val then
+               Error_Msg_N
+                 ("range high bound too large for digits value", High);
+               High_Val := Bound_Val;
+            end if;
+
+            Set_Fixed_Range (T, Loc, Low_Val, High_Val);
+         end;
+
+      --  If no explicit range, use range that corresponds to given
+      --  digits value. This will end up as the final range for the
+      --  first subtype.
+
+      else
+         Set_Fixed_Range (T, Loc, -Bound_Val, Bound_Val);
+      end if;
+
+   end Decimal_Fixed_Point_Type_Declaration;
+
+   -----------------------
+   -- Derive_Subprogram --
+   -----------------------
+
+   procedure Derive_Subprogram
+     (New_Subp     : in out Entity_Id;
+      Parent_Subp  : Entity_Id;
+      Derived_Type : Entity_Id;
+      Parent_Type  : Entity_Id;
+      Actual_Subp  : Entity_Id := Empty)
+   is
+      Formal     : Entity_Id;
+      New_Formal : Entity_Id;
+      Same_Subt  : constant Boolean :=
+        Is_Scalar_Type (Parent_Type)
+          and then Subtypes_Statically_Compatible (Parent_Type, Derived_Type);
+
+      function Is_Private_Overriding return Boolean;
+      --  If Subp is a private overriding of a visible operation, the in-
+      --  herited operation derives from the overridden op (even though
+      --  its body is the overriding one) and the inherited operation is
+      --  visible now. See sem_disp to see the details of the handling of
+      --  the overridden subprogram, which is removed from the list of
+      --  primitive operations of the type.
+
+      procedure Replace_Type (Id, New_Id : Entity_Id);
+      --  When the type is an anonymous access type, create a new access type
+      --  designating the derived type.
+
+      ---------------------------
+      -- Is_Private_Overriding --
+      ---------------------------
+
+      function Is_Private_Overriding return Boolean is
+         Prev : Entity_Id;
+
+      begin
+         Prev := Homonym (Parent_Subp);
+
+         --  The visible operation that is overriden is a homonym of
+         --  the parent subprogram. We scan the homonym chain to find
+         --  the one whose alias is the subprogram we are deriving.
+
+         while Present (Prev) loop
+            if Is_Dispatching_Operation (Parent_Subp)
+              and then Present (Prev)
+              and then Ekind (Prev) = Ekind (Parent_Subp)
+              and then Alias (Prev) = Parent_Subp
+              and then Scope (Parent_Subp) = Scope (Prev)
+              and then not Is_Hidden (Prev)
+            then
+               return True;
+            end if;
+
+            Prev := Homonym (Prev);
+         end loop;
+
+         return False;
+      end Is_Private_Overriding;
+
+      ------------------
+      -- Replace_Type --
+      ------------------
+
+      procedure Replace_Type (Id, New_Id : Entity_Id) is
+         Acc_Type : Entity_Id;
+         IR       : Node_Id;
+
+      begin
+         --  When the type is an anonymous access type, create a new access
+         --  type designating the derived type. This itype must be elaborated
+         --  at the point of the derivation, not on subsequent calls that may
+         --  be out of the proper scope for Gigi, so we insert a reference to
+         --  it after the derivation.
+
+         if Ekind (Etype (Id)) = E_Anonymous_Access_Type then
+            declare
+               Desig_Typ : Entity_Id := Designated_Type (Etype (Id));
+
+            begin
+               if Ekind (Desig_Typ) = E_Record_Type_With_Private
+                 and then Present (Full_View (Desig_Typ))
+                 and then not Is_Private_Type (Parent_Type)
+               then
+                  Desig_Typ := Full_View (Desig_Typ);
+               end if;
+
+               if Base_Type (Desig_Typ) = Base_Type (Parent_Type) then
+                  Acc_Type := New_Copy (Etype (Id));
+                  Set_Etype (Acc_Type, Acc_Type);
+                  Set_Scope (Acc_Type, New_Subp);
+
+                  --  Compute size of anonymous access type.
+
+                  if Is_Array_Type (Desig_Typ)
+                    and then not Is_Constrained (Desig_Typ)
+                  then
+                     Init_Size (Acc_Type, 2 * System_Address_Size);
+                  else
+                     Init_Size (Acc_Type, System_Address_Size);
+                  end if;
+
+                  Init_Alignment (Acc_Type);
+
+                  Set_Directly_Designated_Type (Acc_Type, Derived_Type);
+
+                  Set_Etype (New_Id, Acc_Type);
+                  Set_Scope (New_Id, New_Subp);
+
+                  --  Create a reference to it.
+
+                  IR := Make_Itype_Reference (Sloc (Parent (Derived_Type)));
+                  Set_Itype (IR, Acc_Type);
+                  Insert_After (Parent (Derived_Type), IR);
+
+               else
+                  Set_Etype (New_Id, Etype (Id));
+               end if;
+            end;
+         elsif Base_Type (Etype (Id)) = Base_Type (Parent_Type)
+           or else
+             (Ekind (Etype (Id)) = E_Record_Type_With_Private
+               and then Present (Full_View (Etype (Id)))
+               and then Base_Type (Full_View (Etype (Id))) =
+                 Base_Type (Parent_Type))
+         then
+
+            --  Constraint checks on formals are generated during expansion,
+            --  based on the signature of the original subprogram. The bounds
+            --  of the derived type are not relevant, and thus we can use
+            --  the base type for the formals. However, the return type may be
+            --  used in a context that requires that the proper static bounds
+            --  be used (a case statement, for example)  and for those cases
+            --  we must use the derived type (first subtype), not its base.
+
+            if Etype (Id) = Parent_Type
+              and then Same_Subt
+            then
+               Set_Etype (New_Id, Derived_Type);
+            else
+               Set_Etype (New_Id, Base_Type (Derived_Type));
+            end if;
+
+         else
+            Set_Etype (New_Id, Etype (Id));
+         end if;
+      end Replace_Type;
+
+   --  Start of processing for Derive_Subprogram
+
+   begin
+      New_Subp :=
+         New_Entity (Nkind (Parent_Subp), Sloc (Derived_Type));
+      Set_Ekind (New_Subp, Ekind (Parent_Subp));
+
+      --  Check whether the inherited subprogram is a private operation that
+      --  should be inherited but not yet made visible. Such subprograms can
+      --  become visible at a later point (e.g., the private part of a public
+      --  child unit) via Declare_Inherited_Private_Subprograms. If the
+      --  following predicate is true, then this is not such a private
+      --  operation and the subprogram simply inherits the name of the parent
+      --  subprogram. Note the special check for the names of controlled
+      --  operations, which are currently exempted from being inherited with
+      --  a hidden name because they must be findable for generation of
+      --  implicit run-time calls.
+
+      if not Is_Hidden (Parent_Subp)
+        or else Is_Internal (Parent_Subp)
+        or else Is_Private_Overriding
+        or else Is_Internal_Name (Chars (Parent_Subp))
+        or else Chars (Parent_Subp) = Name_Initialize
+        or else Chars (Parent_Subp) = Name_Adjust
+        or else Chars (Parent_Subp) = Name_Finalize
+      then
+         Set_Chars (New_Subp, Chars (Parent_Subp));
+
+      --  If parent is hidden, this can be a regular derivation if the
+      --  parent is immediately visible in a non-instantiating context,
+      --  or if we are in the private part of an instance. This test
+      --  should still be refined ???
+
+      --  The test for In_Instance_Not_Visible avoids inheriting the
+      --  derived operation as a non-visible operation in cases where
+      --  the parent subprogram might not be visible now, but was
+      --  visible within the original generic, so it would be wrong
+      --  to make the inherited subprogram non-visible now. (Not
+      --  clear if this test is fully correct; are there any cases
+      --  where we should declare the inherited operation as not
+      --  visible to avoid it being overridden, e.g., when the
+      --  parent type is a generic actual with private primitives ???)
+
+      --  (they should be treated the same as other private inherited
+      --  subprograms, but it's not clear how to do this cleanly). ???
+
+      elsif (In_Open_Scopes (Scope (Base_Type (Parent_Type)))
+              and then Is_Immediately_Visible (Parent_Subp)
+              and then not In_Instance)
+        or else In_Instance_Not_Visible
+      then
+         Set_Chars (New_Subp, Chars (Parent_Subp));
+
+      --  The type is inheriting a private operation, so enter
+      --  it with a special name so it can't be overridden.
+
+      else
+         Set_Chars (New_Subp, New_External_Name (Chars (Parent_Subp), 'P'));
+      end if;
+
+      Set_Parent (New_Subp, Parent (Derived_Type));
+      Replace_Type (Parent_Subp, New_Subp);
+      Conditional_Delay (New_Subp, Parent_Subp);
+
+      Formal := First_Formal (Parent_Subp);
+      while Present (Formal) loop
+         New_Formal := New_Copy (Formal);
+
+         --  Normally we do not go copying parents, but in the case of
+         --  formals, we need to link up to the declaration (which is
+         --  the parameter specification), and it is fine to link up to
+         --  the original formal's parameter specification in this case.
+
+         Set_Parent (New_Formal, Parent (Formal));
+
+         Append_Entity (New_Formal, New_Subp);
+
+         Replace_Type (Formal, New_Formal);
+         Next_Formal (Formal);
+      end loop;
+
+      --  If this derivation corresponds to a tagged generic actual, then
+      --  primitive operations rename those of the actual. Otherwise the
+      --  primitive operations rename those of the parent type.
+
+      if No (Actual_Subp) then
+         Set_Alias (New_Subp, Parent_Subp);
+         Set_Is_Intrinsic_Subprogram (New_Subp,
+           Is_Intrinsic_Subprogram (Parent_Subp));
+
+      else
+         Set_Alias (New_Subp, Actual_Subp);
+      end if;
+
+      --  Derived subprograms of a tagged type must inherit the convention
+      --  of the parent subprogram (a requirement of AI-117). Derived
+      --  subprograms of untagged types simply get convention Ada by default.
+
+      if Is_Tagged_Type (Derived_Type) then
+         Set_Convention  (New_Subp, Convention  (Parent_Subp));
+      end if;
+
+      Set_Is_Imported (New_Subp, Is_Imported (Parent_Subp));
+      Set_Is_Exported (New_Subp, Is_Exported (Parent_Subp));
+
+      if Ekind (Parent_Subp) = E_Procedure then
+         Set_Is_Valued_Procedure
+           (New_Subp, Is_Valued_Procedure (Parent_Subp));
+      end if;
+
+      New_Overloaded_Entity (New_Subp, Derived_Type);
+
+      --  Check for case of a derived subprogram for the instantiation
+      --  of a formal derived tagged type, so mark the subprogram as
+      --  dispatching and inherit the dispatching attributes of the
+      --  parent subprogram. The derived subprogram is effectively a
+      --  renaming of the actual subprogram, so it needs to have the
+      --  same attributes as the actual.
+
+      if Present (Actual_Subp)
+        and then Is_Dispatching_Operation (Parent_Subp)
+      then
+         Set_Is_Dispatching_Operation (New_Subp);
+         if Present (DTC_Entity (Parent_Subp)) then
+            Set_DTC_Entity (New_Subp, DTC_Entity (Parent_Subp));
+            Set_DT_Position (New_Subp, DT_Position (Parent_Subp));
+         end if;
+      end if;
+
+      --  Indicate that a derived subprogram does not require a body
+      --  and that it does not require processing of default expressions.
+
+      Set_Has_Completion (New_Subp);
+      Set_Default_Expressions_Processed (New_Subp);
+
+      --  A derived function with a controlling result is abstract.
+      --  If the Derived_Type is a nonabstract formal generic derived
+      --  type, then inherited operations are not abstract: check is
+      --  done at instantiation time. If the derivation is for a generic
+      --  actual, the function is not abstract unless the actual is.
+
+      if Is_Generic_Type (Derived_Type)
+        and then not Is_Abstract (Derived_Type)
+      then
+         null;
+
+      elsif Is_Abstract (Alias (New_Subp))
+        or else (Is_Tagged_Type (Derived_Type)
+                   and then Etype (New_Subp) = Derived_Type
+                   and then No (Actual_Subp))
+      then
+         Set_Is_Abstract (New_Subp);
+      end if;
+
+      if Ekind (New_Subp) = E_Function then
+         Set_Mechanism (New_Subp, Mechanism (Parent_Subp));
+      end if;
+   end Derive_Subprogram;
+
+   ------------------------
+   -- Derive_Subprograms --
+   ------------------------
+
+   procedure Derive_Subprograms
+     (Parent_Type    : Entity_Id;
+      Derived_Type   : Entity_Id;
+      Generic_Actual : Entity_Id := Empty)
+   is
+      Op_List     : Elist_Id := Collect_Primitive_Operations (Parent_Type);
+      Act_List    : Elist_Id;
+      Act_Elmt    : Elmt_Id;
+      Elmt        : Elmt_Id;
+      Subp        : Entity_Id;
+      New_Subp    : Entity_Id := Empty;
+      Parent_Base : Entity_Id;
+
+   begin
+      if Ekind (Parent_Type) = E_Record_Type_With_Private
+        and then Has_Discriminants (Parent_Type)
+        and then Present (Full_View (Parent_Type))
+      then
+         Parent_Base := Full_View (Parent_Type);
+      else
+         Parent_Base := Parent_Type;
+      end if;
+
+      Elmt := First_Elmt (Op_List);
+
+      if Present (Generic_Actual) then
+         Act_List := Collect_Primitive_Operations (Generic_Actual);
+         Act_Elmt := First_Elmt (Act_List);
+      else
+         Act_Elmt := No_Elmt;
+      end if;
+
+      --  Literals are derived earlier in the process of building the
+      --  derived type, and are skipped here.
+
+      while Present (Elmt) loop
+         Subp := Node (Elmt);
+
+         if Ekind (Subp) /= E_Enumeration_Literal then
+            if No (Generic_Actual) then
+               Derive_Subprogram
+                 (New_Subp, Subp, Derived_Type, Parent_Base);
+
+            else
+               Derive_Subprogram (New_Subp, Subp,
+                 Derived_Type, Parent_Base, Node (Act_Elmt));
+               Next_Elmt (Act_Elmt);
+            end if;
+         end if;
+
+         Next_Elmt (Elmt);
+      end loop;
+   end Derive_Subprograms;
+
+   --------------------------------
+   -- Derived_Standard_Character --
+   --------------------------------
+
+   procedure Derived_Standard_Character
+     (N             : Node_Id;
+      Parent_Type   : Entity_Id;
+      Derived_Type  : Entity_Id)
+   is
+      Loc           : constant Source_Ptr := Sloc (N);
+      Def           : constant Node_Id    := Type_Definition (N);
+      Indic         : constant Node_Id    := Subtype_Indication (Def);
+      Parent_Base   : constant Entity_Id  := Base_Type (Parent_Type);
+      Implicit_Base : constant Entity_Id  :=
+                        Create_Itype
+                          (E_Enumeration_Type, N, Derived_Type, 'B');
+
+      Lo : Node_Id;
+      Hi : Node_Id;
+      T  : Entity_Id;
+
+   begin
+      T := Process_Subtype (Indic, N);
+
+      Set_Etype     (Implicit_Base, Parent_Base);
+      Set_Size_Info (Implicit_Base, Root_Type (Parent_Type));
+      Set_RM_Size   (Implicit_Base, RM_Size (Root_Type (Parent_Type)));
+
+      Set_Is_Character_Type  (Implicit_Base, True);
+      Set_Has_Delayed_Freeze (Implicit_Base);
+
+      Lo := New_Copy_Tree (Type_Low_Bound  (Parent_Type));
+      Hi := New_Copy_Tree (Type_High_Bound (Parent_Type));
+
+      Set_Scalar_Range (Implicit_Base,
+        Make_Range (Loc,
+          Low_Bound  => Lo,
+          High_Bound => Hi));
+
+      Conditional_Delay (Derived_Type, Parent_Type);
+
+      Set_Ekind (Derived_Type, E_Enumeration_Subtype);
+      Set_Etype (Derived_Type, Implicit_Base);
+      Set_Size_Info         (Derived_Type, Parent_Type);
+
+      if Unknown_RM_Size (Derived_Type) then
+         Set_RM_Size (Derived_Type, RM_Size (Parent_Type));
+      end if;
+
+      Set_Is_Character_Type (Derived_Type, True);
+
+      if Nkind (Indic) /= N_Subtype_Indication then
+         Set_Scalar_Range (Derived_Type, Scalar_Range (Implicit_Base));
+      end if;
+
+      Convert_Scalar_Bounds (N, Parent_Type, Derived_Type, Loc);
+
+      --  Because the implicit base is used in the conversion of the bounds,
+      --  we have to freeze it now. This is similar to what is done for
+      --  numeric types, and it equally suspicious, but otherwise a non-
+      --  static bound will have a reference to an unfrozen type, which is
+      --  rejected by Gigi (???).
+
+      Freeze_Before (N, Implicit_Base);
+
+   end Derived_Standard_Character;
+
+   ------------------------------
+   -- Derived_Type_Declaration --
+   ------------------------------
+
+   procedure Derived_Type_Declaration
+     (T             : Entity_Id;
+      N             : Node_Id;
+      Is_Completion : Boolean)
+   is
+      Def          : constant Node_Id := Type_Definition (N);
+      Indic        : constant Node_Id := Subtype_Indication (Def);
+      Extension    : constant Node_Id := Record_Extension_Part (Def);
+      Parent_Type  : Entity_Id;
+      Parent_Scope : Entity_Id;
+      Taggd        : Boolean;
+
+   begin
+      Parent_Type := Find_Type_Of_Subtype_Indic (Indic);
+
+      if Parent_Type = Any_Type
+        or else Etype (Parent_Type) = Any_Type
+        or else (Is_Class_Wide_Type (Parent_Type)
+                  and then Etype (Parent_Type) = T)
+      then
+         --  If Parent_Type is undefined or illegal, make new type into
+         --  a subtype of Any_Type, and set a few attributes to prevent
+         --  cascaded errors. If this is a self-definition, emit error now.
+
+         if T = Parent_Type
+           or else T = Etype (Parent_Type)
+         then
+            Error_Msg_N ("type cannot be used in its own definition", Indic);
+         end if;
+
+         Set_Ekind        (T, Ekind (Parent_Type));
+         Set_Etype        (T, Any_Type);
+         Set_Scalar_Range (T, Scalar_Range (Any_Type));
+
+         if Is_Tagged_Type (T) then
+            Set_Primitive_Operations (T, New_Elmt_List);
+         end if;
+         return;
+
+      elsif Is_Unchecked_Union (Parent_Type) then
+         Error_Msg_N ("cannot derive from Unchecked_Union type", N);
+      end if;
+
+      --  Only composite types other than array types are allowed to have
+      --  discriminants.
+
+      if Present (Discriminant_Specifications (N))
+        and then (Is_Elementary_Type (Parent_Type)
+                  or else Is_Array_Type (Parent_Type))
+        and then not Error_Posted (N)
+      then
+         Error_Msg_N
+           ("elementary or array type cannot have discriminants",
+            Defining_Identifier (First (Discriminant_Specifications (N))));
+         Set_Has_Discriminants (T, False);
+      end if;
+
+      --  In Ada 83, a derived type defined in a package specification cannot
+      --  be used for further derivation until the end of its visible part.
+      --  Note that derivation in the private part of the package is allowed.
+
+      if Ada_83
+        and then Is_Derived_Type (Parent_Type)
+        and then In_Visible_Part (Scope (Parent_Type))
+      then
+         if Ada_83 and then Comes_From_Source (Indic) then
+            Error_Msg_N
+              ("(Ada 83): premature use of type for derivation", Indic);
+         end if;
+      end if;
+
+      --  Check for early use of incomplete or private type
+
+      if Ekind (Parent_Type) = E_Void
+        or else Ekind (Parent_Type) = E_Incomplete_Type
+      then
+         Error_Msg_N ("premature derivation of incomplete type", Indic);
+         return;
+
+      elsif (Is_Incomplete_Or_Private_Type (Parent_Type)
+              and then not Is_Generic_Type (Parent_Type)
+              and then not Is_Generic_Type (Root_Type (Parent_Type))
+              and then not Is_Generic_Actual_Type (Parent_Type))
+        or else Has_Private_Component (Parent_Type)
+      then
+         --  The ancestor type of a formal type can be incomplete, in which
+         --  case only the operations of the partial view are available in
+         --  the generic. Subsequent checks may be required when the full
+         --  view is analyzed, to verify that derivation from a tagged type
+         --  has an extension.
+
+         if Nkind (Original_Node (N)) = N_Formal_Type_Declaration then
+            null;
+
+         elsif No (Underlying_Type (Parent_Type))
+           or else Has_Private_Component (Parent_Type)
+         then
+            Error_Msg_N
+              ("premature derivation of derived or private type", Indic);
+
+            --  Flag the type itself as being in error, this prevents some
+            --  nasty problems with people looking at the malformed type.
+
+            Set_Error_Posted (T);
+
+         --  Check that within the immediate scope of an untagged partial
+         --  view it's illegal to derive from the partial view if the
+         --  full view is tagged. (7.3(7))
+
+         --  We verify that the Parent_Type is a partial view by checking
+         --  that it is not a Full_Type_Declaration (i.e. a private type or
+         --  private extension declaration), to distinguish a partial view
+         --  from  a derivation from a private type which also appears as
+         --  E_Private_Type.
+
+         elsif Present (Full_View (Parent_Type))
+           and then Nkind (Parent (Parent_Type)) /= N_Full_Type_Declaration
+           and then not Is_Tagged_Type (Parent_Type)
+           and then Is_Tagged_Type (Full_View (Parent_Type))
+         then
+            Parent_Scope := Scope (T);
+            while Present (Parent_Scope)
+              and then Parent_Scope /= Standard_Standard
+            loop
+               if Parent_Scope = Scope (Parent_Type) then
+                  Error_Msg_N
+                    ("premature derivation from type with tagged full view",
+                     Indic);
+               end if;
+
+               Parent_Scope := Scope (Parent_Scope);
+            end loop;
+         end if;
+      end if;
+
+      --  Check that form of derivation is appropriate
+
+      Taggd := Is_Tagged_Type (Parent_Type);
+
+      --  Perhaps the parent type should be changed to the class-wide type's
+      --  specific type in this case to prevent cascading errors ???
+
+      if Present (Extension) and then Is_Class_Wide_Type (Parent_Type) then
+         Error_Msg_N ("parent type must not be a class-wide type", Indic);
+         return;
+      end if;
+
+      if Present (Extension) and then not Taggd then
+         Error_Msg_N
+           ("type derived from untagged type cannot have extension", Indic);
+
+      elsif No (Extension) and then Taggd then
+         --  If this is within a private part (or body) of a generic
+         --  instantiation then the derivation is allowed (the parent
+         --  type can only appear tagged in this case if it's a generic
+         --  actual type, since it would otherwise have been rejected
+         --  in the analysis of the generic template).
+
+         if not Is_Generic_Actual_Type (Parent_Type)
+           or else In_Visible_Part (Scope (Parent_Type))
+         then
+            Error_Msg_N
+              ("type derived from tagged type must have extension", Indic);
+         end if;
+      end if;
+
+      Build_Derived_Type (N, Parent_Type, T, Is_Completion);
+   end Derived_Type_Declaration;
+
+   ----------------------------------
+   -- Enumeration_Type_Declaration --
+   ----------------------------------
+
+   procedure Enumeration_Type_Declaration (T : Entity_Id; Def : Node_Id) is
+      Ev     : Uint;
+      L      : Node_Id;
+      R_Node : Node_Id;
+      B_Node : Node_Id;
+
+   begin
+      --  Create identifier node representing lower bound
+
+      B_Node := New_Node (N_Identifier, Sloc (Def));
+      L := First (Literals (Def));
+      Set_Chars (B_Node, Chars (L));
+      Set_Entity (B_Node,  L);
+      Set_Etype (B_Node, T);
+      Set_Is_Static_Expression (B_Node, True);
+
+      R_Node := New_Node (N_Range, Sloc (Def));
+      Set_Low_Bound  (R_Node, B_Node);
+
+      Set_Ekind (T, E_Enumeration_Type);
+      Set_First_Literal (T, L);
+      Set_Etype (T, T);
+      Set_Is_Constrained (T);
+
+      Ev := Uint_0;
+
+      --  Loop through literals of enumeration type setting pos and rep values
+      --  except that if the Ekind is already set, then it means that the
+      --  literal was already constructed (case of a derived type declaration
+      --  and we should not disturb the Pos and Rep values.
+
+      while Present (L) loop
+         if Ekind (L) /= E_Enumeration_Literal then
+            Set_Ekind (L, E_Enumeration_Literal);
+            Set_Enumeration_Pos (L, Ev);
+            Set_Enumeration_Rep (L, Ev);
+            Set_Is_Known_Valid  (L, True);
+         end if;
+
+         Set_Etype (L, T);
+         New_Overloaded_Entity (L);
+         Generate_Definition (L);
+         Set_Convention (L, Convention_Intrinsic);
+
+         if Nkind (L) = N_Defining_Character_Literal then
+            Set_Is_Character_Type (T, True);
+         end if;
+
+         Ev := Ev + 1;
+         Next (L);
+      end loop;
+
+      --  Now create a node representing upper bound
+
+      B_Node := New_Node (N_Identifier, Sloc (Def));
+      Set_Chars (B_Node, Chars (Last (Literals (Def))));
+      Set_Entity (B_Node,  Last (Literals (Def)));
+      Set_Etype (B_Node, T);
+      Set_Is_Static_Expression (B_Node, True);
+
+      Set_High_Bound (R_Node, B_Node);
+      Set_Scalar_Range (T, R_Node);
+      Set_RM_Size (T, UI_From_Int (Minimum_Size (T)));
+      Set_Enum_Esize (T);
+
+      --  Set Discard_Names if configuration pragma setg, or if there is
+      --  a parameterless pragma in the current declarative region
+
+      if Global_Discard_Names
+        or else Discard_Names (Scope (T))
+      then
+         Set_Discard_Names (T);
+      end if;
+   end Enumeration_Type_Declaration;
+
+   --------------------------
+   -- Expand_Others_Choice --
+   --------------------------
+
+   procedure Expand_Others_Choice
+     (Case_Table    : Choice_Table_Type;
+      Others_Choice : Node_Id;
+      Choice_Type   : Entity_Id)
+   is
+      Choice      : Node_Id;
+      Choice_List : List_Id := New_List;
+      Exp_Lo      : Node_Id;
+      Exp_Hi      : Node_Id;
+      Hi          : Uint;
+      Lo          : Uint;
+      Loc         : Source_Ptr := Sloc (Others_Choice);
+      Previous_Hi : Uint;
+
+      function Build_Choice (Value1, Value2 : Uint) return Node_Id;
+      --  Builds a node representing the missing choices given by the
+      --  Value1 and Value2. A N_Range node is built if there is more than
+      --  one literal value missing. Otherwise a single N_Integer_Literal,
+      --  N_Identifier or N_Character_Literal is built depending on what
+      --  Choice_Type is.
+
+      function Lit_Of (Value : Uint) return Node_Id;
+      --  Returns the Node_Id for the enumeration literal corresponding to the
+      --  position given by Value within the enumeration type Choice_Type.
+
+      ------------------
+      -- Build_Choice --
+      ------------------
+
+      function Build_Choice (Value1, Value2 : Uint) return Node_Id is
+         Lit_Node : Node_Id;
+         Lo, Hi   : Node_Id;
+
+      begin
+         --  If there is only one choice value missing between Value1 and
+         --  Value2, build an integer or enumeration literal to represent it.
+
+         if (Value2 - Value1) = 0 then
+            if Is_Integer_Type (Choice_Type) then
+               Lit_Node := Make_Integer_Literal (Loc, Value1);
+               Set_Etype (Lit_Node, Choice_Type);
+            else
+               Lit_Node := Lit_Of (Value1);
+            end if;
+
+         --  Otherwise is more that one choice value that is missing between
+         --  Value1 and Value2, therefore build a N_Range node of either
+         --  integer or enumeration literals.
+
+         else
+            if Is_Integer_Type (Choice_Type) then
+               Lo := Make_Integer_Literal (Loc, Value1);
+               Set_Etype (Lo, Choice_Type);
+               Hi := Make_Integer_Literal (Loc, Value2);
+               Set_Etype (Hi, Choice_Type);
+               Lit_Node :=
+                 Make_Range (Loc,
+                   Low_Bound  => Lo,
+                   High_Bound => Hi);
+
+            else
+               Lit_Node :=
+                 Make_Range (Loc,
+                   Low_Bound  => Lit_Of (Value1),
+                   High_Bound => Lit_Of (Value2));
+            end if;
+         end if;
+
+         return Lit_Node;
+      end Build_Choice;
+
+      ------------
+      -- Lit_Of --
+      ------------
+
+      function Lit_Of (Value : Uint) return Node_Id is
+         Lit : Entity_Id;
+
+      begin
+         --  In the case where the literal is of type Character, there needs
+         --  to be some special handling since there is no explicit chain
+         --  of literals to search. Instead, a N_Character_Literal node
+         --  is created with the appropriate Char_Code and Chars fields.
+
+         if Root_Type (Choice_Type) = Standard_Character then
+            Set_Character_Literal_Name (Char_Code (UI_To_Int (Value)));
+            Lit := New_Node (N_Character_Literal, Loc);
+            Set_Chars (Lit, Name_Find);
+            Set_Char_Literal_Value (Lit, Char_Code (UI_To_Int (Value)));
+            Set_Etype (Lit, Choice_Type);
+            Set_Is_Static_Expression (Lit, True);
+            return Lit;
+
+         --  Otherwise, iterate through the literals list of Choice_Type
+         --  "Value" number of times until the desired literal is reached
+         --  and then return an occurrence of it.
+
+         else
+            Lit := First_Literal (Choice_Type);
+            for J in 1 .. UI_To_Int (Value) loop
+               Next_Literal (Lit);
+            end loop;
+
+            return New_Occurrence_Of (Lit, Loc);
+         end if;
+      end Lit_Of;
+
+   --  Start of processing for Expand_Others_Choice
+
+   begin
+      if Case_Table'Length = 0 then
+
+         --  Pathological case: only an others case is present.
+         --  The others case covers the full range of the type.
+
+         if Is_Static_Subtype (Choice_Type) then
+            Choice := New_Occurrence_Of (Choice_Type, Loc);
+         else
+            Choice := New_Occurrence_Of (Base_Type (Choice_Type), Loc);
+         end if;
+
+         Set_Others_Discrete_Choices (Others_Choice, New_List (Choice));
+         return;
+      end if;
+
+      --  Establish the bound values for the variant depending upon whether
+      --  the type of the discriminant name is static or not.
+
+      if Is_OK_Static_Subtype (Choice_Type) then
+         Exp_Lo := Type_Low_Bound (Choice_Type);
+         Exp_Hi := Type_High_Bound (Choice_Type);
+      else
+         Exp_Lo := Type_Low_Bound (Base_Type (Choice_Type));
+         Exp_Hi := Type_High_Bound (Base_Type (Choice_Type));
+      end if;
+
+      Lo := Expr_Value (Case_Table (Case_Table'First).Lo);
+      Hi := Expr_Value (Case_Table (Case_Table'First).Hi);
+      Previous_Hi := Expr_Value (Case_Table (Case_Table'First).Hi);
+
+      --  Build the node for any missing choices that are smaller than any
+      --  explicit choices given in the variant.
+
+      if Expr_Value (Exp_Lo) < Lo then
+         Append (Build_Choice (Expr_Value (Exp_Lo), Lo - 1), Choice_List);
+      end if;
+
+      --  Build the nodes representing any missing choices that lie between
+      --  the explicit ones given in the variant.
+
+      for J in Case_Table'First + 1 .. Case_Table'Last loop
+         Lo := Expr_Value (Case_Table (J).Lo);
+         Hi := Expr_Value (Case_Table (J).Hi);
+
+         if Lo /= (Previous_Hi + 1) then
+            Append_To (Choice_List, Build_Choice (Previous_Hi + 1, Lo - 1));
+         end if;
+
+         Previous_Hi := Hi;
+      end loop;
+
+      --  Build the node for any missing choices that are greater than any
+      --  explicit choices given in the variant.
+
+      if Expr_Value (Exp_Hi) > Hi then
+         Append (Build_Choice (Hi + 1, Expr_Value (Exp_Hi)), Choice_List);
+      end if;
+
+      Set_Others_Discrete_Choices (Others_Choice, Choice_List);
+   end Expand_Others_Choice;
+
+   ---------------------------------
+   -- Expand_To_Girder_Constraint --
+   ---------------------------------
+
+   function Expand_To_Girder_Constraint
+     (Typ        : Entity_Id;
+      Constraint : Elist_Id)
+      return       Elist_Id
+   is
+      Explicitly_Discriminated_Type : Entity_Id;
+      Expansion    : Elist_Id;
+      Discriminant : Entity_Id;
+
+      function Type_With_Explicit_Discrims (Id : Entity_Id) return Entity_Id;
+      --  Find the nearest type that actually specifies discriminants.
+
+      ---------------------------------
+      -- Type_With_Explicit_Discrims --
+      ---------------------------------
+
+      function Type_With_Explicit_Discrims (Id : Entity_Id) return Entity_Id is
+         Typ : constant E := Base_Type (Id);
+
+      begin
+         if Ekind (Typ) in Incomplete_Or_Private_Kind then
+            if Present (Full_View (Typ)) then
+               return Type_With_Explicit_Discrims (Full_View (Typ));
+            end if;
+
+         else
+            if Has_Discriminants (Typ) then
+               return Typ;
+            end if;
+         end if;
+
+         if Etype (Typ) = Typ then
+            return Empty;
+         elsif Has_Discriminants (Typ) then
+            return Typ;
+         else
+            return Type_With_Explicit_Discrims (Etype (Typ));
+         end if;
+
+      end Type_With_Explicit_Discrims;
+
+   --  Start of processing for Expand_To_Girder_Constraint
+
+   begin
+      if No (Constraint)
+        or else Is_Empty_Elmt_List (Constraint)
+      then
+         return No_Elist;
+      end if;
+
+      Explicitly_Discriminated_Type := Type_With_Explicit_Discrims (Typ);
+
+      if No (Explicitly_Discriminated_Type) then
+         return No_Elist;
+      end if;
+
+      Expansion := New_Elmt_List;
+
+      Discriminant :=
+         First_Girder_Discriminant (Explicitly_Discriminated_Type);
+
+      while Present (Discriminant) loop
+
+         Append_Elmt (
+           Get_Discriminant_Value (
+             Discriminant, Explicitly_Discriminated_Type, Constraint),
+           Expansion);
+
+         Next_Girder_Discriminant (Discriminant);
+      end loop;
+
+      return Expansion;
+   end Expand_To_Girder_Constraint;
+
+   --------------------
+   -- Find_Type_Name --
+   --------------------
+
+   function Find_Type_Name (N : Node_Id) return Entity_Id is
+      Id       : constant Entity_Id := Defining_Identifier (N);
+      Prev     : Entity_Id;
+      New_Id   : Entity_Id;
+      Prev_Par : Node_Id;
+
+   begin
+      --  Find incomplete declaration, if some was given.
+
+      Prev := Current_Entity_In_Scope (Id);
+
+      if Present (Prev) then
+
+         --  Previous declaration exists. Error if not incomplete/private case
+         --  except if previous declaration is implicit, etc. Enter_Name will
+         --  emit error if appropriate.
+
+         Prev_Par := Parent (Prev);
+
+         if not Is_Incomplete_Or_Private_Type (Prev) then
+            Enter_Name (Id);
+            New_Id := Id;
+
+         elsif Nkind (N) /= N_Full_Type_Declaration
+           and then Nkind (N) /= N_Task_Type_Declaration
+           and then Nkind (N) /= N_Protected_Type_Declaration
+         then
+            --  Completion must be a full type declarations (RM 7.3(4))
+
+            Error_Msg_Sloc := Sloc (Prev);
+            Error_Msg_NE ("invalid completion of }", Id, Prev);
+
+            --  Set scope of Id to avoid cascaded errors. Entity is never
+            --  examined again, except when saving globals in generics.
+
+            Set_Scope (Id, Current_Scope);
+            New_Id := Id;
+
+         --  Case of full declaration of incomplete type
+
+         elsif Ekind (Prev) = E_Incomplete_Type then
+
+            --  Indicate that the incomplete declaration has a matching
+            --  full declaration. The defining occurrence of the incomplete
+            --  declaration remains the visible one, and the procedure
+            --  Get_Full_View dereferences it whenever the type is used.
+
+            if Present (Full_View (Prev)) then
+               Error_Msg_NE ("invalid redeclaration of }", Id, Prev);
+            end if;
+
+            Set_Full_View (Prev,  Id);
+            Append_Entity (Id, Current_Scope);
+            Set_Is_Public (Id, Is_Public (Prev));
+            Set_Is_Internal (Id);
+            New_Id := Prev;
+
+         --  Case of full declaration of private type
+
+         else
+            if Nkind (Parent (Prev)) /= N_Private_Extension_Declaration then
+               if Etype (Prev) /= Prev then
+
+                  --  Prev is a private subtype or a derived type, and needs
+                  --  no completion.
+
+                  Error_Msg_NE ("invalid redeclaration of }", Id, Prev);
+                  New_Id := Id;
+
+               elsif Ekind (Prev) = E_Private_Type
+                 and then
+                   (Nkind (N) = N_Task_Type_Declaration
+                     or else Nkind (N) = N_Protected_Type_Declaration)
+               then
+                  Error_Msg_N
+                   ("completion of nonlimited type cannot be limited", N);
+               end if;
+
+            elsif Nkind (N) /= N_Full_Type_Declaration
+              or else Nkind (Type_Definition (N)) /= N_Derived_Type_Definition
+            then
+               Error_Msg_N ("full view of private extension must be"
+                 & " an extension", N);
+
+            elsif not (Abstract_Present (Parent (Prev)))
+              and then Abstract_Present (Type_Definition (N))
+            then
+               Error_Msg_N ("full view of non-abstract extension cannot"
+                 & " be abstract", N);
+            end if;
+
+            if not In_Private_Part (Current_Scope) then
+               Error_Msg_N
+                 ("declaration of full view must appear in private part",  N);
+            end if;
+
+            Copy_And_Swap (Prev, Id);
+            Set_Full_View (Id, Prev);
+            Set_Has_Private_Declaration (Prev);
+            Set_Has_Private_Declaration (Id);
+            New_Id := Prev;
+         end if;
+
+         --  Verify that full declaration conforms to incomplete one
+
+         if Is_Incomplete_Or_Private_Type (Prev)
+           and then Present (Discriminant_Specifications (Prev_Par))
+         then
+            if Present (Discriminant_Specifications (N)) then
+               if Ekind (Prev) = E_Incomplete_Type then
+                  Check_Discriminant_Conformance (N, Prev, Prev);
+               else
+                  Check_Discriminant_Conformance (N, Prev, Id);
+               end if;
+
+            else
+               Error_Msg_N
+                 ("missing discriminants in full type declaration", N);
+
+               --  To avoid cascaded errors on subsequent use, share the
+               --  discriminants of the partial view.
+
+               Set_Discriminant_Specifications (N,
+                 Discriminant_Specifications (Prev_Par));
+            end if;
+         end if;
+
+         --  A prior untagged private type can have an associated
+         --  class-wide type due to use of the class attribute,
+         --  and in this case also the full type is required to
+         --  be tagged.
+
+         if Is_Type (Prev)
+           and then (Is_Tagged_Type (Prev)
+                      or else Present (Class_Wide_Type (Prev)))
+         then
+            --  The full declaration is either a tagged record or an
+            --  extension otherwise this is an error
+
+            if Nkind (Type_Definition (N)) = N_Record_Definition then
+               if not Tagged_Present (Type_Definition (N)) then
+                  Error_Msg_NE
+                    ("full declaration of } must be tagged", Prev, Id);
+                  Set_Is_Tagged_Type (Id);
+                  Set_Primitive_Operations (Id, New_Elmt_List);
+               end if;
+
+            elsif Nkind (Type_Definition (N)) = N_Derived_Type_Definition then
+               if No (Record_Extension_Part (Type_Definition (N))) then
+                  Error_Msg_NE (
+                    "full declaration of } must be a record extension",
+                    Prev, Id);
+                  Set_Is_Tagged_Type (Id);
+                  Set_Primitive_Operations (Id, New_Elmt_List);
+               end if;
+
+            else
+               Error_Msg_NE
+                 ("full declaration of } must be a tagged type", Prev, Id);
+
+            end if;
+         end if;
+
+         return New_Id;
+
+      else
+         --  New type declaration
+
+         Enter_Name (Id);
+         return Id;
+      end if;
+   end Find_Type_Name;
+
+   -------------------------
+   -- Find_Type_Of_Object --
+   -------------------------
+
+   function Find_Type_Of_Object
+     (Obj_Def     : Node_Id;
+      Related_Nod : Node_Id)
+      return        Entity_Id
+   is
+      Def_Kind : constant Node_Kind := Nkind (Obj_Def);
+      P        : constant Node_Id   := Parent (Obj_Def);
+      T        : Entity_Id;
+      Nam      : Name_Id;
+
+   begin
+      --  Case of an anonymous array subtype
+
+      if Def_Kind = N_Constrained_Array_Definition
+        or else Def_Kind = N_Unconstrained_Array_Definition
+      then
+         T := Empty;
+         Array_Type_Declaration (T, Obj_Def);
+
+      --  Create an explicit subtype whenever possible.
+
+      elsif Nkind (P) /= N_Component_Declaration
+        and then Def_Kind = N_Subtype_Indication
+      then
+         --  Base name of subtype on object name, which will be unique in
+         --  the current scope.
+
+         --  If this is a duplicate declaration, return base type, to avoid
+         --  generating duplicate anonymous types.
+
+         if Error_Posted (P) then
+            Analyze (Subtype_Mark (Obj_Def));
+            return Entity (Subtype_Mark (Obj_Def));
+         end if;
+
+         Nam :=
+            New_External_Name
+             (Chars (Defining_Identifier (Related_Nod)), 'S', 0, 'T');
+
+         T := Make_Defining_Identifier (Sloc (P), Nam);
+
+         Insert_Action (Obj_Def,
+           Make_Subtype_Declaration (Sloc (P),
+             Defining_Identifier => T,
+             Subtype_Indication  => Relocate_Node (Obj_Def)));
+
+         --  This subtype may need freezing and it will not be done
+         --  automatically if the object declaration is not in a
+         --  declarative part. Since this is an object declaration, the
+         --  type cannot always be frozen here. Deferred constants do not
+         --  freeze their type (which often enough will be private).
+
+         if Nkind (P) = N_Object_Declaration
+           and then Constant_Present (P)
+           and then No (Expression (P))
+         then
+            null;
+
+         else
+            Insert_Actions (Obj_Def, Freeze_Entity (T, Sloc (P)));
+         end if;
+
+      else
+         T := Process_Subtype (Obj_Def, Related_Nod);
+      end if;
+
+      return T;
+   end Find_Type_Of_Object;
+
+   --------------------------------
+   -- Find_Type_Of_Subtype_Indic --
+   --------------------------------
+
+   function Find_Type_Of_Subtype_Indic (S : Node_Id) return Entity_Id is
+      Typ : Entity_Id;
+
+   begin
+      --  Case of subtype mark with a constraint
+
+      if Nkind (S) = N_Subtype_Indication then
+         Find_Type (Subtype_Mark (S));
+         Typ := Entity (Subtype_Mark (S));
+
+         if not
+           Is_Valid_Constraint_Kind (Ekind (Typ), Nkind (Constraint (S)))
+         then
+            Error_Msg_N
+              ("incorrect constraint for this kind of type", Constraint (S));
+            Rewrite (S, New_Copy_Tree (Subtype_Mark (S)));
+         end if;
+
+      --  Otherwise we have a subtype mark without a constraint
+
+      else
+         Find_Type (S);
+         Typ := Entity (S);
+      end if;
+
+      if Typ = Standard_Wide_Character
+        or else Typ = Standard_Wide_String
+      then
+         Check_Restriction (No_Wide_Characters, S);
+      end if;
+
+      return Typ;
+   end Find_Type_Of_Subtype_Indic;
+
+   -------------------------------------
+   -- Floating_Point_Type_Declaration --
+   -------------------------------------
+
+   procedure Floating_Point_Type_Declaration (T : Entity_Id; Def : Node_Id) is
+      Digs          : constant Node_Id := Digits_Expression (Def);
+      Digs_Val      : Uint;
+      Base_Typ      : Entity_Id;
+      Implicit_Base : Entity_Id;
+      Bound         : Node_Id;
+
+      function Can_Derive_From (E : Entity_Id) return Boolean;
+      --  Find if given digits value allows derivation from specified type
+
+      function Can_Derive_From (E : Entity_Id) return Boolean is
+         Spec : constant Entity_Id := Real_Range_Specification (Def);
+
+      begin
+         if Digs_Val > Digits_Value (E) then
+            return False;
+         end if;
+
+         if Present (Spec) then
+            if Expr_Value_R (Type_Low_Bound (E)) >
+               Expr_Value_R (Low_Bound (Spec))
+            then
+               return False;
+            end if;
+
+            if Expr_Value_R (Type_High_Bound (E)) <
+               Expr_Value_R (High_Bound (Spec))
+            then
+               return False;
+            end if;
+         end if;
+
+         return True;
+      end Can_Derive_From;
+
+   --  Start of processing for Floating_Point_Type_Declaration
+
+   begin
+      Check_Restriction (No_Floating_Point, Def);
+
+      --  Create an implicit base type
+
+      Implicit_Base :=
+        Create_Itype (E_Floating_Point_Type, Parent (Def), T, 'B');
+
+      --  Analyze and verify digits value
+
+      Analyze_And_Resolve (Digs, Any_Integer);
+      Check_Digits_Expression (Digs);
+      Digs_Val := Expr_Value (Digs);
+
+      --  Process possible range spec and find correct type to derive from
+
+      Process_Real_Range_Specification (Def);
+
+      if Can_Derive_From (Standard_Short_Float) then
+         Base_Typ := Standard_Short_Float;
+      elsif Can_Derive_From (Standard_Float) then
+         Base_Typ := Standard_Float;
+      elsif Can_Derive_From (Standard_Long_Float) then
+         Base_Typ := Standard_Long_Float;
+      elsif Can_Derive_From (Standard_Long_Long_Float) then
+         Base_Typ := Standard_Long_Long_Float;
+
+      --  If we can't derive from any existing type, use long long float
+      --  and give appropriate message explaining the problem.
+
+      else
+         Base_Typ := Standard_Long_Long_Float;
+
+         if Digs_Val >= Digits_Value (Standard_Long_Long_Float) then
+            Error_Msg_Uint_1 := Digits_Value (Standard_Long_Long_Float);
+            Error_Msg_N ("digits value out of range, maximum is ^", Digs);
+
+         else
+            Error_Msg_N
+              ("range too large for any predefined type",
+               Real_Range_Specification (Def));
+         end if;
+      end if;
+
+      --  If there are bounds given in the declaration use them as the bounds
+      --  of the type, otherwise use the bounds of the predefined base type
+      --  that was chosen based on the Digits value.
+
+      if Present (Real_Range_Specification (Def)) then
+         Set_Scalar_Range (T, Real_Range_Specification (Def));
+         Set_Is_Constrained (T);
+
+         --  The bounds of this range must be converted to machine numbers
+         --  in accordance with RM 4.9(38).
+
+         Bound := Type_Low_Bound (T);
+
+         if Nkind (Bound) = N_Real_Literal then
+            Set_Realval (Bound, Machine (Base_Typ, Realval (Bound), Round));
+            Set_Is_Machine_Number (Bound);
+         end if;
+
+         Bound := Type_High_Bound (T);
+
+         if Nkind (Bound) = N_Real_Literal then
+            Set_Realval (Bound, Machine (Base_Typ, Realval (Bound), Round));
+            Set_Is_Machine_Number (Bound);
+         end if;
+
+      else
+         Set_Scalar_Range (T, Scalar_Range (Base_Typ));
+      end if;
+
+      --  Complete definition of implicit base and declared first subtype
+
+      Set_Etype          (Implicit_Base, Base_Typ);
+
+      Set_Scalar_Range   (Implicit_Base, Scalar_Range   (Base_Typ));
+      Set_Size_Info      (Implicit_Base,                (Base_Typ));
+      Set_RM_Size        (Implicit_Base, RM_Size        (Base_Typ));
+      Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Base_Typ));
+      Set_Digits_Value   (Implicit_Base, Digits_Value   (Base_Typ));
+      Set_Vax_Float      (Implicit_Base, Vax_Float      (Base_Typ));
+
+      Set_Ekind          (T, E_Floating_Point_Subtype);
+      Set_Etype          (T, Implicit_Base);
+
+      Set_Size_Info      (T,                (Implicit_Base));
+      Set_RM_Size        (T, RM_Size        (Implicit_Base));
+      Set_First_Rep_Item (T, First_Rep_Item (Implicit_Base));
+      Set_Digits_Value   (T, Digs_Val);
+
+   end Floating_Point_Type_Declaration;
+
+   ----------------------------
+   -- Get_Discriminant_Value --
+   ----------------------------
+
+   --  This is the situation...
+
+   --  There is a non-derived type
+
+   --       type T0 (Dx, Dy, Dz...)
+
+   --  There are zero or more levels of derivation, with each
+   --  derivation either purely inheriting the discriminants, or
+   --  defining its own.
+
+   --       type Ti      is new Ti-1
+   --  or
+   --       type Ti (Dw) is new Ti-1(Dw, 1, X+Y)
+   --  or
+   --       subtype Ti is ...
+
+   --  The subtype issue is avoided by the use of
+   --    Original_Record_Component, and the fact that derived subtypes
+   --    also derive the constraits.
+
+   --  This chain leads back from
+
+   --       Typ_For_Constraint
+
+   --  Typ_For_Constraint has discriminants, and the value for each
+   --  discriminant is given by its corresponding Elmt of Constraints.
+
+   --  Discriminant is some discriminant in this hierarchy.
+
+   --  We need to return its value.
+
+   --  We do this by recursively searching each level, and looking for
+   --  Discriminant. Once we get to the bottom, we start backing up
+   --  returning the value for it which may in turn be a discriminant
+   --  further up, so on the backup we continue the substitution.
+
+   function Get_Discriminant_Value
+     (Discriminant       : Entity_Id;
+      Typ_For_Constraint : Entity_Id;
+      Constraint         : Elist_Id)
+      return               Node_Id
+   is
+      function Recurse
+        (Ti                    : Entity_Id;
+         Discrim_Values        : Elist_Id;
+         Girder_Discrim_Values : Boolean)
+         return                Node_Or_Entity_Id;
+      --  This is the routine that performs the recursive search of levels
+      --  as described above.
+
+      function Recurse
+        (Ti                    : Entity_Id;
+         Discrim_Values        : Elist_Id;
+         Girder_Discrim_Values : Boolean)
+         return                  Node_Or_Entity_Id
+      is
+         Assoc          : Elmt_Id;
+         Disc           : Entity_Id;
+         Result         : Node_Or_Entity_Id;
+         Result_Entity  : Node_Id;
+
+      begin
+         --  If inappropriate type, return Error, this happens only in
+         --  cascaded error situations, and we want to avoid a blow up.
+
+         if not Is_Composite_Type (Ti) or else Is_Array_Type (Ti) then
+            return Error;
+         end if;
+
+         --  Look deeper if possible. Use Girder_Constraints only for
+         --  untagged types. For tagged types use the given constraint.
+         --  This asymmetry needs explanation???
+
+         if not Girder_Discrim_Values
+           and then Present (Girder_Constraint (Ti))
+           and then not Is_Tagged_Type (Ti)
+         then
+            Result := Recurse (Ti, Girder_Constraint (Ti), True);
+         else
+            declare
+               Td : Entity_Id := Etype (Ti);
+            begin
+
+               if Td = Ti then
+                  Result := Discriminant;
+
+               else
+                  if Present (Girder_Constraint (Ti)) then
+                     Result :=
+                        Recurse (Td, Girder_Constraint (Ti), True);
+                  else
+                     Result :=
+                        Recurse (Td, Discrim_Values, Girder_Discrim_Values);
+                  end if;
+               end if;
+            end;
+         end if;
+
+         --  Extra underlying places to search, if not found above. For
+         --  concurrent types, the relevant discriminant appears in the
+         --  corresponding record. For a type derived from a private type
+         --  without discriminant, the full view inherits the discriminants
+         --  of the full view of the parent.
+
+         if Result = Discriminant then
+            if Is_Concurrent_Type (Ti)
+              and then Present (Corresponding_Record_Type (Ti))
+            then
+               Result :=
+                 Recurse (
+                   Corresponding_Record_Type (Ti),
+                   Discrim_Values,
+                   Girder_Discrim_Values);
+
+            elsif Is_Private_Type (Ti)
+              and then not Has_Discriminants (Ti)
+              and then Present (Full_View (Ti))
+              and then Etype (Full_View (Ti)) /= Ti
+            then
+               Result :=
+                 Recurse (
+                   Full_View (Ti),
+                   Discrim_Values,
+                   Girder_Discrim_Values);
+            end if;
+         end if;
+
+         --  If Result is not a (reference to a) discriminant,
+         --  return it, otherwise set Result_Entity to the discriminant.
+
+         if Nkind (Result) = N_Defining_Identifier then
+
+            pragma Assert (Result = Discriminant);
+
+            Result_Entity := Result;
+
+         else
+            if not Denotes_Discriminant (Result) then
+               return Result;
+            end if;
+
+            Result_Entity := Entity (Result);
+         end if;
+
+         --  See if this level of derivation actually has discriminants
+         --  because tagged derivations can add them, hence the lower
+         --  levels need not have any.
+
+         if not Has_Discriminants (Ti) then
+            return Result;
+         end if;
+
+         --  Scan Ti's discriminants for Result_Entity,
+         --  and return its corresponding value, if any.
+
+         Result_Entity := Original_Record_Component (Result_Entity);
+
+         Assoc := First_Elmt (Discrim_Values);
+
+         if Girder_Discrim_Values then
+            Disc := First_Girder_Discriminant (Ti);
+         else
+            Disc := First_Discriminant (Ti);
+         end if;
+
+         while Present (Disc) loop
+
+            pragma Assert (Present (Assoc));
+
+            if Original_Record_Component (Disc) = Result_Entity then
+               return Node (Assoc);
+            end if;
+
+            Next_Elmt (Assoc);
+
+            if Girder_Discrim_Values then
+               Next_Girder_Discriminant (Disc);
+            else
+               Next_Discriminant (Disc);
+            end if;
+         end loop;
+
+         --  Could not find it
+         --
+         return Result;
+      end Recurse;
+
+      Result : Node_Or_Entity_Id;
+
+   --  Start of processing for Get_Discriminant_Value
+
+   begin
+      --  ??? this routine is a gigantic mess and will be deleted.
+      --  for the time being just test for the trivial case before calling
+      --  recurse.
+
+      if Base_Type (Scope (Discriminant)) = Base_Type (Typ_For_Constraint) then
+         declare
+            D : Entity_Id := First_Discriminant (Typ_For_Constraint);
+            E : Elmt_Id   := First_Elmt (Constraint);
+         begin
+            while Present (D) loop
+               if Chars (D) = Chars (Discriminant) then
+                  return Node (E);
+               end if;
+
+               Next_Discriminant (D);
+               Next_Elmt (E);
+            end loop;
+         end;
+      end if;
+
+      Result := Recurse (Typ_For_Constraint, Constraint, False);
+
+      --  ??? hack to disappear when this routine is gone
+
+      if  Nkind (Result) = N_Defining_Identifier then
+         declare
+            D : Entity_Id := First_Discriminant (Typ_For_Constraint);
+            E : Elmt_Id   := First_Elmt (Constraint);
+         begin
+            while Present (D) loop
+               if Corresponding_Discriminant (D) = Discriminant then
+                  return Node (E);
+               end if;
+
+               Next_Discriminant (D);
+               Next_Elmt (E);
+            end loop;
+         end;
+      end if;
+
+      pragma Assert (Nkind (Result) /= N_Defining_Identifier);
+      return Result;
+   end Get_Discriminant_Value;
+
+   --------------------------
+   -- Has_Range_Constraint --
+   --------------------------
+
+   function Has_Range_Constraint (N : Node_Id) return Boolean is
+      C : constant Node_Id := Constraint (N);
+
+   begin
+      if Nkind (C) = N_Range_Constraint then
+         return True;
+
+      elsif Nkind (C) = N_Digits_Constraint then
+         return
+            Is_Decimal_Fixed_Point_Type (Entity (Subtype_Mark (N)))
+              or else
+            Present (Range_Constraint (C));
+
+      elsif Nkind (C) = N_Delta_Constraint then
+         return Present (Range_Constraint (C));
+
+      else
+         return False;
+      end if;
+   end Has_Range_Constraint;
+
+   ------------------------
+   -- Inherit_Components --
+   ------------------------
+
+   function Inherit_Components
+     (N             : Node_Id;
+      Parent_Base   : Entity_Id;
+      Derived_Base  : Entity_Id;
+      Is_Tagged     : Boolean;
+      Inherit_Discr : Boolean;
+      Discs         : Elist_Id)
+      return          Elist_Id
+   is
+      Assoc_List : Elist_Id := New_Elmt_List;
+
+      procedure Inherit_Component
+        (Old_C          : Entity_Id;
+         Plain_Discrim  : Boolean := False;
+         Girder_Discrim : Boolean := False);
+      --  Inherits component Old_C from Parent_Base to the Derived_Base.
+      --  If Plain_Discrim is True, Old_C is a discriminant.
+      --  If Girder_Discrim is True, Old_C is a girder discriminant.
+      --  If they are both false then Old_C is a regular component.
+
+      -----------------------
+      -- Inherit_Component --
+      -----------------------
+
+      procedure Inherit_Component
+        (Old_C          : Entity_Id;
+         Plain_Discrim  : Boolean := False;
+         Girder_Discrim : Boolean := False)
+      is
+         New_C : Entity_Id := New_Copy (Old_C);
+
+         Discrim      : Entity_Id;
+         Corr_Discrim : Entity_Id;
+
+      begin
+         pragma Assert (not Is_Tagged or else not Girder_Discrim);
+
+         Set_Parent (New_C, Parent (Old_C));
+
+         --  Regular discriminants and components must be inserted
+         --  in the scope of the Derived_Base. Do it here.
+
+         if not Girder_Discrim then
+            Enter_Name (New_C);
+         end if;
+
+         --  For tagged types the Original_Record_Component must point to
+         --  whatever this field was pointing to in the parent type. This has
+         --  already been achieved by the call to New_Copy above.
+
+         if not Is_Tagged then
+            Set_Original_Record_Component (New_C, New_C);
+         end if;
+
+         --  If we have inherited a component then see if its Etype contains
+         --  references to Parent_Base discriminants. In this case, replace
+         --  these references with the constraints given in Discs. We do not
+         --  do this for the partial view of private types because this is
+         --  not needed (only the components of the full view will be used
+         --  for code generation) and cause problem. We also avoid this
+         --  transformation in some error situations.
+
+         if Ekind (New_C) = E_Component then
+            if (Is_Private_Type (Derived_Base)
+                  and then not Is_Generic_Type (Derived_Base))
+              or else (Is_Empty_Elmt_List (Discs)
+                       and then  not Expander_Active)
+            then
+               Set_Etype (New_C, Etype (Old_C));
+            else
+               Set_Etype (New_C, Constrain_Component_Type (Etype (Old_C),
+                 Derived_Base, N, Parent_Base, Discs));
+            end if;
+         end if;
+
+         --  In derived tagged types it is illegal to reference a non
+         --  discriminant component in the parent type. To catch this, mark
+         --  these components with an Ekind of E_Void. This will be reset in
+         --  Record_Type_Definition after processing the record extension of
+         --  the derived type.
+
+         if Is_Tagged and then Ekind (New_C) = E_Component then
+            Set_Ekind (New_C, E_Void);
+         end if;
+
+         if Plain_Discrim then
+            Set_Corresponding_Discriminant (New_C, Old_C);
+            Build_Discriminal (New_C);
+
+         --  If we are explicitely inheriting a girder discriminant it will be
+         --  completely hidden.
+
+         elsif Girder_Discrim then
+            Set_Corresponding_Discriminant (New_C, Empty);
+            Set_Discriminal (New_C, Empty);
+            Set_Is_Completely_Hidden (New_C);
+
+            --  Set the Original_Record_Component of each discriminant in the
+            --  derived base to point to the corresponding girder that we just
+            --  created.
+
+            Discrim := First_Discriminant (Derived_Base);
+            while Present (Discrim) loop
+               Corr_Discrim := Corresponding_Discriminant (Discrim);
+
+               --  Corr_Discrimm could be missing in an error situation.
+
+               if Present (Corr_Discrim)
+                 and then Original_Record_Component (Corr_Discrim) = Old_C
+               then
+                  Set_Original_Record_Component (Discrim, New_C);
+               end if;
+
+               Next_Discriminant (Discrim);
+            end loop;
+
+            Append_Entity (New_C, Derived_Base);
+         end if;
+
+         if not Is_Tagged then
+            Append_Elmt (Old_C, Assoc_List);
+            Append_Elmt (New_C, Assoc_List);
+         end if;
+      end Inherit_Component;
+
+      --  Variables local to Inherit_Components.
+
+      Loc : constant Source_Ptr := Sloc (N);
+
+      Parent_Discrim : Entity_Id;
+      Girder_Discrim : Entity_Id;
+      D              : Entity_Id;
+
+      Component        : Entity_Id;
+
+   --  Start of processing for Inherit_Components
+
+   begin
+      if not Is_Tagged then
+         Append_Elmt (Parent_Base,  Assoc_List);
+         Append_Elmt (Derived_Base, Assoc_List);
+      end if;
+
+      --  Inherit parent discriminants if needed.
+
+      if Inherit_Discr then
+         Parent_Discrim := First_Discriminant (Parent_Base);
+         while Present (Parent_Discrim) loop
+            Inherit_Component (Parent_Discrim, Plain_Discrim => True);
+            Next_Discriminant (Parent_Discrim);
+         end loop;
+      end if;
+
+      --  Create explicit girder discrims for untagged types when necessary.
+
+      if not Has_Unknown_Discriminants (Derived_Base)
+        and then Has_Discriminants (Parent_Base)
+        and then not Is_Tagged
+        and then
+          (not Inherit_Discr
+           or else First_Discriminant (Parent_Base) /=
+                   First_Girder_Discriminant (Parent_Base))
+      then
+         Girder_Discrim := First_Girder_Discriminant (Parent_Base);
+         while Present (Girder_Discrim) loop
+            Inherit_Component (Girder_Discrim, Girder_Discrim => True);
+            Next_Girder_Discriminant (Girder_Discrim);
+         end loop;
+      end if;
+
+      --  See if we can apply the second transformation for derived types, as
+      --  explained in point 6. in the comments above Build_Derived_Record_Type
+      --  This is achieved by appending Derived_Base discriminants into
+      --  Discs, which has the side effect of returning a non empty Discs
+      --  list to the caller of Inherit_Components, which is what we want.
+
+      if Inherit_Discr
+        and then Is_Empty_Elmt_List (Discs)
+        and then (not Is_Private_Type (Derived_Base)
+                   or Is_Generic_Type (Derived_Base))
+      then
+         D := First_Discriminant (Derived_Base);
+         while Present (D) loop
+            Append_Elmt (New_Reference_To (D, Loc), Discs);
+            Next_Discriminant (D);
+         end loop;
+      end if;
+
+      --  Finally, inherit non-discriminant components unless they are not
+      --  visible because defined or inherited from the full view of the
+      --  parent. Don't inherit the _parent field of the parent type.
+
+      Component := First_Entity (Parent_Base);
+      while Present (Component) loop
+         if Ekind (Component) /= E_Component
+           or else Chars (Component) = Name_uParent
+         then
+            null;
+
+         --  If the derived type is within the parent type's declarative
+         --  region, then the components can still be inherited even though
+         --  they aren't visible at this point. This can occur for cases
+         --  such as within public child units where the components must
+         --  become visible upon entering the child unit's private part.
+
+         elsif not Is_Visible_Component (Component)
+           and then not In_Open_Scopes (Scope (Parent_Base))
+         then
+            null;
+
+         elsif Ekind (Derived_Base) = E_Private_Type
+           or else Ekind (Derived_Base) = E_Limited_Private_Type
+         then
+            null;
+
+         else
+            Inherit_Component (Component);
+         end if;
+
+         Next_Entity (Component);
+      end loop;
+
+      --  For tagged derived types, inherited discriminants cannot be used in
+      --  component declarations of the record extension part. To achieve this
+      --  we mark the inherited discriminants as not visible.
+
+      if Is_Tagged and then Inherit_Discr then
+         D := First_Discriminant (Derived_Base);
+         while Present (D) loop
+            Set_Is_Immediately_Visible (D, False);
+            Next_Discriminant (D);
+         end loop;
+      end if;
+
+      return Assoc_List;
+   end Inherit_Components;
+
+   ------------------------------
+   -- Is_Valid_Constraint_Kind --
+   ------------------------------
+
+   function Is_Valid_Constraint_Kind
+     (T_Kind          : Type_Kind;
+      Constraint_Kind : Node_Kind)
+      return            Boolean
+   is
+   begin
+      case T_Kind is
+
+         when Enumeration_Kind |
+              Integer_Kind =>
+            return Constraint_Kind = N_Range_Constraint;
+
+         when Decimal_Fixed_Point_Kind =>
+            return
+              Constraint_Kind = N_Digits_Constraint
+                or else
+              Constraint_Kind = N_Range_Constraint;
+
+         when Ordinary_Fixed_Point_Kind =>
+            return
+              Constraint_Kind = N_Delta_Constraint
+                or else
+              Constraint_Kind = N_Range_Constraint;
+
+         when Float_Kind =>
+            return
+              Constraint_Kind = N_Digits_Constraint
+                or else
+              Constraint_Kind = N_Range_Constraint;
+
+         when Access_Kind       |
+              Array_Kind        |
+              E_Record_Type     |
+              E_Record_Subtype  |
+              Class_Wide_Kind   |
+              E_Incomplete_Type |
+              Private_Kind      |
+              Concurrent_Kind  =>
+            return Constraint_Kind = N_Index_Or_Discriminant_Constraint;
+
+         when others =>
+            return True; -- Error will be detected later.
+      end case;
+
+   end Is_Valid_Constraint_Kind;
+
+   --------------------------
+   -- Is_Visible_Component --
+   --------------------------
+
+   function Is_Visible_Component (C : Entity_Id) return Boolean is
+      Original_Comp  : constant Entity_Id := Original_Record_Component (C);
+      Original_Scope : Entity_Id;
+
+   begin
+      if No (Original_Comp) then
+
+         --  Premature usage, or previous error
+
+         return False;
+
+      else
+         Original_Scope := Scope (Original_Comp);
+      end if;
+
+      --  This test only concern tagged types
+
+      if not Is_Tagged_Type (Original_Scope) then
+         return True;
+
+      --  If it is _Parent or _Tag, there is no visiblity issue
+
+      elsif not Comes_From_Source (Original_Comp) then
+         return True;
+
+      --  If we are in the body of an instantiation, the component is
+      --  visible even when the parent type (possibly defined in an
+      --  enclosing unit or in a parent unit) might not.
+
+      elsif In_Instance_Body then
+         return True;
+
+      --  Discriminants are always visible.
+
+      elsif Ekind (Original_Comp) = E_Discriminant
+        and then not Has_Unknown_Discriminants (Original_Scope)
+      then
+         return True;
+
+      --  If the component has been declared in an ancestor which is
+      --  currently a private type, then it is not visible. The same
+      --  applies if the component's containing type is not in an
+      --  open scope and the original component's enclosing type
+      --  is a visible full type of a private type (which can occur
+      --  in cases where an attempt is being made to reference a
+      --  component in a sibling package that is inherited from
+      --  a visible component of a type in an ancestor package;
+      --  the component in the sibling package should not be
+      --  visible even though the component it inherited from
+      --  is visible). This does not apply however in the case
+      --  where the scope of the type is a private child unit.
+      --  The latter suppression of visibility is needed for cases
+      --  that are tested in B730006.
+
+      elsif (Ekind (Original_Comp) /= E_Discriminant
+              or else Has_Unknown_Discriminants (Original_Scope))
+        and then
+          (Is_Private_Type (Original_Scope)
+            or else
+              (not Is_Private_Descendant (Scope (Base_Type (Scope (C))))
+                and then not In_Open_Scopes (Scope (Base_Type (Scope (C))))
+                and then Has_Private_Declaration (Original_Scope)))
+      then
+         return False;
+
+      --  There is another weird way in which a component may be invisible
+      --  when the private and the full view are not derived from the same
+      --  ancestor. Here is an example :
+
+      --       type A1 is tagged      record F1 : integer; end record;
+      --       type A2 is new A1 with record F2 : integer; end record;
+      --       type T is new A1 with private;
+      --     private
+      --       type T is new A2 with private;
+
+      --  In this case, the full view of T inherits F1 and F2 but the
+      --  private view inherits only F1
+
+      else
+         declare
+            Ancestor : Entity_Id := Scope (C);
+
+         begin
+            loop
+               if Ancestor = Original_Scope then
+                  return True;
+               elsif Ancestor = Etype (Ancestor) then
+                  return False;
+               end if;
+
+               Ancestor := Etype (Ancestor);
+            end loop;
+
+            return True;
+         end;
+      end if;
+   end Is_Visible_Component;
+
+   --------------------------
+   -- Make_Class_Wide_Type --
+   --------------------------
+
+   procedure Make_Class_Wide_Type (T : Entity_Id) is
+      CW_Type : Entity_Id;
+      CW_Name : Name_Id;
+      Next_E  : Entity_Id;
+
+   begin
+      --  The class wide type can have been defined by the partial view in
+      --  which case everything is already done
+
+      if Present (Class_Wide_Type (T)) then
+         return;
+      end if;
+
+      CW_Type :=
+        New_External_Entity (E_Void, Scope (T), Sloc (T), T, 'C', 0, 'T');
+
+      --  Inherit root type characteristics
+
+      CW_Name := Chars (CW_Type);
+      Next_E  := Next_Entity (CW_Type);
+      Copy_Node (T, CW_Type);
+      Set_Comes_From_Source (CW_Type, False);
+      Set_Chars (CW_Type, CW_Name);
+      Set_Parent (CW_Type, Parent (T));
+      Set_Next_Entity (CW_Type, Next_E);
+      Set_Has_Delayed_Freeze (CW_Type);
+
+      --  Customize the class-wide type: It has no prim. op., it cannot be
+      --  abstract and its Etype points back to the root type
+
+      Set_Ekind                (CW_Type, E_Class_Wide_Type);
+      Set_Is_Tagged_Type       (CW_Type, True);
+      Set_Primitive_Operations (CW_Type, New_Elmt_List);
+      Set_Is_Abstract          (CW_Type, False);
+      Set_Etype                (CW_Type, T);
+      Set_Is_Constrained       (CW_Type, False);
+      Set_Is_First_Subtype     (CW_Type, Is_First_Subtype (T));
+      Init_Size_Align          (CW_Type);
+
+      --  If this is the class_wide type of a constrained subtype, it does
+      --  not have discriminants.
+
+      Set_Has_Discriminants (CW_Type,
+        Has_Discriminants (T) and then not Is_Constrained (T));
+
+      Set_Has_Unknown_Discriminants (CW_Type, True);
+      Set_Class_Wide_Type (T, CW_Type);
+      Set_Equivalent_Type (CW_Type, Empty);
+
+      --  The class-wide type of a class-wide type is itself (RM 3.9(14))
+
+      Set_Class_Wide_Type (CW_Type, CW_Type);
+
+   end Make_Class_Wide_Type;
+
+   ----------------
+   -- Make_Index --
+   ----------------
+
+   procedure Make_Index
+     (I            : Node_Id;
+      Related_Nod  : Node_Id;
+      Related_Id   : Entity_Id := Empty;
+      Suffix_Index : Nat := 1)
+   is
+      R      : Node_Id;
+      T      : Entity_Id;
+      Def_Id : Entity_Id := Empty;
+      Found  : Boolean := False;
+
+   begin
+      --  For a discrete range used in a constrained array definition and
+      --  defined by a range, an implicit conversion to the predefined type
+      --  INTEGER is assumed if each bound is either a numeric literal, a named
+      --  number, or an attribute, and the type of both bounds (prior to the
+      --  implicit conversion) is the type universal_integer. Otherwise, both
+      --  bounds must be of the same discrete type, other than universal
+      --  integer; this type must be determinable independently of the
+      --  context, but using the fact that the type must be discrete and that
+      --  both bounds must have the same type.
+
+      --  Character literals also have a universal type in the absence of
+      --  of additional context,  and are resolved to Standard_Character.
+
+      if Nkind (I) = N_Range then
+
+         --  The index is given by a range constraint. The bounds are known
+         --  to be of a consistent type.
+
+         if not Is_Overloaded (I) then
+            T := Etype (I);
+
+            --  If the bounds are universal, choose the specific predefined
+            --  type.
+
+            if T = Universal_Integer then
+               T := Standard_Integer;
+
+            elsif T = Any_Character then
+
+               if not Ada_83 then
+                  Error_Msg_N
+                    ("ambiguous character literals (could be Wide_Character)",
+                      I);
+               end if;
+
+               T := Standard_Character;
+            end if;
+
+         else
+            T := Any_Type;
+
+            declare
+               Ind : Interp_Index;
+               It  : Interp;
+
+            begin
+               Get_First_Interp (I, Ind, It);
+
+               while Present (It.Typ) loop
+                  if Is_Discrete_Type (It.Typ) then
+
+                     if Found
+                       and then not Covers (It.Typ, T)
+                       and then not Covers (T, It.Typ)
+                     then
+                        Error_Msg_N ("ambiguous bounds in discrete range", I);
+                        exit;
+                     else
+                        T := It.Typ;
+                        Found := True;
+                     end if;
+                  end if;
+
+                  Get_Next_Interp (Ind, It);
+               end loop;
+
+               if T = Any_Type then
+                  Error_Msg_N ("discrete type required for range", I);
+                  Set_Etype (I, Any_Type);
+                  return;
+
+               elsif T = Universal_Integer then
+                  T := Standard_Integer;
+               end if;
+            end;
+         end if;
+
+         if not Is_Discrete_Type (T) then
+            Error_Msg_N ("discrete type required for range", I);
+            Set_Etype (I, Any_Type);
+            return;
+         end if;
+
+         R := I;
+         Process_Range_Expr_In_Decl (R, T, Related_Nod);
+
+      elsif Nkind (I) = N_Subtype_Indication then
+
+         --  The index is given by a subtype with a range constraint.
+
+         T :=  Base_Type (Entity (Subtype_Mark (I)));
+
+         if not Is_Discrete_Type (T) then
+            Error_Msg_N ("discrete type required for range", I);
+            Set_Etype (I, Any_Type);
+            return;
+         end if;
+
+         R := Range_Expression (Constraint (I));
+
+         Resolve (R, T);
+         Process_Range_Expr_In_Decl (R,
+           Entity (Subtype_Mark (I)), Related_Nod);
+
+      elsif Nkind (I) = N_Attribute_Reference then
+
+         --  The parser guarantees that the attribute is a RANGE attribute
+
+         --  Is order critical here (setting T before Resolve). If so,
+         --  document why, if not use Analyze_And_Resolve and get T after???
+
+         Analyze (I);
+         T := Etype (I);
+         Resolve (I, T);
+         R := I;
+
+      --  If none of the above, must be a subtype. We convert this to a
+      --  range attribute reference because in the case of declared first
+      --  named subtypes, the types in the range reference can be different
+      --  from the type of the entity. A range attribute normalizes the
+      --  reference and obtains the correct types for the bounds.
+
+      --  This transformation is in the nature of an expansion, is only
+      --  done if expansion is active. In particular, it is not done on
+      --  formal generic types,  because we need to retain the name of the
+      --  original index for instantiation purposes.
+
+      else
+         if not Is_Entity_Name (I) or else not Is_Type (Entity (I)) then
+            Error_Msg_N ("invalid subtype mark in discrete range ", I);
+            Set_Etype (I, Any_Integer);
+            return;
+         else
+            --  The type mark may be that of an incomplete type. It is only
+            --  now that we can get the full view, previous analysis does
+            --  not look specifically for a type mark.
+
+            Set_Entity (I, Get_Full_View (Entity (I)));
+            Set_Etype  (I, Entity (I));
+            Def_Id := Entity (I);
+
+            if not Is_Discrete_Type (Def_Id) then
+               Error_Msg_N ("discrete type required for index", I);
+               Set_Etype (I, Any_Type);
+               return;
+            end if;
+         end if;
+
+         if Expander_Active then
+            Rewrite (I,
+              Make_Attribute_Reference (Sloc (I),
+                Attribute_Name => Name_Range,
+                Prefix         => Relocate_Node (I)));
+
+            --  The original was a subtype mark that does not freeze. This
+            --  means that the rewritten version must not freeze either.
+
+            Set_Must_Not_Freeze (I);
+            Set_Must_Not_Freeze (Prefix (I));
+
+            --  Is order critical??? if so, document why, if not
+            --  use Analyze_And_Resolve
+
+            Analyze (I);
+            T := Etype (I);
+            Resolve (I, T);
+            R := I;
+
+         else
+            --  Type is legal, nothing else to construct.
+            return;
+         end if;
+      end if;
+
+      if not Is_Discrete_Type (T) then
+         Error_Msg_N ("discrete type required for range", I);
+         Set_Etype (I, Any_Type);
+         return;
+
+      elsif T = Any_Type then
+         Set_Etype (I, Any_Type);
+         return;
+      end if;
+
+      --  We will now create the appropriate Itype to describe the
+      --  range, but first a check. If we originally had a subtype,
+      --  then we just label the range with this subtype. Not only
+      --  is there no need to construct a new subtype, but it is wrong
+      --  to do so for two reasons:
+
+      --    1. A legality concern, if we have a subtype, it must not
+      --       freeze, and the Itype would cause freezing incorrectly
+
+      --    2. An efficiency concern, if we created an Itype, it would
+      --       not be recognized as the same type for the purposes of
+      --       eliminating checks in some circumstances.
+
+      --  We signal this case by setting the subtype entity in Def_Id.
+
+      --  It would be nice to also do this optimization for the cases
+      --  of X'Range and also the explicit range X'First .. X'Last,
+      --  but that is not done yet (it is just an efficiency concern) ???
+
+      if No (Def_Id) then
+
+         Def_Id :=
+           Create_Itype (E_Void, Related_Nod, Related_Id, 'D', Suffix_Index);
+         Set_Etype (Def_Id, Base_Type (T));
+
+         if Is_Signed_Integer_Type (T) then
+            Set_Ekind (Def_Id, E_Signed_Integer_Subtype);
+
+         elsif Is_Modular_Integer_Type (T) then
+            Set_Ekind (Def_Id, E_Modular_Integer_Subtype);
+
+         else
+            Set_Ekind             (Def_Id, E_Enumeration_Subtype);
+            Set_Is_Character_Type (Def_Id, Is_Character_Type (T));
+         end if;
+
+         Set_Size_Info      (Def_Id,                  (T));
+         Set_RM_Size        (Def_Id, RM_Size          (T));
+         Set_First_Rep_Item (Def_Id, First_Rep_Item   (T));
+
+         Set_Scalar_Range   (Def_Id, R);
+         Conditional_Delay  (Def_Id, T);
+
+         --  In the subtype indication case, if the immediate parent of the
+         --  new subtype is non-static, then the subtype we create is non-
+         --  static, even if its bounds are static.
+
+         if Nkind (I) = N_Subtype_Indication
+           and then not Is_Static_Subtype (Entity (Subtype_Mark (I)))
+         then
+            Set_Is_Non_Static_Subtype (Def_Id);
+         end if;
+      end if;
+
+      --  Final step is to label the index with this constructed type
+
+      Set_Etype (I, Def_Id);
+   end Make_Index;
+
+   ------------------------------
+   -- Modular_Type_Declaration --
+   ------------------------------
+
+   procedure Modular_Type_Declaration (T : Entity_Id; Def : Node_Id) is
+      Mod_Expr : constant Node_Id := Expression (Def);
+      M_Val    : Uint;
+
+      procedure Set_Modular_Size (Bits : Int);
+      --  Sets RM_Size to Bits, and Esize to normal word size above this
+
+      procedure Set_Modular_Size (Bits : Int) is
+      begin
+         Set_RM_Size (T, UI_From_Int (Bits));
+
+         if Bits <= 8 then
+            Init_Esize (T, 8);
+
+         elsif Bits <= 16 then
+            Init_Esize (T, 16);
+
+         elsif Bits <= 32 then
+            Init_Esize (T, 32);
+
+         else
+            Init_Esize (T, System_Max_Binary_Modulus_Power);
+         end if;
+      end Set_Modular_Size;
+
+   --  Start of processing for Modular_Type_Declaration
+
+   begin
+      Analyze_And_Resolve (Mod_Expr, Any_Integer);
+      Set_Etype (T, T);
+      Set_Ekind (T, E_Modular_Integer_Type);
+      Init_Alignment (T);
+      Set_Is_Constrained (T);
+
+      if not Is_OK_Static_Expression (Mod_Expr) then
+         Error_Msg_N
+           ("non-static expression used for modular type bound", Mod_Expr);
+         M_Val := 2 ** System_Max_Binary_Modulus_Power;
+      else
+         M_Val := Expr_Value (Mod_Expr);
+      end if;
+
+      if M_Val < 1 then
+         Error_Msg_N ("modulus value must be positive", Mod_Expr);
+         M_Val := 2 ** System_Max_Binary_Modulus_Power;
+      end if;
+
+      Set_Modulus (T, M_Val);
+
+      --   Create bounds for the modular type based on the modulus given in
+      --   the type declaration and then analyze and resolve those bounds.
+
+      Set_Scalar_Range (T,
+        Make_Range (Sloc (Mod_Expr),
+          Low_Bound  =>
+            Make_Integer_Literal (Sloc (Mod_Expr), 0),
+          High_Bound =>
+            Make_Integer_Literal (Sloc (Mod_Expr), M_Val - 1)));
+
+      --  Properly analyze the literals for the range. We do this manually
+      --  because we can't go calling Resolve, since we are resolving these
+      --  bounds with the type, and this type is certainly not complete yet!
+
+      Set_Etype (Low_Bound  (Scalar_Range (T)), T);
+      Set_Etype (High_Bound (Scalar_Range (T)), T);
+      Set_Is_Static_Expression (Low_Bound  (Scalar_Range (T)));
+      Set_Is_Static_Expression (High_Bound (Scalar_Range (T)));
+
+      --  Loop through powers of two to find number of bits required
+
+      for Bits in Int range 0 .. System_Max_Binary_Modulus_Power loop
+
+         --  Binary case
+
+         if M_Val = 2 ** Bits then
+            Set_Modular_Size (Bits);
+            return;
+
+         --  Non-binary case
+
+         elsif M_Val < 2 ** Bits then
+            Set_Non_Binary_Modulus (T);
+
+            if Bits > System_Max_Nonbinary_Modulus_Power then
+               Error_Msg_Uint_1 :=
+                 UI_From_Int (System_Max_Nonbinary_Modulus_Power);
+               Error_Msg_N
+                 ("nonbinary modulus exceeds limit (2 '*'*^ - 1)", Mod_Expr);
+               Set_Modular_Size (System_Max_Binary_Modulus_Power);
+               return;
+
+            else
+               --  In the non-binary case, set size as per RM 13.3(55).
+
+               Set_Modular_Size (Bits);
+               return;
+            end if;
+         end if;
+
+      end loop;
+
+      --  If we fall through, then the size exceed System.Max_Binary_Modulus
+      --  so we just signal an error and set the maximum size.
+
+      Error_Msg_Uint_1 := UI_From_Int (System_Max_Binary_Modulus_Power);
+      Error_Msg_N ("modulus exceeds limit (2 '*'*^)", Mod_Expr);
+
+      Set_Modular_Size (System_Max_Binary_Modulus_Power);
+      Init_Alignment (T);
+
+   end Modular_Type_Declaration;
+
+   -------------------------
+   -- New_Binary_Operator --
+   -------------------------
+
+   procedure New_Binary_Operator (Op_Name : Name_Id; Typ : Entity_Id) is
+      Loc : constant Source_Ptr := Sloc (Typ);
+      Op  : Entity_Id;
+
+      function Make_Op_Formal (Typ, Op : Entity_Id) return Entity_Id;
+      --  Create abbreviated declaration for the formal of a predefined
+      --  Operator 'Op' of type 'Typ'
+
+      --------------------
+      -- Make_Op_Formal --
+      --------------------
+
+      function Make_Op_Formal (Typ, Op : Entity_Id) return Entity_Id is
+         Formal : Entity_Id;
+
+      begin
+         Formal := New_Internal_Entity (E_In_Parameter, Op, Loc, 'P');
+         Set_Etype (Formal, Typ);
+         Set_Mechanism (Formal, Default_Mechanism);
+         return Formal;
+      end Make_Op_Formal;
+
+   --  Start of processing for New_Binary_Operator
+
+   begin
+      Op := Make_Defining_Operator_Symbol (Loc, Op_Name);
+
+      Set_Ekind                   (Op, E_Operator);
+      Set_Scope                   (Op, Current_Scope);
+      Set_Etype                   (Op, Typ);
+      Set_Homonym                 (Op, Get_Name_Entity_Id (Op_Name));
+      Set_Is_Immediately_Visible  (Op);
+      Set_Is_Intrinsic_Subprogram (Op);
+      Set_Has_Completion          (Op);
+      Append_Entity               (Op, Current_Scope);
+
+      Set_Name_Entity_Id (Op_Name, Op);
+
+      Append_Entity (Make_Op_Formal (Typ, Op), Op);
+      Append_Entity (Make_Op_Formal (Typ, Op), Op);
+
+   end New_Binary_Operator;
+
+   -------------------------------------------
+   -- Ordinary_Fixed_Point_Type_Declaration --
+   -------------------------------------------
+
+   procedure Ordinary_Fixed_Point_Type_Declaration
+     (T   : Entity_Id;
+      Def : Node_Id)
+   is
+      Loc           : constant Source_Ptr := Sloc (Def);
+      Delta_Expr    : constant Node_Id    := Delta_Expression (Def);
+      RRS           : constant Node_Id    := Real_Range_Specification (Def);
+      Implicit_Base : Entity_Id;
+      Delta_Val     : Ureal;
+      Small_Val     : Ureal;
+      Low_Val       : Ureal;
+      High_Val      : Ureal;
+
+   begin
+      Check_Restriction (No_Fixed_Point, Def);
+
+      --  Create implicit base type
+
+      Implicit_Base :=
+        Create_Itype (E_Ordinary_Fixed_Point_Type, Parent (Def), T, 'B');
+      Set_Etype (Implicit_Base, Implicit_Base);
+
+      --  Analyze and process delta expression
+
+      Analyze_And_Resolve (Delta_Expr, Any_Real);
+
+      Check_Delta_Expression (Delta_Expr);
+      Delta_Val := Expr_Value_R (Delta_Expr);
+
+      Set_Delta_Value (Implicit_Base, Delta_Val);
+
+      --  Compute default small from given delta, which is the largest
+      --  power of two that does not exceed the given delta value.
+
+      declare
+         Tmp   : Ureal := Ureal_1;
+         Scale : Int   := 0;
+
+      begin
+         if Delta_Val < Ureal_1 then
+            while Delta_Val < Tmp loop
+               Tmp := Tmp / Ureal_2;
+               Scale := Scale + 1;
+            end loop;
+
+         else
+            loop
+               Tmp := Tmp * Ureal_2;
+               exit when Tmp > Delta_Val;
+               Scale := Scale - 1;
+            end loop;
+         end if;
+
+         Small_Val := UR_From_Components (Uint_1, UI_From_Int (Scale), 2);
+      end;
+
+      Set_Small_Value (Implicit_Base, Small_Val);
+
+      --  If no range was given, set a dummy range
+
+      if RRS <= Empty_Or_Error then
+         Low_Val  := -Small_Val;
+         High_Val := Small_Val;
+
+      --  Otherwise analyze and process given range
+
+      else
+         declare
+            Low  : constant Node_Id := Low_Bound  (RRS);
+            High : constant Node_Id := High_Bound (RRS);
+
+         begin
+            Analyze_And_Resolve (Low, Any_Real);
+            Analyze_And_Resolve (High, Any_Real);
+            Check_Real_Bound (Low);
+            Check_Real_Bound (High);
+
+            --  Obtain and set the range
+
+            Low_Val  := Expr_Value_R (Low);
+            High_Val := Expr_Value_R (High);
+
+            if Low_Val > High_Val then
+               Error_Msg_NE ("?fixed point type& has null range", Def, T);
+            end if;
+         end;
+      end if;
+
+      --  The range for both the implicit base and the declared first
+      --  subtype cannot be set yet, so we use the special routine
+      --  Set_Fixed_Range to set a temporary range in place. Note that
+      --  the bounds of the base type will be widened to be symmetrical
+      --  and to fill the available bits when the type is frozen.
+
+      --  We could do this with all discrete types, and probably should, but
+      --  we absolutely have to do it for fixed-point, since the end-points
+      --  of the range and the size are determined by the small value, which
+      --  could be reset before the freeze point.
+
+      Set_Fixed_Range (Implicit_Base, Loc, Low_Val, High_Val);
+      Set_Fixed_Range (T, Loc, Low_Val, High_Val);
+
+      Init_Size_Align (Implicit_Base);
+
+      --  Complete definition of first subtype
+
+      Set_Ekind          (T, E_Ordinary_Fixed_Point_Subtype);
+      Set_Etype          (T, Implicit_Base);
+      Init_Size_Align    (T);
+      Set_First_Rep_Item (T, First_Rep_Item (Implicit_Base));
+      Set_Small_Value    (T, Small_Val);
+      Set_Delta_Value    (T, Delta_Val);
+      Set_Is_Constrained (T);
+
+   end Ordinary_Fixed_Point_Type_Declaration;
+
+   ----------------------------------------
+   -- Prepare_Private_Subtype_Completion --
+   ----------------------------------------
+
+   procedure Prepare_Private_Subtype_Completion
+     (Id          : Entity_Id;
+      Related_Nod : Node_Id)
+   is
+      Id_B   : constant Entity_Id := Base_Type (Id);
+      Full_B : constant Entity_Id := Full_View (Id_B);
+      Full   : Entity_Id;
+
+   begin
+      if Present (Full_B) then
+
+         --  The Base_Type is already completed, we can complete the
+         --  subtype now. We have to create a new entity with the same name,
+         --  Thus we can't use Create_Itype.
+         --  This is messy, should be fixed ???
+
+         Full := Make_Defining_Identifier (Sloc (Id), Chars (Id));
+         Set_Is_Itype (Full);
+         Set_Associated_Node_For_Itype (Full, Related_Nod);
+         Complete_Private_Subtype (Id, Full, Full_B, Related_Nod);
+      end if;
+
+      --  The parent subtype may be private, but the base might not, in some
+      --  nested instances. In that case, the subtype does not need to be
+      --  exchanged. It would still be nice to make private subtypes and their
+      --  bases consistent at all times ???
+
+      if Is_Private_Type (Id_B) then
+         Append_Elmt (Id, Private_Dependents (Id_B));
+      end if;
+
+   end Prepare_Private_Subtype_Completion;
+
+   ---------------------------
+   -- Process_Discriminants --
+   ---------------------------
+
+   procedure Process_Discriminants (N : Node_Id) is
+      Id                  : Node_Id;
+      Discr               : Node_Id;
+      Discr_Number        : Uint;
+      Discr_Type          : Entity_Id;
+      Default_Present     : Boolean := False;
+      Default_Not_Present : Boolean := False;
+      Elist               : Elist_Id := New_Elmt_List;
+
+   begin
+      --  A composite type other than an array type can have discriminants.
+      --  Discriminants of non-limited types must have a discrete type.
+      --  On entry, the current scope is the composite type.
+
+      --  The discriminants are initially entered into the scope of the type
+      --  via Enter_Name with the default Ekind of E_Void to prevent premature
+      --  use, as explained at the end of this procedure.
+
+      Discr := First (Discriminant_Specifications (N));
+      while Present (Discr) loop
+         Enter_Name (Defining_Identifier (Discr));
+
+         if Nkind (Discriminant_Type (Discr)) = N_Access_Definition then
+            Discr_Type := Access_Definition (N, Discriminant_Type (Discr));
+
+         else
+            Find_Type (Discriminant_Type (Discr));
+            Discr_Type := Etype (Discriminant_Type (Discr));
+
+            if Error_Posted (Discriminant_Type (Discr)) then
+               Discr_Type := Any_Type;
+            end if;
+         end if;
+
+         if Is_Access_Type (Discr_Type) then
+            Check_Access_Discriminant_Requires_Limited
+              (Discr, Discriminant_Type (Discr));
+
+            if Ada_83 and then Comes_From_Source (Discr) then
+               Error_Msg_N
+                 ("(Ada 83) access discriminant not allowed", Discr);
+            end if;
+
+         elsif not Is_Discrete_Type (Discr_Type) then
+            Error_Msg_N ("discriminants must have a discrete or access type",
+              Discriminant_Type (Discr));
+         end if;
+
+         Set_Etype (Defining_Identifier (Discr), Discr_Type);
+
+         --  If a discriminant specification includes the assignment compound
+         --  delimiter followed by an expression, the expression is the default
+         --  expression of the discriminant; the default expression must be of
+         --  the type of the discriminant. (RM 3.7.1) Since this expression is
+         --  a default expression, we do the special preanalysis, since this
+         --  expression does not freeze (see "Handling of Default Expressions"
+         --  in spec of package Sem).
+
+         if Present (Expression (Discr)) then
+            Analyze_Default_Expression (Expression (Discr), Discr_Type);
+
+            if Nkind (N) = N_Formal_Type_Declaration then
+               Error_Msg_N
+                 ("discriminant defaults not allowed for formal type",
+                  Expression (Discr));
+
+            elsif Is_Tagged_Type (Current_Scope) then
+               Error_Msg_N
+                 ("discriminants of tagged type cannot have defaults",
+                  Expression (Discr));
+
+            else
+               Default_Present := True;
+               Append_Elmt (Expression (Discr), Elist);
+
+               --  Tag the defining identifiers for the discriminants with
+               --  their corresponding default expressions from the tree.
+
+               Set_Discriminant_Default_Value
+                 (Defining_Identifier (Discr), Expression (Discr));
+            end if;
+
+         else
+            Default_Not_Present := True;
+         end if;
+
+         Next (Discr);
+      end loop;
+
+      --  An element list consisting of the default expressions of the
+      --  discriminants is constructed in the above loop and used to set
+      --  the Discriminant_Constraint attribute for the type. If an object
+      --  is declared of this (record or task) type without any explicit
+      --  discriminant constraint given, this element list will form the
+      --  actual parameters for the corresponding initialization procedure
+      --  for the type.
+
+      Set_Discriminant_Constraint (Current_Scope, Elist);
+      Set_Girder_Constraint (Current_Scope, No_Elist);
+
+      --  Default expressions must be provided either for all or for none
+      --  of the discriminants of a discriminant part. (RM 3.7.1)
+
+      if Default_Present and then Default_Not_Present then
+         Error_Msg_N
+           ("incomplete specification of defaults for discriminants", N);
+      end if;
+
+      --  The use of the name of a discriminant is not allowed in default
+      --  expressions of a discriminant part if the specification of the
+      --  discriminant is itself given in the discriminant part. (RM 3.7.1)
+
+      --  To detect this, the discriminant names are entered initially with an
+      --  Ekind of E_Void (which is the default Ekind given by Enter_Name). Any
+      --  attempt to use a void entity (for example in an expression that is
+      --  type-checked) produces the error message: premature usage. Now after
+      --  completing the semantic analysis of the discriminant part, we can set
+      --  the Ekind of all the discriminants appropriately.
+
+      Discr := First (Discriminant_Specifications (N));
+      Discr_Number := Uint_1;
+
+      while Present (Discr) loop
+         Id := Defining_Identifier (Discr);
+         Set_Ekind (Id, E_Discriminant);
+         Init_Component_Location (Id);
+         Init_Esize (Id);
+         Set_Discriminant_Number (Id, Discr_Number);
+
+         --  Make sure this is always set, even in illegal programs
+
+         Set_Corresponding_Discriminant (Id, Empty);
+
+         --  Initialize the Original_Record_Component to the entity itself.
+         --  Inherit_Components will propagate the right value to
+         --  discriminants in derived record types.
+
+         Set_Original_Record_Component (Id, Id);
+
+         --  Create the discriminal for the discriminant.
+
+         Build_Discriminal (Id);
+
+         Next (Discr);
+         Discr_Number := Discr_Number + 1;
+      end loop;
+
+      Set_Has_Discriminants (Current_Scope);
+   end Process_Discriminants;
+
+   -----------------------
+   -- Process_Full_View --
+   -----------------------
+
+   procedure Process_Full_View (N : Node_Id; Full_T, Priv_T : Entity_Id) is
+      Priv_Parent : Entity_Id;
+      Full_Parent : Entity_Id;
+      Full_Indic  : Node_Id;
+
+   begin
+      --  First some sanity checks that must be done after semantic
+      --  decoration of the full view and thus cannot be placed with other
+      --  similar checks in Find_Type_Name
+
+      if not Is_Limited_Type (Priv_T)
+        and then (Is_Limited_Type (Full_T)
+                   or else Is_Limited_Composite (Full_T))
+      then
+         Error_Msg_N
+           ("completion of nonlimited type cannot be limited", Full_T);
+
+      elsif Is_Abstract (Full_T) and then not Is_Abstract (Priv_T) then
+         Error_Msg_N
+           ("completion of nonabstract type cannot be abstract", Full_T);
+
+      elsif Is_Tagged_Type (Priv_T)
+        and then Is_Limited_Type (Priv_T)
+        and then not Is_Limited_Type (Full_T)
+      then
+         --  GNAT allow its own definition of Limited_Controlled to disobey
+         --  this rule in order in ease the implementation. The next test is
+         --  safe because Root_Controlled is defined in a private system child
+
+         if Etype (Full_T) = Full_View (RTE (RE_Root_Controlled)) then
+            Set_Is_Limited_Composite (Full_T);
+         else
+            Error_Msg_N
+              ("completion of limited tagged type must be limited", Full_T);
+         end if;
+
+      elsif Is_Generic_Type (Priv_T) then
+         Error_Msg_N ("generic type cannot have a completion", Full_T);
+      end if;
+
+      if Is_Tagged_Type (Priv_T)
+        and then Nkind (Parent (Priv_T)) = N_Private_Extension_Declaration
+        and then Is_Derived_Type (Full_T)
+      then
+         Priv_Parent := Etype (Priv_T);
+
+         --  The full view of a private extension may have been transformed
+         --  into an unconstrained derived type declaration and a subtype
+         --  declaration (see build_derived_record_type for details).
+
+         if Nkind (N) = N_Subtype_Declaration then
+            Full_Indic  := Subtype_Indication (N);
+            Full_Parent := Etype (Base_Type (Full_T));
+         else
+            Full_Indic  := Subtype_Indication (Type_Definition (N));
+            Full_Parent := Etype (Full_T);
+         end if;
+
+         --  Check that the parent type of the full type is a descendant of
+         --  the ancestor subtype given in the private extension. If either
+         --  entity has an Etype equal to Any_Type then we had some previous
+         --  error situation [7.3(8)].
+
+         if Priv_Parent = Any_Type or else Full_Parent = Any_Type then
+            return;
+
+         elsif not Is_Ancestor (Base_Type (Priv_Parent), Full_Parent) then
+            Error_Msg_N
+              ("parent of full type must descend from parent"
+                  & " of private extension", Full_Indic);
+
+         --  Check the rules of 7.3(10): if the private extension inherits
+         --  known discriminants, then the full type must also inherit those
+         --  discriminants from the same (ancestor) type, and the parent
+         --  subtype of the full type must be constrained if and only if
+         --  the ancestor subtype of the private extension is constrained.
+
+         elsif not Present (Discriminant_Specifications (Parent (Priv_T)))
+           and then not Has_Unknown_Discriminants (Priv_T)
+           and then Has_Discriminants (Base_Type (Priv_Parent))
+         then
+            declare
+               Priv_Indic  : constant Node_Id :=
+                               Subtype_Indication (Parent (Priv_T));
+
+               Priv_Constr : constant Boolean :=
+                               Is_Constrained (Priv_Parent)
+                                 or else
+                                   Nkind (Priv_Indic) = N_Subtype_Indication
+                                 or else Is_Constrained (Entity (Priv_Indic));
+
+               Full_Constr : constant Boolean :=
+                               Is_Constrained (Full_Parent)
+                                 or else
+                                   Nkind (Full_Indic) = N_Subtype_Indication
+                                 or else Is_Constrained (Entity (Full_Indic));
+
+               Priv_Discr : Entity_Id;
+               Full_Discr : Entity_Id;
+
+            begin
+               Priv_Discr := First_Discriminant (Priv_Parent);
+               Full_Discr := First_Discriminant (Full_Parent);
+
+               while Present (Priv_Discr) and then Present (Full_Discr) loop
+                  if Original_Record_Component (Priv_Discr) =
+                     Original_Record_Component (Full_Discr)
+                    or else
+                     Corresponding_Discriminant (Priv_Discr) =
+                     Corresponding_Discriminant (Full_Discr)
+                  then
+                     null;
+                  else
+                     exit;
+                  end if;
+
+                  Next_Discriminant (Priv_Discr);
+                  Next_Discriminant (Full_Discr);
+               end loop;
+
+               if Present (Priv_Discr) or else Present (Full_Discr) then
+                  Error_Msg_N
+                    ("full view must inherit discriminants of the parent type"
+                     & " used in the private extension", Full_Indic);
+
+               elsif Priv_Constr and then not Full_Constr then
+                  Error_Msg_N
+                    ("parent subtype of full type must be constrained",
+                     Full_Indic);
+
+               elsif Full_Constr and then not Priv_Constr then
+                  Error_Msg_N
+                    ("parent subtype of full type must be unconstrained",
+                     Full_Indic);
+               end if;
+            end;
+
+         --  Check the rules of 7.3(12): if a partial view has neither known
+         --  or unknown discriminants, then the full type declaration shall
+         --  define a definite subtype.
+
+         elsif      not Has_Unknown_Discriminants (Priv_T)
+           and then not Has_Discriminants (Priv_T)
+           and then not Is_Constrained (Full_T)
+         then
+            Error_Msg_N
+              ("full view must define a constrained type if partial view"
+               & " has no discriminants", Full_T);
+         end if;
+
+         --  ??????? Do we implement the following properly ?????
+         --  If the ancestor subtype of a private extension has constrained
+         --  discriminants, then the parent subtype of the full view shall
+         --  impose a statically matching constraint on those discriminants
+         --  [7.3(13)].
+
+      else
+         --  For untagged types, verify that a type without discriminants
+         --  is not completed with an unconstrained type.
+
+         if not Is_Indefinite_Subtype (Priv_T)
+           and then Is_Indefinite_Subtype (Full_T)
+         then
+            Error_Msg_N ("full view of type must be definite subtype", Full_T);
+         end if;
+      end if;
+
+      --  Create a full declaration for all its subtypes recorded in
+      --  Private_Dependents and swap them similarly to the base type.
+      --  These are subtypes that have been define before the full
+      --  declaration of the private type. We also swap the entry in
+      --  Private_Dependents list so we can properly restore the
+      --  private view on exit from the scope.
+
+      declare
+         Priv_Elmt : Elmt_Id;
+         Priv      : Entity_Id;
+         Full      : Entity_Id;
+
+      begin
+         Priv_Elmt := First_Elmt (Private_Dependents (Priv_T));
+         while Present (Priv_Elmt) loop
+            Priv := Node (Priv_Elmt);
+
+            if Ekind (Priv) = E_Private_Subtype
+              or else Ekind (Priv) = E_Limited_Private_Subtype
+              or else Ekind (Priv) = E_Record_Subtype_With_Private
+            then
+               Full := Make_Defining_Identifier (Sloc (Priv), Chars (Priv));
+               Set_Is_Itype (Full);
+               Set_Parent (Full, Parent (Priv));
+               Set_Associated_Node_For_Itype (Full, N);
+
+               --  Now we need to complete the private subtype, but since the
+               --  base type has already been swapped, we must also swap the
+               --  subtypes (and thus, reverse the arguments in the call to
+               --  Complete_Private_Subtype).
+
+               Copy_And_Swap (Priv, Full);
+               Complete_Private_Subtype (Full, Priv, Full_T, N);
+               Replace_Elmt (Priv_Elmt, Full);
+            end if;
+
+            Next_Elmt (Priv_Elmt);
+         end loop;
+      end;
+
+      --  If the private view was tagged, copy the new Primitive
+      --  operations from the private view to the full view.
+
+      if Is_Tagged_Type (Full_T) then
+         declare
+            Priv_List : Elist_Id;
+            Full_List : constant Elist_Id := Primitive_Operations (Full_T);
+            P1, P2    : Elmt_Id;
+            Prim      : Entity_Id;
+            D_Type    : Entity_Id;
+
+         begin
+            if Is_Tagged_Type (Priv_T) then
+               Priv_List := Primitive_Operations (Priv_T);
+
+               P1 := First_Elmt (Priv_List);
+               while Present (P1) loop
+                  Prim := Node (P1);
+
+                  --  Transfer explicit primitives, not those inherited from
+                  --  parent of partial view, which will be re-inherited on
+                  --  the full view.
+
+                  if Comes_From_Source (Prim) then
+                     P2 := First_Elmt (Full_List);
+                     while Present (P2) and then Node (P2) /= Prim loop
+                        Next_Elmt (P2);
+                     end loop;
+
+                     --  If not found, that is a new one
+
+                     if No (P2) then
+                        Append_Elmt (Prim, Full_List);
+                     end if;
+                  end if;
+
+                  Next_Elmt (P1);
+               end loop;
+
+            else
+               --  In this case the partial view is untagged, so here we
+               --  locate all of the earlier primitives that need to be
+               --  treated as dispatching (those that appear between the
+               --  two views). Note that these additional operations must
+               --  all be new operations (any earlier operations that
+               --  override inherited operations of the full view will
+               --  already have been inserted in the primitives list and
+               --  marked as dispatching by Check_Operation_From_Private_View.
+               --  Note that implicit "/=" operators are excluded from being
+               --  added to the primitives list since they shouldn't be
+               --  treated as dispatching (tagged "/=" is handled specially).
+
+               Prim := Next_Entity (Full_T);
+               while Present (Prim) and then Prim /= Priv_T loop
+                  if (Ekind (Prim) = E_Procedure
+                       or else Ekind (Prim) = E_Function)
+                  then
+
+                     D_Type := Find_Dispatching_Type (Prim);
+
+                     if D_Type = Full_T
+                       and then (Chars (Prim) /= Name_Op_Ne
+                                  or else Comes_From_Source (Prim))
+                     then
+                        Check_Controlling_Formals (Full_T, Prim);
+
+                        if not Is_Dispatching_Operation (Prim) then
+                           Append_Elmt (Prim, Full_List);
+                           Set_Is_Dispatching_Operation (Prim, True);
+                           Set_DT_Position (Prim, No_Uint);
+                        end if;
+
+                     elsif Is_Dispatching_Operation (Prim)
+                       and then D_Type  /= Full_T
+                     then
+
+                        --  Verify that it is not otherwise controlled by
+                        --  a formal or a return value ot type T.
+
+                        Check_Controlling_Formals (D_Type, Prim);
+                     end if;
+                  end if;
+
+                  Next_Entity (Prim);
+               end loop;
+            end if;
+
+            --  For the tagged case, the two views can share the same
+            --  Primitive Operation list and the same class wide type.
+            --  Update attributes of the class-wide type which depend on
+            --  the full declaration.
+
+            if Is_Tagged_Type (Priv_T) then
+               Set_Primitive_Operations (Priv_T, Full_List);
+               Set_Class_Wide_Type
+                 (Base_Type (Full_T), Class_Wide_Type (Priv_T));
+
+               --  Any other attributes should be propagated to C_W ???
+
+               Set_Has_Task (Class_Wide_Type (Priv_T), Has_Task (Full_T));
+
+            end if;
+         end;
+      end if;
+   end Process_Full_View;
+
+   -----------------------------------
+   -- Process_Incomplete_Dependents --
+   -----------------------------------
+
+   procedure Process_Incomplete_Dependents
+     (N      : Node_Id;
+      Full_T : Entity_Id;
+      Inc_T  : Entity_Id)
+   is
+      Inc_Elmt : Elmt_Id;
+      Priv_Dep : Entity_Id;
+      New_Subt : Entity_Id;
+
+      Disc_Constraint : Elist_Id;
+
+   begin
+      if No (Private_Dependents (Inc_T)) then
+         return;
+
+      else
+         Inc_Elmt := First_Elmt (Private_Dependents (Inc_T));
+
+         --  Itypes that may be generated by the completion of an incomplete
+         --  subtype are not used by the back-end and not attached to the tree.
+         --  They are created only for constraint-checking purposes.
+      end if;
+
+      while Present (Inc_Elmt) loop
+         Priv_Dep := Node (Inc_Elmt);
+
+         if Ekind (Priv_Dep) = E_Subprogram_Type then
+
+            --  An Access_To_Subprogram type may have a return type or a
+            --  parameter type that is incomplete. Replace with the full view.
+
+            if Etype (Priv_Dep) = Inc_T then
+               Set_Etype (Priv_Dep, Full_T);
+            end if;
+
+            declare
+               Formal : Entity_Id;
+
+            begin
+               Formal := First_Formal (Priv_Dep);
+
+               while Present (Formal) loop
+
+                  if Etype (Formal) = Inc_T then
+                     Set_Etype (Formal, Full_T);
+                  end if;
+
+                  Next_Formal (Formal);
+               end loop;
+            end;
+
+         elsif  Is_Overloadable (Priv_Dep) then
+
+            if Is_Tagged_Type (Full_T) then
+
+               --  Subprogram has an access parameter whose designated type
+               --  was incomplete. Reexamine declaration now, because it may
+               --  be a primitive operation of the full type.
+
+               Check_Operation_From_Incomplete_Type (Priv_Dep, Inc_T);
+               Set_Is_Dispatching_Operation (Priv_Dep);
+               Check_Controlling_Formals (Full_T, Priv_Dep);
+            end if;
+
+         elsif Ekind (Priv_Dep) = E_Subprogram_Body then
+
+            --  Can happen during processing of a body before the completion
+            --  of a TA type. Ignore, because spec is also on dependent list.
+
+            return;
+
+         --  Dependent is a subtype
+
+         else
+            --  We build a new subtype indication using the full view of the
+            --  incomplete parent. The discriminant constraints have been
+            --  elaborated already at the point of the subtype declaration.
+
+            New_Subt := Create_Itype (E_Void, N);
+
+            if Has_Discriminants (Full_T) then
+               Disc_Constraint := Discriminant_Constraint (Priv_Dep);
+            else
+               Disc_Constraint := No_Elist;
+            end if;
+
+            Build_Discriminated_Subtype (Full_T, New_Subt, Disc_Constraint, N);
+            Set_Full_View (Priv_Dep, New_Subt);
+         end if;
+
+         Next_Elmt (Inc_Elmt);
+      end loop;
+
+   end Process_Incomplete_Dependents;
+
+   --------------------------------
+   -- Process_Range_Expr_In_Decl --
+   --------------------------------
+
+   procedure Process_Range_Expr_In_Decl
+     (R           : Node_Id;
+      T           : Entity_Id;
+      Related_Nod : Node_Id;
+      Check_List  : List_Id := Empty_List;
+      R_Check_Off : Boolean := False)
+   is
+      Lo, Hi    : Node_Id;
+      R_Checks  : Check_Result;
+      Type_Decl : Node_Id;
+      Def_Id    : Entity_Id;
+
+   begin
+      Analyze_And_Resolve (R, Base_Type (T));
+
+      if Nkind (R) = N_Range then
+         Lo := Low_Bound (R);
+         Hi := High_Bound (R);
+
+         --  If there were errors in the declaration, try and patch up some
+         --  common mistakes in the bounds. The cases handled are literals
+         --  which are Integer where the expected type is Real and vice versa.
+         --  These corrections allow the compilation process to proceed further
+         --  along since some basic assumptions of the format of the bounds
+         --  are guaranteed.
+
+         if Etype (R) = Any_Type then
+
+            if Nkind (Lo) = N_Integer_Literal and then Is_Real_Type (T) then
+               Rewrite (Lo,
+                 Make_Real_Literal (Sloc (Lo), UR_From_Uint (Intval (Lo))));
+
+            elsif Nkind (Hi) = N_Integer_Literal and then Is_Real_Type (T) then
+               Rewrite (Hi,
+                 Make_Real_Literal (Sloc (Hi), UR_From_Uint (Intval (Hi))));
+
+            elsif Nkind (Lo) = N_Real_Literal and then Is_Integer_Type (T) then
+               Rewrite (Lo,
+                 Make_Integer_Literal (Sloc (Lo), UR_To_Uint (Realval (Lo))));
+
+            elsif Nkind (Hi) = N_Real_Literal and then Is_Integer_Type (T) then
+               Rewrite (Hi,
+                 Make_Integer_Literal (Sloc (Hi), UR_To_Uint (Realval (Hi))));
+            end if;
+
+            Set_Etype (Lo, T);
+            Set_Etype (Hi, T);
+         end if;
+
+         --  If the bounds of the range have been mistakenly given as
+         --  string literals (perhaps in place of character literals),
+         --  then an error has already been reported, but we rewrite
+         --  the string literal as a bound of the range's type to
+         --  avoid blowups in later processing that looks at static
+         --  values.
+
+         if Nkind (Lo) = N_String_Literal then
+            Rewrite (Lo,
+              Make_Attribute_Reference (Sloc (Lo),
+                Attribute_Name => Name_First,
+                Prefix => New_Reference_To (T, Sloc (Lo))));
+            Analyze_And_Resolve (Lo);
+         end if;
+
+         if Nkind (Hi) = N_String_Literal then
+            Rewrite (Hi,
+              Make_Attribute_Reference (Sloc (Hi),
+                Attribute_Name => Name_First,
+                Prefix => New_Reference_To (T, Sloc (Hi))));
+            Analyze_And_Resolve (Hi);
+         end if;
+
+         --  If bounds aren't scalar at this point then exit, avoiding
+         --  problems with further processing of the range in this procedure.
+
+         if not Is_Scalar_Type (Etype (Lo)) then
+            return;
+         end if;
+
+         --  Resolve (actually Sem_Eval) has checked that the bounds are in
+         --  then range of the base type. Here we check whether the bounds
+         --  are in the range of the subtype itself. Note that if the bounds
+         --  represent the null range the Constraint_Error exception should
+         --  not be raised.
+
+         --  ??? The following code should be cleaned up as follows
+         --  1. The Is_Null_Range (Lo, Hi) test should disapper since it
+         --     is done in the call to Range_Check (R, T); below
+         --  2. The use of R_Check_Off should be investigated and possibly
+         --     removed, this would clean up things a bit.
+
+         if Is_Null_Range (Lo, Hi) then
+            null;
+
+         else
+            --  We use a flag here instead of suppressing checks on the
+            --  type because the type we check against isn't necessarily the
+            --  place where we put the check.
+
+            if not R_Check_Off then
+               R_Checks := Range_Check (R, T);
+               Type_Decl := Parent (R);
+
+               --  Look up tree to find an appropriate insertion point.
+               --  This seems really junk code, and very brittle, couldn't
+               --  we just use an insert actions call of some kind ???
+
+               while Present (Type_Decl) and then not
+                 (Nkind (Type_Decl) = N_Full_Type_Declaration
+                    or else
+                  Nkind (Type_Decl) = N_Subtype_Declaration
+                    or else
+                  Nkind (Type_Decl) = N_Loop_Statement
+                    or else
+                  Nkind (Type_Decl) = N_Task_Type_Declaration
+                    or else
+                  Nkind (Type_Decl) = N_Single_Task_Declaration
+                    or else
+                  Nkind (Type_Decl) = N_Protected_Type_Declaration
+                    or else
+                  Nkind (Type_Decl) = N_Single_Protected_Declaration)
+               loop
+                  Type_Decl := Parent (Type_Decl);
+               end loop;
+
+               --  Why would Type_Decl not be present???  Without this test,
+               --  short regression tests fail.
+
+               if Present (Type_Decl) then
+                  if Nkind (Type_Decl) = N_Loop_Statement then
+                     declare
+                        Indic : Node_Id := Parent (R);
+                     begin
+                        while Present (Indic) and then not
+                          (Nkind (Indic) = N_Subtype_Indication)
+                        loop
+                           Indic := Parent (Indic);
+                        end loop;
+
+                        if Present (Indic) then
+                           Def_Id := Etype (Subtype_Mark (Indic));
+
+                           Insert_Range_Checks
+                             (R_Checks,
+                              Type_Decl,
+                              Def_Id,
+                              Sloc (Type_Decl),
+                              R,
+                              Do_Before => True);
+                        end if;
+                     end;
+                  else
+                     Def_Id := Defining_Identifier (Type_Decl);
+
+                     if (Ekind (Def_Id) = E_Record_Type
+                          and then Depends_On_Discriminant (R))
+                       or else
+                        (Ekind (Def_Id) = E_Protected_Type
+                          and then Has_Discriminants (Def_Id))
+                     then
+                        Append_Range_Checks
+                          (R_Checks, Check_List, Def_Id, Sloc (Type_Decl), R);
+
+                     else
+                        Insert_Range_Checks
+                          (R_Checks, Type_Decl, Def_Id, Sloc (Type_Decl), R);
+
+                     end if;
+                  end if;
+               end if;
+            end if;
+         end if;
+      end if;
+
+      Get_Index_Bounds (R, Lo, Hi);
+
+      if Expander_Active then
+         Force_Evaluation (Lo);
+         Force_Evaluation (Hi);
+      end if;
+
+   end Process_Range_Expr_In_Decl;
+
+   --------------------------------------
+   -- Process_Real_Range_Specification --
+   --------------------------------------
+
+   procedure Process_Real_Range_Specification (Def : Node_Id) is
+      Spec : constant Node_Id := Real_Range_Specification (Def);
+      Lo   : Node_Id;
+      Hi   : Node_Id;
+      Err  : Boolean := False;
+
+      procedure Analyze_Bound (N : Node_Id);
+      --  Analyze and check one bound
+
+      procedure Analyze_Bound (N : Node_Id) is
+      begin
+         Analyze_And_Resolve (N, Any_Real);
+
+         if not Is_OK_Static_Expression (N) then
+            Error_Msg_N
+              ("bound in real type definition is not static", N);
+            Err := True;
+         end if;
+      end Analyze_Bound;
+
+   begin
+      if Present (Spec) then
+         Lo := Low_Bound (Spec);
+         Hi := High_Bound (Spec);
+         Analyze_Bound (Lo);
+         Analyze_Bound (Hi);
+
+         --  If error, clear away junk range specification
+
+         if Err then
+            Set_Real_Range_Specification (Def, Empty);
+         end if;
+      end if;
+   end Process_Real_Range_Specification;
+
+   ---------------------
+   -- Process_Subtype --
+   ---------------------
+
+   function Process_Subtype
+     (S           : Node_Id;
+      Related_Nod : Node_Id;
+      Related_Id  : Entity_Id := Empty;
+      Suffix      : Character := ' ')
+      return        Entity_Id
+   is
+      P               : Node_Id;
+      Def_Id          : Entity_Id;
+      Full_View_Id    : Entity_Id;
+      Subtype_Mark_Id : Entity_Id;
+      N_Dynamic_Ityp  : Node_Id := Empty;
+
+   begin
+      --  Case of constraint present, so that we have an N_Subtype_Indication
+      --  node (this node is created only if constraints are present).
+
+      if Nkind (S) = N_Subtype_Indication then
+         Find_Type (Subtype_Mark (S));
+
+         if Nkind (Parent (S)) /= N_Access_To_Object_Definition
+           and then not
+            (Nkind (Parent (S)) = N_Subtype_Declaration
+              and then
+             Is_Itype (Defining_Identifier (Parent (S))))
+         then
+            Check_Incomplete (Subtype_Mark (S));
+         end if;
+
+         P := Parent (S);
+         Subtype_Mark_Id := Entity (Subtype_Mark (S));
+
+         if Is_Unchecked_Union (Subtype_Mark_Id)
+           and then Comes_From_Source (Related_Nod)
+         then
+            Error_Msg_N
+              ("cannot create subtype of Unchecked_Union", Related_Nod);
+         end if;
+
+         --  Explicit subtype declaration case
+
+         if Nkind (P) = N_Subtype_Declaration then
+            Def_Id := Defining_Identifier (P);
+
+         --  Explicit derived type definition case
+
+         elsif Nkind (P) = N_Derived_Type_Definition then
+            Def_Id := Defining_Identifier (Parent (P));
+
+         --  Implicit case, the Def_Id must be created as an implicit type.
+         --  The one exception arises in the case of concurrent types,
+         --  array and access types, where other subsidiary implicit types
+         --  may be created and must appear before the main implicit type.
+         --  In these cases we leave Def_Id set to Empty as a signal that
+         --  Create_Itype has not yet been called to create Def_Id.
+
+         else
+            if Is_Array_Type (Subtype_Mark_Id)
+              or else Is_Concurrent_Type (Subtype_Mark_Id)
+              or else Is_Access_Type (Subtype_Mark_Id)
+            then
+               Def_Id := Empty;
+
+            --  For the other cases, we create a new unattached Itype,
+            --  and set the indication to ensure it gets attached later.
+
+            else
+               Def_Id :=
+                 Create_Itype (E_Void, Related_Nod, Related_Id, Suffix);
+            end if;
+
+            N_Dynamic_Ityp := Related_Nod;
+         end if;
+
+         --  If the kind of constraint is invalid for this kind of type,
+         --  then give an error, and then pretend no constraint was given.
+
+         if not Is_Valid_Constraint_Kind
+                   (Ekind (Subtype_Mark_Id), Nkind (Constraint (S)))
+         then
+            Error_Msg_N
+              ("incorrect constraint for this kind of type", Constraint (S));
+
+            Rewrite (S, New_Copy_Tree (Subtype_Mark (S)));
+
+            --  Make recursive call, having got rid of the bogus constraint
+
+            return Process_Subtype (S, Related_Nod, Related_Id, Suffix);
+         end if;
+
+         --  Remaining processing depends on type
+
+         case Ekind (Subtype_Mark_Id) is
+
+            when Access_Kind =>
+               Constrain_Access (Def_Id, S, Related_Nod);
+
+            when Array_Kind =>
+               Constrain_Array (Def_Id, S, Related_Nod, Related_Id, Suffix);
+
+            when Decimal_Fixed_Point_Kind =>
+               Constrain_Decimal (Def_Id, S, N_Dynamic_Ityp);
+
+            when Enumeration_Kind =>
+               Constrain_Enumeration (Def_Id, S, N_Dynamic_Ityp);
+
+            when Ordinary_Fixed_Point_Kind =>
+               Constrain_Ordinary_Fixed (Def_Id, S, N_Dynamic_Ityp);
+
+            when Float_Kind =>
+               Constrain_Float (Def_Id, S, N_Dynamic_Ityp);
+
+            when Integer_Kind =>
+               Constrain_Integer (Def_Id, S, N_Dynamic_Ityp);
+
+            when E_Record_Type     |
+                 E_Record_Subtype  |
+                 Class_Wide_Kind   |
+                 E_Incomplete_Type =>
+               Constrain_Discriminated_Type (Def_Id, S, Related_Nod);
+
+            when Private_Kind =>
+               Constrain_Discriminated_Type (Def_Id, S, Related_Nod);
+               Set_Private_Dependents (Def_Id, New_Elmt_List);
+
+               --  In case of an invalid constraint prevent further processing
+               --  since the type constructed is missing expected fields.
+
+               if Etype (Def_Id) = Any_Type then
+                  return Def_Id;
+               end if;
+
+               --  If the full view is that of a task with discriminants,
+               --  we must constrain both the concurrent type and its
+               --  corresponding record type. Otherwise we will just propagate
+               --  the constraint to the full view, if available.
+
+               if Present (Full_View (Subtype_Mark_Id))
+                 and then Has_Discriminants (Subtype_Mark_Id)
+                 and then Is_Concurrent_Type (Full_View (Subtype_Mark_Id))
+               then
+                  Full_View_Id :=
+                    Create_Itype (E_Void, Related_Nod, Related_Id, Suffix);
+
+                  Set_Entity (Subtype_Mark (S), Full_View (Subtype_Mark_Id));
+                  Constrain_Concurrent (Full_View_Id, S,
+                    Related_Nod, Related_Id, Suffix);
+                  Set_Entity (Subtype_Mark (S), Subtype_Mark_Id);
+                  Set_Full_View (Def_Id, Full_View_Id);
+
+               else
+                  Prepare_Private_Subtype_Completion (Def_Id, Related_Nod);
+               end if;
+
+            when Concurrent_Kind  =>
+               Constrain_Concurrent (Def_Id, S,
+                 Related_Nod, Related_Id, Suffix);
+
+            when others =>
+               Error_Msg_N ("invalid subtype mark in subtype indication", S);
+         end case;
+
+         --  Size and Convention are always inherited from the base type
+
+         Set_Size_Info  (Def_Id,            (Subtype_Mark_Id));
+         Set_Convention (Def_Id, Convention (Subtype_Mark_Id));
+
+         return Def_Id;
+
+      --  Case of no constraints present
+
+      else
+         Find_Type (S);
+         Check_Incomplete (S);
+         return Entity (S);
+      end if;
+   end Process_Subtype;
+
+   -----------------------------
+   -- Record_Type_Declaration --
+   -----------------------------
+
+   procedure Record_Type_Declaration (T : Entity_Id; N : Node_Id) is
+      Def : constant Node_Id := Type_Definition (N);
+      Range_Checks_Suppressed_Flag : Boolean := False;
+
+      Is_Tagged : Boolean;
+      Tag_Comp  : Entity_Id;
+
+   begin
+      --  The flag Is_Tagged_Type might have already been set by Find_Type_Name
+      --  if it detected an error for declaration T. This arises in the case of
+      --  private tagged types where the full view omits the word tagged.
+
+      Is_Tagged := Tagged_Present (Def)
+        or else (Errors_Detected > 0 and then Is_Tagged_Type (T));
+
+      --  Records constitute a scope for the component declarations within.
+      --  The scope is created prior to the processing of these declarations.
+      --  Discriminants are processed first, so that they are visible when
+      --  processing the other components. The Ekind of the record type itself
+      --  is set to E_Record_Type (subtypes appear as E_Record_Subtype).
+
+      --  Enter record scope
+
+      New_Scope (T);
+
+      --  These flags must be initialized before calling Process_Discriminants
+      --  because this routine makes use of them.
+
+      Set_Is_Tagged_Type     (T, Is_Tagged);
+      Set_Is_Limited_Record  (T, Limited_Present (Def));
+
+      --  Type is abstract if full declaration carries keyword, or if
+      --  previous partial view did.
+
+      Set_Is_Abstract (T, Is_Abstract (T) or else Abstract_Present (Def));
+
+      Set_Ekind       (T, E_Record_Type);
+      Set_Etype       (T, T);
+      Init_Size_Align (T);
+
+      Set_Girder_Constraint (T, No_Elist);
+
+      --  If an incomplete or private type declaration was already given for
+      --  the type, then this scope already exists, and the discriminants have
+      --  been declared within. We must verify that the full declaration
+      --  matches the incomplete one.
+
+      Check_Or_Process_Discriminants (N, T);
+
+      Set_Is_Constrained     (T, not Has_Discriminants (T));
+      Set_Has_Delayed_Freeze (T, True);
+
+      --  For tagged types add a manually analyzed component corresponding
+      --  to the component _tag, the corresponding piece of tree will be
+      --  expanded as part of the freezing actions if it is not a CPP_Class.
+
+      if Is_Tagged then
+         --  Do not add the tag unless we are in expansion mode.
+
+         if Expander_Active then
+            Tag_Comp := Make_Defining_Identifier (Sloc (Def), Name_uTag);
+            Enter_Name (Tag_Comp);
+
+            Set_Is_Tag                    (Tag_Comp);
+            Set_Ekind                     (Tag_Comp, E_Component);
+            Set_Etype                     (Tag_Comp, RTE (RE_Tag));
+            Set_DT_Entry_Count            (Tag_Comp, No_Uint);
+            Set_Original_Record_Component (Tag_Comp, Tag_Comp);
+            Init_Component_Location       (Tag_Comp);
+         end if;
+
+         Make_Class_Wide_Type (T);
+         Set_Primitive_Operations (T, New_Elmt_List);
+      end if;
+
+      --  We must suppress range checks when processing the components
+      --  of a record in the presence of discriminants, since we don't
+      --  want spurious checks to be generated during their analysis, but
+      --  must reset the Suppress_Range_Checks flags after having procesed
+      --  the record definition.
+
+      if Has_Discriminants (T) and then not Suppress_Range_Checks (T) then
+         Set_Suppress_Range_Checks (T, True);
+         Range_Checks_Suppressed_Flag := True;
+      end if;
+
+      Record_Type_Definition (Def, T);
+
+      if Range_Checks_Suppressed_Flag then
+         Set_Suppress_Range_Checks (T, False);
+         Range_Checks_Suppressed_Flag := False;
+      end if;
+
+      --  Exit from record scope
+
+      End_Scope;
+   end Record_Type_Declaration;
+
+   ----------------------------
+   -- Record_Type_Definition --
+   ----------------------------
+
+   procedure Record_Type_Definition (Def : Node_Id; T : Entity_Id) is
+      Component          : Entity_Id;
+      Ctrl_Components    : Boolean := False;
+      Final_Storage_Only : Boolean := not Is_Controlled (T);
+
+   begin
+      --  If the component list of a record type is defined by the reserved
+      --  word null and there is no discriminant part, then the record type has
+      --  no components and all records of the type are null records (RM 3.7)
+      --  This procedure is also called to process the extension part of a
+      --  record extension, in which case the current scope may have inherited
+      --  components.
+
+      if No (Def)
+        or else No (Component_List (Def))
+        or else Null_Present (Component_List (Def))
+      then
+         null;
+
+      else
+         Analyze_Declarations (Component_Items (Component_List (Def)));
+
+         if Present (Variant_Part (Component_List (Def))) then
+            Analyze (Variant_Part (Component_List (Def)));
+         end if;
+      end if;
+
+      --  After completing the semantic analysis of the record definition,
+      --  record components, both new and inherited, are accessible. Set
+      --  their kind accordingly.
+
+      Component := First_Entity (Current_Scope);
+      while Present (Component) loop
+
+         if Ekind (Component) = E_Void then
+            Set_Ekind (Component, E_Component);
+            Init_Component_Location (Component);
+         end if;
+
+         if Has_Task (Etype (Component)) then
+            Set_Has_Task (T);
+         end if;
+
+         if Ekind (Component) /= E_Component then
+            null;
+
+         elsif Has_Controlled_Component (Etype (Component))
+           or else (Chars (Component) /= Name_uParent
+                    and then Is_Controlled (Etype (Component)))
+         then
+            Set_Has_Controlled_Component (T, True);
+            Final_Storage_Only := Final_Storage_Only
+              and then Finalize_Storage_Only (Etype (Component));
+            Ctrl_Components := True;
+         end if;
+
+         Next_Entity (Component);
+      end loop;
+
+      --  A type is Finalize_Storage_Only only if all its controlled
+      --  components are so.
+
+      if Ctrl_Components then
+         Set_Finalize_Storage_Only (T, Final_Storage_Only);
+      end if;
+
+      if Present (Def) then
+         Process_End_Label (Def, 'e');
+      end if;
+   end Record_Type_Definition;
+
+   ---------------------
+   -- Set_Fixed_Range --
+   ---------------------
+
+   --  The range for fixed-point types is complicated by the fact that we
+   --  do not know the exact end points at the time of the declaration. This
+   --  is true for three reasons:
+
+   --     A size clause may affect the fudging of the end-points
+   --     A small clause may affect the values of the end-points
+   --     We try to include the end-points if it does not affect the size
+
+   --  This means that the actual end-points must be established at the
+   --  point when the type is frozen. Meanwhile, we first narrow the range
+   --  as permitted (so that it will fit if necessary in a small specified
+   --  size), and then build a range subtree with these narrowed bounds.
+
+   --  Set_Fixed_Range constructs the range from real literal values, and
+   --  sets the range as the Scalar_Range of the given fixed-point type
+   --  entity.
+
+   --  The parent of this range is set to point to the entity so that it
+   --  is properly hooked into the tree (unlike normal Scalar_Range entries
+   --  for other scalar types, which are just pointers to the range in the
+   --  original tree, this would otherwise be an orphan).
+
+   --  The tree is left unanalyzed. When the type is frozen, the processing
+   --  in Freeze.Freeze_Fixed_Point_Type notices that the range is not
+   --  analyzed, and uses this as an indication that it should complete
+   --  work on the range (it will know the final small and size values).
+
+   procedure Set_Fixed_Range
+     (E   : Entity_Id;
+      Loc : Source_Ptr;
+      Lo  : Ureal;
+      Hi  : Ureal)
+   is
+      S : constant Node_Id :=
+            Make_Range (Loc,
+              Low_Bound  => Make_Real_Literal (Loc, Lo),
+              High_Bound => Make_Real_Literal (Loc, Hi));
+
+   begin
+      Set_Scalar_Range (E, S);
+      Set_Parent (S, E);
+   end Set_Fixed_Range;
+
+   --------------------------------------------------------
+   -- Set_Girder_Constraint_From_Discriminant_Constraint --
+   --------------------------------------------------------
+
+   procedure Set_Girder_Constraint_From_Discriminant_Constraint
+     (E : Entity_Id)
+   is
+   begin
+      --  Make sure set if encountered during
+      --  Expand_To_Girder_Constraint
+
+      Set_Girder_Constraint (E, No_Elist);
+
+      --  Give it the right value
+
+      if Is_Constrained (E) and then Has_Discriminants (E) then
+         Set_Girder_Constraint (E,
+           Expand_To_Girder_Constraint (E, Discriminant_Constraint (E)));
+      end if;
+
+   end Set_Girder_Constraint_From_Discriminant_Constraint;
+
+   ----------------------------------
+   -- Set_Scalar_Range_For_Subtype --
+   ----------------------------------
+
+   procedure Set_Scalar_Range_For_Subtype
+     (Def_Id      : Entity_Id;
+      R           : Node_Id;
+      Subt        : Entity_Id;
+      Related_Nod : Node_Id)
+   is
+      Kind : constant Entity_Kind :=  Ekind (Def_Id);
+   begin
+      Set_Scalar_Range (Def_Id, R);
+
+      --  We need to link the range into the tree before resolving it so
+      --  that types that are referenced, including importantly the subtype
+      --  itself, are properly frozen (Freeze_Expression requires that the
+      --  expression be properly linked into the tree). Of course if it is
+      --  already linked in, then we do not disturb the current link.
+
+      if No (Parent (R)) then
+         Set_Parent (R, Def_Id);
+      end if;
+
+      --  Reset the kind of the subtype during analysis of the range, to
+      --  catch possible premature use in the bounds themselves.
+
+      Set_Ekind (Def_Id, E_Void);
+      Process_Range_Expr_In_Decl (R, Subt, Related_Nod);
+      Set_Ekind (Def_Id, Kind);
+
+   end Set_Scalar_Range_For_Subtype;
+
+   -------------------------------------
+   -- Signed_Integer_Type_Declaration --
+   -------------------------------------
+
+   procedure Signed_Integer_Type_Declaration (T : Entity_Id; Def : Node_Id) is
+      Implicit_Base : Entity_Id;
+      Base_Typ      : Entity_Id;
+      Lo_Val        : Uint;
+      Hi_Val        : Uint;
+      Errs          : Boolean := False;
+      Lo            : Node_Id;
+      Hi            : Node_Id;
+
+      function Can_Derive_From (E : Entity_Id) return Boolean;
+      --  Determine whether given bounds allow derivation from specified type
+
+      procedure Check_Bound (Expr : Node_Id);
+      --  Check bound to make sure it is integral and static. If not, post
+      --  appropriate error message and set Errs flag
+
+      function Can_Derive_From (E : Entity_Id) return Boolean is
+         Lo : constant Uint := Expr_Value (Type_Low_Bound (E));
+         Hi : constant Uint := Expr_Value (Type_High_Bound (E));
+
+      begin
+         --  Note we check both bounds against both end values, to deal with
+         --  strange types like ones with a range of 0 .. -12341234.
+
+         return Lo <= Lo_Val and then Lo_Val <= Hi
+                  and then
+                Lo <= Hi_Val and then Hi_Val <= Hi;
+      end Can_Derive_From;
+
+      procedure Check_Bound (Expr : Node_Id) is
+      begin
+         --  If a range constraint is used as an integer type definition, each
+         --  bound of the range must be defined by a static expression of some
+         --  integer type, but the two bounds need not have the same integer
+         --  type (Negative bounds are allowed.) (RM 3.5.4)
+
+         if not Is_Integer_Type (Etype (Expr)) then
+            Error_Msg_N
+              ("integer type definition bounds must be of integer type", Expr);
+            Errs := True;
+
+         elsif not Is_OK_Static_Expression (Expr) then
+            Error_Msg_N
+              ("non-static expression used for integer type bound", Expr);
+            Errs := True;
+
+         --  The bounds are folded into literals, and we set their type to be
+         --  universal, to avoid typing difficulties: we cannot set the type
+         --  of the literal to the new type, because this would be a forward
+         --  reference for the back end,  and if the original type is user-
+         --  defined this can lead to spurious semantic errors (e.g. 2928-003).
+
+         else
+            if Is_Entity_Name (Expr) then
+               Fold_Uint (Expr, Expr_Value (Expr));
+            end if;
+
+            Set_Etype (Expr, Universal_Integer);
+         end if;
+      end Check_Bound;
+
+   --  Start of processing for Signed_Integer_Type_Declaration
+
+   begin
+      --  Create an anonymous base type
+
+      Implicit_Base :=
+        Create_Itype (E_Signed_Integer_Type, Parent (Def), T, 'B');
+
+      --  Analyze and check the bounds, they can be of any integer type
+
+      Lo := Low_Bound (Def);
+      Hi := High_Bound (Def);
+      Analyze_And_Resolve (Lo, Any_Integer);
+      Analyze_And_Resolve (Hi, Any_Integer);
+
+      Check_Bound (Lo);
+      Check_Bound (Hi);
+
+      if Errs then
+         Hi := Type_High_Bound (Standard_Long_Long_Integer);
+         Lo := Type_Low_Bound (Standard_Long_Long_Integer);
+      end if;
+
+      --  Find type to derive from
+
+      Lo_Val := Expr_Value (Lo);
+      Hi_Val := Expr_Value (Hi);
+
+      if Can_Derive_From (Standard_Short_Short_Integer) then
+         Base_Typ := Base_Type (Standard_Short_Short_Integer);
+
+      elsif Can_Derive_From (Standard_Short_Integer) then
+         Base_Typ := Base_Type (Standard_Short_Integer);
+
+      elsif Can_Derive_From (Standard_Integer) then
+         Base_Typ := Base_Type (Standard_Integer);
+
+      elsif Can_Derive_From (Standard_Long_Integer) then
+         Base_Typ := Base_Type (Standard_Long_Integer);
+
+      elsif Can_Derive_From (Standard_Long_Long_Integer) then
+         Base_Typ := Base_Type (Standard_Long_Long_Integer);
+
+      else
+         Base_Typ := Base_Type (Standard_Long_Long_Integer);
+         Error_Msg_N ("integer type definition bounds out of range", Def);
+         Hi := Type_High_Bound (Standard_Long_Long_Integer);
+         Lo := Type_Low_Bound (Standard_Long_Long_Integer);
+      end if;
+
+      --  Complete both implicit base and declared first subtype entities
+
+      Set_Etype          (Implicit_Base, Base_Typ);
+      Set_Scalar_Range   (Implicit_Base, Scalar_Range   (Base_Typ));
+      Set_Size_Info      (Implicit_Base,                (Base_Typ));
+      Set_RM_Size        (Implicit_Base, RM_Size        (Base_Typ));
+      Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Base_Typ));
+
+      Set_Ekind          (T, E_Signed_Integer_Subtype);
+      Set_Etype          (T, Implicit_Base);
+
+      Set_Size_Info      (T,                (Implicit_Base));
+      Set_First_Rep_Item (T, First_Rep_Item (Implicit_Base));
+      Set_Scalar_Range   (T, Def);
+      Set_RM_Size        (T, UI_From_Int (Minimum_Size (T)));
+      Set_Is_Constrained (T);
+
+   end Signed_Integer_Type_Declaration;
+
+end Sem_Ch3;
diff --git a/gcc/ada/sem_ch3.ads b/gcc/ada/sem_ch3.ads
new file mode 100644
index 00000000000..aefb310c647
--- /dev/null
+++ b/gcc/ada/sem_ch3.ads
@@ -0,0 +1,224 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              S E M _ C H 3                               --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.57 $
+--                                                                          --
+--          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 Nlists; use Nlists;
+with Types;  use Types;
+
+package Sem_Ch3  is
+   procedure Analyze_Component_Declaration              (N : Node_Id);
+   procedure Analyze_Incomplete_Type_Decl               (N : Node_Id);
+   procedure Analyze_Itype_Reference                    (N : Node_Id);
+   procedure Analyze_Number_Declaration                 (N : Node_Id);
+   procedure Analyze_Object_Declaration                 (N : Node_Id);
+   procedure Analyze_Others_Choice                      (N : Node_Id);
+   procedure Analyze_Private_Extension_Declaration      (N : Node_Id);
+   procedure Analyze_Subtype_Declaration                (N : Node_Id);
+   procedure Analyze_Subtype_Indication                 (N : Node_Id);
+   procedure Analyze_Type_Declaration                   (N : Node_Id);
+   procedure Analyze_Variant_Part                       (N : Node_Id);
+
+   function Access_Definition
+     (Related_Nod : Node_Id;
+      N           : Node_Id)
+      return        Entity_Id;
+   --  An access definition defines a general access type for a formal
+   --  parameter.  The procedure is called when processing formals, when
+   --  the current scope is the subprogram. The Implicit type is attached
+   --  to the Related_Nod put into the enclosing scope, so that the only
+   --  entities defined in the spec are the formals themselves.
+
+   procedure Access_Subprogram_Declaration
+     (T_Name : Entity_Id;
+      T_Def  : Node_Id);
+   --  The subprogram specification yields the signature of an implicit
+   --  type, whose Ekind is Access_Subprogram_Type. This implicit type is
+   --  the designated type of the declared access type. In subprogram calls,
+   --  the signature of the implicit type works like the profile of a regular
+   --  subprogram.
+
+   procedure Analyze_Declarations (L : List_Id);
+   --  Called to analyze a list of declarations (in what context ???). Also
+   --  performs necessary freezing actions (more description needed ???)
+
+   procedure Analyze_Default_Expression (N : Node_Id; T : Entity_Id);
+   --  Default expressions do not freeze their components, and must be
+   --  analyzed and resolved accordingly, by calling the
+   --  Pre_Analyze_And_Resolve routine and setting the global
+   --  In_Default_Expression flag.
+
+   procedure Array_Type_Declaration (T : in out Entity_Id; Def : Node_Id);
+   --  Process an array type declaration. If the array is constrained, we
+   --  create an implicit parent array type, with the same index types and
+   --  component type.
+
+   procedure Access_Type_Declaration (T : Entity_Id; Def : Node_Id);
+   --  Process an access type declaration
+
+   procedure Check_Abstract_Overriding (T : Entity_Id);
+   --  Check that all abstract subprograms inherited from T's parent type
+   --  have been overridden as required, and that nonabstract subprograms
+   --  have not been incorrectly overridden with an abstract subprogram.
+
+   procedure Check_Aliased_Component_Types (T : Entity_Id);
+   --  Given an array type or record type T, check that if the type is
+   --  nonlimited, then the nominal subtype of any components of T
+   --  that have discriminants must be constrained.
+
+   procedure Check_Completion (Body_Id : Node_Id := Empty);
+   --  At the end of a declarative part, verify that all entities that
+   --  require completion have received one. If Body_Id is absent, the
+   --  error indicating a missing completion is placed on the declaration
+   --  that needs completion. If Body_Id is present, it is the defining
+   --  identifier of a package body, and errors are posted on that node,
+   --  rather than on the declarations that require completion in the package
+   --  declaration.
+
+   procedure Derive_Subprogram
+     (New_Subp       : in out Entity_Id;
+      Parent_Subp    : Entity_Id;
+      Derived_Type   : Entity_Id;
+      Parent_Type    : Entity_Id;
+      Actual_Subp    : Entity_Id := Empty);
+   --  Derive the subprogram Parent_Subp from Parent_Type, and replace the
+   --  subsidiary subtypes with the derived type to build the specification
+   --  of the inherited subprogram (returned in New_Subp). For tagged types,
+   --  the derived subprogram is aliased to that of the actual (in the
+   --  case where Actual_Subp is nonempty) rather than to the corresponding
+   --  subprogram of the parent type.
+
+   procedure Derive_Subprograms
+     (Parent_Type    : Entity_Id;
+      Derived_Type   : Entity_Id;
+      Generic_Actual : Entity_Id := Empty);
+   --  To complete type derivation, collect or retrieve the primitive
+   --  operations of the parent type, and replace the subsidiary subtypes
+   --  with the derived type, to build the specs of the inherited ops.
+   --  For generic actuals, the mapping of the primitive operations to those
+   --  of the parent type is also done by rederiving the operations within
+   --  the instance. For tagged types, the derived subprograms are aliased to
+   --  those of the actual, not those of the ancestor.
+
+   function Expand_To_Girder_Constraint
+     (Typ        : Entity_Id;
+      Constraint : Elist_Id)
+      return       Elist_Id;
+   --  Given a Constraint (ie a list of expressions) on the discriminants of
+   --  Typ, expand it into a constraint on the girder discriminants and
+   --  return the new list of expressions constraining the girder
+   --  discriminants.
+
+   function Find_Type_Name (N : Node_Id) return Entity_Id;
+   --  Enter the identifier in a type definition, or find the entity already
+   --  declared, in the case of the full declaration of an incomplete or
+   --  private type.
+
+   function Get_Discriminant_Value
+     (Discriminant         : Entity_Id;
+      Typ_For_Constraint   : Entity_Id;
+      Constraint           : Elist_Id)
+      return                 Node_Id;
+   --  ??? MORE DOCUMENTATION
+   --  Given a discriminant somewhere in the Typ_For_Constraint tree
+   --  and a Constraint, return the value of that discriminant.
+
+   function Is_Visible_Component (C : Entity_Id) return Boolean;
+   --  Determines if a record component C is visible in the present context.
+   --  Note that even though component C could appear in the entity chain
+   --  of a record type, C may not be visible in the current context. For
+   --  instance, C may be a component inherited in the full view of a private
+   --  extension which is not visible in the current context.
+
+   procedure Make_Index
+     (I            : Node_Id;
+      Related_Nod  : Node_Id;
+      Related_Id   : Entity_Id := Empty;
+      Suffix_Index : Nat := 1);
+   --  Process an index that is given in an array declaration, an entry
+   --  family declaration or a loop iteration. The index is given by an
+   --  index declaration (a 'box'), or by a discrete range. The later can
+   --  be the name of a discrete type, or a subtype indication.
+   --  Related_Nod is the node where the potential generated implicit types
+   --  will be inserted. The 2 last parameters are used for creating the name.
+
+   procedure Make_Class_Wide_Type (T : Entity_Id);
+   --  A Class_Wide_Type is created for each tagged type definition. The
+   --  attributes of a class wide type are inherited from those of the type
+   --  T. If T is introduced by a private declaration, the corresponding
+   --  class wide type is created at the same time, and therefore there is
+   --  a private and a full declaration for the class wide type type as well.
+
+   procedure Process_Full_View (N : Node_Id; Full_T, Priv_T : Entity_Id);
+   --  Process some semantic actions when the full view of a private type is
+   --  encountered and analyzed. The first action is to create the full views
+   --  of the dependant private subtypes. The second action is to recopy the
+   --  primitive operations of the private view (in the tagged case).
+   --  N is the N_Full_Type_Declaration node.
+
+   --    Full_T is the full view of the type whose full declaration is in N.
+   --
+   --    Priv_T is the private view of the type whose full declaration is in N.
+
+   procedure Process_Range_Expr_In_Decl
+     (R           : Node_Id;
+      T           : Entity_Id;
+      Related_Nod : Node_Id;
+      Check_List  : List_Id := Empty_List;
+      R_Check_Off : Boolean := False);
+   --  Process a range expression that appears in a declaration context. The
+   --  range is analyzed and resolved with the base type of the given type,
+   --  and an appropriate check for expressions in non-static contexts made
+   --  on the bounds. R is analyzed and resolved using T, so the caller should
+   --  if necessary link R into the tree before the call, and in particular in
+   --  the case of a subtype declaration, it is appropriate to set the parent
+   --  pointer of R so that the types get properly frozen. The Check_List
+   --  parameter is used when the subprogram is called from
+   --  Build_Record_Init_Proc and is used to return a set of constraint
+   --  checking statements generated by the Checks package. R_Check_Off is
+   --  set to True when the call to Range_Check is to be skipped.
+
+   function Process_Subtype
+     (S           : Node_Id;
+      Related_Nod : Node_Id;
+      Related_Id  : Entity_Id := Empty;
+      Suffix      : Character := ' ')
+      return        Entity_Id;
+   --  Process a subtype indication S and return corresponding entity.
+   --  Related_Nod is the node where the potential generated implicit types
+   --  will be inserted. The Related_Id and Suffix parameters are used to
+   --  build the associated Implicit type name.
+
+   procedure Process_Discriminants (N : Node_Id);
+   --  Process the discriminants contained in an N_Full_Type_Declaration or
+   --  N_Incomplete_Type_Decl node N.
+
+   procedure Set_Girder_Constraint_From_Discriminant_Constraint
+     (E : Entity_Id);
+   --  E is some record type. This routine computes E's Girder_Constraint
+   --  from its Discriminant_Constraint.
+
+end Sem_Ch3;
diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb
new file mode 100644
index 00000000000..31f244d2795
--- /dev/null
+++ b/gcc/ada/sem_ch4.adb
@@ -0,0 +1,4272 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              S E M _ C H 4                               --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.511 $
+--                                                                          --
+--          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 Debug;    use Debug;
+with Einfo;    use Einfo;
+with Errout;   use Errout;
+with Exp_Util; use Exp_Util;
+with Hostparm; use Hostparm;
+with Itypes;   use Itypes;
+with Lib.Xref; use Lib.Xref;
+with Namet;    use Namet;
+with Nlists;   use Nlists;
+with Nmake;    use Nmake;
+with Opt;      use Opt;
+with Output;   use Output;
+with Restrict; use Restrict;
+with Sem;      use Sem;
+with Sem_Cat;  use Sem_Cat;
+with Sem_Ch3;  use Sem_Ch3;
+with Sem_Ch8;  use Sem_Ch8;
+with Sem_Dist; use Sem_Dist;
+with Sem_Eval; use Sem_Eval;
+with Sem_Res;  use Sem_Res;
+with Sem_Util; use Sem_Util;
+with Sem_Type; use Sem_Type;
+with Stand;    use Stand;
+with Sinfo;    use Sinfo;
+with Snames;   use Snames;
+with Tbuild;   use Tbuild;
+
+with GNAT.Spelling_Checker; use GNAT.Spelling_Checker;
+
+package body Sem_Ch4 is
+
+   -----------------------
+   -- Local Subprograms --
+   -----------------------
+
+   procedure Analyze_Expression (N : Node_Id);
+   --  For expressions that are not names, this is just a call to analyze.
+   --  If the expression is a name, it may be a call to a parameterless
+   --  function, and if so must be converted into an explicit call node
+   --  and analyzed as such. This deproceduring must be done during the first
+   --  pass of overload resolution, because otherwise a procedure call with
+   --  overloaded actuals may fail to resolve. See 4327-001 for an example.
+
+   procedure Analyze_Operator_Call (N : Node_Id; Op_Id : Entity_Id);
+   --  Analyze a call of the form "+"(x, y), etc. The prefix of the call
+   --  is an operator name or an expanded name whose selector is an operator
+   --  name, and one possible interpretation is as a predefined operator.
+
+   procedure Analyze_Overloaded_Selected_Component (N : Node_Id);
+   --  If the prefix of a selected_component is overloaded, the proper
+   --  interpretation that yields a record type with the proper selector
+   --  name must be selected.
+
+   procedure Analyze_User_Defined_Binary_Op (N : Node_Id; Op_Id : Entity_Id);
+   --  Procedure to analyze a user defined binary operator, which is resolved
+   --  like a function, but instead of a list of actuals it is presented
+   --  with the left and right operands of an operator node.
+
+   procedure Analyze_User_Defined_Unary_Op (N : Node_Id; Op_Id : Entity_Id);
+   --  Procedure to analyze a user defined unary operator, which is resolved
+   --  like a function, but instead of a list of actuals, it is presented with
+   --  the operand of the operator node.
+
+   procedure Ambiguous_Operands (N : Node_Id);
+   --  for equality, membership, and comparison operators with overloaded
+   --  arguments, list possible interpretations.
+
+   procedure Insert_Explicit_Dereference (N : Node_Id);
+   --  In a context that requires a composite or subprogram type and
+   --  where a prefix is an access type, insert an explicit dereference.
+
+   procedure Analyze_One_Call
+      (N       : Node_Id;
+       Nam     : Entity_Id;
+       Report  : Boolean;
+       Success : out Boolean);
+   --  Check one interpretation of an overloaded subprogram name for
+   --  compatibility with the types of the actuals in a call. If there is a
+   --  single interpretation which does not match, post error if Report is
+   --  set to True.
+   --
+   --  Nam is the entity that provides the formals against which the actuals
+   --  are checked. Nam is either the name of a subprogram, or the internal
+   --  subprogram type constructed for an access_to_subprogram. If the actuals
+   --  are compatible with Nam, then Nam is added to the list of candidate
+   --  interpretations for N, and Success is set to True.
+
+   procedure Check_Misspelled_Selector
+     (Prefix : Entity_Id;
+      Sel    : Node_Id);
+   --  Give possible misspelling diagnostic if Sel is likely to be
+   --  a misspelling of one of the selectors of the Prefix.
+   --  This is called by Analyze_Selected_Component after producing
+   --  an invalid selector error message.
+
+   function Defined_In_Scope (T : Entity_Id; S : Entity_Id) return Boolean;
+   --  Verify that type T is declared in scope S. Used to find intepretations
+   --  for operators given by expanded names. This is abstracted as a separate
+   --  function to handle extensions to System, where S is System, but T is
+   --  declared in the extension.
+
+   procedure Find_Arithmetic_Types
+     (L, R  : Node_Id;
+      Op_Id : Entity_Id;
+      N     : Node_Id);
+   --  L and R are the operands of an arithmetic operator. Find
+   --  consistent pairs of interpretations for L and R that have a
+   --  numeric type consistent with the semantics of the operator.
+
+   procedure Find_Comparison_Types
+     (L, R  : Node_Id;
+      Op_Id : Entity_Id;
+      N     : Node_Id);
+   --  L and R are operands of a comparison operator. Find consistent
+   --  pairs of interpretations for L and R.
+
+   procedure Find_Concatenation_Types
+     (L, R  : Node_Id;
+      Op_Id : Entity_Id;
+      N     : Node_Id);
+   --  For the four varieties of concatenation.
+
+   procedure Find_Equality_Types
+     (L, R  : Node_Id;
+      Op_Id : Entity_Id;
+      N     : Node_Id);
+   --  Ditto for equality operators.
+
+   procedure Find_Boolean_Types
+     (L, R  : Node_Id;
+      Op_Id : Entity_Id;
+      N     : Node_Id);
+   --  Ditto for binary logical operations.
+
+   procedure Find_Negation_Types
+     (R     : Node_Id;
+      Op_Id : Entity_Id;
+      N     : Node_Id);
+   --  Find consistent interpretation for operand of negation operator.
+
+   procedure Find_Non_Universal_Interpretations
+     (N     : Node_Id;
+      R     : Node_Id;
+      Op_Id : Entity_Id;
+      T1    : Entity_Id);
+   --  For equality and comparison operators, the result is always boolean,
+   --  and the legality of the operation is determined from the visibility
+   --  of the operand types. If one of the operands has a universal interpre-
+   --  tation,  the legality check uses some compatible non-universal
+   --  interpretation of the other operand. N can be an operator node, or
+   --  a function call whose name is an operator designator.
+
+   procedure Find_Unary_Types
+     (R     : Node_Id;
+      Op_Id : Entity_Id;
+      N     : Node_Id);
+   --  Unary arithmetic types: plus, minus, abs.
+
+   procedure Check_Arithmetic_Pair
+     (T1, T2 : Entity_Id;
+      Op_Id  : Entity_Id;
+      N      : Node_Id);
+   --  Subsidiary procedure to Find_Arithmetic_Types. T1 and T2 are valid
+   --  types for left and right operand. Determine whether they constitute
+   --  a valid pair for the given operator, and record the corresponding
+   --  interpretation of the operator node. The node N may be an operator
+   --  node (the usual case) or a function call whose prefix is an operator
+   --  designator. In  both cases Op_Id is the operator name itself.
+
+   procedure Diagnose_Call (N : Node_Id; Nam : Node_Id);
+   --  Give detailed information on overloaded call where none of the
+   --  interpretations match. N is the call node, Nam the designator for
+   --  the overloaded entity being called.
+
+   function Junk_Operand (N : Node_Id) return Boolean;
+   --  Test for an operand that is an inappropriate entity (e.g. a package
+   --  name or a label). If so, issue an error message and return True. If
+   --  the operand is not an inappropriate entity kind, return False.
+
+   procedure Operator_Check (N : Node_Id);
+   --  Verify that an operator has received some valid interpretation.
+   --  If none was found, determine whether a use clause would make the
+   --  operation legal. The variable Candidate_Type (defined in Sem_Type) is
+   --  set for every type compatible with the operator, even if the operator
+   --  for the type is not directly visible. The routine uses this type to emit
+   --  a more informative message.
+
+   function Try_Indexed_Call
+     (N      : Node_Id;
+      Nam    : Entity_Id;
+      Typ    : Entity_Id)
+      return   Boolean;
+   --  If a function has defaults for all its actuals, a call to it may
+   --  in fact be an indexing on the result of the call. Try_Indexed_Call
+   --  attempts the interpretation as an indexing, prior to analysis as
+   --  a call. If both are possible,  the node is overloaded with both
+   --  interpretations (same symbol but two different types).
+
+   function Try_Indirect_Call
+     (N      : Node_Id;
+      Nam    : Entity_Id;
+      Typ    : Entity_Id)
+      return   Boolean;
+   --  Similarly, a function F that needs no actuals can return an access
+   --  to a subprogram, and the call F (X)  interpreted as F.all (X). In
+   --  this case the call may be overloaded with both interpretations.
+
+   ------------------------
+   -- Ambiguous_Operands --
+   ------------------------
+
+   procedure Ambiguous_Operands (N : Node_Id) is
+      procedure List_Interps (Opnd : Node_Id);
+
+      procedure List_Interps (Opnd : Node_Id) is
+         Index : Interp_Index;
+         It    : Interp;
+         Nam   : Node_Id;
+         Err   : Node_Id := N;
+
+      begin
+         if Is_Overloaded (Opnd) then
+            if Nkind (Opnd) in N_Op then
+               Nam := Opnd;
+
+            elsif Nkind (Opnd) = N_Function_Call then
+               Nam := Name (Opnd);
+
+            else
+               return;
+            end if;
+
+         else
+            return;
+         end if;
+
+         if Opnd = Left_Opnd (N) then
+            Error_Msg_N
+              ("\left operand has the following interpretations", N);
+         else
+            Error_Msg_N
+              ("\right operand has the following interpretations", N);
+            Err := Opnd;
+         end if;
+
+         Get_First_Interp (Nam, Index, It);
+
+         while Present (It.Nam) loop
+
+            if Scope (It.Nam) = Standard_Standard
+              and then Scope (It.Typ) /= Standard_Standard
+            then
+               Error_Msg_Sloc := Sloc (Parent (It.Typ));
+               Error_Msg_NE ("   & (inherited) declared#!", Err, It.Nam);
+
+            else
+               Error_Msg_Sloc := Sloc (It.Nam);
+               Error_Msg_NE ("   & declared#!", Err, It.Nam);
+            end if;
+
+            Get_Next_Interp (Index, It);
+         end loop;
+      end List_Interps;
+
+   begin
+      if Nkind (N) = N_In
+        or else Nkind (N) = N_Not_In
+      then
+         Error_Msg_N ("ambiguous operands for membership",  N);
+
+      elsif Nkind (N) = N_Op_Eq
+        or else Nkind (N) = N_Op_Ne
+      then
+         Error_Msg_N ("ambiguous operands for equality",  N);
+
+      else
+         Error_Msg_N ("ambiguous operands for comparison",  N);
+      end if;
+
+      if All_Errors_Mode then
+         List_Interps (Left_Opnd  (N));
+         List_Interps (Right_Opnd (N));
+      else
+
+         if OpenVMS then
+            Error_Msg_N (
+               "\use '/'R'E'P'O'R'T'_'E'R'R'O'R'S'='F'U'L'L for details",
+                N);
+         else
+            Error_Msg_N ("\use -gnatf for details", N);
+         end if;
+      end if;
+   end Ambiguous_Operands;
+
+   -----------------------
+   -- Analyze_Aggregate --
+   -----------------------
+
+   --  Most of the analysis of Aggregates requires that the type be known,
+   --  and is therefore put off until resolution.
+
+   procedure Analyze_Aggregate (N : Node_Id) is
+   begin
+      if No (Etype (N)) then
+         Set_Etype (N, Any_Composite);
+      end if;
+   end Analyze_Aggregate;
+
+   -----------------------
+   -- Analyze_Allocator --
+   -----------------------
+
+   procedure Analyze_Allocator (N : Node_Id) is
+      Loc      : constant Source_Ptr := Sloc (N);
+      Sav_Errs : constant Nat        := Errors_Detected;
+      E        : Node_Id             := Expression (N);
+      Acc_Type : Entity_Id;
+      Type_Id  : Entity_Id;
+
+   begin
+      Check_Restriction (No_Allocators, N);
+
+      if Nkind (E) = N_Qualified_Expression then
+         Acc_Type := Create_Itype (E_Allocator_Type, N);
+         Set_Etype (Acc_Type, Acc_Type);
+         Init_Size_Align (Acc_Type);
+         Find_Type (Subtype_Mark (E));
+         Type_Id := Entity (Subtype_Mark (E));
+         Check_Fully_Declared (Type_Id, N);
+         Set_Directly_Designated_Type (Acc_Type, Type_Id);
+
+         if Is_Protected_Type (Type_Id) then
+            Check_Restriction (No_Protected_Type_Allocators, N);
+         end if;
+
+         if Is_Limited_Type (Type_Id)
+           and then Comes_From_Source (N)
+           and then not In_Instance_Body
+         then
+            Error_Msg_N ("initialization not allowed for limited types", N);
+         end if;
+
+         Analyze_And_Resolve (Expression (E), Type_Id);
+
+         --  A qualified expression requires an exact match of the type,
+         --  class-wide matching is not allowed.
+
+         if Is_Class_Wide_Type (Type_Id)
+           and then Base_Type (Etype (Expression (E))) /= Base_Type (Type_Id)
+         then
+            Wrong_Type (Expression (E), Type_Id);
+         end if;
+
+         Check_Non_Static_Context (Expression (E));
+
+         --  We don't analyze the qualified expression itself because it's
+         --  part of the allocator
+
+         Set_Etype  (E, Type_Id);
+
+      else
+         declare
+            Def_Id : Entity_Id;
+
+         begin
+            --  If the allocator includes a N_Subtype_Indication then a
+            --  constraint is present, otherwise the node is a subtype mark.
+            --  Introduce an explicit subtype declaration into the tree
+            --  defining some anonymous subtype and rewrite the allocator to
+            --  use this subtype rather than the subtype indication.
+
+            --  It is important to introduce the explicit subtype declaration
+            --  so that the bounds of the subtype indication are attached to
+            --  the tree in case the allocator is inside a generic unit.
+
+            if Nkind (E) = N_Subtype_Indication then
+
+               --  A constraint is only allowed for a composite type in Ada
+               --  95. In Ada 83, a constraint is also allowed for an
+               --  access-to-composite type, but the constraint is ignored.
+
+               Find_Type (Subtype_Mark (E));
+
+               if Is_Elementary_Type (Entity (Subtype_Mark (E))) then
+                  if not (Ada_83
+                           and then Is_Access_Type (Entity (Subtype_Mark (E))))
+                  then
+                     Error_Msg_N ("constraint not allowed here", E);
+
+                     if Nkind (Constraint (E))
+                       = N_Index_Or_Discriminant_Constraint
+                     then
+                        Error_Msg_N
+                          ("\if qualified expression was meant, " &
+                              "use apostrophe", Constraint (E));
+                     end if;
+                  end if;
+
+                  --  Get rid of the bogus constraint:
+
+                  Rewrite (E, New_Copy_Tree (Subtype_Mark (E)));
+                  Analyze_Allocator (N);
+                  return;
+               end if;
+
+               if Expander_Active then
+                  Def_Id :=
+                    Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
+
+                  Insert_Action (E,
+                    Make_Subtype_Declaration (Loc,
+                      Defining_Identifier => Def_Id,
+                      Subtype_Indication  => Relocate_Node (E)));
+
+                  if Sav_Errs /= Errors_Detected
+                    and then Nkind (Constraint (E))
+                      = N_Index_Or_Discriminant_Constraint
+                  then
+                     Error_Msg_N
+                       ("if qualified expression was meant, " &
+                           "use apostrophe!", Constraint (E));
+                  end if;
+
+                  E := New_Occurrence_Of (Def_Id, Loc);
+                  Rewrite (Expression (N), E);
+               end if;
+            end if;
+
+            Type_Id := Process_Subtype (E, N);
+            Acc_Type := Create_Itype (E_Allocator_Type, N);
+            Set_Etype                    (Acc_Type, Acc_Type);
+            Init_Size_Align              (Acc_Type);
+            Set_Directly_Designated_Type (Acc_Type, Type_Id);
+            Check_Fully_Declared (Type_Id, N);
+
+            --  Check for missing initialization. Skip this check if we already
+            --  had errors on analyzing the allocator, since in that case these
+            --  are probably cascaded errors
+
+            if Is_Indefinite_Subtype (Type_Id)
+              and then Errors_Detected = Sav_Errs
+            then
+               if Is_Class_Wide_Type (Type_Id) then
+                  Error_Msg_N
+                    ("initialization required in class-wide allocation", N);
+               else
+                  Error_Msg_N
+                    ("initialization required in unconstrained allocation", N);
+               end if;
+            end if;
+         end;
+      end if;
+
+      if Is_Abstract (Type_Id) then
+         Error_Msg_N ("cannot allocate abstract object", E);
+      end if;
+
+      if Has_Task (Designated_Type (Acc_Type)) then
+         Check_Restriction (No_Task_Allocators, N);
+      end if;
+
+      Set_Etype (N, Acc_Type);
+
+      if not Is_Library_Level_Entity (Acc_Type) then
+         Check_Restriction (No_Local_Allocators, N);
+      end if;
+
+      if Errors_Detected > Sav_Errs then
+         Set_Error_Posted (N);
+         Set_Etype (N, Any_Type);
+      end if;
+
+   end Analyze_Allocator;
+
+   ---------------------------
+   -- Analyze_Arithmetic_Op --
+   ---------------------------
+
+   procedure Analyze_Arithmetic_Op (N : Node_Id) is
+      L     : constant Node_Id := Left_Opnd (N);
+      R     : constant Node_Id := Right_Opnd (N);
+      Op_Id : Entity_Id;
+
+   begin
+      Candidate_Type := Empty;
+      Analyze_Expression (L);
+      Analyze_Expression (R);
+
+      --  If the entity is already set, the node is the instantiation of
+      --  a generic node with a non-local reference, or was manufactured
+      --  by a call to Make_Op_xxx. In either case the entity is known to
+      --  be valid, and we do not need to collect interpretations, instead
+      --  we just get the single possible interpretation.
+
+      Op_Id := Entity (N);
+
+      if Present (Op_Id) then
+         if Ekind (Op_Id) = E_Operator then
+
+            if (Nkind (N) = N_Op_Divide   or else
+                Nkind (N) = N_Op_Mod      or else
+                Nkind (N) = N_Op_Multiply or else
+                Nkind (N) = N_Op_Rem)
+              and then Treat_Fixed_As_Integer (N)
+            then
+               null;
+            else
+               Set_Etype (N, Any_Type);
+               Find_Arithmetic_Types (L, R, Op_Id, N);
+            end if;
+
+         else
+            Set_Etype (N, Any_Type);
+            Add_One_Interp (N, Op_Id, Etype (Op_Id));
+         end if;
+
+      --  Entity is not already set, so we do need to collect interpretations
+
+      else
+         Op_Id := Get_Name_Entity_Id (Chars (N));
+         Set_Etype (N, Any_Type);
+
+         while Present (Op_Id) loop
+            if Ekind (Op_Id) = E_Operator
+              and then Present (Next_Entity (First_Entity (Op_Id)))
+            then
+               Find_Arithmetic_Types (L, R, Op_Id, N);
+
+            --  The following may seem superfluous, because an operator cannot
+            --  be generic, but this ignores the cleverness of the author of
+            --  ACVC bc1013a.
+
+            elsif Is_Overloadable (Op_Id) then
+               Analyze_User_Defined_Binary_Op (N, Op_Id);
+            end if;
+
+            Op_Id := Homonym (Op_Id);
+         end loop;
+      end if;
+
+      Operator_Check (N);
+   end Analyze_Arithmetic_Op;
+
+   ------------------
+   -- Analyze_Call --
+   ------------------
+
+   --  Function, procedure, and entry calls are checked here. The Name
+   --  in the call may be overloaded. The actuals have been analyzed
+   --  and may themselves be overloaded. On exit from this procedure, the node
+   --  N may have zero, one or more interpretations. In the first case an error
+   --  message is produced. In the last case, the node is flagged as overloaded
+   --  and the interpretations are collected in All_Interp.
+
+   --  If the name is an Access_To_Subprogram, it cannot be overloaded, but
+   --  the type-checking is similar to that of other calls.
+
+   procedure Analyze_Call (N : Node_Id) is
+      Actuals : constant List_Id := Parameter_Associations (N);
+      Nam     : Node_Id          := Name (N);
+      X       : Interp_Index;
+      It      : Interp;
+      Nam_Ent : Entity_Id;
+      Success : Boolean := False;
+
+      function Name_Denotes_Function return Boolean;
+      --  If the type of the name is an access to subprogram, this may be
+      --  the type of a name, or the return type of the function being called.
+      --  If the name is not an entity then it can denote a protected function.
+      --  Until we distinguish Etype from Return_Type, we must use this
+      --  routine to resolve the meaning of the name in the call.
+
+      ---------------------------
+      -- Name_Denotes_Function --
+      ---------------------------
+
+      function Name_Denotes_Function return Boolean is
+      begin
+         if Is_Entity_Name (Nam) then
+            return Ekind (Entity (Nam)) = E_Function;
+
+         elsif Nkind (Nam) = N_Selected_Component then
+            return Ekind (Entity (Selector_Name (Nam))) = E_Function;
+
+         else
+            return False;
+         end if;
+      end Name_Denotes_Function;
+
+   --  Start of processing for Analyze_Call
+
+   begin
+      --  Initialize the type of the result of the call to the error type,
+      --  which will be reset if the type is successfully resolved.
+
+      Set_Etype (N, Any_Type);
+
+      if not Is_Overloaded (Nam) then
+
+         --  Only one interpretation to check
+
+         if Ekind (Etype (Nam)) = E_Subprogram_Type then
+            Nam_Ent := Etype (Nam);
+
+         elsif Is_Access_Type (Etype (Nam))
+           and then Ekind (Designated_Type (Etype (Nam))) = E_Subprogram_Type
+           and then not Name_Denotes_Function
+         then
+            Nam_Ent := Designated_Type (Etype (Nam));
+            Insert_Explicit_Dereference (Nam);
+
+         --  Selected component case. Simple entry or protected operation,
+         --  where the entry name is given by the selector name.
+
+         elsif Nkind (Nam) = N_Selected_Component then
+            Nam_Ent := Entity (Selector_Name (Nam));
+
+            if Ekind (Nam_Ent) /= E_Entry
+              and then Ekind (Nam_Ent) /= E_Entry_Family
+              and then Ekind (Nam_Ent) /= E_Function
+              and then Ekind (Nam_Ent) /= E_Procedure
+            then
+               Error_Msg_N ("name in call is not a callable entity", Nam);
+               Set_Etype (N, Any_Type);
+               return;
+            end if;
+
+         --  If the name is an Indexed component, it can be a call to a member
+         --  of an entry family. The prefix must be a selected component whose
+         --  selector is the entry. Analyze_Procedure_Call normalizes several
+         --  kinds of call into this form.
+
+         elsif Nkind (Nam) = N_Indexed_Component then
+
+            if Nkind (Prefix (Nam)) = N_Selected_Component then
+               Nam_Ent := Entity (Selector_Name (Prefix (Nam)));
+
+            else
+               Error_Msg_N ("name in call is not a callable entity", Nam);
+               Set_Etype (N, Any_Type);
+               return;
+
+            end if;
+
+         elsif not Is_Entity_Name (Nam) then
+            Error_Msg_N ("name in call is not a callable entity", Nam);
+            Set_Etype (N, Any_Type);
+            return;
+
+         else
+            Nam_Ent := Entity (Nam);
+
+            --  If no interpretations, give error message
+
+            if not Is_Overloadable (Nam_Ent) then
+               declare
+                  L : constant Boolean   := Is_List_Member (N);
+                  K : constant Node_Kind := Nkind (Parent (N));
+
+               begin
+                  --  If the node is in a list whose parent is not an
+                  --  expression then it must be an attempted procedure call.
+
+                  if L and then K not in N_Subexpr then
+                     if Ekind (Entity (Nam)) = E_Generic_Procedure then
+                        Error_Msg_NE
+                          ("must instantiate generic procedure& before call",
+                           Nam, Entity (Nam));
+                     else
+                        Error_Msg_N
+                          ("procedure or entry name expected", Nam);
+                     end if;
+
+                  --  Check for tasking cases where only an entry call will do
+
+                  elsif not L
+                    and then (K = N_Entry_Call_Alternative
+                               or else K = N_Triggering_Alternative)
+                  then
+                     Error_Msg_N ("entry name expected", Nam);
+
+                  --  Otherwise give general error message
+
+                  else
+                     Error_Msg_N ("invalid prefix in call", Nam);
+                  end if;
+
+                  return;
+               end;
+            end if;
+         end if;
+
+         Analyze_One_Call (N, Nam_Ent, True, Success);
+
+      else
+         --  An overloaded selected component must denote overloaded
+         --  operations of a concurrent type. The interpretations are
+         --  attached to the simple name of those operations.
+
+         if Nkind (Nam) = N_Selected_Component then
+            Nam := Selector_Name (Nam);
+         end if;
+
+         Get_First_Interp (Nam, X, It);
+
+         while Present (It.Nam) loop
+            Nam_Ent := It.Nam;
+
+            --  Name may be call that returns an access to subprogram, or more
+            --  generally an overloaded expression one of whose interpretations
+            --  yields an access to subprogram. If the name is an entity, we
+            --  do not dereference, because the node is a call that returns
+            --  the access type: note difference between f(x), where the call
+            --  may return an access subprogram type, and f(x)(y), where the
+            --  type returned by the call to f is implicitly dereferenced to
+            --  analyze the outer call.
+
+            if Is_Access_Type (Nam_Ent) then
+               Nam_Ent := Designated_Type (Nam_Ent);
+
+            elsif Is_Access_Type (Etype (Nam_Ent))
+              and then not Is_Entity_Name (Nam)
+              and then Ekind (Designated_Type (Etype (Nam_Ent)))
+                                                          = E_Subprogram_Type
+            then
+               Nam_Ent := Designated_Type (Etype (Nam_Ent));
+            end if;
+
+            Analyze_One_Call (N, Nam_Ent, False, Success);
+
+            --  If the interpretation succeeds, mark the proper type of the
+            --  prefix (any valid candidate will do). If not, remove the
+            --  candidate interpretation. This only needs to be done for
+            --  overloaded protected operations, for other entities disambi-
+            --  guation is done directly in Resolve.
+
+            if Success then
+               Set_Etype (Nam, It.Typ);
+
+            elsif Nkind (Name (N)) = N_Selected_Component then
+               Remove_Interp (X);
+            end if;
+
+            Get_Next_Interp (X, It);
+         end loop;
+
+         --  If the name is the result of a function call, it can only
+         --  be a call to a function returning an access to subprogram.
+         --  Insert explicit dereference.
+
+         if Nkind (Nam) = N_Function_Call then
+            Insert_Explicit_Dereference (Nam);
+         end if;
+
+         if Etype (N) = Any_Type then
+
+            --  None of the interpretations is compatible with the actuals
+
+            Diagnose_Call (N, Nam);
+
+            --  Special checks for uninstantiated put routines
+
+            if Nkind (N) = N_Procedure_Call_Statement
+              and then Is_Entity_Name (Nam)
+              and then Chars (Nam) = Name_Put
+              and then List_Length (Actuals) = 1
+            then
+               declare
+                  Arg : constant Node_Id := First (Actuals);
+                  Typ : Entity_Id;
+
+               begin
+                  if Nkind (Arg) = N_Parameter_Association then
+                     Typ := Etype (Explicit_Actual_Parameter (Arg));
+                  else
+                     Typ := Etype (Arg);
+                  end if;
+
+                  if Is_Signed_Integer_Type (Typ) then
+                     Error_Msg_N
+                       ("possible missing instantiation of " &
+                          "'Text_'I'O.'Integer_'I'O!", Nam);
+
+                  elsif Is_Modular_Integer_Type (Typ) then
+                     Error_Msg_N
+                       ("possible missing instantiation of " &
+                          "'Text_'I'O.'Modular_'I'O!", Nam);
+
+                  elsif Is_Floating_Point_Type (Typ) then
+                     Error_Msg_N
+                       ("possible missing instantiation of " &
+                          "'Text_'I'O.'Float_'I'O!", Nam);
+
+                  elsif Is_Ordinary_Fixed_Point_Type (Typ) then
+                     Error_Msg_N
+                       ("possible missing instantiation of " &
+                          "'Text_'I'O.'Fixed_'I'O!", Nam);
+
+                  elsif Is_Decimal_Fixed_Point_Type (Typ) then
+                     Error_Msg_N
+                       ("possible missing instantiation of " &
+                          "'Text_'I'O.'Decimal_'I'O!", Nam);
+
+                  elsif Is_Enumeration_Type (Typ) then
+                     Error_Msg_N
+                       ("possible missing instantiation of " &
+                          "'Text_'I'O.'Enumeration_'I'O!", Nam);
+                  end if;
+               end;
+            end if;
+
+         elsif not Is_Overloaded (N)
+           and then Is_Entity_Name (Nam)
+         then
+            --  Resolution yields a single interpretation. Verify that
+            --  is has the proper capitalization.
+
+            Set_Entity_With_Style_Check (Nam, Entity (Nam));
+            Generate_Reference (Entity (Nam), Nam);
+
+            Set_Etype (Nam, Etype (Entity (Nam)));
+         end if;
+
+         End_Interp_List;
+      end if;
+   end Analyze_Call;
+
+   ---------------------------
+   -- Analyze_Comparison_Op --
+   ---------------------------
+
+   procedure Analyze_Comparison_Op (N : Node_Id) is
+      L     : constant Node_Id := Left_Opnd (N);
+      R     : constant Node_Id := Right_Opnd (N);
+      Op_Id : Entity_Id        := Entity (N);
+
+   begin
+      Set_Etype (N, Any_Type);
+      Candidate_Type := Empty;
+
+      Analyze_Expression (L);
+      Analyze_Expression (R);
+
+      if Present (Op_Id) then
+
+         if Ekind (Op_Id) = E_Operator then
+            Find_Comparison_Types (L, R, Op_Id, N);
+         else
+            Add_One_Interp (N, Op_Id, Etype (Op_Id));
+         end if;
+
+         if Is_Overloaded (L) then
+            Set_Etype (L, Intersect_Types (L, R));
+         end if;
+
+      else
+         Op_Id := Get_Name_Entity_Id (Chars (N));
+
+         while Present (Op_Id) loop
+
+            if Ekind (Op_Id) = E_Operator then
+               Find_Comparison_Types (L, R, Op_Id, N);
+            else
+               Analyze_User_Defined_Binary_Op (N, Op_Id);
+            end if;
+
+            Op_Id := Homonym (Op_Id);
+         end loop;
+      end if;
+
+      Operator_Check (N);
+   end Analyze_Comparison_Op;
+
+   ---------------------------
+   -- Analyze_Concatenation --
+   ---------------------------
+
+   --  If the only one-dimensional array type in scope is String,
+   --  this is the resulting type of the operation. Otherwise there
+   --  will be a concatenation operation defined for each user-defined
+   --  one-dimensional array.
+
+   procedure Analyze_Concatenation (N : Node_Id) is
+      L     : constant Node_Id := Left_Opnd (N);
+      R     : constant Node_Id := Right_Opnd (N);
+      Op_Id : Entity_Id        := Entity (N);
+      LT    : Entity_Id;
+      RT    : Entity_Id;
+
+   begin
+      Set_Etype (N, Any_Type);
+      Candidate_Type := Empty;
+
+      Analyze_Expression (L);
+      Analyze_Expression (R);
+
+      --  If the entity is present, the  node appears in an instance,
+      --  and denotes a predefined concatenation operation. The resulting
+      --  type is obtained from the arguments when possible.
+
+      if Present (Op_Id) then
+         if Ekind (Op_Id) = E_Operator then
+
+            LT := Base_Type (Etype (L));
+            RT := Base_Type (Etype (R));
+
+            if Is_Array_Type (LT)
+              and then (RT = LT or else RT = Base_Type (Component_Type (LT)))
+            then
+               Add_One_Interp (N, Op_Id, LT);
+
+            elsif Is_Array_Type (RT)
+              and then LT = Base_Type (Component_Type (RT))
+            then
+               Add_One_Interp (N, Op_Id, RT);
+
+            else
+               Add_One_Interp (N, Op_Id, Etype (Op_Id));
+            end if;
+
+         else
+            Add_One_Interp (N, Op_Id, Etype (Op_Id));
+         end if;
+
+      else
+         Op_Id  := Get_Name_Entity_Id (Name_Op_Concat);
+
+         while Present (Op_Id) loop
+            if Ekind (Op_Id) = E_Operator then
+               Find_Concatenation_Types (L, R, Op_Id, N);
+            else
+               Analyze_User_Defined_Binary_Op (N, Op_Id);
+            end if;
+
+            Op_Id := Homonym (Op_Id);
+         end loop;
+      end if;
+
+      Operator_Check (N);
+   end Analyze_Concatenation;
+
+   ------------------------------------
+   -- Analyze_Conditional_Expression --
+   ------------------------------------
+
+   procedure Analyze_Conditional_Expression (N : Node_Id) is
+      Condition : constant Node_Id := First (Expressions (N));
+      Then_Expr : constant Node_Id := Next (Condition);
+      Else_Expr : constant Node_Id := Next (Then_Expr);
+
+   begin
+      Analyze_Expression (Condition);
+      Analyze_Expression (Then_Expr);
+      Analyze_Expression (Else_Expr);
+      Set_Etype (N, Etype (Then_Expr));
+   end Analyze_Conditional_Expression;
+
+   -------------------------
+   -- Analyze_Equality_Op --
+   -------------------------
+
+   procedure Analyze_Equality_Op (N : Node_Id) is
+      Loc    : constant Source_Ptr := Sloc (N);
+      L      : constant Node_Id := Left_Opnd (N);
+      R      : constant Node_Id := Right_Opnd (N);
+      Op_Id  : Entity_Id;
+
+   begin
+      Set_Etype (N, Any_Type);
+      Candidate_Type := Empty;
+
+      Analyze_Expression (L);
+      Analyze_Expression (R);
+
+      --  If the entity is set, the node is a generic instance with a non-local
+      --  reference to the predefined operator or to a user-defined function.
+      --  It can also be an inequality that is expanded into the negation of a
+      --  call to a user-defined equality operator.
+
+      --  For the predefined case, the result is Boolean, regardless of the
+      --  type of the  operands. The operands may even be limited, if they are
+      --  generic actuals. If they are overloaded, label the left argument with
+      --  the common type that must be present, or with the type of the formal
+      --  of the user-defined function.
+
+      if Present (Entity (N)) then
+
+         Op_Id := Entity (N);
+
+         if Ekind (Op_Id) = E_Operator then
+            Add_One_Interp (N, Op_Id, Standard_Boolean);
+         else
+            Add_One_Interp (N, Op_Id, Etype (Op_Id));
+         end if;
+
+         if Is_Overloaded (L) then
+
+            if Ekind (Op_Id) = E_Operator then
+               Set_Etype (L, Intersect_Types (L, R));
+            else
+               Set_Etype (L, Etype (First_Formal (Op_Id)));
+            end if;
+         end if;
+
+      else
+         Op_Id := Get_Name_Entity_Id (Chars (N));
+
+         while Present (Op_Id) loop
+
+            if Ekind (Op_Id) = E_Operator then
+               Find_Equality_Types (L, R, Op_Id, N);
+            else
+               Analyze_User_Defined_Binary_Op (N, Op_Id);
+            end if;
+
+            Op_Id := Homonym (Op_Id);
+         end loop;
+      end if;
+
+      --  If there was no match, and the operator is inequality, this may
+      --  be a case where inequality has not been made explicit, as for
+      --  tagged types. Analyze the node as the negation of an equality
+      --  operation. This cannot be done earlier, because before analysis
+      --  we cannot rule out the presence of an explicit inequality.
+
+      if Etype (N) = Any_Type
+        and then Nkind (N) = N_Op_Ne
+      then
+         Op_Id := Get_Name_Entity_Id (Name_Op_Eq);
+
+         while Present (Op_Id) loop
+
+            if Ekind (Op_Id) = E_Operator then
+               Find_Equality_Types (L, R, Op_Id, N);
+            else
+               Analyze_User_Defined_Binary_Op (N, Op_Id);
+            end if;
+
+            Op_Id := Homonym (Op_Id);
+         end loop;
+
+         if Etype (N) /= Any_Type then
+            Op_Id := Entity (N);
+
+            Rewrite (N,
+              Make_Op_Not (Loc,
+                Right_Opnd =>
+                  Make_Op_Eq (Loc,
+                    Left_Opnd =>  Relocate_Node (Left_Opnd (N)),
+                    Right_Opnd => Relocate_Node (Right_Opnd (N)))));
+
+            Set_Entity (Right_Opnd (N), Op_Id);
+            Analyze (N);
+         end if;
+      end if;
+
+      Operator_Check (N);
+   end Analyze_Equality_Op;
+
+   ----------------------------------
+   -- Analyze_Explicit_Dereference --
+   ----------------------------------
+
+   procedure Analyze_Explicit_Dereference (N : Node_Id) is
+      Loc   : constant Source_Ptr := Sloc (N);
+      P     : constant Node_Id := Prefix (N);
+      T     : Entity_Id;
+      I     : Interp_Index;
+      It    : Interp;
+      New_N : Node_Id;
+
+      function Is_Function_Type return Boolean;
+      --  Check whether node may be interpreted as an implicit function call.
+
+      function Is_Function_Type return Boolean is
+         I     : Interp_Index;
+         It    : Interp;
+
+      begin
+         if not Is_Overloaded (N) then
+            return Ekind (Base_Type (Etype (N))) = E_Subprogram_Type
+              and then Etype (Base_Type (Etype (N))) /= Standard_Void_Type;
+
+         else
+            Get_First_Interp (N, I, It);
+
+            while Present (It.Nam) loop
+               if Ekind (Base_Type (It.Typ)) /= E_Subprogram_Type
+                 or else Etype (Base_Type (It.Typ)) = Standard_Void_Type
+               then
+                  return False;
+               end if;
+
+               Get_Next_Interp (I, It);
+            end loop;
+
+            return True;
+         end if;
+      end Is_Function_Type;
+
+   begin
+      Analyze (P);
+      Set_Etype (N, Any_Type);
+
+      --  Test for remote access to subprogram type, and if so return
+      --  after rewriting the original tree.
+
+      if Remote_AST_E_Dereference (P) then
+         return;
+      end if;
+
+      --  Normal processing for other than remote access to subprogram type
+
+      if not Is_Overloaded (P) then
+         if Is_Access_Type (Etype (P)) then
+
+            --  Set the Etype. We need to go thru Is_For_Access_Subtypes
+            --  to avoid other problems caused by the Private_Subtype
+            --  and it is safe to go to the Base_Type because this is the
+            --  same as converting the access value to its Base_Type.
+
+            declare
+               DT : Entity_Id := Designated_Type (Etype (P));
+
+            begin
+               if Ekind (DT) = E_Private_Subtype
+                 and then Is_For_Access_Subtype (DT)
+               then
+                  DT := Base_Type (DT);
+               end if;
+
+               Set_Etype (N, DT);
+            end;
+
+         elsif Etype (P) /= Any_Type then
+            Error_Msg_N ("prefix of dereference must be an access type", N);
+            return;
+         end if;
+
+      else
+         Get_First_Interp (P, I, It);
+
+         while Present (It.Nam) loop
+            T := It.Typ;
+
+            if Is_Access_Type (T) then
+               Add_One_Interp (N, Designated_Type (T), Designated_Type (T));
+            end if;
+
+            Get_Next_Interp (I, It);
+         end loop;
+
+         End_Interp_List;
+
+         --  Error if no interpretation of the prefix has an access type.
+
+         if Etype (N) = Any_Type then
+            Error_Msg_N
+              ("access type required in prefix of explicit dereference", P);
+            Set_Etype (N, Any_Type);
+            return;
+         end if;
+      end if;
+
+      if Is_Function_Type
+        and then Nkind (Parent (N)) /= N_Indexed_Component
+
+        and then (Nkind (Parent (N)) /= N_Function_Call
+                   or else N /= Name (Parent (N)))
+
+        and then (Nkind (Parent (N)) /= N_Procedure_Call_Statement
+                   or else N /= Name (Parent (N)))
+
+        and then Nkind (Parent (N)) /= N_Subprogram_Renaming_Declaration
+        and then (Nkind (Parent (N)) /= N_Attribute_Reference
+                    or else
+                      (Attribute_Name (Parent (N)) /= Name_Address
+                        and then
+                       Attribute_Name (Parent (N)) /= Name_Access))
+      then
+         --  Name is a function call with no actuals, in a context that
+         --  requires deproceduring (including as an actual in an enclosing
+         --  function or procedure call). We can conceive of pathological cases
+         --  where the prefix might include functions that return access to
+         --  subprograms and others that return a regular type. Disambiguation
+         --  of those will have to take place in Resolve. See e.g. 7117-014.
+
+         New_N :=
+           Make_Function_Call (Loc,
+           Name => Make_Explicit_Dereference (Loc, P),
+           Parameter_Associations => New_List);
+
+         --  If the prefix is overloaded, remove operations that have formals,
+         --  we know that this is a parameterless call.
+
+         if Is_Overloaded (P) then
+            Get_First_Interp (P, I, It);
+
+            while Present (It.Nam) loop
+               T := It.Typ;
+
+               if No (First_Formal (Base_Type (Designated_Type (T)))) then
+                  Set_Etype (P, T);
+               else
+                  Remove_Interp (I);
+               end if;
+
+               Get_Next_Interp (I, It);
+            end loop;
+         end if;
+
+         Rewrite (N, New_N);
+         Analyze (N);
+      end if;
+
+      --  A value of remote access-to-class-wide must not be dereferenced
+      --  (RM E.2.2(16)).
+
+      Validate_Remote_Access_To_Class_Wide_Type (N);
+
+   end Analyze_Explicit_Dereference;
+
+   ------------------------
+   -- Analyze_Expression --
+   ------------------------
+
+   procedure Analyze_Expression (N : Node_Id) is
+   begin
+      Analyze (N);
+      Check_Parameterless_Call (N);
+   end Analyze_Expression;
+
+   ------------------------------------
+   -- Analyze_Indexed_Component_Form --
+   ------------------------------------
+
+   procedure Analyze_Indexed_Component_Form (N : Node_Id) is
+      P   : constant Node_Id := Prefix (N);
+      Exprs : List_Id := Expressions (N);
+      Exp : Node_Id;
+      P_T : Entity_Id;
+      E   : Node_Id;
+      U_N : Entity_Id;
+
+      procedure Process_Function_Call;
+      --  Prefix in indexed component form is an overloadable entity,
+      --  so the node is a function call. Reformat it as such.
+
+      procedure Process_Indexed_Component;
+      --  Prefix in indexed component form is actually an indexed component.
+      --  This routine processes it, knowing that the prefix is already
+      --  resolved.
+
+      procedure Process_Indexed_Component_Or_Slice;
+      --  An indexed component with a single index may designate a slice if
+      --  the index is a subtype mark. This routine disambiguates these two
+      --  cases by resolving the prefix to see if it is a subtype mark.
+
+      procedure Process_Overloaded_Indexed_Component;
+      --  If the prefix of an indexed component is overloaded, the proper
+      --  interpretation is selected by the index types and the context.
+
+      ---------------------------
+      -- Process_Function_Call --
+      ---------------------------
+
+      procedure Process_Function_Call is
+         Actual : Node_Id;
+
+      begin
+         Change_Node (N, N_Function_Call);
+         Set_Name (N, P);
+         Set_Parameter_Associations (N, Exprs);
+         Actual := First (Parameter_Associations (N));
+
+         while Present (Actual) loop
+            Analyze (Actual);
+            Check_Parameterless_Call (Actual);
+            Next_Actual (Actual);
+         end loop;
+
+         Analyze_Call (N);
+      end Process_Function_Call;
+
+      -------------------------------
+      -- Process_Indexed_Component --
+      -------------------------------
+
+      procedure Process_Indexed_Component is
+         Exp          : Node_Id;
+         Array_Type   : Entity_Id;
+         Index        : Node_Id;
+         Entry_Family : Entity_Id;
+
+      begin
+         Exp := First (Exprs);
+
+         if Is_Overloaded (P) then
+            Process_Overloaded_Indexed_Component;
+
+         else
+            Array_Type := Etype (P);
+
+            --  Prefix must be appropriate for an array type.
+            --  Dereference the prefix if it is an access type.
+
+            if Is_Access_Type (Array_Type) then
+               Array_Type := Designated_Type (Array_Type);
+            end if;
+
+            if Is_Array_Type (Array_Type) then
+               null;
+
+            elsif (Is_Entity_Name (P)
+                     and then
+                   Ekind (Entity (P)) = E_Entry_Family)
+               or else
+                 (Nkind (P) = N_Selected_Component
+                    and then
+                  Is_Entity_Name (Selector_Name (P))
+                    and then
+                  Ekind (Entity (Selector_Name (P))) = E_Entry_Family)
+            then
+               if Is_Entity_Name (P) then
+                  Entry_Family := Entity (P);
+               else
+                  Entry_Family := Entity (Selector_Name (P));
+               end if;
+
+               Analyze (Exp);
+               Set_Etype (N, Any_Type);
+
+               if not Has_Compatible_Type
+                 (Exp, Entry_Index_Type (Entry_Family))
+               then
+                  Error_Msg_N ("invalid index type in entry name", N);
+
+               elsif Present (Next (Exp)) then
+                  Error_Msg_N ("too many subscripts in entry reference", N);
+
+               else
+                  Set_Etype (N,  Etype (P));
+               end if;
+
+               return;
+
+            elsif Is_Record_Type (Array_Type)
+              and then Remote_AST_I_Dereference (P)
+            then
+               return;
+
+            elsif Array_Type = Any_Type then
+               Set_Etype (N, Any_Type);
+               return;
+
+            --  Here we definitely have a bad indexing
+
+            else
+               if Nkind (Parent (N)) = N_Requeue_Statement
+                 and then
+                   ((Is_Entity_Name (P)
+                        and then Ekind (Entity (P)) = E_Entry)
+                    or else
+                     (Nkind (P) = N_Selected_Component
+                       and then Is_Entity_Name (Selector_Name (P))
+                       and then Ekind (Entity (Selector_Name (P))) = E_Entry))
+               then
+                  Error_Msg_N
+                    ("REQUEUE does not permit parameters", First (Exprs));
+
+               elsif Is_Entity_Name (P)
+                 and then Etype (P) = Standard_Void_Type
+               then
+                  Error_Msg_NE ("incorrect use of&", P, Entity (P));
+
+               else
+                  Error_Msg_N ("array type required in indexed component", P);
+               end if;
+
+               Set_Etype (N, Any_Type);
+               return;
+            end if;
+
+            Index := First_Index (Array_Type);
+
+            while Present (Index) and then Present (Exp) loop
+               if not Has_Compatible_Type (Exp, Etype (Index)) then
+                  Wrong_Type (Exp, Etype (Index));
+                  Set_Etype (N, Any_Type);
+                  return;
+               end if;
+
+               Next_Index (Index);
+               Next (Exp);
+            end loop;
+
+            Set_Etype (N, Component_Type (Array_Type));
+
+            if Present (Index) then
+               Error_Msg_N
+                 ("too few subscripts in array reference", First (Exprs));
+
+            elsif Present (Exp) then
+               Error_Msg_N ("too many subscripts in array reference", Exp);
+            end if;
+         end if;
+
+      end Process_Indexed_Component;
+
+      ----------------------------------------
+      -- Process_Indexed_Component_Or_Slice --
+      ----------------------------------------
+
+      procedure Process_Indexed_Component_Or_Slice is
+      begin
+         Exp := First (Exprs);
+
+         while Present (Exp) loop
+            Analyze_Expression (Exp);
+            Next (Exp);
+         end loop;
+
+         Exp := First (Exprs);
+
+         --  If one index is present, and it is a subtype name, then the
+         --  node denotes a slice (note that the case of an explicit range
+         --  for a slice was already built as an N_Slice node in the first
+         --  place, so that case is not handled here).
+
+         --  We use a replace rather than a rewrite here because this is one
+         --  of the cases in which the tree built by the parser is plain wrong.
+
+         if No (Next (Exp))
+           and then Is_Entity_Name (Exp)
+           and then Is_Type (Entity (Exp))
+         then
+            Replace (N,
+               Make_Slice (Sloc (N),
+                 Prefix => P,
+                 Discrete_Range => New_Copy (Exp)));
+            Analyze (N);
+
+         --  Otherwise (more than one index present, or single index is not
+         --  a subtype name), then we have the indexed component case.
+
+         else
+            Process_Indexed_Component;
+         end if;
+      end Process_Indexed_Component_Or_Slice;
+
+      ------------------------------------------
+      -- Process_Overloaded_Indexed_Component --
+      ------------------------------------------
+
+      procedure Process_Overloaded_Indexed_Component is
+         Exp   : Node_Id;
+         I     : Interp_Index;
+         It    : Interp;
+         Typ   : Entity_Id;
+         Index : Node_Id;
+         Found : Boolean;
+
+      begin
+         Set_Etype (N, Any_Type);
+         Get_First_Interp (P, I, It);
+
+         while Present (It.Nam) loop
+            Typ := It.Typ;
+
+            if Is_Access_Type (Typ) then
+               Typ := Designated_Type (Typ);
+            end if;
+
+            if Is_Array_Type (Typ) then
+
+               --  Got a candidate: verify that index types are compatible
+
+               Index := First_Index (Typ);
+               Found := True;
+
+               Exp := First (Exprs);
+
+               while Present (Index) and then Present (Exp) loop
+                  if Has_Compatible_Type (Exp, Etype (Index)) then
+                     null;
+                  else
+                     Found := False;
+                     Remove_Interp (I);
+                     exit;
+                  end if;
+
+                  Next_Index (Index);
+                  Next (Exp);
+               end loop;
+
+               if Found and then No (Index) and then No (Exp) then
+                  Add_One_Interp (N,
+                     Etype (Component_Type (Typ)),
+                     Etype (Component_Type (Typ)));
+               end if;
+            end if;
+
+            Get_Next_Interp (I, It);
+         end loop;
+
+         if Etype (N) = Any_Type then
+            Error_Msg_N ("no legal interpetation for indexed component", N);
+            Set_Is_Overloaded (N, False);
+         end if;
+
+         End_Interp_List;
+      end Process_Overloaded_Indexed_Component;
+
+   ------------------------------------
+   -- Analyze_Indexed_Component_Form --
+   ------------------------------------
+
+   begin
+      --  Get name of array, function or type
+
+      Analyze (P);
+      P_T := Base_Type (Etype (P));
+
+      if Is_Entity_Name (P)
+        or else Nkind (P) = N_Operator_Symbol
+      then
+         U_N := Entity (P);
+
+         if Ekind (U_N) in  Type_Kind then
+
+            --  Reformat node as a type conversion.
+
+            E := Remove_Head (Exprs);
+
+            if Present (First (Exprs)) then
+               Error_Msg_N
+                ("argument of type conversion must be single expression", N);
+            end if;
+
+            Change_Node (N, N_Type_Conversion);
+            Set_Subtype_Mark (N, P);
+            Set_Etype (N, U_N);
+            Set_Expression (N, E);
+
+            --  After changing the node, call for the specific Analysis
+            --  routine directly, to avoid a double call to the expander.
+
+            Analyze_Type_Conversion (N);
+            return;
+         end if;
+
+         if Is_Overloadable (U_N) then
+            Process_Function_Call;
+
+         elsif Ekind (Etype (P)) = E_Subprogram_Type
+           or else (Is_Access_Type (Etype (P))
+                      and then
+                    Ekind (Designated_Type (Etype (P))) = E_Subprogram_Type)
+         then
+            --  Call to access_to-subprogram with possible implicit dereference
+
+            Process_Function_Call;
+
+         elsif Ekind (U_N) = E_Generic_Function
+           or else Ekind (U_N) = E_Generic_Procedure
+         then
+            --  A common beginner's (or C++ templates fan) error.
+
+            Error_Msg_N ("generic subprogram cannot be called", N);
+            Set_Etype (N, Any_Type);
+            return;
+
+         else
+            Process_Indexed_Component_Or_Slice;
+         end if;
+
+      --  If not an entity name, prefix is an expression that may denote
+      --  an array or an access-to-subprogram.
+
+      else
+
+         if (Ekind (P_T) = E_Subprogram_Type)
+           or else (Is_Access_Type (P_T)
+                     and then
+                    Ekind (Designated_Type (P_T)) = E_Subprogram_Type)
+         then
+            Process_Function_Call;
+
+         elsif Nkind (P) = N_Selected_Component
+           and then Ekind (Entity (Selector_Name (P))) = E_Function
+         then
+            Process_Function_Call;
+
+         else
+            --  Indexed component, slice, or a call to a member of a family
+            --  entry, which will be converted to an entry call later.
+            Process_Indexed_Component_Or_Slice;
+         end if;
+      end if;
+   end Analyze_Indexed_Component_Form;
+
+   ------------------------
+   -- Analyze_Logical_Op --
+   ------------------------
+
+   procedure Analyze_Logical_Op (N : Node_Id) is
+      L     : constant Node_Id := Left_Opnd (N);
+      R     : constant Node_Id := Right_Opnd (N);
+      Op_Id : Entity_Id := Entity (N);
+
+   begin
+      Set_Etype (N, Any_Type);
+      Candidate_Type := Empty;
+
+      Analyze_Expression (L);
+      Analyze_Expression (R);
+
+      if Present (Op_Id) then
+
+         if Ekind (Op_Id) = E_Operator then
+            Find_Boolean_Types (L, R, Op_Id, N);
+         else
+            Add_One_Interp (N, Op_Id, Etype (Op_Id));
+         end if;
+
+      else
+         Op_Id := Get_Name_Entity_Id (Chars (N));
+
+         while Present (Op_Id) loop
+            if Ekind (Op_Id) = E_Operator then
+               Find_Boolean_Types (L, R, Op_Id, N);
+            else
+               Analyze_User_Defined_Binary_Op (N, Op_Id);
+            end if;
+
+            Op_Id := Homonym (Op_Id);
+         end loop;
+      end if;
+
+      Operator_Check (N);
+   end Analyze_Logical_Op;
+
+   ---------------------------
+   -- Analyze_Membership_Op --
+   ---------------------------
+
+   procedure Analyze_Membership_Op (N : Node_Id) is
+      L     : constant Node_Id := Left_Opnd (N);
+      R     : constant Node_Id := Right_Opnd (N);
+
+      Index : Interp_Index;
+      It    : Interp;
+      Found : Boolean := False;
+      I_F   : Interp_Index;
+      T_F   : Entity_Id;
+
+      procedure Try_One_Interp (T1 : Entity_Id);
+      --  Routine to try one proposed interpretation. Note that the context
+      --  of the operation plays no role in resolving the arguments, so that
+      --  if there is more than one interpretation of the operands that is
+      --  compatible with a membership test, the operation is ambiguous.
+
+      procedure Try_One_Interp (T1 : Entity_Id) is
+      begin
+         if Has_Compatible_Type (R, T1) then
+            if Found
+              and then Base_Type (T1) /= Base_Type (T_F)
+            then
+               It := Disambiguate (L, I_F, Index, Any_Type);
+
+               if It = No_Interp then
+                  Ambiguous_Operands (N);
+                  Set_Etype (L, Any_Type);
+                  return;
+
+               else
+                  T_F := It.Typ;
+               end if;
+
+            else
+               Found := True;
+               T_F   := T1;
+               I_F   := Index;
+            end if;
+
+            Set_Etype (L, T_F);
+         end if;
+
+      end Try_One_Interp;
+
+   --  Start of processing for Analyze_Membership_Op
+
+   begin
+      Analyze_Expression (L);
+
+      if Nkind (R) = N_Range
+        or else (Nkind (R) = N_Attribute_Reference
+                  and then Attribute_Name (R) = Name_Range)
+      then
+         Analyze (R);
+
+         if not Is_Overloaded (L) then
+            Try_One_Interp (Etype (L));
+
+         else
+            Get_First_Interp (L, Index, It);
+
+            while Present (It.Typ) loop
+               Try_One_Interp (It.Typ);
+               Get_Next_Interp (Index, It);
+            end loop;
+         end if;
+
+      --  If not a range, it can only be a subtype mark, or else there
+      --  is a more basic error, to be diagnosed in Find_Type.
+
+      else
+         Find_Type (R);
+
+         if Is_Entity_Name (R) then
+            Check_Fully_Declared (Entity (R), R);
+         end if;
+      end if;
+
+      --  Compatibility between expression and subtype mark or range is
+      --  checked during resolution. The result of the operation is Boolean
+      --  in any case.
+
+      Set_Etype (N, Standard_Boolean);
+   end Analyze_Membership_Op;
+
+   ----------------------
+   -- Analyze_Negation --
+   ----------------------
+
+   procedure Analyze_Negation (N : Node_Id) is
+      R     : constant Node_Id := Right_Opnd (N);
+      Op_Id : Entity_Id := Entity (N);
+
+   begin
+      Set_Etype (N, Any_Type);
+      Candidate_Type := Empty;
+
+      Analyze_Expression (R);
+
+      if Present (Op_Id) then
+         if Ekind (Op_Id) = E_Operator then
+            Find_Negation_Types (R, Op_Id, N);
+         else
+            Add_One_Interp (N, Op_Id, Etype (Op_Id));
+         end if;
+
+      else
+         Op_Id := Get_Name_Entity_Id (Chars (N));
+
+         while Present (Op_Id) loop
+            if Ekind (Op_Id) = E_Operator then
+               Find_Negation_Types (R, Op_Id, N);
+            else
+               Analyze_User_Defined_Unary_Op (N, Op_Id);
+            end if;
+
+            Op_Id := Homonym (Op_Id);
+         end loop;
+      end if;
+
+      Operator_Check (N);
+   end Analyze_Negation;
+
+   -------------------
+   --  Analyze_Null --
+   -------------------
+
+   procedure Analyze_Null (N : Node_Id) is
+   begin
+      Set_Etype (N, Any_Access);
+   end Analyze_Null;
+
+   ----------------------
+   -- Analyze_One_Call --
+   ----------------------
+
+   procedure Analyze_One_Call
+      (N       : Node_Id;
+       Nam     : Entity_Id;
+       Report  : Boolean;
+       Success : out Boolean)
+   is
+      Actuals    : constant List_Id   := Parameter_Associations (N);
+      Prev_T     : constant Entity_Id := Etype (N);
+      Formal     : Entity_Id;
+      Actual     : Node_Id;
+      Is_Indexed : Boolean := False;
+      Subp_Type  : constant Entity_Id := Etype (Nam);
+      Norm_OK    : Boolean;
+
+      procedure Set_Name;
+      --  If candidate interpretation matches, indicate name and type of
+      --  result on call node.
+
+      --------------
+      -- Set_Name --
+      --------------
+
+      procedure Set_Name is
+      begin
+         Add_One_Interp (N, Nam, Etype (Nam));
+         Success := True;
+
+         --  If the prefix of the call is a name, indicate the entity
+         --  being called. If it is not a name,  it is an expression that
+         --  denotes an access to subprogram or else an entry or family. In
+         --  the latter case, the name is a selected component, and the entity
+         --  being called is noted on the selector.
+
+         if not Is_Type (Nam) then
+            if Is_Entity_Name (Name (N))
+              or else Nkind (Name (N)) = N_Operator_Symbol
+            then
+               Set_Entity (Name (N), Nam);
+
+            elsif Nkind (Name (N)) = N_Selected_Component then
+               Set_Entity (Selector_Name (Name (N)),  Nam);
+            end if;
+         end if;
+
+         if Debug_Flag_E and not Report then
+            Write_Str (" Overloaded call ");
+            Write_Int (Int (N));
+            Write_Str (" compatible with ");
+            Write_Int (Int (Nam));
+            Write_Eol;
+         end if;
+      end Set_Name;
+
+   --  Start of processing for Analyze_One_Call
+
+   begin
+      Success := False;
+
+      --  If the subprogram has no formals, or if all the formals have
+      --  defaults, and the return type is an array type, the node may
+      --  denote an indexing of the result of a parameterless call.
+
+      if Needs_No_Actuals (Nam)
+        and then Present (Actuals)
+      then
+         if Is_Array_Type (Subp_Type) then
+            Is_Indexed := Try_Indexed_Call (N, Nam, Subp_Type);
+
+         elsif Is_Access_Type (Subp_Type)
+           and then Is_Array_Type (Designated_Type (Subp_Type))
+         then
+            Is_Indexed :=
+              Try_Indexed_Call (N, Nam, Designated_Type (Subp_Type));
+
+         elsif Is_Access_Type (Subp_Type)
+           and then Ekind (Designated_Type (Subp_Type))  = E_Subprogram_Type
+         then
+            Is_Indexed := Try_Indirect_Call (N, Nam, Subp_Type);
+         end if;
+
+      end if;
+
+      Normalize_Actuals (N, Nam, (Report and not Is_Indexed), Norm_OK);
+
+      if not Norm_OK then
+
+         --  Mismatch in number or names of parameters
+
+         if Debug_Flag_E then
+            Write_Str (" normalization fails in call ");
+            Write_Int (Int (N));
+            Write_Str (" with subprogram ");
+            Write_Int (Int (Nam));
+            Write_Eol;
+         end if;
+
+      --  If the context expects a function call, discard any interpretation
+      --  that is a procedure. If the node is not overloaded, leave as is for
+      --  better error reporting when type mismatch is found.
+
+      elsif Nkind (N) = N_Function_Call
+        and then Is_Overloaded (Name (N))
+        and then Ekind (Nam) = E_Procedure
+      then
+         return;
+
+      --  Ditto for function calls in a procedure context.
+
+      elsif Nkind (N) = N_Procedure_Call_Statement
+         and then Is_Overloaded (Name (N))
+         and then Etype (Nam) /= Standard_Void_Type
+      then
+         return;
+
+      elsif not Present (Actuals) then
+
+         --  If Normalize succeeds, then there are default parameters for
+         --  all formals.
+
+         Set_Name;
+
+      elsif Ekind (Nam) = E_Operator then
+
+         if Nkind (N) = N_Procedure_Call_Statement then
+            return;
+         end if;
+
+         --  This can occur when the prefix of the call is an operator
+         --  name or an expanded name whose selector is an operator name.
+
+         Analyze_Operator_Call (N, Nam);
+
+         if Etype (N) /= Prev_T then
+
+            --  There may be a user-defined operator that hides the
+            --  current interpretation. We must check for this independently
+            --  of the analysis of the call with the user-defined operation,
+            --  because the parameter names may be wrong and yet the hiding
+            --  takes place. Fixes b34014o.
+
+            if Is_Overloaded (Name (N)) then
+               declare
+                  I  : Interp_Index;
+                  It : Interp;
+
+               begin
+                  Get_First_Interp (Name (N), I, It);
+
+                  while Present (It.Nam) loop
+
+                     if Ekind (It.Nam) /= E_Operator
+                        and then Hides_Op (It.Nam, Nam)
+                        and then
+                          Has_Compatible_Type
+                            (First_Actual (N), Etype (First_Formal (It.Nam)))
+                        and then (No (Next_Actual (First_Actual (N)))
+                           or else Has_Compatible_Type
+                            (Next_Actual (First_Actual (N)),
+                             Etype (Next_Formal (First_Formal (It.Nam)))))
+                     then
+                        Set_Etype (N, Prev_T);
+                        return;
+                     end if;
+
+                     Get_Next_Interp (I, It);
+                  end loop;
+               end;
+            end if;
+
+            --  If operator matches formals, record its name on the call.
+            --  If the operator is overloaded, Resolve will select the
+            --  correct one from the list of interpretations. The call
+            --  node itself carries the first candidate.
+
+            Set_Entity (Name (N), Nam);
+            Success := True;
+
+         elsif Report and then Etype (N) = Any_Type then
+            Error_Msg_N ("incompatible arguments for operator", N);
+         end if;
+
+      else
+         --  Normalize_Actuals has chained the named associations in the
+         --  correct order of the formals.
+
+         Actual := First_Actual (N);
+         Formal := First_Formal (Nam);
+
+         while Present (Actual) and then Present (Formal) loop
+
+            if (Nkind (Parent (Actual)) /= N_Parameter_Association
+              or else Chars (Selector_Name (Parent (Actual))) = Chars (Formal))
+            then
+               if Has_Compatible_Type (Actual, Etype (Formal)) then
+                  Next_Actual (Actual);
+                  Next_Formal (Formal);
+
+               else
+                  if Debug_Flag_E then
+                     Write_Str (" type checking fails in call ");
+                     Write_Int (Int (N));
+                     Write_Str (" with formal ");
+                     Write_Int (Int (Formal));
+                     Write_Str (" in subprogram ");
+                     Write_Int (Int (Nam));
+                     Write_Eol;
+                  end if;
+
+                  if Report and not Is_Indexed then
+
+                     Wrong_Type (Actual, Etype (Formal));
+
+                     if Nkind (Actual) = N_Op_Eq
+                       and then Nkind (Left_Opnd (Actual)) = N_Identifier
+                     then
+                        Formal := First_Formal (Nam);
+
+                        while Present (Formal) loop
+
+                           if Chars (Left_Opnd (Actual)) = Chars (Formal) then
+                              Error_Msg_N
+                                ("possible misspelling of `=>`!", Actual);
+                              exit;
+                           end if;
+
+                           Next_Formal (Formal);
+                        end loop;
+                     end if;
+
+                     if All_Errors_Mode then
+                        Error_Msg_Sloc := Sloc (Nam);
+
+                        if Is_Overloadable (Nam)
+                          and then Present (Alias (Nam))
+                          and then not Comes_From_Source (Nam)
+                        then
+                           Error_Msg_NE
+                             ("  ==> in call to &#(inherited)!", Actual, Nam);
+                        else
+                           Error_Msg_NE ("  ==> in call to &#!", Actual, Nam);
+                        end if;
+                     end if;
+                  end if;
+
+                  return;
+               end if;
+
+            else
+               --  Normalize_Actuals has verified that a default value exists
+               --  for this formal. Current actual names a subsequent formal.
+
+               Next_Formal (Formal);
+            end if;
+         end loop;
+
+         --  On exit, all actuals match.
+
+         Set_Name;
+      end if;
+   end Analyze_One_Call;
+
+   ----------------------------
+   --  Analyze_Operator_Call --
+   ----------------------------
+
+   procedure Analyze_Operator_Call (N : Node_Id; Op_Id : Entity_Id) is
+      Op_Name : constant Name_Id := Chars (Op_Id);
+      Act1    : constant Node_Id := First_Actual (N);
+      Act2    : constant Node_Id := Next_Actual (Act1);
+
+   begin
+      if Present (Act2) then
+
+         --  Maybe binary operators
+
+         if Present (Next_Actual (Act2)) then
+
+            --  Too many actuals for an operator
+
+            return;
+
+         elsif     Op_Name = Name_Op_Add
+           or else Op_Name = Name_Op_Subtract
+           or else Op_Name = Name_Op_Multiply
+           or else Op_Name = Name_Op_Divide
+           or else Op_Name = Name_Op_Mod
+           or else Op_Name = Name_Op_Rem
+           or else Op_Name = Name_Op_Expon
+         then
+            Find_Arithmetic_Types (Act1, Act2, Op_Id, N);
+
+         elsif     Op_Name =  Name_Op_And
+           or else Op_Name = Name_Op_Or
+           or else Op_Name = Name_Op_Xor
+         then
+            Find_Boolean_Types (Act1, Act2, Op_Id, N);
+
+         elsif     Op_Name = Name_Op_Lt
+           or else Op_Name = Name_Op_Le
+           or else Op_Name = Name_Op_Gt
+           or else Op_Name = Name_Op_Ge
+         then
+            Find_Comparison_Types (Act1, Act2, Op_Id,  N);
+
+         elsif     Op_Name = Name_Op_Eq
+           or else Op_Name = Name_Op_Ne
+         then
+            Find_Equality_Types (Act1, Act2, Op_Id,  N);
+
+         elsif     Op_Name = Name_Op_Concat then
+            Find_Concatenation_Types (Act1, Act2, Op_Id, N);
+
+         --  Is this else null correct, or should it be an abort???
+
+         else
+            null;
+         end if;
+
+      else
+         --  Unary operators
+
+         if Op_Name = Name_Op_Subtract or else
+            Op_Name = Name_Op_Add      or else
+            Op_Name = Name_Op_Abs
+         then
+            Find_Unary_Types (Act1, Op_Id, N);
+
+         elsif
+            Op_Name = Name_Op_Not
+         then
+            Find_Negation_Types (Act1, Op_Id, N);
+
+         --  Is this else null correct, or should it be an abort???
+
+         else
+            null;
+         end if;
+      end if;
+   end Analyze_Operator_Call;
+
+   -------------------------------------------
+   -- Analyze_Overloaded_Selected_Component --
+   -------------------------------------------
+
+   procedure Analyze_Overloaded_Selected_Component (N : Node_Id) is
+      Comp  : Entity_Id;
+      Nam   : Node_Id := Prefix (N);
+      Sel   : Node_Id := Selector_Name (N);
+      I     : Interp_Index;
+      It    : Interp;
+      T     : Entity_Id;
+
+   begin
+      Get_First_Interp (Nam, I, It);
+
+      Set_Etype (Sel,  Any_Type);
+
+      while Present (It.Typ) loop
+         if Is_Access_Type (It.Typ) then
+            T := Designated_Type (It.Typ);
+         else
+            T := It.Typ;
+         end if;
+
+         if Is_Record_Type (T) then
+            Comp := First_Entity (T);
+
+            while Present (Comp) loop
+
+               if Chars (Comp) = Chars (Sel)
+                 and then Is_Visible_Component (Comp)
+               then
+                  Set_Entity_With_Style_Check (Sel, Comp);
+                  Generate_Reference (Comp, Sel);
+
+                  Set_Etype (Sel, Etype (Comp));
+                  Add_One_Interp (N, Etype (Comp), Etype (Comp));
+
+                  --  This also specifies a candidate to resolve the name.
+                  --  Further overloading will be resolved from context.
+
+                  Set_Etype (Nam, It.Typ);
+               end if;
+
+               Next_Entity (Comp);
+            end loop;
+
+         elsif Is_Concurrent_Type (T) then
+            Comp := First_Entity (T);
+
+            while Present (Comp)
+              and then Comp /= First_Private_Entity (T)
+            loop
+               if Chars (Comp) = Chars (Sel) then
+                  if Is_Overloadable (Comp) then
+                     Add_One_Interp (Sel, Comp, Etype (Comp));
+                  else
+                     Set_Entity_With_Style_Check (Sel, Comp);
+                     Generate_Reference (Comp, Sel);
+                  end if;
+
+                  Set_Etype (Sel, Etype (Comp));
+                  Set_Etype (N,   Etype (Comp));
+                  Set_Etype (Nam, It.Typ);
+
+                  --  For access type case, introduce explicit deference for
+                  --  more uniform treatment of entry calls.
+
+                  if Is_Access_Type (Etype (Nam)) then
+                     Insert_Explicit_Dereference (Nam);
+                  end if;
+               end if;
+
+               Next_Entity (Comp);
+            end loop;
+
+            Set_Is_Overloaded (N, Is_Overloaded (Sel));
+
+         end if;
+
+         Get_Next_Interp (I, It);
+      end loop;
+
+      if Etype (N) = Any_Type then
+         Error_Msg_NE ("undefined selector& for overloaded prefix", N, Sel);
+         Set_Entity (Sel, Any_Id);
+         Set_Etype  (Sel, Any_Type);
+      end if;
+
+   end Analyze_Overloaded_Selected_Component;
+
+   ----------------------------------
+   -- Analyze_Qualified_Expression --
+   ----------------------------------
+
+   procedure Analyze_Qualified_Expression (N : Node_Id) is
+      Mark : constant Entity_Id := Subtype_Mark (N);
+      T    : Entity_Id;
+
+   begin
+      Set_Etype (N, Any_Type);
+      Find_Type (Mark);
+      T := Entity (Mark);
+
+      if T = Any_Type then
+         return;
+      end if;
+      Check_Fully_Declared (T, N);
+
+      Analyze_Expression (Expression (N));
+      Set_Etype  (N, T);
+   end Analyze_Qualified_Expression;
+
+   -------------------
+   -- Analyze_Range --
+   -------------------
+
+   procedure Analyze_Range (N : Node_Id) is
+      L        : constant Node_Id := Low_Bound (N);
+      H        : constant Node_Id := High_Bound (N);
+      I1, I2   : Interp_Index;
+      It1, It2 : Interp;
+
+      procedure Check_Common_Type (T1, T2 : Entity_Id);
+      --  Verify the compatibility of two types,  and choose the
+      --  non universal one if the other is universal.
+
+      procedure Check_High_Bound (T : Entity_Id);
+      --  Test one interpretation of the low bound against all those
+      --  of the high bound.
+
+      -----------------------
+      -- Check_Common_Type --
+      -----------------------
+
+      procedure Check_Common_Type (T1, T2 : Entity_Id) is
+      begin
+         if Covers (T1, T2) or else Covers (T2, T1) then
+            if T1 = Universal_Integer
+              or else T1 = Universal_Real
+              or else T1 = Any_Character
+            then
+               Add_One_Interp (N, Base_Type (T2), Base_Type (T2));
+
+            elsif (T1 = T2) then
+               Add_One_Interp (N, T1, T1);
+
+            else
+               Add_One_Interp (N, Base_Type (T1), Base_Type (T1));
+            end if;
+         end if;
+      end Check_Common_Type;
+
+      ----------------------
+      -- Check_High_Bound --
+      ----------------------
+
+      procedure Check_High_Bound (T : Entity_Id) is
+      begin
+         if not Is_Overloaded (H) then
+            Check_Common_Type (T, Etype (H));
+         else
+            Get_First_Interp (H, I2, It2);
+
+            while Present (It2.Typ) loop
+               Check_Common_Type (T, It2.Typ);
+               Get_Next_Interp (I2, It2);
+            end loop;
+         end if;
+      end Check_High_Bound;
+
+   --  Start of processing for Analyze_Range
+
+   begin
+      Set_Etype (N, Any_Type);
+      Analyze_Expression (L);
+      Analyze_Expression (H);
+
+      if Etype (L) = Any_Type or else Etype (H) = Any_Type then
+         return;
+
+      else
+         if not Is_Overloaded (L) then
+            Check_High_Bound (Etype (L));
+         else
+            Get_First_Interp (L, I1, It1);
+
+            while Present (It1.Typ) loop
+               Check_High_Bound (It1.Typ);
+               Get_Next_Interp (I1, It1);
+            end loop;
+         end if;
+
+         --  If result is Any_Type, then we did not find a compatible pair
+
+         if Etype (N) = Any_Type then
+            Error_Msg_N ("incompatible types in range ", N);
+         end if;
+      end if;
+   end Analyze_Range;
+
+   -----------------------
+   -- Analyze_Reference --
+   -----------------------
+
+   procedure Analyze_Reference (N : Node_Id) is
+      P        : constant Node_Id := Prefix (N);
+      Acc_Type : Entity_Id;
+
+   begin
+      Analyze (P);
+      Acc_Type := Create_Itype (E_Allocator_Type, N);
+      Set_Etype                    (Acc_Type,  Acc_Type);
+      Init_Size_Align              (Acc_Type);
+      Set_Directly_Designated_Type (Acc_Type, Etype (P));
+      Set_Etype (N, Acc_Type);
+   end Analyze_Reference;
+
+   --------------------------------
+   -- Analyze_Selected_Component --
+   --------------------------------
+
+   --  Prefix is a record type or a task or protected type. In the
+   --  later case, the selector must denote a visible entry.
+
+   procedure Analyze_Selected_Component (N : Node_Id) is
+      Name        : constant Node_Id := Prefix (N);
+      Sel         : constant Node_Id := Selector_Name (N);
+      Comp        : Entity_Id;
+      Entity_List : Entity_Id;
+      Prefix_Type : Entity_Id;
+      Act_Decl    : Node_Id;
+      In_Scope    : Boolean;
+      Parent_N    : Node_Id;
+
+   --  Start of processing for Analyze_Selected_Component
+
+   begin
+      Set_Etype (N, Any_Type);
+
+      if Is_Overloaded (Name) then
+         Analyze_Overloaded_Selected_Component (N);
+         return;
+
+      elsif Etype (Name) = Any_Type then
+         Set_Entity (Sel, Any_Id);
+         Set_Etype (Sel, Any_Type);
+         return;
+
+      else
+         --  Function calls that are prefixes of selected components must be
+         --  fully resolved in case we need to build an actual subtype, or
+         --  do some other operation requiring a fully resolved prefix.
+
+         --  Note: Resolving all Nkinds of nodes here doesn't work.
+         --  (Breaks 2129-008) ???.
+
+         if Nkind (Name) = N_Function_Call then
+            Resolve (Name, Etype (Name));
+         end if;
+
+         Prefix_Type := Etype (Name);
+      end if;
+
+      if Is_Access_Type (Prefix_Type) then
+         if Is_Remote_Access_To_Class_Wide_Type (Prefix_Type)
+           and then Comes_From_Source (N)
+         then
+            --  A RACW object can never be used as prefix of a selected
+            --  component since that means it is dereferenced without
+            --  being a controlling operand of a dispatching operation
+            --  (RM E.2.2(15)).
+
+            Error_Msg_N
+              ("invalid dereference of a remote access to class-wide value",
+               N);
+         end if;
+         Prefix_Type := Designated_Type (Prefix_Type);
+      end if;
+
+      if Ekind (Prefix_Type) = E_Private_Subtype then
+         Prefix_Type := Base_Type (Prefix_Type);
+      end if;
+
+      Entity_List := Prefix_Type;
+
+      --  For class-wide types, use the entity list of the root type. This
+      --  indirection is specially important for private extensions because
+      --  only the root type get switched (not the class-wide type).
+
+      if Is_Class_Wide_Type (Prefix_Type) then
+         Entity_List := Root_Type (Prefix_Type);
+      end if;
+
+      Comp := First_Entity (Entity_List);
+
+      --  If the selector has an original discriminant, the node appears in
+      --  an instance. Replace the discriminant with the corresponding one
+      --  in the current discriminated type. For nested generics, this must
+      --  be done transitively, so note the new original discriminant.
+
+      if Nkind (Sel) = N_Identifier
+        and then Present (Original_Discriminant (Sel))
+      then
+         Comp := Find_Corresponding_Discriminant (Sel, Prefix_Type);
+
+         --  Mark entity before rewriting, for completeness and because
+         --  subsequent semantic checks might examine the original node.
+
+         Set_Entity (Sel, Comp);
+         Rewrite (Selector_Name (N),
+           New_Occurrence_Of (Comp, Sloc (N)));
+         Set_Original_Discriminant (Selector_Name (N), Comp);
+         Set_Etype (N, Etype (Comp));
+
+         if Is_Access_Type (Etype (Name)) then
+            Insert_Explicit_Dereference (Name);
+         end if;
+
+      elsif Is_Record_Type (Prefix_Type) then
+
+         --  Find component with given name
+
+         while Present (Comp) loop
+
+            if Chars (Comp) = Chars (Sel)
+              and then Is_Visible_Component (Comp)
+            then
+               Set_Entity_With_Style_Check (Sel, Comp);
+               Generate_Reference (Comp, Sel);
+
+               Set_Etype (Sel, Etype (Comp));
+
+               if Ekind (Comp) = E_Discriminant then
+                  if Is_Unchecked_Union (Prefix_Type) then
+                     Error_Msg_N
+                       ("cannot reference discriminant of Unchecked_Union",
+                        Sel);
+                  end if;
+
+                  if Is_Generic_Type (Prefix_Type)
+                       or else
+                     Is_Generic_Type (Root_Type (Prefix_Type))
+                  then
+                     Set_Original_Discriminant (Sel, Comp);
+                  end if;
+               end if;
+
+               --  Resolve the prefix early otherwise it is not possible to
+               --  build the actual subtype of the component: it may need
+               --  to duplicate this prefix and duplication is only allowed
+               --  on fully resolved expressions.
+
+               Resolve (Name, Etype (Name));
+
+               --  We never need an actual subtype for the case of a selection
+               --  for a indexed component of a non-packed array, since in
+               --  this case gigi generates all the checks and can find the
+               --  necessary bounds information.
+
+               --  We also do not need an actual subtype for the case of
+               --  a first, last, length, or range attribute applied to a
+               --  non-packed array, since gigi can again get the bounds in
+               --  these cases (gigi cannot handle the packed case, since it
+               --  has the bounds of the packed array type, not the original
+               --  bounds of the type). However, if the prefix is itself a
+               --  selected component, as in a.b.c (i), gigi may regard a.b.c
+               --  as a dynamic-sized temporary, so we do generate an actual
+               --  subtype for this case.
+
+               Parent_N := Parent (N);
+
+               if not Is_Packed (Etype (Comp))
+                 and then
+                   ((Nkind (Parent_N) = N_Indexed_Component
+                      and then Nkind (Name) /= N_Selected_Component)
+                     or else
+                      (Nkind (Parent_N) = N_Attribute_Reference
+                         and then (Attribute_Name (Parent_N) = Name_First
+                                    or else
+                                   Attribute_Name (Parent_N) = Name_Last
+                                    or else
+                                   Attribute_Name (Parent_N) = Name_Length
+                                    or else
+                                   Attribute_Name (Parent_N) = Name_Range)))
+               then
+                  Set_Etype (N, Etype (Comp));
+
+               --  In all other cases, we currently build an actual subtype. It
+               --  seems likely that many of these cases can be avoided, but
+               --  right now, the front end makes direct references to the
+               --  bounds (e.g. in egnerating a length check), and if we do
+               --  not make an actual subtype, we end up getting a direct
+               --  reference to a discriminant which will not do.
+
+               else
+                  Act_Decl :=
+                    Build_Actual_Subtype_Of_Component (Etype (Comp), N);
+                  Insert_Action (N, Act_Decl);
+
+                  if No (Act_Decl) then
+                     Set_Etype (N, Etype (Comp));
+
+                  else
+                     --  Component type depends on discriminants. Enter the
+                     --  main attributes of the subtype.
+
+                     declare
+                        Subt : Entity_Id := Defining_Identifier (Act_Decl);
+
+                     begin
+                        Set_Etype (Subt, Base_Type (Etype (Comp)));
+                        Set_Ekind (Subt, Ekind (Etype (Comp)));
+                        Set_Etype (N, Subt);
+                     end;
+                  end if;
+               end if;
+
+               return;
+            end if;
+
+            Next_Entity (Comp);
+         end loop;
+
+      elsif Is_Private_Type (Prefix_Type) then
+
+         --  Allow access only to discriminants of the type. If the
+         --  type has no full view, gigi uses the parent type for
+         --  the components, so we do the same here.
+
+         if No (Full_View (Prefix_Type)) then
+            Entity_List := Root_Type (Base_Type (Prefix_Type));
+            Comp := First_Entity (Entity_List);
+         end if;
+
+         while Present (Comp) loop
+
+            if Chars (Comp) = Chars (Sel) then
+               if Ekind (Comp) = E_Discriminant then
+                  Set_Entity_With_Style_Check (Sel, Comp);
+                  Generate_Reference (Comp, Sel);
+
+                  Set_Etype (Sel, Etype (Comp));
+                  Set_Etype (N,   Etype (Comp));
+
+                  if Is_Generic_Type (Prefix_Type)
+                    or else
+                     Is_Generic_Type (Root_Type (Prefix_Type))
+                  then
+                     Set_Original_Discriminant (Sel, Comp);
+                  end if;
+
+               else
+                  Error_Msg_NE
+                    ("invisible selector for }",
+                     N, First_Subtype (Prefix_Type));
+                  Set_Entity (Sel, Any_Id);
+                  Set_Etype (N, Any_Type);
+               end if;
+
+               return;
+            end if;
+
+            Next_Entity (Comp);
+         end loop;
+
+      elsif Is_Concurrent_Type (Prefix_Type) then
+
+         --  Prefix is concurrent type. Find visible operation with given name
+         --  For a task, this can only include entries or discriminants if
+         --  the task type is not an enclosing scope. If it is an enclosing
+         --  scope (e.g. in an inner task) then all entities are visible, but
+         --  the prefix must denote the enclosing scope, i.e. can only be
+         --  a direct name or an expanded name.
+
+         Set_Etype (Sel,  Any_Type);
+         In_Scope := In_Open_Scopes (Prefix_Type);
+
+         while Present (Comp) loop
+            if Chars (Comp) = Chars (Sel) then
+               if Is_Overloadable (Comp) then
+                  Add_One_Interp (Sel, Comp, Etype (Comp));
+
+               elsif Ekind (Comp) = E_Discriminant
+                 or else Ekind (Comp) = E_Entry_Family
+                 or else (In_Scope
+                   and then Is_Entity_Name (Name))
+               then
+                  Set_Entity_With_Style_Check (Sel, Comp);
+                  Generate_Reference (Comp, Sel);
+
+               else
+                  goto Next_Comp;
+               end if;
+
+               Set_Etype (Sel, Etype (Comp));
+               Set_Etype (N,   Etype (Comp));
+
+               if Ekind (Comp) = E_Discriminant then
+                  Set_Original_Discriminant (Sel, Comp);
+               end if;
+
+               --  For access type case, introduce explicit deference for
+               --  more uniform treatment of entry calls.
+
+               if Is_Access_Type (Etype (Name)) then
+                  Insert_Explicit_Dereference (Name);
+               end if;
+            end if;
+
+            <<Next_Comp>>
+               Next_Entity (Comp);
+               exit when not In_Scope
+                 and then Comp = First_Private_Entity (Prefix_Type);
+         end loop;
+
+         Set_Is_Overloaded (N, Is_Overloaded (Sel));
+
+      else
+         --  Invalid prefix
+
+         Error_Msg_NE ("invalid prefix in selected component&", N, Sel);
+      end if;
+
+      --  If N still has no type, the component is not defined in the prefix.
+
+      if Etype (N) = Any_Type then
+
+         --  If the prefix is a single concurrent object, use its name in
+         --  the error message, rather than that of its anonymous type.
+
+         if Is_Concurrent_Type (Prefix_Type)
+           and then Is_Internal_Name (Chars (Prefix_Type))
+           and then not Is_Derived_Type (Prefix_Type)
+           and then Is_Entity_Name (Name)
+         then
+
+            Error_Msg_Node_2 := Entity (Name);
+            Error_Msg_NE ("no selector& for&", N, Sel);
+
+            Check_Misspelled_Selector (Entity_List, Sel);
+
+         else
+            if Ekind (Prefix_Type) = E_Record_Subtype then
+
+               --  Check whether this is a component of the base type
+               --  which is absent from a statically constrained subtype.
+               --  This will raise constraint error at run-time, but is
+               --  not a compile-time error. When the selector is illegal
+               --  for base type as well fall through and generate a
+               --  compilation error anyway.
+
+               Comp := First_Component (Base_Type (Prefix_Type));
+
+               while Present (Comp) loop
+
+                  if Chars (Comp) = Chars (Sel)
+                    and then Is_Visible_Component (Comp)
+                  then
+                     Set_Entity_With_Style_Check (Sel, Comp);
+                     Generate_Reference (Comp, Sel);
+                     Set_Etype (Sel, Etype (Comp));
+                     Set_Etype (N,   Etype (Comp));
+
+                     --  Emit appropriate message. Gigi will replace the
+                     --  node subsequently with the appropriate Raise.
+
+                     Apply_Compile_Time_Constraint_Error
+                       (N, "component not present in }?",
+                        Ent => Prefix_Type, Rep => False);
+                     Set_Raises_Constraint_Error (N);
+                     return;
+                  end if;
+
+                  Next_Component (Comp);
+               end loop;
+
+            end if;
+
+            Error_Msg_Node_2 := First_Subtype (Prefix_Type);
+            Error_Msg_NE ("no selector& for}", N, Sel);
+
+            Check_Misspelled_Selector (Entity_List, Sel);
+
+         end if;
+
+         Set_Entity (Sel, Any_Id);
+         Set_Etype (Sel, Any_Type);
+      end if;
+   end Analyze_Selected_Component;
+
+   ---------------------------
+   -- Analyze_Short_Circuit --
+   ---------------------------
+
+   procedure Analyze_Short_Circuit (N : Node_Id) is
+      L   : constant Node_Id := Left_Opnd  (N);
+      R   : constant Node_Id := Right_Opnd (N);
+      Ind : Interp_Index;
+      It  : Interp;
+
+   begin
+      Analyze_Expression (L);
+      Analyze_Expression (R);
+      Set_Etype (N, Any_Type);
+
+      if not Is_Overloaded (L) then
+
+         if Root_Type (Etype (L)) = Standard_Boolean
+           and then Has_Compatible_Type (R, Etype (L))
+         then
+            Add_One_Interp (N, Etype (L), Etype (L));
+         end if;
+
+      else
+         Get_First_Interp (L, Ind, It);
+
+         while Present (It.Typ) loop
+            if Root_Type (It.Typ) = Standard_Boolean
+              and then Has_Compatible_Type (R, It.Typ)
+            then
+               Add_One_Interp (N, It.Typ, It.Typ);
+            end if;
+
+            Get_Next_Interp (Ind, It);
+         end loop;
+      end if;
+
+      --  Here we have failed to find an interpretation. Clearly we
+      --  know that it is not the case that both operands can have
+      --  an interpretation of Boolean, but this is by far the most
+      --  likely intended interpretation. So we simply resolve both
+      --  operands as Booleans, and at least one of these resolutions
+      --  will generate an error message, and we do not need to give
+      --  a further error message on the short circuit operation itself.
+
+      if Etype (N) = Any_Type then
+         Resolve (L, Standard_Boolean);
+         Resolve (R, Standard_Boolean);
+         Set_Etype (N, Standard_Boolean);
+      end if;
+   end Analyze_Short_Circuit;
+
+   -------------------
+   -- Analyze_Slice --
+   -------------------
+
+   procedure Analyze_Slice (N : Node_Id) is
+      P          : constant Node_Id := Prefix (N);
+      D          : constant Node_Id := Discrete_Range (N);
+      Array_Type : Entity_Id;
+
+      procedure Analyze_Overloaded_Slice;
+      --  If the prefix is overloaded, select those interpretations that
+      --  yield a one-dimensional array type.
+
+      procedure Analyze_Overloaded_Slice is
+         I   : Interp_Index;
+         It  : Interp;
+         Typ : Entity_Id;
+
+      begin
+         Set_Etype (N, Any_Type);
+         Get_First_Interp (P, I, It);
+
+         while Present (It.Nam) loop
+            Typ := It.Typ;
+
+            if Is_Access_Type (Typ) then
+               Typ := Designated_Type (Typ);
+            end if;
+
+            if Is_Array_Type (Typ)
+              and then Number_Dimensions (Typ) = 1
+              and then Has_Compatible_Type (D, Etype (First_Index (Typ)))
+            then
+               Add_One_Interp (N, Typ, Typ);
+            end if;
+
+            Get_Next_Interp (I, It);
+         end loop;
+
+         if Etype (N) = Any_Type then
+            Error_Msg_N ("expect array type in prefix of slice",  N);
+         end if;
+      end Analyze_Overloaded_Slice;
+
+   --  Start of processing for Analyze_Slice
+
+   begin
+      --  Analyze the prefix if not done already
+
+      if No (Etype (P)) then
+         Analyze (P);
+      end if;
+
+      Analyze (D);
+
+      if Is_Overloaded (P) then
+         Analyze_Overloaded_Slice;
+
+      else
+         Array_Type := Etype (P);
+         Set_Etype (N, Any_Type);
+
+         if Is_Access_Type (Array_Type) then
+            Array_Type := Designated_Type (Array_Type);
+         end if;
+
+         if not Is_Array_Type (Array_Type) then
+            Wrong_Type (P, Any_Array);
+
+         elsif Number_Dimensions (Array_Type) > 1 then
+            Error_Msg_N
+              ("type is not one-dimensional array in slice prefix", N);
+
+         elsif not
+           Has_Compatible_Type (D, Etype (First_Index (Array_Type)))
+         then
+            Wrong_Type (D, Etype (First_Index (Array_Type)));
+
+         else
+            Set_Etype (N, Array_Type);
+         end if;
+      end if;
+   end Analyze_Slice;
+
+   -----------------------------
+   -- Analyze_Type_Conversion --
+   -----------------------------
+
+   procedure Analyze_Type_Conversion (N : Node_Id) is
+      Expr : constant Node_Id := Expression (N);
+      T    : Entity_Id;
+
+   begin
+      --  If Conversion_OK is set, then the Etype is already set, and the
+      --  only processing required is to analyze the expression. This is
+      --  used to construct certain "illegal" conversions which are not
+      --  allowed by Ada semantics, but can be handled OK by Gigi, see
+      --  Sinfo for further details.
+
+      if Conversion_OK (N) then
+         Analyze (Expr);
+         return;
+      end if;
+
+      --  Otherwise full type analysis is required, as well as some semantic
+      --  checks to make sure the argument of the conversion is appropriate.
+
+      Find_Type (Subtype_Mark (N));
+      T := Entity (Subtype_Mark (N));
+      Set_Etype (N, T);
+      Check_Fully_Declared (T, N);
+      Analyze_Expression (Expr);
+      Validate_Remote_Type_Type_Conversion (N);
+
+      --  Only remaining step is validity checks on the argument. These
+      --  are skipped if the conversion does not come from the source.
+
+      if not Comes_From_Source (N) then
+         return;
+
+      elsif Nkind (Expr) = N_Null then
+         Error_Msg_N ("argument of conversion cannot be null", N);
+         Error_Msg_N ("\use qualified expression instead", N);
+         Set_Etype (N, Any_Type);
+
+      elsif Nkind (Expr) = N_Aggregate then
+         Error_Msg_N ("argument of conversion cannot be aggregate", N);
+         Error_Msg_N ("\use qualified expression instead", N);
+
+      elsif Nkind (Expr) = N_Allocator then
+         Error_Msg_N ("argument of conversion cannot be an allocator", N);
+         Error_Msg_N ("\use qualified expression instead", N);
+
+      elsif Nkind (Expr) = N_String_Literal then
+         Error_Msg_N ("argument of conversion cannot be string literal", N);
+         Error_Msg_N ("\use qualified expression instead", N);
+
+      elsif Nkind (Expr) = N_Character_Literal then
+         if Ada_83 then
+            Resolve (Expr, T);
+         else
+            Error_Msg_N ("argument of conversion cannot be character literal",
+              N);
+            Error_Msg_N ("\use qualified expression instead", N);
+         end if;
+
+      elsif Nkind (Expr) = N_Attribute_Reference
+        and then
+          (Attribute_Name (Expr) = Name_Access            or else
+           Attribute_Name (Expr) = Name_Unchecked_Access  or else
+           Attribute_Name (Expr) = Name_Unrestricted_Access)
+      then
+         Error_Msg_N ("argument of conversion cannot be access", N);
+         Error_Msg_N ("\use qualified expression instead", N);
+      end if;
+
+   end Analyze_Type_Conversion;
+
+   ----------------------
+   -- Analyze_Unary_Op --
+   ----------------------
+
+   procedure Analyze_Unary_Op (N : Node_Id) is
+      R     : constant Node_Id := Right_Opnd (N);
+      Op_Id : Entity_Id := Entity (N);
+
+   begin
+      Set_Etype (N, Any_Type);
+      Candidate_Type := Empty;
+
+      Analyze_Expression (R);
+
+      if Present (Op_Id) then
+         if Ekind (Op_Id) = E_Operator then
+            Find_Unary_Types (R, Op_Id,  N);
+         else
+            Add_One_Interp (N, Op_Id, Etype (Op_Id));
+         end if;
+
+      else
+         Op_Id := Get_Name_Entity_Id (Chars (N));
+
+         while Present (Op_Id) loop
+
+            if Ekind (Op_Id) = E_Operator then
+               if No (Next_Entity (First_Entity (Op_Id))) then
+                  Find_Unary_Types (R, Op_Id,  N);
+               end if;
+
+            elsif Is_Overloadable (Op_Id) then
+               Analyze_User_Defined_Unary_Op (N, Op_Id);
+            end if;
+
+            Op_Id := Homonym (Op_Id);
+         end loop;
+      end if;
+
+      Operator_Check (N);
+   end Analyze_Unary_Op;
+
+   ----------------------------------
+   -- Analyze_Unchecked_Expression --
+   ----------------------------------
+
+   procedure Analyze_Unchecked_Expression (N : Node_Id) is
+   begin
+      Analyze (Expression (N), Suppress => All_Checks);
+      Set_Etype (N, Etype (Expression (N)));
+      Save_Interps (Expression (N), N);
+   end Analyze_Unchecked_Expression;
+
+   ---------------------------------------
+   -- Analyze_Unchecked_Type_Conversion --
+   ---------------------------------------
+
+   procedure Analyze_Unchecked_Type_Conversion (N : Node_Id) is
+   begin
+      Find_Type (Subtype_Mark (N));
+      Analyze_Expression (Expression (N));
+      Set_Etype (N, Entity (Subtype_Mark (N)));
+   end Analyze_Unchecked_Type_Conversion;
+
+   ------------------------------------
+   -- Analyze_User_Defined_Binary_Op --
+   ------------------------------------
+
+   procedure Analyze_User_Defined_Binary_Op
+     (N     : Node_Id;
+      Op_Id : Entity_Id)
+   is
+   begin
+      --  Only do analysis if the operator Comes_From_Source, since otherwise
+      --  the operator was generated by the expander, and all such operators
+      --  always refer to the operators in package Standard.
+
+      if Comes_From_Source (N) then
+         declare
+            F1 : constant Entity_Id := First_Formal (Op_Id);
+            F2 : constant Entity_Id := Next_Formal (F1);
+
+         begin
+            --  Verify that Op_Id is a visible binary function. Note that since
+            --  we know Op_Id is overloaded, potentially use visible means use
+            --  visible for sure (RM 9.4(11)).
+
+            if Ekind (Op_Id) = E_Function
+              and then Present (F2)
+              and then (Is_Immediately_Visible (Op_Id)
+                         or else Is_Potentially_Use_Visible (Op_Id))
+              and then Has_Compatible_Type (Left_Opnd (N), Etype (F1))
+              and then Has_Compatible_Type (Right_Opnd (N), Etype (F2))
+            then
+               Add_One_Interp (N, Op_Id, Etype (Op_Id));
+
+               if Debug_Flag_E then
+                  Write_Str ("user defined operator ");
+                  Write_Name (Chars (Op_Id));
+                  Write_Str (" on node ");
+                  Write_Int (Int (N));
+                  Write_Eol;
+               end if;
+            end if;
+         end;
+      end if;
+   end Analyze_User_Defined_Binary_Op;
+
+   -----------------------------------
+   -- Analyze_User_Defined_Unary_Op --
+   -----------------------------------
+
+   procedure Analyze_User_Defined_Unary_Op
+     (N     : Node_Id;
+      Op_Id : Entity_Id)
+   is
+   begin
+      --  Only do analysis if the operator Comes_From_Source, since otherwise
+      --  the operator was generated by the expander, and all such operators
+      --  always refer to the operators in package Standard.
+
+      if Comes_From_Source (N) then
+         declare
+            F : constant Entity_Id := First_Formal (Op_Id);
+
+         begin
+            --  Verify that Op_Id is a visible unary function. Note that since
+            --  we know Op_Id is overloaded, potentially use visible means use
+            --  visible for sure (RM 9.4(11)).
+
+            if Ekind (Op_Id) = E_Function
+              and then No (Next_Formal (F))
+              and then (Is_Immediately_Visible (Op_Id)
+                         or else Is_Potentially_Use_Visible (Op_Id))
+              and then Has_Compatible_Type (Right_Opnd (N), Etype (F))
+            then
+               Add_One_Interp (N, Op_Id, Etype (Op_Id));
+            end if;
+         end;
+      end if;
+   end Analyze_User_Defined_Unary_Op;
+
+   ---------------------------
+   -- Check_Arithmetic_Pair --
+   ---------------------------
+
+   procedure Check_Arithmetic_Pair
+     (T1, T2 : Entity_Id;
+      Op_Id  : Entity_Id;
+      N      : Node_Id)
+   is
+      Op_Name : constant Name_Id   := Chars (Op_Id);
+
+      function Specific_Type (T1, T2 : Entity_Id) return Entity_Id;
+      --  Get specific type (i.e. non-universal type if there is one)
+
+      function Specific_Type (T1, T2 : Entity_Id) return Entity_Id is
+      begin
+         if T1 = Universal_Integer or else T1 = Universal_Real then
+            return Base_Type (T2);
+         else
+            return Base_Type (T1);
+         end if;
+      end Specific_Type;
+
+   --  Start of processing for Check_Arithmetic_Pair
+
+   begin
+      if Op_Name = Name_Op_Add or else Op_Name = Name_Op_Subtract then
+
+         if Is_Numeric_Type (T1)
+           and then Is_Numeric_Type (T2)
+           and then (Covers (T1, T2) or else Covers (T2, T1))
+         then
+            Add_One_Interp (N, Op_Id, Specific_Type (T1, T2));
+         end if;
+
+      elsif Op_Name = Name_Op_Multiply or else Op_Name = Name_Op_Divide then
+
+         if Is_Fixed_Point_Type (T1)
+           and then (Is_Fixed_Point_Type (T2)
+                       or else T2 = Universal_Real)
+         then
+            --  If Treat_Fixed_As_Integer is set then the Etype is already set
+            --  and no further processing is required (this is the case of an
+            --  operator constructed by Exp_Fixd for a fixed point operation)
+            --  Otherwise add one interpretation with universal fixed result
+            --  If the operator is given in  functional notation, it comes
+            --  from source and Fixed_As_Integer cannot apply.
+
+            if Nkind (N) not in N_Op
+              or else not Treat_Fixed_As_Integer (N) then
+               Add_One_Interp (N, Op_Id, Universal_Fixed);
+            end if;
+
+         elsif Is_Fixed_Point_Type (T2)
+           and then (Nkind (N) not in N_Op
+                      or else not Treat_Fixed_As_Integer (N))
+           and then T1 = Universal_Real
+         then
+            Add_One_Interp (N, Op_Id, Universal_Fixed);
+
+         elsif Is_Numeric_Type (T1)
+           and then Is_Numeric_Type (T2)
+           and then (Covers (T1, T2) or else Covers (T2, T1))
+         then
+            Add_One_Interp (N, Op_Id, Specific_Type (T1, T2));
+
+         elsif Is_Fixed_Point_Type (T1)
+           and then (Base_Type (T2) = Base_Type (Standard_Integer)
+                       or else T2 = Universal_Integer)
+         then
+            Add_One_Interp (N, Op_Id, T1);
+
+         elsif T2 = Universal_Real
+           and then Base_Type (T1) = Base_Type (Standard_Integer)
+           and then Op_Name = Name_Op_Multiply
+         then
+            Add_One_Interp (N, Op_Id, Any_Fixed);
+
+         elsif T1 = Universal_Real
+           and then Base_Type (T2) = Base_Type (Standard_Integer)
+         then
+            Add_One_Interp (N, Op_Id, Any_Fixed);
+
+         elsif Is_Fixed_Point_Type (T2)
+           and then (Base_Type (T1) = Base_Type (Standard_Integer)
+                       or else T1 = Universal_Integer)
+           and then Op_Name = Name_Op_Multiply
+         then
+            Add_One_Interp (N, Op_Id, T2);
+
+         elsif T1 = Universal_Real and then T2 = Universal_Integer then
+            Add_One_Interp (N, Op_Id, T1);
+
+         elsif T2 = Universal_Real
+           and then T1 = Universal_Integer
+           and then Op_Name = Name_Op_Multiply
+         then
+            Add_One_Interp (N, Op_Id, T2);
+         end if;
+
+      elsif Op_Name = Name_Op_Mod or else Op_Name = Name_Op_Rem then
+
+         --  Note: The fixed-point operands case with Treat_Fixed_As_Integer
+         --  set does not require any special processing, since the Etype is
+         --  already set (case of operation constructed by Exp_Fixed).
+
+         if Is_Integer_Type (T1)
+           and then (Covers (T1, T2) or else Covers (T2, T1))
+         then
+            Add_One_Interp (N, Op_Id, Specific_Type (T1, T2));
+         end if;
+
+      elsif Op_Name = Name_Op_Expon then
+
+         if Is_Numeric_Type (T1)
+           and then not Is_Fixed_Point_Type (T1)
+           and then (Base_Type (T2) = Base_Type (Standard_Integer)
+                      or else T2 = Universal_Integer)
+         then
+            Add_One_Interp (N, Op_Id, Base_Type (T1));
+         end if;
+
+      else pragma Assert (Nkind (N) in N_Op_Shift);
+
+         --  If not one of the predefined operators, the node may be one
+         --  of the intrinsic functions. Its kind is always specific, and
+         --  we can use it directly, rather than the name of the operation.
+
+         if Is_Integer_Type (T1)
+           and then (Base_Type (T2) = Base_Type (Standard_Integer)
+                      or else T2 = Universal_Integer)
+         then
+            Add_One_Interp (N, Op_Id, Base_Type (T1));
+         end if;
+      end if;
+   end Check_Arithmetic_Pair;
+
+   -------------------------------
+   -- Check_Misspelled_Selector --
+   -------------------------------
+
+   procedure Check_Misspelled_Selector
+     (Prefix : Entity_Id;
+      Sel    : Node_Id)
+   is
+      Max_Suggestions   : constant := 2;
+      Nr_Of_Suggestions : Natural := 0;
+
+      Suggestion_1 : Entity_Id := Empty;
+      Suggestion_2 : Entity_Id := Empty;
+
+      Comp : Entity_Id;
+
+   begin
+      --  All the components of the prefix of selector Sel are matched
+      --  against  Sel and a count is maintained of possible misspellings.
+      --  When at the end of the analysis there are one or two (not more!)
+      --  possible misspellings, these misspellings will be suggested as
+      --  possible correction.
+
+      if not (Is_Private_Type (Prefix) or Is_Record_Type (Prefix)) then
+         --  Concurrent types should be handled as well ???
+         return;
+      end if;
+
+      Get_Name_String (Chars (Sel));
+
+      declare
+         S  : constant String (1 .. Name_Len) :=
+                Name_Buffer (1 .. Name_Len);
+
+      begin
+         Comp  := First_Entity (Prefix);
+
+         while Nr_Of_Suggestions <= Max_Suggestions
+            and then Present (Comp)
+         loop
+
+            if Is_Visible_Component (Comp) then
+               Get_Name_String (Chars (Comp));
+
+               if Is_Bad_Spelling_Of (Name_Buffer (1 .. Name_Len), S) then
+                  Nr_Of_Suggestions := Nr_Of_Suggestions + 1;
+
+                  case Nr_Of_Suggestions is
+                     when 1      => Suggestion_1 := Comp;
+                     when 2      => Suggestion_2 := Comp;
+                     when others => exit;
+                  end case;
+               end if;
+            end if;
+
+            Comp := Next_Entity (Comp);
+         end loop;
+
+         --  Report at most two suggestions
+
+         if Nr_Of_Suggestions = 1 then
+            Error_Msg_NE ("\possible misspelling of&", Sel, Suggestion_1);
+
+         elsif Nr_Of_Suggestions = 2 then
+            Error_Msg_Node_2 := Suggestion_2;
+            Error_Msg_NE ("\possible misspelling of& or&",
+              Sel, Suggestion_1);
+         end if;
+      end;
+   end Check_Misspelled_Selector;
+
+   ----------------------
+   -- Defined_In_Scope --
+   ----------------------
+
+   function Defined_In_Scope (T : Entity_Id; S : Entity_Id) return Boolean
+   is
+      S1 : constant Entity_Id := Scope (Base_Type (T));
+
+   begin
+      return S1 = S
+        or else (S1 = System_Aux_Id and then S = Scope (S1));
+   end Defined_In_Scope;
+
+   -------------------
+   -- Diagnose_Call --
+   -------------------
+
+   procedure Diagnose_Call (N : Node_Id; Nam : Node_Id) is
+      Actual  : Node_Id;
+      X       : Interp_Index;
+      It      : Interp;
+      Success : Boolean;
+
+   begin
+      if Extensions_Allowed then
+         Actual := First_Actual (N);
+
+         while Present (Actual) loop
+            if not Analyzed (Etype (Actual))
+             and then From_With_Type (Etype (Actual))
+            then
+               Error_Msg_Qual_Level := 1;
+               Error_Msg_NE
+                ("missing with_clause for scope of imported type&",
+                  Actual, Etype (Actual));
+               Error_Msg_Qual_Level := 0;
+            end if;
+
+            Next_Actual (Actual);
+         end loop;
+      end if;
+
+      if All_Errors_Mode then
+
+         --   Analyze each candidate call again, with full error reporting
+         --   for each.
+
+         Error_Msg_N ("\no candidate interpretations "
+           & "match the actuals:!", Nam);
+
+         Get_First_Interp (Nam, X, It);
+
+         while Present (It.Nam) loop
+            Analyze_One_Call (N, It.Nam, True, Success);
+            Get_Next_Interp (X, It);
+         end loop;
+
+      else
+         if OpenVMS then
+            Error_Msg_N
+              ("invalid parameter list in call " &
+               "('/'R'E'P'O'R'T'_'E'R'R'O'R'S'='F'U'L'L for details)!",
+                Nam);
+         else
+            Error_Msg_N
+              ("invalid parameter list in call (use -gnatf for details)!",
+                Nam);
+         end if;
+      end if;
+
+      if Nkind (N) = N_Function_Call then
+         Get_First_Interp (Nam, X, It);
+
+         while Present (It.Nam) loop
+            if Ekind (It.Nam) = E_Function
+              or else Ekind (It.Nam) = E_Operator
+            then
+               return;
+            else
+               Get_Next_Interp (X, It);
+            end if;
+         end loop;
+
+         --  If all interpretations are procedures, this deserves a
+         --  more precise message. Ditto if this appears as the prefix
+         --  of a selected component, which may be a lexical error.
+
+         Error_Msg_N (
+         "\context requires function call, found procedure name", Nam);
+
+         if Nkind (Parent (N)) = N_Selected_Component
+           and then N = Prefix (Parent (N))
+         then
+            Error_Msg_N (
+              "\period should probably be semicolon", Parent (N));
+         end if;
+      end if;
+   end Diagnose_Call;
+
+   ---------------------------
+   -- Find_Arithmetic_Types --
+   ---------------------------
+
+   procedure Find_Arithmetic_Types
+     (L, R  : Node_Id;
+      Op_Id : Entity_Id;
+      N     : Node_Id)
+   is
+      Index1, Index2 : Interp_Index;
+      It1, It2 : Interp;
+
+      procedure Check_Right_Argument (T : Entity_Id);
+      --  Check right operand of operator
+
+      procedure Check_Right_Argument (T : Entity_Id) is
+      begin
+         if not Is_Overloaded (R) then
+            Check_Arithmetic_Pair (T, Etype (R), Op_Id,  N);
+         else
+            Get_First_Interp (R, Index2, It2);
+
+            while Present (It2.Typ) loop
+               Check_Arithmetic_Pair (T, It2.Typ, Op_Id, N);
+               Get_Next_Interp (Index2, It2);
+            end loop;
+         end if;
+      end Check_Right_Argument;
+
+   --  Start processing for Find_Arithmetic_Types
+
+   begin
+      if not Is_Overloaded (L) then
+         Check_Right_Argument (Etype (L));
+
+      else
+         Get_First_Interp (L, Index1, It1);
+
+         while Present (It1.Typ) loop
+            Check_Right_Argument (It1.Typ);
+            Get_Next_Interp (Index1, It1);
+         end loop;
+      end if;
+
+   end Find_Arithmetic_Types;
+
+   ------------------------
+   -- Find_Boolean_Types --
+   ------------------------
+
+   procedure Find_Boolean_Types
+     (L, R  : Node_Id;
+      Op_Id : Entity_Id;
+      N     : Node_Id)
+   is
+      Index : Interp_Index;
+      It    : Interp;
+
+      procedure Check_Numeric_Argument (T : Entity_Id);
+      --  Special case for logical operations one of whose operands is an
+      --  integer literal. If both are literal the result is any modular type.
+
+      procedure Check_Numeric_Argument (T : Entity_Id) is
+      begin
+         if T = Universal_Integer then
+            Add_One_Interp (N, Op_Id, Any_Modular);
+
+         elsif Is_Modular_Integer_Type (T) then
+            Add_One_Interp (N, Op_Id, T);
+         end if;
+      end Check_Numeric_Argument;
+
+   --  Start of processing for Find_Boolean_Types
+
+   begin
+      if not Is_Overloaded (L) then
+
+         if Etype (L) = Universal_Integer
+           or else Etype (L) = Any_Modular
+         then
+            if not Is_Overloaded (R) then
+               Check_Numeric_Argument (Etype (R));
+
+            else
+               Get_First_Interp (R, Index, It);
+
+               while Present (It.Typ) loop
+                  Check_Numeric_Argument (It.Typ);
+
+                  Get_Next_Interp (Index, It);
+               end loop;
+            end if;
+
+         elsif Valid_Boolean_Arg (Etype (L))
+           and then Has_Compatible_Type (R, Etype (L))
+         then
+            Add_One_Interp (N, Op_Id, Etype (L));
+         end if;
+
+      else
+         Get_First_Interp (L, Index, It);
+
+         while Present (It.Typ) loop
+            if Valid_Boolean_Arg (It.Typ)
+              and then Has_Compatible_Type (R, It.Typ)
+            then
+               Add_One_Interp (N, Op_Id, It.Typ);
+            end if;
+
+            Get_Next_Interp (Index, It);
+         end loop;
+      end if;
+   end Find_Boolean_Types;
+
+   ---------------------------
+   -- Find_Comparison_Types --
+   ---------------------------
+
+   procedure Find_Comparison_Types
+     (L, R  : Node_Id;
+      Op_Id : Entity_Id;
+      N     : Node_Id)
+   is
+      Index : Interp_Index;
+      It    : Interp;
+      Found : Boolean := False;
+      I_F   : Interp_Index;
+      T_F   : Entity_Id;
+      Scop  : Entity_Id := Empty;
+
+      procedure Try_One_Interp (T1 : Entity_Id);
+      --  Routine to try one proposed interpretation. Note that the context
+      --  of the operator plays no role in resolving the arguments, so that
+      --  if there is more than one interpretation of the operands that is
+      --  compatible with comparison, the operation is ambiguous.
+
+      procedure Try_One_Interp (T1 : Entity_Id) is
+      begin
+
+         --  If the operator is an expanded name, then the type of the operand
+         --  must be defined in the corresponding scope. If the type is
+         --  universal, the context will impose the correct type.
+
+         if Present (Scop)
+            and then not Defined_In_Scope (T1, Scop)
+            and then T1 /= Universal_Integer
+            and then T1 /= Universal_Real
+            and then T1 /= Any_String
+            and then T1 /= Any_Composite
+         then
+            return;
+         end if;
+
+         if Valid_Comparison_Arg (T1)
+           and then Has_Compatible_Type (R, T1)
+         then
+            if Found
+              and then Base_Type (T1) /= Base_Type (T_F)
+            then
+               It := Disambiguate (L, I_F, Index, Any_Type);
+
+               if It = No_Interp then
+                  Ambiguous_Operands (N);
+                  Set_Etype (L, Any_Type);
+                  return;
+
+               else
+                  T_F := It.Typ;
+               end if;
+
+            else
+               Found := True;
+               T_F   := T1;
+               I_F   := Index;
+            end if;
+
+            Set_Etype (L, T_F);
+            Find_Non_Universal_Interpretations (N, R, Op_Id, T1);
+
+         end if;
+      end Try_One_Interp;
+
+   --  Start processing for Find_Comparison_Types
+
+   begin
+
+      if Nkind (N) = N_Function_Call
+         and then Nkind (Name (N)) = N_Expanded_Name
+      then
+         Scop := Entity (Prefix (Name (N)));
+
+         --  The prefix may be a package renaming, and the subsequent test
+         --  requires the original package.
+
+         if Ekind (Scop) = E_Package
+           and then Present (Renamed_Entity (Scop))
+         then
+            Scop := Renamed_Entity (Scop);
+            Set_Entity (Prefix (Name (N)), Scop);
+         end if;
+      end if;
+
+      if not Is_Overloaded (L) then
+         Try_One_Interp (Etype (L));
+
+      else
+         Get_First_Interp (L, Index, It);
+
+         while Present (It.Typ) loop
+            Try_One_Interp (It.Typ);
+            Get_Next_Interp (Index, It);
+         end loop;
+      end if;
+   end Find_Comparison_Types;
+
+   ----------------------------------------
+   -- Find_Non_Universal_Interpretations --
+   ----------------------------------------
+
+   procedure Find_Non_Universal_Interpretations
+     (N     : Node_Id;
+      R     : Node_Id;
+      Op_Id : Entity_Id;
+      T1    : Entity_Id)
+   is
+      Index : Interp_Index;
+      It   : Interp;
+
+   begin
+      if T1 = Universal_Integer
+        or else T1 = Universal_Real
+      then
+         if not Is_Overloaded (R) then
+            Add_One_Interp
+              (N, Op_Id, Standard_Boolean, Base_Type (Etype (R)));
+         else
+            Get_First_Interp (R, Index, It);
+
+            while Present (It.Typ) loop
+               if Covers (It.Typ, T1) then
+                  Add_One_Interp
+                    (N, Op_Id, Standard_Boolean, Base_Type (It.Typ));
+               end if;
+
+               Get_Next_Interp (Index, It);
+            end loop;
+         end if;
+      else
+         Add_One_Interp (N, Op_Id, Standard_Boolean, Base_Type (T1));
+      end if;
+   end Find_Non_Universal_Interpretations;
+
+   ------------------------------
+   -- Find_Concatenation_Types --
+   ------------------------------
+
+   procedure Find_Concatenation_Types
+     (L, R  : Node_Id;
+      Op_Id : Entity_Id;
+      N     : Node_Id)
+   is
+      Op_Type : constant Entity_Id := Etype (Op_Id);
+
+   begin
+      if Is_Array_Type (Op_Type)
+        and then not Is_Limited_Type (Op_Type)
+
+        and then (Has_Compatible_Type (L, Op_Type)
+                    or else
+                  Has_Compatible_Type (L, Component_Type (Op_Type)))
+
+        and then (Has_Compatible_Type (R, Op_Type)
+                    or else
+                  Has_Compatible_Type (R, Component_Type (Op_Type)))
+      then
+         Add_One_Interp (N, Op_Id, Op_Type);
+      end if;
+   end Find_Concatenation_Types;
+
+   -------------------------
+   -- Find_Equality_Types --
+   -------------------------
+
+   procedure Find_Equality_Types
+     (L, R  : Node_Id;
+      Op_Id : Entity_Id;
+      N     : Node_Id)
+   is
+      Index : Interp_Index;
+      It    : Interp;
+      Found : Boolean := False;
+      I_F   : Interp_Index;
+      T_F   : Entity_Id;
+      Scop  : Entity_Id := Empty;
+
+      procedure Try_One_Interp (T1 : Entity_Id);
+      --  The context of the operator plays no role in resolving the
+      --  arguments,  so that if there is more than one interpretation
+      --  of the operands that is compatible with equality, the construct
+      --  is ambiguous and an error can be emitted now, after trying to
+      --  disambiguate, i.e. applying preference rules.
+
+      procedure Try_One_Interp (T1 : Entity_Id) is
+      begin
+
+         --  If the operator is an expanded name, then the type of the operand
+         --  must be defined in the corresponding scope. If the type is
+         --  universal, the context will impose the correct type. An anonymous
+         --  type for a 'Access reference is also universal in this sense, as
+         --  the actual type is obtained from context.
+
+         if Present (Scop)
+            and then not Defined_In_Scope (T1, Scop)
+            and then T1 /= Universal_Integer
+            and then T1 /= Universal_Real
+            and then T1 /= Any_Access
+            and then T1 /= Any_String
+            and then T1 /= Any_Composite
+            and then (Ekind (T1) /= E_Access_Subprogram_Type
+                        or else Comes_From_Source (T1))
+         then
+            return;
+         end if;
+
+         if T1 /= Standard_Void_Type
+           and then not Is_Limited_Type (T1)
+           and then not Is_Limited_Composite (T1)
+           and then Ekind (T1) /= E_Anonymous_Access_Type
+           and then Has_Compatible_Type (R, T1)
+         then
+            if Found
+              and then Base_Type (T1) /= Base_Type (T_F)
+            then
+               It := Disambiguate (L, I_F, Index, Any_Type);
+
+               if It = No_Interp then
+                  Ambiguous_Operands (N);
+                  Set_Etype (L, Any_Type);
+                  return;
+
+               else
+                  T_F := It.Typ;
+               end if;
+
+            else
+               Found := True;
+               T_F   := T1;
+               I_F   := Index;
+            end if;
+
+            if not Analyzed (L) then
+               Set_Etype (L, T_F);
+            end if;
+
+            Find_Non_Universal_Interpretations (N, R, Op_Id, T1);
+
+            if Etype (N) = Any_Type then
+
+               --  Operator was not visible.
+
+               Found := False;
+            end if;
+         end if;
+      end Try_One_Interp;
+
+   --  Start of processing for Find_Equality_Types
+
+   begin
+
+      if Nkind (N) = N_Function_Call
+         and then Nkind (Name (N)) = N_Expanded_Name
+      then
+         Scop := Entity (Prefix (Name (N)));
+
+         --  The prefix may be a package renaming, and the subsequent test
+         --  requires the original package.
+
+         if Ekind (Scop) = E_Package
+           and then Present (Renamed_Entity (Scop))
+         then
+            Scop := Renamed_Entity (Scop);
+            Set_Entity (Prefix (Name (N)), Scop);
+         end if;
+      end if;
+
+      if not Is_Overloaded (L) then
+         Try_One_Interp (Etype (L));
+      else
+
+         Get_First_Interp (L, Index, It);
+
+         while Present (It.Typ) loop
+            Try_One_Interp (It.Typ);
+            Get_Next_Interp (Index, It);
+         end loop;
+      end if;
+   end Find_Equality_Types;
+
+   -------------------------
+   -- Find_Negation_Types --
+   -------------------------
+
+   procedure Find_Negation_Types
+     (R     : Node_Id;
+      Op_Id : Entity_Id;
+      N     : Node_Id)
+   is
+      Index : Interp_Index;
+      It    : Interp;
+
+   begin
+      if not Is_Overloaded (R) then
+
+         if Etype (R) = Universal_Integer then
+            Add_One_Interp (N, Op_Id, Any_Modular);
+
+         elsif Valid_Boolean_Arg (Etype (R)) then
+            Add_One_Interp (N, Op_Id, Etype (R));
+         end if;
+
+      else
+         Get_First_Interp (R, Index, It);
+
+         while Present (It.Typ) loop
+            if Valid_Boolean_Arg (It.Typ) then
+               Add_One_Interp (N, Op_Id, It.Typ);
+            end if;
+
+            Get_Next_Interp (Index, It);
+         end loop;
+      end if;
+   end Find_Negation_Types;
+
+   ----------------------
+   -- Find_Unary_Types --
+   ----------------------
+
+   procedure Find_Unary_Types
+     (R     : Node_Id;
+      Op_Id : Entity_Id;
+      N     : Node_Id)
+   is
+      Index : Interp_Index;
+      It    : Interp;
+
+   begin
+      if not Is_Overloaded (R) then
+         if Is_Numeric_Type (Etype (R)) then
+            Add_One_Interp (N, Op_Id, Base_Type (Etype (R)));
+         end if;
+
+      else
+         Get_First_Interp (R, Index, It);
+
+         while Present (It.Typ) loop
+            if Is_Numeric_Type (It.Typ) then
+               Add_One_Interp (N, Op_Id, Base_Type (It.Typ));
+            end if;
+
+            Get_Next_Interp (Index, It);
+         end loop;
+      end if;
+   end Find_Unary_Types;
+
+   ---------------------------------
+   -- Insert_Explicit_Dereference --
+   ---------------------------------
+
+   procedure Insert_Explicit_Dereference (N : Node_Id) is
+      New_Prefix : Node_Id := Relocate_Node (N);
+      I          : Interp_Index;
+      It         : Interp;
+      T          : Entity_Id;
+
+   begin
+      Save_Interps (N, New_Prefix);
+      Rewrite (N,
+        Make_Explicit_Dereference (Sloc (N), Prefix => New_Prefix));
+
+      Set_Etype (N, Designated_Type (Etype (New_Prefix)));
+
+      if Is_Overloaded (New_Prefix) then
+
+         --  The deference is also overloaded, and its interpretations are the
+         --  designated types of the interpretations of the original node.
+
+         Set_Is_Overloaded (N);
+         Get_First_Interp (New_Prefix, I, It);
+
+         while Present (It.Nam) loop
+            T := It.Typ;
+
+            if Is_Access_Type (T) then
+               Add_One_Interp (N, Designated_Type (T), Designated_Type (T));
+            end if;
+
+            Get_Next_Interp (I, It);
+         end loop;
+
+         End_Interp_List;
+      end if;
+
+   end Insert_Explicit_Dereference;
+
+   ------------------
+   -- Junk_Operand --
+   ------------------
+
+   function Junk_Operand (N : Node_Id) return Boolean is
+      Enode : Node_Id;
+
+   begin
+      if Error_Posted (N) then
+         return False;
+      end if;
+
+      --  Get entity to be tested
+
+      if Is_Entity_Name (N)
+        and then Present (Entity (N))
+      then
+         Enode := N;
+
+      --  An odd case, a procedure name gets converted to a very peculiar
+      --  function call, and here is where we detect this happening.
+
+      elsif Nkind (N) = N_Function_Call
+        and then Is_Entity_Name (Name (N))
+        and then Present (Entity (Name (N)))
+      then
+         Enode := Name (N);
+
+      --  Another odd case, there are at least some cases of selected
+      --  components where the selected component is not marked as having
+      --  an entity, even though the selector does have an entity
+
+      elsif Nkind (N) = N_Selected_Component
+        and then Present (Entity (Selector_Name (N)))
+      then
+         Enode := Selector_Name (N);
+
+      else
+         return False;
+      end if;
+
+      --  Now test the entity we got to see if it a bad case
+
+      case Ekind (Entity (Enode)) is
+
+         when E_Package =>
+            Error_Msg_N
+              ("package name cannot be used as operand", Enode);
+
+         when Generic_Unit_Kind =>
+            Error_Msg_N
+              ("generic unit name cannot be used as operand", Enode);
+
+         when Type_Kind =>
+            Error_Msg_N
+              ("subtype name cannot be used as operand", Enode);
+
+         when Entry_Kind =>
+            Error_Msg_N
+              ("entry name cannot be used as operand", Enode);
+
+         when E_Procedure =>
+            Error_Msg_N
+              ("procedure name cannot be used as operand", Enode);
+
+         when E_Exception =>
+            Error_Msg_N
+              ("exception name cannot be used as operand", Enode);
+
+         when E_Block | E_Label | E_Loop =>
+            Error_Msg_N
+              ("label name cannot be used as operand", Enode);
+
+         when others =>
+            return False;
+
+      end case;
+
+      return True;
+   end Junk_Operand;
+
+   --------------------
+   -- Operator_Check --
+   --------------------
+
+   procedure Operator_Check (N : Node_Id) is
+   begin
+      --  Test for case of no interpretation found for operator
+
+      if Etype (N) = Any_Type then
+         declare
+            L : Node_Id;
+            R : Node_Id;
+
+         begin
+            R := Right_Opnd (N);
+
+            if Nkind (N) in N_Binary_Op then
+               L := Left_Opnd (N);
+            else
+               L := Empty;
+            end if;
+
+            --  If either operand has no type, then don't complain further,
+            --  since this simply means that we have a propragated error.
+
+            if R = Error
+              or else Etype (R) = Any_Type
+              or else (Nkind (N) in N_Binary_Op and then Etype (L) = Any_Type)
+            then
+               return;
+
+            --  We explicitly check for the case of concatenation of
+            --  component with component to avoid reporting spurious
+            --  matching array types that might happen to be lurking
+            --  in distant packages (such as run-time packages). This
+            --  also prevents inconsistencies in the messages for certain
+            --  ACVC B tests, which can vary depending on types declared
+            --  in run-time interfaces. A further improvement, when
+            --  aggregates are present, is to look for a well-typed operand.
+
+            elsif Present (Candidate_Type)
+              and then (Nkind (N) /= N_Op_Concat
+                         or else Is_Array_Type (Etype (L))
+                         or else Is_Array_Type (Etype (R)))
+            then
+
+               if Nkind (N) = N_Op_Concat then
+                  if Etype (L) /= Any_Composite
+                    and then Is_Array_Type (Etype (L))
+                  then
+                     Candidate_Type := Etype (L);
+
+                  elsif Etype (R) /= Any_Composite
+                    and then Is_Array_Type (Etype (R))
+                  then
+                     Candidate_Type := Etype (R);
+                  end if;
+               end if;
+
+               Error_Msg_NE
+                 ("operator for} is not directly visible!",
+                  N, First_Subtype (Candidate_Type));
+               Error_Msg_N ("use clause would make operation legal!",  N);
+               return;
+
+            --  If either operand is a junk operand (e.g. package name), then
+            --  post appropriate error messages, but do not complain further.
+
+            --  Note that the use of OR in this test instead of OR ELSE
+            --  is quite deliberate, we may as well check both operands
+            --  in the binary operator case.
+
+            elsif Junk_Operand (R)
+              or (Nkind (N) in N_Binary_Op and then Junk_Operand (L))
+            then
+               return;
+
+            --  If we have a logical operator, one of whose operands is
+            --  Boolean, then we know that the other operand cannot resolve
+            --  to Boolean (since we got no interpretations), but in that
+            --  case we pretty much know that the other operand should be
+            --  Boolean, so resolve it that way (generating an error)
+
+            elsif Nkind (N) = N_Op_And
+                    or else
+                  Nkind (N) = N_Op_Or
+                    or else
+                  Nkind (N) = N_Op_Xor
+            then
+               if Etype (L) = Standard_Boolean then
+                  Resolve (R, Standard_Boolean);
+                  return;
+               elsif Etype (R) = Standard_Boolean then
+                  Resolve (L, Standard_Boolean);
+                  return;
+               end if;
+
+            --  For an arithmetic operator or comparison operator, if one
+            --  of the operands is numeric, then we know the other operand
+            --  is not the same numeric type. If it is a non-numeric type,
+            --  then probably it is intended to match the other operand.
+
+            elsif Nkind (N) = N_Op_Add      or else
+                  Nkind (N) = N_Op_Divide   or else
+                  Nkind (N) = N_Op_Ge       or else
+                  Nkind (N) = N_Op_Gt       or else
+                  Nkind (N) = N_Op_Le       or else
+                  Nkind (N) = N_Op_Lt       or else
+                  Nkind (N) = N_Op_Mod      or else
+                  Nkind (N) = N_Op_Multiply or else
+                  Nkind (N) = N_Op_Rem      or else
+                  Nkind (N) = N_Op_Subtract
+            then
+               if Is_Numeric_Type (Etype (L))
+                 and then not Is_Numeric_Type (Etype (R))
+               then
+                  Resolve (R, Etype (L));
+                  return;
+
+               elsif Is_Numeric_Type (Etype (R))
+                 and then not Is_Numeric_Type (Etype (L))
+               then
+                  Resolve (L, Etype (R));
+                  return;
+               end if;
+
+            --  Comparisons on A'Access are common enough to deserve a
+            --  special message.
+
+            elsif (Nkind (N) = N_Op_Eq  or else
+                   Nkind (N) = N_Op_Ne)
+               and then Ekind (Etype (L)) = E_Access_Attribute_Type
+               and then Ekind (Etype (R)) = E_Access_Attribute_Type
+            then
+               Error_Msg_N
+                 ("two access attributes cannot be compared directly", N);
+               Error_Msg_N
+                 ("\they must be converted to an explicit type for comparison",
+                   N);
+               return;
+
+            --  Another one for C programmers
+
+            elsif Nkind (N) = N_Op_Concat
+              and then Valid_Boolean_Arg (Etype (L))
+              and then Valid_Boolean_Arg (Etype (R))
+            then
+               Error_Msg_N ("invalid operands for concatenation", N);
+               Error_Msg_N ("\maybe AND was meant", N);
+               return;
+
+            --  A special case for comparison of access parameter with null
+
+            elsif Nkind (N) = N_Op_Eq
+              and then Is_Entity_Name (L)
+              and then Nkind (Parent (Entity (L))) = N_Parameter_Specification
+              and then Nkind (Parameter_Type (Parent (Entity (L)))) =
+                                                  N_Access_Definition
+              and then Nkind (R) = N_Null
+            then
+               Error_Msg_N ("access parameter is not allowed to be null", L);
+               Error_Msg_N ("\(call would raise Constraint_Error)", L);
+               return;
+            end if;
+
+            --  If we fall through then just give general message. Note
+            --  that in the following messages, if the operand is overloaded
+            --  we choose an arbitrary type to complain about, but that is
+            --  probably more useful than not giving a type at all.
+
+            if Nkind (N) in N_Unary_Op then
+               Error_Msg_Node_2 := Etype (R);
+               Error_Msg_N ("operator& not defined for}", N);
+               return;
+
+            else
+               Error_Msg_N ("invalid operand types for operator&", N);
+
+               if Nkind (N) in N_Binary_Op
+                 and then Nkind (N) /= N_Op_Concat
+               then
+                  Error_Msg_NE ("\left operand has}!",  N, Etype (L));
+                  Error_Msg_NE ("\right operand has}!", N, Etype (R));
+               end if;
+            end if;
+         end;
+      end if;
+   end Operator_Check;
+
+   -----------------------
+   -- Try_Indirect_Call --
+   -----------------------
+
+   function Try_Indirect_Call
+     (N      : Node_Id;
+      Nam    : Entity_Id;
+      Typ    : Entity_Id)
+      return   Boolean
+   is
+      Actuals    : List_Id   := Parameter_Associations (N);
+      Actual     : Node_Id   := First (Actuals);
+      Formal     : Entity_Id := First_Formal (Designated_Type (Typ));
+
+   begin
+      while Present (Actual)
+        and then Present (Formal)
+      loop
+         if not Has_Compatible_Type (Actual, Etype (Formal)) then
+            return False;
+         end if;
+
+         Next (Actual);
+         Next_Formal (Formal);
+      end loop;
+
+      if No (Actual) and then No (Formal) then
+         Add_One_Interp (N, Nam, Etype (Designated_Type (Typ)));
+
+         --  Nam is a candidate interpretation for the name in the call,
+         --  if it is not an indirect call.
+
+         if not Is_Type (Nam)
+            and then Is_Entity_Name (Name (N))
+         then
+            Set_Entity (Name (N), Nam);
+         end if;
+
+         return True;
+      else
+         return False;
+      end if;
+   end Try_Indirect_Call;
+
+   ----------------------
+   -- Try_Indexed_Call --
+   ----------------------
+
+   function Try_Indexed_Call
+     (N      : Node_Id;
+      Nam    : Entity_Id;
+      Typ    : Entity_Id)
+      return   Boolean
+   is
+      Actuals    : List_Id   := Parameter_Associations (N);
+      Actual     : Node_Id   := First (Actuals);
+      Index      : Entity_Id := First_Index (Typ);
+
+   begin
+      while Present (Actual)
+        and then Present (Index)
+      loop
+         --  If the parameter list has a named association, the expression
+         --  is definitely a call and not an indexed component.
+
+         if Nkind (Actual) = N_Parameter_Association then
+            return False;
+         end if;
+
+         if not Has_Compatible_Type (Actual, Etype (Index)) then
+            return False;
+         end if;
+
+         Next (Actual);
+         Next_Index (Index);
+      end loop;
+
+      if No (Actual) and then No (Index) then
+         Add_One_Interp (N, Nam, Component_Type (Typ));
+
+         --  Nam is a candidate interpretation for the name in the call,
+         --  if it is not an indirect call.
+
+         if not Is_Type (Nam)
+            and then Is_Entity_Name (Name (N))
+         then
+            Set_Entity (Name (N), Nam);
+         end if;
+
+         return True;
+      else
+         return False;
+      end if;
+
+   end Try_Indexed_Call;
+
+end Sem_Ch4;
diff --git a/gcc/ada/sem_ch4.ads b/gcc/ada/sem_ch4.ads
new file mode 100644
index 00000000000..236785facc8
--- /dev/null
+++ b/gcc/ada/sem_ch4.ads
@@ -0,0 +1,66 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              S E M _ C H 4                               --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.18 $                             --
+--                                                                          --
+--   Copyright (C) 1992,1993,1994,1995,1996 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 Sem_Ch4  is
+   procedure Analyze_Aggregate                          (N : Node_Id);
+   procedure Analyze_Allocator                          (N : Node_Id);
+   procedure Analyze_Arithmetic_Op                      (N : Node_Id);
+   procedure Analyze_Call                               (N : Node_Id);
+   procedure Analyze_Comparison_Op                      (N : Node_Id);
+   procedure Analyze_Concatenation                      (N : Node_Id);
+   procedure Analyze_Conditional_Expression             (N : Node_Id);
+   procedure Analyze_Equality_Op                        (N : Node_Id);
+   procedure Analyze_Explicit_Dereference               (N : Node_Id);
+   procedure Analyze_Logical_Op                         (N : Node_Id);
+   procedure Analyze_Membership_Op                      (N : Node_Id);
+   procedure Analyze_Negation                           (N : Node_Id);
+   procedure Analyze_Null                               (N : Node_Id);
+   procedure Analyze_Qualified_Expression               (N : Node_Id);
+   procedure Analyze_Range                              (N : Node_Id);
+   procedure Analyze_Reference                          (N : Node_Id);
+   procedure Analyze_Selected_Component                 (N : Node_Id);
+   procedure Analyze_Short_Circuit                      (N : Node_Id);
+   procedure Analyze_Slice                              (N : Node_Id);
+   procedure Analyze_Type_Conversion                    (N : Node_Id);
+   procedure Analyze_Unary_Op                           (N : Node_Id);
+   procedure Analyze_Unchecked_Expression               (N : Node_Id);
+   procedure Analyze_Unchecked_Type_Conversion          (N : Node_Id);
+
+   procedure Analyze_Indexed_Component_Form (N : Node_Id);
+   --  Prior to semantic analysis, an indexed component node can denote any
+   --  of the following syntactic constructs:
+   --    a) An indexed component of an array
+   --    b) A function call
+   --    c) A conversion
+   --    d) A slice
+   --  The resolution of the construct requires some semantic information
+   --  on the prefix and the indices.
+
+end Sem_Ch4;
diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb
new file mode 100644
index 00000000000..658a685ced7
--- /dev/null
+++ b/gcc/ada/sem_ch5.adb
@@ -0,0 +1,1256 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              S E M _ C H 5                               --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.262 $
+--                                                                          --
+--          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 Checks;   use Checks;
+with Einfo;    use Einfo;
+with Errout;   use Errout;
+with Expander; use Expander;
+with Exp_Util; use Exp_Util;
+with Freeze;   use Freeze;
+with Lib.Xref; use Lib.Xref;
+with Nlists;   use Nlists;
+with Opt;      use Opt;
+with Sem;      use Sem;
+with Sem_Case; use Sem_Case;
+with Sem_Ch3;  use Sem_Ch3;
+with Sem_Ch8;  use Sem_Ch8;
+with Sem_Disp; use Sem_Disp;
+with Sem_Eval; use Sem_Eval;
+with Sem_Res;  use Sem_Res;
+with Sem_Type; use Sem_Type;
+with Sem_Util; use Sem_Util;
+with Sem_Warn; use Sem_Warn;
+with Stand;    use Stand;
+with Sinfo;    use Sinfo;
+with Tbuild;   use Tbuild;
+with Uintp;    use Uintp;
+
+package body Sem_Ch5 is
+
+   Unblocked_Exit_Count : Nat := 0;
+   --  This variable is used when processing if statements or case
+   --  statements, it counts the number of branches of the conditional
+   --  that are not blocked by unconditional transfer instructions. At
+   --  the end of processing, if the count is zero, it means that control
+   --  cannot fall through the conditional statement. This is used for
+   --  the generation of warning messages. This variable is recursively
+   --  saved on entry to processing an if or case, and restored on exit.
+
+   -----------------------
+   -- Local Subprograms --
+   -----------------------
+
+   procedure Analyze_Iteration_Scheme (N : Node_Id);
+
+   ------------------------
+   -- Analyze_Assignment --
+   ------------------------
+
+   procedure Analyze_Assignment (N : Node_Id) is
+      Lhs    : constant Node_Id := Name (N);
+      Rhs    : constant Node_Id := Expression (N);
+      T1, T2 : Entity_Id;
+      Decl   : Node_Id;
+
+      procedure Diagnose_Non_Variable_Lhs (N : Node_Id);
+      --  N is the node for the left hand side of an assignment, and it
+      --  is not a variable. This routine issues an appropriate diagnostic.
+
+      procedure Set_Assignment_Type
+        (Opnd      : Node_Id;
+         Opnd_Type : in out Entity_Id);
+      --  Opnd is either the Lhs or Rhs of the assignment, and Opnd_Type
+      --  is the nominal subtype. This procedure is used to deal with cases
+      --  where the nominal subtype must be replaced by the actual subtype.
+
+      -------------------------------
+      -- Diagnose_Non_Variable_Lhs --
+      -------------------------------
+
+      procedure Diagnose_Non_Variable_Lhs (N : Node_Id) is
+      begin
+         --  Not worth posting another error if left hand side already
+         --  flagged as being illegal in some respect
+
+         if Error_Posted (N) then
+            return;
+
+         --  Some special bad cases of entity names
+
+         elsif Is_Entity_Name (N) then
+
+            if Ekind (Entity (N)) = E_In_Parameter then
+               Error_Msg_N
+                 ("assignment to IN mode parameter not allowed", N);
+               return;
+
+            --  Private declarations in a protected object are turned into
+            --  constants when compiling a protected function.
+
+            elsif Present (Scope (Entity (N)))
+              and then Is_Protected_Type (Scope (Entity (N)))
+              and then
+                (Ekind (Current_Scope) = E_Function
+                  or else
+                 Ekind (Enclosing_Dynamic_Scope (Current_Scope)) = E_Function)
+            then
+               Error_Msg_N
+                 ("protected function cannot modify protected object", N);
+               return;
+
+            elsif Ekind (Entity (N)) = E_Loop_Parameter then
+               Error_Msg_N
+                 ("assignment to loop parameter not allowed", N);
+               return;
+
+            end if;
+
+         --  For indexed components, or selected components, test prefix
+
+         elsif Nkind (N) = N_Indexed_Component
+           or else Nkind (N) = N_Selected_Component
+         then
+            Diagnose_Non_Variable_Lhs (Prefix (N));
+            return;
+         end if;
+
+         --  If we fall through, we have no special message to issue!
+
+         Error_Msg_N ("left hand side of assignment must be a variable", N);
+
+      end Diagnose_Non_Variable_Lhs;
+
+      -------------------------
+      -- Set_Assignment_Type --
+      -------------------------
+
+      procedure Set_Assignment_Type
+        (Opnd      : Node_Id;
+         Opnd_Type : in out Entity_Id)
+      is
+      begin
+         --  If the assignment operand is an in-out or out parameter, then we
+         --  get the actual subtype (needed for the unconstrained case).
+
+         if Is_Entity_Name (Opnd)
+           and then (Ekind (Entity (Opnd)) = E_Out_Parameter
+                      or else Ekind (Entity (Opnd)) =
+                           E_In_Out_Parameter
+                      or else Ekind (Entity (Opnd)) =
+                           E_Generic_In_Out_Parameter)
+         then
+            Opnd_Type := Get_Actual_Subtype (Opnd);
+
+         --  If assignment operand is a component reference, then we get the
+         --  actual subtype of the component for the unconstrained case.
+
+         elsif Nkind (Opnd) = N_Selected_Component
+           or else Nkind (Opnd) = N_Explicit_Dereference
+         then
+            Decl := Build_Actual_Subtype_Of_Component (Opnd_Type, Opnd);
+
+            if Present (Decl) then
+               Insert_Action (N, Decl);
+               Mark_Rewrite_Insertion (Decl);
+               Analyze (Decl);
+               Opnd_Type := Defining_Identifier (Decl);
+               Set_Etype (Opnd, Opnd_Type);
+               Freeze_Itype (Opnd_Type, N);
+
+            elsif Is_Constrained (Etype (Opnd)) then
+               Opnd_Type := Etype (Opnd);
+            end if;
+
+         --  For slice, use the constrained subtype created for the slice
+
+         elsif Nkind (Opnd) = N_Slice then
+            Opnd_Type := Etype (Opnd);
+         end if;
+      end Set_Assignment_Type;
+
+   --  Start of processing for Analyze_Assignment
+
+   begin
+      Analyze (Rhs);
+      Analyze (Lhs);
+      T1 := Etype (Lhs);
+
+      --  In the most general case, both Lhs and Rhs can be overloaded, and we
+      --  must compute the intersection of the possible types on each side.
+
+      if Is_Overloaded (Lhs) then
+         declare
+            I  : Interp_Index;
+            It : Interp;
+
+         begin
+            T1 := Any_Type;
+            Get_First_Interp (Lhs, I, It);
+
+            while Present (It.Typ) loop
+               if Has_Compatible_Type (Rhs, It.Typ) then
+
+                  if T1 /= Any_Type then
+
+                     --  An explicit dereference is overloaded if the prefix
+                     --  is. Try to remove the ambiguity on the prefix, the
+                     --  error will be posted there if the ambiguity is real.
+
+                     if Nkind (Lhs) = N_Explicit_Dereference then
+                        declare
+                           PI    : Interp_Index;
+                           PI1   : Interp_Index := 0;
+                           PIt   : Interp;
+                           Found : Boolean;
+
+                        begin
+                           Found := False;
+                           Get_First_Interp (Prefix (Lhs), PI, PIt);
+
+                           while Present (PIt.Typ) loop
+                              if Has_Compatible_Type (Rhs,
+                                Designated_Type (PIt.Typ))
+                              then
+                                 if Found then
+                                    PIt :=
+                                      Disambiguate (Prefix (Lhs),
+                                        PI1, PI, Any_Type);
+
+                                    if PIt = No_Interp then
+                                       return;
+                                    else
+                                       Resolve (Prefix (Lhs), PIt.Typ);
+                                    end if;
+
+                                    exit;
+                                 else
+                                    Found := True;
+                                    PI1 := PI;
+                                 end if;
+                              end if;
+
+                              Get_Next_Interp (PI, PIt);
+                           end loop;
+                        end;
+
+                     else
+                        Error_Msg_N
+                          ("ambiguous left-hand side in assignment", Lhs);
+                        exit;
+                     end if;
+                  else
+                     T1 := It.Typ;
+                  end if;
+               end if;
+
+               Get_Next_Interp (I, It);
+            end loop;
+         end;
+
+         if T1 = Any_Type then
+            Error_Msg_N
+              ("no valid types for left-hand side for assignment", Lhs);
+            return;
+         end if;
+      end if;
+
+      Resolve (Lhs, T1);
+
+      if not Is_Variable (Lhs) then
+         Diagnose_Non_Variable_Lhs (Lhs);
+         return;
+
+      elsif Is_Limited_Type (T1)
+        and then not Assignment_OK (Lhs)
+        and then not Assignment_OK (Original_Node (Lhs))
+      then
+         Error_Msg_N
+           ("left hand of assignment must not be limited type", Lhs);
+         return;
+      end if;
+
+      --  Resolution may have updated the subtype, in case the left-hand
+      --  side is a private protected component. Use the correct subtype
+      --  to avoid scoping issues in the back-end.
+
+      T1 := Etype (Lhs);
+      Set_Assignment_Type (Lhs, T1);
+
+      Resolve (Rhs, T1);
+
+      --  Remaining steps are skipped if Rhs was synatactically in error
+
+      if Rhs = Error then
+         return;
+      end if;
+
+      T2 := Etype (Rhs);
+      Check_Unset_Reference (Rhs);
+      Note_Possible_Modification (Lhs);
+
+      if Covers (T1, T2) then
+         null;
+      else
+         Wrong_Type (Rhs, Etype (Lhs));
+         return;
+      end if;
+
+      Set_Assignment_Type (Rhs, T2);
+
+      if T1 = Any_Type or else T2 = Any_Type then
+         return;
+      end if;
+
+      if (Is_Class_Wide_Type (T2) or else Is_Dynamically_Tagged (Rhs))
+        and then not Is_Class_Wide_Type (T1)
+      then
+         Error_Msg_N ("dynamically tagged expression not allowed!", Rhs);
+
+      elsif Is_Class_Wide_Type (T1)
+        and then not Is_Class_Wide_Type (T2)
+        and then not Is_Tag_Indeterminate (Rhs)
+        and then not Is_Dynamically_Tagged (Rhs)
+      then
+         Error_Msg_N ("dynamically tagged expression required!", Rhs);
+      end if;
+
+      --  Tag propagation is done only in semantics mode only. If expansion
+      --  is on, the rhs tag indeterminate function call has been expanded
+      --  and tag propagation would have happened too late, so the
+      --  propagation take place in expand_call instead.
+
+      if not Expander_Active
+        and then Is_Class_Wide_Type (T1)
+        and then Is_Tag_Indeterminate (Rhs)
+      then
+         Propagate_Tag (Lhs, Rhs);
+      end if;
+
+      if Is_Scalar_Type (T1) then
+         Apply_Scalar_Range_Check (Rhs, Etype (Lhs));
+
+      elsif Is_Array_Type (T1) then
+
+         --  Assignment verifies that the length of the Lsh and Rhs are equal,
+         --  but of course the indices do not have to match.
+
+         Apply_Length_Check (Rhs, Etype (Lhs));
+
+      else
+         --  Discriminant checks are applied in the course of expansion.
+         null;
+      end if;
+
+      --  ??? a real accessibility check is needed when ???
+
+      --  Post warning for useless assignment
+
+      if Warn_On_Redundant_Constructs
+
+         --  We only warn for source constructs
+
+         and then Comes_From_Source (N)
+
+         --  Where the entity is the same on both sides
+
+         and then Is_Entity_Name (Lhs)
+         and then Is_Entity_Name (Rhs)
+         and then Entity (Lhs) = Entity (Rhs)
+
+         --  But exclude the case where the right side was an operation
+         --  that got rewritten (e.g. JUNK + K, where K was known to be
+         --  zero). We don't want to warn in such a case, since it is
+         --  reasonable to write such expressions especially when K is
+         --  defined symbolically in some other package.
+
+        and then Nkind (Original_Node (Rhs)) not in N_Op
+      then
+         Error_Msg_NE
+           ("?useless assignment of & to itself", N, Entity (Lhs));
+      end if;
+   end Analyze_Assignment;
+
+   -----------------------------
+   -- Analyze_Block_Statement --
+   -----------------------------
+
+   procedure Analyze_Block_Statement (N : Node_Id) is
+      Decls : constant List_Id := Declarations (N);
+      Id    : constant Node_Id := Identifier (N);
+      Ent   : Entity_Id;
+
+   begin
+      --  If a label is present analyze it and mark it as referenced
+
+      if Present (Id) then
+         Analyze (Id);
+         Ent := Entity (Id);
+         Set_Ekind (Ent, E_Block);
+         Generate_Reference (Ent, N, ' ');
+         Generate_Definition (Ent);
+
+         if Nkind (Parent (Ent)) = N_Implicit_Label_Declaration then
+            Set_Label_Construct (Parent (Ent), N);
+         end if;
+
+      --  Otherwise create a label entity
+
+      else
+         Ent := New_Internal_Entity (E_Block, Current_Scope, Sloc (N), 'B');
+         Set_Identifier (N, New_Occurrence_Of (Ent, Sloc (N)));
+      end if;
+
+      Set_Etype (Ent, Standard_Void_Type);
+      Set_Block_Node (Ent, N);
+      New_Scope (Ent);
+
+      if Present (Decls) then
+         Analyze_Declarations (Decls);
+         Check_Completion;
+      end if;
+
+      Analyze (Handled_Statement_Sequence (N));
+      Process_End_Label (Handled_Statement_Sequence (N), 'e');
+
+      --  Analyze exception handlers if present. Note that the test for
+      --  HSS being present is an error defence against previous errors.
+
+      if Present (Handled_Statement_Sequence (N))
+        and then Present (Exception_Handlers (Handled_Statement_Sequence (N)))
+      then
+         declare
+            S : Entity_Id := Scope (Ent);
+
+         begin
+            --  Indicate that enclosing scopes contain a block with handlers.
+            --  Only non-generic scopes need to be marked.
+
+            loop
+               Set_Has_Nested_Block_With_Handler (S);
+               exit when Is_Overloadable (S)
+                 or else Ekind (S) = E_Package
+                 or else Ekind (S) = E_Generic_Function
+                 or else Ekind (S) = E_Generic_Package
+                 or else Ekind (S) = E_Generic_Procedure;
+               S := Scope (S);
+            end loop;
+         end;
+      end if;
+
+      Check_References (Ent);
+      End_Scope;
+   end Analyze_Block_Statement;
+
+   ----------------------------
+   -- Analyze_Case_Statement --
+   ----------------------------
+
+   procedure Analyze_Case_Statement (N : Node_Id) is
+
+      Statements_Analyzed : Boolean := False;
+      --  Set True if at least some statement sequences get analyzed.
+      --  If False on exit, means we had a serious error that prevented
+      --  full analysis of the case statement, and as a result it is not
+      --  a good idea to output warning messages about unreachable code.
+
+      Save_Unblocked_Exit_Count : constant Nat := Unblocked_Exit_Count;
+      --  Recursively save value of this global, will be restored on exit
+
+      procedure Non_Static_Choice_Error (Choice : Node_Id);
+      --  Error routine invoked by the generic instantiation below when
+      --  the case statment has a non static choice.
+
+      procedure Process_Statements (Alternative : Node_Id);
+      --  Analyzes all the statements associated to a case alternative.
+      --  Needed by the generic instantiation below.
+
+      package Case_Choices_Processing is new
+        Generic_Choices_Processing
+          (Get_Alternatives          => Alternatives,
+           Get_Choices               => Discrete_Choices,
+           Process_Empty_Choice      => No_OP,
+           Process_Non_Static_Choice => Non_Static_Choice_Error,
+           Process_Associated_Node   => Process_Statements);
+      use Case_Choices_Processing;
+      --  Instantiation of the generic choice processing package.
+
+      -----------------------------
+      -- Non_Static_Choice_Error --
+      -----------------------------
+
+      procedure Non_Static_Choice_Error (Choice : Node_Id) is
+      begin
+         Error_Msg_N ("choice given in case statement is not static", Choice);
+      end Non_Static_Choice_Error;
+
+      ------------------------
+      -- Process_Statements --
+      ------------------------
+
+      procedure Process_Statements (Alternative : Node_Id) is
+      begin
+         Unblocked_Exit_Count := Unblocked_Exit_Count + 1;
+         Statements_Analyzed := True;
+         Analyze_Statements (Statements (Alternative));
+      end Process_Statements;
+
+      --  Variables local to Analyze_Case_Statement.
+
+      Exp       : Node_Id;
+      Exp_Type  : Entity_Id;
+      Exp_Btype : Entity_Id;
+
+      Case_Table     : Choice_Table_Type (1 .. Number_Of_Choices (N));
+      Last_Choice    : Nat;
+      Dont_Care      : Boolean;
+      Others_Present : Boolean;
+
+   --  Start of processing for Analyze_Case_Statement
+
+   begin
+      Unblocked_Exit_Count := 0;
+      Exp := Expression (N);
+      Analyze_And_Resolve (Exp, Any_Discrete);
+      Check_Unset_Reference (Exp);
+      Exp_Type  := Etype (Exp);
+      Exp_Btype := Base_Type (Exp_Type);
+
+      --  The expression must be of a discrete type which must be determinable
+      --  independently of the context in which the expression occurs, but
+      --  using the fact that the expression must be of a discrete type.
+      --  Moreover, the type this expression must not be a character literal
+      --  (which is always ambiguous) or, for Ada-83, a generic formal type.
+
+      --  If error already reported by Resolve, nothing more to do
+
+      if Exp_Btype = Any_Discrete
+        or else Exp_Btype = Any_Type
+      then
+         return;
+
+      elsif Exp_Btype = Any_Character then
+         Error_Msg_N
+           ("character literal as case expression is ambiguous", Exp);
+         return;
+
+      elsif Ada_83
+        and then (Is_Generic_Type (Exp_Btype)
+                    or else Is_Generic_Type (Root_Type (Exp_Btype)))
+      then
+         Error_Msg_N
+           ("(Ada 83) case expression cannot be of a generic type", Exp);
+         return;
+      end if;
+
+      --  If the case expression is a formal object of mode in out,
+      --  then treat it as having a nonstatic subtype by forcing
+      --  use of the base type (which has to get passed to
+      --  Check_Case_Choices below).  Also use base type when
+      --  the case expression is parenthesized.
+
+      if Paren_Count (Exp) > 0
+        or else (Is_Entity_Name (Exp)
+                  and then Ekind (Entity (Exp)) = E_Generic_In_Out_Parameter)
+      then
+         Exp_Type := Exp_Btype;
+      end if;
+
+      --  Call the instantiated Analyze_Choices which does the rest of the work
+
+      Analyze_Choices
+        (N, Exp_Type, Case_Table, Last_Choice, Dont_Care, Others_Present);
+
+      if Exp_Type = Universal_Integer and then not Others_Present then
+         Error_Msg_N ("case on universal integer requires OTHERS choice", Exp);
+      end if;
+
+      --  If all our exits were blocked by unconditional transfers of control,
+      --  then the entire CASE statement acts as an unconditional transfer of
+      --  control, so treat it like one, and check unreachable code. Skip this
+      --  test if we had serious errors preventing any statement analysis.
+
+      if Unblocked_Exit_Count = 0 and then Statements_Analyzed then
+         Unblocked_Exit_Count := Save_Unblocked_Exit_Count;
+         Check_Unreachable_Code (N);
+      else
+         Unblocked_Exit_Count := Save_Unblocked_Exit_Count;
+      end if;
+   end Analyze_Case_Statement;
+
+   ----------------------------
+   -- Analyze_Exit_Statement --
+   ----------------------------
+
+   --  If the exit includes a name, it must be the name of a currently open
+   --  loop. Otherwise there must be an innermost open loop on the stack,
+   --  to which the statement implicitly refers.
+
+   procedure Analyze_Exit_Statement (N : Node_Id) is
+      Target   : constant Node_Id := Name (N);
+      Cond     : constant Node_Id := Condition (N);
+      Scope_Id : Entity_Id;
+      U_Name   : Entity_Id;
+      Kind     : Entity_Kind;
+
+   begin
+      if No (Cond) then
+         Check_Unreachable_Code (N);
+      end if;
+
+      if Present (Target) then
+         Analyze (Target);
+         U_Name := Entity (Target);
+
+         if not In_Open_Scopes (U_Name) or else Ekind (U_Name) /= E_Loop then
+            Error_Msg_N ("invalid loop name in exit statement", N);
+            return;
+         else
+            Set_Has_Exit (U_Name);
+         end if;
+
+      else
+         U_Name := Empty;
+      end if;
+
+      for J in reverse 0 .. Scope_Stack.Last loop
+         Scope_Id := Scope_Stack.Table (J).Entity;
+         Kind := Ekind (Scope_Id);
+
+         if Kind = E_Loop
+           and then (No (Target) or else Scope_Id = U_Name) then
+            Set_Has_Exit (Scope_Id);
+            exit;
+
+         elsif Kind = E_Block or else Kind = E_Loop then
+            null;
+
+         else
+            Error_Msg_N
+              ("cannot exit from program unit or accept statement", N);
+            exit;
+         end if;
+      end loop;
+
+      --  Verify that if present the condition is a Boolean expression.
+
+      if Present (Cond) then
+         Analyze_And_Resolve (Cond, Any_Boolean);
+         Check_Unset_Reference (Cond);
+      end if;
+   end Analyze_Exit_Statement;
+
+   ----------------------------
+   -- Analyze_Goto_Statement --
+   ----------------------------
+
+   procedure Analyze_Goto_Statement (N : Node_Id) is
+      Label       : constant Node_Id := Name (N);
+      Scope_Id    : Entity_Id;
+      Label_Scope : Entity_Id;
+
+   begin
+      Check_Unreachable_Code (N);
+
+      Analyze (Label);
+
+      if Entity (Label) = Any_Id then
+         return;
+
+      elsif Ekind (Entity (Label)) /= E_Label then
+         Error_Msg_N ("target of goto statement must be a label", Label);
+         return;
+
+      elsif not Reachable (Entity (Label)) then
+         Error_Msg_N ("target of goto statement is not reachable", Label);
+         return;
+      end if;
+
+      Label_Scope := Enclosing_Scope (Entity (Label));
+
+      for J in reverse 0 .. Scope_Stack.Last loop
+         Scope_Id := Scope_Stack.Table (J).Entity;
+
+         if Label_Scope = Scope_Id
+           or else (Ekind (Scope_Id) /= E_Block
+                     and then Ekind (Scope_Id) /= E_Loop)
+         then
+            if Scope_Id /= Label_Scope then
+               Error_Msg_N
+                 ("cannot exit from program unit or accept statement", N);
+            end if;
+
+            return;
+         end if;
+      end loop;
+
+      raise Program_Error;
+
+   end Analyze_Goto_Statement;
+
+   --------------------------
+   -- Analyze_If_Statement --
+   --------------------------
+
+   --  A special complication arises in the analysis of if statements.
+   --  The expander has circuitry to completely deleted code that it
+   --  can tell will not be executed (as a result of compile time known
+   --  conditions). In the analyzer, we ensure that code that will be
+   --  deleted in this manner is analyzed but not expanded. This is
+   --  obviously more efficient, but more significantly, difficulties
+   --  arise if code is expanded and then eliminated (e.g. exception
+   --  table entries disappear).
+
+   procedure Analyze_If_Statement (N : Node_Id) is
+      E : Node_Id;
+
+      Save_Unblocked_Exit_Count : constant Nat := Unblocked_Exit_Count;
+      --  Recursively save value of this global, will be restored on exit
+
+      Del : Boolean := False;
+      --  This flag gets set True if a True condition has been found,
+      --  which means that remaining ELSE/ELSIF parts are deleted.
+
+      procedure Analyze_Cond_Then (Cnode : Node_Id);
+      --  This is applied to either the N_If_Statement node itself or
+      --  to an N_Elsif_Part node. It deals with analyzing the condition
+      --  and the THEN statements associated with it.
+
+      procedure Analyze_Cond_Then (Cnode : Node_Id) is
+         Cond : constant Node_Id := Condition (Cnode);
+         Tstm : constant List_Id := Then_Statements (Cnode);
+
+      begin
+         Unblocked_Exit_Count := Unblocked_Exit_Count + 1;
+         Analyze_And_Resolve (Cond, Any_Boolean);
+         Check_Unset_Reference (Cond);
+
+         --  If already deleting, then just analyze then statements
+
+         if Del then
+            Analyze_Statements (Tstm);
+
+         --  Compile time known value, not deleting yet
+
+         elsif Compile_Time_Known_Value (Cond) then
+
+            --  If condition is True, then analyze the THEN statements
+            --  and set no expansion for ELSE and ELSIF parts.
+
+            if Is_True (Expr_Value (Cond)) then
+               Analyze_Statements (Tstm);
+               Del := True;
+               Expander_Mode_Save_And_Set (False);
+
+            --  If condition is False, analyze THEN with expansion off
+
+            else -- Is_False (Expr_Value (Cond))
+               Expander_Mode_Save_And_Set (False);
+               Analyze_Statements (Tstm);
+               Expander_Mode_Restore;
+            end if;
+
+         --  Not known at compile time, not deleting, normal analysis
+
+         else
+            Analyze_Statements (Tstm);
+         end if;
+      end Analyze_Cond_Then;
+
+   --  Start of Analyze_If_Statement
+
+   begin
+      --  Initialize exit count for else statements. If there is no else
+      --  part, this count will stay non-zero reflecting the fact that the
+      --  uncovered else case is an unblocked exit.
+
+      Unblocked_Exit_Count := 1;
+      Analyze_Cond_Then (N);
+
+      --  Now to analyze the elsif parts if any are present
+
+      if Present (Elsif_Parts (N)) then
+         E := First (Elsif_Parts (N));
+         while Present (E) loop
+            Analyze_Cond_Then (E);
+            Next (E);
+         end loop;
+      end if;
+
+      if Present (Else_Statements (N)) then
+         Analyze_Statements (Else_Statements (N));
+      end if;
+
+      --  If all our exits were blocked by unconditional transfers of control,
+      --  then the entire IF statement acts as an unconditional transfer of
+      --  control, so treat it like one, and check unreachable code.
+
+      if Unblocked_Exit_Count = 0 then
+         Unblocked_Exit_Count := Save_Unblocked_Exit_Count;
+         Check_Unreachable_Code (N);
+      else
+         Unblocked_Exit_Count := Save_Unblocked_Exit_Count;
+      end if;
+
+      if Del then
+         Expander_Mode_Restore;
+      end if;
+
+   end Analyze_If_Statement;
+
+   ----------------------------------------
+   -- Analyze_Implicit_Label_Declaration --
+   ----------------------------------------
+
+   --  An implicit label declaration is generated in the innermost
+   --  enclosing declarative part. This is done for labels as well as
+   --  block and loop names.
+
+   --  Note: any changes in this routine may need to be reflected in
+   --  Analyze_Label_Entity.
+
+   procedure Analyze_Implicit_Label_Declaration (N : Node_Id) is
+      Id : Node_Id := Defining_Identifier (N);
+
+   begin
+      Enter_Name (Id);
+      Set_Ekind           (Id, E_Label);
+      Set_Etype           (Id, Standard_Void_Type);
+      Set_Enclosing_Scope (Id, Current_Scope);
+   end Analyze_Implicit_Label_Declaration;
+
+   ------------------------------
+   -- Analyze_Iteration_Scheme --
+   ------------------------------
+
+   procedure Analyze_Iteration_Scheme (N : Node_Id) is
+   begin
+      --  For an infinite loop, there is no iteration scheme
+
+      if No (N) then
+         return;
+
+      else
+         declare
+            Cond : constant Node_Id := Condition (N);
+
+         begin
+            --  For WHILE loop, verify that the condition is a Boolean
+            --  expression and resolve and check it.
+
+            if Present (Cond) then
+               Analyze_And_Resolve (Cond, Any_Boolean);
+               Check_Unset_Reference (Cond);
+
+            --  Else we have a FOR loop
+
+            else
+               declare
+                  LP : constant Node_Id   := Loop_Parameter_Specification (N);
+                  Id : constant Entity_Id := Defining_Identifier (LP);
+                  DS : constant Node_Id   := Discrete_Subtype_Definition (LP);
+                  F  : List_Id;
+
+               begin
+                  Enter_Name (Id);
+
+                  --  We always consider the loop variable to be referenced,
+                  --  since the loop may be used just for counting purposes.
+
+                  Generate_Reference (Id, N, ' ');
+
+                  --  Check for case of loop variable hiding a local
+                  --  variable (used later on to give a nice warning
+                  --  if the hidden variable is never assigned).
+
+                  declare
+                     H : constant Entity_Id := Homonym (Id);
+
+                  begin
+                     if Present (H)
+                       and then Enclosing_Dynamic_Scope (H) =
+                                Enclosing_Dynamic_Scope (Id)
+                       and then Ekind (H) = E_Variable
+                       and then Is_Discrete_Type (Etype (H))
+                     then
+                        Set_Hiding_Loop_Variable (H, Id);
+                     end if;
+                  end;
+
+                  --  Now analyze the subtype definition
+
+                  Analyze (DS);
+
+                  if DS = Error then
+                     return;
+                  end if;
+
+                  --  The subtype indication may denote the completion
+                  --  of an incomplete type declaration.
+
+                  if Is_Entity_Name (DS)
+                    and then Present (Entity (DS))
+                    and then Is_Type (Entity (DS))
+                    and then Ekind (Entity (DS)) = E_Incomplete_Type
+                  then
+                     Set_Entity (DS, Get_Full_View (Entity (DS)));
+                     Set_Etype  (DS, Entity (DS));
+                  end if;
+
+                  if not Is_Discrete_Type (Etype (DS)) then
+                     Wrong_Type (DS, Any_Discrete);
+                     Set_Etype (DS, Any_Type);
+                  end if;
+
+                  Make_Index (DS, LP);
+
+                  Set_Ekind          (Id, E_Loop_Parameter);
+                  Set_Etype          (Id, Etype (DS));
+                  Set_Is_Known_Valid (Id, True);
+
+                  --  The loop is not a declarative part, so the only entity
+                  --  declared "within" must be frozen explicitly. Since the
+                  --  type of this entity has already been frozen, this cannot
+                  --  generate any freezing actions.
+
+                  F := Freeze_Entity (Id, Sloc (LP));
+                  pragma Assert (F = No_List);
+
+                  --  Check for null or possibly null range and issue warning
+
+                  if Nkind (DS) = N_Range
+                    and then Comes_From_Source (N)
+                    and then not Inside_A_Generic
+                  then
+                     declare
+                        L : constant Node_Id := Low_Bound  (DS);
+                        H : constant Node_Id := High_Bound (DS);
+
+                        Llo : Uint;
+                        Lhi : Uint;
+                        LOK : Boolean;
+                        Hlo : Uint;
+                        Hhi : Uint;
+                        HOK : Boolean;
+
+                     begin
+                        Determine_Range (L, LOK, Llo, Lhi);
+                        Determine_Range (H, HOK, Hlo, Hhi);
+
+                        --  If range of loop is null, issue warning
+
+                        if (LOK and HOK) and then Llo > Hhi then
+                           Warn_On_Instance := True;
+                           Error_Msg_N
+                             ("?loop range is null, loop will not execute",
+                              DS);
+                           Warn_On_Instance := False;
+
+                        --  The other case for a warning is a reverse loop
+                        --  where the upper bound is the integer literal
+                        --  zero or one, and the lower bound can be positive.
+
+                        elsif Reverse_Present (LP)
+                          and then Nkind (H) = N_Integer_Literal
+                          and then (Intval (H) = Uint_0
+                                      or else
+                                    Intval (H) = Uint_1)
+                          and then Lhi > Hhi
+                        then
+                           Warn_On_Instance := True;
+                           Error_Msg_N ("?loop range may be null", DS);
+                           Warn_On_Instance := False;
+                        end if;
+                     end;
+                  end if;
+               end;
+            end if;
+         end;
+      end if;
+   end Analyze_Iteration_Scheme;
+
+   -------------------
+   -- Analyze_Label --
+   -------------------
+
+   --  Important note: normally this routine is called from Analyze_Statements
+   --  which does a prescan, to make sure that the Reachable flags are set on
+   --  all labels before encountering a possible goto to one of these labels.
+   --  If expanded code analyzes labels via the normal Sem path, then it must
+   --  ensure that Reachable is set early enough to avoid problems in the case
+   --  of a forward goto.
+
+   procedure Analyze_Label (N : Node_Id) is
+      Lab : Entity_Id;
+
+   begin
+      Analyze (Identifier (N));
+      Lab := Entity (Identifier (N));
+
+      --  If we found a label mark it as reachable.
+
+      if Ekind (Lab) = E_Label then
+         Generate_Definition (Lab);
+         Set_Reachable (Lab);
+
+         if Nkind (Parent (Lab)) = N_Implicit_Label_Declaration then
+            Set_Label_Construct (Parent (Lab), N);
+         end if;
+
+      --  If we failed to find a label, it means the implicit declaration
+      --  of the label was hidden.  A for-loop parameter can do this to a
+      --  label with the same name inside the loop, since the implicit label
+      --  declaration is in the innermost enclosing body or block statement.
+
+      else
+         Error_Msg_Sloc := Sloc (Lab);
+         Error_Msg_N
+           ("implicit label declaration for & is hidden#",
+            Identifier (N));
+      end if;
+   end Analyze_Label;
+
+   --------------------------
+   -- Analyze_Label_Entity --
+   --------------------------
+
+   procedure Analyze_Label_Entity (E : Entity_Id) is
+   begin
+      Set_Ekind           (E, E_Label);
+      Set_Etype           (E, Standard_Void_Type);
+      Set_Enclosing_Scope (E, Current_Scope);
+      Set_Reachable       (E, True);
+   end Analyze_Label_Entity;
+
+   ----------------------------
+   -- Analyze_Loop_Statement --
+   ----------------------------
+
+   procedure Analyze_Loop_Statement (N : Node_Id) is
+      Id  : constant Node_Id := Identifier (N);
+      Ent : Entity_Id;
+
+   begin
+      if Present (Id) then
+
+         --  Make name visible, e.g. for use in exit statements. Loop
+         --  labels are always considered to be referenced.
+
+         Analyze (Id);
+         Ent := Entity (Id);
+         Generate_Reference  (Ent, N, ' ');
+         Generate_Definition (Ent);
+
+         --  If we found a label, mark its type. If not, ignore it, since it
+         --  means we have a conflicting declaration, which would already have
+         --  been diagnosed at declaration time. Set Label_Construct of the
+         --  implicit label declaration, which is not created by the parser
+         --  for generic units.
+
+         if Ekind (Ent) = E_Label then
+            Set_Ekind (Ent, E_Loop);
+
+            if Nkind (Parent (Ent)) = N_Implicit_Label_Declaration then
+               Set_Label_Construct (Parent (Ent), N);
+            end if;
+         end if;
+
+      --  Case of no identifier present
+
+      else
+         Ent := New_Internal_Entity (E_Loop, Current_Scope, Sloc (N), 'L');
+         Set_Etype (Ent,  Standard_Void_Type);
+         Set_Parent (Ent, N);
+      end if;
+
+      New_Scope (Ent);
+      Analyze_Iteration_Scheme (Iteration_Scheme (N));
+      Analyze_Statements (Statements (N));
+      Process_End_Label (N, 'e');
+      End_Scope;
+   end Analyze_Loop_Statement;
+
+   ----------------------------
+   -- Analyze_Null_Statement --
+   ----------------------------
+
+   --  Note: the semantics of the null statement is implemented by a single
+   --  null statement, too bad everything isn't as simple as this!
+
+   procedure Analyze_Null_Statement (N : Node_Id) is
+   begin
+      null;
+   end Analyze_Null_Statement;
+
+   ------------------------
+   -- Analyze_Statements --
+   ------------------------
+
+   procedure Analyze_Statements (L : List_Id) is
+      S : Node_Id;
+
+   begin
+      --  The labels declared in the statement list are reachable from
+      --  statements in the list. We do this as a prepass so that any
+      --  goto statement will be properly flagged if its target is not
+      --  reachable. This is not required, but is nice behavior!
+
+      S := First (L);
+
+      while Present (S) loop
+         if Nkind (S) = N_Label then
+            Analyze_Label (S);
+         end if;
+
+         Next (S);
+      end loop;
+
+      --  Perform semantic analysis on all statements
+
+      S := First (L);
+
+      while Present (S) loop
+
+         if Nkind (S) /= N_Label then
+            Analyze (S);
+         end if;
+
+         Next (S);
+      end loop;
+
+      --  Make labels unreachable. Visibility is not sufficient, because
+      --  labels in one if-branch for example are not reachable from the
+      --  other branch, even though their declarations are in the enclosing
+      --  declarative part.
+
+      S := First (L);
+
+      while Present (S) loop
+         if Nkind (S) = N_Label then
+            Set_Reachable (Entity (Identifier (S)), False);
+         end if;
+
+         Next (S);
+      end loop;
+   end Analyze_Statements;
+
+   ----------------------------
+   -- Check_Unreachable_Code --
+   ----------------------------
+
+   procedure Check_Unreachable_Code (N : Node_Id) is
+      Error_Loc : Source_Ptr;
+      P         : Node_Id;
+
+   begin
+      if Is_List_Member (N)
+        and then Comes_From_Source (N)
+      then
+         declare
+            Nxt : Node_Id;
+
+         begin
+            Nxt := Original_Node (Next (N));
+
+            if Present (Nxt)
+              and then Comes_From_Source (Nxt)
+              and then Is_Statement (Nxt)
+            then
+               --  Special very annoying exception. If we have a return that
+               --  follows a raise, then we allow it without a warning, since
+               --  the Ada RM annoyingly requires a useless return here!
+
+               if Nkind (Original_Node (N)) /= N_Raise_Statement
+                 or else Nkind (Nxt) /= N_Return_Statement
+               then
+                  --  The rather strange shenanigans with the warning message
+                  --  here reflects the fact that Kill_Dead_Code is very good
+                  --  at removing warnings in deleted code, and this is one
+                  --  warning we would prefer NOT to have removed :-)
+
+                  Error_Loc := Sloc (Nxt);
+
+                  --  If we have unreachable code, analyze and remove the
+                  --  unreachable code, since it is useless and we don't
+                  --  want to generate junk warnings.
+
+                  --  We skip this step if we are not in code generation mode.
+                  --  This is the one case where we remove dead code in the
+                  --  semantics as opposed to the expander, and we do not want
+                  --  to remove code if we are not in code generation mode,
+                  --  since this messes up the ASIS trees.
+
+                  --  Note that one might react by moving the whole circuit to
+                  --  exp_ch5, but then we lose the warning in -gnatc mode.
+
+                  if Operating_Mode = Generate_Code then
+                     loop
+                        Nxt := Next (N);
+                        exit when No (Nxt) or else not Is_Statement (Nxt);
+                        Analyze (Nxt);
+                        Remove (Nxt);
+                        Kill_Dead_Code (Nxt);
+                     end loop;
+                  end if;
+
+                  --  Now issue the warning
+
+                  Error_Msg ("?unreachable code", Error_Loc);
+               end if;
+
+            --  If the unconditional transfer of control instruction is
+            --  the last statement of a sequence, then see if our parent
+            --  is an IF statement, and if so adjust the unblocked exit
+            --  count of the if statement to reflect the fact that this
+            --  branch of the if is indeed blocked by a transfer of control.
+
+            else
+               P := Parent (N);
+
+               if Nkind (P) = N_If_Statement then
+                  null;
+
+               elsif Nkind (P) = N_Elsif_Part then
+                  P := Parent (P);
+                  pragma Assert (Nkind (P) = N_If_Statement);
+
+               elsif Nkind (P) = N_Case_Statement_Alternative then
+                  P := Parent (P);
+                  pragma Assert (Nkind (P) = N_Case_Statement);
+
+               else
+                  return;
+               end if;
+
+               Unblocked_Exit_Count := Unblocked_Exit_Count - 1;
+            end if;
+         end;
+      end if;
+   end Check_Unreachable_Code;
+
+end Sem_Ch5;
diff --git a/gcc/ada/sem_ch5.ads b/gcc/ada/sem_ch5.ads
new file mode 100644
index 00000000000..c7d94685fa1
--- /dev/null
+++ b/gcc/ada/sem_ch5.ads
@@ -0,0 +1,58 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              S E M _ C H 5                               --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.16 $                             --
+--                                                                          --
+--          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). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+with Types; use Types;
+
+package Sem_Ch5 is
+
+   procedure Analyze_Assignment                 (N : Node_Id);
+   procedure Analyze_Block_Statement            (N : Node_Id);
+   procedure Analyze_Case_Statement             (N : Node_Id);
+   procedure Analyze_Exit_Statement             (N : Node_Id);
+   procedure Analyze_Goto_Statement             (N : Node_Id);
+   procedure Analyze_If_Statement               (N : Node_Id);
+   procedure Analyze_Implicit_Label_Declaration (N : Node_Id);
+   procedure Analyze_Label                      (N : Node_Id);
+   procedure Analyze_Loop_Statement             (N : Node_Id);
+   procedure Analyze_Null_Statement             (N : Node_Id);
+   procedure Analyze_Statements                 (L : List_Id);
+
+   procedure Analyze_Label_Entity (E : Entity_Id);
+   --  This procedure performs direct analysis of the label entity E. It
+   --  is used when a label is created by the expander without bothering
+   --  to insert an N_Implicit_Label_Declaration in the tree. It also takes
+   --  care of setting Reachable, since labels defined by the expander can
+   --  be assumed to be reachable.
+
+   procedure Check_Unreachable_Code (N : Node_Id);
+   --  This procedure is called with N being the node for a statement that
+   --  is an unconditional transfer of control. It checks to see if the
+   --  statement is followed by some other statement, and if so generates
+   --  an appropriate warning for unreachable code.
+
+end Sem_Ch5;
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
new file mode 100644
index 00000000000..f8e0b4fce42
--- /dev/null
+++ b/gcc/ada/sem_ch6.adb
@@ -0,0 +1,4779 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              S E M _ C H 6                               --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.508 $
+--                                                                          --
+--          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 Checks;   use Checks;
+with Debug;    use Debug;
+with Einfo;    use Einfo;
+with Elists;   use Elists;
+with Errout;   use Errout;
+with Expander; use Expander;
+with Exp_Ch7;  use Exp_Ch7;
+with Freeze;   use Freeze;
+with Lib.Xref; use Lib.Xref;
+with Namet;    use Namet;
+with Lib;      use Lib;
+with Nlists;   use Nlists;
+with Nmake;    use Nmake;
+with Opt;      use Opt;
+with Output;   use Output;
+with Rtsfind;  use Rtsfind;
+with Sem;      use Sem;
+with Sem_Cat;  use Sem_Cat;
+with Sem_Ch3;  use Sem_Ch3;
+with Sem_Ch4;  use Sem_Ch4;
+with Sem_Ch5;  use Sem_Ch5;
+with Sem_Ch8;  use Sem_Ch8;
+with Sem_Ch12; use Sem_Ch12;
+with Sem_Disp; use Sem_Disp;
+with Sem_Dist; use Sem_Dist;
+with Sem_Elim; use Sem_Elim;
+with Sem_Eval; use Sem_Eval;
+with Sem_Mech; use Sem_Mech;
+with Sem_Prag; use Sem_Prag;
+with Sem_Res;  use Sem_Res;
+with Sem_Util; use Sem_Util;
+with Sem_Type; use Sem_Type;
+with Sem_Warn; use Sem_Warn;
+with Sinput;   use Sinput;
+with Stand;    use Stand;
+with Sinfo;    use Sinfo;
+with Sinfo.CN; use Sinfo.CN;
+with Snames;   use Snames;
+with Stringt;  use Stringt;
+with Style;
+with Stylesw;  use Stylesw;
+with Tbuild;   use Tbuild;
+with Uintp;    use Uintp;
+with Urealp;   use Urealp;
+with Validsw;  use Validsw;
+
+package body Sem_Ch6 is
+
+   -----------------------
+   -- Local Subprograms --
+   -----------------------
+
+   procedure Analyze_Generic_Subprogram_Body (N : Node_Id; Gen_Id : Entity_Id);
+   --  Analyze a generic subprogram body
+
+   function Build_Body_To_Inline
+     (N         : Node_Id;
+      Subp      : Entity_Id;
+      Orig_Body : Node_Id)
+      return      Boolean;
+   --  If a subprogram has pragma Inline and inlining is active, use generic
+   --  machinery to build an unexpanded body for the subprogram. This body is
+   --  subsequenty used for inline expansions at call sites. If subprogram can
+   --  be inlined (depending on size and nature of local declarations) this
+   --  function returns true. Otherwise subprogram body is treated normally.
+
+   type Conformance_Type is
+     (Type_Conformant, Mode_Conformant, Subtype_Conformant, Fully_Conformant);
+
+   procedure Check_Conformance
+     (New_Id   : Entity_Id;
+      Old_Id   : Entity_Id;
+      Ctype    : Conformance_Type;
+      Errmsg   : Boolean;
+      Conforms : out Boolean;
+      Err_Loc  : Node_Id := Empty;
+      Get_Inst : Boolean := False);
+   --  Given two entities, this procedure checks that the profiles associated
+   --  with these entities meet the conformance criterion given by the third
+   --  parameter. If they conform, Conforms is set True and control returns
+   --  to the caller. If they do not conform, Conforms is set to False, and
+   --  in addition, if Errmsg is True on the call, proper messages are output
+   --  to complain about the conformance failure. If Err_Loc is non_Empty
+   --  the error messages are placed on Err_Loc, if Err_Loc is empty, then
+   --  error messages are placed on the appropriate part of the construct
+   --  denoted by New_Id. If Get_Inst is true, then this is a mode conformance
+   --  against a formal access-to-subprogram type so Get_Instance_Of must
+   --  be called.
+
+   procedure Check_Subprogram_Order (N : Node_Id);
+   --  N is the N_Subprogram_Body node for a subprogram. This routine applies
+   --  the alpha ordering rule for N if this ordering requirement applicable.
+
+   function Is_Non_Overriding_Operation
+     (Prev_E : Entity_Id;
+      New_E  : Entity_Id)
+      return   Boolean;
+   --  Enforce the rule given in 12.3(18): a private operation in an instance
+   --  overrides an inherited operation only if the corresponding operation
+   --  was overriding in the generic. This can happen for primitive operations
+   --  of types derived (in the generic unit) from formal private or formal
+   --  derived types.
+
+   procedure Check_Returns
+     (HSS  : Node_Id;
+      Mode : Character;
+      Err  : out Boolean);
+   --  Called to check for missing return statements in a function body,
+   --  or for returns present in a procedure body which has No_Return set.
+   --  L is the handled statement sequence for the subprogram body. This
+   --  procedure checks all flow paths to make sure they either have a
+   --  return (Mode = 'F') or do not have a return (Mode = 'P'). The flag
+   --  Err is set if there are any control paths not explicitly terminated
+   --  by a return in the function case, and is True otherwise.
+
+   function Conforming_Types
+     (T1       : Entity_Id;
+      T2       : Entity_Id;
+      Ctype    : Conformance_Type;
+      Get_Inst : Boolean := False)
+      return     Boolean;
+   --  Check that two formal parameter types conform, checking both
+   --  for equality of base types, and where required statically
+   --  matching subtypes, depending on the setting of Ctype.
+
+   procedure Enter_Overloaded_Entity (S : Entity_Id);
+   --  This procedure makes S, a new overloaded entity, into the first
+   --  visible entity with that name.
+
+   procedure Install_Entity (E : Entity_Id);
+   --  Make single entity visible. Used for generic formals as well.
+
+   procedure Install_Formals (Id : Entity_Id);
+   --  On entry to a subprogram body, make the formals visible. Note
+   --  that simply placing the subprogram on the scope stack is not
+   --  sufficient: the formals must become the current entities for
+   --  their names.
+
+   procedure Make_Inequality_Operator (S : Entity_Id);
+   --  Create the declaration for an inequality operator that is implicitly
+   --  created by a user-defined equality operator that yields a boolean.
+
+   procedure May_Need_Actuals (Fun : Entity_Id);
+   --  Flag functions that can be called without parameters, i.e. those that
+   --  have no parameters, or those for which defaults exist for all parameters
+
+   procedure Set_Formal_Validity (Formal_Id : Entity_Id);
+   --  Formal_Id is an formal parameter entity. This procedure deals with
+   --  setting the proper validity status for this entity, which depends
+   --  on the kind of parameter and the validity checking mode.
+
+   ---------------------------------------------
+   -- Analyze_Abstract_Subprogram_Declaration --
+   ---------------------------------------------
+
+   procedure Analyze_Abstract_Subprogram_Declaration (N : Node_Id) is
+      Designator : constant Entity_Id := Analyze_Spec (Specification (N));
+      Scop       : constant Entity_Id := Current_Scope;
+
+   begin
+      Generate_Definition (Designator);
+      Set_Is_Abstract (Designator);
+      New_Overloaded_Entity (Designator);
+      Check_Delayed_Subprogram (Designator);
+
+      Set_Is_Pure (Designator,
+        Is_Pure (Scop) and then Is_Library_Level_Entity (Designator));
+      Set_Is_Remote_Call_Interface (
+        Designator, Is_Remote_Call_Interface (Scop));
+      Set_Is_Remote_Types (Designator, Is_Remote_Types (Scop));
+
+      if Ekind (Scope (Designator)) = E_Protected_Type then
+         Error_Msg_N
+           ("abstract subprogram not allowed in protected type", N);
+      end if;
+   end Analyze_Abstract_Subprogram_Declaration;
+
+   ----------------------------
+   -- Analyze_Function_Call  --
+   ----------------------------
+
+   procedure Analyze_Function_Call (N : Node_Id) is
+      P      : constant Node_Id := Name (N);
+      L      : constant List_Id := Parameter_Associations (N);
+      Actual : Node_Id;
+
+   begin
+      Analyze (P);
+
+      --  If error analyzing name, then set Any_Type as result type and return
+
+      if Etype (P) = Any_Type then
+         Set_Etype (N, Any_Type);
+         return;
+      end if;
+
+      --  Otherwise analyze the parameters
+
+      if Present (L) then
+         Actual := First (L);
+
+         while Present (Actual) loop
+            Analyze (Actual);
+            Check_Parameterless_Call (Actual);
+            Next (Actual);
+         end loop;
+      end if;
+
+      Analyze_Call (N);
+
+   end Analyze_Function_Call;
+
+   -------------------------------------
+   -- Analyze_Generic_Subprogram_Body --
+   -------------------------------------
+
+   procedure Analyze_Generic_Subprogram_Body
+     (N      : Node_Id;
+      Gen_Id : Entity_Id)
+   is
+      Gen_Decl : constant Node_Id := Unit_Declaration_Node (Gen_Id);
+      Spec     : Node_Id;
+      Kind     : constant Entity_Kind := Ekind (Gen_Id);
+      Nam      : Entity_Id;
+      New_N    : Node_Id;
+
+   begin
+      --  Copy body and disable expansion while analyzing the generic
+      --  For a stub, do not copy the stub (which would load the proper body),
+      --  this will be done when the proper body is analyzed.
+
+      if Nkind (N) /= N_Subprogram_Body_Stub then
+         New_N := Copy_Generic_Node (N, Empty, Instantiating => False);
+         Rewrite (N, New_N);
+         Start_Generic;
+      end if;
+
+      Spec := Specification (N);
+
+      --  Within the body of the generic, the subprogram is callable, and
+      --  behaves like the corresponding non-generic unit.
+
+      Nam := Defining_Entity (Spec);
+
+      if Kind = E_Generic_Procedure
+        and then Nkind (Spec) /= N_Procedure_Specification
+      then
+         Error_Msg_N ("invalid body for generic procedure ", Nam);
+         return;
+
+      elsif Kind = E_Generic_Function
+        and then Nkind (Spec) /= N_Function_Specification
+      then
+         Error_Msg_N ("invalid body for generic function ", Nam);
+         return;
+      end if;
+
+      Set_Corresponding_Body (Gen_Decl, Nam);
+
+      if Has_Completion (Gen_Id)
+        and then Nkind (Parent (N)) /= N_Subunit
+      then
+         Error_Msg_N ("duplicate generic body", N);
+         return;
+      else
+         Set_Has_Completion (Gen_Id);
+      end if;
+
+      if Nkind (N) = N_Subprogram_Body_Stub then
+         Set_Ekind (Defining_Entity (Specification (N)), Kind);
+      else
+         Set_Corresponding_Spec (N, Gen_Id);
+      end if;
+
+      if Nkind (Parent (N)) = N_Compilation_Unit then
+         Set_Cunit_Entity (Current_Sem_Unit, Defining_Entity (N));
+      end if;
+
+      --  Make generic parameters immediately visible in the body. They are
+      --  needed to process the formals declarations. Then make the formals
+      --  visible in a separate step.
+
+      New_Scope (Gen_Id);
+
+      declare
+         E         : Entity_Id;
+         First_Ent : Entity_Id;
+
+      begin
+         First_Ent := First_Entity (Gen_Id);
+
+         E := First_Ent;
+         while Present (E) and then not Is_Formal (E) loop
+            Install_Entity (E);
+            Next_Entity (E);
+         end loop;
+
+         Set_Use (Generic_Formal_Declarations (Gen_Decl));
+
+         --  Now generic formals are visible, and the specification can be
+         --  analyzed, for subsequent conformance check.
+
+         Nam := Analyze_Spec (Spec);
+
+         if Nkind (N) = N_Subprogram_Body_Stub then
+
+            --  Nothing to do if no body to process
+
+            Set_Ekind (Nam, Kind);
+            End_Scope;
+            return;
+         end if;
+
+         if Present (E) then
+
+            --  E is the first formal parameter, which must be the first
+            --  entity in the subprogram body.
+
+            Set_First_Entity (Gen_Id, E);
+
+            --  Now make formal parameters visible
+
+            while Present (E) loop
+               Install_Entity (E);
+               Next_Formal (E);
+            end loop;
+         end if;
+
+         --  Visible generic entity is callable within its own body.
+
+         Set_Ekind (Gen_Id, Ekind (Nam));
+         Set_Convention (Nam, Convention (Gen_Id));
+         Set_Scope (Nam, Scope (Gen_Id));
+         Check_Fully_Conformant (Nam, Gen_Id, Nam);
+
+         --  If this is a compilation unit, it must be made visible
+         --  explicitly, because the compilation of the declaration,
+         --  unlike other library unit declarations, does not. If it
+         --  is not a unit, the following is redundant but harmless.
+
+         Set_Is_Immediately_Visible (Gen_Id);
+
+         Set_Actual_Subtypes (N, Current_Scope);
+         Analyze_Declarations (Declarations (N));
+         Check_Completion;
+         Analyze (Handled_Statement_Sequence (N));
+
+         Save_Global_References (Original_Node (N));
+
+         --  Prior to exiting the scope, include generic formals again
+         --  (if any are present) in the set of local entities.
+
+         if Present (First_Ent) then
+            Set_First_Entity (Gen_Id, First_Ent);
+         end if;
+
+      end;
+
+      End_Scope;
+      Check_Subprogram_Order (N);
+
+      --  Outside of its body, unit is generic again.
+
+      Set_Ekind (Gen_Id, Kind);
+      Set_Ekind (Nam, E_Subprogram_Body);
+      Generate_Reference (Gen_Id, Nam, 'b');
+      Style.Check_Identifier (Nam, Gen_Id);
+      End_Generic;
+
+   end Analyze_Generic_Subprogram_Body;
+
+   -----------------------------
+   -- Analyze_Operator_Symbol --
+   -----------------------------
+
+   --  An operator symbol such as "+" or "and" may appear in context where
+   --  the literal denotes an entity name, such as  "+"(x, y) or in a
+   --  context when it is just a string, as in  (conjunction = "or"). In
+   --  these cases the parser generates this node, and the semantics does
+   --  the disambiguation. Other such case are actuals in an instantiation,
+   --  the generic unit in an instantiation, and pragma arguments.
+
+   procedure Analyze_Operator_Symbol (N : Node_Id) is
+      Par : constant Node_Id := Parent (N);
+
+   begin
+      if        (Nkind (Par) = N_Function_Call and then N = Name (Par))
+        or else  Nkind (Par) = N_Function_Instantiation
+        or else (Nkind (Par) = N_Indexed_Component and then N = Prefix (Par))
+        or else (Nkind (Par) = N_Pragma_Argument_Association
+                   and then not Is_Pragma_String_Literal (Par))
+        or else  Nkind (Par) = N_Subprogram_Renaming_Declaration
+        or else  (Nkind (Par) = N_Attribute_Reference
+                   and then Attribute_Name (Par) /= Name_Value)
+      then
+         Find_Direct_Name (N);
+
+      else
+         Change_Operator_Symbol_To_String_Literal (N);
+         Analyze (N);
+      end if;
+   end Analyze_Operator_Symbol;
+
+   -----------------------------------
+   -- Analyze_Parameter_Association --
+   -----------------------------------
+
+   procedure Analyze_Parameter_Association (N : Node_Id) is
+   begin
+      Analyze (Explicit_Actual_Parameter (N));
+   end Analyze_Parameter_Association;
+
+   ----------------------------
+   -- Analyze_Procedure_Call --
+   ----------------------------
+
+   procedure Analyze_Procedure_Call (N : Node_Id) is
+      Loc     : constant Source_Ptr := Sloc (N);
+      P       : constant Node_Id    := Name (N);
+      Actuals : constant List_Id    := Parameter_Associations (N);
+      Actual  : Node_Id;
+      New_N   : Node_Id;
+
+      procedure Analyze_Call_And_Resolve;
+      --  Do Analyze and Resolve calls for procedure call
+
+      procedure Analyze_Call_And_Resolve is
+      begin
+         if Nkind (N) = N_Procedure_Call_Statement then
+            Analyze_Call (N);
+            Resolve (N, Standard_Void_Type);
+         else
+            Analyze (N);
+         end if;
+      end Analyze_Call_And_Resolve;
+
+   --  Start of processing for Analyze_Procedure_Call
+
+   begin
+      --  The syntactic construct: PREFIX ACTUAL_PARAMETER_PART can denote
+      --  a procedure call or an entry call. The prefix may denote an access
+      --  to subprogram type, in which case an implicit dereference applies.
+      --  If the prefix is an indexed component (without implicit defererence)
+      --  then the construct denotes a call to a member of an entire family.
+      --  If the prefix is a simple name, it may still denote a call to a
+      --  parameterless member of an entry family. Resolution of these various
+      --  interpretations is delicate.
+
+      Analyze (P);
+
+      --  If error analyzing prefix, then set Any_Type as result and return
+
+      if Etype (P) = Any_Type then
+         Set_Etype (N, Any_Type);
+         return;
+      end if;
+
+      --  Otherwise analyze the parameters
+
+      if Present (Actuals) then
+         Actual := First (Actuals);
+
+         while Present (Actual) loop
+            Analyze (Actual);
+            Check_Parameterless_Call (Actual);
+            Next (Actual);
+         end loop;
+      end if;
+
+      --  Special processing for Elab_Spec and Elab_Body calls
+
+      if Nkind (P) = N_Attribute_Reference
+        and then (Attribute_Name (P) = Name_Elab_Spec
+                   or else Attribute_Name (P) = Name_Elab_Body)
+      then
+         if Present (Actuals) then
+            Error_Msg_N
+              ("no parameters allowed for this call", First (Actuals));
+            return;
+         end if;
+
+         Set_Etype (N, Standard_Void_Type);
+         Set_Analyzed (N);
+
+      elsif Is_Entity_Name (P)
+        and then Is_Record_Type (Etype (Entity (P)))
+        and then Remote_AST_I_Dereference (P)
+      then
+         return;
+
+      elsif Is_Entity_Name (P)
+        and then Ekind (Entity (P)) /= E_Entry_Family
+      then
+         if Is_Access_Type (Etype (P))
+           and then Ekind (Designated_Type (Etype (P))) = E_Subprogram_Type
+           and then No (Actuals)
+           and then Comes_From_Source (N)
+         then
+            Error_Msg_N ("missing explicit dereference in call", N);
+         end if;
+
+         Analyze_Call_And_Resolve;
+
+      --  If the prefix is the simple name of an entry family, this is
+      --  a parameterless call from within the task body itself.
+
+      elsif Is_Entity_Name (P)
+        and then Nkind (P) = N_Identifier
+        and then Ekind (Entity (P)) = E_Entry_Family
+        and then Present (Actuals)
+        and then No (Next (First (Actuals)))
+      then
+         --  Can be call to parameterless entry family. What appears to be
+         --  the sole argument is in fact the entry index. Rewrite prefix
+         --  of node accordingly. Source representation is unchanged by this
+         --  transformation.
+
+         New_N :=
+           Make_Indexed_Component (Loc,
+             Prefix =>
+               Make_Selected_Component (Loc,
+                 Prefix => New_Occurrence_Of (Scope (Entity (P)), Loc),
+                 Selector_Name => New_Occurrence_Of (Entity (P), Loc)),
+             Expressions => Actuals);
+         Set_Name (N, New_N);
+         Set_Etype (New_N, Standard_Void_Type);
+         Set_Parameter_Associations (N, No_List);
+         Analyze_Call_And_Resolve;
+
+      elsif Nkind (P) = N_Explicit_Dereference then
+         if Ekind (Etype (P)) = E_Subprogram_Type then
+            Analyze_Call_And_Resolve;
+         else
+            Error_Msg_N ("expect access to procedure in call", P);
+         end if;
+
+      --  The name can be a selected component or an indexed component
+      --  that yields an access to subprogram. Such a prefix is legal if
+      --  the call has parameter associations.
+
+      elsif Is_Access_Type (Etype (P))
+        and then Ekind (Designated_Type (Etype (P))) = E_Subprogram_Type
+      then
+         if Present (Actuals) then
+            Analyze_Call_And_Resolve;
+         else
+            Error_Msg_N ("missing explicit dereference in call ", N);
+         end if;
+
+      --  If not an access to subprogram, then the prefix must resolve to
+      --  the name of an entry, entry family, or protected operation.
+
+      --  For the case of a simple entry call, P is a selected component
+      --  where the prefix is the task and the selector name is the entry.
+      --  A call to a protected procedure will have the same syntax. If
+      --  the protected object contains overloaded operations, the entity
+      --  may appear as a function, the context will select the operation
+      --  whose type is Void.
+
+      elsif Nkind (P) = N_Selected_Component
+        and then (Ekind (Entity (Selector_Name (P))) = E_Entry
+                    or else
+                  Ekind (Entity (Selector_Name (P))) = E_Procedure
+                    or else
+                  Ekind (Entity (Selector_Name (P))) = E_Function)
+      then
+         Analyze_Call_And_Resolve;
+
+      elsif Nkind (P) = N_Selected_Component
+        and then Ekind (Entity (Selector_Name (P))) = E_Entry_Family
+        and then Present (Actuals)
+        and then No (Next (First (Actuals)))
+      then
+         --  Can be call to parameterless entry family. What appears to be
+         --  the sole argument is in fact the entry index. Rewrite prefix
+         --  of node accordingly. Source representation is unchanged by this
+         --  transformation.
+
+         New_N :=
+           Make_Indexed_Component (Loc,
+             Prefix => New_Copy (P),
+             Expressions => Actuals);
+         Set_Name (N, New_N);
+         Set_Etype (New_N, Standard_Void_Type);
+         Set_Parameter_Associations (N, No_List);
+         Analyze_Call_And_Resolve;
+
+      --  For the case of a reference to an element of an entry family, P is
+      --  an indexed component whose prefix is a selected component (task and
+      --  entry family), and whose index is the entry family index.
+
+      elsif Nkind (P) = N_Indexed_Component
+        and then Nkind (Prefix (P)) = N_Selected_Component
+        and then Ekind (Entity (Selector_Name (Prefix (P)))) = E_Entry_Family
+      then
+         Analyze_Call_And_Resolve;
+
+      --  If the prefix is the name of an entry family, it is a call from
+      --  within the task body itself.
+
+      elsif Nkind (P) = N_Indexed_Component
+        and then Nkind (Prefix (P)) = N_Identifier
+        and then Ekind (Entity (Prefix (P))) = E_Entry_Family
+      then
+         New_N :=
+           Make_Selected_Component (Loc,
+             Prefix => New_Occurrence_Of (Scope (Entity (Prefix (P))), Loc),
+             Selector_Name => New_Occurrence_Of (Entity (Prefix (P)), Loc));
+         Rewrite (Prefix (P), New_N);
+         Analyze (P);
+         Analyze_Call_And_Resolve;
+
+      --  Anything else is an error.
+
+      else
+         Error_Msg_N ("Invalid procedure or entry call", N);
+      end if;
+   end Analyze_Procedure_Call;
+
+   ------------------------------
+   -- Analyze_Return_Statement --
+   ------------------------------
+
+   procedure Analyze_Return_Statement (N : Node_Id) is
+      Loc      : constant Source_Ptr := Sloc (N);
+      Expr     : Node_Id;
+      Scope_Id : Entity_Id;
+      Kind     : Entity_Kind;
+      R_Type   : Entity_Id;
+
+   begin
+      --  Find subprogram or accept statement enclosing the return statement
+
+      Scope_Id := Empty;
+      for J in reverse 0 .. Scope_Stack.Last loop
+         Scope_Id := Scope_Stack.Table (J).Entity;
+         exit when Ekind (Scope_Id) /= E_Block and then
+                   Ekind (Scope_Id) /= E_Loop;
+      end loop;
+
+      pragma Assert (Present (Scope_Id));
+
+      Kind := Ekind (Scope_Id);
+      Expr := Expression (N);
+
+      if Kind /= E_Function
+        and then Kind /= E_Generic_Function
+        and then Kind /= E_Procedure
+        and then Kind /= E_Generic_Procedure
+        and then Kind /= E_Entry
+        and then Kind /= E_Entry_Family
+      then
+         Error_Msg_N ("illegal context for return statement", N);
+
+      elsif Present (Expr) then
+         if Kind = E_Function or else Kind = E_Generic_Function then
+            Set_Return_Present (Scope_Id);
+            R_Type := Etype (Scope_Id);
+            Set_Return_Type (N, R_Type);
+            Analyze_And_Resolve (Expr, R_Type);
+
+            if (Is_Class_Wide_Type (Etype (Expr))
+                 or else Is_Dynamically_Tagged (Expr))
+              and then not Is_Class_Wide_Type (R_Type)
+            then
+               Error_Msg_N
+                 ("dynamically tagged expression not allowed!", Expr);
+            end if;
+
+            Apply_Constraint_Check (Expr, R_Type);
+
+            --  ??? A real run-time accessibility check is needed
+            --  in cases involving dereferences of access parameters.
+            --  For now we just check the static cases.
+
+            if Is_Return_By_Reference_Type (Etype (Scope_Id))
+              and then Object_Access_Level (Expr)
+                > Subprogram_Access_Level (Scope_Id)
+            then
+               Rewrite (N, Make_Raise_Program_Error (Loc));
+               Analyze (N);
+
+               Error_Msg_N
+                 ("cannot return a local value by reference?", N);
+               Error_Msg_NE
+                 ("& will be raised at run time?!",
+                  N, Standard_Program_Error);
+            end if;
+
+         elsif Kind = E_Procedure or else Kind = E_Generic_Procedure then
+            Error_Msg_N ("procedure cannot return value (use function)", N);
+
+         else
+            Error_Msg_N ("accept statement cannot return value", N);
+         end if;
+
+      --  No expression present
+
+      else
+         if Kind = E_Function or Kind = E_Generic_Function then
+            Error_Msg_N ("missing expression in return from function", N);
+         end if;
+
+         if (Ekind (Scope_Id) = E_Procedure
+              or else Ekind (Scope_Id) = E_Generic_Procedure)
+           and then  No_Return (Scope_Id)
+         then
+            Error_Msg_N
+              ("RETURN statement not allowed (No_Return)", N);
+         end if;
+      end if;
+
+      Check_Unreachable_Code (N);
+   end Analyze_Return_Statement;
+
+   ------------------
+   -- Analyze_Spec --
+   ------------------
+
+   function Analyze_Spec (N : Node_Id) return Entity_Id is
+      Designator : constant Entity_Id := Defining_Entity (N);
+      Formals    : constant List_Id   := Parameter_Specifications (N);
+      Typ        : Entity_Id;
+
+   begin
+      Generate_Definition (Designator);
+
+      if Nkind (N) = N_Function_Specification then
+         Set_Ekind (Designator, E_Function);
+         Set_Mechanism (Designator, Default_Mechanism);
+
+         if Subtype_Mark (N) /= Error then
+            Find_Type (Subtype_Mark (N));
+            Typ := Entity (Subtype_Mark (N));
+            Set_Etype (Designator, Typ);
+
+            if (Ekind (Typ) = E_Incomplete_Type
+                 or else (Is_Class_Wide_Type (Typ)
+                           and then
+                             Ekind (Root_Type (Typ)) = E_Incomplete_Type))
+            then
+               Error_Msg_N
+                 ("invalid use of incomplete type", Subtype_Mark (N));
+            end if;
+
+         else
+            Set_Etype (Designator, Any_Type);
+         end if;
+
+      else
+         Set_Ekind (Designator, E_Procedure);
+         Set_Etype (Designator, Standard_Void_Type);
+      end if;
+
+      if Present (Formals) then
+         Set_Scope (Designator, Current_Scope);
+         New_Scope (Designator);
+         Process_Formals (Designator, Formals, N);
+         End_Scope;
+      end if;
+
+      if Nkind (N) = N_Function_Specification then
+         if Nkind (Designator) = N_Defining_Operator_Symbol then
+            Valid_Operator_Definition (Designator);
+         end if;
+
+         May_Need_Actuals (Designator);
+
+         if Is_Abstract (Etype (Designator))
+           and then Nkind (Parent (N)) /= N_Abstract_Subprogram_Declaration
+         then
+            Error_Msg_N
+              ("function that returns abstract type must be abstract", N);
+         end if;
+      end if;
+
+      return Designator;
+   end Analyze_Spec;
+
+   -----------------------------
+   -- Analyze_Subprogram_Body --
+   -----------------------------
+
+   --  This procedure is called for regular subprogram bodies, generic bodies,
+   --  and for subprogram stubs of both kinds. In the case of stubs, only the
+   --  specification matters, and is used to create a proper declaration for
+   --  the subprogram, or to perform conformance checks.
+
+   procedure Analyze_Subprogram_Body (N : Node_Id) is
+      Body_Spec : constant Node_Id    := Specification (N);
+      Body_Id   : Entity_Id           := Defining_Entity (Body_Spec);
+      Prev_Id   : constant Entity_Id  := Current_Entity_In_Scope (Body_Id);
+
+      HSS         : Node_Id;
+      Spec_Id     : Entity_Id;
+      Spec_Decl   : Node_Id   := Empty;
+      Last_Formal : Entity_Id := Empty;
+      Conformant  : Boolean;
+      Missing_Ret : Boolean;
+
+   begin
+      if Debug_Flag_C then
+         Write_Str ("====  Compiling subprogram body ");
+         Write_Name (Chars (Body_Id));
+         Write_Str (" from ");
+         Write_Location (Sloc (N));
+         Write_Eol;
+      end if;
+
+      Trace_Scope (N, Body_Id, " Analyze subprogram");
+
+      --  Generic subprograms are handled separately. They always have
+      --  a generic specification. Determine whether current scope has
+      --  a previous declaration.
+
+      --  If the subprogram body is defined within an instance of the
+      --  same name, the instance appears as a package renaming, and
+      --  will be hidden within the subprogram.
+
+      if Present (Prev_Id)
+        and then not Is_Overloadable (Prev_Id)
+        and then (Nkind (Parent (Prev_Id)) /= N_Package_Renaming_Declaration
+                   or else Comes_From_Source (Prev_Id))
+      then
+         if Ekind (Prev_Id) = E_Generic_Procedure
+           or else Ekind (Prev_Id) = E_Generic_Function
+         then
+            Spec_Id := Prev_Id;
+            Set_Is_Compilation_Unit (Body_Id, Is_Compilation_Unit (Spec_Id));
+            Set_Is_Child_Unit       (Body_Id, Is_Child_Unit       (Spec_Id));
+
+            Analyze_Generic_Subprogram_Body (N, Spec_Id);
+            return;
+
+         else
+            --  Previous entity conflicts with subprogram name.
+            --  Attempting to enter name will post error.
+
+            Enter_Name (Body_Id);
+            return;
+         end if;
+
+      --  Non-generic case, find the subprogram declaration, if one was
+      --  seen, or enter new overloaded entity in the current scope.
+      --  If the current_entity is the body_id itself, the unit is being
+      --  analyzed as part of the context of one of its subunits. No need
+      --  to redo the analysis.
+
+      elsif Prev_Id = Body_Id
+        and then Has_Completion (Body_Id)
+      then
+         return;
+
+      else
+         Body_Id := Analyze_Spec (Body_Spec);
+
+         if Nkind (N) = N_Subprogram_Body_Stub
+           or else No (Corresponding_Spec (N))
+         then
+            Spec_Id := Find_Corresponding_Spec (N);
+
+            --  If this is a duplicate body, no point in analyzing it
+
+            if Error_Posted (N) then
+               return;
+            end if;
+
+            --  A subprogram body should cause freezing of its own
+            --  declaration, but if there was no previous explicit
+            --  declaration, then the subprogram will get frozen too
+            --  late (there may be code within the body that depends
+            --  on the subprogram having been frozen, such as uses of
+            --  extra formals), so we force it to be frozen here.
+            --  Same holds if the body and the spec are compilation units.
+
+            if No (Spec_Id) then
+               Freeze_Before (N, Body_Id);
+
+            elsif Nkind (Parent (N)) = N_Compilation_Unit then
+               Freeze_Before (N, Spec_Id);
+            end if;
+         else
+            Spec_Id := Corresponding_Spec (N);
+         end if;
+      end if;
+
+      if No (Spec_Id)
+        and then Comes_From_Source (N)
+        and then Is_Protected_Type (Current_Scope)
+      then
+         --  Fully private operation in the body of the protected type. We
+         --  must create a declaration for the subprogram, in order to attach
+         --  the protected subprogram that will be used in internal calls.
+
+         declare
+            Loc      : constant Source_Ptr := Sloc (N);
+            Decl     : Node_Id;
+            Plist    : List_Id;
+            Formal   : Entity_Id;
+            New_Spec : Node_Id;
+
+         begin
+            Formal := First_Formal (Body_Id);
+
+            --  The protected operation always has at least one formal,
+            --  namely the object itself, but it is only placed in the
+            --  parameter list if expansion is enabled.
+
+            if Present (Formal)
+              or else Expander_Active
+            then
+               Plist := New_List;
+
+            else
+               Plist := No_List;
+            end if;
+
+            while Present (Formal) loop
+               Append
+                 (Make_Parameter_Specification (Loc,
+                   Defining_Identifier =>
+                     Make_Defining_Identifier (Sloc (Formal),
+                       Chars => Chars (Formal)),
+                   In_Present  => In_Present (Parent (Formal)),
+                   Out_Present => Out_Present (Parent (Formal)),
+                   Parameter_Type =>
+                     New_Reference_To (Etype (Formal), Loc),
+                   Expression =>
+                     New_Copy_Tree (Expression (Parent (Formal)))),
+                 Plist);
+
+               Next_Formal (Formal);
+            end loop;
+
+            if Nkind (Body_Spec) = N_Procedure_Specification then
+               New_Spec :=
+                 Make_Procedure_Specification (Loc,
+                    Defining_Unit_Name =>
+                      Make_Defining_Identifier (Sloc (Body_Id),
+                        Chars => Chars (Body_Id)),
+                    Parameter_Specifications => Plist);
+            else
+               New_Spec :=
+                 Make_Function_Specification (Loc,
+                    Defining_Unit_Name =>
+                      Make_Defining_Identifier (Sloc (Body_Id),
+                        Chars => Chars (Body_Id)),
+                    Parameter_Specifications => Plist,
+                    Subtype_Mark => New_Occurrence_Of (Etype (Body_Id), Loc));
+            end if;
+
+            Decl :=
+              Make_Subprogram_Declaration (Loc,
+                Specification => New_Spec);
+            Insert_Before (N, Decl);
+            Analyze (Decl);
+            Spec_Id := Defining_Unit_Name (New_Spec);
+            Set_Has_Completion (Spec_Id);
+            Set_Convention (Spec_Id, Convention_Protected);
+         end;
+
+      elsif Present (Spec_Id) then
+         Spec_Decl := Unit_Declaration_Node (Spec_Id);
+      end if;
+
+      --  Place subprogram on scope stack, and make formals visible. If there
+      --  is a spec, the visible entity remains that of the spec.
+
+      if Present (Spec_Id) then
+         Generate_Reference (Spec_Id, Body_Id, 'b');
+         Style.Check_Identifier (Body_Id, Spec_Id);
+
+         Set_Is_Compilation_Unit (Body_Id, Is_Compilation_Unit (Spec_Id));
+         Set_Is_Child_Unit       (Body_Id, Is_Child_Unit       (Spec_Id));
+
+         if Is_Abstract (Spec_Id) then
+            Error_Msg_N ("an abstract subprogram cannot have a body", N);
+            return;
+         else
+            Set_Convention (Body_Id, Convention (Spec_Id));
+            Set_Has_Completion (Spec_Id);
+
+            if Is_Protected_Type (Scope (Spec_Id)) then
+               Set_Privals_Chain (Spec_Id, New_Elmt_List);
+            end if;
+
+            --  If this is a body generated for a renaming, do not check for
+            --  full conformance. The check is redundant, because the spec of
+            --  the body is a copy of the spec in the renaming declaration,
+            --  and the test can lead to spurious errors on nested defaults.
+
+            if Present (Spec_Decl)
+              and then Nkind (Original_Node (Spec_Decl)) =
+                N_Subprogram_Renaming_Declaration
+              and then not Comes_From_Source (N)
+            then
+               Conformant := True;
+            else
+               Check_Conformance
+                 (Body_Id, Spec_Id,
+                   Fully_Conformant, True, Conformant, Body_Id);
+            end if;
+
+            --  If the body is not fully conformant, we have to decide if we
+            --  should analyze it or not. If it has a really messed up profile
+            --  then we probably should not analyze it, since we will get too
+            --  many bogus messages.
+
+            --  Our decision is to go ahead in the non-fully conformant case
+            --  only if it is at least mode conformant with the spec. Note
+            --  that the call to Check_Fully_Conformant has issued the proper
+            --  error messages to complain about the lack of conformance.
+
+            if not Conformant
+              and then not Mode_Conformant (Body_Id, Spec_Id)
+            then
+               return;
+            end if;
+         end if;
+
+         --  Generate references from body formals to spec formals
+         --  and also set the Spec_Entity fields for all formals
+
+         if Spec_Id /= Body_Id then
+            declare
+               Fs : Entity_Id;
+               Fb : Entity_Id;
+
+            begin
+               Fs := First_Formal (Spec_Id);
+               Fb := First_Formal (Body_Id);
+               while Present (Fs) loop
+                  Generate_Reference (Fs, Fb, 'b');
+                  Style.Check_Identifier (Fb, Fs);
+                  Set_Spec_Entity (Fb, Fs);
+                  Next_Formal (Fs);
+                  Next_Formal (Fb);
+               end loop;
+            end;
+         end if;
+
+         if Nkind (N) /= N_Subprogram_Body_Stub then
+            Set_Corresponding_Spec (N, Spec_Id);
+            Install_Formals (Spec_Id);
+            Last_Formal := Last_Entity (Spec_Id);
+            New_Scope (Spec_Id);
+
+            --  Make sure that the subprogram is immediately visible. For
+            --  child units that have no separate spec this is indispensable.
+            --  Otherwise it is safe albeit redundant.
+
+            Set_Is_Immediately_Visible (Spec_Id);
+         end if;
+
+         Set_Corresponding_Body (Unit_Declaration_Node (Spec_Id), Body_Id);
+         Set_Ekind (Body_Id, E_Subprogram_Body);
+         Set_Scope (Body_Id, Scope (Spec_Id));
+
+      --  Case of subprogram body with no previous spec
+
+      else
+         if Style_Check
+           and then Comes_From_Source (Body_Id)
+           and then not Suppress_Style_Checks (Body_Id)
+           and then not In_Instance
+         then
+            Style.Body_With_No_Spec (N);
+         end if;
+
+         New_Overloaded_Entity (Body_Id);
+
+         if Nkind (N) /= N_Subprogram_Body_Stub then
+            Set_Acts_As_Spec (N);
+            Generate_Definition (Body_Id);
+            Install_Formals (Body_Id);
+            New_Scope (Body_Id);
+         end if;
+      end if;
+
+      --  If this is the proper body of a stub, we must verify that the stub
+      --  conforms to the body, and to the previous spec if one was present.
+      --  we know already that the body conforms to that spec. This test is
+      --  only required for subprograms that come from source.
+
+      if Nkind (Parent (N)) = N_Subunit
+        and then Comes_From_Source (N)
+        and then not Error_Posted (Body_Id)
+      then
+         declare
+            Conformant : Boolean := False;
+            Old_Id     : Entity_Id :=
+                           Defining_Entity
+                             (Specification (Corresponding_Stub (Parent (N))));
+
+         begin
+            if No (Spec_Id) then
+               Check_Fully_Conformant (Body_Id, Old_Id);
+
+            else
+               Check_Conformance
+                 (Body_Id, Old_Id, Fully_Conformant, False, Conformant);
+
+               if not Conformant then
+
+                  --  The stub was taken to be a new declaration. Indicate
+                  --  that it lacks a body.
+
+                  Set_Has_Completion (Old_Id, False);
+               end if;
+            end if;
+         end;
+      end if;
+
+      Set_Has_Completion (Body_Id);
+      Check_Eliminated (Body_Id);
+
+      if Nkind (N) = N_Subprogram_Body_Stub then
+         return;
+
+      elsif  Present (Spec_Id)
+        and then Expander_Active
+        and then Has_Pragma_Inline (Spec_Id)
+        and then (Front_End_Inlining
+                   or else
+                 (No_Run_Time and then Is_Always_Inlined (Spec_Id)))
+      then
+         if Build_Body_To_Inline (N, Spec_Id, Copy_Separate_Tree (N)) then
+            null;
+         end if;
+      end if;
+
+      --  Here we have a real body, not a stub
+
+      HSS := Handled_Statement_Sequence (N);
+      Set_Actual_Subtypes (N, Current_Scope);
+      Analyze_Declarations (Declarations (N));
+      Check_Completion;
+      Analyze (HSS);
+      Process_End_Label (HSS, 't');
+      End_Scope;
+      Check_Subprogram_Order (N);
+
+      --  If we have a separate spec, then the analysis of the declarations
+      --  caused the entities in the body to be chained to the spec id, but
+      --  we want them chained to the body id. Only the formal parameters
+      --  end up chained to the spec id in this case.
+
+      if Present (Spec_Id) then
+
+         --  If a parent unit is categorized, the context of a subunit
+         --  must conform to the categorization. Conversely, if a child
+         --  unit is categorized, the parents themselves must conform.
+
+         if Nkind (Parent (N)) = N_Subunit then
+            Validate_Categorization_Dependency (N, Spec_Id);
+
+         elsif Is_Child_Unit (Spec_Id) then
+            Validate_Categorization_Dependency
+              (Unit_Declaration_Node (Spec_Id), Spec_Id);
+         end if;
+
+         if Present (Last_Formal) then
+            Set_Next_Entity
+              (Last_Entity (Body_Id), Next_Entity (Last_Formal));
+            Set_Next_Entity (Last_Formal, Empty);
+            Set_Last_Entity (Body_Id, Last_Entity (Spec_Id));
+            Set_Last_Entity (Spec_Id, Last_Formal);
+
+         else
+            Set_First_Entity (Body_Id, First_Entity (Spec_Id));
+            Set_Last_Entity  (Body_Id, Last_Entity (Spec_Id));
+            Set_First_Entity (Spec_Id, Empty);
+            Set_Last_Entity  (Spec_Id, Empty);
+         end if;
+      end if;
+
+      --  If function, check return statements
+
+      if Nkind (Body_Spec) = N_Function_Specification then
+         declare
+            Id : Entity_Id;
+
+         begin
+            if Present (Spec_Id) then
+               Id := Spec_Id;
+            else
+               Id := Body_Id;
+            end if;
+
+            if Return_Present (Id) then
+               Check_Returns (HSS, 'F', Missing_Ret);
+
+               if Missing_Ret then
+                  Set_Has_Missing_Return (Id);
+               end if;
+
+            elsif not Is_Machine_Code_Subprogram (Id) then
+               Error_Msg_N ("missing RETURN statement in function body", N);
+            end if;
+         end;
+
+      --  If procedure with No_Return, check returns
+
+      elsif Nkind (Body_Spec) = N_Procedure_Specification
+        and then Present (Spec_Id)
+        and then No_Return (Spec_Id)
+      then
+         Check_Returns (HSS, 'P', Missing_Ret);
+      end if;
+
+      --  Don't worry about checking for variables that are never modified
+      --  if the first statement of the body is a raise statement, since
+      --  we assume this is some kind of stub. We ignore a label generated
+      --  by the exception stuff for the purpose of this test.
+
+      declare
+         Stm : Node_Id := First (Statements (HSS));
+
+      begin
+         if Nkind (Stm) = N_Label then
+            Next (Stm);
+         end if;
+
+         if Nkind (Original_Node (Stm)) = N_Raise_Statement then
+            return;
+         end if;
+      end;
+
+      --  Check for variables that are never modified
+
+      declare
+         E1, E2 : Entity_Id;
+
+      begin
+         --  If there is a separate spec, then transfer Not_Source_Assigned
+         --  flags from out parameters to the corresponding entities in the
+         --  body. The reason we do that is we want to post error flags on
+         --  the body entities, not the spec entities.
+
+         if Present (Spec_Id) then
+            E1 := First_Entity (Spec_Id);
+
+            while Present (E1) loop
+               if Ekind (E1) = E_Out_Parameter then
+                  E2 := First_Entity (Body_Id);
+
+                  loop
+                     --  If no matching body entity, then we already had
+                     --  a detected error of some kind, so just forget
+                     --  about worrying about these warnings.
+
+                     if No (E2) then
+                        return;
+                     end if;
+
+                     exit when Chars (E1) = Chars (E2);
+                     Next_Entity (E2);
+                  end loop;
+
+                  Set_Not_Source_Assigned (E2, Not_Source_Assigned (E1));
+               end if;
+
+               Next_Entity (E1);
+            end loop;
+         end if;
+
+         Check_References (Body_Id);
+      end;
+   end Analyze_Subprogram_Body;
+
+   ------------------------------------
+   -- Analyze_Subprogram_Declaration --
+   ------------------------------------
+
+   procedure Analyze_Subprogram_Declaration (N : Node_Id) is
+      Designator : constant Entity_Id := Analyze_Spec (Specification (N));
+      Scop        : constant Entity_Id := Current_Scope;
+
+   --  Start of processing for Analyze_Subprogram_Declaration
+
+   begin
+      Generate_Definition (Designator);
+
+      --  Check for RCI unit subprogram declarations against in-lined
+      --  subprograms and subprograms having access parameter or limited
+      --  parameter without Read and Write (RM E.2.3(12-13)).
+
+      Validate_RCI_Subprogram_Declaration (N);
+
+      Trace_Scope
+        (N,
+         Defining_Entity (N),
+         " Analyze subprogram spec. ");
+
+      if Debug_Flag_C then
+         Write_Str ("====  Compiling subprogram spec ");
+         Write_Name (Chars (Designator));
+         Write_Str (" from ");
+         Write_Location (Sloc (N));
+         Write_Eol;
+      end if;
+
+      New_Overloaded_Entity (Designator);
+      Check_Delayed_Subprogram (Designator);
+      Set_Suppress_Elaboration_Checks
+        (Designator, Elaboration_Checks_Suppressed (Designator));
+
+      if Scop /= Standard_Standard
+        and then not Is_Child_Unit (Designator)
+      then
+         Set_Is_Pure (Designator,
+           Is_Pure (Scop) and then Is_Library_Level_Entity (Designator));
+         Set_Is_Remote_Call_Interface (
+           Designator, Is_Remote_Call_Interface (Scop));
+         Set_Is_Remote_Types (Designator, Is_Remote_Types (Scop));
+
+      else
+         --  For a compilation unit, check for library-unit pragmas.
+
+         New_Scope (Designator);
+         Set_Categorization_From_Pragmas (N);
+         Validate_Categorization_Dependency (N, Designator);
+         Pop_Scope;
+      end if;
+
+      --  For a compilation unit, set body required. This flag will only be
+      --  reset if a valid Import or Interface pragma is processed later on.
+
+      if Nkind (Parent (N)) = N_Compilation_Unit then
+         Set_Body_Required (Parent (N), True);
+      end if;
+
+      Check_Eliminated (Designator);
+   end Analyze_Subprogram_Declaration;
+
+   --------------------------
+   -- Build_Body_To_Inline --
+   --------------------------
+
+   function Build_Body_To_Inline
+     (N         : Node_Id;
+      Subp      : Entity_Id;
+      Orig_Body : Node_Id) return Boolean
+   is
+      Decl : constant Node_Id := Unit_Declaration_Node (Subp);
+      Original_Body   : Node_Id;
+      Body_To_Analyze : Node_Id;
+      Max_Size        : constant := 10;
+      Stat_Count      : Integer := 0;
+
+      function Has_Excluded_Declaration (Decls : List_Id) return Boolean;
+      --  Check for declarations that make inlining not worthwhile.
+
+      function Has_Excluded_Statement   (Stats : List_Id) return Boolean;
+      --  Check for statements that make inlining not worthwhile: any
+      --  tasking statement, nested at any level. Keep track of total
+      --  number of elementary statements, as a measure of acceptable size.
+
+      function Has_Pending_Instantiation return Boolean;
+      --  If some enclosing body contains instantiations that appear before
+      --  the corresponding generic body, the enclosing body has a freeze node
+      --  so that it can be elaborated after the generic itself. This might
+      --  conflict with subsequent inlinings, so that it is unsafe to try to
+      --  inline in such a case.
+
+      -------------------
+      -- Cannot_Inline --
+      -------------------
+
+      procedure Cannot_Inline (Msg : String; N : Node_Id);
+      --  If subprogram has pragma Inline_Always, it is an error if
+      --  it cannot be inlined. Otherwise, emit a warning.
+
+      procedure Cannot_Inline (Msg : String; N : Node_Id) is
+      begin
+         if Is_Always_Inlined (Subp) then
+            Error_Msg_NE (Msg (1 .. Msg'Length - 1), N, Subp);
+
+         elsif Ineffective_Inline_Warnings then
+            Error_Msg_NE (Msg, N, Subp);
+         end if;
+      end Cannot_Inline;
+
+      ------------------------------
+      -- Has_Excluded_Declaration --
+      ------------------------------
+
+      function Has_Excluded_Declaration (Decls : List_Id) return Boolean is
+         D : Node_Id;
+
+      begin
+         D := First (Decls);
+
+         while Present (D) loop
+            if        Nkind (D) = N_Function_Instantiation
+              or else Nkind (D) = N_Protected_Type_Declaration
+              or else Nkind (D) = N_Package_Declaration
+              or else Nkind (D) = N_Package_Instantiation
+              or else Nkind (D) = N_Subprogram_Body
+              or else Nkind (D) = N_Procedure_Instantiation
+              or else Nkind (D) = N_Task_Type_Declaration
+            then
+               Cannot_Inline
+                 ("\declaration prevents front-end inlining of&?", D);
+               return True;
+            end if;
+
+            Next (D);
+         end loop;
+
+         return False;
+
+      end Has_Excluded_Declaration;
+
+      ----------------------------
+      -- Has_Excluded_Statement --
+      ----------------------------
+
+      function Has_Excluded_Statement (Stats : List_Id) return Boolean is
+         S : Node_Id;
+         E : Node_Id;
+
+      begin
+         S := First (Stats);
+
+         while Present (S) loop
+            Stat_Count := Stat_Count + 1;
+
+            if Nkind (S) = N_Abort_Statement
+              or else Nkind (S) = N_Asynchronous_Select
+              or else Nkind (S) = N_Conditional_Entry_Call
+              or else Nkind (S) = N_Delay_Relative_Statement
+              or else Nkind (S) = N_Delay_Until_Statement
+              or else Nkind (S) = N_Selective_Accept
+              or else Nkind (S) = N_Timed_Entry_Call
+            then
+               Cannot_Inline
+                 ("\statement prevents front-end inlining of&?", S);
+               return True;
+
+            elsif Nkind (S) = N_Block_Statement then
+               if Present (Declarations (S))
+                 and then Has_Excluded_Declaration (Declarations (S))
+               then
+                  return True;
+
+               elsif Present (Handled_Statement_Sequence (S))
+                  and then
+                    (Present
+                      (Exception_Handlers (Handled_Statement_Sequence (S)))
+                     or else
+                       Has_Excluded_Statement
+                         (Statements (Handled_Statement_Sequence (S))))
+               then
+                  return True;
+               end if;
+
+            elsif Nkind (S) = N_Case_Statement then
+               E := First (Alternatives (S));
+
+               while Present (E) loop
+                  if Has_Excluded_Statement (Statements (E)) then
+                     return True;
+                  end if;
+
+                  Next (E);
+               end loop;
+
+            elsif Nkind (S) = N_If_Statement then
+               if Has_Excluded_Statement (Then_Statements (S)) then
+                  return True;
+               end if;
+
+               if Present (Elsif_Parts (S)) then
+                  E := First (Elsif_Parts (S));
+
+                  while Present (E) loop
+                     if Has_Excluded_Statement (Then_Statements (E)) then
+                        return True;
+                     end if;
+                     Next (E);
+                  end loop;
+               end if;
+
+               if Present (Else_Statements (S))
+                 and then Has_Excluded_Statement (Else_Statements (S))
+               then
+                  return True;
+               end if;
+
+            elsif Nkind (S) = N_Loop_Statement
+              and then Has_Excluded_Statement (Statements (S))
+            then
+               return True;
+            end if;
+
+            Next (S);
+         end loop;
+
+         return False;
+      end Has_Excluded_Statement;
+
+      -------------------------------
+      -- Has_Pending_Instantiation --
+      -------------------------------
+
+      function Has_Pending_Instantiation return Boolean is
+         S : Entity_Id := Current_Scope;
+
+      begin
+         while Present (S) loop
+            if Is_Compilation_Unit (S)
+              or else Is_Child_Unit (S)
+            then
+               return False;
+            elsif Ekind (S) = E_Package
+              and then Has_Forward_Instantiation (S)
+            then
+               return True;
+            end if;
+
+            S := Scope (S);
+         end loop;
+
+         return False;
+      end Has_Pending_Instantiation;
+
+   --  Start of processing for Build_Body_To_Inline
+
+   begin
+      if Nkind (Decl) = N_Subprogram_Declaration
+        and then Present (Body_To_Inline (Decl))
+      then
+         return True;    --  Done already.
+
+      --  Functions that return unconstrained composite types will require
+      --  secondary stack handling, and cannot currently be inlined.
+
+      elsif Ekind (Subp) = E_Function
+        and then not Is_Scalar_Type (Etype (Subp))
+        and then not Is_Access_Type (Etype (Subp))
+        and then not Is_Constrained (Etype (Subp))
+      then
+         Cannot_Inline
+           ("unconstrained return type prevents front-end inlining of&?", N);
+         return False;
+      end if;
+
+      --  We need to capture references to the formals in order to substitute
+      --  the actuals at the point of inlining, i.e. instantiation. To treat
+      --  the formals as globals to the body to inline, we nest it within
+      --  a dummy parameterless subprogram, declared within the real one.
+
+      Original_Body := Orig_Body;
+
+      --  Within an instance, the current tree is already the result of
+      --  a generic copy, and not what we need for subsequent inlining.
+      --  We create the required body by doing an instantiating copy, to
+      --  obtain the proper partially analyzed tree.
+
+      if In_Instance then
+         if No (Generic_Parent (Specification (N))) then
+            return False;
+
+         elsif Is_Child_Unit (Scope (Current_Scope)) then
+            return False;
+
+         elsif Scope (Current_Scope) = Cunit_Entity (Main_Unit) then
+
+            --  compiling an instantiation. There is no point in generating
+            --  bodies to inline, because they will not be used.
+
+            return False;
+
+         else
+            Body_To_Analyze :=
+              Copy_Generic_Node
+                (Generic_Parent (Specification (N)), Empty,
+                   Instantiating => True);
+         end if;
+      else
+         Body_To_Analyze :=
+           Copy_Generic_Node (Original_Body, Empty,
+             Instantiating => False);
+      end if;
+
+      Set_Parameter_Specifications (Specification (Original_Body), No_List);
+      Set_Defining_Unit_Name (Specification (Original_Body),
+        Make_Defining_Identifier (Sloc (N), New_Internal_Name ('S')));
+      Set_Corresponding_Spec (Original_Body, Empty);
+
+      if Ekind (Subp) = E_Function then
+         Set_Subtype_Mark (Specification (Original_Body),
+           New_Occurrence_Of (Etype (Subp), Sloc (N)));
+      end if;
+
+      if Present (Declarations (Orig_Body))
+        and then Has_Excluded_Declaration (Declarations (Orig_Body))
+      then
+         return False;
+      end if;
+
+      if Present (Handled_Statement_Sequence (N)) then
+         if
+          (Present (Exception_Handlers (Handled_Statement_Sequence (N))))
+         then
+            Cannot_Inline ("handler prevents front-end inlining of&?",
+               First (Exception_Handlers (Handled_Statement_Sequence (N))));
+            return False;
+         elsif
+           Has_Excluded_Statement
+             (Statements (Handled_Statement_Sequence (N)))
+         then
+            return False;
+         end if;
+      end if;
+
+      --  We do not inline a subprogram  that is too large, unless it is
+      --  marked Inline_Always. This pragma does not suppress the other
+      --  checks on inlining (forbidden declarations, handlers, etc).
+
+      if Stat_Count > Max_Size
+        and then not Is_Always_Inlined (Subp)
+      then
+         Cannot_Inline ("body is too large for front-end inlining of&?", N);
+         return False;
+      end if;
+
+      if Has_Pending_Instantiation then
+         Cannot_Inline
+           ("cannot inline& because of forward instance within enclosing body",
+             N);
+         return False;
+      end if;
+
+      Body_To_Analyze := Copy_Generic_Node (Original_Body, Empty, False);
+
+      --  Set return type of function, which is also global and does not need
+      --  to be resolved.
+
+      if Ekind (Subp) = E_Function then
+         Set_Subtype_Mark (Specification (Body_To_Analyze),
+           New_Occurrence_Of (Etype (Subp), Sloc (N)));
+      end if;
+
+      if No (Declarations (N)) then
+         Set_Declarations (N, New_List (Body_To_Analyze));
+      else
+         Append (Body_To_Analyze, Declarations (N));
+      end if;
+
+      Expander_Mode_Save_And_Set (False);
+
+      Analyze (Body_To_Analyze);
+      New_Scope (Defining_Entity (Body_To_Analyze));
+      Save_Global_References (Original_Body);
+      End_Scope;
+      Remove (Body_To_Analyze);
+
+      Expander_Mode_Restore;
+      Set_Body_To_Inline (Decl, Original_Body);
+      Set_Is_Inlined (Subp);
+      return True;
+
+   end Build_Body_To_Inline;
+
+   -----------------------
+   -- Check_Conformance --
+   -----------------------
+
+   procedure Check_Conformance
+     (New_Id   : Entity_Id;
+      Old_Id   : Entity_Id;
+      Ctype    : Conformance_Type;
+      Errmsg   : Boolean;
+      Conforms : out Boolean;
+      Err_Loc  : Node_Id := Empty;
+      Get_Inst : Boolean := False)
+   is
+      Old_Type   : constant Entity_Id := Etype (Old_Id);
+      New_Type   : constant Entity_Id := Etype (New_Id);
+      Old_Formal : Entity_Id;
+      New_Formal : Entity_Id;
+
+      procedure Conformance_Error (Msg : String; N : Node_Id := New_Id);
+      --  Post error message for conformance error on given node.
+      --  Two messages are output. The first points to the previous
+      --  declaration with a general "no conformance" message.
+      --  The second is the detailed reason, supplied as Msg. The
+      --  parameter N provide information for a possible & insertion
+      --  in the message, and also provides the location for posting
+      --  the message in the absence of a specified Err_Loc location.
+
+      -----------------------
+      -- Conformance_Error --
+      -----------------------
+
+      procedure Conformance_Error (Msg : String; N : Node_Id := New_Id) is
+         Enode : Node_Id;
+
+      begin
+         Conforms := False;
+
+         if Errmsg then
+            if No (Err_Loc) then
+               Enode := N;
+            else
+               Enode := Err_Loc;
+            end if;
+
+            Error_Msg_Sloc := Sloc (Old_Id);
+
+            case Ctype is
+               when Type_Conformant =>
+                  Error_Msg_N
+                    ("not type conformant with declaration#!", Enode);
+
+               when Mode_Conformant =>
+                  Error_Msg_N
+                    ("not mode conformant with declaration#!", Enode);
+
+               when Subtype_Conformant =>
+                  Error_Msg_N
+                    ("not subtype conformant with declaration#!", Enode);
+
+               when Fully_Conformant =>
+                  Error_Msg_N
+                    ("not fully conformant with declaration#!", Enode);
+            end case;
+
+            Error_Msg_NE (Msg, Enode, N);
+         end if;
+      end Conformance_Error;
+
+   --  Start of processing for Check_Conformance
+
+   begin
+      Conforms := True;
+
+      --  We need a special case for operators, since they don't
+      --  appear explicitly.
+
+      if Ctype = Type_Conformant then
+         if Ekind (New_Id) = E_Operator
+           and then Operator_Matches_Spec (New_Id, Old_Id)
+         then
+            return;
+         end if;
+      end if;
+
+      --  If both are functions/operators, check return types conform
+
+      if Old_Type /= Standard_Void_Type
+        and then New_Type /= Standard_Void_Type
+      then
+         if not Conforming_Types (Old_Type, New_Type, Ctype, Get_Inst) then
+            Conformance_Error ("return type does not match!", New_Id);
+            return;
+         end if;
+
+      --  If either is a function/operator and the other isn't, error
+
+      elsif Old_Type /= Standard_Void_Type
+        or else New_Type /= Standard_Void_Type
+      then
+         Conformance_Error ("functions can only match functions!", New_Id);
+         return;
+      end if;
+
+      --  In subtype conformant case, conventions must match (RM 6.3.1(16))
+      --  If this is a renaming as body, refine error message to indicate that
+      --  the conflict is with the original declaration. If the entity is not
+      --  frozen, the conventions don't have to match, the one of the renamed
+      --  entity is inherited.
+
+      if Ctype >= Subtype_Conformant then
+
+         if Convention (Old_Id) /= Convention (New_Id) then
+
+            if not Is_Frozen (New_Id) then
+               null;
+
+            elsif Present (Err_Loc)
+              and then Nkind (Err_Loc) = N_Subprogram_Renaming_Declaration
+              and then Present (Corresponding_Spec (Err_Loc))
+            then
+               Error_Msg_Name_1 := Chars (New_Id);
+               Error_Msg_Name_2 :=
+                 Name_Ada + Convention_Id'Pos (Convention (New_Id));
+
+               Conformance_Error ("prior declaration for% has convention %!");
+
+            else
+               Conformance_Error ("calling conventions do not match!");
+            end if;
+
+            return;
+
+         elsif Is_Formal_Subprogram (Old_Id)
+           or else Is_Formal_Subprogram (New_Id)
+         then
+            Conformance_Error ("formal subprograms not allowed!");
+            return;
+         end if;
+      end if;
+
+      --  Deal with parameters
+
+      --  Note: we use the entity information, rather than going directly
+      --  to the specification in the tree. This is not only simpler, but
+      --  absolutely necessary for some cases of conformance tests between
+      --  operators, where the declaration tree simply does not exist!
+
+      Old_Formal := First_Formal (Old_Id);
+      New_Formal := First_Formal (New_Id);
+
+      while Present (Old_Formal) and then Present (New_Formal) loop
+
+         --  Types must always match. In the visible part of an instance,
+         --  usual overloading rules for dispatching operations apply, and
+         --  we check base types (not the actual subtypes).
+
+         if In_Instance_Visible_Part
+           and then Is_Dispatching_Operation (New_Id)
+         then
+            if not Conforming_Types
+              (Base_Type (Etype (Old_Formal)),
+                 Base_Type (Etype (New_Formal)), Ctype, Get_Inst)
+            then
+               Conformance_Error ("type of & does not match!", New_Formal);
+               return;
+            end if;
+
+         elsif not Conforming_Types
+           (Etype (Old_Formal), Etype (New_Formal), Ctype, Get_Inst)
+         then
+            Conformance_Error ("type of & does not match!", New_Formal);
+            return;
+         end if;
+
+         --  For mode conformance, mode must match
+
+         if Ctype >= Mode_Conformant
+           and then Parameter_Mode (Old_Formal) /= Parameter_Mode (New_Formal)
+         then
+            Conformance_Error ("mode of & does not match!", New_Formal);
+            return;
+         end if;
+
+         --  Full conformance checks
+
+         if Ctype = Fully_Conformant then
+
+            --  Names must match
+
+            if Chars (Old_Formal) /= Chars (New_Formal) then
+               Conformance_Error ("name & does not match!", New_Formal);
+               return;
+
+            --  And default expressions for in parameters
+
+            elsif Parameter_Mode (Old_Formal) = E_In_Parameter then
+               declare
+                  NewD : constant Boolean :=
+                           Present (Default_Value (New_Formal));
+                  OldD : constant Boolean :=
+                           Present (Default_Value (Old_Formal));
+               begin
+                  if NewD or OldD then
+
+                     --  The old default value has been analyzed and expanded,
+                     --  because the current full declaration will have frozen
+                     --  everything before. The new default values have not
+                     --  been expanded, so expand now to check conformance.
+
+                     if NewD then
+                        New_Scope (New_Id);
+                        Analyze_Default_Expression
+                         (Default_Value (New_Formal), Etype (New_Formal));
+                        End_Scope;
+                     end if;
+
+                     if not (NewD and OldD)
+                       or else not Fully_Conformant_Expressions
+                                    (Default_Value (Old_Formal),
+                                     Default_Value (New_Formal))
+                     then
+                        Conformance_Error
+                          ("default expression for & does not match!",
+                           New_Formal);
+                        return;
+                     end if;
+                  end if;
+               end;
+            end if;
+         end if;
+
+         --  A couple of special checks for Ada 83 mode. These checks are
+         --  skipped if either entity is an operator in package Standard.
+         --  or if either old or new instance is not from the source program.
+
+         if Ada_83
+           and then Sloc (Old_Id) > Standard_Location
+           and then Sloc (New_Id) > Standard_Location
+           and then Comes_From_Source (Old_Id)
+           and then Comes_From_Source (New_Id)
+         then
+            declare
+               Old_Param : constant Node_Id := Declaration_Node (Old_Formal);
+               New_Param : constant Node_Id := Declaration_Node (New_Formal);
+
+            begin
+               --  Explicit IN must be present or absent in both cases. This
+               --  test is required only in the full conformance case.
+
+               if In_Present (Old_Param) /= In_Present (New_Param)
+                 and then Ctype = Fully_Conformant
+               then
+                  Conformance_Error
+                    ("(Ada 83) IN must appear in both declarations",
+                     New_Formal);
+                  return;
+               end if;
+
+               --  Grouping (use of comma in param lists) must be the same
+               --  This is where we catch a misconformance like:
+
+               --    A,B : Integer
+               --    A : Integer; B : Integer
+
+               --  which are represented identically in the tree except
+               --  for the setting of the flags More_Ids and Prev_Ids.
+
+               if More_Ids (Old_Param) /= More_Ids (New_Param)
+                 or else Prev_Ids (Old_Param) /= Prev_Ids (New_Param)
+               then
+                  Conformance_Error
+                    ("grouping of & does not match!", New_Formal);
+                  return;
+               end if;
+            end;
+         end if;
+
+         Next_Formal (Old_Formal);
+         Next_Formal (New_Formal);
+      end loop;
+
+      if Present (Old_Formal) then
+         Conformance_Error ("too few parameters!");
+         return;
+
+      elsif Present (New_Formal) then
+         Conformance_Error ("too many parameters!", New_Formal);
+         return;
+      end if;
+
+   end Check_Conformance;
+
+   ------------------------------
+   -- Check_Delayed_Subprogram --
+   ------------------------------
+
+   procedure Check_Delayed_Subprogram (Designator : Entity_Id) is
+      F : Entity_Id;
+
+      procedure Possible_Freeze (T : Entity_Id);
+      --  T is the type of either a formal parameter or of the return type.
+      --  If T is not yet frozen and needs a delayed freeze, then the
+      --  subprogram itself must be delayed.
+
+      procedure Possible_Freeze (T : Entity_Id) is
+      begin
+         if Has_Delayed_Freeze (T)
+           and then not Is_Frozen (T)
+         then
+            Set_Has_Delayed_Freeze (Designator);
+
+         elsif Is_Access_Type (T)
+           and then Has_Delayed_Freeze (Designated_Type (T))
+           and then not Is_Frozen (Designated_Type (T))
+         then
+            Set_Has_Delayed_Freeze (Designator);
+         end if;
+      end Possible_Freeze;
+
+   --  Start of processing for Check_Delayed_Subprogram
+
+   begin
+      --  Never need to freeze abstract subprogram
+
+      if Is_Abstract (Designator) then
+         null;
+      else
+         --  Need delayed freeze if return type itself needs a delayed
+         --  freeze and is not yet frozen.
+
+         Possible_Freeze (Etype (Designator));
+         Possible_Freeze (Base_Type (Etype (Designator))); -- needed ???
+
+         --  Need delayed freeze if any of the formal types themselves need
+         --  a delayed freeze and are not yet frozen.
+
+         F := First_Formal (Designator);
+         while Present (F) loop
+            Possible_Freeze (Etype (F));
+            Possible_Freeze (Base_Type (Etype (F))); -- needed ???
+            Next_Formal (F);
+         end loop;
+      end if;
+
+      --  Mark functions that return by reference. Note that it cannot be
+      --  done for delayed_freeze subprograms because the underlying
+      --  returned type may not be known yet (for private types)
+
+      if not Has_Delayed_Freeze (Designator)
+        and then Expander_Active
+      then
+         declare
+            Typ  : constant Entity_Id := Etype (Designator);
+            Utyp : constant Entity_Id := Underlying_Type (Typ);
+
+         begin
+            if Is_Return_By_Reference_Type (Typ) then
+               Set_Returns_By_Ref (Designator);
+
+            elsif Present (Utyp) and then Controlled_Type (Utyp) then
+               Set_Returns_By_Ref (Designator);
+            end if;
+         end;
+      end if;
+   end Check_Delayed_Subprogram;
+
+   ------------------------------------
+   -- Check_Discriminant_Conformance --
+   ------------------------------------
+
+   procedure Check_Discriminant_Conformance
+     (N        : Node_Id;
+      Prev     : Entity_Id;
+      Prev_Loc : Node_Id)
+   is
+      Old_Discr      : Entity_Id := First_Discriminant (Prev);
+      New_Discr      : Node_Id   := First (Discriminant_Specifications (N));
+      New_Discr_Id   : Entity_Id;
+      New_Discr_Type : Entity_Id;
+
+      procedure Conformance_Error (Msg : String; N : Node_Id);
+      --  Post error message for conformance error on given node.
+      --  Two messages are output. The first points to the previous
+      --  declaration with a general "no conformance" message.
+      --  The second is the detailed reason, supplied as Msg. The
+      --  parameter N provide information for a possible & insertion
+      --  in the message.
+
+      -----------------------
+      -- Conformance_Error --
+      -----------------------
+
+      procedure Conformance_Error (Msg : String; N : Node_Id) is
+      begin
+         Error_Msg_Sloc := Sloc (Prev_Loc);
+         Error_Msg_N ("not fully conformant with declaration#!", N);
+         Error_Msg_NE (Msg, N, N);
+      end Conformance_Error;
+
+   --  Start of processing for Check_Discriminant_Conformance
+
+   begin
+      while Present (Old_Discr) and then Present (New_Discr) loop
+
+         New_Discr_Id := Defining_Identifier (New_Discr);
+
+         --  The subtype mark of the discriminant on the full type
+         --  has not been analyzed so we do it here. For an access
+         --  discriminant a new type is created.
+
+         if Nkind (Discriminant_Type (New_Discr)) = N_Access_Definition then
+            New_Discr_Type :=
+              Access_Definition (N, Discriminant_Type (New_Discr));
+
+         else
+            Analyze (Discriminant_Type (New_Discr));
+            New_Discr_Type := Etype (Discriminant_Type (New_Discr));
+         end if;
+
+         if not Conforming_Types
+                  (Etype (Old_Discr), New_Discr_Type, Fully_Conformant)
+         then
+            Conformance_Error ("type of & does not match!", New_Discr_Id);
+            return;
+         end if;
+
+         --  Names must match
+
+         if Chars (Old_Discr) /= Chars (Defining_Identifier (New_Discr)) then
+            Conformance_Error ("name & does not match!", New_Discr_Id);
+            return;
+         end if;
+
+         --  Default expressions must match
+
+         declare
+            NewD : constant Boolean :=
+                     Present (Expression (New_Discr));
+            OldD : constant Boolean :=
+                     Present (Expression (Parent (Old_Discr)));
+
+         begin
+            if NewD or OldD then
+
+               --  The old default value has been analyzed and expanded,
+               --  because the current full declaration will have frozen
+               --  everything before. The new default values have not
+               --  been expanded, so expand now to check conformance.
+
+               if NewD then
+                  Analyze_Default_Expression
+                    (Expression (New_Discr), New_Discr_Type);
+               end if;
+
+               if not (NewD and OldD)
+                 or else not Fully_Conformant_Expressions
+                              (Expression (Parent (Old_Discr)),
+                               Expression (New_Discr))
+
+               then
+                  Conformance_Error
+                    ("default expression for & does not match!",
+                     New_Discr_Id);
+                  return;
+               end if;
+            end if;
+         end;
+
+         --  In Ada 83 case, grouping must match: (A,B : X) /= (A : X; B : X)
+
+         if Ada_83 then
+            declare
+               Old_Disc : constant Node_Id := Declaration_Node (Old_Discr);
+
+            begin
+               --  Grouping (use of comma in param lists) must be the same
+               --  This is where we catch a misconformance like:
+
+               --    A,B : Integer
+               --    A : Integer; B : Integer
+
+               --  which are represented identically in the tree except
+               --  for the setting of the flags More_Ids and Prev_Ids.
+
+               if More_Ids (Old_Disc) /= More_Ids (New_Discr)
+                 or else Prev_Ids (Old_Disc) /= Prev_Ids (New_Discr)
+               then
+                  Conformance_Error
+                    ("grouping of & does not match!", New_Discr_Id);
+                  return;
+               end if;
+            end;
+         end if;
+
+         Next_Discriminant (Old_Discr);
+         Next (New_Discr);
+      end loop;
+
+      if Present (Old_Discr) then
+         Conformance_Error ("too few discriminants!", Defining_Identifier (N));
+         return;
+
+      elsif Present (New_Discr) then
+         Conformance_Error
+           ("too many discriminants!", Defining_Identifier (New_Discr));
+         return;
+      end if;
+   end Check_Discriminant_Conformance;
+
+   ----------------------------
+   -- Check_Fully_Conformant --
+   ----------------------------
+
+   procedure Check_Fully_Conformant
+     (New_Id  : Entity_Id;
+      Old_Id  : Entity_Id;
+      Err_Loc : Node_Id := Empty)
+   is
+      Result : Boolean;
+
+   begin
+      Check_Conformance
+        (New_Id, Old_Id, Fully_Conformant, True, Result, Err_Loc);
+   end Check_Fully_Conformant;
+
+   ---------------------------
+   -- Check_Mode_Conformant --
+   ---------------------------
+
+   procedure Check_Mode_Conformant
+     (New_Id   : Entity_Id;
+      Old_Id   : Entity_Id;
+      Err_Loc  : Node_Id := Empty;
+      Get_Inst : Boolean := False)
+   is
+      Result : Boolean;
+
+   begin
+      Check_Conformance
+        (New_Id, Old_Id, Mode_Conformant, True, Result, Err_Loc, Get_Inst);
+   end Check_Mode_Conformant;
+
+   -------------------
+   -- Check_Returns --
+   -------------------
+
+   procedure Check_Returns
+     (HSS  : Node_Id;
+      Mode : Character;
+      Err  : out Boolean)
+   is
+      Handler : Node_Id;
+
+      procedure Check_Statement_Sequence (L : List_Id);
+      --  Internal recursive procedure to check a list of statements for proper
+      --  termination by a return statement (or a transfer of control or a
+      --  compound statement that is itself internally properly terminated).
+
+      ------------------------------
+      -- Check_Statement_Sequence --
+      ------------------------------
+
+      procedure Check_Statement_Sequence (L : List_Id) is
+         Last_Stm : Node_Id;
+         Kind     : Node_Kind;
+
+         Raise_Exception_Call : Boolean;
+         --  Set True if statement sequence terminated by Raise_Exception call
+         --  or a Reraise_Occurrence call.
+
+      begin
+         Raise_Exception_Call := False;
+
+         --  Get last real statement
+
+         Last_Stm := Last (L);
+
+         --  Don't count pragmas
+
+         while Nkind (Last_Stm) = N_Pragma
+
+         --  Don't count call to SS_Release (can happen after Raise_Exception)
+
+           or else
+             (Nkind (Last_Stm) = N_Procedure_Call_Statement
+                and then
+              Nkind (Name (Last_Stm)) = N_Identifier
+                and then
+              Is_RTE (Entity (Name (Last_Stm)), RE_SS_Release))
+
+         --  Don't count exception junk
+
+           or else
+             ((Nkind (Last_Stm) = N_Goto_Statement
+                 or else Nkind (Last_Stm) = N_Label
+                 or else Nkind (Last_Stm) = N_Object_Declaration)
+               and then Exception_Junk (Last_Stm))
+         loop
+            Prev (Last_Stm);
+         end loop;
+
+         --  Here we have the "real" last statement
+
+         Kind := Nkind (Last_Stm);
+
+         --  Transfer of control, OK. Note that in the No_Return procedure
+         --  case, we already diagnosed any explicit return statements, so
+         --  we can treat them as OK in this context.
+
+         if Is_Transfer (Last_Stm) then
+            return;
+
+         --  Check cases of explicit non-indirect procedure calls
+
+         elsif Kind = N_Procedure_Call_Statement
+           and then Is_Entity_Name (Name (Last_Stm))
+         then
+            --  Check call to Raise_Exception procedure which is treated
+            --  specially, as is a call to Reraise_Occurrence.
+
+            --  We suppress the warning in these cases since it is likely that
+            --  the programmer really does not expect to deal with the case
+            --  of Null_Occurrence, and thus would find a warning about a
+            --  missing return curious, and raising Program_Error does not
+            --  seem such a bad behavior if this does occur.
+
+            if Is_RTE (Entity (Name (Last_Stm)), RE_Raise_Exception)
+                 or else
+               Is_RTE (Entity (Name (Last_Stm)), RE_Reraise_Occurrence)
+            then
+               Raise_Exception_Call := True;
+
+               --  For Raise_Exception call, test first argument, if it is
+               --  an attribute reference for a 'Identity call, then we know
+               --  that the call cannot possibly return.
+
+               declare
+                  Arg : constant Node_Id :=
+                          Original_Node (First_Actual (Last_Stm));
+
+               begin
+                  if Nkind (Arg) = N_Attribute_Reference
+                    and then Attribute_Name (Arg) = Name_Identity
+                  then
+                     return;
+                  end if;
+               end;
+            end if;
+
+         --  If statement, need to look inside if there is an else and check
+         --  each constituent statement sequence for proper termination.
+
+         elsif Kind = N_If_Statement
+           and then Present (Else_Statements (Last_Stm))
+         then
+            Check_Statement_Sequence (Then_Statements (Last_Stm));
+            Check_Statement_Sequence (Else_Statements (Last_Stm));
+
+            if Present (Elsif_Parts (Last_Stm)) then
+               declare
+                  Elsif_Part : Node_Id := First (Elsif_Parts (Last_Stm));
+
+               begin
+                  while Present (Elsif_Part) loop
+                     Check_Statement_Sequence (Then_Statements (Elsif_Part));
+                     Next (Elsif_Part);
+                  end loop;
+               end;
+            end if;
+
+            return;
+
+         --  Case statement, check each case for proper termination
+
+         elsif Kind = N_Case_Statement then
+            declare
+               Case_Alt : Node_Id;
+
+            begin
+               Case_Alt := First_Non_Pragma (Alternatives (Last_Stm));
+               while Present (Case_Alt) loop
+                  Check_Statement_Sequence (Statements (Case_Alt));
+                  Next_Non_Pragma (Case_Alt);
+               end loop;
+            end;
+
+            return;
+
+         --  Block statement, check its handled sequence of statements
+
+         elsif Kind = N_Block_Statement then
+            declare
+               Err1 : Boolean;
+
+            begin
+               Check_Returns
+                 (Handled_Statement_Sequence (Last_Stm), Mode, Err1);
+
+               if Err1 then
+                  Err := True;
+               end if;
+
+               return;
+            end;
+
+         --  Loop statement. If there is an iteration scheme, we can definitely
+         --  fall out of the loop. Similarly if there is an exit statement, we
+         --  can fall out. In either case we need a following return.
+
+         elsif Kind = N_Loop_Statement then
+            if Present (Iteration_Scheme (Last_Stm))
+              or else Has_Exit (Entity (Identifier (Last_Stm)))
+            then
+               null;
+
+            --  A loop with no exit statement or iteration scheme if either
+            --  an inifite loop, or it has some other exit (raise/return).
+            --  In either case, no warning is required.
+
+            else
+               return;
+            end if;
+
+         --  Timed entry call, check entry call and delay alternatives
+
+         --  Note: in expanded code, the timed entry call has been converted
+         --  to a set of expanded statements on which the check will work
+         --  correctly in any case.
+
+         elsif Kind = N_Timed_Entry_Call then
+            declare
+               ECA : constant Node_Id := Entry_Call_Alternative (Last_Stm);
+               DCA : constant Node_Id := Delay_Alternative      (Last_Stm);
+
+            begin
+               --  If statement sequence of entry call alternative is missing,
+               --  then we can definitely fall through, and we post the error
+               --  message on the entry call alternative itself.
+
+               if No (Statements (ECA)) then
+                  Last_Stm := ECA;
+
+               --  If statement sequence of delay alternative is missing, then
+               --  we can definitely fall through, and we post the error
+               --  message on the delay alternative itself.
+
+               --  Note: if both ECA and DCA are missing the return, then we
+               --  post only one message, should be enough to fix the bugs.
+               --  If not we will get a message next time on the DCA when the
+               --  ECA is fixed!
+
+               elsif No (Statements (DCA)) then
+                  Last_Stm := DCA;
+
+               --  Else check both statement sequences
+
+               else
+                  Check_Statement_Sequence (Statements (ECA));
+                  Check_Statement_Sequence (Statements (DCA));
+                  return;
+               end if;
+            end;
+
+         --  Conditional entry call, check entry call and else part
+
+         --  Note: in expanded code, the conditional entry call has been
+         --  converted to a set of expanded statements on which the check
+         --  will work correctly in any case.
+
+         elsif Kind = N_Conditional_Entry_Call then
+            declare
+               ECA : constant Node_Id := Entry_Call_Alternative (Last_Stm);
+
+            begin
+               --  If statement sequence of entry call alternative is missing,
+               --  then we can definitely fall through, and we post the error
+               --  message on the entry call alternative itself.
+
+               if No (Statements (ECA)) then
+                  Last_Stm := ECA;
+
+               --  Else check statement sequence and else part
+
+               else
+                  Check_Statement_Sequence (Statements (ECA));
+                  Check_Statement_Sequence (Else_Statements (Last_Stm));
+                  return;
+               end if;
+            end;
+         end if;
+
+         --  If we fall through, issue appropriate message
+
+         if Mode = 'F' then
+
+            if not Raise_Exception_Call then
+               Error_Msg_N
+                 ("?RETURN statement missing following this statement!",
+                  Last_Stm);
+               Error_Msg_N
+                 ("\?Program_Error may be raised at run time",
+                  Last_Stm);
+            end if;
+
+            --  Note: we set Err even though we have not issued a warning
+            --  because we still have a case of a missing return. This is
+            --  an extremely marginal case, probably will never be noticed
+            --  but we might as well get it right.
+
+            Err := True;
+
+         else
+            Error_Msg_N
+              ("implied return after this statement not allowed (No_Return)",
+               Last_Stm);
+         end if;
+      end Check_Statement_Sequence;
+
+   --  Start of processing for Check_Returns
+
+   begin
+      Err := False;
+      Check_Statement_Sequence (Statements (HSS));
+
+      if Present (Exception_Handlers (HSS)) then
+         Handler := First_Non_Pragma (Exception_Handlers (HSS));
+         while Present (Handler) loop
+            Check_Statement_Sequence (Statements (Handler));
+            Next_Non_Pragma (Handler);
+         end loop;
+      end if;
+   end Check_Returns;
+
+   ----------------------------
+   -- Check_Subprogram_Order --
+   ----------------------------
+
+   procedure Check_Subprogram_Order (N : Node_Id) is
+
+      function Subprogram_Name_Greater (S1, S2 : String) return Boolean;
+      --  This is used to check if S1 > S2 in the sense required by this
+      --  test, for example nameab < namec, but name2 < name10.
+
+      function Subprogram_Name_Greater (S1, S2 : String) return Boolean is
+         L1, L2 : Positive;
+         N1, N2 : Natural;
+
+      begin
+         --  Remove trailing numeric parts
+
+         L1 := S1'Last;
+         while S1 (L1) in '0' .. '9' loop
+            L1 := L1 - 1;
+         end loop;
+
+         L2 := S2'Last;
+         while S2 (L2) in '0' .. '9' loop
+            L2 := L2 - 1;
+         end loop;
+
+         --  If non-numeric parts non-equal, that's decisive
+
+         if S1 (S1'First .. L1) < S2 (S2'First .. L2) then
+            return False;
+
+         elsif S1 (S1'First .. L1) > S2 (S2'First .. L2) then
+            return True;
+
+         --  If non-numeric parts equal, compare suffixed numeric parts. Note
+         --  that a missing suffix is treated as numeric zero in this test.
+
+         else
+            N1 := 0;
+            while L1 < S1'Last loop
+               L1 := L1 + 1;
+               N1 := N1 * 10 + Character'Pos (S1 (L1)) - Character'Pos ('0');
+            end loop;
+
+            N2 := 0;
+            while L2 < S2'Last loop
+               L2 := L2 + 1;
+               N2 := N2 * 10 + Character'Pos (S2 (L2)) - Character'Pos ('0');
+            end loop;
+
+            return N1 > N2;
+         end if;
+      end Subprogram_Name_Greater;
+
+   --  Start of processing for Check_Subprogram_Order
+
+   begin
+      --  Check body in alpha order if this is option
+
+      if Style_Check_Subprogram_Order
+        and then Nkind (N) = N_Subprogram_Body
+        and then Comes_From_Source (N)
+        and then In_Extended_Main_Source_Unit (N)
+      then
+         declare
+            LSN : String_Ptr
+                    renames Scope_Stack.Table
+                              (Scope_Stack.Last).Last_Subprogram_Name;
+
+            Body_Id : constant Entity_Id :=
+                        Defining_Entity (Specification (N));
+
+         begin
+            Get_Decoded_Name_String (Chars (Body_Id));
+
+            if LSN /= null then
+               if Subprogram_Name_Greater
+                    (LSN.all, Name_Buffer (1 .. Name_Len))
+               then
+                  Style.Subprogram_Not_In_Alpha_Order (Body_Id);
+               end if;
+
+               Free (LSN);
+            end if;
+
+            LSN := new String'(Name_Buffer (1 .. Name_Len));
+         end;
+      end if;
+   end Check_Subprogram_Order;
+
+   ------------------------------
+   -- Check_Subtype_Conformant --
+   ------------------------------
+
+   procedure Check_Subtype_Conformant
+     (New_Id  : Entity_Id;
+      Old_Id  : Entity_Id;
+      Err_Loc : Node_Id := Empty)
+   is
+      Result : Boolean;
+
+   begin
+      Check_Conformance
+        (New_Id, Old_Id, Subtype_Conformant, True, Result, Err_Loc);
+   end Check_Subtype_Conformant;
+
+   ---------------------------
+   -- Check_Type_Conformant --
+   ---------------------------
+
+   procedure Check_Type_Conformant
+     (New_Id  : Entity_Id;
+      Old_Id  : Entity_Id;
+      Err_Loc : Node_Id := Empty)
+   is
+      Result : Boolean;
+
+   begin
+      Check_Conformance
+        (New_Id, Old_Id, Type_Conformant, True, Result, Err_Loc);
+   end Check_Type_Conformant;
+
+   ----------------------
+   -- Conforming_Types --
+   ----------------------
+
+   function Conforming_Types
+     (T1       : Entity_Id;
+      T2       : Entity_Id;
+      Ctype    : Conformance_Type;
+      Get_Inst : Boolean := False)
+      return     Boolean
+   is
+      Type_1 : Entity_Id := T1;
+      Type_2 : Entity_Id := T2;
+
+      function Base_Types_Match (T1, T2 : Entity_Id) return Boolean;
+      --  If neither T1 nor T2 are generic actual types, then verify
+      --  that the base types are equal. Otherwise T1 and T2 must be
+      --  on the same subtype chain. The whole purpose of this procedure
+      --  is to prevent spurious ambiguities in an instantiation that may
+      --  arise if two distinct generic types are instantiated with the
+      --  same actual.
+
+      ----------------------
+      -- Base_Types_Match --
+      ----------------------
+
+      function Base_Types_Match (T1, T2 : Entity_Id) return Boolean is
+      begin
+         if T1 = T2 then
+            return True;
+
+         elsif Base_Type (T1) = Base_Type (T2) then
+
+            --  The following is too permissive. A more precise test must
+            --  check that the generic actual is an ancestor subtype of the
+            --  other ???.
+
+            return not Is_Generic_Actual_Type (T1)
+              or else not Is_Generic_Actual_Type (T2);
+
+         else
+            return False;
+         end if;
+      end Base_Types_Match;
+
+   begin
+      --  The context is an instance association for a formal
+      --  access-to-subprogram type; the formal parameter types
+      --  require mapping because they may denote other formal
+      --  parameters of the generic unit.
+
+      if Get_Inst then
+         Type_1 := Get_Instance_Of (T1);
+         Type_2 := Get_Instance_Of (T2);
+      end if;
+
+      --  First see if base types match
+
+      if Base_Types_Match (Type_1, Type_2) then
+         return Ctype <= Mode_Conformant
+           or else Subtypes_Statically_Match (Type_1, Type_2);
+
+      elsif Is_Incomplete_Or_Private_Type (Type_1)
+        and then Present (Full_View (Type_1))
+        and then Base_Types_Match (Full_View (Type_1), Type_2)
+      then
+         return Ctype <= Mode_Conformant
+           or else Subtypes_Statically_Match (Full_View (Type_1), Type_2);
+
+      elsif Ekind (Type_2) = E_Incomplete_Type
+        and then Present (Full_View (Type_2))
+        and then Base_Types_Match (Type_1, Full_View (Type_2))
+      then
+         return Ctype <= Mode_Conformant
+           or else Subtypes_Statically_Match (Type_1, Full_View (Type_2));
+      end if;
+
+      --  Test anonymous access type case. For this case, static subtype
+      --  matching is required for mode conformance (RM 6.3.1(15))
+
+      if Ekind (Type_1) = E_Anonymous_Access_Type
+        and then Ekind (Type_2) = E_Anonymous_Access_Type
+      then
+         declare
+            Desig_1 : Entity_Id;
+            Desig_2 : Entity_Id;
+
+         begin
+            Desig_1 := Directly_Designated_Type (Type_1);
+
+            --  An access parameter can designate an incomplete type.
+
+            if Ekind (Desig_1) = E_Incomplete_Type
+              and then Present (Full_View (Desig_1))
+            then
+               Desig_1 := Full_View (Desig_1);
+            end if;
+
+            Desig_2 := Directly_Designated_Type (Type_2);
+
+            if Ekind (Desig_2) = E_Incomplete_Type
+              and then Present (Full_View (Desig_2))
+            then
+               Desig_2 := Full_View (Desig_2);
+            end if;
+
+            --  The context is an instance association for a formal
+            --  access-to-subprogram type; formal access parameter
+            --  designated types require mapping because they may
+            --  denote other formal parameters of the generic unit.
+
+            if Get_Inst then
+               Desig_1 := Get_Instance_Of (Desig_1);
+               Desig_2 := Get_Instance_Of (Desig_2);
+            end if;
+
+            --  It is possible for a Class_Wide_Type to be introduced for
+            --  an incomplete type, in which case there is a separate class_
+            --  wide type for the full view. The types conform if their
+            --  Etypes conform, i.e. one may be the full view of the other.
+            --  This can only happen in the context of an access parameter,
+            --  other uses of an incomplete Class_Wide_Type are illegal.
+
+            if Ekind (Desig_1) = E_Class_Wide_Type
+              and then Ekind (Desig_2) = E_Class_Wide_Type
+            then
+               return
+                 Conforming_Types (Etype (Desig_1), Etype (Desig_2), Ctype);
+            else
+               return Base_Type (Desig_1) = Base_Type (Desig_2)
+                and then (Ctype = Type_Conformant
+                          or else
+                        Subtypes_Statically_Match (Desig_1, Desig_2));
+            end if;
+         end;
+
+      --  Otherwise definitely no match
+
+      else
+         return False;
+      end if;
+
+   end Conforming_Types;
+
+   --------------------------
+   -- Create_Extra_Formals --
+   --------------------------
+
+   procedure Create_Extra_Formals (E : Entity_Id) is
+      Formal      : Entity_Id;
+      Last_Formal : Entity_Id;
+      Last_Extra  : Entity_Id;
+      Formal_Type : Entity_Id;
+      P_Formal    : Entity_Id := Empty;
+
+      function Add_Extra_Formal (Typ : Entity_Id) return Entity_Id;
+      --  Add an extra formal, associated with the current Formal. The
+      --  extra formal is added to the list of extra formals, and also
+      --  returned as the result. These formals are always of mode IN.
+
+      function Add_Extra_Formal (Typ : Entity_Id) return Entity_Id is
+         EF : constant Entity_Id :=
+                Make_Defining_Identifier (Sloc (Formal),
+                  Chars => New_External_Name (Chars (Formal), 'F'));
+
+      begin
+         --  We never generate extra formals if expansion is not active
+         --  because we don't need them unless we are generating code.
+
+         if not Expander_Active then
+            return Empty;
+         end if;
+
+         --  A little optimization. Never generate an extra formal for
+         --  the _init operand of an initialization procedure, since it
+         --  could never be used.
+
+         if Chars (Formal) = Name_uInit then
+            return Empty;
+         end if;
+
+         Set_Ekind           (EF, E_In_Parameter);
+         Set_Actual_Subtype  (EF, Typ);
+         Set_Etype           (EF, Typ);
+         Set_Scope           (EF, Scope (Formal));
+         Set_Mechanism       (EF, Default_Mechanism);
+         Set_Formal_Validity (EF);
+
+         Set_Extra_Formal (Last_Extra, EF);
+         Last_Extra := EF;
+         return EF;
+      end Add_Extra_Formal;
+
+   --  Start of processing for Create_Extra_Formals
+
+   begin
+      --  If this is a derived subprogram then the subtypes of the
+      --  parent subprogram's formal parameters will be used to
+      --  to determine the need for extra formals.
+
+      if Is_Overloadable (E) and then Present (Alias (E)) then
+         P_Formal := First_Formal (Alias (E));
+      end if;
+
+      Last_Extra := Empty;
+      Formal := First_Formal (E);
+      while Present (Formal) loop
+         Last_Extra := Formal;
+         Next_Formal (Formal);
+      end loop;
+
+      --  If Extra_formals where already created, don't do it again
+      --  This situation may arise for subprogram types created as part
+      --  of dispatching calls (see Expand_Dispatch_Call)
+
+      if Present (Last_Extra) and then
+        Present (Extra_Formal (Last_Extra))
+      then
+         return;
+      end if;
+
+      Formal := First_Formal (E);
+
+      while Present (Formal) loop
+
+         --  Create extra formal for supporting the attribute 'Constrained.
+         --  The case of a private type view without discriminants also
+         --  requires the extra formal if the underlying type has defaulted
+         --  discriminants.
+
+         if Ekind (Formal) /= E_In_Parameter then
+            if Present (P_Formal) then
+               Formal_Type := Etype (P_Formal);
+            else
+               Formal_Type := Etype (Formal);
+            end if;
+
+            if not Has_Discriminants (Formal_Type)
+              and then Ekind (Formal_Type) in Private_Kind
+              and then Present (Underlying_Type (Formal_Type))
+            then
+               Formal_Type := Underlying_Type (Formal_Type);
+            end if;
+
+            if Has_Discriminants (Formal_Type)
+              and then
+                ((not Is_Constrained (Formal_Type)
+                    and then not Is_Indefinite_Subtype (Formal_Type))
+                  or else Present (Extra_Formal (Formal)))
+            then
+               Set_Extra_Constrained
+                 (Formal, Add_Extra_Formal (Standard_Boolean));
+            end if;
+         end if;
+
+         --  Create extra formal for supporting accessibility checking
+
+         --  This is suppressed if we specifically suppress accessibility
+         --  checks for either the subprogram, or the package in which it
+         --  resides. However, we do not suppress it simply if the scope
+         --  has accessibility checks suppressed, since this could cause
+         --  trouble when clients are compiled with a different suppression
+         --  setting. The explicit checks are safe from this point of view.
+
+         if Ekind (Etype (Formal)) = E_Anonymous_Access_Type
+           and then not
+             (Suppress_Accessibility_Checks (E)
+               or else
+              Suppress_Accessibility_Checks (Scope (E)))
+           and then
+             (not Present (P_Formal)
+               or else Present (Extra_Accessibility (P_Formal)))
+         then
+            --  Temporary kludge: for now we avoid creating the extra
+            --  formal for access parameters of protected operations
+            --  because of problem with the case of internal protected
+            --  calls. ???
+
+            if Nkind (Parent (Parent (Parent (E)))) /= N_Protected_Definition
+              and then Nkind (Parent (Parent (Parent (E)))) /= N_Protected_Body
+            then
+               Set_Extra_Accessibility
+                 (Formal, Add_Extra_Formal (Standard_Natural));
+            end if;
+         end if;
+
+         if Present (P_Formal) then
+            Next_Formal (P_Formal);
+         end if;
+
+         Last_Formal := Formal;
+         Next_Formal (Formal);
+      end loop;
+   end Create_Extra_Formals;
+
+   -----------------------------
+   -- Enter_Overloaded_Entity --
+   -----------------------------
+
+   procedure Enter_Overloaded_Entity (S : Entity_Id) is
+      E   : Entity_Id := Current_Entity_In_Scope (S);
+      C_E : Entity_Id := Current_Entity (S);
+
+   begin
+      if Present (E) then
+         Set_Has_Homonym (E);
+         Set_Has_Homonym (S);
+      end if;
+
+      Set_Is_Immediately_Visible (S);
+      Set_Scope (S, Current_Scope);
+
+      --  Chain new entity if front of homonym in current scope, so that
+      --  homonyms are contiguous.
+
+      if Present (E)
+        and then E /= C_E
+      then
+         while Homonym (C_E) /= E loop
+            C_E := Homonym (C_E);
+         end loop;
+
+         Set_Homonym (C_E, S);
+
+      else
+         E := C_E;
+         Set_Current_Entity (S);
+      end if;
+
+      Set_Homonym (S, E);
+
+      Append_Entity (S, Current_Scope);
+      Set_Public_Status (S);
+
+      if Debug_Flag_E then
+         Write_Str ("New overloaded entity chain: ");
+         Write_Name (Chars (S));
+         E := S;
+
+         while Present (E) loop
+            Write_Str (" "); Write_Int (Int (E));
+            E := Homonym (E);
+         end loop;
+
+         Write_Eol;
+      end if;
+
+      --  Generate warning for hiding
+
+      if Warn_On_Hiding
+        and then Comes_From_Source (S)
+        and then In_Extended_Main_Source_Unit (S)
+      then
+         E := S;
+         loop
+            E := Homonym (E);
+            exit when No (E);
+
+            --  Warn unless genuine overloading
+
+            if (not Is_Overloadable (E))
+              or else Subtype_Conformant (E, S)
+            then
+               Error_Msg_Sloc := Sloc (E);
+               Error_Msg_N ("declaration of & hides one#?", S);
+            end if;
+         end loop;
+      end if;
+   end Enter_Overloaded_Entity;
+
+   -----------------------------
+   -- Find_Corresponding_Spec --
+   -----------------------------
+
+   function Find_Corresponding_Spec (N : Node_Id) return Entity_Id is
+      Spec       : constant Node_Id   := Specification (N);
+      Designator : constant Entity_Id := Defining_Entity (Spec);
+
+      E : Entity_Id;
+
+   begin
+      E := Current_Entity (Designator);
+
+      while Present (E) loop
+
+         --  We are looking for a matching spec. It must have the same scope,
+         --  and the same name, and either be type conformant, or be the case
+         --  of a library procedure spec and its body (which belong to one
+         --  another regardless of whether they are type conformant or not).
+
+         if Scope (E) = Current_Scope then
+            if (Current_Scope = Standard_Standard
+                  or else (Ekind (E) = Ekind (Designator)
+                and then
+                  Type_Conformant (E, Designator)))
+            then
+               --  Within an instantiation, we know that spec and body are
+               --  subtype conformant, because they were subtype conformant
+               --  in the generic. We choose the subtype-conformant entity
+               --  here as well, to resolve spurious ambiguities in the
+               --  instance that were not present in the generic (i.e. when
+               --  two different types are given the same actual). If we are
+               --  looking for a spec to match a body, full conformance is
+               --  expected.
+
+               if In_Instance then
+                  Set_Convention (Designator, Convention (E));
+
+                  if Nkind (N) = N_Subprogram_Body
+                    and then Present (Homonym (E))
+                    and then not Fully_Conformant (E, Designator)
+                  then
+                     goto Next_Entity;
+
+                  elsif not Subtype_Conformant (E, Designator) then
+                     goto Next_Entity;
+                  end if;
+               end if;
+
+               if not Has_Completion (E) then
+
+                  if Nkind (N) /= N_Subprogram_Body_Stub then
+                     Set_Corresponding_Spec (N, E);
+                  end if;
+
+                  Set_Has_Completion (E);
+                  return E;
+
+               elsif Nkind (Parent (N)) = N_Subunit then
+
+                  --  If this is the proper body of a subunit, the completion
+                  --  flag is set when analyzing the stub.
+
+                  return E;
+
+               --  If body already exists, this is an error unless the
+               --  previous declaration is the implicit declaration of
+               --  a derived subprogram, or this is a spurious overloading
+               --  in an instance.
+
+               elsif No (Alias (E))
+                 and then not Is_Intrinsic_Subprogram (E)
+                 and then not In_Instance
+               then
+                  Error_Msg_Sloc := Sloc (E);
+                  Error_Msg_NE ("duplicate body for & declared#", N, E);
+               end if;
+
+            elsif Is_Child_Unit (E)
+              and then
+                Nkind (Unit_Declaration_Node (Designator)) = N_Subprogram_Body
+              and then
+                Nkind (Parent (Unit_Declaration_Node (Designator)))
+                  = N_Compilation_Unit
+            then
+
+               --  Child units cannot be overloaded, so a conformance mismatch
+               --  between body and a previous spec is an error.
+
+               Error_Msg_N
+                 ("body of child unit does not match previous declaration", N);
+            end if;
+         end if;
+
+         <<Next_Entity>>
+            E := Homonym (E);
+      end loop;
+
+      --  On exit, we know that no previous declaration of subprogram exists
+
+      return Empty;
+   end Find_Corresponding_Spec;
+
+   ----------------------
+   -- Fully_Conformant --
+   ----------------------
+
+   function Fully_Conformant (New_Id, Old_Id : Entity_Id) return Boolean is
+      Result : Boolean;
+
+   begin
+      Check_Conformance (New_Id, Old_Id, Fully_Conformant, False, Result);
+      return Result;
+   end Fully_Conformant;
+
+   ----------------------------------
+   -- Fully_Conformant_Expressions --
+   ----------------------------------
+
+   function Fully_Conformant_Expressions
+     (Given_E1 : Node_Id;
+      Given_E2 : Node_Id)
+      return     Boolean
+   is
+      E1 : constant Node_Id := Original_Node (Given_E1);
+      E2 : constant Node_Id := Original_Node (Given_E2);
+      --  We always test conformance on original nodes, since it is possible
+      --  for analysis and/or expansion to make things look as though they
+      --  conform when they do not, e.g. by converting 1+2 into 3.
+
+      function FCE (Given_E1, Given_E2 : Node_Id) return Boolean
+        renames Fully_Conformant_Expressions;
+
+      function FCL (L1, L2 : List_Id) return Boolean;
+      --  Compare elements of two lists for conformance. Elements have to
+      --  be conformant, and actuals inserted as default parameters do not
+      --  match explicit actuals with the same value.
+
+      function FCO (Op_Node, Call_Node : Node_Id) return Boolean;
+      --  Compare an operator node with a function call.
+
+      ---------
+      -- FCL --
+      ---------
+
+      function FCL (L1, L2 : List_Id) return Boolean is
+         N1, N2 : Node_Id;
+
+      begin
+         if L1 = No_List then
+            N1 := Empty;
+         else
+            N1 := First (L1);
+         end if;
+
+         if L2 = No_List then
+            N2 := Empty;
+         else
+            N2 := First (L2);
+         end if;
+
+         --  Compare two lists, skipping rewrite insertions (we want to
+         --  compare the original trees, not the expanded versions!)
+
+         loop
+            if Is_Rewrite_Insertion (N1) then
+               Next (N1);
+            elsif Is_Rewrite_Insertion (N2) then
+               Next (N2);
+            elsif No (N1) then
+               return No (N2);
+            elsif No (N2) then
+               return False;
+            elsif not FCE (N1, N2) then
+               return False;
+            else
+               Next (N1);
+               Next (N2);
+            end if;
+         end loop;
+      end FCL;
+
+      ---------
+      -- FCO --
+      ---------
+
+      function FCO (Op_Node, Call_Node : Node_Id) return Boolean is
+         Actuals : constant List_Id := Parameter_Associations (Call_Node);
+         Act     : Node_Id;
+
+      begin
+         if No (Actuals)
+            or else Entity (Op_Node) /= Entity (Name (Call_Node))
+         then
+            return False;
+
+         else
+            Act := First (Actuals);
+
+            if Nkind (Op_Node) in N_Binary_Op then
+
+               if not FCE (Left_Opnd (Op_Node), Act) then
+                  return False;
+               end if;
+
+               Next (Act);
+            end if;
+
+            return Present (Act)
+              and then FCE (Right_Opnd (Op_Node), Act)
+              and then No (Next (Act));
+         end if;
+      end FCO;
+
+   --  Start of processing for Fully_Conformant_Expressions
+
+   begin
+      --  Non-conformant if paren count does not match. Note: if some idiot
+      --  complains that we don't do this right for more than 3 levels of
+      --  parentheses, they will be treated with the respect they deserve :-)
+
+      if Paren_Count (E1) /= Paren_Count (E2) then
+         return False;
+
+      --  If same entities are referenced, then they are conformant
+      --  even if they have different forms (RM 8.3.1(19-20)).
+
+      elsif Is_Entity_Name (E1) and then Is_Entity_Name (E2) then
+         if Present (Entity (E1)) then
+            return Entity (E1) = Entity (E2)
+              or else (Chars (Entity (E1)) = Chars (Entity (E2))
+                        and then Ekind (Entity (E1)) = E_Discriminant
+                        and then Ekind (Entity (E2)) = E_In_Parameter);
+
+         elsif Nkind (E1) = N_Expanded_Name
+           and then Nkind (E2) = N_Expanded_Name
+           and then Nkind (Selector_Name (E1)) = N_Character_Literal
+           and then Nkind (Selector_Name (E2)) = N_Character_Literal
+         then
+            return Chars (Selector_Name (E1)) = Chars (Selector_Name (E2));
+
+         else
+            --  Identifiers in component associations don't always have
+            --  entities, but their names must conform.
+
+            return Nkind  (E1) = N_Identifier
+              and then Nkind (E2) = N_Identifier
+              and then Chars (E1) = Chars (E2);
+         end if;
+
+      elsif Nkind (E1) = N_Character_Literal
+        and then Nkind (E2) = N_Expanded_Name
+      then
+         return Nkind (Selector_Name (E2)) = N_Character_Literal
+           and then Chars (E1) = Chars (Selector_Name (E2));
+
+      elsif Nkind (E2) = N_Character_Literal
+        and then Nkind (E1) = N_Expanded_Name
+      then
+         return Nkind (Selector_Name (E1)) = N_Character_Literal
+           and then Chars (E2) = Chars (Selector_Name (E1));
+
+      elsif Nkind (E1) in N_Op
+        and then Nkind (E2) = N_Function_Call
+      then
+         return FCO (E1, E2);
+
+      elsif Nkind (E2) in N_Op
+        and then Nkind (E1) = N_Function_Call
+      then
+         return FCO (E2, E1);
+
+      --  Otherwise we must have the same syntactic entity
+
+      elsif Nkind (E1) /= Nkind (E2) then
+         return False;
+
+      --  At this point, we specialize by node type
+
+      else
+         case Nkind (E1) is
+
+            when N_Aggregate =>
+               return
+                 FCL (Expressions (E1), Expressions (E2))
+                   and then FCL (Component_Associations (E1),
+                                 Component_Associations (E2));
+
+            when N_Allocator =>
+               if Nkind (Expression (E1)) = N_Qualified_Expression
+                    or else
+                  Nkind (Expression (E2)) = N_Qualified_Expression
+               then
+                  return FCE (Expression (E1), Expression (E2));
+
+               --  Check that the subtype marks and any constraints
+               --  are conformant
+
+               else
+                  declare
+                     Indic1 : constant Node_Id := Expression (E1);
+                     Indic2 : constant Node_Id := Expression (E2);
+                     Elt1   : Node_Id;
+                     Elt2   : Node_Id;
+
+                  begin
+                     if Nkind (Indic1) /= N_Subtype_Indication then
+                        return
+                          Nkind (Indic2) /= N_Subtype_Indication
+                            and then Entity (Indic1) = Entity (Indic2);
+
+                     elsif Nkind (Indic2) /= N_Subtype_Indication then
+                        return
+                          Nkind (Indic1) /= N_Subtype_Indication
+                            and then Entity (Indic1) = Entity (Indic2);
+
+                     else
+                        if Entity (Subtype_Mark (Indic1)) /=
+                          Entity (Subtype_Mark (Indic2))
+                        then
+                           return False;
+                        end if;
+
+                        Elt1 := First (Constraints (Constraint (Indic1)));
+                        Elt2 := First (Constraints (Constraint (Indic2)));
+
+                        while Present (Elt1) and then Present (Elt2) loop
+                           if not FCE (Elt1, Elt2) then
+                              return False;
+                           end if;
+
+                           Next (Elt1);
+                           Next (Elt2);
+                        end loop;
+
+                        return True;
+                     end if;
+                  end;
+               end if;
+
+            when N_Attribute_Reference =>
+               return
+                 Attribute_Name (E1) = Attribute_Name (E2)
+                   and then FCL (Expressions (E1), Expressions (E2));
+
+            when N_Binary_Op =>
+               return
+                 Entity (E1) = Entity (E2)
+                   and then FCE (Left_Opnd  (E1), Left_Opnd  (E2))
+                   and then FCE (Right_Opnd (E1), Right_Opnd (E2));
+
+            when N_And_Then | N_Or_Else | N_In | N_Not_In =>
+               return
+                 FCE (Left_Opnd  (E1), Left_Opnd  (E2))
+                   and then
+                 FCE (Right_Opnd (E1), Right_Opnd (E2));
+
+            when N_Character_Literal =>
+               return
+                 Char_Literal_Value (E1) = Char_Literal_Value (E2);
+
+            when N_Component_Association =>
+               return
+                 FCL (Choices (E1), Choices (E2))
+                   and then FCE (Expression (E1), Expression (E2));
+
+            when N_Conditional_Expression =>
+               return
+                 FCL (Expressions (E1), Expressions (E2));
+
+            when N_Explicit_Dereference =>
+               return
+                 FCE (Prefix (E1), Prefix (E2));
+
+            when N_Extension_Aggregate =>
+               return
+                 FCL (Expressions (E1), Expressions (E2))
+                   and then Null_Record_Present (E1) =
+                            Null_Record_Present (E2)
+                   and then FCL (Component_Associations (E1),
+                               Component_Associations (E2));
+
+            when N_Function_Call =>
+               return
+                 FCE (Name (E1), Name (E2))
+                   and then FCL (Parameter_Associations (E1),
+                                 Parameter_Associations (E2));
+
+            when N_Indexed_Component =>
+               return
+                 FCE (Prefix (E1), Prefix (E2))
+                   and then FCL (Expressions (E1), Expressions (E2));
+
+            when N_Integer_Literal =>
+               return (Intval (E1) = Intval (E2));
+
+            when N_Null =>
+               return True;
+
+            when N_Operator_Symbol =>
+               return
+                 Chars (E1) = Chars (E2);
+
+            when N_Others_Choice =>
+               return True;
+
+            when N_Parameter_Association =>
+               return
+
+                 Chars (Selector_Name (E1))  = Chars (Selector_Name (E2))
+                   and then FCE (Explicit_Actual_Parameter (E1),
+                                 Explicit_Actual_Parameter (E2));
+
+            when N_Qualified_Expression =>
+               return
+                 FCE (Subtype_Mark (E1), Subtype_Mark (E2))
+                   and then FCE (Expression (E1), Expression (E2));
+
+            when N_Range =>
+               return
+                 FCE (Low_Bound (E1), Low_Bound (E2))
+                   and then FCE (High_Bound (E1), High_Bound (E2));
+
+            when N_Real_Literal =>
+               return (Realval (E1) = Realval (E2));
+
+            when N_Selected_Component =>
+               return
+                 FCE (Prefix (E1), Prefix (E2))
+                   and then FCE (Selector_Name (E1), Selector_Name (E2));
+
+            when N_Slice =>
+               return
+                 FCE (Prefix (E1), Prefix (E2))
+                   and then FCE (Discrete_Range (E1), Discrete_Range (E2));
+
+            when N_String_Literal =>
+               declare
+                  S1 : constant String_Id := Strval (E1);
+                  S2 : constant String_Id := Strval (E2);
+                  L1 : constant Nat       := String_Length (S1);
+                  L2 : constant Nat       := String_Length (S2);
+
+               begin
+                  if L1 /= L2 then
+                     return False;
+
+                  else
+                     for J in 1 .. L1 loop
+                        if Get_String_Char (S1, J) /=
+                           Get_String_Char (S2, J)
+                        then
+                           return False;
+                        end if;
+                     end loop;
+
+                     return True;
+                  end if;
+               end;
+
+            when N_Type_Conversion =>
+               return
+                 FCE (Subtype_Mark (E1), Subtype_Mark (E2))
+                   and then FCE (Expression (E1), Expression (E2));
+
+            when N_Unary_Op =>
+               return
+                 Entity (E1) = Entity (E2)
+                   and then FCE (Right_Opnd (E1), Right_Opnd (E2));
+
+            when N_Unchecked_Type_Conversion =>
+               return
+                 FCE (Subtype_Mark (E1), Subtype_Mark (E2))
+                   and then FCE (Expression (E1), Expression (E2));
+
+            --  All other node types cannot appear in this context. Strictly
+            --  we should raise a fatal internal error. Instead we just ignore
+            --  the nodes. This means that if anyone makes a mistake in the
+            --  expander and mucks an expression tree irretrievably, the
+            --  result will be a failure to detect a (probably very obscure)
+            --  case of non-conformance, which is better than bombing on some
+            --  case where two expressions do in fact conform.
+
+            when others =>
+               return True;
+
+         end case;
+      end if;
+   end Fully_Conformant_Expressions;
+
+   --------------------
+   -- Install_Entity --
+   --------------------
+
+   procedure Install_Entity (E : Entity_Id) is
+      Prev : constant Entity_Id := Current_Entity (E);
+
+   begin
+      Set_Is_Immediately_Visible (E);
+      Set_Current_Entity (E);
+      Set_Homonym (E, Prev);
+   end Install_Entity;
+
+   ---------------------
+   -- Install_Formals --
+   ---------------------
+
+   procedure Install_Formals (Id : Entity_Id) is
+      F : Entity_Id;
+
+   begin
+      F := First_Formal (Id);
+
+      while Present (F) loop
+         Install_Entity (F);
+         Next_Formal (F);
+      end loop;
+   end Install_Formals;
+
+   ---------------------------------
+   -- Is_Non_Overriding_Operation --
+   ---------------------------------
+
+   function Is_Non_Overriding_Operation
+     (Prev_E : Entity_Id;
+      New_E  : Entity_Id)
+      return Boolean
+   is
+      Formal : Entity_Id;
+      F_Typ  : Entity_Id;
+      G_Typ  : Entity_Id := Empty;
+
+      function Get_Generic_Parent_Type (F_Typ : Entity_Id) return Entity_Id;
+      --  If F_Type is a derived type associated with a generic actual
+      --  subtype, then return its Generic_Parent_Type attribute, else
+      --  return Empty.
+
+      function Types_Correspond
+        (P_Type : Entity_Id;
+         N_Type : Entity_Id)
+         return   Boolean;
+      --  Returns true if and only if the types (or designated types
+      --  in the case of anonymous access types) are the same or N_Type
+      --  is derived directly or indirectly from P_Type.
+
+      -----------------------------
+      -- Get_Generic_Parent_Type --
+      -----------------------------
+
+      function Get_Generic_Parent_Type (F_Typ : Entity_Id) return Entity_Id is
+         G_Typ : Entity_Id;
+         Indic : Node_Id;
+
+      begin
+         if Is_Derived_Type (F_Typ)
+           and then Nkind (Parent (F_Typ)) = N_Full_Type_Declaration
+         then
+            --  The tree must be traversed to determine the parent
+            --  subtype in the generic unit, which unfortunately isn't
+            --  always available via semantic attributes. ???
+            --  (Note: The use of Original_Node is needed for cases
+            --  where a full derived type has been rewritten.)
+
+            Indic := Subtype_Indication
+                       (Type_Definition (Original_Node (Parent (F_Typ))));
+
+            if Nkind (Indic) = N_Subtype_Indication then
+               G_Typ := Entity (Subtype_Mark (Indic));
+            else
+               G_Typ := Entity (Indic);
+            end if;
+
+            if Nkind (Parent (G_Typ)) = N_Subtype_Declaration
+              and then Present (Generic_Parent_Type (Parent (G_Typ)))
+            then
+               return Generic_Parent_Type (Parent (G_Typ));
+            end if;
+         end if;
+
+         return Empty;
+      end Get_Generic_Parent_Type;
+
+      ----------------------
+      -- Types_Correspond --
+      ----------------------
+
+      function Types_Correspond
+        (P_Type : Entity_Id;
+         N_Type : Entity_Id)
+         return   Boolean
+      is
+         Prev_Type : Entity_Id := Base_Type (P_Type);
+         New_Type  : Entity_Id := Base_Type (N_Type);
+
+      begin
+         if Ekind (Prev_Type) = E_Anonymous_Access_Type then
+            Prev_Type := Designated_Type (Prev_Type);
+         end if;
+
+         if Ekind (New_Type) = E_Anonymous_Access_Type then
+            New_Type := Designated_Type (New_Type);
+         end if;
+
+         if Prev_Type = New_Type then
+            return True;
+
+         elsif not Is_Class_Wide_Type (New_Type) then
+            while Etype (New_Type) /= New_Type loop
+               New_Type := Etype (New_Type);
+               if New_Type = Prev_Type then
+                  return True;
+               end if;
+            end loop;
+         end if;
+         return False;
+      end Types_Correspond;
+
+   --  Start of processing for Is_Non_Overriding_Operation
+
+   begin
+      --  In the case where both operations are implicit derived
+      --  subprograms then neither overrides the other. This can
+      --  only occur in certain obscure cases (e.g., derivation
+      --  from homographs created in a generic instantiation).
+
+      if Present (Alias (Prev_E)) and then Present (Alias (New_E)) then
+         return True;
+
+      elsif Ekind (Current_Scope) = E_Package
+        and then Is_Generic_Instance (Current_Scope)
+        and then In_Private_Part (Current_Scope)
+        and then Comes_From_Source (New_E)
+      then
+         --  We examine the formals and result subtype of the inherited
+         --  operation, to determine whether their type is derived from
+         --  (the instance of) a generic type.
+
+         Formal := First_Formal (Prev_E);
+
+         while Present (Formal) loop
+            F_Typ := Base_Type (Etype (Formal));
+
+            if Ekind (F_Typ) = E_Anonymous_Access_Type then
+               F_Typ := Designated_Type (F_Typ);
+            end if;
+
+            G_Typ := Get_Generic_Parent_Type (F_Typ);
+
+            Next_Formal (Formal);
+         end loop;
+
+         if not Present (G_Typ) and then Ekind (Prev_E) = E_Function then
+            G_Typ := Get_Generic_Parent_Type (Base_Type (Etype (Prev_E)));
+         end if;
+
+         if No (G_Typ) then
+            return False;
+         end if;
+
+         --  If the generic type is a private type, then the original
+         --  operation was not overriding in the generic, because there was
+         --  no primitive operation to override.
+
+         if Nkind (Parent (G_Typ)) = N_Formal_Type_Declaration
+           and then Nkind (Formal_Type_Definition (Parent (G_Typ))) =
+             N_Formal_Private_Type_Definition
+         then
+            return True;
+
+         --  The generic parent type is the ancestor of a formal derived
+         --  type declaration. We need to check whether it has a primitive
+         --  operation that should be overridden by New_E in the generic.
+
+         else
+            declare
+               P_Formal : Entity_Id;
+               N_Formal : Entity_Id;
+               P_Typ    : Entity_Id;
+               N_Typ    : Entity_Id;
+               P_Prim   : Entity_Id;
+               Prim_Elt : Elmt_Id := First_Elmt (Primitive_Operations (G_Typ));
+
+            begin
+               while Present (Prim_Elt) loop
+                  P_Prim := Node (Prim_Elt);
+                  if Chars (P_Prim) = Chars (New_E)
+                    and then Ekind (P_Prim) = Ekind (New_E)
+                  then
+                     P_Formal := First_Formal (P_Prim);
+                     N_Formal := First_Formal (New_E);
+                     while Present (P_Formal) and then Present (N_Formal) loop
+                        P_Typ := Etype (P_Formal);
+                        N_Typ := Etype (N_Formal);
+
+                        if not Types_Correspond (P_Typ, N_Typ) then
+                           exit;
+                        end if;
+
+                        Next_Entity (P_Formal);
+                        Next_Entity (N_Formal);
+                     end loop;
+
+                     --  Found a matching primitive operation belonging to
+                     --  the formal ancestor type, so the new subprogram
+                     --  is overriding.
+
+                     if not Present (P_Formal)
+                       and then not Present (N_Formal)
+                       and then (Ekind (New_E) /= E_Function
+                                  or else
+                                 Types_Correspond
+                                   (Etype (P_Prim), Etype (New_E)))
+                     then
+                        return False;
+                     end if;
+                  end if;
+
+                  Next_Elmt (Prim_Elt);
+               end loop;
+
+               --  If no match found, then the new subprogram does
+               --  not override in the generic (nor in the instance).
+
+               return True;
+            end;
+         end if;
+      else
+         return False;
+      end if;
+   end Is_Non_Overriding_Operation;
+
+   ------------------------------
+   -- Make_Inequality_Operator --
+   ------------------------------
+
+   --  S is the defining identifier of an equality operator. We build a
+   --  subprogram declaration with the right signature. This operation is
+   --  intrinsic, because it is always expanded as the negation of the
+   --  call to the equality function.
+
+   procedure Make_Inequality_Operator (S : Entity_Id) is
+      Loc     : constant Source_Ptr := Sloc (S);
+      Decl    : Node_Id;
+      Formals : List_Id;
+      Op_Name : Entity_Id;
+
+      A : Entity_Id;
+      B : Entity_Id;
+
+   begin
+      --  Check that equality was properly defined.
+
+      if  No (Next_Formal (First_Formal (S))) then
+         return;
+      end if;
+
+      A := Make_Defining_Identifier (Loc, Chars (First_Formal (S)));
+      B := Make_Defining_Identifier (Loc,
+             Chars (Next_Formal (First_Formal (S))));
+
+      Op_Name := Make_Defining_Operator_Symbol (Loc, Name_Op_Ne);
+
+      Formals := New_List (
+        Make_Parameter_Specification (Loc,
+          Defining_Identifier => A,
+          Parameter_Type =>
+            New_Reference_To (Etype (First_Formal (S)), Loc)),
+
+        Make_Parameter_Specification (Loc,
+          Defining_Identifier => B,
+          Parameter_Type =>
+            New_Reference_To (Etype (Next_Formal (First_Formal (S))), Loc)));
+
+      Decl :=
+        Make_Subprogram_Declaration (Loc,
+          Specification =>
+            Make_Function_Specification (Loc,
+              Defining_Unit_Name => Op_Name,
+              Parameter_Specifications => Formals,
+              Subtype_Mark => New_Reference_To (Standard_Boolean, Loc)));
+
+      --  Insert inequality right after equality if it is explicit or after
+      --  the derived type when implicit. These entities are created only
+      --  for visibility purposes, and eventually replaced in the course of
+      --  expansion, so they do not need to be attached to the tree and seen
+      --  by the back-end. Keeping them internal also avoids spurious freezing
+      --  problems. The parent field is set simply to make analysis safe.
+
+      if No (Alias (S)) then
+         Set_Parent (Decl, Parent (Unit_Declaration_Node (S)));
+      else
+         Set_Parent (Decl, Parent (Parent (Etype (First_Formal (S)))));
+      end if;
+
+      Mark_Rewrite_Insertion (Decl);
+      Set_Is_Intrinsic_Subprogram (Op_Name);
+      Analyze (Decl);
+      Set_Has_Completion (Op_Name);
+      Set_Corresponding_Equality (Op_Name, S);
+      Set_Is_Abstract (Op_Name, Is_Abstract (S));
+
+   end Make_Inequality_Operator;
+
+   ----------------------
+   -- May_Need_Actuals --
+   ----------------------
+
+   procedure May_Need_Actuals (Fun : Entity_Id) is
+      F : Entity_Id;
+      B : Boolean;
+
+   begin
+      F := First_Formal (Fun);
+      B := True;
+
+      while Present (F) loop
+         if No (Default_Value (F)) then
+            B := False;
+            exit;
+         end if;
+
+         Next_Formal (F);
+      end loop;
+
+      Set_Needs_No_Actuals (Fun, B);
+   end May_Need_Actuals;
+
+   ---------------------
+   -- Mode_Conformant --
+   ---------------------
+
+   function Mode_Conformant (New_Id, Old_Id : Entity_Id) return Boolean is
+      Result : Boolean;
+
+   begin
+      Check_Conformance (New_Id, Old_Id, Mode_Conformant, False, Result);
+      return Result;
+   end Mode_Conformant;
+
+   ---------------------------
+   -- New_Overloaded_Entity --
+   ---------------------------
+
+   procedure New_Overloaded_Entity
+     (S            : Entity_Id;
+      Derived_Type : Entity_Id := Empty)
+   is
+      E        : Entity_Id := Current_Entity_In_Scope (S);
+      Prev_Vis : Entity_Id := Empty;
+
+      function Is_Private_Declaration (E : Entity_Id) return Boolean;
+      --  Check that E is declared in the private part of the current package,
+      --  or in the package body, where it may hide a previous declaration.
+      --  We can' use In_Private_Part by itself because this flag is also
+      --  set when freezing entities, so we must examine the place of the
+      --  declaration in the tree, and recognize wrapper packages as well.
+
+      procedure Maybe_Primitive_Operation (Overriding : Boolean := False);
+      --  If the subprogram being analyzed is a primitive operation of
+      --  the type of one of its formals, set the corresponding flag.
+
+      ----------------------------
+      -- Is_Private_Declaration --
+      ----------------------------
+
+      function Is_Private_Declaration (E : Entity_Id) return Boolean is
+         Priv_Decls : List_Id;
+         Decl       : constant Node_Id := Unit_Declaration_Node (E);
+
+      begin
+         if Is_Package (Current_Scope)
+           and then In_Private_Part (Current_Scope)
+         then
+            Priv_Decls :=
+              Private_Declarations (
+                Specification (Unit_Declaration_Node (Current_Scope)));
+
+            return In_Package_Body (Current_Scope)
+              or else List_Containing (Decl) = Priv_Decls
+              or else (Nkind (Parent (Decl)) = N_Package_Specification
+                         and then not Is_Compilation_Unit (
+                           Defining_Entity (Parent (Decl)))
+                         and then List_Containing (Parent (Parent (Decl)))
+                           = Priv_Decls);
+         else
+            return False;
+         end if;
+      end Is_Private_Declaration;
+
+      -------------------------------
+      -- Maybe_Primitive_Operation --
+      -------------------------------
+
+      procedure Maybe_Primitive_Operation (Overriding : Boolean := False) is
+         Formal : Entity_Id;
+         F_Typ  : Entity_Id;
+
+         function Visible_Part_Type (T : Entity_Id) return Boolean;
+         --  Returns true if T is declared in the visible part of
+         --  the current package scope; otherwise returns false.
+         --  Assumes that T is declared in a package.
+
+         procedure Check_Private_Overriding (T : Entity_Id);
+         --  Checks that if a primitive abstract subprogram of a visible
+         --  abstract type is declared in a private part, then it must
+         --  override an abstract subprogram declared in the visible part.
+         --  Also checks that if a primitive function with a controlling
+         --  result is declared in a private part, then it must override
+         --  a function declared in the visible part.
+
+         ------------------------------
+         -- Check_Private_Overriding --
+         ------------------------------
+
+         procedure Check_Private_Overriding (T : Entity_Id) is
+         begin
+            if Ekind (Current_Scope) = E_Package
+              and then In_Private_Part (Current_Scope)
+              and then Visible_Part_Type (T)
+              and then not In_Instance
+            then
+               if Is_Abstract (T)
+                 and then Is_Abstract (S)
+                 and then (not Overriding or else not Is_Abstract (E))
+               then
+                  Error_Msg_N ("abstract subprograms must be visible "
+                                & "('R'M 3.9.3(10))!", S);
+
+               elsif Ekind (S) = E_Function
+                 and then Is_Tagged_Type (T)
+                 and then T = Base_Type (Etype (S))
+                 and then not Overriding
+               then
+                  Error_Msg_N
+                    ("private function with tagged result must"
+                     & " override visible-part function", S);
+                  Error_Msg_N
+                    ("\move subprogram to the visible part"
+                     & " ('R'M 3.9.3(10))", S);
+               end if;
+            end if;
+         end Check_Private_Overriding;
+
+         -----------------------
+         -- Visible_Part_Type --
+         -----------------------
+
+         function Visible_Part_Type (T : Entity_Id) return Boolean is
+            P : Node_Id := Unit_Declaration_Node (Scope (T));
+            N : Node_Id := First (Visible_Declarations (Specification (P)));
+
+         begin
+            --  If the entity is a private type, then it must be
+            --  declared in a visible part.
+
+            if Ekind (T) in Private_Kind then
+               return True;
+            end if;
+
+            --  Otherwise, we traverse the visible part looking for its
+            --  corresponding declaration. We cannot use the declaration
+            --  node directly because in the private part the entity of a
+            --  private type is the one in the full view, which does not
+            --  indicate that it is the completion of something visible.
+
+            while Present (N) loop
+               if Nkind (N) = N_Full_Type_Declaration
+                 and then Present (Defining_Identifier (N))
+                 and then T = Defining_Identifier (N)
+               then
+                  return True;
+
+               elsif (Nkind (N) = N_Private_Type_Declaration
+                       or else
+                      Nkind (N) = N_Private_Extension_Declaration)
+                 and then Present (Defining_Identifier (N))
+                 and then T = Full_View (Defining_Identifier (N))
+               then
+                  return True;
+               end if;
+
+               Next (N);
+            end loop;
+
+            return False;
+         end Visible_Part_Type;
+
+      --  Start of processing for Maybe_Primitive_Operation
+
+      begin
+         if not Comes_From_Source (S) then
+            null;
+
+         elsif (Ekind (Current_Scope) = E_Package
+                 and then not In_Package_Body (Current_Scope))
+           or else Overriding
+         then
+
+            if Ekind (S) = E_Function
+              and then Scope (Base_Type (Etype (S))) = Current_Scope
+            then
+               Set_Has_Primitive_Operations (Base_Type (Etype (S)));
+               Check_Private_Overriding (Base_Type (Etype (S)));
+            end if;
+
+            Formal := First_Formal (S);
+
+            while Present (Formal) loop
+               if Ekind (Etype (Formal)) = E_Anonymous_Access_Type then
+                  F_Typ := Designated_Type (Etype (Formal));
+               else
+                  F_Typ := Etype (Formal);
+               end if;
+
+               if Scope (Base_Type (F_Typ)) = Current_Scope then
+                  Set_Has_Primitive_Operations (Base_Type (F_Typ));
+                  Check_Private_Overriding (Base_Type (F_Typ));
+               end if;
+
+               Next_Formal (Formal);
+            end loop;
+
+         end if;
+      end Maybe_Primitive_Operation;
+
+   --  Start of processing for New_Overloaded_Entity
+
+   begin
+      if No (E) then
+         Enter_Overloaded_Entity (S);
+         Check_Dispatching_Operation (S, Empty);
+         Maybe_Primitive_Operation;
+
+      elsif not Is_Overloadable (E) then
+
+         --  Check for spurious conflict produced by a subprogram that has the
+         --  same name as that of the enclosing generic package. The conflict
+         --  occurs within an instance, between the subprogram and the renaming
+         --  declaration for the package. After the subprogram, the package
+         --  renaming declaration becomes hidden.
+
+         if Ekind (E) = E_Package
+           and then Present (Renamed_Object (E))
+           and then Renamed_Object (E) = Current_Scope
+           and then Nkind (Parent (Renamed_Object (E))) =
+                                                     N_Package_Specification
+           and then Present (Generic_Parent (Parent (Renamed_Object (E))))
+         then
+            Set_Is_Hidden (E);
+            Set_Is_Immediately_Visible (E, False);
+            Enter_Overloaded_Entity (S);
+            Set_Homonym (S, Homonym (E));
+            Check_Dispatching_Operation (S, Empty);
+
+         --  If the subprogram is implicit it is hidden by the previous
+         --  declaration. However if it is dispatching, it must appear in
+         --  the dispatch table anyway, because it can be dispatched to
+         --  even if it cannot be called directly.
+
+         elsif Present (Alias (S))
+           and then not Comes_From_Source (S)
+         then
+            Set_Scope (S, Current_Scope);
+
+            if Is_Dispatching_Operation (Alias (S)) then
+               Check_Dispatching_Operation (S, Empty);
+            end if;
+
+            return;
+
+         else
+            Error_Msg_Sloc := Sloc (E);
+            Error_Msg_N ("& conflicts with declaration#", S);
+
+            --  Useful additional warning.
+
+            if Is_Generic_Unit (E) then
+               Error_Msg_N ("\previous generic unit cannot be overloaded", S);
+            end if;
+
+            return;
+         end if;
+
+      else
+         --  E exists and is overloadable. Determine whether S is the body
+         --  of E, a new overloaded entity with a different signature, or
+         --  an error altogether.
+
+         while Present (E) loop
+            if Scope (E) /= Current_Scope then
+               null;
+
+            elsif Type_Conformant (E, S) then
+
+               --  If the old and new entities have the same profile and
+               --  one is not the body of the other, then this is an error,
+               --  unless one of them is implicitly declared.
+
+               --  There are some cases when both can be implicit, for example
+               --  when both a literal and a function that overrides it are
+               --  inherited in a derivation, or when an inhertited operation
+               --  of a tagged full type overrides the ineherited operation of
+               --  a private extension. Ada 83 had a special rule for the
+               --  the literal case. In Ada95, the later implicit operation
+               --  hides the former, and the literal is always the former.
+               --  In the odd case where both are derived operations declared
+               --  at the same point, both operations should be declared,
+               --  and in that case we bypass the following test and proceed
+               --  to the next part (this can only occur for certain obscure
+               --  cases involving homographs in instances and can't occur for
+               --  dispatching operations ???). Note that the following
+               --  condition is less than clear. For example, it's not at
+               --  all clear why there's a test for E_Entry here. ???
+
+               if Present (Alias (S))
+                 and then (No (Alias (E))
+                            or else Comes_From_Source (E)
+                            or else Is_Dispatching_Operation (E))
+                 and then
+                   (Ekind (E) = E_Entry
+                     or else Ekind (E) /= E_Enumeration_Literal)
+               then
+                  --  When an derived operation is overloaded it may be due
+                  --  to the fact that the full view of a private extension
+                  --  re-inherits. It has to be dealt with.
+
+                  if Is_Package (Current_Scope)
+                    and then In_Private_Part (Current_Scope)
+                  then
+                     Check_Operation_From_Private_View (S, E);
+                  end if;
+
+                  --  In any case the implicit operation remains hidden by
+                  --  the existing declaration.
+
+                  return;
+
+                  --  Within an instance, the renaming declarations for
+                  --  actual subprograms may become ambiguous, but they do
+                  --  not hide each other.
+
+               elsif Ekind (E) /= E_Entry
+                 and then not Comes_From_Source (E)
+                 and then not Is_Generic_Instance (E)
+                 and then (Present (Alias (E))
+                            or else Is_Intrinsic_Subprogram (E))
+                 and then (not In_Instance
+                            or else No (Parent (E))
+                            or else Nkind (Unit_Declaration_Node (E)) /=
+                               N_Subprogram_Renaming_Declaration)
+               then
+                  --  A subprogram child unit is not allowed to override
+                  --  an inherited subprogram (10.1.1(20)).
+
+                  if Is_Child_Unit (S) then
+                     Error_Msg_N
+                       ("child unit overrides inherited subprogram in parent",
+                        S);
+                     return;
+                  end if;
+
+                  if Is_Non_Overriding_Operation (E, S) then
+                     Enter_Overloaded_Entity (S);
+                     if not Present (Derived_Type)
+                       or else Is_Tagged_Type (Derived_Type)
+                     then
+                        Check_Dispatching_Operation (S, Empty);
+                     end if;
+
+                     return;
+                  end if;
+
+                  --  E is a derived operation or an internal operator which
+                  --  is being overridden. Remove E from further visibility.
+                  --  Furthermore, if E is a dispatching operation, it must be
+                  --  replaced in the list of primitive operations of its type
+                  --  (see Override_Dispatching_Operation).
+
+                  declare
+                     Prev : Entity_Id;
+
+                  begin
+                     Prev := First_Entity (Current_Scope);
+
+                     while Present (Prev)
+                       and then Next_Entity (Prev) /= E
+                     loop
+                        Next_Entity (Prev);
+                     end loop;
+
+                     --  It is possible for E to be in the current scope and
+                     --  yet not in the entity chain. This can only occur in a
+                     --  generic context where E is an implicit concatenation
+                     --  in the formal part, because in a generic body the
+                     --  entity chain starts with the formals.
+
+                     pragma Assert
+                       (Present (Prev) or else Chars (E) = Name_Op_Concat);
+
+                     --  E must be removed both from the entity_list of the
+                     --  current scope, and from the visibility chain
+
+                     if Debug_Flag_E then
+                        Write_Str ("Override implicit operation ");
+                        Write_Int (Int (E));
+                        Write_Eol;
+                     end if;
+
+                     --  If E is a predefined concatenation, it stands for four
+                     --  different operations. As a result, a single explicit
+                     --  declaration does not hide it. In a possible ambiguous
+                     --  situation, Disambiguate chooses the user-defined op,
+                     --  so it is correct to retain the previous internal one.
+
+                     if Chars (E) /= Name_Op_Concat
+                       or else Ekind (E) /= E_Operator
+                     then
+                        --  For nondispatching derived operations that are
+                        --  overridden by a subprogram declared in the private
+                        --  part of a package, we retain the derived subprogram
+                        --  but mark it as not immediately visible. If the
+                        --  derived operation was declared in the visible part
+                        --  then this ensures that it will still be visible
+                        --  outside the package with the proper signature
+                        --  (calls from outside must also be directed to this
+                        --  version rather than the overriding one, unlike the
+                        --  dispatching case). Calls from inside the package
+                        --  will still resolve to the overriding subprogram
+                        --  since the derived one is marked as not visible
+                        --  within the package.
+
+                        --  If the private operation is dispatching, we achieve
+                        --  the overriding by keeping the implicit operation
+                        --  but setting its alias to be the overring one. In
+                        --  this fashion the proper body is executed in all
+                        --  cases, but the original signature is used outside
+                        --  of the package.
+
+                        --  If the overriding is not in the private part, we
+                        --  remove the implicit operation altogether.
+
+                        if Is_Private_Declaration (S) then
+
+                           if not Is_Dispatching_Operation (E) then
+                              Set_Is_Immediately_Visible (E, False);
+                           else
+
+                              --  work done in Override_Dispatching_Operation.
+
+                              null;
+                           end if;
+                        else
+
+                           --  Find predecessor of E in Homonym chain.
+
+                           if E = Current_Entity (E) then
+                              Prev_Vis := Empty;
+                           else
+                              Prev_Vis := Current_Entity (E);
+                              while Homonym (Prev_Vis) /= E loop
+                                 Prev_Vis := Homonym (Prev_Vis);
+                              end loop;
+                           end if;
+
+                           if Prev_Vis /= Empty then
+
+                              --  Skip E in the visibility chain
+
+                              Set_Homonym (Prev_Vis, Homonym (E));
+
+                           else
+                              Set_Name_Entity_Id (Chars (E), Homonym (E));
+                           end if;
+
+                           Set_Next_Entity (Prev, Next_Entity (E));
+
+                           if No (Next_Entity (Prev)) then
+                              Set_Last_Entity (Current_Scope, Prev);
+                           end if;
+
+                        end if;
+                     end if;
+
+                     Enter_Overloaded_Entity (S);
+
+                     if Is_Dispatching_Operation (E) then
+                        --  An overriding dispatching subprogram inherits
+                        --  the convention of the overridden subprogram
+                        --  (by AI-117).
+
+                        Set_Convention (S, Convention (E));
+
+                        Check_Dispatching_Operation (S, E);
+                     else
+                        Check_Dispatching_Operation (S, Empty);
+                     end if;
+
+                     Maybe_Primitive_Operation (Overriding => True);
+                     goto Check_Inequality;
+                  end;
+
+               --  Apparent redeclarations in instances can occur when two
+               --  formal types get the same actual type. The subprograms in
+               --  in the instance are legal,  even if not callable from the
+               --  outside. Calls from within are disambiguated elsewhere.
+               --  For dispatching operations in the visible part, the usual
+               --  rules apply, and operations with the same profile are not
+               --  legal (B830001).
+
+               elsif (In_Instance_Visible_Part
+                       and then not Is_Dispatching_Operation (E))
+                 or else In_Instance_Not_Visible
+               then
+                  null;
+
+               --  Here we have a real error (identical profile)
+
+               else
+                  Error_Msg_Sloc := Sloc (E);
+
+                  --  Avoid cascaded errors if the entity appears in
+                  --  subsequent calls.
+
+                  Set_Scope (S, Current_Scope);
+
+                  Error_Msg_N ("& conflicts with declaration#", S);
+
+                  if Is_Generic_Instance (S)
+                    and then not Has_Completion (E)
+                  then
+                     Error_Msg_N
+                       ("\instantiation cannot provide body for it", S);
+                  end if;
+
+                  return;
+               end if;
+
+            else
+               null;
+            end if;
+
+            Prev_Vis := E;
+            E := Homonym (E);
+         end loop;
+
+         --  On exit, we know that S is a new entity
+
+         Enter_Overloaded_Entity (S);
+         Maybe_Primitive_Operation;
+
+         --  If S is a derived operation for an untagged type then
+         --  by definition it's not a dispatching operation (even
+         --  if the parent operation was dispatching), so we don't
+         --  call Check_Dispatching_Operation in that case.
+
+         if not Present (Derived_Type)
+           or else Is_Tagged_Type (Derived_Type)
+         then
+            Check_Dispatching_Operation (S, Empty);
+         end if;
+      end if;
+
+      --  If this is a  user-defined equality operator that is not
+      --  a derived subprogram, create the corresponding inequality.
+      --  If the operation is dispatching, the expansion is done
+      --  elsewhere,  and we do not create an explicit inequality
+      --  operation.
+
+      <<Check_Inequality>>
+         if Chars (S) = Name_Op_Eq
+           and then Etype (S) = Standard_Boolean
+           and then Present (Parent (S))
+           and then not Is_Dispatching_Operation (S)
+         then
+            Make_Inequality_Operator (S);
+         end if;
+
+   end New_Overloaded_Entity;
+
+   ---------------------
+   -- Process_Formals --
+   ---------------------
+
+   procedure Process_Formals
+     (S           : Entity_Id;
+      T           : List_Id;
+      Related_Nod : Node_Id)
+   is
+      Param_Spec  : Node_Id;
+      Formal      : Entity_Id;
+      Formal_Type : Entity_Id;
+      Default     : Node_Id;
+      Ptype       : Entity_Id;
+
+   begin
+      --  In order to prevent premature use of the formals in the same formal
+      --  part, the Ekind is left undefined until all default expressions are
+      --  analyzed. The Ekind is established in a separate loop at the end.
+
+      Param_Spec := First (T);
+
+      while Present (Param_Spec) loop
+
+         Formal := Defining_Identifier (Param_Spec);
+         Enter_Name (Formal);
+
+         --  Case of ordinary parameters
+
+         if Nkind (Parameter_Type (Param_Spec)) /= N_Access_Definition then
+            Find_Type (Parameter_Type (Param_Spec));
+            Ptype := Parameter_Type (Param_Spec);
+
+            if Ptype = Error then
+               goto Continue;
+            end if;
+
+            Formal_Type := Entity (Ptype);
+
+            if Ekind (Formal_Type) = E_Incomplete_Type
+              or else (Is_Class_Wide_Type (Formal_Type)
+                        and then Ekind (Root_Type (Formal_Type)) =
+                                                         E_Incomplete_Type)
+            then
+               if Nkind (Parent (T)) /= N_Access_Function_Definition
+                 and then Nkind (Parent (T)) /= N_Access_Procedure_Definition
+               then
+                  Error_Msg_N ("invalid use of incomplete type", Param_Spec);
+               end if;
+
+            elsif Ekind (Formal_Type) = E_Void then
+               Error_Msg_NE ("premature use of&",
+                 Parameter_Type (Param_Spec), Formal_Type);
+            end if;
+
+         --  An access formal type
+
+         else
+            Formal_Type :=
+              Access_Definition (Related_Nod, Parameter_Type (Param_Spec));
+         end if;
+
+         Set_Etype (Formal, Formal_Type);
+
+         Default :=  Expression (Param_Spec);
+
+         if Present (Default) then
+            if Out_Present (Param_Spec) then
+               Error_Msg_N
+                 ("default initialization only allowed for IN parameters",
+                  Param_Spec);
+            end if;
+
+            --  Do the special preanalysis of the expression (see section on
+            --  "Handling of Default Expressions" in the spec of package Sem).
+
+            Analyze_Default_Expression (Default, Formal_Type);
+
+            --  Check that the designated type of an access parameter's
+            --  default is not a class-wide type unless the parameter's
+            --  designated type is also class-wide.
+
+            if Ekind (Formal_Type) = E_Anonymous_Access_Type
+              and then Is_Class_Wide_Type (Designated_Type (Etype (Default)))
+              and then not Is_Class_Wide_Type (Designated_Type (Formal_Type))
+            then
+               Wrong_Type (Default, Formal_Type);
+            end if;
+         end if;
+
+      <<Continue>>
+         Next (Param_Spec);
+      end loop;
+
+      --  Now set the kind (mode) of each formal
+
+      Param_Spec := First (T);
+
+      while Present (Param_Spec) loop
+         Formal := Defining_Identifier (Param_Spec);
+         Set_Formal_Mode (Formal);
+
+         if Ekind (Formal) = E_In_Parameter then
+            Set_Default_Value (Formal, Expression (Param_Spec));
+
+            if Present (Expression (Param_Spec)) then
+               Default :=  Expression (Param_Spec);
+
+               if Is_Scalar_Type (Etype (Default)) then
+                  if Nkind
+                       (Parameter_Type (Param_Spec)) /= N_Access_Definition
+                  then
+                     Formal_Type := Entity (Parameter_Type (Param_Spec));
+
+                  else
+                     Formal_Type := Access_Definition
+                       (Related_Nod, Parameter_Type (Param_Spec));
+                  end if;
+
+                  Apply_Scalar_Range_Check (Default, Formal_Type);
+               end if;
+
+            end if;
+         end if;
+
+         Next (Param_Spec);
+      end loop;
+
+   end Process_Formals;
+
+   -------------------------
+   -- Set_Actual_Subtypes --
+   -------------------------
+
+   procedure Set_Actual_Subtypes (N : Node_Id; Subp : Entity_Id) is
+      Loc        : constant Source_Ptr := Sloc (N);
+      Decl       : Node_Id;
+      Formal     : Entity_Id;
+      T          : Entity_Id;
+      First_Stmt : Node_Id := Empty;
+      AS_Needed  : Boolean;
+
+   begin
+      Formal := First_Formal (Subp);
+      while Present (Formal) loop
+         T := Etype (Formal);
+
+         --  We never need an actual subtype for a constrained formal.
+
+         if Is_Constrained (T) then
+            AS_Needed := False;
+
+         --  If we have unknown discriminants, then we do not need an
+         --  actual subtype, or more accurately we cannot figure it out!
+         --  Note that all class-wide types have unknown discriminants.
+
+         elsif Has_Unknown_Discriminants (T) then
+            AS_Needed := False;
+
+         --  At this stage we have an unconstrained type that may need
+         --  an actual subtype. For sure the actual subtype is needed
+         --  if we have an unconstrained array type.
+
+         elsif Is_Array_Type (T) then
+            AS_Needed := True;
+
+         --  The only other case which needs an actual subtype is an
+         --  unconstrained record type which is an IN parameter (we
+         --  cannot generate actual subtypes for the OUT or IN OUT case,
+         --  since an assignment can change the discriminant values.
+         --  However we exclude the case of initialization procedures,
+         --  since discriminants are handled very specially in this context,
+         --  see the section entitled "Handling of Discriminants" in Einfo.
+         --  We also exclude the case of Discrim_SO_Functions (functions
+         --  used in front end layout mode for size/offset values), since
+         --  in such functions only discriminants are referenced, and not
+         --  only are such subtypes not needed, but they cannot always
+         --  be generated, because of order of elaboration issues.
+
+         elsif Is_Record_Type (T)
+           and then Ekind (Formal) = E_In_Parameter
+           and then Chars (Formal) /= Name_uInit
+           and then not Is_Discrim_SO_Function (Subp)
+         then
+            AS_Needed := True;
+
+         --  All other cases do not need an actual subtype
+
+         else
+            AS_Needed := False;
+         end if;
+
+         --  Generate actual subtypes for unconstrained arrays and
+         --  unconstrained discriminated records.
+
+         if AS_Needed then
+            Decl := Build_Actual_Subtype (T, Formal);
+
+            if Nkind (N) = N_Accept_Statement then
+               if Present (Handled_Statement_Sequence (N)) then
+                  First_Stmt :=
+                    First (Statements (Handled_Statement_Sequence (N)));
+                  Prepend (Decl, Statements (Handled_Statement_Sequence (N)));
+                  Mark_Rewrite_Insertion (Decl);
+               else
+                  --  If the accept statement has no body, there will be
+                  --  no reference to the actuals, so no need to compute
+                  --  actual subtypes.
+
+                  return;
+               end if;
+
+            else
+               Prepend (Decl, Declarations (N));
+               Mark_Rewrite_Insertion (Decl);
+            end if;
+
+            Analyze (Decl);
+
+            --  We need to freeze manually the generated type when it is
+            --  inserted anywhere else than in a declarative part.
+
+            if Present (First_Stmt) then
+               Insert_List_Before_And_Analyze (First_Stmt,
+                 Freeze_Entity (Defining_Identifier (Decl), Loc));
+            end if;
+
+            Set_Actual_Subtype (Formal, Defining_Identifier (Decl));
+         end if;
+
+         Next_Formal (Formal);
+      end loop;
+   end Set_Actual_Subtypes;
+
+   ---------------------
+   -- Set_Formal_Mode --
+   ---------------------
+
+   procedure Set_Formal_Mode (Formal_Id : Entity_Id) is
+      Spec : constant Node_Id := Parent (Formal_Id);
+
+   begin
+      --  Note: we set Is_Known_Valid for IN parameters and IN OUT parameters
+      --  since we ensure that corresponding actuals are always valid at the
+      --  point of the call.
+
+      if Out_Present (Spec) then
+
+         if Ekind (Scope (Formal_Id)) = E_Function
+           or else Ekind (Scope (Formal_Id)) = E_Generic_Function
+         then
+            Error_Msg_N ("functions can only have IN parameters", Spec);
+            Set_Ekind (Formal_Id, E_In_Parameter);
+
+         elsif In_Present (Spec) then
+            Set_Ekind (Formal_Id, E_In_Out_Parameter);
+
+         else
+            Set_Ekind (Formal_Id, E_Out_Parameter);
+            Set_Not_Source_Assigned (Formal_Id);
+         end if;
+
+      else
+         Set_Ekind (Formal_Id, E_In_Parameter);
+      end if;
+
+      Set_Mechanism (Formal_Id, Default_Mechanism);
+      Set_Formal_Validity (Formal_Id);
+   end Set_Formal_Mode;
+
+   -------------------------
+   -- Set_Formal_Validity --
+   -------------------------
+
+   procedure Set_Formal_Validity (Formal_Id : Entity_Id) is
+   begin
+      --  If in full validity checking mode, then we can assume that
+      --  an IN or IN OUT parameter is valid (see Exp_Ch5.Expand_Call)
+
+      if not Validity_Checks_On then
+         return;
+
+      elsif Ekind (Formal_Id) = E_In_Parameter
+        and then Validity_Check_In_Params
+      then
+         Set_Is_Known_Valid (Formal_Id, True);
+
+      elsif Ekind (Formal_Id) = E_In_Out_Parameter
+        and then Validity_Check_In_Out_Params
+      then
+         Set_Is_Known_Valid (Formal_Id, True);
+      end if;
+   end Set_Formal_Validity;
+
+   ------------------------
+   -- Subtype_Conformant --
+   ------------------------
+
+   function Subtype_Conformant (New_Id, Old_Id : Entity_Id) return Boolean is
+      Result : Boolean;
+
+   begin
+      Check_Conformance (New_Id, Old_Id, Subtype_Conformant, False, Result);
+      return Result;
+   end Subtype_Conformant;
+
+   ---------------------
+   -- Type_Conformant --
+   ---------------------
+
+   function Type_Conformant (New_Id, Old_Id : Entity_Id) return Boolean is
+      Result : Boolean;
+
+   begin
+      Check_Conformance (New_Id, Old_Id, Type_Conformant, False, Result);
+      return Result;
+   end Type_Conformant;
+
+   -------------------------------
+   -- Valid_Operator_Definition --
+   -------------------------------
+
+   procedure Valid_Operator_Definition (Designator : Entity_Id) is
+      N    : Integer := 0;
+      F    : Entity_Id;
+      Id   : constant Name_Id := Chars (Designator);
+      N_OK : Boolean;
+
+   begin
+      F := First_Formal (Designator);
+
+      while Present (F) loop
+         N := N + 1;
+
+         if Present (Default_Value (F)) then
+            Error_Msg_N
+              ("default values not allowed for operator parameters",
+               Parent (F));
+         end if;
+
+         Next_Formal (F);
+      end loop;
+
+      --  Verify that user-defined operators have proper number of arguments
+      --  First case of operators which can only be unary
+
+      if Id = Name_Op_Not
+        or else Id = Name_Op_Abs
+      then
+         N_OK := (N = 1);
+
+      --  Case of operators which can be unary or binary
+
+      elsif Id = Name_Op_Add
+        or Id = Name_Op_Subtract
+      then
+         N_OK := (N in 1 .. 2);
+
+      --  All other operators can only be binary
+
+      else
+         N_OK := (N = 2);
+      end if;
+
+      if not N_OK then
+         Error_Msg_N
+           ("incorrect number of arguments for operator", Designator);
+      end if;
+
+      if Id = Name_Op_Ne
+        and then Base_Type (Etype (Designator)) = Standard_Boolean
+        and then not Is_Intrinsic_Subprogram (Designator)
+      then
+         Error_Msg_N
+            ("explicit definition of inequality not allowed", Designator);
+      end if;
+   end Valid_Operator_Definition;
+
+end Sem_Ch6;
diff --git a/gcc/ada/sem_ch6.ads b/gcc/ada/sem_ch6.ads
new file mode 100644
index 00000000000..beb47569a42
--- /dev/null
+++ b/gcc/ada/sem_ch6.ads
@@ -0,0 +1,170 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              S E M _ C H 6                               --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.22 $                             --
+--                                                                          --
+--   Copyright (C) 1992,1993,1994,1995,1996 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 Sem_Ch6 is
+
+   procedure Analyze_Abstract_Subprogram_Declaration    (N : Node_Id);
+   procedure Analyze_Function_Call                      (N : Node_Id);
+   procedure Analyze_Operator_Symbol                    (N : Node_Id);
+   procedure Analyze_Parameter_Association              (N : Node_Id);
+   procedure Analyze_Procedure_Call                     (N : Node_Id);
+   procedure Analyze_Return_Statement                   (N : Node_Id);
+   procedure Analyze_Subprogram_Declaration             (N : Node_Id);
+   procedure Analyze_Subprogram_Body                    (N : Node_Id);
+
+   function Analyze_Spec (N : Node_Id) return Entity_Id;
+   --  Analyze subprogram specification in both subprogram declarations
+   --  and body declarations.
+
+   procedure Check_Delayed_Subprogram (Designator : Entity_Id);
+   --  Designator can be a E_Subrpgram_Type, E_Procedure or E_Function. If a
+   --  type in its profile depends on a private type without a full
+   --  declaration, indicate that the subprogram is delayed.
+
+   procedure Check_Discriminant_Conformance
+     (N        : Node_Id;
+      Prev     : Entity_Id;
+      Prev_Loc : Node_Id);
+   --  Check that the discriminants of a full type N fully conform to
+   --  the discriminants of the corresponding partial view Prev.
+   --  Prev_Loc indicates the source location of the partial view,
+   --  which may be different than Prev in the case of private types.
+
+   procedure Check_Fully_Conformant
+     (New_Id  : Entity_Id;
+      Old_Id  : Entity_Id;
+      Err_Loc : Node_Id := Empty);
+   --  Check that two callable entitites (subprograms, entries, literals)
+   --  are fully conformant, post error message if not (RM 6.3.1(17)) with
+   --  the flag being placed on the Err_Loc node if it is specified, and
+   --  on the appropriate component of the New_Id construct if not. Note:
+   --  when checking spec/body conformance, New_Id must be the body entity
+   --  and Old_Id is the spec entity (the code in the implementation relies
+   --  on this ordering, and in any case, this makes sense, since if flags
+   --  are to be placed on the construct, they clearly belong on the body.
+
+   procedure Check_Mode_Conformant
+     (New_Id   : Entity_Id;
+      Old_Id   : Entity_Id;
+      Err_Loc  : Node_Id := Empty;
+      Get_Inst : Boolean := False);
+   --  Check that two callable entitites (subprograms, entries, literals)
+   --  are mode conformant, post error message if not (RM 6.3.1(15)) with
+   --  the flag being placed on the Err_Loc node if it is specified, and
+   --  on the appropriate component of the New_Id construct if not. The
+   --  argument Get_Inst is set to True when this is a check against a
+   --  formal access-to-subprogram type, indicating that mapping of types
+   --  is needed.
+
+   procedure Check_Subtype_Conformant
+     (New_Id  : Entity_Id;
+      Old_Id  : Entity_Id;
+      Err_Loc : Node_Id := Empty);
+   --  Check that two callable entitites (subprograms, entries, literals)
+   --  are subtype conformant, post error message if not (RM 6.3.1(16))
+   --  the flag being placed on the Err_Loc node if it is specified, and
+   --  on the appropriate component of the New_Id construct if not.
+
+   procedure Check_Type_Conformant
+     (New_Id  : Entity_Id;
+      Old_Id  : Entity_Id;
+      Err_Loc : Node_Id := Empty);
+   --  Check that two callable entitites (subprograms, entries, literals)
+   --  are type conformant, post error message if not (RM 6.3.1(14)) with
+   --  the flag being placed on the Err_Loc node if it is specified, and
+   --  on the appropriate component of the New_Id construct if not.
+
+   procedure Create_Extra_Formals (E : Entity_Id);
+   --  For each parameter of a subprogram or entry that requires an additional
+   --  formal (such as for access parameters and indefinite discriminated
+   --  parameters), creates the appropriate formal and attach it to its
+   --  associated parameter. Each extra formal will also be appended to
+   --  the end of Subp's parameter list (with each subsequent extra formal
+   --  being attached to the preceding extra formal).
+
+   function Find_Corresponding_Spec (N : Node_Id) return Entity_Id;
+   --  Use the subprogram specification in the body to retrieve the previous
+   --  subprogram declaration, if any.
+
+   function Fully_Conformant (New_Id, Old_Id : Entity_Id) return Boolean;
+   --  Determine whether two callable entities (subprograms, entries,
+   --  literals) are fully conformant (RM 6.3.1(17))
+
+   function Fully_Conformant_Expressions
+     (Given_E1 : Node_Id;
+      Given_E2 : Node_Id)
+      return  Boolean;
+   --  Determines if two (non-empty) expressions are fully conformant
+   --  as defined by (RM 6.3.1(18-21))
+
+   function Mode_Conformant (New_Id, Old_Id : Entity_Id) return Boolean;
+   --  Determine whether two callable entities (subprograms, entries,
+   --  literals) are mode conformant (RM 6.3.1(15))
+
+   procedure New_Overloaded_Entity
+     (S            : Entity_Id;
+      Derived_Type : Entity_Id := Empty);
+   --  Process new overloaded entity. Overloaded entities are created
+   --  by enumeration type declarations, subprogram specifications,
+   --  entry declarations, and (implicitly) by type derivations.
+   --  If Derived_Type is not Empty, then it indicates that this
+   --  is subprogram derived for that type.
+
+   procedure Process_Formals (
+     S           : Entity_Id;
+     T           : List_Id;
+     Related_Nod : Node_Id);
+   --  Enter the formals in the scope of the subprogram or entry, and
+   --  analyze default expressions if any. The implicit types created for
+   --  access parameter are attached to the Related_Nod which comes from the
+   --  context.
+
+   procedure Set_Actual_Subtypes (N : Node_Id; Subp : Entity_Id);
+   --  If the formals of a subprogram are unconstrained, build a subtype
+   --  declaration that uses the bounds or discriminants of the actual to
+   --  construct an actual subtype for them. This is an optimization that
+   --  is done only in some cases where the actual subtype cannot change
+   --  during execution of the subprogram. By setting the actual subtype
+   --  once, we avoid recomputing it unnecessarily.
+
+   procedure Set_Formal_Mode (Formal_Id : Entity_Id);
+   --  Set proper Ekind to reflect formal mode (in, out, in out)
+
+   function Subtype_Conformant (New_Id, Old_Id : Entity_Id) return Boolean;
+   --  Determine whether two callable entities (subprograms, entries,
+   --  literals) are subtype conformant (RM6.3.1(16))
+
+   function Type_Conformant (New_Id, Old_Id : Entity_Id) return Boolean;
+   --  Determine whether two callable entities (subprograms, entries,
+   --  literals) are type conformant (RM6.3.1(14))
+
+   procedure Valid_Operator_Definition (Designator : Entity_Id);
+   --  Verify that an operator definition has the proper number of formals
+
+end Sem_Ch6;
diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb
new file mode 100644
index 00000000000..c1b0521b38a
--- /dev/null
+++ b/gcc/ada/sem_ch7.adb
@@ -0,0 +1,1703 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              S E M . C H 7                               --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.335 $
+--                                                                          --
+--          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 contains the routines to process package specifications and
+--  bodies. The most important semantic aspects of package processing are the
+--  handling of private and full declarations, and the construction of
+--  dispatch tables for tagged types.
+
+with Atree;    use Atree;
+with Debug;    use Debug;
+with Einfo;    use Einfo;
+with Elists;   use Elists;
+with Errout;   use Errout;
+with Exp_Disp; use Exp_Disp;
+with Exp_Dbug; use Exp_Dbug;
+with Lib;      use Lib;
+with Lib.Xref; use Lib.Xref;
+with Namet;    use Namet;
+with Nmake;    use Nmake;
+with Nlists;   use Nlists;
+with Opt;      use Opt;
+with Output;   use Output;
+with Sem;      use Sem;
+with Sem_Cat;  use Sem_Cat;
+with Sem_Ch3;  use Sem_Ch3;
+with Sem_Ch6;  use Sem_Ch6;
+with Sem_Ch8;  use Sem_Ch8;
+with Sem_Ch12; use Sem_Ch12;
+with Sem_Util; use Sem_Util;
+with Sem_Warn; use Sem_Warn;
+with Snames;   use Snames;
+with Stand;    use Stand;
+with Sinfo;    use Sinfo;
+with Sinput;   use Sinput;
+with Style;
+
+package body Sem_Ch7 is
+
+   -----------------------------------
+   -- Handling private declarations --
+   -----------------------------------
+
+   --  The principle that each entity has a single defining occurrence clashes
+   --  with the presence of two separate definitions for private types: the
+   --  first is the private type declaration, and the second is the full type
+   --  declaration. It is important that all references to the type point to
+   --  the same defining occurence, namely the first one. To enforce the two
+   --  separate views of the entity, the corresponding information is swapped
+   --  between the two declarations. Outside of the package, the defining
+   --  occurence only contains the private declaration information, while in
+   --  the private part and the body of the package the defining occurrence
+   --  contains the full declaration. To simplify the swap, the defining
+   --  occurrence that currently holds the private declaration points to the
+   --  full declaration. During semantic processing the defining occurence also
+   --  points to a list of private dependents, that is to say access types or
+   --  composite types whose designated types or component types are subtypes
+   --  or derived types of the private type in question. After the full decla-
+   --  ration has been seen, the private dependents are updated to indicate
+   --  that they have full definitions.
+
+   -----------------------
+   -- Local Subprograms --
+   -----------------------
+
+   procedure Install_Composite_Operations (P : Entity_Id);
+   --  Composite types declared in the current scope may depend on
+   --  types that were private at the point of declaration, and whose
+   --  full view is now in  scope. Indicate that the corresponding
+   --  operations on the composite type are available.
+
+   function Is_Private_Base_Type (E : Entity_Id) return Boolean;
+   --  True for a private type that is not a subtype.
+
+   function Is_Visible_Dependent (Dep : Entity_Id) return Boolean;
+   --  If the private dependent is a private type whose full view is
+   --  derived from the parent type, its full properties are revealed
+   --  only if we are in the immediate scope of the private dependent.
+   --  Should this predicate be tightened further???
+
+   procedure Preserve_Full_Attributes (Priv, Full : Entity_Id);
+   --  Copy to the private declaration the attributes of the full view
+   --  that need to be available for the partial view also.
+
+   procedure Declare_Inherited_Private_Subprograms (Id : Entity_Id);
+   --  Called upon entering the private part of a public child package
+   --  and the body of a nested package, to potentially declare certain
+   --  inherited subprograms that were inherited by types in the visible
+   --  part, but whose declaration was deferred because the parent
+   --  operation was private and not visible at that point. These
+   --  subprograms are located by traversing the visible part declarations
+   --  looking for nonprivate type extensions and then examining each of
+   --  the primitive operations of such types to find those that were
+   --  inherited but declared with a special internal name. Each such
+   --  operation is now declared as an operation with a normal name (using
+   --  the name of the parent operation) and replaces the previous implicit
+   --  operation in the primitive operations list of the type. If the
+   --  inherited private operation has been overridden, then it's
+   --  replaced by the overriding operation.
+
+   --------------------------
+   -- Analyze_Package_Body --
+   --------------------------
+
+   procedure Analyze_Package_Body (N : Node_Id) is
+      Loc              : constant Source_Ptr := Sloc (N);
+      HSS              : Node_Id;
+      Body_Id          : Entity_Id;
+      Spec_Id          : Entity_Id;
+      Last_Spec_Entity : Entity_Id;
+      New_N            : Node_Id;
+      Pack_Decl        : Node_Id;
+
+   begin
+      --  Find corresponding package specification, and establish the
+      --  current scope. The visible defining entity for the package is the
+      --  defining occurrence in the spec. On exit from the package body, all
+      --  body declarations are attached to the defining entity for the body,
+      --  but the later is never used for name resolution. In this fashion
+      --  there is only one visible entity that denotes the package.
+
+      if Debug_Flag_C then
+         Write_Str ("====  Compiling package body ");
+         Write_Name (Chars (Defining_Entity (N)));
+         Write_Str (" from ");
+         Write_Location (Loc);
+         Write_Eol;
+      end if;
+
+      --  Set Body_Id. Note that this wil be reset to point to the
+      --  generic copy later on in the generic case.
+
+      Body_Id := Defining_Entity (N);
+
+      if Present (Corresponding_Spec (N)) then
+
+         --  Body is body of package instantiation. Corresponding spec
+         --  has already been set.
+
+         Spec_Id := Corresponding_Spec (N);
+         Pack_Decl := Unit_Declaration_Node (Spec_Id);
+
+      else
+         Spec_Id := Current_Entity_In_Scope (Defining_Entity (N));
+
+         if Present (Spec_Id)
+           and then Is_Package (Spec_Id)
+         then
+            Pack_Decl := Unit_Declaration_Node (Spec_Id);
+
+            if Nkind (Pack_Decl) = N_Package_Renaming_Declaration then
+               Error_Msg_N ("cannot supply body for package renaming", N);
+               return;
+
+            elsif Present (Corresponding_Body (Pack_Decl)) then
+               Error_Msg_N ("redefinition of package body", N);
+               return;
+            end if;
+
+         else
+            Error_Msg_N ("missing specification for package body", N);
+            return;
+         end if;
+
+         if Is_Package (Spec_Id)
+           and then
+             (Scope (Spec_Id) = Standard_Standard
+               or else Is_Child_Unit (Spec_Id))
+           and then not Unit_Requires_Body (Spec_Id)
+         then
+            if Ada_83 then
+               Error_Msg_N
+                 ("optional package body (not allowed in Ada 95)?", N);
+            else
+               Error_Msg_N
+                 ("spec of this package does not allow a body", N);
+            end if;
+         end if;
+      end if;
+
+      Set_Is_Compilation_Unit (Body_Id, Is_Compilation_Unit (Spec_Id));
+      Style.Check_Identifier (Body_Id, Spec_Id);
+
+      if Is_Child_Unit (Spec_Id) then
+
+         if Nkind (Parent (N)) /= N_Compilation_Unit then
+            Error_Msg_NE
+              ("body of child unit& cannot be an inner package", N, Spec_Id);
+         end if;
+
+         Set_Is_Child_Unit (Body_Id);
+      end if;
+
+      --  Generic package case
+
+      if Ekind (Spec_Id) = E_Generic_Package then
+
+         --  Disable expansion and perform semantic analysis on copy.
+         --  The unannotated body will be used in all instantiations.
+
+         Body_Id := Defining_Entity (N);
+         Set_Ekind (Body_Id, E_Package_Body);
+         Set_Scope (Body_Id, Scope (Spec_Id));
+         Set_Body_Entity (Spec_Id, Body_Id);
+         Set_Spec_Entity (Body_Id, Spec_Id);
+
+         New_N := Copy_Generic_Node (N, Empty, Instantiating => False);
+         Rewrite (N, New_N);
+
+         --  Update Body_Id to point to the copied node for the remainder
+         --  of the processing.
+
+         Body_Id := Defining_Entity (N);
+         Start_Generic;
+      end if;
+
+      --  The Body_Id is that of the copied node in the generic case, the
+      --  current node otherwise. Note that N was rewritten above, so we
+      --  must be sure to get the latest Body_Id value.
+
+      Set_Ekind (Body_Id, E_Package_Body);
+      Set_Body_Entity (Spec_Id, Body_Id);
+      Set_Spec_Entity (Body_Id, Spec_Id);
+
+      --  Defining name for the package body is not a visible entity: Only
+      --  the defining name for the declaration is visible.
+
+      Set_Etype (Body_Id, Standard_Void_Type);
+      Set_Scope (Body_Id, Scope (Spec_Id));
+      Set_Corresponding_Spec (N, Spec_Id);
+      Set_Corresponding_Body (Pack_Decl, Body_Id);
+
+      --  The body entity is not used for semantics or code generation, but
+      --  it is attached to the entity list of the enclosing scope to simplify
+      --  the listing of back-annotations for the types it main contain.
+
+      if Scope (Spec_Id) /= Standard_Standard then
+         Append_Entity (Body_Id, Scope (Spec_Id));
+      end if;
+
+      --  Indicate that we are currently compiling the body of the package.
+
+      Set_In_Package_Body (Spec_Id);
+      Set_Has_Completion (Spec_Id);
+      Last_Spec_Entity := Last_Entity (Spec_Id);
+
+      New_Scope (Spec_Id);
+
+      Set_Categorization_From_Pragmas (N);
+
+      Install_Visible_Declarations (Spec_Id);
+      Install_Private_Declarations (Spec_Id);
+      Install_Composite_Operations (Spec_Id);
+
+      if Ekind (Spec_Id) = E_Generic_Package then
+         Set_Use (Generic_Formal_Declarations (Pack_Decl));
+      end if;
+
+      Set_Use (Visible_Declarations (Specification (Pack_Decl)));
+      Set_Use (Private_Declarations (Specification (Pack_Decl)));
+
+      --  This is a nested package, so it may be necessary to declare
+      --  certain inherited subprograms that are not yet visible because
+      --  the parent type's subprograms are now visible.
+
+      if Ekind (Scope (Spec_Id)) = E_Package
+        and then Scope (Spec_Id) /= Standard_Standard
+      then
+         Declare_Inherited_Private_Subprograms (Spec_Id);
+      end if;
+
+      if Present (Declarations (N)) then
+         Analyze_Declarations (Declarations (N));
+      end if;
+
+      HSS := Handled_Statement_Sequence (N);
+
+      if Present (HSS) then
+         Process_End_Label (HSS, 't');
+         Analyze (HSS);
+
+         --  Check that elaboration code in a preelaborable package body is
+         --  empty other than null statements and labels (RM 10.2.1(6)).
+
+         Validate_Null_Statement_Sequence (N);
+      end if;
+
+      Validate_Categorization_Dependency (N, Spec_Id);
+      Check_Completion (Body_Id);
+
+      --  Generate start of body reference. Note that we do this fairly late,
+      --  because the call will use In_Extended_Main_Source_Unit as a check,
+      --  and we want to make sure that Corresponding_Stub links are set
+
+      Generate_Reference (Spec_Id, Body_Id, 'b');
+
+      --  For a generic package, collect global references and mark
+      --  them on the original body so that they are not resolved
+      --  again at the point of instantiation.
+
+      if Ekind (Spec_Id) /= E_Package then
+         Save_Global_References (Original_Node (N));
+         End_Generic;
+      end if;
+
+      --  The entities of the package body have so far been chained onto
+      --  the declaration chain for the spec. That's been fine while we
+      --  were in the body, since we wanted them to be visible, but now
+      --  that we are leaving the package body, they are no longer visible,
+      --  so we remove them from the entity chain of the package spec entity,
+      --  and copy them to the entity chain of the package body entity, where
+      --  they will never again be visible.
+
+      if Present (Last_Spec_Entity) then
+         Set_First_Entity (Body_Id, Next_Entity (Last_Spec_Entity));
+         Set_Next_Entity (Last_Spec_Entity, Empty);
+         Set_Last_Entity (Body_Id, Last_Entity (Spec_Id));
+         Set_Last_Entity (Spec_Id, Last_Spec_Entity);
+
+      else
+         Set_First_Entity (Body_Id, First_Entity (Spec_Id));
+         Set_Last_Entity  (Body_Id, Last_Entity  (Spec_Id));
+         Set_First_Entity (Spec_Id, Empty);
+         Set_Last_Entity  (Spec_Id, Empty);
+      end if;
+
+      End_Package_Scope (Spec_Id);
+
+      --  All entities declared in body are not visible.
+
+      declare
+         E : Entity_Id;
+
+      begin
+         E := First_Entity (Body_Id);
+
+         while Present (E) loop
+            Set_Is_Immediately_Visible (E, False);
+            Set_Is_Potentially_Use_Visible (E, False);
+            Set_Is_Hidden (E);
+
+            --  Child units may appear on the entity list (for example if
+            --  they appear in the context of a subunit) but they are not
+            --  body entities.
+
+            if not Is_Child_Unit (E) then
+               Set_Is_Package_Body_Entity (E);
+            end if;
+
+            Next_Entity (E);
+         end loop;
+      end;
+
+      Check_References (Body_Id);
+
+      --  The processing so far has made all entities of the package body
+      --  public (i.e. externally visible to the linker). This is in general
+      --  necessary, since inlined or generic bodies, for which code is
+      --  generated in other units, may need to see these entities. The
+      --  following loop runs backwards from the end of the entities of the
+      --  package body making these entities invisible until we reach a
+      --  referencer, i.e. a declaration that could reference a previous
+      --  declaration, a generic body or an inlined body, or a stub (which
+      --  may contain either of these). This is of course an approximation,
+      --  but it is conservative and definitely correct.
+
+      --  We only do this at the outer (library) level non-generic packages.
+      --  The reason is simply to cut down on the number of external symbols
+      --  generated, so this is simply an optimization of the efficiency
+      --  of the compilation process. It has no other effect.
+
+      if (Scope (Spec_Id) = Standard_Standard or else Is_Child_Unit (Spec_Id))
+        and then not Is_Generic_Unit (Spec_Id)
+        and then Present (Declarations (N))
+      then
+         Make_Non_Public_Where_Possible : declare
+            Discard : Boolean;
+
+            function Has_Referencer
+              (L     : List_Id;
+               Outer : Boolean)
+               return  Boolean;
+            --  Traverse the given list of declarations in reverse order.
+            --  Return True as soon as a referencer is reached. Return
+            --  False if none is found. The Outer parameter is True for
+            --  the outer level call, and False for inner level calls for
+            --  nested packages. If Outer is True, then any entities up
+            --  to the point of hitting a referencer get their Is_Public
+            --  flag cleared, so that the entities will be treated as
+            --  static entities in the C sense, and need not have fully
+            --  qualified names. For inner levels, we need all names to
+            --  be fully qualified to deal with the same name appearing
+            --  in parallel packages (right now this is tied to their
+            --  being external).
+
+            --------------------
+            -- Has_Referencer --
+            --------------------
+
+            function Has_Referencer
+              (L     : List_Id;
+               Outer : Boolean)
+               return  Boolean
+            is
+               D : Node_Id;
+               E : Entity_Id;
+               K : Node_Kind;
+               S : Entity_Id;
+
+            begin
+               if No (L) then
+                  return False;
+               end if;
+
+               D := Last (L);
+
+               while Present (D) loop
+                  K := Nkind (D);
+
+                  if K in N_Body_Stub then
+                     return True;
+
+                  elsif K = N_Subprogram_Body then
+                     if Acts_As_Spec (D) then
+                        E := Defining_Entity (D);
+
+                        --  An inlined body acts as a referencer. Note also
+                        --  that we never reset Is_Public for an inlined
+                        --  subprogram. Gigi requires Is_Public to be set.
+
+                        --  Note that we test Has_Pragma_Inline here rather
+                        --  than Is_Inlined. We are compiling this for a
+                        --  client, and it is the client who will decide
+                        --  if actual inlining should occur, so we need to
+                        --  assume that the procedure could be inlined for
+                        --  the purpose of accessing global entities.
+
+                        if Has_Pragma_Inline (E) then
+                           return True;
+                        else
+                           Set_Is_Public (E, False);
+                        end if;
+
+                     else
+                        E := Corresponding_Spec (D);
+
+                        if Present (E)
+                          and then (Is_Generic_Unit (E)
+                                     or else Has_Pragma_Inline (E)
+                                     or else Is_Inlined (E))
+                        then
+                           return True;
+                        end if;
+                     end if;
+
+                  --  Processing for package bodies
+
+                  elsif K = N_Package_Body
+                    and then Present (Corresponding_Spec (D))
+                  then
+                     E := Corresponding_Spec (D);
+
+                     --  Generic package body is a referencer. It would
+                     --  seem that we only have to consider generics that
+                     --  can be exported, i.e. where the corresponding spec
+                     --  is the spec of the current package, but because of
+                     --  nested instantiations, a fully private generic
+                     --  body may export other private body entities.
+
+                     if Is_Generic_Unit (E) then
+                        return True;
+
+                     --  For non-generic package body, recurse into body
+                     --  unless this is an instance, we ignore instances
+                     --  since they cannot have references that affect
+                     --  outer entities.
+
+                     elsif not Is_Generic_Instance (E) then
+                        if Has_Referencer
+                             (Declarations (D), Outer => False)
+                        then
+                           return True;
+                        end if;
+                     end if;
+
+                  --  Processing for package specs, recurse into declarations.
+                  --  Again we skip this for the case of generic instances.
+
+                  elsif K = N_Package_Declaration then
+                     S := Specification (D);
+
+                     if not Is_Generic_Unit (Defining_Entity (S)) then
+                        if Has_Referencer
+                             (Private_Declarations (S), Outer => False)
+                        then
+                           return True;
+                        elsif Has_Referencer
+                               (Visible_Declarations (S), Outer => False)
+                        then
+                           return True;
+                        end if;
+                     end if;
+
+                  --  Objects and exceptions need not be public if we have
+                  --  not encountered a referencer so far. We only reset
+                  --  the flag for outer level entities that are not
+                  --  imported/exported, and which have no interface name.
+
+                  elsif K = N_Object_Declaration
+                    or else K = N_Exception_Declaration
+                    or else K = N_Subprogram_Declaration
+                  then
+                     E := Defining_Entity (D);
+
+                     if Outer
+                       and then not Is_Imported (E)
+                       and then not Is_Exported (E)
+                       and then No (Interface_Name (E))
+                     then
+                        Set_Is_Public (E, False);
+                     end if;
+                  end if;
+
+                  Prev (D);
+               end loop;
+
+               return False;
+            end Has_Referencer;
+
+         --  Start of processing for Make_Non_Public_Where_Possible
+
+         begin
+            Discard := Has_Referencer (Declarations (N), Outer => True);
+         end Make_Non_Public_Where_Possible;
+      end if;
+
+      --  If expander is not active, then here is where we turn off the
+      --  In_Package_Body flag, otherwise it is turned off at the end of
+      --  the corresponding expansion routine. If this is an instance body,
+      --  we need to qualify names of local entities, because the body may
+      --  have been compiled as a preliminary to another instantiation.
+
+      if not Expander_Active then
+         Set_In_Package_Body (Spec_Id, False);
+
+         if Is_Generic_Instance (Spec_Id)
+           and then Operating_Mode = Generate_Code
+         then
+            Qualify_Entity_Names (N);
+         end if;
+      end if;
+   end Analyze_Package_Body;
+
+   ---------------------------------
+   -- Analyze_Package_Declaration --
+   ---------------------------------
+
+   procedure Analyze_Package_Declaration (N : Node_Id) is
+      Id : constant Node_Id := Defining_Entity (N);
+      PF : Boolean;
+
+   begin
+      Generate_Definition (Id);
+      Enter_Name (Id);
+      Set_Ekind (Id, E_Package);
+      Set_Etype (Id, Standard_Void_Type);
+      New_Scope (Id);
+
+      PF := Is_Pure (Enclosing_Lib_Unit_Entity);
+      Set_Is_Pure (Id, PF);
+
+      Set_Categorization_From_Pragmas (N);
+
+      if Debug_Flag_C then
+         Write_Str ("====  Compiling package spec ");
+         Write_Name (Chars (Id));
+         Write_Str (" from ");
+         Write_Location (Sloc (N));
+         Write_Eol;
+      end if;
+
+      Analyze (Specification (N));
+      Validate_Categorization_Dependency (N, Id);
+      End_Package_Scope (Id);
+
+      --  For a compilation unit, indicate whether it needs a body, and
+      --  whether elaboration warnings may be meaningful on it.
+
+      if Nkind (Parent (N)) = N_Compilation_Unit then
+         Set_Body_Required (Parent (N), Unit_Requires_Body (Id));
+
+         if not Body_Required (Parent (N)) then
+            Set_Suppress_Elaboration_Warnings (Id);
+         end if;
+
+         Validate_RT_RAT_Component (N);
+      end if;
+
+      --  Clear Not_Source_Assigned on all variables in the package spec,
+      --  because at this stage some client, or the body, or a child package,
+      --  may modify variables in the declaration. Note that we wait till now
+      --  to reset these flags, because during analysis of the declaration,
+      --  the flags correctly indicated the status up to that point. We
+      --  similarly clear any Is_True_Constant indications.
+
+      declare
+         E : Entity_Id;
+
+      begin
+         E := First_Entity (Id);
+         while Present (E) loop
+            if Ekind (E) = E_Variable then
+               Set_Not_Source_Assigned (E, False);
+               Set_Is_True_Constant    (E, False);
+            end if;
+
+            Next_Entity (E);
+         end loop;
+      end;
+   end Analyze_Package_Declaration;
+
+   -----------------------------------
+   -- Analyze_Package_Specification --
+   -----------------------------------
+
+   procedure Analyze_Package_Specification (N : Node_Id) is
+      Id           : constant Entity_Id  := Defining_Entity (N);
+      Orig_Decl    : constant Node_Id    := Original_Node (Parent (N));
+      Vis_Decls    : constant List_Id    := Visible_Declarations (N);
+      Priv_Decls   : constant List_Id    := Private_Declarations (N);
+      E            : Entity_Id;
+      L            : Entity_Id;
+      Public_Child : Boolean             := False;
+
+      function Is_Public_Child (Child, Unit : Entity_Id) return Boolean;
+      --  Child and Unit are entities of compilation units. True if Child
+      --  is a public child of Parent as defined in 10.1.1
+
+      function Is_Public_Child (Child, Unit : Entity_Id) return Boolean is
+      begin
+         if not Is_Private_Descendant (Child) then
+            return True;
+         else
+            if Child = Unit then
+               return not Private_Present (
+                 Parent (Unit_Declaration_Node (Child)));
+            else
+               return Is_Public_Child (Scope (Child), Unit);
+            end if;
+         end if;
+      end Is_Public_Child;
+
+   --  Start of processing for Analyze_Package_Specification
+
+   begin
+      if Present (Vis_Decls) then
+         Analyze_Declarations (Vis_Decls);
+      end if;
+
+      --  Verify that incomplete types have received full declarations.
+
+      E := First_Entity (Id);
+
+      while Present (E) loop
+         if Ekind (E) = E_Incomplete_Type
+           and then No (Full_View (E))
+         then
+            Error_Msg_N ("no declaration in visible part for incomplete}", E);
+         end if;
+
+         Next_Entity (E);
+      end loop;
+
+      if Is_Remote_Call_Interface (Id)
+         and then Nkind (Parent (Parent (N))) = N_Compilation_Unit
+      then
+         Validate_RCI_Declarations (Id);
+      end if;
+
+      --  Save global references in the visible declarations, before
+      --  installing private declarations of parent unit if there is one,
+      --  because the privacy status of types defined in the parent will
+      --  change. This is only relevant for generic child units, but is
+      --  done in all cases for uniformity.
+
+      if Ekind (Id) = E_Generic_Package
+        and then Nkind (Orig_Decl) = N_Generic_Package_Declaration
+      then
+         declare
+            Orig_Spec : constant Node_Id    := Specification (Orig_Decl);
+            Save_Priv : constant List_Id := Private_Declarations (Orig_Spec);
+
+         begin
+            Set_Private_Declarations (Orig_Spec, Empty_List);
+            Save_Global_References   (Orig_Decl);
+            Set_Private_Declarations (Orig_Spec, Save_Priv);
+         end;
+      end if;
+
+      --  If package is a public child unit, then make the private
+      --  declarations of the parent visible.
+
+      if Present (Parent_Spec (Parent (N))) then
+         declare
+            Par       : Entity_Id := Id;
+            Pack_Decl : Node_Id;
+
+         begin
+            while Scope (Par) /= Standard_Standard
+              and then Is_Public_Child (Id, Par)
+            loop
+               Public_Child := True;
+               Par := Scope (Par);
+               Install_Private_Declarations (Par);
+               Pack_Decl := Unit_Declaration_Node (Par);
+               Set_Use (Private_Declarations (Specification (Pack_Decl)));
+            end loop;
+         end;
+      end if;
+
+      --  Analyze private part if present. The flag In_Private_Part is
+      --  reset in End_Package_Scope.
+
+      L := Last_Entity (Id);
+
+      if Present (Priv_Decls) then
+         L := Last_Entity (Id);
+         Set_In_Private_Part (Id);
+
+         --  Upon entering a public child's private part, it may be
+         --  necessary to declare subprograms that were derived in
+         --  the package visible part but not yet made visible.
+
+         if Public_Child then
+            Declare_Inherited_Private_Subprograms (Id);
+         end if;
+
+         Analyze_Declarations (Priv_Decls);
+
+         --  The first private entity is the immediate follower of the last
+         --  visible entity, if there was one.
+
+         if Present (L) then
+            Set_First_Private_Entity (Id, Next_Entity (L));
+         else
+            Set_First_Private_Entity (Id, First_Entity (Id));
+         end if;
+
+      --  There may be inherited private subprograms that need to be
+      --  declared, even in the absence of an explicit private part.
+      --  If there are any public declarations in the package and
+      --  the package is a public child unit, then an implicit private
+      --  part is assumed.
+
+      elsif Present (L) and then Public_Child then
+         Set_In_Private_Part (Id);
+         Declare_Inherited_Private_Subprograms (Id);
+         Set_First_Private_Entity (Id, Next_Entity (L));
+      end if;
+
+      --  Check rule of 3.6(11), which in general requires
+      --  waiting till all full types have been seen.
+
+      E := First_Entity (Id);
+      while Present (E) loop
+         if Ekind (E) = E_Record_Type or else Ekind (E) = E_Array_Type then
+            Check_Aliased_Component_Types (E);
+         end if;
+
+         Next_Entity (E);
+      end loop;
+
+      if Ekind (Id) = E_Generic_Package
+        and then Nkind (Orig_Decl) = N_Generic_Package_Declaration
+        and then Present (Priv_Decls)
+      then
+         --  Save global references in private declarations, ignoring the
+         --  visible declarations that were processed earlier.
+
+         declare
+            Orig_Spec : constant Node_Id := Specification (Orig_Decl);
+            Save_Vis  : constant List_Id := Visible_Declarations (Orig_Spec);
+            Save_Form : constant List_Id :=
+                          Generic_Formal_Declarations (Orig_Decl);
+
+         begin
+            Set_Visible_Declarations        (Orig_Spec, Empty_List);
+            Set_Generic_Formal_Declarations (Orig_Decl, Empty_List);
+            Save_Global_References          (Orig_Decl);
+            Set_Generic_Formal_Declarations (Orig_Decl, Save_Form);
+            Set_Visible_Declarations        (Orig_Spec, Save_Vis);
+         end;
+      end if;
+
+      Process_End_Label (N, 'e');
+   end Analyze_Package_Specification;
+
+   --------------------------------------
+   -- Analyze_Private_Type_Declaration --
+   --------------------------------------
+
+   procedure Analyze_Private_Type_Declaration (N : Node_Id) is
+      PF : constant Boolean := Is_Pure (Enclosing_Lib_Unit_Entity);
+      Id : Entity_Id := Defining_Identifier (N);
+
+   begin
+      Generate_Definition (Id);
+      Set_Is_Pure         (Id, PF);
+      Init_Size_Align     (Id);
+
+      if (Ekind (Current_Scope) /= E_Package
+          and then Ekind (Current_Scope) /= E_Generic_Package)
+        or else In_Private_Part (Current_Scope)
+      then
+         Error_Msg_N ("invalid context for private declaration", N);
+      end if;
+
+      New_Private_Type (N, Id, N);
+      Set_Depends_On_Private (Id);
+      Set_Has_Delayed_Freeze (Id);
+
+   end Analyze_Private_Type_Declaration;
+
+   -------------------------------------------
+   -- Declare_Inherited_Private_Subprograms --
+   -------------------------------------------
+
+   procedure Declare_Inherited_Private_Subprograms (Id : Entity_Id) is
+      E : Entity_Id;
+
+   begin
+      E := First_Entity (Id);
+
+      while Present (E) loop
+
+         --  If the entity is a nonprivate type extension whose parent
+         --  type is declared in an open scope, then the type may have
+         --  inherited operations that now need to be made visible.
+         --  Ditto if the entity is a formal derived type in a child unit.
+
+         if Is_Tagged_Type (E)
+           and then
+             ((Is_Derived_Type (E) and then not Is_Private_Type (E))
+               or else
+             (Nkind (Parent (E)) = N_Private_Extension_Declaration
+               and then Is_Generic_Type (E)))
+           and then In_Open_Scopes (Scope (Etype (E)))
+           and then E = Base_Type (E)
+         then
+            declare
+               Op_List        : constant Elist_Id := Primitive_Operations (E);
+               Op_Elmt        : Elmt_Id := First_Elmt (Op_List);
+               Op_Elmt_2      : Elmt_Id;
+               Prim_Op        : Entity_Id;
+               New_Op         : Entity_Id := Empty;
+               Parent_Subp    : Entity_Id;
+               Found_Explicit : Boolean;
+               Decl_Privates  : Boolean := False;
+
+            begin
+               while Present (Op_Elmt) loop
+                  Prim_Op := Node (Op_Elmt);
+
+                  --  If the primitive operation is an implicit operation
+                  --  with an internal name whose parent operation has
+                  --  a normal name, then we now need to either declare the
+                  --  operation (i.e., make it visible), or replace it
+                  --  by an overriding operation if one exists.
+
+                  if Present (Alias (Prim_Op))
+                    and then not Comes_From_Source (Prim_Op)
+                    and then Is_Internal_Name (Chars (Prim_Op))
+                    and then not Is_Internal_Name (Chars (Alias (Prim_Op)))
+                  then
+                     Parent_Subp := Alias (Prim_Op);
+
+                     Found_Explicit := False;
+                     Op_Elmt_2 := Next_Elmt (Op_Elmt);
+                     while Present (Op_Elmt_2) loop
+                        if Chars (Node (Op_Elmt_2)) = Chars (Parent_Subp)
+                          and then Type_Conformant (Prim_Op, Node (Op_Elmt_2))
+                        then
+                           --  The private inherited operation has been
+                           --  overridden by an explicit subprogram, so
+                           --  change the private op's list element to
+                           --  designate the explicit so the explicit
+                           --  one will get the right dispatching slot.
+
+                           New_Op := Node (Op_Elmt_2);
+                           Replace_Elmt (Op_Elmt, New_Op);
+                           Remove_Elmt (Op_List, Op_Elmt_2);
+                           Found_Explicit := True;
+                           Decl_Privates  := True;
+                           exit;
+                        end if;
+
+                        Next_Elmt (Op_Elmt_2);
+                     end loop;
+
+                     if not Found_Explicit then
+                        Derive_Subprogram
+                          (New_Op, Alias (Prim_Op), E, Etype (E));
+
+                        pragma Assert
+                          (Is_Dispatching_Operation (New_Op)
+                            and then Node (Last_Elmt (Op_List)) = New_Op);
+
+                        --  Substitute the new operation for the old one
+                        --  in the type's primitive operations list. Since
+                        --  the new operation was also just added to the end
+                        --  of list, the last element must be removed.
+
+                        --  (Question: is there a simpler way of declaring
+                        --  the operation, say by just replacing the name
+                        --  of the earlier operation, reentering it in the
+                        --  in the symbol table (how?), and marking it as
+                        --  private???)
+
+                        Replace_Elmt (Op_Elmt, New_Op);
+                        Remove_Last_Elmt (Op_List);
+                        Decl_Privates := True;
+                     end if;
+                  end if;
+
+                  Next_Elmt (Op_Elmt);
+               end loop;
+
+               --  The type's DT attributes need to be recalculated
+               --  in the case where private dispatching operations
+               --  have been added or overridden. Normally this action
+               --  occurs during type freezing, but we force it here
+               --  since the type may already have been frozen (e.g.,
+               --  if the type's package has an empty private part).
+               --  This can only be done if expansion is active, otherwise
+               --  Tag may not be present.
+
+               if Decl_Privates
+                 and then Expander_Active
+               then
+                  Set_All_DT_Position (E);
+               end if;
+            end;
+         end if;
+
+         Next_Entity (E);
+      end loop;
+   end Declare_Inherited_Private_Subprograms;
+
+   -----------------------
+   -- End_Package_Scope --
+   -----------------------
+
+   procedure End_Package_Scope (P : Entity_Id) is
+   begin
+      Uninstall_Declarations (P);
+      Pop_Scope;
+   end End_Package_Scope;
+
+   ---------------------------
+   -- Exchange_Declarations --
+   ---------------------------
+
+   procedure Exchange_Declarations (Id : Entity_Id) is
+      Full_Id : constant Entity_Id := Full_View (Id);
+      H1      : constant Entity_Id := Homonym (Id);
+      Next1   : constant Entity_Id := Next_Entity (Id);
+      H2      : Entity_Id;
+      Next2   : Entity_Id;
+
+   begin
+      --  If missing full declaration for type, nothing to exchange
+
+      if No (Full_Id) then
+         return;
+      end if;
+
+      --  Otherwise complete the exchange, and preserve semantic links
+
+      Next2 := Next_Entity (Full_Id);
+      H2    := Homonym (Full_Id);
+
+      --  Reset full declaration pointer to reflect the switched entities
+      --  and readjust the next entity chains.
+
+      Exchange_Entities (Id, Full_Id);
+
+      Set_Next_Entity (Id, Next1);
+      Set_Homonym     (Id, H1);
+
+      Set_Full_View   (Full_Id, Id);
+      Set_Next_Entity (Full_Id, Next2);
+      Set_Homonym     (Full_Id, H2);
+   end Exchange_Declarations;
+
+   ----------------------------------
+   -- Install_Composite_Operations --
+   ----------------------------------
+
+   procedure Install_Composite_Operations (P : Entity_Id) is
+      Id : Entity_Id;
+
+   begin
+      Id := First_Entity (P);
+
+      while Present (Id) loop
+
+         if Is_Type (Id)
+           and then (Is_Limited_Composite (Id)
+                      or else Is_Private_Composite (Id))
+           and then No (Private_Component (Id))
+         then
+            Set_Is_Limited_Composite (Id, False);
+            Set_Is_Private_Composite (Id, False);
+         end if;
+
+         Next_Entity (Id);
+      end loop;
+   end Install_Composite_Operations;
+
+   ----------------------------
+   -- Install_Package_Entity --
+   ----------------------------
+
+   procedure Install_Package_Entity (Id : Entity_Id) is
+   begin
+      if not Is_Internal (Id) then
+         if Debug_Flag_E then
+            Write_Str ("Install: ");
+            Write_Name (Chars (Id));
+            Write_Eol;
+         end if;
+
+         if not Is_Child_Unit (Id) then
+            Set_Is_Immediately_Visible (Id);
+         end if;
+
+      end if;
+   end Install_Package_Entity;
+
+   ----------------------------------
+   -- Install_Private_Declarations --
+   ----------------------------------
+
+   procedure Install_Private_Declarations (P : Entity_Id) is
+      Id        : Entity_Id;
+      Priv_Elmt : Elmt_Id;
+      Priv      : Entity_Id;
+      Full      : Entity_Id;
+
+   begin
+      --  First exchange declarations for private types, so that the
+      --  full declaration is visible. For each private type, we check
+      --  its Private_Dependents list and also exchange any subtypes of
+      --  or derived types from it. Finally, if this is a Taft amendment
+      --  type, the incomplete declaration is irrelevant, and we want to
+      --  link the eventual full declaration with the original private
+      --  one so we also skip the exchange.
+
+      Id := First_Entity (P);
+
+      while Present (Id) and then Id /= First_Private_Entity (P) loop
+
+         if Is_Private_Base_Type (Id)
+           and then Comes_From_Source (Full_View (Id))
+           and then Present (Full_View (Id))
+           and then Scope (Full_View (Id)) = Scope (Id)
+           and then Ekind (Full_View (Id)) /= E_Incomplete_Type
+         then
+            Priv_Elmt := First_Elmt (Private_Dependents (Id));
+
+            --  If there is a use-type clause on the private type, set the
+            --  full view accordingly.
+
+            Set_In_Use (Full_View (Id), In_Use (Id));
+            Full := Full_View (Id);
+
+            if Is_Private_Base_Type (Full)
+              and then Has_Private_Declaration (Full)
+              and then Nkind (Parent (Full)) = N_Full_Type_Declaration
+              and then In_Open_Scopes (Scope (Etype (Full)))
+              and then In_Package_Body (Current_Scope)
+              and then not Is_Private_Type (Etype (Full))
+            then
+               --  This is the completion of a private type by a derivation
+               --  from another private type which is not private anymore. This
+               --  can only happen in a package nested within a child package,
+               --  when the parent type is defined in the parent unit. At this
+               --  point the current type is not private either, and we have to
+               --  install the underlying full view, which is now visible.
+
+               if No (Full_View (Full))
+                 and then Present (Underlying_Full_View (Full))
+               then
+                  Set_Full_View (Id, Underlying_Full_View (Full));
+                  Set_Underlying_Full_View (Full, Empty);
+                  Set_Is_Frozen (Full_View (Id));
+               end if;
+            end if;
+
+            Exchange_Declarations (Id);
+            Set_Is_Immediately_Visible (Id);
+
+            while Present (Priv_Elmt) loop
+               Priv := Node (Priv_Elmt);
+
+               --  Before the exchange, verify that the presence of the
+               --  Full_View field. It will be empty if the entity
+               --  has already been installed due to a previous call.
+
+               if Present (Full_View (Priv))
+                 and then Is_Visible_Dependent (Priv)
+               then
+
+                  --  For each subtype that is swapped, we also swap the
+                  --  reference to it in Private_Dependents, to allow access
+                  --  to it when we swap them out in End_Package_Scope.
+
+                  Replace_Elmt (Priv_Elmt, Full_View (Priv));
+                  Exchange_Declarations (Priv);
+                  Set_Is_Immediately_Visible
+                    (Priv, In_Open_Scopes (Scope (Priv)));
+                  Set_Is_Potentially_Use_Visible
+                    (Priv, Is_Potentially_Use_Visible (Node (Priv_Elmt)));
+               end if;
+
+               Next_Elmt (Priv_Elmt);
+            end loop;
+
+            null;
+         end if;
+
+         Next_Entity (Id);
+      end loop;
+
+      --  Next make other declarations in the private part visible as well.
+
+      Id := First_Private_Entity (P);
+
+      while Present (Id) loop
+         Install_Package_Entity (Id);
+         Next_Entity (Id);
+      end loop;
+
+      --  Indicate that the private part is currently visible, so it can be
+      --  properly reset on exit.
+
+      Set_In_Private_Part (P);
+   end Install_Private_Declarations;
+
+   ----------------------------------
+   -- Install_Visible_Declarations --
+   ----------------------------------
+
+   procedure Install_Visible_Declarations (P : Entity_Id) is
+      Id : Entity_Id;
+
+   begin
+      Id := First_Entity (P);
+
+      while Present (Id) and then Id /= First_Private_Entity (P) loop
+         Install_Package_Entity (Id);
+         Next_Entity (Id);
+      end loop;
+   end Install_Visible_Declarations;
+
+   ----------------------
+   -- Is_Fully_Visible --
+   ----------------------
+
+   --  The full declaration of a private type is visible in the private
+   --  part of the package declaration, and in the package body, at which
+   --  point the full declaration must have been given.
+
+   function Is_Fully_Visible (Type_Id : Entity_Id) return Boolean is
+      S : constant Entity_Id := Scope (Type_Id);
+
+   begin
+      if Is_Generic_Type (Type_Id) then
+         return False;
+
+      elsif In_Private_Part (S) then
+         return Present (Full_View (Type_Id));
+
+      else
+         return In_Package_Body (S);
+      end if;
+   end Is_Fully_Visible;
+
+   --------------------------
+   -- Is_Private_Base_Type --
+   --------------------------
+
+   function Is_Private_Base_Type (E : Entity_Id) return Boolean is
+   begin
+      return Ekind (E) = E_Private_Type
+        or else Ekind (E) = E_Limited_Private_Type
+        or else Ekind (E) = E_Record_Type_With_Private;
+   end Is_Private_Base_Type;
+
+   --------------------------
+   -- Is_Visible_Dependent --
+   --------------------------
+
+   function Is_Visible_Dependent (Dep : Entity_Id) return Boolean
+   is
+      S : constant Entity_Id := Scope (Dep);
+
+   begin
+      --  Renamings created for actual types have the visibility of the
+      --  actual.
+
+      if Ekind (S) = E_Package
+        and then Is_Generic_Instance (S)
+        and then (Is_Generic_Actual_Type (Dep)
+                   or else Is_Generic_Actual_Type (Full_View (Dep)))
+      then
+         return True;
+
+      elsif not (Is_Derived_Type (Dep))
+        and then Is_Derived_Type (Full_View (Dep))
+      then
+         return In_Open_Scopes (S);
+      else
+         return True;
+      end if;
+   end Is_Visible_Dependent;
+
+   ----------------------------
+   -- May_Need_Implicit_Body --
+   ----------------------------
+
+   procedure May_Need_Implicit_Body (E : Entity_Id) is
+      P     : constant Node_Id := Unit_Declaration_Node (E);
+      S     : constant Node_Id := Parent (P);
+      B     : Node_Id;
+      Decls : List_Id;
+
+   begin
+      if not Has_Completion (E)
+        and then Nkind (P) = N_Package_Declaration
+        and then Present (Activation_Chain_Entity (P))
+      then
+         B :=
+           Make_Package_Body (Sloc (E),
+             Defining_Unit_Name => Make_Defining_Identifier (Sloc (E),
+               Chars => Chars (E)),
+             Declarations  => New_List);
+
+         if Nkind (S) = N_Package_Specification then
+            if Present (Private_Declarations (S)) then
+               Decls := Private_Declarations (S);
+            else
+               Decls := Visible_Declarations (S);
+            end if;
+         else
+            Decls := Declarations (S);
+         end if;
+
+         Append (B, Decls);
+         Analyze (B);
+      end if;
+   end May_Need_Implicit_Body;
+
+   ----------------------
+   -- New_Private_Type --
+   ----------------------
+
+   procedure New_Private_Type (N : Node_Id; Id : Entity_Id; Def : Node_Id) is
+   begin
+      Enter_Name (Id);
+
+      if Limited_Present (Def) then
+         Set_Ekind (Id, E_Limited_Private_Type);
+      else
+         Set_Ekind (Id, E_Private_Type);
+      end if;
+
+      Set_Etype              (Id, Id);
+      Set_Has_Delayed_Freeze (Id);
+      Set_Is_First_Subtype   (Id);
+      Init_Size_Align        (Id);
+
+      Set_Is_Constrained (Id,
+        No (Discriminant_Specifications (N))
+          and then not Unknown_Discriminants_Present (N));
+
+      Set_Discriminant_Constraint (Id, No_Elist);
+      Set_Girder_Constraint (Id, No_Elist);
+
+      if Present (Discriminant_Specifications (N)) then
+         New_Scope (Id);
+         Process_Discriminants (N);
+         End_Scope;
+
+      elsif Unknown_Discriminants_Present (N) then
+         Set_Has_Unknown_Discriminants (Id);
+      end if;
+
+      Set_Private_Dependents (Id, New_Elmt_List);
+
+      if Tagged_Present (Def) then
+         Set_Is_Tagged_Type       (Id, True);
+         Set_Ekind                (Id, E_Record_Type_With_Private);
+         Make_Class_Wide_Type     (Id);
+         Set_Primitive_Operations (Id, New_Elmt_List);
+         Set_Is_Abstract          (Id, Abstract_Present (Def));
+         Set_Is_Limited_Record    (Id, Limited_Present (Def));
+         Set_Has_Delayed_Freeze   (Id, True);
+
+      elsif Abstract_Present (Def) then
+         Error_Msg_N ("only a tagged type can be abstract", N);
+      end if;
+   end New_Private_Type;
+
+   ------------------------------
+   -- Preserve_Full_Attributes --
+   ------------------------------
+
+   procedure Preserve_Full_Attributes (Priv, Full : Entity_Id) is
+      Priv_Is_Base_Type : constant Boolean := Priv = Base_Type (Priv);
+
+   begin
+      Set_Size_Info                   (Priv,                          (Full));
+      Set_RM_Size                     (Priv, RM_Size                  (Full));
+      Set_Size_Known_At_Compile_Time  (Priv, Size_Known_At_Compile_Time
+                                                                      (Full));
+
+      if Priv_Is_Base_Type then
+         Set_Is_Controlled            (Priv, Is_Controlled (Base_Type (Full)));
+         Set_Has_Task                 (Priv, Has_Task      (Base_Type (Full)));
+         Set_Finalize_Storage_Only    (Priv, Finalize_Storage_Only
+                                                           (Base_Type (Full)));
+         Set_Has_Controlled_Component (Priv, Has_Controlled_Component
+                                                           (Base_Type (Full)));
+      end if;
+
+      Set_Freeze_Node                 (Priv, Freeze_Node              (Full));
+
+      if Is_Tagged_Type (Priv)
+        and then Is_Tagged_Type (Full)
+        and then not Error_Posted (Full)
+      then
+         if Priv_Is_Base_Type then
+            Set_Access_Disp_Table     (Priv, Access_Disp_Table
+                                                           (Base_Type (Full)));
+         end if;
+
+         Set_First_Entity             (Priv, First_Entity             (Full));
+         Set_Last_Entity              (Priv, Last_Entity              (Full));
+      end if;
+   end Preserve_Full_Attributes;
+
+   ----------------------------
+   -- Uninstall_Declarations --
+   ----------------------------
+
+   procedure Uninstall_Declarations (P : Entity_Id) is
+      Id   : Entity_Id;
+      Decl : Node_Id := Unit_Declaration_Node (P);
+      Full : Entity_Id;
+      Priv_Elmt : Elmt_Id;
+      Priv_Sub  : Entity_Id;
+
+      function Type_In_Use (T : Entity_Id) return Boolean;
+      --  Check whether type or base type appear in an active use_type clause.
+
+      function Type_In_Use (T : Entity_Id) return Boolean is
+      begin
+         return Scope (Base_Type (T)) = P
+           and then  (In_Use (T) or else In_Use (Base_Type (T)));
+      end Type_In_Use;
+
+   --  Start of processing for Uninstall_Declarations
+
+   begin
+      Id := First_Entity (P);
+
+      while Present (Id) and then Id /= First_Private_Entity (P) loop
+         if Debug_Flag_E then
+            Write_Str ("unlinking visible entity ");
+            Write_Int (Int (Id));
+            Write_Eol;
+         end if;
+
+         --  On  exit from the package scope, we must preserve the visibility
+         --  established by use clauses in the current scope. Two cases:
+
+         --  a) If the entity is an operator, it may be a primitive operator of
+         --  a type for which there is a visible use-type clause.
+
+         --  b) for other entities, their use-visibility is determined by a
+         --  visible use clause for the package itself. For a generic instance,
+         --  the instantiation of the formals appears in the visible part,
+         --  but the formals are private and remain so.
+
+         if Ekind (Id) = E_Function
+           and then  Is_Operator_Symbol_Name (Chars (Id))
+           and then not Is_Hidden (Id)
+         then
+            Set_Is_Potentially_Use_Visible (Id,
+              In_Use (P)
+              or else Type_In_Use (Etype (Id))
+              or else Type_In_Use (Etype (First_Formal (Id)))
+              or else (Present (Next_Formal (First_Formal (Id)))
+                         and then
+                           Type_In_Use
+                             (Etype (Next_Formal (First_Formal (Id))))));
+         else
+            Set_Is_Potentially_Use_Visible (Id,
+              In_Use (P) and not Is_Hidden (Id));
+         end if;
+
+         --  Local entities are not immediately visible outside of the package.
+
+         Set_Is_Immediately_Visible (Id, False);
+
+         if Is_Tagged_Type (Id) and then Ekind (Id) = E_Record_Type then
+            Check_Abstract_Overriding (Id);
+         end if;
+
+         if (Ekind (Id) = E_Private_Type
+               or else Ekind (Id) = E_Limited_Private_Type)
+           and then No (Full_View (Id))
+           and then not Is_Generic_Type (Id)
+           and then not Is_Derived_Type (Id)
+         then
+            Error_Msg_N ("missing full declaration for private type&", Id);
+
+         elsif Ekind (Id) = E_Record_Type_With_Private
+           and then not Is_Generic_Type (Id)
+           and then No (Full_View (Id))
+         then
+            if Nkind (Parent (Id)) = N_Private_Type_Declaration then
+               Error_Msg_N ("missing full declaration for private type&", Id);
+            else
+               Error_Msg_N
+                 ("missing full declaration for private extension", Id);
+            end if;
+
+         elsif Ekind (Id) = E_Constant
+           and then No (Constant_Value (Id))
+           and then No (Full_View (Id))
+           and then not Is_Imported (Id)
+           and then (Nkind (Parent (Id)) /= N_Object_Declaration
+                      or else not No_Initialization (Parent (Id)))
+         then
+            Error_Msg_N ("missing full declaration for deferred constant", Id);
+         end if;
+
+         Next_Entity (Id);
+      end loop;
+
+      --  If the specification was installed as the parent of a public child
+      --  unit, the private declarations were not installed, and there is
+      --  nothing to do.
+
+      if not In_Private_Part (P) then
+         return;
+      else
+         Set_In_Private_Part (P, False);
+      end if;
+
+      --  Make private entities invisible and exchange full and private
+      --  declarations for private types.
+
+      while Present (Id) loop
+         if Debug_Flag_E then
+            Write_Str ("unlinking private entity ");
+            Write_Int (Int (Id));
+            Write_Eol;
+         end if;
+
+         if Is_Tagged_Type (Id) and then Ekind (Id) = E_Record_Type then
+            Check_Abstract_Overriding (Id);
+         end if;
+
+         Set_Is_Immediately_Visible (Id, False);
+
+         if Is_Private_Base_Type (Id)
+           and then Present (Full_View (Id))
+         then
+            Full := Full_View (Id);
+
+            --  If the partial view is not declared in the visible part
+            --  of the package (as is the case when it is a type derived
+            --  from some other private type in the private part if the
+            --  current package), no exchange takes place.
+
+            if No (Parent (Id))
+              or else List_Containing (Parent (Id))
+                /= Visible_Declarations (Specification (Decl))
+            then
+               goto Next_Id;
+            end if;
+
+            --  The entry in the private part points to the full declaration,
+            --  which is currently visible. Exchange them so only the private
+            --  type declaration remains accessible, and link private and
+            --  full declaration in the opposite direction. Before the actual
+            --  exchange, we copy back attributes of the full view that
+            --  must be available to the partial view too.
+
+            Preserve_Full_Attributes (Id, Full);
+
+            Set_Is_Potentially_Use_Visible (Id, In_Use (P));
+
+            if  Is_Indefinite_Subtype (Full)
+              and then not Is_Indefinite_Subtype (Id)
+            then
+               Error_Msg_N
+                 ("full view of type must be definite subtype", Full);
+            end if;
+
+            Priv_Elmt := First_Elmt (Private_Dependents (Id));
+            Exchange_Declarations (Id);
+
+            --  Swap out the subtypes and derived types of Id that were
+            --  compiled in this scope, or installed previously by
+            --  Install_Private_Declarations.
+            --  Before we do the swap, we verify the presence of the
+            --  Full_View field which may be empty due to a swap by
+            --  a previous call to End_Package_Scope (e.g. from the
+            --  freezing mechanism).
+
+            while Present (Priv_Elmt) loop
+               Priv_Sub := Node (Priv_Elmt);
+
+               if Present (Full_View (Priv_Sub)) then
+
+                  if Scope (Priv_Sub) = P
+                     or else not In_Open_Scopes (Scope (Priv_Sub))
+                  then
+                     Set_Is_Immediately_Visible (Priv_Sub, False);
+                  end if;
+
+                  if Is_Visible_Dependent (Priv_Sub) then
+                     Preserve_Full_Attributes
+                       (Priv_Sub, Full_View (Priv_Sub));
+                     Replace_Elmt (Priv_Elmt, Full_View (Priv_Sub));
+                     Exchange_Declarations (Priv_Sub);
+                  end if;
+               end if;
+
+               Next_Elmt (Priv_Elmt);
+            end loop;
+
+         elsif Ekind (Id) = E_Incomplete_Type
+           and then No (Full_View (Id))
+         then
+            --  Mark Taft amendment types
+
+            Set_Has_Completion_In_Body (Id);
+
+         elsif not Is_Child_Unit (Id)
+           and then (not Is_Private_Type (Id)
+                      or else No (Full_View (Id)))
+         then
+            Set_Is_Hidden (Id);
+            Set_Is_Potentially_Use_Visible (Id, False);
+         end if;
+
+         <<Next_Id>>
+            Next_Entity (Id);
+      end loop;
+
+   end Uninstall_Declarations;
+
+   ------------------------
+   -- Unit_Requires_Body --
+   ------------------------
+
+   function Unit_Requires_Body (P : Entity_Id) return Boolean is
+      E : Entity_Id;
+
+   begin
+      --  Imported entity never requires body. Right now, only
+      --  subprograms can be imported, but perhaps in the future
+      --  we will allow import of packages.
+
+      if Is_Imported (P) then
+         return False;
+
+      --  Body required if library package with pragma Elaborate_Body
+
+      elsif Has_Pragma_Elaborate_Body (P) then
+         return True;
+
+      --  Body required if subprogram
+
+      elsif (Is_Subprogram (P)
+               or else
+             Ekind (P) = E_Generic_Function
+               or else
+             Ekind (P) = E_Generic_Procedure)
+      then
+         return True;
+
+      --  Treat a block as requiring a body
+
+      elsif Ekind (P) = E_Block then
+         return True;
+
+      elsif Ekind (P) = E_Package
+        and then Nkind (Parent (P)) = N_Package_Specification
+        and then Present (Generic_Parent (Parent (P)))
+      then
+         declare
+            G_P : Entity_Id := Generic_Parent (Parent (P));
+
+         begin
+            if Has_Pragma_Elaborate_Body (G_P) then
+               return True;
+            end if;
+         end;
+      end if;
+
+      --  Otherwise search entity chain for entity requiring completion.
+
+      E := First_Entity (P);
+      while Present (E) loop
+
+         --  Always ignore child units. Child units get added to the entity
+         --  list of a parent unit, but are not original entities of the
+         --  parent, and so do not affect whether the parent needs a body.
+
+         if Is_Child_Unit (E) then
+            null;
+
+         --  Otherwise test to see if entity requires a completion
+
+         elsif (Is_Overloadable (E)
+               and then Ekind (E) /= E_Enumeration_Literal
+               and then Ekind (E) /= E_Operator
+               and then not Is_Abstract (E)
+               and then not Has_Completion (E))
+
+           or else
+             (Ekind (E) = E_Package
+               and then E /= P
+               and then not Has_Completion (E)
+               and then Unit_Requires_Body (E))
+
+           or else
+             (Ekind (E) = E_Incomplete_Type and then No (Full_View (E)))
+
+           or else
+            ((Ekind (E) = E_Task_Type or else
+              Ekind (E) = E_Protected_Type)
+               and then not Has_Completion (E))
+
+           or else
+             (Ekind (E) = E_Generic_Package and then E /= P
+               and then not Has_Completion (E)
+               and then Unit_Requires_Body (E))
+
+           or else
+             (Ekind (E) = E_Generic_Function
+               and then not Has_Completion (E))
+
+           or else
+             (Ekind (E) = E_Generic_Procedure
+               and then not Has_Completion (E))
+
+         then
+            return True;
+
+         --  Entity that does not require completion
+
+         else
+            null;
+         end if;
+
+         Next_Entity (E);
+      end loop;
+
+      return False;
+   end Unit_Requires_Body;
+
+end Sem_Ch7;
diff --git a/gcc/ada/sem_ch7.ads b/gcc/ada/sem_ch7.ads
new file mode 100644
index 00000000000..057c73ca655
--- /dev/null
+++ b/gcc/ada/sem_ch7.ads
@@ -0,0 +1,87 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              S E M _ C H 7                               --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.19 $                             --
+--                                                                          --
+--        Copyright (C) 1992,1993,1994 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 Sem_Ch7  is
+
+   procedure Analyze_Package_Body                       (N : Node_Id);
+   procedure Analyze_Package_Declaration                (N : Node_Id);
+   procedure Analyze_Package_Specification              (N : Node_Id);
+   procedure Analyze_Private_Type_Declaration           (N : Node_Id);
+
+   procedure End_Package_Scope (P : Entity_Id);
+   --  Calls Uninstall_Declarations, and then pops the scope stack.
+
+   procedure Exchange_Declarations (Id : Entity_Id);
+   --  Exchange private and full declaration on entry/exit from a package
+   --  declaration or body. The semantic links of the respective nodes
+   --  are preserved in the exchange.
+
+   procedure Install_Visible_Declarations (P : Entity_Id);
+   procedure Install_Private_Declarations (P : Entity_Id);
+
+   --  On entrance to a package body, make declarations in package spec
+   --  immediately visible.
+
+   --  When compiling the body of a package,  both routines are called in
+   --  succession. When compiling the body of a child package, the call
+   --  to Install_Private_Declaration is immediate for private children,
+   --  but is deffered until the compilation of the  private part of the
+   --  child for public child packages.
+
+   procedure Install_Package_Entity (Id : Entity_Id);
+   --  Basic procedure for the previous two. Places one entity on its
+   --  visibility chain, and recurses on the visible part if the entity
+   --  is an inner package.
+
+   function Unit_Requires_Body (P : Entity_Id) return Boolean;
+   --  Check if a unit requires a body. A specification requires a body
+   --  if it contains declarations that require completion in a body.
+
+   procedure May_Need_Implicit_Body (E : Entity_Id);
+   --  If a package declaration contains tasks and does not require a
+   --  body, create an implicit body at the end of the current declarative
+   --  part to activate those tasks.
+
+   function Is_Fully_Visible (Type_Id : Entity_Id) return Boolean;
+   --  Indicates whether the Full Declaration of a private type is visible.
+
+   procedure New_Private_Type (N : Node_Id; Id : Entity_Id; Def : Node_Id);
+   --  Common processing for private type declarations and for formal
+   --  private type declarations. For private types, N and Def are the type
+   --  declaration node; for formal private types, Def is the formal type
+   --  definition.
+
+   procedure Uninstall_Declarations (P : Entity_Id);
+   --  At the end of a package declaration or body, declarations in the
+   --  visible part are no longer immediately visible, and declarations in
+   --  the private part are not visible at all. For inner packages, place
+   --  visible entities at the end of their homonym chains. For compilation
+   --  units, make all entities invisible. In both cases, exchange private
+   --  and visible declarations to restore order of elaboration.
+end Sem_Ch7;
diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb
new file mode 100644
index 00000000000..ab90a102d70
--- /dev/null
+++ b/gcc/ada/sem_ch8.adb
@@ -0,0 +1,5224 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              S E M . C H 8                               --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.583 $
+--                                                                          --
+--          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 Debug;    use Debug;
+with Einfo;    use Einfo;
+with Elists;   use Elists;
+with Errout;   use Errout;
+with Exp_Util; use Exp_Util;
+with Fname;    use Fname;
+with Freeze;   use Freeze;
+with Lib;      use Lib;
+with Lib.Load; use Lib.Load;
+with Lib.Xref; use Lib.Xref;
+with Namet;    use Namet;
+with Nlists;   use Nlists;
+with Nmake;    use Nmake;
+with Opt;      use Opt;
+with Output;   use Output;
+with Restrict; use Restrict;
+with Rtsfind;  use Rtsfind;
+with Sem;      use Sem;
+with Sem_Ch3;  use Sem_Ch3;
+with Sem_Ch4;  use Sem_Ch4;
+with Sem_Ch6;  use Sem_Ch6;
+with Sem_Ch12; use Sem_Ch12;
+with Sem_Res;  use Sem_Res;
+with Sem_Util; use Sem_Util;
+with Sem_Type; use Sem_Type;
+with Stand;    use Stand;
+with Sinfo;    use Sinfo;
+with Sinfo.CN; use Sinfo.CN;
+with Snames;   use Snames;
+with Style;    use Style;
+with Table;
+with Tbuild;   use Tbuild;
+with Uintp;    use Uintp;
+
+with GNAT.Spelling_Checker; use GNAT.Spelling_Checker;
+
+package body Sem_Ch8 is
+
+   ------------------------------------
+   -- Visibility and Name Resolution --
+   ------------------------------------
+
+   --  This package handles name resolution and the collection of
+   --  interpretations for overloaded names, prior to overload resolution.
+
+   --  Name resolution is the process that establishes a mapping between source
+   --  identifiers and the entities they denote at each point in the program.
+   --  Each entity is represented by a defining occurrence. Each identifier
+   --  that denotes an entity points to the corresponding defining occurrence.
+   --  This is the entity of the applied occurrence. Each occurrence holds
+   --  an index into the names table, where source identifiers are stored.
+
+   --  Each entry in the names table for an identifier or designator uses the
+   --  Info pointer to hold a link to the currently visible entity that has
+   --  this name (see subprograms Get_Name_Entity_Id and Set_Name_Entity_Id
+   --  in package Sem_Util). The visibility is initialized at the beginning of
+   --  semantic processing to make entities in package Standard immediately
+   --  visible. The visibility table is used in a more subtle way when
+   --  compiling subunits (see below).
+
+   --  Entities that have the same name (i.e. homonyms) are chained. In the
+   --  case of overloaded entities, this chain holds all the possible meanings
+   --  of a given identifier. The process of overload resolution uses type
+   --  information to select from this chain the unique meaning of a given
+   --  identifier.
+
+   --  Entities are also chained in their scope, through the Next_Entity link.
+   --  As a consequence, the name space is organized as a sparse matrix, where
+   --  each row corresponds to a scope, and each column to a source identifier.
+   --  Open scopes, that is to say scopes currently being compiled, have their
+   --  corresponding rows of entities in order, innermost scope first.
+
+   --  The scopes of packages that are mentioned in  context clauses appear in
+   --  no particular order, interspersed among open scopes. This is because
+   --  in the course of analyzing the context of a compilation, a package
+   --  declaration is first an open scope, and subsequently an element of the
+   --  context. If subunits or child units are present, a parent unit may
+   --  appear under various guises at various times in the compilation.
+
+   --  When the compilation of the innermost scope is complete, the entities
+   --  defined therein are no longer visible. If the scope is not a package
+   --  declaration, these entities are never visible subsequently, and can be
+   --  removed from visibility chains. If the scope is a package declaration,
+   --  its visible declarations may still be accessible. Therefore the entities
+   --  defined in such a scope are left on the visibility chains, and only
+   --  their visibility (immediately visibility or potential use-visibility)
+   --  is affected.
+
+   --  The ordering of homonyms on their chain does not necessarily follow
+   --  the order of their corresponding scopes on the scope stack. For
+   --  example, if package P and the enclosing scope both contain entities
+   --  named E, then when compiling the package body the chain for E will
+   --  hold the global entity first,  and the local one (corresponding to
+   --  the current inner scope) next. As a result, name resolution routines
+   --  do not assume any relative ordering of the homonym chains, either
+   --  for scope nesting or to order of appearance of context clauses.
+
+   --  When compiling a child unit, entities in the parent scope are always
+   --  immediately visible. When compiling the body of a child unit, private
+   --  entities in the parent must also be made immediately visible. There
+   --  are separate routines to make the visible and private declarations
+   --  visible at various times (see package Sem_Ch7).
+
+   --              +--------+         +-----+
+   --              | In use |-------->| EU1 |-------------------------->
+   --              +--------+         +-----+
+   --                                    |                      |
+   --      +--------+                 +-----+                +-----+
+   --      | Stand. |---------------->| ES1 |--------------->| ES2 |--->
+   --      +--------+                 +-----+                +-----+
+   --                                    |                      |
+   --              +---------+           |                   +-----+
+   --              | with'ed |------------------------------>| EW2 |--->
+   --              +---------+           |                   +-----+
+   --                                    |                      |
+   --      +--------+                 +-----+                +-----+
+   --      | Scope2 |---------------->| E12 |--------------->| E22 |--->
+   --      +--------+                 +-----+                +-----+
+   --                                    |                      |
+   --      +--------+                 +-----+                +-----+
+   --      | Scope1 |---------------->| E11 |--------------->| E12 |--->
+   --      +--------+                 +-----+                +-----+
+   --          ^                         |                      |
+   --          |                         |                      |
+   --          |   +---------+           |                      |
+   --          |   | with'ed |----------------------------------------->
+   --          |   +---------+           |                      |
+   --          |                         |                      |
+   --      Scope stack                   |                      |
+   --      (innermost first)             |                      |
+   --                                 +----------------------------+
+   --      Names  table =>            | Id1 |     |    |     | Id2 |
+   --                                 +----------------------------+
+
+   --  Name resolution must deal with several syntactic forms: simple names,
+   --  qualified names, indexed names, and various forms of calls.
+
+   --  Each identifier points to an entry in the names table. The resolution
+   --  of a simple name consists in traversing the homonym chain, starting
+   --  from the names table. If an entry is immediately visible, it is the one
+   --  designated by the identifier. If only potemtially use-visible entities
+   --  are on the chain, we must verify that they do not hide each other. If
+   --  the entity we find is overloadable, we collect all other overloadable
+   --  entities on the chain as long as they are not hidden.
+   --
+   --  To resolve expanded names, we must find the entity at the intersection
+   --  of the entity chain for the scope (the prefix) and the homonym chain
+   --  for the selector. In general, homonym chains will be much shorter than
+   --  entity chains, so it is preferable to start from the names table as
+   --  well. If the entity found is overloadable, we must collect all other
+   --  interpretations that are defined in the scope denoted by the prefix.
+
+   --  For records, protected types, and tasks, their local entities are
+   --  removed from visibility chains on exit from the corresponding scope.
+   --  From the outside, these entities are always accessed by selected
+   --  notation, and the entity chain for the record type, protected type,
+   --  etc. is traversed sequentially in  order to find the designated entity.
+
+   --  The discriminants of a type and the operations of a protected type or
+   --  task are unchained on  exit from the first view of the type, (such as
+   --  a private or incomplete type declaration, or a protected type speci-
+   --  fication) and rechained when compiling the second view.
+
+   --  In the case of operators,  we do not make operators on derived types
+   --  explicit. As a result, the notation P."+" may denote either a user-
+   --  defined function with name "+", or else an implicit declaration of the
+   --  operator "+" in package P. The resolution of expanded names always
+   --  tries to resolve an operator name as such an implicitly defined entity,
+   --  in addition to looking for explicit declarations.
+
+   --  All forms of names that denote entities (simple names, expanded names,
+   --  character literals in some cases) have a Entity attribute, which
+   --  identifies the entity denoted by the name.
+
+   ---------------------
+   -- The Scope Stack --
+   ---------------------
+
+   --  The Scope stack keeps track of the scopes currently been compiled.
+   --  Every entity that contains declarations (including records) is placed
+   --  on the scope stack while it is being processed, and removed at the end.
+   --  Whenever a non-package scope is exited, the entities defined therein
+   --  are removed from the visibility table, so that entities in outer scopes
+   --  become visible (see previous description). On entry to Sem, the scope
+   --  stack only contains the package Standard. As usual, subunits complicate
+   --  this picture ever so slightly.
+
+   --  The Rtsfind mechanism can force a call to Semantics while another
+   --  compilation is in progress. The unit retrieved by Rtsfind must be
+   --  compiled in  its own context, and has no access to the visibility of
+   --  the unit currently being compiled. The procedures Save_Scope_Stack and
+   --  Restore_Scope_Stack make entities in current open scopes invisible
+   --  before compiling the retrieved unit, and restore the compilation
+   --  environment afterwards.
+
+   ------------------------
+   -- Compiling subunits --
+   ------------------------
+
+   --  Subunits must be compiled in the environment of the corresponding
+   --  stub, that is to say with the same visibility into the parent (and its
+   --  context) that is available at the point of the stub declaration, but
+   --  with the additional visibility provided by the context clause of the
+   --  subunit itself. As a result, compilation of a subunit forces compilation
+   --  of the parent (see description in lib-). At the point of the stub
+   --  declaration, Analyze is called recursively to compile the proper body
+   --  of the subunit, but without reinitializing the names table, nor the
+   --  scope stack (i.e. standard is not pushed on the stack). In this fashion
+   --  the context of the subunit is added to the context of the parent, and
+   --  the subunit is compiled in the correct environment. Note that in the
+   --  course of processing the context of a subunit, Standard will appear
+   --  twice on the scope stack: once for the parent of the subunit, and
+   --  once for the unit in the context clause being compiled. However, the
+   --  two sets of entities are not linked by homonym chains, so that the
+   --  compilation of any context unit happens in a fresh visibility
+   --  environment.
+
+   -------------------------------
+   -- Processing of USE Clauses --
+   -------------------------------
+
+   --  Every defining occurrence has a flag indicating if it is potentially use
+   --  visible. Resolution of simple names examines this flag. The processing
+   --  of use clauses consists in setting this flag on all visible entities
+   --  defined in the corresponding package. On exit from the scope of the use
+   --  clause, the corresponding flag must be reset. However, a package may
+   --  appear in several nested use clauses (pathological but legal, alas!)
+   --  which forces us to use a slightly more involved scheme:
+
+   --    a) The defining occurrence for a package holds a flag -In_Use- to
+   --    indicate that it is currently in the scope of a use clause. If a
+   --    redundant use clause is encountered, then the corresponding occurence
+   --    of the package name is flagged -Redundant_Use-.
+
+   --    b) On exit from a scope, the use clauses in its declarative part are
+   --    scanned. The visibility flag is reset in all entities declared in
+   --    package named in a use clause, as long as the package is not flagged
+   --    as being in a redundant use clause (in which case the outer use
+   --    clause is still in effect, and the direct visibility of its entities
+   --    must be retained).
+
+   --  Note that entities are not removed from their homonym chains on exit
+   --  from the package specification. A subsequent use clause does not need
+   --  to rechain the visible entities, but only to establish their direct
+   --  visibility.
+
+   -----------------------------------
+   -- Handling private declarations --
+   -----------------------------------
+
+   --  The principle that each entity has a single defining occurrence clashes
+   --  with the presence of two separate definitions for private types: the
+   --  first is the private type declaration, and second is the full type
+   --  declaration. It is important that all references to the type point to
+   --  the same defining occurence, namely the first one. To enforce the two
+   --  separate views of the entity, the corresponding information is swapped
+   --  between the two declarations. Outside of the package, the defining
+   --  occurence only contains the private declaration information, while in
+   --  the private part and the body of the package the defining occurrence
+   --  contains the full declaration. To simplify the swap, the defining
+   --  occurrence that currently holds the private declaration points to the
+   --  full declaration. During semantic processing the defining occurence
+   --  also points to a list of private dependents, that is to say access
+   --  types or composite types whose designated types or component types are
+   --  subtypes or derived types of the private type in question. After the
+   --  full declaration has been seen, the private dependents are updated to
+   --  indicate that they have full definitions.
+
+   ------------------------------------
+   -- Handling of Undefined Messages --
+   ------------------------------------
+
+   --  In normal mode, only the first use of an undefined identifier generates
+   --  a message. The table Urefs is used to record error messages that have
+   --  been issued so that second and subsequent ones do not generate further
+   --  messages. However, the second reference causes text to be added to the
+   --  original undefined message noting "(more references follow)". The
+   --  full error list option (-gnatf) forces messages to be generated for
+   --  every reference and disconnects the use of this table.
+
+   type Uref_Entry is record
+      Node : Node_Id;
+      --  Node for identifier for which original message was posted. The
+      --  Chars field of this identifier is used to detect later references
+      --  to the same identifier.
+
+      Err : Error_Msg_Id;
+      --  Records error message Id of original undefined message. Reset to
+      --  No_Error_Msg after the second occurrence, where it is used to add
+      --  text to the original message as described above.
+
+      Nvis : Boolean;
+      --  Set if the message is not visible rather than undefined
+
+      Loc : Source_Ptr;
+      --  Records location of error message. Used to make sure that we do
+      --  not consider a, b : undefined as two separate instances, which
+      --  would otherwise happen, since the parser converts this sequence
+      --  to a : undefined; b : undefined.
+
+   end record;
+
+   package Urefs is new Table.Table (
+     Table_Component_Type => Uref_Entry,
+     Table_Index_Type     => Nat,
+     Table_Low_Bound      => 1,
+     Table_Initial        => 10,
+     Table_Increment      => 100,
+     Table_Name           => "Urefs");
+
+   Candidate_Renaming : Entity_Id;
+   --  Holds a candidate interpretation that appears in a subprogram renaming
+   --  declaration and does not match the given specification, but matches at
+   --  least on the first formal. Allows better error message when given
+   --  specification omits defaulted parameters, a common error.
+
+   -----------------------
+   -- Local Subprograms --
+   -----------------------
+
+   procedure Analyze_Generic_Renaming
+     (N : Node_Id;
+      K : Entity_Kind);
+   --  Common processing for all three kinds of generic renaming declarations.
+   --  Enter new name and indicate that it renames the generic unit.
+
+   procedure Analyze_Renamed_Character
+     (N       : Node_Id;
+      New_S   : Entity_Id;
+      Is_Body : Boolean);
+   --  Renamed entity is given by a character literal, which must belong
+   --  to the return type of the new entity. Is_Body indicates whether the
+   --  declaration is a renaming_as_body. If the original declaration has
+   --  already been frozen (because of an intervening body, e.g.) the body of
+   --  the function must be built now. The same applies to the following
+   --  various renaming procedures.
+
+   procedure Analyze_Renamed_Dereference
+     (N       : Node_Id;
+      New_S   : Entity_Id;
+      Is_Body : Boolean);
+   --  Renamed entity is given by an explicit dereference. Prefix must be a
+   --  conformant access_to_subprogram type.
+
+   procedure Analyze_Renamed_Entry
+     (N       : Node_Id;
+      New_S   : Entity_Id;
+      Is_Body : Boolean);
+   --  If the renamed entity in a subprogram renaming is an entry or protected
+   --  subprogram, build a body for the new entity whose only statement is a
+   --  call to the renamed entity.
+
+   procedure Analyze_Renamed_Family_Member
+     (N       : Node_Id;
+      New_S   : Entity_Id;
+      Is_Body : Boolean);
+   --  Used when the renamed entity is an indexed component. The prefix must
+   --  denote an entry family.
+
+   procedure Attribute_Renaming (N : Node_Id);
+   --  Analyze renaming of attribute as function. The renaming declaration N
+   --  is rewritten as a function body that returns the attribute reference
+   --  applied to the formals of the function.
+
+   procedure Check_Frozen_Renaming (N : Node_Id; Subp : Entity_Id);
+   --  A renaming_as_body may occur after the entity of the original decla-
+   --  ration has been frozen. In that case, the body of the new entity must
+   --  be built now, because the usual mechanism of building the renamed
+   --  body at the point of freezing will not work. Subp is the subprogram
+   --  for which N provides the Renaming_As_Body.
+
+   procedure Check_Library_Unit_Renaming (N : Node_Id; Old_E : Entity_Id);
+   --  Verify that the entity in a renaming declaration that is a library unit
+   --  is itself a library unit and not a nested unit or subunit. Also check
+   --  that if the renaming is a child unit of a generic parent, then the
+   --  renamed unit must also be a child unit of that parent. Finally, verify
+   --  that a renamed generic unit is not an implicit child declared within
+   --  an instance of the parent.
+
+   procedure Chain_Use_Clause (N : Node_Id);
+   --  Chain use clause onto list of uses clauses headed by First_Use_Clause
+   --  in the top scope table entry.
+
+   function Has_Implicit_Character_Literal (N : Node_Id) return Boolean;
+   --  Find a type derived from Character or Wide_Character in the prefix of N.
+   --  Used to resolved qualified names whose selector is a character literal.
+
+   function Find_Renamed_Entity
+     (N         : Node_Id;
+      Nam       : Node_Id;
+      New_S     : Entity_Id;
+      Is_Actual : Boolean := False) return Entity_Id;
+   --  Find the renamed entity that corresponds to the given parameter profile
+   --  in a subprogram renaming declaration. The renamed entity may be an
+   --  operator, a subprogram, an entry, or a protected operation. Is_Actual
+   --  indicates that the renaming is the one generated for an actual subpro-
+   --  gram in an instance, for which special visibility checks apply.
+
+   procedure Inherit_Renamed_Profile (New_S : Entity_Id; Old_S : Entity_Id);
+   --  A subprogram defined by a renaming declaration inherits the parameter
+   --  profile of the renamed entity. The subtypes given in the subprogram
+   --  specification are discarded and replaced with those of the renamed
+   --  subprogram, which are then used to recheck the default values.
+
+   procedure Premature_Usage (N : Node_Id);
+   --  Diagnose usage of an entity before it is visible.
+
+   procedure Write_Info;
+   --  Write debugging information on entities declared in current scope
+
+   procedure Write_Scopes;
+   pragma Warnings (Off, Write_Scopes);
+   --  Debugging information: dump all entities on scope stack
+
+   --------------------------------
+   -- Analyze_Exception_Renaming --
+   --------------------------------
+
+   --  The language only allows a single identifier, but the tree holds
+   --  an identifier list. The parser has already issued an error message
+   --  if there is more than one element in the list.
+
+   procedure Analyze_Exception_Renaming (N : Node_Id) is
+      Id  : constant Node_Id := Defining_Identifier (N);
+      Nam : constant Node_Id := Name (N);
+
+   begin
+      Enter_Name (Id);
+      Analyze (Nam);
+
+      Set_Ekind          (Id, E_Exception);
+      Set_Exception_Code (Id, Uint_0);
+      Set_Etype          (Id, Standard_Exception_Type);
+      Set_Is_Pure        (Id, Is_Pure (Current_Scope));
+
+      if not Is_Entity_Name (Nam) or else
+        Ekind (Entity (Nam)) /= E_Exception
+      then
+         Error_Msg_N ("invalid exception name in renaming", Nam);
+      else
+         if Present (Renamed_Object (Entity (Nam))) then
+            Set_Renamed_Object (Id, Renamed_Object (Entity (Nam)));
+         else
+            Set_Renamed_Object (Id, Entity (Nam));
+         end if;
+      end if;
+   end Analyze_Exception_Renaming;
+
+   ---------------------------
+   -- Analyze_Expanded_Name --
+   ---------------------------
+
+   procedure Analyze_Expanded_Name (N : Node_Id) is
+   begin
+      --  If the entity pointer is already set, this is an internal node, or
+      --  a node that is analyzed more than once, after a tree modification.
+      --  In such a case there is no resolution to perform, just set the type.
+      --  For completeness, analyze prefix as well.
+
+      if Present (Entity (N)) then
+         if Is_Type (Entity (N)) then
+            Set_Etype (N, Entity (N));
+         else
+            Set_Etype (N, Etype (Entity (N)));
+         end if;
+
+         Analyze (Prefix (N));
+         return;
+      else
+         Find_Expanded_Name (N);
+      end if;
+   end Analyze_Expanded_Name;
+
+   ----------------------------------------
+   --  Analyze_Generic_Function_Renaming --
+   ----------------------------------------
+
+   procedure Analyze_Generic_Function_Renaming  (N : Node_Id) is
+   begin
+      Analyze_Generic_Renaming (N, E_Generic_Function);
+   end Analyze_Generic_Function_Renaming;
+
+   ---------------------------------------
+   --  Analyze_Generic_Package_Renaming --
+   ---------------------------------------
+
+   procedure Analyze_Generic_Package_Renaming   (N : Node_Id) is
+   begin
+      --  Apply the Text_IO Kludge here, since we may be renaming
+      --  one of the subpackages of Text_IO, then join common routine.
+
+      Text_IO_Kludge (Name (N));
+
+      Analyze_Generic_Renaming (N, E_Generic_Package);
+   end Analyze_Generic_Package_Renaming;
+
+   -----------------------------------------
+   --  Analyze_Generic_Procedure_Renaming --
+   -----------------------------------------
+
+   procedure Analyze_Generic_Procedure_Renaming (N : Node_Id) is
+   begin
+      Analyze_Generic_Renaming (N, E_Generic_Procedure);
+   end Analyze_Generic_Procedure_Renaming;
+
+   ------------------------------
+   -- Analyze_Generic_Renaming --
+   ------------------------------
+
+   procedure Analyze_Generic_Renaming
+     (N : Node_Id;
+      K : Entity_Kind)
+   is
+      New_P : Entity_Id := Defining_Entity (N);
+      Old_P : Entity_Id;
+      Inst  : Boolean   := False; -- prevent junk warning
+
+   begin
+      Generate_Definition (New_P);
+
+      if Current_Scope /= Standard_Standard then
+         Set_Is_Pure (New_P, Is_Pure (Current_Scope));
+      end if;
+
+      if Nkind (Name (N)) = N_Selected_Component then
+         Check_Generic_Child_Unit (Name (N), Inst);
+      else
+         Analyze (Name (N));
+      end if;
+
+      if not Is_Entity_Name (Name (N)) then
+         Error_Msg_N ("expect entity name in renaming declaration", Name (N));
+         Old_P := Any_Id;
+      else
+         Old_P := Entity (Name (N));
+      end if;
+
+      Enter_Name (New_P);
+      Set_Ekind (New_P, K);
+
+      if Etype (Old_P) = Any_Type then
+         null;
+
+      elsif Ekind (Old_P) /= K then
+         Error_Msg_N ("invalid generic unit name", Name (N));
+
+      else
+         if Present (Renamed_Object (Old_P)) then
+            Set_Renamed_Object (New_P,  Renamed_Object (Old_P));
+         else
+            Set_Renamed_Object (New_P, Old_P);
+         end if;
+
+         Set_Etype (New_P, Etype (Old_P));
+         Set_Has_Completion (New_P);
+
+         if In_Open_Scopes (Old_P) then
+            Error_Msg_N ("within its scope, generic denotes its instance", N);
+         end if;
+
+         Check_Library_Unit_Renaming (N, Old_P);
+      end if;
+
+   end Analyze_Generic_Renaming;
+
+   -----------------------------
+   -- Analyze_Object_Renaming --
+   -----------------------------
+
+   procedure Analyze_Object_Renaming (N : Node_Id) is
+      Id  : constant Entity_Id := Defining_Identifier (N);
+      Dec : Node_Id;
+      Nam : constant Node_Id   := Name (N);
+      S   : constant Entity_Id := Subtype_Mark (N);
+      T   : Entity_Id;
+      T2  : Entity_Id;
+
+   begin
+      Set_Is_Pure (Id, Is_Pure (Current_Scope));
+      Enter_Name (Id);
+
+      --  The renaming of a component that depends on a discriminant
+      --  requires an actual subtype, because in subsequent use of the object
+      --  Gigi will be unable to locate the actual bounds. This explicit step
+      --  is required when the renaming is generated in removing side effects
+      --  of an already-analyzed expression.
+
+      if Nkind (Nam) = N_Selected_Component
+        and then Analyzed (Nam)
+      then
+         T := Etype (Nam);
+         Dec :=  Build_Actual_Subtype_Of_Component (Etype (Nam), Nam);
+
+         if Present (Dec) then
+            Insert_Action (N, Dec);
+            T := Defining_Identifier (Dec);
+            Set_Etype (Nam, T);
+         end if;
+
+      else
+         Find_Type (S);
+         T := Entity (S);
+         Analyze_And_Resolve (Nam, T);
+      end if;
+
+      --  An object renaming requires an exact match of the type;
+      --  class-wide matching is not allowed.
+
+      if Is_Class_Wide_Type (T)
+        and then Base_Type (Etype (Nam)) /= Base_Type (T)
+      then
+         Wrong_Type (Nam, T);
+      end if;
+
+      T2 := Etype (Nam);
+      Set_Ekind (Id, E_Variable);
+      Init_Size_Align (Id);
+
+      if T = Any_Type or else Etype (Nam) = Any_Type then
+         return;
+
+      --  Verify that the renamed entity is an object or a function call.
+      --  It may have been rewritten in several ways.
+
+      elsif Is_Object_Reference (Nam) then
+
+         if Comes_From_Source (N)
+           and then Is_Dependent_Component_Of_Mutable_Object (Nam)
+         then
+            Error_Msg_N
+              ("illegal renaming of discriminant-dependent component", Nam);
+         else
+            null;
+         end if;
+
+      --  A static function call may have been folded into a literal
+
+      elsif Nkind (Original_Node (Nam)) = N_Function_Call
+
+            --  When expansion is disabled, attribute reference is not
+            --  rewritten as function call. Otherwise it may be rewritten
+            --  as a conversion, so check original node.
+
+        or else (Nkind (Original_Node (Nam)) = N_Attribute_Reference
+                  and then Is_Function_Attribute_Name
+                    (Attribute_Name (Original_Node (Nam))))
+
+            --  Weird but legal, equivalent to renaming a function call.
+
+        or else (Is_Entity_Name (Nam)
+                  and then Ekind (Entity (Nam)) = E_Enumeration_Literal)
+
+        or else (Nkind (Nam) = N_Type_Conversion
+                    and then Is_Tagged_Type (Entity (Subtype_Mark (Nam))))
+      then
+         null;
+
+      else
+         if Nkind (Nam) = N_Type_Conversion then
+            Error_Msg_N
+              ("renaming of conversion only allowed for tagged types", Nam);
+
+         else
+            Error_Msg_N ("expect object name in renaming", Nam);
+         end if;
+
+      end if;
+
+      Set_Etype (Id, T2);
+
+      if not Is_Variable (Nam) then
+         Set_Ekind               (Id, E_Constant);
+         Set_Not_Source_Assigned (Id, True);
+         Set_Is_True_Constant    (Id, True);
+      end if;
+
+      Set_Renamed_Object (Id, Nam);
+   end Analyze_Object_Renaming;
+
+   ------------------------------
+   -- Analyze_Package_Renaming --
+   ------------------------------
+
+   procedure Analyze_Package_Renaming (N : Node_Id) is
+      New_P : constant Entity_Id := Defining_Entity (N);
+      Old_P : Entity_Id;
+      Spec  : Node_Id;
+
+   begin
+      --  Apply Text_IO kludge here, since we may be renaming one of
+      --  the children of Text_IO
+
+      Text_IO_Kludge (Name (N));
+
+      if Current_Scope /= Standard_Standard then
+         Set_Is_Pure (New_P, Is_Pure (Current_Scope));
+      end if;
+
+      Enter_Name (New_P);
+      Analyze (Name (N));
+      if Is_Entity_Name (Name (N)) then
+         Old_P := Entity (Name (N));
+      else
+         Old_P := Any_Id;
+      end if;
+
+      if Etype (Old_P) = Any_Type then
+            Error_Msg_N
+             ("expect package name in renaming", Name (N));
+
+      elsif Ekind (Old_P) /= E_Package
+        and then not (Ekind (Old_P) = E_Generic_Package
+                       and then In_Open_Scopes (Old_P))
+      then
+         if Ekind (Old_P) = E_Generic_Package then
+            Error_Msg_N
+               ("generic package cannot be renamed as a package", Name (N));
+         else
+            Error_Msg_Sloc := Sloc (Old_P);
+            Error_Msg_NE
+             ("expect package name in renaming, found& declared#",
+               Name (N), Old_P);
+         end if;
+
+         --  Set basic attributes to minimize cascaded errors.
+
+         Set_Ekind (New_P, E_Package);
+         Set_Etype (New_P, Standard_Void_Type);
+
+      elsif Ekind (Old_P) = E_Package
+        and then From_With_Type (Old_P)
+      then
+         Error_Msg_N ("imported package cannot be renamed", Name (N));
+
+      else
+         --  Entities in the old package are accessible through the
+         --  renaming entity. The simplest implementation is to have
+         --  both packages share the entity list.
+
+         Set_Ekind (New_P, E_Package);
+         Set_Etype (New_P, Standard_Void_Type);
+
+         if Present (Renamed_Object (Old_P)) then
+            Set_Renamed_Object (New_P,  Renamed_Object (Old_P));
+         else
+            Set_Renamed_Object (New_P,  Old_P);
+         end if;
+
+         Set_Has_Completion (New_P);
+
+         Set_First_Entity (New_P,  First_Entity (Old_P));
+         Set_Last_Entity  (New_P,  Last_Entity  (Old_P));
+         Set_First_Private_Entity (New_P, First_Private_Entity (Old_P));
+         Check_Library_Unit_Renaming (N, Old_P);
+         Generate_Reference (Old_P, Name (N));
+
+         --  If this is the renaming declaration of a package instantiation
+         --  within itself, it is the declaration that ends the list of actuals
+         --  for the instantiation. At this point, the subtypes that rename
+         --  the actuals are flagged as generic, to avoid spurious ambiguities
+         --  if the actuals for two distinct formals happen to coincide. If
+         --  the actual is a private type, the subtype has a private completion
+         --  that is flagged in the same fashion.
+
+         --  Resolution is identical to what is was in the original generic.
+         --  On exit from the generic instance, these are turned into regular
+         --  subtypes again, so they are compatible with types in their class.
+
+         if not Is_Generic_Instance (Old_P) then
+            return;
+         else
+            Spec := Specification (Unit_Declaration_Node (Old_P));
+         end if;
+
+         if Nkind (Spec) = N_Package_Specification
+           and then Present (Generic_Parent (Spec))
+           and then Old_P = Current_Scope
+           and then Chars (New_P) = Chars (Generic_Parent (Spec))
+         then
+            declare
+               E : Entity_Id := First_Entity (Old_P);
+            begin
+               while Present (E)
+                 and then E /= New_P
+               loop
+                  if Is_Type (E)
+                    and then Nkind (Parent (E)) = N_Subtype_Declaration
+                  then
+                     Set_Is_Generic_Actual_Type (E);
+
+                     if Is_Private_Type (E)
+                       and then Present (Full_View (E))
+                     then
+                        Set_Is_Generic_Actual_Type (Full_View (E));
+                     end if;
+                  end if;
+
+                  Next_Entity (E);
+               end loop;
+            end;
+         end if;
+      end if;
+
+   end Analyze_Package_Renaming;
+
+   -------------------------------
+   -- Analyze_Renamed_Character --
+   -------------------------------
+
+   procedure Analyze_Renamed_Character
+     (N       : Node_Id;
+      New_S   : Entity_Id;
+      Is_Body : Boolean)
+   is
+      C : constant Node_Id := Name (N);
+
+   begin
+      if Ekind (New_S) = E_Function then
+         Resolve (C, Etype (New_S));
+
+         if Is_Body then
+            Check_Frozen_Renaming (N, New_S);
+         end if;
+
+      else
+         Error_Msg_N ("character literal can only be renamed as function", N);
+      end if;
+   end Analyze_Renamed_Character;
+
+   ---------------------------------
+   -- Analyze_Renamed_Dereference --
+   ---------------------------------
+
+   procedure Analyze_Renamed_Dereference
+     (N       : Node_Id;
+      New_S   : Entity_Id;
+      Is_Body : Boolean)
+   is
+      Nam : constant Node_Id := Name (N);
+      P   : constant Node_Id := Prefix (Nam);
+      Typ : Entity_Id;
+      I   : Interp_Index;
+      It  : Interp;
+
+   begin
+      if not Is_Overloaded (P) then
+
+         if Ekind (Etype (Nam)) /= E_Subprogram_Type
+           or else not Type_Conformant (Etype (Nam), New_S) then
+            Error_Msg_N ("designated type does not match specification", P);
+         else
+            Resolve (P, Etype (P));
+         end if;
+
+         return;
+
+      else
+         Typ := Any_Type;
+         Get_First_Interp (Nam, I, It);
+
+         while Present (It.Nam) loop
+
+            if Ekind (It.Nam) = E_Subprogram_Type
+              and then Type_Conformant (It.Nam, New_S) then
+
+               if Typ /= Any_Id then
+                  Error_Msg_N ("ambiguous renaming", P);
+                  return;
+               else
+                  Typ := It.Nam;
+               end if;
+            end if;
+
+            Get_Next_Interp (I, It);
+         end loop;
+
+         if Typ = Any_Type then
+            Error_Msg_N ("designated type does not match specification", P);
+         else
+            Resolve (N, Typ);
+
+            if Is_Body then
+               Check_Frozen_Renaming (N, New_S);
+            end if;
+         end if;
+      end if;
+   end Analyze_Renamed_Dereference;
+
+   ---------------------------
+   -- Analyze_Renamed_Entry --
+   ---------------------------
+
+   procedure Analyze_Renamed_Entry
+     (N       : Node_Id;
+      New_S   : Entity_Id;
+      Is_Body : Boolean)
+   is
+      Nam   : Node_Id := Name (N);
+      Sel   : Node_Id := Selector_Name (Nam);
+      Old_S : Entity_Id;
+
+   begin
+      if Entity (Sel) = Any_Id then
+
+         --  Selector is undefined on prefix. Error emitted already.
+
+         Set_Has_Completion (New_S);
+         return;
+      end if;
+
+      --  Otherwise, find renamed entity, and build body of New_S as a call
+      --  to it.
+
+      Old_S := Find_Renamed_Entity (N, Selector_Name (Nam), New_S);
+
+      if Old_S = Any_Id then
+         Error_Msg_N (" no subprogram or entry matches specification",  N);
+      else
+         if Is_Body then
+            Check_Subtype_Conformant (New_S, Old_S, N);
+            Generate_Reference (New_S, Defining_Entity (N), 'b');
+            Style.Check_Identifier (Defining_Entity (N), New_S);
+         end if;
+
+         Inherit_Renamed_Profile (New_S, Old_S);
+      end if;
+
+      Set_Convention (New_S, Convention (Old_S));
+      Set_Has_Completion (New_S, Inside_A_Generic);
+
+      if Is_Body then
+         Check_Frozen_Renaming (N, New_S);
+      end if;
+   end Analyze_Renamed_Entry;
+
+   -----------------------------------
+   -- Analyze_Renamed_Family_Member --
+   -----------------------------------
+
+   procedure Analyze_Renamed_Family_Member
+     (N       : Node_Id;
+      New_S   : Entity_Id;
+      Is_Body : Boolean)
+   is
+      Nam   : Node_Id := Name (N);
+      P     : Node_Id := Prefix (Nam);
+      Old_S : Entity_Id;
+
+   begin
+      if (Is_Entity_Name (P) and then Ekind (Entity (P)) = E_Entry_Family)
+        or else (Nkind (P) = N_Selected_Component
+                   and then
+                 Ekind (Entity (Selector_Name (P))) = E_Entry_Family)
+      then
+         if Is_Entity_Name (P) then
+            Old_S := Entity (P);
+         else
+            Old_S := Entity (Selector_Name (P));
+         end if;
+
+         if not Entity_Matches_Spec (Old_S, New_S) then
+            Error_Msg_N ("entry family does not match specification", N);
+
+         elsif Is_Body then
+            Check_Subtype_Conformant (New_S, Old_S, N);
+            Generate_Reference (New_S, Defining_Entity (N), 'b');
+            Style.Check_Identifier (Defining_Entity (N), New_S);
+         end if;
+      else
+         Error_Msg_N ("no entry family matches specification", N);
+      end if;
+
+      Set_Has_Completion (New_S, Inside_A_Generic);
+
+      if Is_Body then
+         Check_Frozen_Renaming (N, New_S);
+      end if;
+   end Analyze_Renamed_Family_Member;
+
+   ---------------------------------
+   -- Analyze_Subprogram_Renaming --
+   ---------------------------------
+
+   procedure Analyze_Subprogram_Renaming (N : Node_Id) is
+      Nam         : Node_Id  := Name (N);
+      Spec        : constant Node_Id := Specification (N);
+      New_S       : Entity_Id;
+      Old_S       : Entity_Id := Empty;
+      Rename_Spec : Entity_Id;
+      Is_Actual   : Boolean := False;
+      Inst_Node   : Node_Id := Empty;
+      Save_83     : Boolean := Ada_83;
+
+   begin
+      --  We must test for the attribute renaming case before the Analyze
+      --  call because otherwise Sem_Attr will complain that the attribute
+      --  is missing an argument when it is analyzed.
+
+      if Nkind (Nam) = N_Attribute_Reference then
+         Attribute_Renaming (N);
+         return;
+      end if;
+
+      --  Check whether this declaration corresponds to the instantiation
+      --  of a formal subprogram. This is indicated by the presence of a
+      --  Corresponding_Spec that is the instantiation declaration.
+
+      --  If this is an instantiation, the corresponding actual is frozen
+      --  and error messages can be made more precise. If this is a default
+      --  subprogram, the entity is already established in the generic, and
+      --  is not retrieved by visibility. If it is a default with a box, the
+      --  candidate interpretations, if any, have been collected when building
+      --  the renaming declaration. If overloaded, the proper interpretation
+      --  is determined in Find_Renamed_Entity. If the entity is an operator,
+      --  Find_Renamed_Entity applies additional visibility checks.
+
+      if Present (Corresponding_Spec (N)) then
+         Is_Actual := True;
+         Inst_Node := Corresponding_Spec (N);
+
+         if Is_Entity_Name (Nam)
+           and then Present (Entity (Nam))
+           and then not Comes_From_Source (Nam)
+           and then not Is_Overloaded (Nam)
+         then
+            Old_S := Entity (Nam);
+            New_S := Analyze_Spec (Spec);
+
+            if Ekind (Entity (Nam)) = E_Operator
+              and then Box_Present (Corresponding_Spec (N))
+            then
+               Old_S := Find_Renamed_Entity (N, Name (N), New_S, Is_Actual);
+            end if;
+
+         else
+            Analyze (Nam);
+            New_S := Analyze_Spec (Spec);
+         end if;
+
+         Set_Corresponding_Spec (N, Empty);
+
+      else
+         --  Renamed entity must be analyzed first, to avoid being hidden by
+         --  new name (which might be the same in a generic instance).
+
+         Analyze (Nam);
+
+         --  The renaming defines a new overloaded entity, which is analyzed
+         --  like a subprogram declaration.
+
+         New_S := Analyze_Spec (Spec);
+      end if;
+
+      if Current_Scope /= Standard_Standard then
+         Set_Is_Pure (New_S, Is_Pure (Current_Scope));
+      end if;
+
+      Rename_Spec := Find_Corresponding_Spec (N);
+
+      if Present (Rename_Spec) then
+
+         --  Renaming_As_Body. Renaming declaration is the completion of
+         --  the declaration of Rename_Spec. We will build an actual body
+         --  for it at the freezing point.
+
+         Set_Corresponding_Spec (N, Rename_Spec);
+         Set_Corresponding_Body (Unit_Declaration_Node (Rename_Spec), New_S);
+
+         --  The body is created when the entity is frozen. If the context
+         --  is generic, freeze_all is not invoked, so we need to indicate
+         --  that the entity has a completion.
+
+         Set_Has_Completion (Rename_Spec, Inside_A_Generic);
+
+         if Ada_83 and then Comes_From_Source (N) then
+            Error_Msg_N ("(Ada 83) renaming cannot serve as a body", N);
+         end if;
+
+         Set_Convention (New_S,  Convention (Rename_Spec));
+         Check_Fully_Conformant (New_S, Rename_Spec);
+         Set_Public_Status (New_S);
+
+         --  Indicate that the entity in the declaration functions like
+         --  the corresponding body, and is not a new entity.
+
+         Set_Ekind (New_S, E_Subprogram_Body);
+         New_S := Rename_Spec;
+
+      else
+         Generate_Definition (New_S);
+         New_Overloaded_Entity (New_S);
+         if Is_Entity_Name (Nam)
+           and then Is_Intrinsic_Subprogram (Entity (Nam))
+         then
+            null;
+         else
+            Check_Delayed_Subprogram (New_S);
+         end if;
+      end if;
+
+      --  There is no need for elaboration checks on the new entity, which
+      --  may be called before the next freezing point where the body will
+      --  appear.
+
+      Set_Suppress_Elaboration_Checks (New_S, True);
+
+      if Etype (Nam) = Any_Type then
+         Set_Has_Completion (New_S);
+         return;
+
+      elsif Nkind (Nam) = N_Selected_Component then
+
+         --  Renamed entity is an entry or protected subprogram. For those
+         --  cases an explicit body is built (at the point of freezing of
+         --  this entity) that contains a call to the renamed entity.
+
+         Analyze_Renamed_Entry (N, New_S, Present (Rename_Spec));
+         return;
+
+      elsif Nkind (Nam) = N_Explicit_Dereference then
+
+         --  Renamed entity is designated by access_to_subprogram expression.
+         --  Must build body to encapsulate call, as in the entry case.
+
+         Analyze_Renamed_Dereference (N, New_S, Present (Rename_Spec));
+         return;
+
+      elsif Nkind (Nam) = N_Indexed_Component then
+         Analyze_Renamed_Family_Member (N, New_S, Present (Rename_Spec));
+         return;
+
+      elsif Nkind (Nam) = N_Character_Literal then
+         Analyze_Renamed_Character (N, New_S, Present (Rename_Spec));
+         return;
+
+      elsif (not Is_Entity_Name (Nam)
+              and then Nkind (Nam) /= N_Operator_Symbol)
+        or else not Is_Overloadable (Entity (Nam))
+      then
+         Error_Msg_N ("expect valid subprogram name in renaming", N);
+         return;
+
+      end if;
+
+      --  Most common case: subprogram renames subprogram. No body is
+      --  generated in this case, so we must indicate that the declaration
+      --  is complete as is.
+
+      if No (Rename_Spec) then
+         Set_Has_Completion (New_S);
+      end if;
+
+      --  Find the renamed entity that matches the given specification.
+      --  Disable Ada_83 because there is no requirement of full conformance
+      --  between renamed entity and new entity, even though the same circuit
+      --  is used.
+
+      Ada_83 := False;
+
+      if No (Old_S) then
+         Old_S := Find_Renamed_Entity (N, Name (N), New_S, Is_Actual);
+      end if;
+
+      if Old_S /= Any_Id then
+
+         if Is_Actual
+           and then Box_Present (Inst_Node)
+         then
+            --  This is an implicit reference to the default actual
+
+            Generate_Reference (Old_S, Nam, Typ => 'i', Force => True);
+         else
+            Generate_Reference (Old_S, Nam);
+         end if;
+
+         --  For a renaming-as-body, require subtype conformance,
+         --  but if the declaration being completed has not been
+         --  frozen, then inherit the convention of the renamed
+         --  subprogram prior to checking conformance (unless the
+         --  renaming has an explicit convention established; the
+         --  rule stated in the RM doesn't seem to address this ???).
+
+         if Present (Rename_Spec) then
+            Generate_Reference (Rename_Spec, Defining_Entity (Spec), 'b');
+            Style.Check_Identifier (Defining_Entity (Spec), Rename_Spec);
+
+            if not Is_Frozen (Rename_Spec)
+              and then not Has_Convention_Pragma (Rename_Spec)
+            then
+               Set_Convention (New_S, Convention (Old_S));
+            end if;
+
+            Check_Frozen_Renaming (N, Rename_Spec);
+            Check_Subtype_Conformant (New_S, Old_S, Spec);
+
+         elsif Ekind (Old_S) /= E_Operator then
+            Check_Mode_Conformant (New_S, Old_S);
+
+            if Is_Actual
+              and then Error_Posted (New_S)
+            then
+               Error_Msg_NE ("invalid actual subprogram: & #!", N, Old_S);
+            end if;
+         end if;
+
+         if No (Rename_Spec) then
+
+            --  The parameter profile of the new entity is that of the renamed
+            --  entity: the subtypes given in the specification are irrelevant.
+
+            Inherit_Renamed_Profile (New_S, Old_S);
+
+            --  A call to the subprogram is transformed into a call to the
+            --  renamed entity. This is transitive if the renamed entity is
+            --  itself a renaming.
+
+            if Present (Alias (Old_S)) then
+               Set_Alias (New_S, Alias (Old_S));
+            else
+               Set_Alias (New_S, Old_S);
+            end if;
+
+            --  Note that we do not set Is_Instrinsic_Subprogram if we have
+            --  a renaming as body, since the entity in this case is not an
+            --  intrinsic (it calls an intrinsic, but we have a real body
+            --  for this call, and it is in this body that the required
+            --  intrinsic processing will take place).
+
+            Set_Is_Intrinsic_Subprogram
+              (New_S, Is_Intrinsic_Subprogram (Old_S));
+
+            if Ekind (Alias (New_S)) = E_Operator then
+               Set_Has_Delayed_Freeze (New_S, False);
+            end if;
+
+         end if;
+
+         if not Is_Actual
+           and then (Old_S = New_S
+                      or else (Nkind (Nam) /= N_Expanded_Name
+                        and then  Chars (Old_S) = Chars (New_S)))
+         then
+            Error_Msg_N ("subprogram cannot rename itself", N);
+         end if;
+
+         Set_Convention (New_S, Convention (Old_S));
+         Set_Is_Abstract (New_S, Is_Abstract (Old_S));
+         Check_Library_Unit_Renaming (N, Old_S);
+
+         --  Pathological case: procedure renames entry in the scope of
+         --  its task. Entry is given by simple name, but body must be built
+         --  for procedure. Of course if called it will deadlock.
+
+         if Ekind (Old_S) = E_Entry then
+            Set_Has_Completion (New_S, False);
+            Set_Alias (New_S, Empty);
+         end if;
+
+         if Is_Actual then
+            Freeze_Before (N, Old_S);
+            Set_Has_Delayed_Freeze (New_S, False);
+            Freeze_Before (N, New_S);
+
+            if (Ekind (Old_S) = E_Procedure or else Ekind (Old_S) = E_Function)
+              and then Is_Abstract (Old_S)
+            then
+               Error_Msg_N
+                 ("abstract subprogram not allowed as generic actual", Nam);
+            end if;
+         end if;
+
+      else
+         --  A common error is to assume that implicit operators for types
+         --  are defined in Standard, or in the scope of a subtype. In those
+         --  cases where the renamed entity is given with an expanded name,
+         --  it is worth mentioning that operators for the type are not
+         --  declared in the scope given by the prefix.
+
+         if Nkind (Nam) = N_Expanded_Name
+           and then Nkind (Selector_Name (Nam)) = N_Operator_Symbol
+           and then Scope (Entity (Nam)) = Standard_Standard
+         then
+            declare
+               T : constant Entity_Id :=
+                     Base_Type (Etype (First_Formal (New_S)));
+
+            begin
+               Error_Msg_Node_2 := Prefix (Nam);
+               Error_Msg_NE ("\operator for type& is not declared in&",
+                 Prefix (Nam), T);
+            end;
+         else
+            Error_Msg_NE
+              ("no visible subprogram matches the specification for&",
+                Spec, New_S);
+         end if;
+
+         if Present (Candidate_Renaming) then
+            declare
+               F1 : Entity_Id;
+               F2 : Entity_Id;
+
+            begin
+               F1 := First_Formal (Candidate_Renaming);
+               F2 := First_Formal (New_S);
+
+               while Present (F1) and then Present (F2) loop
+                  Next_Formal (F1);
+                  Next_Formal (F2);
+               end loop;
+
+               if Present (F1) and then Present (Default_Value (F1)) then
+                  if Present (Next_Formal (F1)) then
+                     Error_Msg_NE
+                       ("\missing specification for &" &
+                          " and other formals with defaults", Spec, F1);
+                  else
+                     Error_Msg_NE
+                    ("\missing specification for &", Spec, F1);
+                  end if;
+               end if;
+            end;
+         end if;
+      end if;
+
+      Ada_83 := Save_83;
+   end Analyze_Subprogram_Renaming;
+
+   -------------------------
+   -- Analyze_Use_Package --
+   -------------------------
+
+   --  Resolve the package names in the use clause, and make all the visible
+   --  entities defined in the package potentially use-visible. If the package
+   --  is already in use from a previous use clause, its visible entities are
+   --  already use-visible. In that case, mark the occurrence as a redundant
+   --  use. If the package is an open scope, i.e. if the use clause occurs
+   --  within the package itself, ignore it.
+
+   procedure Analyze_Use_Package (N : Node_Id) is
+      Pack_Name : Node_Id;
+      Pack      : Entity_Id;
+
+      function In_Previous_With_Clause (P : Entity_Id) return Boolean;
+      --  For use clauses in a context clause, the indicated package may
+      --  be visible and yet illegal, if it did not appear in a previous
+      --  with clause.
+
+      -----------------------------
+      -- In_Previous_With_Clause --
+      -----------------------------
+
+      function In_Previous_With_Clause (P : Entity_Id) return Boolean is
+         Item : Node_Id;
+
+      begin
+         Item := First (Context_Items (Parent (N)));
+
+         while Present (Item)
+           and then Item /= N
+         loop
+            if Nkind (Item) = N_With_Clause
+              and then Entity (Name (Item)) = Pack
+            then
+               return True;
+            end if;
+
+            Next (Item);
+         end loop;
+
+         return False;
+      end In_Previous_With_Clause;
+
+   --  Start of processing for Analyze_Use_Package
+
+   begin
+      Set_Hidden_By_Use_Clause (N, No_Elist);
+
+      --  Use clause is not allowed in a spec of a predefined package
+      --  declaration except that packages whose file name starts a-n
+      --  are OK (these are children of Ada.Numerics, and such packages
+      --  are never loaded by Rtsfind).
+
+      if Is_Predefined_File_Name (Unit_File_Name (Current_Sem_Unit))
+        and then Name_Buffer (1 .. 3) /= "a-n"
+        and then
+          Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Declaration
+      then
+         Error_Msg_N ("use clause not allowed in predefined spec", N);
+      end if;
+
+      --  Chain clause to list of use clauses in current scope.
+
+      if Nkind (Parent (N)) /= N_Compilation_Unit then
+         Chain_Use_Clause (N);
+      end if;
+
+      --  Loop through package names to identify referenced packages
+
+      Pack_Name := First (Names (N));
+
+      while Present (Pack_Name) loop
+         Analyze (Pack_Name);
+
+         if Nkind (Parent (N)) = N_Compilation_Unit
+           and then Nkind (Pack_Name) = N_Expanded_Name
+         then
+            declare
+               Pref : Node_Id := Prefix (Pack_Name);
+
+            begin
+               while Nkind (Pref) = N_Expanded_Name loop
+                  Pref := Prefix (Pref);
+               end loop;
+
+               if Entity (Pref) = Standard_Standard then
+                  Error_Msg_N
+                   ("predefined package Standard cannot appear"
+                     & " in a context clause", Pref);
+               end if;
+            end;
+         end if;
+
+         Next (Pack_Name);
+      end loop;
+
+      --  Loop through package names to mark all entities as potentially
+      --  use visible.
+
+      Pack_Name := First (Names (N));
+
+      while Present (Pack_Name) loop
+
+         if Is_Entity_Name (Pack_Name) then
+            Pack := Entity (Pack_Name);
+
+            if Ekind (Pack) /= E_Package
+              and then Etype (Pack) /= Any_Type
+            then
+               if Ekind (Pack) = E_Generic_Package then
+                  Error_Msg_N
+                   ("a generic package is not allowed in a use clause",
+                      Pack_Name);
+               else
+                  Error_Msg_N ("& is not a usable package", Pack_Name);
+               end if;
+
+            elsif Nkind (Parent (N)) = N_Compilation_Unit
+              and then Nkind (Pack_Name) /= N_Expanded_Name
+              and then not In_Previous_With_Clause (Pack)
+            then
+               Error_Msg_N ("package is not directly visible", Pack_Name);
+
+            elsif Applicable_Use (Pack_Name) then
+               Use_One_Package (Pack, N);
+            end if;
+         end if;
+
+         Next (Pack_Name);
+      end loop;
+
+   end Analyze_Use_Package;
+
+   ----------------------
+   -- Analyze_Use_Type --
+   ----------------------
+
+   procedure Analyze_Use_Type (N : Node_Id) is
+      Id : Entity_Id;
+
+   begin
+      Set_Hidden_By_Use_Clause (N, No_Elist);
+
+      --  Chain clause to list of use clauses in current scope.
+
+      if Nkind (Parent (N)) /= N_Compilation_Unit then
+         Chain_Use_Clause (N);
+      end if;
+
+      Id := First (Subtype_Marks (N));
+
+      while Present (Id) loop
+         Find_Type (Id);
+
+         if Entity (Id) /= Any_Type then
+            Use_One_Type (Id, N);
+         end if;
+
+         Next (Id);
+      end loop;
+   end Analyze_Use_Type;
+
+   --------------------
+   -- Applicable_Use --
+   --------------------
+
+   function Applicable_Use (Pack_Name : Node_Id) return Boolean is
+      Pack : constant Entity_Id := Entity (Pack_Name);
+
+   begin
+      if In_Open_Scopes (Pack) then
+         return False;
+
+      elsif In_Use (Pack) then
+         Set_Redundant_Use (Pack_Name, True);
+         return False;
+
+      elsif Present (Renamed_Object (Pack))
+        and then In_Use (Renamed_Object (Pack))
+      then
+         Set_Redundant_Use (Pack_Name, True);
+         return False;
+
+      else
+         return True;
+      end if;
+   end Applicable_Use;
+
+   ------------------------
+   -- Attribute_Renaming --
+   ------------------------
+
+   procedure Attribute_Renaming (N : Node_Id) is
+      Loc        : constant Source_Ptr := Sloc (N);
+      Nam        : constant Node_Id    := Name (N);
+      Spec       : constant Node_Id    := Specification (N);
+      New_S      : constant Entity_Id  := Defining_Unit_Name (Spec);
+      Aname      : constant Name_Id    := Attribute_Name (Nam);
+
+      Form_Num   : Nat      := 0;
+      Expr_List  : List_Id  := No_List;
+
+      Attr_Node  : Node_Id;
+      Body_Node  : Node_Id;
+      Param_Spec : Node_Id;
+
+   begin
+      Generate_Definition (New_S);
+
+      --  This procedure is called in the context of subprogram renaming,
+      --  and thus the attribute must be one that is a subprogram. All of
+      --  those have at least one formal parameter, with the singular
+      --  exception of AST_Entry (which is a real oddity, it is odd that
+      --  this can be renamed at all!)
+
+      if not Is_Non_Empty_List (Parameter_Specifications (Spec)) then
+         if Aname /= Name_AST_Entry then
+            Error_Msg_N
+              ("subprogram renaming an attribute must have formals", N);
+            return;
+         end if;
+
+      else
+         Param_Spec := First (Parameter_Specifications (Spec));
+
+         while Present (Param_Spec) loop
+            Form_Num := Form_Num + 1;
+
+            if Nkind (Parameter_Type (Param_Spec)) /= N_Access_Definition then
+               Find_Type (Parameter_Type (Param_Spec));
+
+               --  The profile of the new entity denotes the base type (s) of
+               --  the types given in the specification. For access parameters
+               --  there are no subtypes involved.
+
+               Rewrite (Parameter_Type (Param_Spec),
+                New_Reference_To
+                  (Base_Type (Entity (Parameter_Type (Param_Spec))), Loc));
+            end if;
+
+            if No (Expr_List) then
+               Expr_List := New_List;
+            end if;
+
+            Append_To (Expr_List,
+              Make_Identifier (Loc,
+                Chars => Chars (Defining_Identifier (Param_Spec))));
+
+            Next (Param_Spec);
+         end loop;
+      end if;
+
+      --  Immediate error if too many formals. Other mismatches in numbers
+      --  of number of types of parameters are detected when we analyze the
+      --  body of the subprogram that we construct.
+
+      if Form_Num > 2 then
+         Error_Msg_N ("too many formals for attribute", N);
+
+      elsif
+        Aname = Name_Compose      or else
+        Aname = Name_Exponent     or else
+        Aname = Name_Leading_Part or else
+        Aname = Name_Pos          or else
+        Aname = Name_Round        or else
+        Aname = Name_Scaling      or else
+        Aname = Name_Val
+      then
+         if Nkind (N) = N_Subprogram_Renaming_Declaration
+           and then Present (Corresponding_Spec (N))
+           and then Nkind (Corresponding_Spec (N)) =
+                                   N_Formal_Subprogram_Declaration
+         then
+            Error_Msg_N
+              ("generic actual cannot be attribute involving universal type",
+               Nam);
+         else
+            Error_Msg_N
+              ("attribute involving a universal type cannot be renamed",
+               Nam);
+         end if;
+      end if;
+
+      --  AST_Entry is an odd case. It doesn't really make much sense to
+      --  allow it to be renamed, but that's the DEC rule, so we have to
+      --  do it right. The point is that the AST_Entry call should be made
+      --  now, and what the function will return is the returned value.
+
+      --  Note that there is no Expr_List in this case anyway
+
+      if Aname = Name_AST_Entry then
+
+         declare
+            Ent  : Entity_Id;
+            Decl : Node_Id;
+
+         begin
+            Ent := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
+
+            Decl :=
+              Make_Object_Declaration (Loc,
+                Defining_Identifier => Ent,
+                Object_Definition =>
+                  New_Occurrence_Of (RTE (RE_AST_Handler), Loc),
+                Expression => Nam,
+                Constant_Present => True);
+
+            Set_Assignment_OK (Decl, True);
+            Insert_Action (N, Decl);
+            Attr_Node := Make_Identifier (Loc, Chars (Ent));
+         end;
+
+      --  For all other attributes, we rewrite the attribute node to have
+      --  a list of expressions corresponding to the subprogram formals.
+      --  A renaming declaration is not a freeze point, and the analysis of
+      --  the attribute reference should not freeze the type of the prefix.
+
+      else
+         Attr_Node :=
+           Make_Attribute_Reference (Loc,
+             Prefix         => Prefix (Nam),
+             Attribute_Name => Aname,
+             Expressions    => Expr_List);
+
+         Set_Must_Not_Freeze (Attr_Node);
+         Set_Must_Not_Freeze (Prefix (Nam));
+      end if;
+
+      --  Case of renaming a function
+
+      if Nkind (Spec) = N_Function_Specification then
+
+         if Is_Procedure_Attribute_Name (Aname) then
+            Error_Msg_N ("attribute can only be renamed as procedure", Nam);
+            return;
+         end if;
+
+         Find_Type (Subtype_Mark (Spec));
+         Rewrite (Subtype_Mark (Spec),
+             New_Reference_To (Base_Type (Entity (Subtype_Mark (Spec))), Loc));
+
+         Body_Node :=
+           Make_Subprogram_Body (Loc,
+             Specification => Spec,
+             Declarations => New_List,
+             Handled_Statement_Sequence =>
+               Make_Handled_Sequence_Of_Statements (Loc,
+                   Statements => New_List (
+                     Make_Return_Statement (Loc,
+                       Expression => Attr_Node))));
+
+      --  Case of renaming a procedure
+
+      else
+         if not Is_Procedure_Attribute_Name (Aname) then
+            Error_Msg_N ("attribute can only be renamed as function", Nam);
+            return;
+         end if;
+
+         Body_Node :=
+           Make_Subprogram_Body (Loc,
+             Specification => Spec,
+             Declarations => New_List,
+             Handled_Statement_Sequence =>
+               Make_Handled_Sequence_Of_Statements (Loc,
+                   Statements => New_List (Attr_Node)));
+      end if;
+
+      Rewrite (N, Body_Node);
+      Analyze (N);
+
+      Set_Etype (New_S, Base_Type (Etype (New_S)));
+
+      --  We suppress elaboration warnings for the resulting entity, since
+      --  clearly they are not needed, and more particularly, in the case
+      --  of a generic formal subprogram, the resulting entity can appear
+      --  after the instantiation itself, and thus look like a bogus case
+      --  of access before elaboration.
+
+      Set_Suppress_Elaboration_Warnings (New_S);
+
+   end Attribute_Renaming;
+
+   ----------------------
+   -- Chain_Use_Clause --
+   ----------------------
+
+   procedure Chain_Use_Clause (N : Node_Id) is
+   begin
+      Set_Next_Use_Clause (N,
+        Scope_Stack.Table (Scope_Stack.Last).First_Use_Clause);
+      Scope_Stack.Table (Scope_Stack.Last).First_Use_Clause := N;
+   end Chain_Use_Clause;
+
+   ----------------------------
+   --  Check_Frozen_Renaming --
+   ----------------------------
+
+   procedure Check_Frozen_Renaming (N : Node_Id; Subp : Entity_Id) is
+      B_Node : Node_Id;
+      Old_S  : Entity_Id;
+
+   begin
+      if Is_Frozen (Subp)
+        and then not Has_Completion (Subp)
+      then
+         B_Node :=
+           Build_Renamed_Body
+             (Parent (Declaration_Node (Subp)), Defining_Entity (N));
+
+         if Is_Entity_Name (Name (N)) then
+            Old_S := Entity (Name (N));
+
+            if not Is_Frozen (Old_S) then
+               Ensure_Freeze_Node (Old_S);
+               if No (Actions (Freeze_Node (Old_S))) then
+                  Set_Actions (Freeze_Node (Old_S), New_List (B_Node));
+               else
+                  Append (B_Node, Actions (Freeze_Node (Old_S)));
+               end if;
+            else
+               Insert_After (N, B_Node);
+               Analyze (B_Node);
+            end if;
+
+            if Is_Intrinsic_Subprogram (Old_S)
+              and then not In_Instance
+            then
+               Error_Msg_N
+                 ("subprogram used in renaming_as_body cannot be intrinsic",
+                    Name (N));
+            end if;
+
+         else
+            Insert_After (N, B_Node);
+            Analyze (B_Node);
+         end if;
+      end if;
+   end Check_Frozen_Renaming;
+
+   ---------------------------------
+   -- Check_Library_Unit_Renaming --
+   ---------------------------------
+
+   procedure Check_Library_Unit_Renaming (N : Node_Id; Old_E : Entity_Id) is
+      New_E : Entity_Id;
+
+   begin
+      if Nkind (Parent (N)) /= N_Compilation_Unit then
+         return;
+
+      elsif Scope (Old_E) /= Standard_Standard
+        and then not Is_Child_Unit (Old_E)
+      then
+         Error_Msg_N ("renamed unit must be a library unit", Name (N));
+
+      elsif Present (Parent_Spec (N))
+        and then Nkind (Unit (Parent_Spec (N))) = N_Generic_Package_Declaration
+        and then not Is_Child_Unit (Old_E)
+      then
+         Error_Msg_N
+           ("renamed unit must be a child unit of generic parent", Name (N));
+
+      elsif Nkind (N) in N_Generic_Renaming_Declaration
+         and then  Nkind (Name (N)) = N_Expanded_Name
+         and then Is_Generic_Instance (Entity (Prefix (Name (N))))
+         and then Is_Generic_Unit (Old_E)
+      then
+         Error_Msg_N
+           ("renamed generic unit must be a library unit", Name (N));
+
+      elsif Ekind (Old_E) = E_Package
+        or else Ekind (Old_E) = E_Generic_Package
+      then
+         --  Inherit categorization flags
+
+         New_E := Defining_Entity (N);
+         Set_Is_Pure                  (New_E, Is_Pure           (Old_E));
+         Set_Is_Preelaborated         (New_E, Is_Preelaborated  (Old_E));
+         Set_Is_Remote_Call_Interface (New_E,
+                                       Is_Remote_Call_Interface (Old_E));
+         Set_Is_Remote_Types          (New_E, Is_Remote_Types   (Old_E));
+         Set_Is_Shared_Passive        (New_E, Is_Shared_Passive (Old_E));
+      end if;
+   end Check_Library_Unit_Renaming;
+
+   ---------------
+   -- End_Scope --
+   ---------------
+
+   procedure End_Scope is
+      Id    : Entity_Id;
+      Prev  : Entity_Id;
+      Outer : Entity_Id;
+
+   begin
+      Id := First_Entity (Current_Scope);
+
+      while Present (Id) loop
+         --  An entity in the current scope is not necessarily the first one
+         --  on its homonym chain. Find its predecessor if any,
+         --  If it is an internal entity, it will not be in the visibility
+         --  chain altogether,  and there is nothing to unchain.
+
+         if Id /= Current_Entity (Id) then
+            Prev := Current_Entity (Id);
+            while Present (Prev)
+              and then Present (Homonym (Prev))
+              and then Homonym (Prev) /= Id
+            loop
+               Prev := Homonym (Prev);
+            end loop;
+
+            --  Skip to end of loop if Id is not in the visibility chain
+
+            if No (Prev) or else Homonym (Prev) /= Id then
+               goto Next_Ent;
+            end if;
+
+         else
+            Prev := Empty;
+         end if;
+
+         Outer := Homonym (Id);
+         Set_Is_Immediately_Visible (Id, False);
+
+         while Present (Outer) and then Scope (Outer) = Current_Scope loop
+            Outer := Homonym (Outer);
+         end loop;
+
+         --  Reset homonym link of other entities, but do not modify link
+         --  between entities in current scope, so that the back-end can have
+         --  a proper count of local overloadings.
+
+         if No (Prev) then
+            Set_Name_Entity_Id (Chars (Id), Outer);
+
+         elsif Scope (Prev) /= Scope (Id) then
+            Set_Homonym (Prev,  Outer);
+         end if;
+
+         <<Next_Ent>>
+            Next_Entity (Id);
+      end loop;
+
+      --  If the scope generated freeze actions, place them before the
+      --  current declaration and analyze them. Type declarations and
+      --  the bodies of initialization procedures can generate such nodes.
+      --  We follow the parent chain until we reach a list node, which is
+      --  the enclosing list of declarations. If the list appears within
+      --  a protected definition, move freeze nodes outside the protected
+      --  type altogether.
+
+      if Present
+         (Scope_Stack.Table (Scope_Stack.Last).Pending_Freeze_Actions)
+      then
+         declare
+            Decl : Node_Id;
+            L    : constant List_Id := Scope_Stack.Table
+                    (Scope_Stack.Last).Pending_Freeze_Actions;
+
+         begin
+            if Is_Itype (Current_Scope) then
+               Decl := Associated_Node_For_Itype (Current_Scope);
+            else
+               Decl := Parent (Current_Scope);
+            end if;
+
+            Pop_Scope;
+
+            while not (Is_List_Member (Decl))
+              or else Nkind (Parent (Decl)) = N_Protected_Definition
+              or else Nkind (Parent (Decl)) = N_Task_Definition
+            loop
+               Decl := Parent (Decl);
+            end loop;
+
+            Insert_List_Before_And_Analyze (Decl, L);
+         end;
+
+      else
+         Pop_Scope;
+      end if;
+
+   end End_Scope;
+
+   ---------------------
+   -- End_Use_Clauses --
+   ---------------------
+
+   procedure End_Use_Clauses (Clause : Node_Id) is
+      U : Node_Id := Clause;
+
+   begin
+      while Present (U) loop
+         if Nkind (U) = N_Use_Package_Clause then
+            End_Use_Package (U);
+         elsif Nkind (U) = N_Use_Type_Clause then
+            End_Use_Type (U);
+         end if;
+
+         Next_Use_Clause (U);
+      end loop;
+   end End_Use_Clauses;
+
+   ---------------------
+   -- End_Use_Package --
+   ---------------------
+
+   procedure End_Use_Package (N : Node_Id) is
+      Pack_Name : Node_Id;
+      Pack      : Entity_Id;
+      Id        : Entity_Id;
+      Elmt      : Elmt_Id;
+
+   begin
+      Pack_Name := First (Names (N));
+
+      while Present (Pack_Name) loop
+         Pack := Entity (Pack_Name);
+
+         if Ekind (Pack) = E_Package then
+
+            if In_Open_Scopes (Pack) then
+               null;
+
+            elsif not Redundant_Use (Pack_Name) then
+               Set_In_Use (Pack, False);
+               Id := First_Entity (Pack);
+
+               while Present (Id) loop
+
+                  --  Preserve use-visibility of operators whose formals have
+                  --  a type that is use_visible thanks to a previous use_type
+                  --  clause.
+
+                  if Nkind (Id) = N_Defining_Operator_Symbol
+                       and then
+                         (In_Use (Etype (First_Formal (Id)))
+                            or else
+                              (Present (Next_Formal (First_Formal (Id)))
+                                and then In_Use (Etype (Next_Formal
+                                                        (First_Formal (Id))))))
+                  then
+                     null;
+
+                  else
+                     Set_Is_Potentially_Use_Visible (Id, False);
+                  end if;
+
+                  if Is_Private_Type (Id)
+                    and then Present (Full_View (Id))
+                  then
+                     Set_Is_Potentially_Use_Visible (Full_View (Id), False);
+                  end if;
+
+                  Next_Entity (Id);
+               end loop;
+
+               if Present (Renamed_Object (Pack)) then
+                  Set_In_Use (Renamed_Object (Pack), False);
+               end if;
+
+               if Chars (Pack) = Name_System
+                 and then Scope (Pack) = Standard_Standard
+                 and then Present_System_Aux
+               then
+                  Id := First_Entity (System_Aux_Id);
+
+                  while Present (Id) loop
+                     Set_Is_Potentially_Use_Visible (Id, False);
+
+                     if Is_Private_Type (Id)
+                       and then Present (Full_View (Id))
+                     then
+                        Set_Is_Potentially_Use_Visible (Full_View (Id), False);
+                     end if;
+
+                     Next_Entity (Id);
+                  end loop;
+
+                  Set_In_Use (System_Aux_Id, False);
+               end if;
+
+            else
+               Set_Redundant_Use (Pack_Name, False);
+            end if;
+
+         end if;
+
+         Next (Pack_Name);
+      end loop;
+
+      if Present (Hidden_By_Use_Clause (N)) then
+         Elmt := First_Elmt (Hidden_By_Use_Clause (N));
+
+         while Present (Elmt) loop
+            Set_Is_Immediately_Visible (Node (Elmt));
+            Next_Elmt (Elmt);
+         end loop;
+
+         Set_Hidden_By_Use_Clause (N, No_Elist);
+      end if;
+   end End_Use_Package;
+
+   ------------------
+   -- End_Use_Type --
+   ------------------
+
+   procedure End_Use_Type (N : Node_Id) is
+      Id      : Entity_Id;
+      Op_List : Elist_Id;
+      Elmt    : Elmt_Id;
+      T       : Entity_Id;
+
+   begin
+      Id := First (Subtype_Marks (N));
+
+      while Present (Id) loop
+         T := Entity (Id);
+
+         if T = Any_Type then
+            null;
+
+         --  Note that the use_Type clause may mention a subtype of the
+         --  type whose primitive operations have been made visible. Here
+         --  as elsewhere, it is the base type that matters for visibility.
+
+         elsif In_Open_Scopes (Scope (Base_Type (T))) then
+            null;
+
+         elsif not Redundant_Use (Id) then
+            Set_In_Use (T, False);
+            Set_In_Use (Base_Type (T), False);
+            Op_List := Collect_Primitive_Operations (T);
+            Elmt := First_Elmt (Op_List);
+
+            while Present (Elmt) loop
+
+               if Nkind (Node (Elmt)) = N_Defining_Operator_Symbol then
+                  Set_Is_Potentially_Use_Visible (Node (Elmt), False);
+               end if;
+
+               Next_Elmt (Elmt);
+            end loop;
+         end if;
+
+         Next (Id);
+      end loop;
+   end End_Use_Type;
+
+   ----------------------
+   -- Find_Direct_Name --
+   ----------------------
+
+   procedure Find_Direct_Name (N : Node_Id) is
+      E    : Entity_Id;
+      E2   : Entity_Id;
+      Msg  : Boolean;
+
+      Inst : Entity_Id := Empty;
+      --  Enclosing instance, if any.
+
+      Homonyms : Entity_Id;
+      --  Saves start of homonym chain
+
+      Nvis_Entity : Boolean;
+      --  Set True to indicate that at there is at least one entity on the
+      --  homonym chain which, while not visible, is visible enough from the
+      --  user point of view to warrant an error message of "not visible"
+      --  rather than undefined.
+
+      function From_Actual_Package (E : Entity_Id) return Boolean;
+      --  Returns true if the entity is declared in a package that is
+      --  an actual for a formal package of the current instance. Such an
+      --  entity requires special handling because it may be use-visible
+      --  but hides directly visible entities defined outside the instance.
+
+      function Known_But_Invisible (E : Entity_Id) return Boolean;
+      --  This function determines whether the entity E (which is not
+      --  visible) can reasonably be considered to be known to the writer
+      --  of the reference. This is a heuristic test, used only for the
+      --  purposes of figuring out whether we prefer to complain that an
+      --  entity is undefined or invisible (and identify the declaration
+      --  of the invisible entity in the latter case). The point here is
+      --  that we don't want to complain that something is invisible and
+      --  then point to something entirely mysterious to the writer.
+
+      procedure Nvis_Messages;
+      --  Called if there are no visible entries for N, but there is at least
+      --  one non-directly visible, or hidden declaration. This procedure
+      --  outputs an appropriate set of error messages.
+
+      procedure Undefined (Nvis : Boolean);
+      --  This function is called if the current node has no corresponding
+      --  visible entity or entities. The value set in Msg indicates whether
+      --  an error message was generated (multiple error messages for the
+      --  same variable are generally suppressed, see body for details).
+      --  Msg is True if an error message was generated, False if not. This
+      --  value is used by the caller to determine whether or not to output
+      --  additional messages where appropriate. The parameter is set False
+      --  to get the message "X is undefined", and True to get the message
+      --  "X is not visible".
+
+      -------------------------
+      -- From_Actual_Package --
+      -------------------------
+
+      function From_Actual_Package (E : Entity_Id) return Boolean is
+         Scop : constant Entity_Id := Scope (E);
+         Act  : Entity_Id;
+
+      begin
+         if not In_Instance then
+            return False;
+         else
+            Inst := Current_Scope;
+
+            while Present (Inst)
+              and then Ekind (Inst) /= E_Package
+              and then not Is_Generic_Instance (Inst)
+            loop
+               Inst := Scope (Inst);
+            end loop;
+
+            if No (Inst) then
+               return False;
+            end if;
+
+            Act := First_Entity (Inst);
+
+            while Present (Act) loop
+               if Ekind (Act) = E_Package then
+
+                  --  Check for end of actuals list
+
+                  if Renamed_Object (Act) = Inst then
+                     return False;
+
+                  elsif Present (Associated_Formal_Package (Act))
+                    and then Renamed_Object (Act) = Scop
+                  then
+                     --  Entity comes from (instance of) formal package
+
+                     return True;
+
+                  else
+                     Next_Entity (Act);
+                  end if;
+
+               else
+                  Next_Entity (Act);
+               end if;
+            end loop;
+
+            return False;
+         end if;
+      end From_Actual_Package;
+
+      -------------------------
+      -- Known_But_Invisible --
+      -------------------------
+
+      function Known_But_Invisible (E : Entity_Id) return Boolean is
+         Fname : File_Name_Type;
+
+      begin
+         --  Entities in Standard are always considered to be known
+
+         if Sloc (E) <= Standard_Location then
+            return True;
+
+         --  An entity that does not come from source is always considered
+         --  to be unknown, since it is an artifact of code expansion.
+
+         elsif not Comes_From_Source (E) then
+            return False;
+
+         --  In gnat internal mode, we consider all entities known
+
+         elsif GNAT_Mode then
+            return True;
+         end if;
+
+         --  Here we have an entity that is not from package Standard, and
+         --  which comes from Source. See if it comes from an internal file.
+
+         Fname := Unit_File_Name (Get_Source_Unit (E));
+
+         --  Case of from internal file
+
+         if Is_Internal_File_Name (Fname) then
+
+            --  Private part entities in internal files are never considered
+            --  to be known to the writer of normal application code.
+
+            if Is_Hidden (E) then
+               return False;
+            end if;
+
+            --  Entities from System packages other than System and
+            --  System.Storage_Elements are not considered to be known.
+            --  System.Auxxxx files are also considered known to the user.
+
+            --  Should refine this at some point to generally distinguish
+            --  between known and unknown internal files ???
+
+            Get_Name_String (Fname);
+
+            return
+              Name_Len < 2
+                or else
+              Name_Buffer (1 .. 2) /= "s-"
+                or else
+              Name_Buffer (3 .. 8) = "stoele"
+                or else
+              Name_Buffer (3 .. 5) = "aux";
+
+         --  If not an internal file, then entity is definitely known,
+         --  even if it is in a private part (the message generated will
+         --  note that it is in a private part)
+
+         else
+            return True;
+         end if;
+      end Known_But_Invisible;
+
+      -------------------
+      -- Nvis_Messages --
+      -------------------
+
+      procedure Nvis_Messages is
+         Ent    : Entity_Id;
+         Hidden : Boolean := False;
+
+      begin
+         Undefined (Nvis => True);
+
+         if Msg then
+
+            --  First loop does hidden declarations
+
+            Ent := Homonyms;
+            while Present (Ent) loop
+               if Is_Potentially_Use_Visible (Ent) then
+
+                  if not Hidden then
+                     Error_Msg_N ("multiple use clauses cause hiding!", N);
+                     Hidden := True;
+                  end if;
+
+                  Error_Msg_Sloc := Sloc (Ent);
+                  Error_Msg_N ("hidden declaration#!", N);
+               end if;
+
+               Ent := Homonym (Ent);
+            end loop;
+
+            --  If we found hidden declarations, then that's enough, don't
+            --  bother looking for non-visible declarations as well.
+
+            if Hidden then
+               return;
+            end if;
+
+            --  Second loop does non-directly visible declarations
+
+            Ent := Homonyms;
+            while Present (Ent) loop
+               if not Is_Potentially_Use_Visible (Ent) then
+
+                  --  Do not bother the user with unknown entities
+
+                  if not Known_But_Invisible (Ent) then
+                     goto Continue;
+                  end if;
+
+                  Error_Msg_Sloc := Sloc (Ent);
+
+                  --  Output message noting that there is a non-visible
+                  --  declaration, distinguishing the private part case.
+
+                  if Is_Hidden (Ent) then
+                     Error_Msg_N ("non-visible (private) declaration#!", N);
+                  else
+                     Error_Msg_N ("non-visible declaration#!", N);
+                  end if;
+               end if;
+
+               <<Continue>>
+               Ent := Homonym (Ent);
+            end loop;
+
+         end if;
+      end Nvis_Messages;
+
+      ---------------
+      -- Undefined --
+      ---------------
+
+      procedure Undefined (Nvis : Boolean) is
+         Emsg : Error_Msg_Id;
+
+      begin
+         --  A very specialized error check, if the undefined variable is
+         --  a case tag, and the case type is an enumeration type, check
+         --  for a possible misspelling, and if so, modify the identifier
+
+         --  Named aggregate should also be handled similarly ???
+
+         if Nkind (N) = N_Identifier
+           and then Nkind (Parent (N)) = N_Case_Statement_Alternative
+         then
+            Get_Name_String (Chars (N));
+
+            declare
+               Case_Str : constant String    := Name_Buffer (1 .. Name_Len);
+               Case_Stm : constant Node_Id   := Parent (Parent (N));
+               Case_Typ : constant Entity_Id := Etype (Expression (Case_Stm));
+
+               Lit : Node_Id;
+
+            begin
+               if Is_Enumeration_Type (Case_Typ)
+                 and then Case_Typ /= Standard_Character
+                 and then Case_Typ /= Standard_Wide_Character
+               then
+                  Lit := First_Literal (Case_Typ);
+                  Get_Name_String (Chars (Lit));
+
+                  if Chars (Lit) /= Chars (N)
+                    and then Is_Bad_Spelling_Of
+                      (Case_Str, Name_Buffer (1 .. Name_Len))
+                  then
+                     Error_Msg_Node_2 := Lit;
+                     Error_Msg_N
+                       ("& is undefined, assume misspelling of &", N);
+                     Rewrite (N, New_Occurrence_Of (Lit, Sloc (N)));
+                     return;
+                  end if;
+
+                  Lit := Next_Literal (Lit);
+               end if;
+            end;
+         end if;
+
+         --  Normal processing
+
+         Set_Entity (N, Any_Id);
+         Set_Etype  (N, Any_Type);
+
+         --  We use the table Urefs to keep track of entities for which we
+         --  have issued errors for undefined references. Multiple errors
+         --  for a single name are normally suppressed, however we modify
+         --  the error message to alert the programmer to this effect.
+
+         for J in Urefs.First .. Urefs.Last loop
+            if Chars (N) = Chars (Urefs.Table (J).Node) then
+               if Urefs.Table (J).Err /= No_Error_Msg
+                 and then Sloc (N) /= Urefs.Table (J).Loc
+               then
+                  Error_Msg_Node_1 := Urefs.Table (J).Node;
+
+                  if Urefs.Table (J).Nvis then
+                     Change_Error_Text (Urefs.Table (J).Err,
+                       "& is not visible (more references follow)");
+                  else
+                     Change_Error_Text (Urefs.Table (J).Err,
+                       "& is undefined (more references follow)");
+                  end if;
+
+                  Urefs.Table (J).Err := No_Error_Msg;
+               end if;
+
+               --  Although we will set Msg False, and thus suppress the
+               --  message, we also set Error_Posted True, to avoid any
+               --  cascaded messages resulting from the undefined reference.
+
+               Msg := False;
+               Set_Error_Posted (N, True);
+               return;
+            end if;
+         end loop;
+
+         --  If entry not found, this is first undefined occurrence
+
+         if Nvis then
+            Error_Msg_N ("& is not visible!", N);
+            Emsg := Get_Msg_Id;
+
+         else
+            Error_Msg_N ("& is undefined!", N);
+            Emsg := Get_Msg_Id;
+
+            --  A very bizarre special check, if the undefined identifier
+            --  is put or put_line, then add a special error message (since
+            --  this is a very common error for beginners to make).
+
+            if Chars (N) = Name_Put or else Chars (N) = Name_Put_Line then
+               Error_Msg_N ("\possible missing with of 'Text_'I'O!", N);
+            end if;
+
+            --  Now check for possible misspellings
+
+            Get_Name_String (Chars (N));
+
+            declare
+               E      : Entity_Id;
+               Ematch : Entity_Id := Empty;
+
+               Last_Name_Id : constant Name_Id :=
+                                Name_Id (Nat (First_Name_Id) +
+                                           Name_Entries_Count - 1);
+
+               S  : constant String (1 .. Name_Len) :=
+                      Name_Buffer (1 .. Name_Len);
+
+            begin
+               for N in First_Name_Id .. Last_Name_Id loop
+                  E := Get_Name_Entity_Id (N);
+
+                  if Present (E)
+                     and then (Is_Immediately_Visible (E)
+                                 or else
+                               Is_Potentially_Use_Visible (E))
+                  then
+                     Get_Name_String (N);
+
+                     if Is_Bad_Spelling_Of
+                          (Name_Buffer (1 .. Name_Len), S)
+                     then
+                        Ematch := E;
+                        exit;
+                     end if;
+                  end if;
+               end loop;
+
+               if Present (Ematch) then
+                  Error_Msg_NE ("\possible misspelling of&", N, Ematch);
+               end if;
+            end;
+         end if;
+
+         --  Make entry in undefined references table unless the full
+         --  errors switch is set, in which case by refraining from
+         --  generating the table entry, we guarantee that we get an
+         --  error message for every undefined reference.
+
+         if not All_Errors_Mode then
+            Urefs.Increment_Last;
+            Urefs.Table (Urefs.Last).Node := N;
+            Urefs.Table (Urefs.Last).Err  := Emsg;
+            Urefs.Table (Urefs.Last).Nvis := Nvis;
+            Urefs.Table (Urefs.Last).Loc  := Sloc (N);
+         end if;
+
+         Msg := True;
+      end Undefined;
+
+   --  Start of processing for Find_Direct_Name
+
+   begin
+      --  If the entity pointer is already set, this is an internal node, or
+      --  a node that is analyzed more than once, after a tree modification.
+      --  In such a case there is no resolution to perform, just set the type.
+
+      if Present (Entity (N)) then
+         if Is_Type (Entity (N)) then
+            Set_Etype (N, Entity (N));
+
+         else
+            declare
+               Entyp : constant Entity_Id := Etype (Entity (N));
+
+            begin
+               --  One special case here. If the Etype field is already set,
+               --  and references the packed array type corresponding to the
+               --  etype of the referenced entity, then leave it alone. This
+               --  happens for trees generated from Exp_Pakd, where expressions
+               --  can be deliberately "mis-typed" to the packed array type.
+
+               if Is_Array_Type (Entyp)
+                 and then Is_Packed (Entyp)
+                 and then Present (Etype (N))
+                 and then Etype (N) = Packed_Array_Type (Entyp)
+               then
+                  null;
+
+               --  If not that special case, then just reset the Etype
+
+               else
+                  Set_Etype (N, Etype (Entity (N)));
+               end if;
+            end;
+         end if;
+
+         return;
+      end if;
+
+      --  Here if Entity pointer was not set, we need full visibility analysis
+      --  First we generate debugging output if the debug E flag is set.
+
+      if Debug_Flag_E then
+         Write_Str ("Looking for ");
+         Write_Name (Chars (N));
+         Write_Eol;
+      end if;
+
+      Homonyms := Current_Entity (N);
+      Nvis_Entity := False;
+
+      E := Homonyms;
+      while Present (E) loop
+
+         --  If entity is immediately visible or potentially use
+         --  visible, then process the entity and we are done.
+
+         if Is_Immediately_Visible (E) then
+            goto Immediately_Visible_Entity;
+
+         elsif Is_Potentially_Use_Visible (E) then
+            goto Potentially_Use_Visible_Entity;
+
+         --  Note if a known but invisible entity encountered
+
+         elsif Known_But_Invisible (E) then
+            Nvis_Entity := True;
+         end if;
+
+         --  Move to next entity in chain and continue search
+
+         E := Homonym (E);
+      end loop;
+
+      --  If no entries on homonym chain that were potentially visible,
+      --  and no entities reasonably considered as non-visible, then
+      --  we have a plain undefined reference, with no additional
+      --  explanation required!
+
+      if not Nvis_Entity then
+         Undefined (Nvis => False);
+         return;
+
+      --  Otherwise there is at least one entry on the homonym chain that
+      --  is reasonably considered as being known and non-visible.
+
+      else
+         Nvis_Messages;
+         return;
+      end if;
+
+      --  Processing for a potentially use visible entry found. We must search
+      --  the rest of the homonym chain for two reasons. First, if there is a
+      --  directly visible entry, then none of the potentially use-visible
+      --  entities are directly visible (RM 8.4(10)). Second, we need to check
+      --  for the case of multiple potentially use-visible entries hiding one
+      --  another and as a result being non-directly visible (RM 8.4(11)).
+
+      <<Potentially_Use_Visible_Entity>> declare
+         Only_One_Visible : Boolean := True;
+         All_Overloadable : Boolean := Is_Overloadable (E);
+
+      begin
+         E2 := Homonym (E);
+
+         while Present (E2) loop
+            if Is_Immediately_Visible (E2) then
+
+               --  If the use-visible entity comes from the actual for a
+               --  formal package, it hides a directly visible entity from
+               --  outside the instance.
+
+               if From_Actual_Package (E)
+                 and then Scope_Depth (E2) < Scope_Depth (Inst)
+               then
+                  goto Found;
+               else
+                  E := E2;
+                  goto Immediately_Visible_Entity;
+               end if;
+
+            elsif Is_Potentially_Use_Visible (E2) then
+               Only_One_Visible := False;
+               All_Overloadable := All_Overloadable and Is_Overloadable (E2);
+            end if;
+
+            E2 := Homonym (E2);
+         end loop;
+
+         --  On falling through this loop, we have checked that there are no
+         --  immediately visible entities. Only_One_Visible is set if exactly
+         --  one potentially use visible entity exists. All_Overloadable is
+         --  set if all the potentially use visible entities are overloadable.
+         --  The condition for legality is that either there is one potentially
+         --  use visible entity, or if there is more than one, then all of them
+         --  are overloadable.
+
+         if Only_One_Visible or All_Overloadable then
+            goto Found;
+
+         --  If there is more than one potentially use-visible entity and at
+         --  least one of them non-overloadable, we have an error (RM 8.4(11).
+         --  Note that E points to the first such entity on the homonym list.
+         --  Special case: if one of the entities is declared in an actual
+         --  package, it was visible in the generic, and takes precedence over
+         --  other entities that are potentially use-visible.
+
+         else
+            if In_Instance then
+               E2 := E;
+
+               while Present (E2) loop
+                  if Is_Generic_Instance (Scope (E2)) then
+                     E := E2;
+                     goto Found;
+                  end if;
+
+                  E2 := Homonym (E2);
+               end loop;
+
+               Nvis_Messages;
+               return;
+
+            else
+               Nvis_Messages;
+               return;
+            end if;
+         end if;
+      end;
+
+      --  Come here with E set to the first immediately visible entity on
+      --  the homonym chain. This is the one we want unless there is another
+      --  immediately visible entity further on in the chain for a more
+      --  inner scope (RM 8.3(8)).
+
+      <<Immediately_Visible_Entity>> declare
+         Level : Int;
+         Scop  : Entity_Id;
+
+      begin
+         --  Find scope level of initial entity. When compiling  through
+         --  Rtsfind, the previous context is not completely invisible, and
+         --  an outer entity may appear on the chain, whose scope is below
+         --  the entry for Standard that delimits the current scope stack.
+         --  Indicate that the level for this spurious entry is outside of
+         --  the current scope stack.
+
+         Level := Scope_Stack.Last;
+         loop
+            Scop := Scope_Stack.Table (Level).Entity;
+            exit when Scop = Scope (E);
+            Level := Level - 1;
+            exit when Scop = Standard_Standard;
+         end loop;
+
+         --  Now search remainder of homonym chain for more inner entry
+         --  If the entity is Standard itself, it has no scope, and we
+         --  compare it with the stack entry directly.
+
+         E2 := Homonym (E);
+         while Present (E2) loop
+            if Is_Immediately_Visible (E2) then
+               for J in Level + 1 .. Scope_Stack.Last loop
+                  if Scope_Stack.Table (J).Entity = Scope (E2)
+                    or else Scope_Stack.Table (J).Entity = E2
+                  then
+                     Level := J;
+                     E := E2;
+                     exit;
+                  end if;
+               end loop;
+            end if;
+
+            E2 := Homonym (E2);
+         end loop;
+
+         --  At the end of that loop, E is the innermost immediately
+         --  visible entity, so we are all set.
+      end;
+
+      --  Come here with entity found, and stored in E
+
+      <<Found>> begin
+
+         if Comes_From_Source (N)
+           and then Is_Remote_Access_To_Subprogram_Type (E)
+           and then Expander_Active
+         then
+            Rewrite (N,
+              New_Occurrence_Of (Equivalent_Type (E), Sloc (N)));
+            return;
+         end if;
+
+         Set_Entity (N, E);
+         --  Why no Style_Check here???
+
+         if Is_Type (E) then
+            Set_Etype (N, E);
+         else
+            Set_Etype (N, Get_Full_View (Etype (E)));
+         end if;
+
+         if Debug_Flag_E then
+            Write_Str (" found  ");
+            Write_Entity_Info (E, "      ");
+         end if;
+
+         --  If the Ekind of the entity is Void, it means that all homonyms
+         --  are hidden from all visibility (RM 8.3(5,14-20)). However, this
+         --  test is skipped if the current scope is a record and the name is
+         --  a pragma argument expression (case of Atomic and Volatile pragmas
+         --  and possibly other similar pragmas added later, which are allowed
+         --  to reference components in the current record).
+
+         if Ekind (E) = E_Void
+           and then
+             (not Is_Record_Type (Current_Scope)
+               or else Nkind (Parent (N)) /= N_Pragma_Argument_Association)
+         then
+            Premature_Usage (N);
+
+         --  If the entity is overloadable, collect all interpretations
+         --  of the name for subsequent overload resolution. We optimize
+         --  a bit here to do this only if we have an overloadable entity
+         --  that is not on its own on the homonym chain.
+
+         elsif Is_Overloadable (E)
+           and then (Present (Homonym (E)) or else Current_Entity (N) /= E)
+         then
+            Collect_Interps (N);
+
+            --  If no homonyms were visible, the entity is unambiguous.
+
+            if not Is_Overloaded (N) then
+               Generate_Reference (E, N);
+            end if;
+
+         --  Case of non-overloadable entity, set the entity providing that
+         --  we do not have the case of a discriminant reference within a
+         --  default expression. Such references are replaced with the
+         --  corresponding discriminal, which is the formal corresponding to
+         --  to the discriminant in the initialization procedure.
+
+         --  This replacement must not be done if we are currently processing
+         --  a generic spec or body.
+
+         --  The replacement is not done either for a task discriminant that
+         --  appears in a default expression of an entry parameter. See
+         --  Expand_Discriminant in exp_ch2 for details on their handling.
+
+         else
+            --  Entity is unambiguous, indicate that it is referenced here
+            --  One slightly odd case is that we do not want to set the
+            --  Referenced flag if the entity is a label, and the identifier
+            --  is the label in the source, since this is not a reference
+            --  from the point of view of the user
+
+            if Nkind (Parent (N)) = N_Label then
+               declare
+                  R : constant Boolean := Referenced (E);
+
+               begin
+                  Generate_Reference (E, N);
+                  Set_Referenced (E, R);
+               end;
+
+            else
+               Generate_Reference (E, N);
+            end if;
+
+            if not In_Default_Expression
+              or else Ekind (E) /= E_Discriminant
+              or else Inside_A_Generic
+            then
+               Set_Entity_With_Style_Check (N, E);
+
+            elsif Is_Concurrent_Type (Scope (E)) then
+               declare
+                  P : Node_Id := Parent (N);
+
+               begin
+                  while Present (P)
+                    and then Nkind (P) /= N_Parameter_Specification
+                    and then Nkind (P) /= N_Component_Declaration
+                  loop
+                     P := Parent (P);
+                  end loop;
+
+                  if Present (P)
+                     and then Nkind (P) = N_Parameter_Specification
+                  then
+                     null;
+                  else
+                     Set_Entity (N, Discriminal (E));
+                  end if;
+               end;
+
+            else
+               Set_Entity (N, Discriminal (E));
+            end if;
+         end if;
+      end;
+   end Find_Direct_Name;
+
+   ------------------------
+   -- Find_Expanded_Name --
+   ------------------------
+
+   --  This routine searches the homonym chain of the entity until it finds
+   --  an entity declared in the scope denoted by the prefix. If the entity
+   --  is private, it may nevertheless be immediately visible, if we are in
+   --  the scope of its declaration.
+
+   procedure Find_Expanded_Name (N : Node_Id) is
+      Candidate : Entity_Id := Empty;
+      Selector  : constant Node_Id    := Selector_Name (N);
+      P_Name    : Entity_Id;
+      O_Name    : Entity_Id;
+      Id        : Entity_Id;
+
+   begin
+      P_Name := Entity (Prefix (N));
+      O_Name := P_Name;
+
+      --  If the prefix is a renamed package, look for the entity
+      --  in the original package.
+
+      if Ekind (P_Name) = E_Package
+        and then Present (Renamed_Object (P_Name))
+      then
+         P_Name := Renamed_Object (P_Name);
+
+         --  Rewrite node with entity field pointing to renamed object
+
+         Rewrite (Prefix (N), New_Copy (Prefix (N)));
+         Set_Entity (Prefix (N), P_Name);
+
+      --  If the prefix is an object of a concurrent type, look for
+      --  the entity in the associated task or protected type.
+
+      elsif Is_Concurrent_Type (Etype (P_Name)) then
+         P_Name := Etype (P_Name);
+      end if;
+
+      Id := Current_Entity (Selector);
+
+      while Present (Id) loop
+
+         if Scope (Id) = P_Name then
+            Candidate := Id;
+
+            if Is_Child_Unit (Id) then
+               exit when
+                 (Is_Visible_Child_Unit (Id)
+                    or else Is_Immediately_Visible (Id));
+
+            else
+               exit when
+                   (not Is_Hidden (Id) or else Is_Immediately_Visible (Id));
+            end if;
+         end if;
+
+         Id := Homonym (Id);
+      end loop;
+
+      if No (Id)
+        and then (Ekind (P_Name) = E_Procedure
+                    or else
+                  Ekind (P_Name) = E_Function)
+        and then Is_Generic_Instance (P_Name)
+      then
+         --  Expanded name denotes entity in (instance of) generic subprogram.
+         --  The entity may be in the subprogram instance, or may denote one of
+         --  the formals, which is declared in the enclosing wrapper package.
+
+         P_Name := Scope (P_Name);
+         Id := Current_Entity (Selector);
+
+         while Present (Id) loop
+            exit when  Scope (Id) = P_Name;
+            Id := Homonym (Id);
+         end loop;
+      end if;
+
+      if No (Id) or else Chars (Id) /=  Chars (Selector) then
+
+         Set_Etype (N, Any_Type);
+
+         --  If we are looking for an entity defined in System, try to
+         --  find it in the child package that may have been provided as
+         --  an extension to System. The Extend_System pragma will have
+         --  supplied the name of the extension, which may have to be loaded.
+
+         if Chars (P_Name) = Name_System
+           and then Scope (P_Name) = Standard_Standard
+           and then Present (System_Extend_Pragma_Arg)
+           and then Present_System_Aux (N)
+         then
+            Set_Entity (Prefix (N), System_Aux_Id);
+            Find_Expanded_Name (N);
+            return;
+
+         elsif (Nkind (Selector) = N_Operator_Symbol
+           and then Has_Implicit_Operator (N))
+         then
+            --  There is an implicit instance of the predefined operator in
+            --  the given scope. The operator entity is defined in Standard.
+            --  Has_Implicit_Operator makes the node into an Expanded_Name.
+
+            return;
+
+         elsif Nkind (Selector) = N_Character_Literal
+           and then Has_Implicit_Character_Literal (N)
+         then
+            --  If there is no literal defined in the scope denoted by the
+            --  prefix, the literal may belong to (a type derived from)
+            --  Standard_Character, for which we have no explicit literals.
+
+            return;
+
+         else
+            --  If the prefix is a single concurrent object, use its
+            --  name in  the error message, rather than that of the
+            --  anonymous type.
+
+            if Is_Concurrent_Type (P_Name)
+              and then Is_Internal_Name (Chars (P_Name))
+            then
+               Error_Msg_Node_2 := Entity (Prefix (N));
+            else
+               Error_Msg_Node_2 := P_Name;
+            end if;
+
+            if P_Name = System_Aux_Id then
+               P_Name := Scope (P_Name);
+               Set_Entity (Prefix (N), P_Name);
+            end if;
+
+            if Present (Candidate) then
+
+               if Is_Child_Unit (Candidate) then
+                  Error_Msg_N
+                    ("missing with_clause for child unit &", Selector);
+               else
+                  Error_Msg_NE ("& is not a visible entity of&", N, Selector);
+               end if;
+
+            else
+               --  Within the instantiation of a child unit, the prefix may
+               --  denote the parent instance, but the selector has the
+               --  name of the original child. Find whether we are within
+               --  the corresponding instance, and get the proper entity, which
+               --  can only be an enclosing scope.
+
+               if O_Name /= P_Name
+                 and then In_Open_Scopes (P_Name)
+                 and then Is_Generic_Instance (P_Name)
+               then
+                  declare
+                     S : Entity_Id := Current_Scope;
+                     P : Entity_Id;
+
+                  begin
+                     for J in reverse 0 .. Scope_Stack.Last loop
+                        S := Scope_Stack.Table (J).Entity;
+
+                        exit when S = Standard_Standard;
+
+                        if Ekind (S) = E_Function
+                          or else Ekind (S) = E_Package
+                          or else Ekind (S) = E_Procedure
+                        then
+                           P := Generic_Parent (Specification
+                                  (Unit_Declaration_Node (S)));
+
+                           if Present (P)
+                             and then Chars (Scope (P)) = Chars (O_Name)
+                             and then Chars (P) = Chars (Selector)
+                           then
+                              Id := S;
+                              goto found;
+                           end if;
+                        end if;
+
+                     end loop;
+                  end;
+               end if;
+
+               if (Chars (P_Name) = Name_Ada
+                     and then Scope (P_Name) = Standard_Standard)
+               then
+                  Error_Msg_Node_2 := Selector;
+                  Error_Msg_NE
+                    ("\missing with for `&.&`", N, P_Name);
+
+               --  If this is a selection from a dummy package, then
+               --  suppress the error message, of course the entity
+               --  is missing if the package is missing!
+
+               elsif Sloc (Error_Msg_Node_2) = No_Location then
+                  null;
+
+               --  Here we have the case of an undefined component
+
+               else
+
+                  Error_Msg_NE ("& not declared in&", N, Selector);
+
+                  --  Check for misspelling of some entity in prefix.
+
+                  Id := First_Entity (P_Name);
+                  Get_Name_String (Chars (Selector));
+
+                  declare
+                     S  : constant String (1 .. Name_Len) :=
+                            Name_Buffer (1 .. Name_Len);
+                  begin
+                     while Present (Id) loop
+                        Get_Name_String (Chars (Id));
+                        if Is_Bad_Spelling_Of
+                          (Name_Buffer (1 .. Name_Len), S)
+                          and then not Is_Internal_Name (Chars (Id))
+                        then
+                           Error_Msg_NE
+                             ("possible misspelling of&", Selector, Id);
+                           exit;
+                        end if;
+
+                        Next_Entity (Id);
+                     end loop;
+                  end;
+
+                  --  Specialize the message if this may be an instantiation
+                  --  of a child unit that was not mentioned in the context.
+
+                  if Nkind (Parent (N)) = N_Package_Instantiation
+                    and then Is_Generic_Instance (Entity (Prefix (N)))
+                    and then Is_Compilation_Unit
+                     (Generic_Parent (Parent (Entity (Prefix (N)))))
+                  then
+                     Error_Msg_NE
+                      ("\possible missing with clause on child unit&",
+                        N, Selector);
+                  end if;
+               end if;
+            end if;
+
+            Id := Any_Id;
+         end if;
+      end if;
+
+      <<found>>
+      if Comes_From_Source (N)
+        and then Is_Remote_Access_To_Subprogram_Type (Id)
+      then
+         Id := Equivalent_Type (Id);
+         Set_Chars (Selector, Chars (Id));
+      end if;
+
+      if Ekind (P_Name) = E_Package
+        and then From_With_Type (P_Name)
+      then
+         if From_With_Type (Id)
+           or else (Ekind (Id) = E_Package and then From_With_Type (Id))
+         then
+            null;
+         else
+            Error_Msg_N
+              ("imported package can only be used to access imported type",
+                N);
+         end if;
+      end if;
+
+      if Is_Task_Type (P_Name)
+        and then ((Ekind (Id) = E_Entry
+                    and then Nkind (Parent (N)) /= N_Attribute_Reference)
+                    or else
+                  (Ekind (Id) = E_Entry_Family
+                    and then
+                      Nkind (Parent (Parent (N))) /= N_Attribute_Reference))
+      then
+         --  It is an entry call after all, either to the current task
+         --  (which will deadlock) or to an enclosing task.
+
+         Analyze_Selected_Component (N);
+         return;
+      end if;
+
+      Change_Selected_Component_To_Expanded_Name (N);
+      Set_Entity_With_Style_Check (N, Id);
+      Generate_Reference (Id, N);
+
+      if Is_Type (Id) then
+         Set_Etype (N, Id);
+      else
+         Set_Etype (N, Get_Full_View (Etype (Id)));
+      end if;
+
+      --  If the Ekind of the entity is Void, it means that all homonyms
+      --  are hidden from all visibility (RM 8.3(5,14-20)).
+
+      if Ekind (Id) = E_Void then
+         Premature_Usage (N);
+
+      elsif Is_Overloadable (Id)
+        and then Present (Homonym (Id))
+      then
+         declare
+            H : Entity_Id := Homonym (Id);
+
+         begin
+            while Present (H) loop
+               if Scope (H) = Scope (Id) then
+                  Collect_Interps (N);
+                  exit;
+               end if;
+
+               H := Homonym (H);
+            end loop;
+         end;
+      end if;
+
+      if Nkind (Selector_Name (N)) = N_Operator_Symbol
+        and then Scope (Id) /= Standard_Standard
+      then
+         --  In addition to user-defined operators in the given scope,
+         --  there may be an implicit instance of the predefined
+         --  operator. The operator (defined in Standard) is found
+         --  in Has_Implicit_Operator, and added to the interpretations.
+         --  Procedure Add_One_Interp will determine which hides which.
+
+         if Has_Implicit_Operator (N) then
+            null;
+         end if;
+      end if;
+   end Find_Expanded_Name;
+
+   -------------------------
+   -- Find_Renamed_Entity --
+   -------------------------
+
+   function Find_Renamed_Entity
+     (N         : Node_Id;
+      Nam       : Node_Id;
+      New_S     : Entity_Id;
+      Is_Actual : Boolean := False) return Entity_Id
+   is
+      I     : Interp_Index;
+      I1    : Interp_Index := 0; -- Suppress junk warnings
+      It    : Interp;
+      It1   : Interp;
+      Old_S : Entity_Id;
+      Inst  : Entity_Id;
+
+      function Enclosing_Instance return Entity_Id;
+      --  If the renaming determines the entity for the default of a formal
+      --  subprogram nested within another instance, choose the innermost
+      --  candidate. This is because if the formal has a box, and we are within
+      --  an enclosing instance where some candidate interpretations are local
+      --  to this enclosing instance, we know that the default was properly
+      --  resolved when analyzing the generic, so we prefer the local
+      --  candidates to those that are external. This is not always the case
+      --  but is a reasonable heuristic on the use of nested generics.
+      --  The proper solution requires a full renaming model.
+
+      function Within (Inner, Outer : Entity_Id) return Boolean;
+      --  Determine whether a candidate subprogram is defined within
+      --  the enclosing instance. If yes, it has precedence over outer
+      --  candidates.
+
+      function Is_Visible_Operation (Op : Entity_Id) return Boolean;
+      --  If the renamed entity is an implicit operator, check whether it is
+      --  visible because its operand type is properly visible. This
+      --  check applies to explicit renamed entities that appear in the
+      --  source in a renaming declaration or a formal subprogram instance,
+      --  but not to default generic actuals with a name.
+
+      ------------------------
+      -- Enclosing_Instance --
+      ------------------------
+
+      function Enclosing_Instance return Entity_Id is
+         S : Entity_Id;
+
+      begin
+         if not Is_Generic_Instance (Current_Scope)
+           and then not Is_Actual
+         then
+            return Empty;
+         end if;
+
+         S := Scope (Current_Scope);
+
+         while S /= Standard_Standard loop
+
+            if Is_Generic_Instance (S) then
+               return S;
+            end if;
+
+            S := Scope (S);
+         end loop;
+
+         return Empty;
+      end Enclosing_Instance;
+
+      --------------------------
+      -- Is_Visible_Operation --
+      --------------------------
+
+      function Is_Visible_Operation (Op : Entity_Id) return Boolean is
+         Scop : Entity_Id;
+         Typ  : Entity_Id;
+         Btyp : Entity_Id;
+
+      begin
+         if Ekind (Op) /= E_Operator
+           or else Scope (Op) /= Standard_Standard
+           or else (In_Instance
+                      and then
+                        (not Is_Actual
+                           or else Present (Enclosing_Instance)))
+         then
+            return True;
+
+         else
+            --  For a fixed point type operator, check the resulting type,
+            --  because it may be a mixed mode integer * fixed operation.
+
+            if Present (Next_Formal (First_Formal (New_S)))
+              and then Is_Fixed_Point_Type (Etype (New_S))
+            then
+               Typ := Etype (New_S);
+            else
+               Typ := Etype (First_Formal (New_S));
+            end if;
+
+            Btyp := Base_Type (Typ);
+
+            if Nkind (Nam) /= N_Expanded_Name then
+               return (In_Open_Scopes (Scope (Btyp))
+                        or else Is_Potentially_Use_Visible (Btyp)
+                        or else In_Use (Btyp)
+                        or else In_Use (Scope (Btyp)));
+
+            else
+               Scop := Entity (Prefix (Nam));
+
+               if Ekind (Scop) = E_Package
+                 and then Present (Renamed_Object (Scop))
+               then
+                  Scop := Renamed_Object (Scop);
+               end if;
+
+               --  Operator is visible if prefix of expanded name denotes
+               --  scope of type, or else type type is defined in System_Aux
+               --  and the prefix denotes System.
+
+               return Scope (Btyp) = Scop
+                 or else (Scope (Btyp) = System_Aux_Id
+                           and then Scope (Scope (Btyp)) = Scop);
+            end if;
+         end if;
+      end Is_Visible_Operation;
+
+      ------------
+      -- Within --
+      ------------
+
+      function Within (Inner, Outer : Entity_Id) return Boolean is
+         Sc : Entity_Id := Scope (Inner);
+
+      begin
+         while Sc /= Standard_Standard loop
+
+            if Sc = Outer then
+               return True;
+            else
+               Sc := Scope (Sc);
+            end if;
+         end loop;
+
+         return False;
+      end Within;
+
+   --  Start of processing for Find_Renamed_Entry
+
+   begin
+      Old_S := Any_Id;
+      Candidate_Renaming := Empty;
+
+      if not Is_Overloaded (Nam) then
+         if Entity_Matches_Spec (Entity (Nam), New_S)
+           and then Is_Visible_Operation (Entity (Nam))
+         then
+            Old_S := Entity (Nam);
+
+         elsif
+           Present (First_Formal (Entity (Nam)))
+             and then Present (First_Formal (New_S))
+             and then (Base_Type (Etype (First_Formal (Entity (Nam))))
+                        = Base_Type (Etype (First_Formal (New_S))))
+         then
+            Candidate_Renaming := Entity (Nam);
+         end if;
+
+      else
+         Get_First_Interp (Nam, I, It);
+
+         while Present (It.Nam) loop
+
+            if Entity_Matches_Spec (It.Nam, New_S)
+               and then Is_Visible_Operation (It.Nam)
+            then
+               if Old_S /= Any_Id then
+
+                  --  Note: The call to Disambiguate only happens if a
+                  --  previous interpretation was found, in which case I1
+                  --  has received a value.
+
+                  It1 := Disambiguate (Nam, I1, I, Etype (Old_S));
+
+                  if It1 = No_Interp then
+
+                     Inst := Enclosing_Instance;
+
+                     if Present (Inst) then
+
+                        if Within (It.Nam, Inst) then
+                           return (It.Nam);
+
+                        elsif Within (Old_S, Inst) then
+                           return (Old_S);
+
+                        else
+                           Error_Msg_N ("ambiguous renaming", N);
+                           return Old_S;
+                        end if;
+
+                     else
+                        Error_Msg_N ("ambiguous renaming", N);
+                        return Old_S;
+                     end if;
+
+                  else
+                     Old_S := It1.Nam;
+                     exit;
+                  end if;
+
+               else
+                  I1 := I;
+                  Old_S := It.Nam;
+               end if;
+
+            elsif
+              Present (First_Formal (It.Nam))
+                and then Present (First_Formal (New_S))
+                and then  (Base_Type (Etype (First_Formal (It.Nam)))
+                            = Base_Type (Etype (First_Formal (New_S))))
+            then
+               Candidate_Renaming := It.Nam;
+            end if;
+
+            Get_Next_Interp (I, It);
+         end loop;
+
+         Set_Entity (Nam, Old_S);
+         Set_Is_Overloaded (Nam, False);
+      end if;
+
+      return Old_S;
+   end Find_Renamed_Entity;
+
+   -----------------------------
+   -- Find_Selected_Component --
+   -----------------------------
+
+   procedure Find_Selected_Component (N : Node_Id) is
+      P : Node_Id := Prefix (N);
+
+      P_Name : Entity_Id;
+      --  Entity denoted by prefix
+
+      P_Type : Entity_Id;
+      --  and its type
+
+      Nam : Node_Id;
+
+   begin
+      Analyze (P);
+
+      if Nkind (P) = N_Error then
+         return;
+
+      --  If the selector already has an entity, the node has been
+      --  constructed in the course of expansion, and is known to be
+      --  valid. Do not verify that it is defined for the type (it may
+      --  be a private component used in the expansion of record equality).
+
+      elsif Present (Entity (Selector_Name (N))) then
+
+         if No (Etype (N))
+           or else Etype (N) = Any_Type
+         then
+            declare
+               Sel_Name : Node_Id   := Selector_Name (N);
+               Selector : Entity_Id := Entity (Sel_Name);
+               C_Etype  : Node_Id;
+
+            begin
+               Set_Etype (Sel_Name, Etype (Selector));
+
+               if not Is_Entity_Name (P) then
+                  Resolve (P, Etype (P));
+               end if;
+
+               --  Build an actual subtype except for the first parameter
+               --  of an init_proc, where this actual subtype is by
+               --  definition incorrect, since the object is uninitialized
+               --  (and does not even have defined discriminants etc.)
+
+               if Is_Entity_Name (P)
+                 and then Ekind (Entity (P)) = E_Function
+               then
+                  Nam := New_Copy (P);
+
+                  if Is_Overloaded (P) then
+                     Save_Interps (P, Nam);
+                  end if;
+
+                  Rewrite (P,
+                    Make_Function_Call (Sloc (P), Name => Nam));
+                  Analyze_Call (P);
+                  Analyze_Selected_Component (N);
+                  return;
+
+               elsif Ekind (Selector) = E_Component
+                 and then (not Is_Entity_Name (P)
+                            or else Chars (Entity (P)) /= Name_uInit)
+               then
+                  C_Etype :=
+                    Build_Actual_Subtype_Of_Component (
+                      Etype (Selector), N);
+               else
+                  C_Etype := Empty;
+               end if;
+
+               if No (C_Etype) then
+                  C_Etype := Etype (Selector);
+               else
+                  Insert_Action (N, C_Etype);
+                  C_Etype := Defining_Identifier (C_Etype);
+               end if;
+
+               Set_Etype (N, C_Etype);
+            end;
+
+            --  If this is the name of an entry or protected operation, and
+            --  the prefix is an access type, insert an explicit dereference,
+            --  so that entry calls are treated uniformly.
+
+            if Is_Access_Type (Etype (P))
+              and then Is_Concurrent_Type (Designated_Type (Etype (P)))
+            then
+               declare
+                  New_P :  Node_Id :=
+                    Make_Explicit_Dereference (Sloc (P),
+                      Prefix => Relocate_Node (P));
+               begin
+                  Rewrite (P, New_P);
+                  Set_Etype (P, Designated_Type (Etype (Prefix (P))));
+               end;
+            end if;
+
+         --  If the selected component appears within a default expression
+         --  and it has an actual subtype, the pre-analysis has not yet
+         --  completed its analysis, because Insert_Actions is disabled in
+         --  that context. Within the init_proc of the enclosing type we
+         --  must complete this analysis, if an actual subtype was created.
+
+         elsif Inside_Init_Proc then
+            declare
+               Typ  : constant Entity_Id := Etype (N);
+               Decl : constant Node_Id   := Declaration_Node (Typ);
+
+            begin
+               if Nkind (Decl) = N_Subtype_Declaration
+                 and then not Analyzed (Decl)
+                 and then Is_List_Member (Decl)
+                 and then No (Parent (Decl))
+               then
+                  Remove (Decl);
+                  Insert_Action (N, Decl);
+               end if;
+            end;
+         end if;
+
+         return;
+
+      elsif Is_Entity_Name (P) then
+         P_Name := Entity (P);
+
+         --  The prefix may denote an enclosing type which is the completion
+         --  of an incomplete type declaration.
+
+         if Is_Type (P_Name) then
+            Set_Entity (P, Get_Full_View (P_Name));
+            Set_Etype  (P, Entity (P));
+            P_Name := Entity (P);
+         end if;
+
+         P_Type := Base_Type (Etype (P));
+
+         if Debug_Flag_E then
+            Write_Str ("Found prefix type to be ");
+            Write_Entity_Info (P_Type, "      "); Write_Eol;
+         end if;
+
+         --  First check for components of a record object (not the
+         --  result of a call, which is handled below).
+
+         if Is_Appropriate_For_Record (P_Type)
+           and then not Is_Overloadable (P_Name)
+           and then not Is_Type (P_Name)
+         then
+            --  Selected component of record. Type checking will validate
+            --  name of selector.
+
+            Analyze_Selected_Component (N);
+
+         elsif Is_Appropriate_For_Entry_Prefix (P_Type)
+           and then not In_Open_Scopes (P_Name)
+           and then (not Is_Concurrent_Type (Etype (P_Name))
+                       or else not In_Open_Scopes (Etype (P_Name)))
+         then
+            --  Call to protected operation or entry. Type checking is
+            --  needed on the prefix.
+
+            Analyze_Selected_Component (N);
+
+         elsif (In_Open_Scopes (P_Name)
+                  and then Ekind (P_Name) /= E_Void
+                  and then not Is_Overloadable (P_Name))
+           or else (Is_Concurrent_Type (Etype (P_Name))
+                      and then In_Open_Scopes (Etype (P_Name)))
+         then
+            --  Prefix denotes an enclosing loop, block, or task, i.e. an
+            --  enclosing construct that is not a subprogram or accept.
+
+            Find_Expanded_Name (N);
+
+         elsif Ekind (P_Name) = E_Package then
+            Find_Expanded_Name (N);
+
+         elsif Is_Overloadable (P_Name) then
+
+            --  The subprogram may be a renaming (of an enclosing scope) as
+            --  in the case of the name of the generic within an instantiation.
+
+            if (Ekind (P_Name) = E_Procedure
+                 or else Ekind (P_Name) = E_Function)
+              and then Present (Alias (P_Name))
+              and then Is_Generic_Instance (Alias (P_Name))
+            then
+               P_Name := Alias (P_Name);
+            end if;
+
+            if Is_Overloaded (P) then
+
+               --  The prefix must resolve to a unique enclosing construct.
+
+               declare
+                  Found : Boolean := False;
+                  I     : Interp_Index;
+                  It    : Interp;
+
+               begin
+                  Get_First_Interp (P, I, It);
+
+                  while Present (It.Nam) loop
+
+                     if In_Open_Scopes (It.Nam) then
+                        if Found then
+                           Error_Msg_N (
+                              "prefix must be unique enclosing scope", N);
+                           Set_Entity (N, Any_Id);
+                           Set_Etype  (N, Any_Type);
+                           return;
+
+                        else
+                           Found := True;
+                           P_Name := It.Nam;
+                        end if;
+                     end if;
+
+                     Get_Next_Interp (I, It);
+                  end loop;
+               end;
+            end if;
+
+            if In_Open_Scopes (P_Name) then
+               Set_Entity (P, P_Name);
+               Set_Is_Overloaded (P, False);
+               Find_Expanded_Name (N);
+
+            else
+               --  If no interpretation as an expanded name is possible, it
+               --  must be a selected component of a record returned by a
+               --  function call. Reformat prefix as a function call, the
+               --  rest is done by type resolution. If the prefix is a
+               --  procedure or entry, as is P.X;  this is an error.
+
+               if Ekind (P_Name) /= E_Function
+                 and then (not Is_Overloaded (P)
+                             or else
+                           Nkind (Parent (N)) = N_Procedure_Call_Statement)
+               then
+
+                  --  Prefix may mention a package that is hidden by a local
+                  --  declaration: let the user know.
+
+                  if Present (Homonym (P_Name)) then
+
+                     while Present (P_Name) loop
+                        exit when Ekind (P_Name) = E_Package;
+                        P_Name := Homonym (P_Name);
+                     end loop;
+
+                     if Present (P_Name) then
+                        Error_Msg_Sloc := Sloc (Entity (Prefix (N)));
+
+                        Error_Msg_NE
+                          ("package& is hidden by declaration#",
+                            N, P_Name);
+
+                        Set_Entity (Prefix (N), P_Name);
+                        Find_Expanded_Name (N);
+                        return;
+                     else
+                        P_Name := Entity (Prefix (N));
+                     end if;
+                  end if;
+
+                  Error_Msg_NE
+                    ("invalid prefix in selected component&", N, P_Name);
+                  Change_Selected_Component_To_Expanded_Name (N);
+                  Set_Entity (N, Any_Id);
+                  Set_Etype (N, Any_Type);
+
+               else
+                  Nam := New_Copy (P);
+                  Save_Interps (P, Nam);
+                  Rewrite (P,
+                    Make_Function_Call (Sloc (P), Name => Nam));
+                  Analyze_Call (P);
+                  Analyze_Selected_Component (N);
+               end if;
+            end if;
+
+         --  Remaining cases generate various error messages
+
+         else
+            --  Format node as expanded name, to avoid cascaded errors
+
+            Change_Node (N, N_Expanded_Name);
+            Set_Prefix  (N, P);
+            Set_Entity  (N, Any_Id);
+            Set_Etype   (N, Any_Type);
+
+            --  Set_Selector_Name (N, Empty); ????
+
+            --  Issue error message, but avoid this if error issued already.
+            --  Use identifier of prefix if one is available.
+
+            if P_Name = Any_Id  then
+               null;
+
+            elsif Ekind (P_Name) = E_Void then
+               Premature_Usage (P);
+
+            elsif Nkind (P) /= N_Attribute_Reference then
+               Error_Msg_N (
+                "invalid prefix in selected component&", P);
+
+            else
+               Error_Msg_N (
+                "invalid prefix in selected component", P);
+            end if;
+         end if;
+
+      else
+         --  If prefix is not the name of an entity, it must be an expression,
+         --  whose type is appropriate for a record. This is determined by
+         --  type resolution.
+
+         Analyze_Selected_Component (N);
+      end if;
+   end Find_Selected_Component;
+
+   ---------------
+   -- Find_Type --
+   ---------------
+
+   procedure Find_Type (N : Node_Id) is
+      C      : Entity_Id;
+      Typ    : Entity_Id;
+      T      : Entity_Id;
+      T_Name : Entity_Id;
+
+   begin
+      if N = Error then
+         return;
+
+      elsif Nkind (N) = N_Attribute_Reference then
+
+         --  Class attribute. This is only valid in Ada 95 mode, but we don't
+         --  do a check, since the tagged type referenced could only exist if
+         --  we were in 95 mode when it was declared (or, if we were in Ada
+         --  83 mode, then an error message would already have been issued).
+
+         if Attribute_Name (N) = Name_Class then
+            Check_Restriction (No_Dispatch, N);
+            Find_Type (Prefix (N));
+
+            --  Propagate error from bad prefix
+
+            if Etype (Prefix (N)) = Any_Type then
+               Set_Entity (N, Any_Type);
+               Set_Etype  (N, Any_Type);
+               return;
+            end if;
+
+            T := Base_Type (Entity (Prefix (N)));
+
+            --  Case of non-tagged type
+
+            if not Is_Tagged_Type (T) then
+               if Ekind (T) = E_Incomplete_Type then
+
+                  --  It is legal to denote the class type of an incomplete
+                  --  type. The full type will have to be tagged, of course.
+
+                  Set_Is_Tagged_Type (T);
+                  Make_Class_Wide_Type (T);
+                  Set_Entity (N, Class_Wide_Type (T));
+                  Set_Etype  (N, Class_Wide_Type (T));
+
+               elsif Ekind (T) = E_Private_Type
+                 and then not Is_Generic_Type (T)
+                 and then In_Private_Part (Scope (T))
+               then
+                  --  The Class attribute can be applied to an untagged
+                  --  private type fulfilled by a tagged type prior to
+                  --  the full type declaration (but only within the
+                  --  parent package's private part). Create the class-wide
+                  --  type now and check that the full type is tagged
+                  --  later during its analysis. Note that we do not
+                  --  mark the private type as tagged, unlike the case
+                  --  of incomplete types, because the type must still
+                  --  appear untagged to outside units.
+
+                  if not Present (Class_Wide_Type (T)) then
+                     Make_Class_Wide_Type (T);
+                  end if;
+
+                  Set_Entity (N, Class_Wide_Type (T));
+                  Set_Etype  (N, Class_Wide_Type (T));
+
+               else
+                  --  Should we introduce a type Any_Tagged and use
+                  --  Wrong_Type here, it would be a bit more consistent???
+
+                  Error_Msg_NE
+                    ("tagged type required, found}",
+                     Prefix (N), First_Subtype (T));
+                  Set_Entity (N, Any_Type);
+                  return;
+               end if;
+
+            --  Case of tagged type
+
+            else
+               C := Class_Wide_Type (Entity (Prefix (N)));
+               Set_Entity_With_Style_Check (N, C);
+               Generate_Reference (C, N);
+               Set_Etype (N, C);
+
+               if From_With_Type (C)
+                 and then Nkind (Parent (N)) /= N_Access_Definition
+                 and then not Analyzed (T)
+               then
+                  Error_Msg_N
+                   ("imported class-wide type can only be used" &
+                      " for access parameters", N);
+               end if;
+            end if;
+
+         --  Base attribute, allowed in Ada 95 mode only
+
+         elsif Attribute_Name (N) = Name_Base then
+            if Ada_83 and then Comes_From_Source (N) then
+               Error_Msg_N
+                 ("(Ada 83) Base attribute not allowed in subtype mark", N);
+
+            else
+               Find_Type (Prefix (N));
+               Typ := Entity (Prefix (N));
+
+               if Sloc (Typ) = Standard_Location
+                 and then Base_Type (Typ) = Typ
+                 and then Warn_On_Redundant_Constructs
+               then
+                  Error_Msg_NE
+                    ("?redudant attribute, & is its own base type", N, Typ);
+               end if;
+
+               T := Base_Type (Typ);
+               Set_Entity (N, T);
+               Set_Etype (N, T);
+
+               --  Rewrite attribute reference with type itself (see similar
+               --  processing in Analyze_Attribute, case Base)
+
+               Rewrite (N,
+                 New_Reference_To (Entity (N), Sloc (N)));
+               Set_Etype (N, T);
+            end if;
+
+         --  All other attributes are invalid in a subtype mark
+
+         else
+            Error_Msg_N ("invalid attribute in subtype mark", N);
+         end if;
+
+      else
+         Analyze (N);
+
+         if Is_Entity_Name (N) then
+            T_Name := Entity (N);
+         else
+            Error_Msg_N ("subtype mark required in this context", N);
+            Set_Etype (N, Any_Type);
+            return;
+         end if;
+
+         if T_Name  = Any_Id or else Etype (N) = Any_Type then
+
+            --  Undefined id. Make it into a valid type
+
+            Set_Entity (N, Any_Type);
+
+         elsif not Is_Type (T_Name)
+           and then T_Name /= Standard_Void_Type
+         then
+            Error_Msg_Sloc := Sloc (T_Name);
+            Error_Msg_N ("subtype mark required in this context", N);
+            Error_Msg_NE ("\found & declared#", N, T_Name);
+            Set_Entity (N, Any_Type);
+
+         else
+            T_Name := Get_Full_View (T_Name);
+
+            if In_Open_Scopes (T_Name) then
+               if Ekind (Base_Type (T_Name)) = E_Task_Type then
+                  Error_Msg_N ("task type cannot be used as type mark " &
+                     "within its own body", N);
+               else
+                  Error_Msg_N ("type declaration cannot refer to itself", N);
+               end if;
+
+               Set_Etype (N, Any_Type);
+               Set_Entity (N, Any_Type);
+               Set_Error_Posted (T_Name);
+               return;
+            end if;
+
+            Set_Entity (N, T_Name);
+            Set_Etype  (N, T_Name);
+         end if;
+      end if;
+
+      if Present (Etype (N)) then
+         if Is_Fixed_Point_Type (Etype (N)) then
+            Check_Restriction (No_Fixed_Point, N);
+         elsif Is_Floating_Point_Type (Etype (N)) then
+            Check_Restriction (No_Floating_Point, N);
+         end if;
+      end if;
+   end Find_Type;
+
+   -------------------
+   -- Get_Full_View --
+   -------------------
+
+   function Get_Full_View (T_Name : Entity_Id) return Entity_Id is
+   begin
+      if (Ekind (T_Name) = E_Incomplete_Type
+          and then Present (Full_View (T_Name)))
+      then
+         return Full_View (T_Name);
+
+      elsif Is_Class_Wide_Type (T_Name)
+        and then Ekind (Root_Type (T_Name)) = E_Incomplete_Type
+        and then Present (Full_View (Root_Type (T_Name)))
+      then
+         return Class_Wide_Type (Full_View (Root_Type (T_Name)));
+
+      else
+         return T_Name;
+      end if;
+   end Get_Full_View;
+
+   ------------------------------------
+   -- Has_Implicit_Character_Literal --
+   ------------------------------------
+
+   function Has_Implicit_Character_Literal (N : Node_Id) return Boolean is
+      Id      : Entity_Id;
+      Found   : Boolean := False;
+      P       : constant Entity_Id := Entity (Prefix (N));
+      Priv_Id : Entity_Id := Empty;
+
+   begin
+      if Ekind (P) = E_Package
+        and then not In_Open_Scopes (P)
+      then
+         Priv_Id := First_Private_Entity (P);
+      end if;
+
+      if P = Standard_Standard then
+         Change_Selected_Component_To_Expanded_Name (N);
+         Rewrite (N, Selector_Name (N));
+         Analyze (N);
+         Set_Etype (Original_Node (N), Standard_Character);
+         return True;
+      end if;
+
+      Id := First_Entity (P);
+
+      while Present (Id)
+        and then Id /= Priv_Id
+      loop
+         if Is_Character_Type (Id)
+           and then (Root_Type (Id) = Standard_Character
+                       or else Root_Type (Id) = Standard_Wide_Character)
+           and then Id = Base_Type (Id)
+         then
+            --  We replace the node with the literal itself, resolve as a
+            --  character, and set the type correctly.
+
+            if not Found then
+               Change_Selected_Component_To_Expanded_Name (N);
+               Rewrite (N, Selector_Name (N));
+               Analyze (N);
+               Set_Etype (N, Id);
+               Set_Etype (Original_Node (N), Id);
+               Found := True;
+
+            else
+               --  More than one type derived from Character in given scope.
+               --  Collect all possible interpretations.
+
+               Add_One_Interp (N, Id, Id);
+            end if;
+         end if;
+
+         Next_Entity (Id);
+      end loop;
+
+      return Found;
+   end Has_Implicit_Character_Literal;
+
+   ---------------------------
+   -- Has_Implicit_Operator --
+   ---------------------------
+
+   function Has_Implicit_Operator (N : Node_Id) return Boolean is
+      Op_Id   : constant Name_Id   := Chars (Selector_Name (N));
+      P       : constant Entity_Id := Entity (Prefix (N));
+      Id      : Entity_Id;
+      Priv_Id : Entity_Id := Empty;
+
+      procedure Add_Implicit_Operator (T : Entity_Id);
+      --  Add implicit interpretation to node N, using the type for which
+      --  a predefined operator exists.
+
+      ---------------------------
+      -- Add_Implicit_Operator --
+      ---------------------------
+
+      procedure Add_Implicit_Operator (T : Entity_Id) is
+         Predef_Op : Entity_Id;
+
+      begin
+         Predef_Op := Current_Entity (Selector_Name (N));
+
+         while Present (Predef_Op)
+           and then Scope (Predef_Op) /= Standard_Standard
+         loop
+            Predef_Op := Homonym (Predef_Op);
+         end loop;
+
+         if Nkind (N) = N_Selected_Component then
+            Change_Selected_Component_To_Expanded_Name (N);
+         end if;
+
+         Add_One_Interp (N, Predef_Op, T);
+
+         --  For operators with unary and binary interpretations, add both
+
+         if Present (Homonym (Predef_Op)) then
+            Add_One_Interp (N, Homonym (Predef_Op), T);
+         end if;
+      end Add_Implicit_Operator;
+
+   --  Start of processing for Has_Implicit_Operator
+
+   begin
+
+      if Ekind (P) = E_Package
+        and then not In_Open_Scopes (P)
+      then
+         Priv_Id := First_Private_Entity (P);
+      end if;
+
+      Id := First_Entity (P);
+
+      case Op_Id is
+
+         --  Boolean operators: an implicit declaration exists if the scope
+         --  contains a declaration for a derived Boolean type, or for an
+         --  array of Boolean type.
+
+         when Name_Op_And | Name_Op_Not | Name_Op_Or  | Name_Op_Xor =>
+
+            while Id  /= Priv_Id loop
+
+               if Valid_Boolean_Arg (Id)
+                 and then Id = Base_Type (Id)
+               then
+                  Add_Implicit_Operator (Id);
+                  return True;
+               end if;
+
+               Next_Entity (Id);
+            end loop;
+
+         --  Equality: look for any non-limited type. Result is Boolean.
+
+         when Name_Op_Eq | Name_Op_Ne =>
+
+            while Id  /= Priv_Id loop
+
+               if Is_Type (Id)
+                 and then not Is_Limited_Type (Id)
+                 and then Id = Base_Type (Id)
+               then
+                  Add_Implicit_Operator (Standard_Boolean);
+                  return True;
+               end if;
+
+               Next_Entity (Id);
+            end loop;
+
+         --  Comparison operators: scalar type, or array of scalar.
+
+         when Name_Op_Lt | Name_Op_Le | Name_Op_Gt | Name_Op_Ge =>
+
+            while Id  /= Priv_Id loop
+               if (Is_Scalar_Type (Id)
+                 or else (Is_Array_Type (Id)
+                           and then Is_Scalar_Type (Component_Type (Id))))
+                 and then Id = Base_Type (Id)
+               then
+                  Add_Implicit_Operator (Standard_Boolean);
+                  return True;
+               end if;
+
+               Next_Entity (Id);
+            end loop;
+
+         --  Arithmetic operators: any numeric type
+
+         when Name_Op_Abs      |
+              Name_Op_Add      |
+              Name_Op_Mod      |
+              Name_Op_Rem      |
+              Name_Op_Subtract |
+              Name_Op_Multiply |
+              Name_Op_Divide   |
+              Name_Op_Expon    =>
+
+            while Id  /= Priv_Id loop
+               if Is_Numeric_Type (Id)
+                 and then Id = Base_Type (Id)
+               then
+                  Add_Implicit_Operator (Id);
+                  return True;
+               end if;
+
+               Next_Entity (Id);
+            end loop;
+
+         --  Concatenation: any one-dimensional array type
+
+         when Name_Op_Concat =>
+
+            while Id  /= Priv_Id loop
+               if Is_Array_Type (Id) and then Number_Dimensions (Id) = 1
+                 and then Id = Base_Type (Id)
+               then
+                  Add_Implicit_Operator (Id);
+                  return True;
+               end if;
+
+               Next_Entity (Id);
+            end loop;
+
+         --  What is the others condition here? Should we be using a
+         --  subtype of Name_Id that would restrict to operators ???
+
+         when others => null;
+
+      end case;
+
+      --  If we fall through, then we do not have an implicit operator
+
+      return False;
+
+   end Has_Implicit_Operator;
+
+   --------------------
+   -- In_Open_Scopes --
+   --------------------
+
+   function In_Open_Scopes (S : Entity_Id) return Boolean is
+   begin
+      --  Since there are several scope stacks maintained by Scope_Stack each
+      --  delineated by Standard (see comments by definition of Scope_Stack)
+      --  it is necessary to end the search when Standard is reached.
+
+      for J in reverse 0 .. Scope_Stack.Last loop
+         if Scope_Stack.Table (J).Entity = S then
+            return True;
+         end if;
+
+         --  We need Is_Active_Stack_Base to tell us when to stop rather
+         --  than checking for Standard_Standard because there are cases
+         --  where Standard_Standard appears in the middle of the active
+         --  set of scopes. This affects the declaration and overriding
+         --  of private inherited operations in instantiations of generic
+         --  child units.
+
+         exit when Scope_Stack.Table (J).Is_Active_Stack_Base;
+      end loop;
+
+      return False;
+   end In_Open_Scopes;
+
+   -----------------------------
+   -- Inherit_Renamed_Profile --
+   -----------------------------
+
+   procedure Inherit_Renamed_Profile (New_S : Entity_Id; Old_S : Entity_Id) is
+      New_F : Entity_Id;
+      Old_F : Entity_Id;
+      Old_T : Entity_Id;
+      New_T : Entity_Id;
+
+   begin
+      if Ekind (Old_S) = E_Operator then
+
+         New_F := First_Formal (New_S);
+
+         while Present (New_F) loop
+            Set_Etype (New_F, Base_Type (Etype (New_F)));
+            Next_Formal (New_F);
+         end loop;
+
+         Set_Etype (New_S, Base_Type (Etype (New_S)));
+
+      else
+         New_F := First_Formal (New_S);
+         Old_F := First_Formal (Old_S);
+
+         while Present (New_F) loop
+            New_T := Etype (New_F);
+            Old_T := Etype (Old_F);
+
+            --  If the new type is a renaming of the old one, as is the
+            --  case for actuals in instances, retain its name, to simplify
+            --  later disambiguation.
+
+            if Nkind (Parent (New_T)) = N_Subtype_Declaration
+              and then Is_Entity_Name (Subtype_Indication (Parent (New_T)))
+              and then Entity (Subtype_Indication (Parent (New_T))) = Old_T
+            then
+               null;
+            else
+               Set_Etype (New_F, Old_T);
+            end if;
+
+            Next_Formal (New_F);
+            Next_Formal (Old_F);
+         end loop;
+
+         if Ekind (Old_S) = E_Function
+           or else Ekind (Old_S) = E_Enumeration_Literal
+         then
+            Set_Etype (New_S, Etype (Old_S));
+         end if;
+      end if;
+   end Inherit_Renamed_Profile;
+
+   ----------------
+   -- Initialize --
+   ----------------
+
+   procedure Initialize is
+   begin
+      Urefs.Init;
+   end Initialize;
+
+   -------------------------
+   -- Install_Use_Clauses --
+   -------------------------
+
+   procedure Install_Use_Clauses (Clause : Node_Id) is
+      U  : Node_Id := Clause;
+      P  : Node_Id;
+      Id : Entity_Id;
+
+   begin
+      while Present (U) loop
+
+         --  Case of USE package
+
+         if Nkind (U) = N_Use_Package_Clause then
+            P := First (Names (U));
+
+            while Present (P) loop
+               Id := Entity (P);
+
+               if Ekind (Id) = E_Package then
+
+                  if In_Use (Id) then
+                     Set_Redundant_Use (P, True);
+
+                  elsif Present (Renamed_Object (Id))
+                    and then In_Use (Renamed_Object (Id))
+                  then
+                     Set_Redundant_Use (P, True);
+
+                  else
+                     Use_One_Package (Id, U);
+                  end if;
+               end if;
+
+               Next (P);
+            end loop;
+
+         --  case of USE TYPE
+
+         else
+            P := First (Subtype_Marks (U));
+
+            while Present (P) loop
+
+               if Entity (P) /= Any_Type then
+                  Use_One_Type (P, U);
+               end if;
+
+               Next (P);
+            end loop;
+         end if;
+
+         Next_Use_Clause (U);
+      end loop;
+   end Install_Use_Clauses;
+
+   -------------------------------------
+   -- Is_Appropriate_For_Entry_Prefix --
+   -------------------------------------
+
+   function Is_Appropriate_For_Entry_Prefix (T : Entity_Id) return Boolean is
+      P_Type : Entity_Id := T;
+
+   begin
+      if Is_Access_Type (P_Type) then
+         P_Type := Designated_Type (P_Type);
+      end if;
+
+      return Is_Task_Type (P_Type) or else Is_Protected_Type (P_Type);
+   end Is_Appropriate_For_Entry_Prefix;
+
+   -------------------------------
+   -- Is_Appropriate_For_Record --
+   -------------------------------
+
+   function Is_Appropriate_For_Record
+     (T    : Entity_Id)
+      return Boolean
+   is
+      function Has_Components (T1 : Entity_Id) return Boolean;
+      --  Determine if given type has components (i.e. is either a record
+      --  type or a type that has discriminants).
+
+      function Has_Components (T1 : Entity_Id) return Boolean is
+      begin
+         return Is_Record_Type (T1)
+           or else (Is_Private_Type (T1) and then Has_Discriminants (T1))
+           or else (Is_Task_Type (T1) and then Has_Discriminants (T1));
+      end Has_Components;
+
+   --  Start of processing for Is_Appropriate_For_Record
+
+   begin
+      return
+        Present (T)
+          and then (Has_Components (T)
+                      or else (Is_Access_Type (T)
+                                 and then
+                                   Has_Components (Designated_Type (T))));
+   end Is_Appropriate_For_Record;
+
+   ---------------
+   -- New_Scope --
+   ---------------
+
+   procedure New_Scope (S : Entity_Id) is
+      E : Entity_Id;
+
+   begin
+      if Ekind (S) = E_Void then
+         null;
+
+      --  Set scope depth if not a non-concurrent type, and we have not
+      --  yet set the scope depth. This means that we have the first
+      --  occurrence of the scope, and this is where the depth is set.
+
+      elsif (not Is_Type (S) or else Is_Concurrent_Type (S))
+        and then not Scope_Depth_Set (S)
+      then
+         if S = Standard_Standard then
+            Set_Scope_Depth_Value (S, Uint_0);
+
+         elsif Is_Child_Unit (S) then
+            Set_Scope_Depth_Value (S, Uint_1);
+
+         elsif not Is_Record_Type (Current_Scope) then
+            if Ekind (S) = E_Loop then
+               Set_Scope_Depth_Value (S, Scope_Depth (Current_Scope));
+            else
+               Set_Scope_Depth_Value (S, Scope_Depth (Current_Scope) + 1);
+            end if;
+         end if;
+      end if;
+
+      Scope_Stack.Increment_Last;
+
+      Scope_Stack.Table (Scope_Stack.Last).Entity := S;
+
+      Scope_Stack.Table (Scope_Stack.Last).Save_Scope_Suppress  :=
+        Scope_Suppress;
+
+      Scope_Stack.Table (Scope_Stack.Last).Save_Entity_Suppress :=
+        Entity_Suppress.Last;
+
+      if Scope_Stack.Last > Scope_Stack.First then
+         Scope_Stack.Table (Scope_Stack.Last).Component_Alignment_Default :=
+         Scope_Stack.Table (Scope_Stack.Last - 1).Component_Alignment_Default;
+      end if;
+
+      Scope_Stack.Table (Scope_Stack.Last).Last_Subprogram_Name   := null;
+      Scope_Stack.Table (Scope_Stack.Last).Is_Transient           := False;
+      Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped     := Empty;
+      Scope_Stack.Table (Scope_Stack.Last).Pending_Freeze_Actions := No_List;
+      Scope_Stack.Table
+        (Scope_Stack.Last).Actions_To_Be_Wrapped_Before           := No_List;
+      Scope_Stack.Table
+        (Scope_Stack.Last).Actions_To_Be_Wrapped_After            := No_List;
+      Scope_Stack.Table (Scope_Stack.Last).First_Use_Clause       := Empty;
+      Scope_Stack.Table (Scope_Stack.Last).Is_Active_Stack_Base   := False;
+
+      if Debug_Flag_W then
+         Write_Str ("--> new scope: ");
+         Write_Name (Chars (Current_Scope));
+         Write_Str (", Id=");
+         Write_Int (Int (Current_Scope));
+         Write_Str (", Depth=");
+         Write_Int (Int (Scope_Stack.Last));
+         Write_Eol;
+      end if;
+
+      --  Copy from Scope (S) the categorization flags to S, this is not
+      --  done in case Scope (S) is Standard_Standard since propagation
+      --  is from library unit entity inwards.
+
+      if S /= Standard_Standard
+        and then Scope (S) /= Standard_Standard
+        and then not Is_Child_Unit (S)
+      then
+         E := Scope (S);
+
+         if Nkind (E) not in N_Entity then
+            return;
+         end if;
+
+         --  We only propagate inwards for library level entities,
+         --  inner level subprograms do not inherit the categorization.
+
+         if Is_Library_Level_Entity (S) then
+            Set_Is_Pure (S, Is_Pure (E));
+            Set_Is_Preelaborated (S, Is_Preelaborated (E));
+            Set_Is_Remote_Call_Interface (S, Is_Remote_Call_Interface (E));
+            Set_Is_Remote_Types (S, Is_Remote_Types (E));
+            Set_Is_Shared_Passive (S, Is_Shared_Passive (E));
+         end if;
+      end if;
+   end New_Scope;
+
+   ---------------
+   -- Pop_Scope --
+   ---------------
+
+   procedure Pop_Scope is
+      E : Entity_Id;
+
+   begin
+      if Debug_Flag_E then
+         Write_Info;
+      end if;
+
+      Scope_Suppress :=
+        Scope_Stack.Table (Scope_Stack.Last).Save_Scope_Suppress;
+
+      while Entity_Suppress.Last >
+                 Scope_Stack.Table (Scope_Stack.Last).Save_Entity_Suppress
+      loop
+         E := Entity_Suppress.Table (Entity_Suppress.Last).Entity;
+
+         case Entity_Suppress.Table (Entity_Suppress.Last).Check is
+
+            when Access_Check        =>
+               Set_Suppress_Access_Checks        (E, False);
+
+            when Accessibility_Check =>
+               Set_Suppress_Accessibility_Checks (E, False);
+
+            when Discriminant_Check  =>
+               Set_Suppress_Discriminant_Checks  (E, False);
+
+            when Division_Check      =>
+               Set_Suppress_Division_Checks      (E, False);
+
+            when Elaboration_Check   =>
+               Set_Suppress_Elaboration_Checks   (E, False);
+
+            when Index_Check         =>
+               Set_Suppress_Index_Checks         (E, False);
+
+            when Length_Check        =>
+               Set_Suppress_Length_Checks        (E, False);
+
+            when Overflow_Check      =>
+               Set_Suppress_Overflow_Checks      (E, False);
+
+            when Range_Check         =>
+               Set_Suppress_Range_Checks         (E, False);
+
+            when Storage_Check       =>
+               Set_Suppress_Storage_Checks       (E, False);
+
+            when Tag_Check           =>
+               Set_Suppress_Tag_Checks           (E, False);
+
+            --  All_Checks should not appear here (since it is entered as a
+            --  series of its separate checks). Bomb if it is encountered
+
+            when All_Checks =>
+               raise Program_Error;
+         end case;
+
+         Entity_Suppress.Decrement_Last;
+      end loop;
+
+      if Debug_Flag_W then
+         Write_Str ("--> exiting scope: ");
+         Write_Name (Chars (Current_Scope));
+         Write_Str (", Depth=");
+         Write_Int (Int (Scope_Stack.Last));
+         Write_Eol;
+      end if;
+
+      End_Use_Clauses (Scope_Stack.Table (Scope_Stack.Last).First_Use_Clause);
+
+      --  If the actions to be wrapped are still there they will get lost
+      --  causing incomplete code to be generated. It is better to abort in
+      --  this case.
+
+      pragma Assert (Scope_Stack.Table
+        (Scope_Stack.Last).Actions_To_Be_Wrapped_Before = No_List);
+
+      pragma Assert (Scope_Stack.Table
+        (Scope_Stack.Last).Actions_To_Be_Wrapped_After = No_List);
+
+      --  Free last subprogram name if allocated, and pop scope
+
+      Free (Scope_Stack.Table (Scope_Stack.Last).Last_Subprogram_Name);
+      Scope_Stack.Decrement_Last;
+   end Pop_Scope;
+
+   ---------------------
+   -- Premature_Usage --
+   ---------------------
+
+   procedure Premature_Usage (N : Node_Id) is
+      Kind : Node_Kind := Nkind (Parent (Entity (N)));
+      E    : Entity_Id := Entity (N);
+
+   begin
+      --  Within an instance, the analysis of the actual for a formal object
+      --  does not see the name of the object itself. This is significant
+      --  only if the object is an aggregate, where its analysis does not do
+      --  any name resolution on component associations. (see 4717-008). In
+      --  such a case, look for the visible homonym on the chain.
+
+      if In_Instance
+        and then Present (Homonym (E))
+      then
+         E := Homonym (E);
+
+         while Present (E)
+           and then not In_Open_Scopes (Scope (E))
+         loop
+            E := Homonym (E);
+         end loop;
+
+         if Present (E) then
+            Set_Entity (N, E);
+            Set_Etype (N, Etype (E));
+            return;
+         end if;
+      end if;
+
+      if Kind  = N_Component_Declaration then
+         Error_Msg_N
+           ("component&! cannot be used before end of record declaration", N);
+
+      elsif Kind  = N_Parameter_Specification then
+         Error_Msg_N
+           ("formal parameter&! cannot be used before end of specification",
+            N);
+
+      elsif Kind  = N_Discriminant_Specification then
+         Error_Msg_N
+           ("discriminant&! cannot be used before end of discriminant part",
+            N);
+
+      elsif Kind  = N_Procedure_Specification
+        or else Kind = N_Function_Specification
+      then
+         Error_Msg_N
+           ("subprogram&! cannot be used before end of its declaration",
+            N);
+      else
+         Error_Msg_N
+           ("object& cannot be used before end of its declaration!", N);
+      end if;
+   end Premature_Usage;
+
+   ------------------------
+   -- Present_System_Aux --
+   ------------------------
+
+   function Present_System_Aux (N : Node_Id := Empty) return Boolean is
+      Loc      : Source_Ptr;
+      Aux_Name : Name_Id;
+      Unum     : Unit_Number_Type;
+      Withn    : Node_Id;
+      With_Sys : Node_Id;
+      The_Unit : Node_Id;
+
+      function Find_System (C_Unit : Node_Id) return Entity_Id;
+      --  Scan context clause of compilation unit to find a with_clause
+      --  for System.
+
+      function Find_System (C_Unit : Node_Id) return Entity_Id is
+         With_Clause : Node_Id;
+
+      begin
+         With_Clause := First (Context_Items (C_Unit));
+
+         while Present (With_Clause) loop
+            if (Nkind (With_Clause) = N_With_Clause
+              and then Chars (Name (With_Clause)) = Name_System)
+              and then Comes_From_Source (With_Clause)
+            then
+               return With_Clause;
+            end if;
+
+            Next (With_Clause);
+         end loop;
+
+         return Empty;
+      end Find_System;
+
+   --  Start of processing for Present_System_Aux
+
+   begin
+      --  The child unit may have been loaded and analyzed already.
+
+      if Present (System_Aux_Id) then
+         return True;
+
+      --  If no previous pragma for System.Aux, nothing to load
+
+      elsif No (System_Extend_Pragma_Arg) then
+         return False;
+
+      --  Use the unit name given in the pragma to retrieve the unit.
+      --  Verify that System itself appears in the context clause of the
+      --  current compilation. If System is not present, an error will
+      --  have been reported already.
+
+      else
+         With_Sys := Find_System (Cunit (Current_Sem_Unit));
+
+         The_Unit := Unit (Cunit (Current_Sem_Unit));
+
+         if No (With_Sys)
+           and then (Nkind (The_Unit) = N_Package_Body
+                      or else (Nkind (The_Unit) = N_Subprogram_Body
+                        and then not Acts_As_Spec (Cunit (Current_Sem_Unit))))
+         then
+            With_Sys := Find_System (Library_Unit (Cunit (Current_Sem_Unit)));
+         end if;
+
+         if No (With_Sys)
+           and then Present (N)
+         then
+            --  If we are compiling a subunit, we need to examine its
+            --  context as well (Current_Sem_Unit is the parent unit);
+
+            The_Unit := Parent (N);
+
+            while Nkind (The_Unit) /= N_Compilation_Unit loop
+               The_Unit := Parent (The_Unit);
+            end loop;
+
+            if Nkind (Unit (The_Unit)) = N_Subunit then
+               With_Sys := Find_System (The_Unit);
+            end if;
+         end if;
+
+         if No (With_Sys) then
+            return False;
+         end if;
+
+         Loc := Sloc (With_Sys);
+         Get_Name_String (Chars (Expression (System_Extend_Pragma_Arg)));
+         Name_Buffer (8 .. Name_Len + 7) := Name_Buffer (1 .. Name_Len);
+         Name_Buffer (1 .. 7) := "system.";
+         Name_Buffer (Name_Len + 8) := '%';
+         Name_Buffer (Name_Len + 9) := 's';
+         Name_Len := Name_Len + 9;
+         Aux_Name := Name_Find;
+
+         Unum :=
+           Load_Unit
+             (Load_Name  => Aux_Name,
+              Required   => False,
+              Subunit    => False,
+              Error_Node => With_Sys);
+
+         if Unum /= No_Unit then
+            Semantics (Cunit (Unum));
+            System_Aux_Id :=
+              Defining_Entity (Specification (Unit (Cunit (Unum))));
+
+            Withn := Make_With_Clause (Loc,
+              Name =>
+                Make_Expanded_Name (Loc,
+                  Chars  => Chars (System_Aux_Id),
+                  Prefix =>
+                    New_Reference_To (Scope (System_Aux_Id), Loc),
+                  Selector_Name =>
+                    New_Reference_To (System_Aux_Id, Loc)));
+
+            Set_Entity (Name (Withn), System_Aux_Id);
+
+            Set_Library_Unit          (Withn, Cunit (Unum));
+            Set_Corresponding_Spec    (Withn, System_Aux_Id);
+            Set_First_Name            (Withn, True);
+            Set_Implicit_With         (Withn, True);
+
+            Insert_After (With_Sys, Withn);
+            Mark_Rewrite_Insertion (Withn);
+            Set_Context_Installed (Withn);
+
+            return True;
+
+         --  Here if unit load failed
+
+         else
+            Error_Msg_Name_1 := Name_System;
+            Error_Msg_Name_2 := Chars (Expression (System_Extend_Pragma_Arg));
+            Error_Msg_N
+              ("extension package `%.%` does not exist",
+               Opt.System_Extend_Pragma_Arg);
+            return False;
+         end if;
+      end if;
+   end Present_System_Aux;
+
+   -------------------------
+   -- Restore_Scope_Stack --
+   -------------------------
+
+   procedure Restore_Scope_Stack is
+      E         : Entity_Id;
+      S         : Entity_Id;
+      Comp_Unit : Node_Id;
+      In_Child  : Boolean := False;
+      Full_Vis  : Boolean := True;
+
+   begin
+      --  Restore visibility of previous scope stack, if any.
+
+      for J in reverse 0 .. Scope_Stack.Last loop
+         exit when  Scope_Stack.Table (J).Entity = Standard_Standard
+            or else No (Scope_Stack.Table (J).Entity);
+
+         S := Scope_Stack.Table (J).Entity;
+
+         if not Is_Hidden_Open_Scope (S) then
+
+            --  If the parent scope is hidden, its entities are hidden as
+            --  well, unless the entity is the instantiation currently
+            --  being analyzed.
+
+            if not Is_Hidden_Open_Scope (Scope (S))
+              or else not Analyzed (Parent (S))
+              or else Scope (S) = Standard_Standard
+            then
+               Set_Is_Immediately_Visible (S, True);
+            end if;
+
+            E := First_Entity (S);
+
+            while Present (E) loop
+               if Is_Child_Unit (E) then
+                  Set_Is_Immediately_Visible (E,
+                    Is_Visible_Child_Unit (E) or else In_Open_Scopes (E));
+               else
+                  Set_Is_Immediately_Visible (E, True);
+               end if;
+
+               Next_Entity (E);
+
+               if not Full_Vis then
+                  exit when E = First_Private_Entity (S);
+               end if;
+            end loop;
+
+            --  The visibility of child units (siblings of current compilation)
+            --  must be restored in any case. Their declarations may appear
+            --  after the private part of the parent.
+
+            if not Full_Vis
+              and then Present (E)
+            then
+               while Present (E) loop
+                  if Is_Child_Unit (E) then
+                     Set_Is_Immediately_Visible (E,
+                       Is_Visible_Child_Unit (E) or else In_Open_Scopes (E));
+                  end if;
+
+                  Next_Entity (E);
+               end loop;
+            end if;
+         end if;
+
+         if Is_Child_Unit (S)
+            and not In_Child     --  check only for current unit.
+         then
+            In_Child := True;
+
+            --  restore visibility of parents according to whether the child
+            --  is private and whether we are in its visible part.
+
+            Comp_Unit := Parent (Unit_Declaration_Node (S));
+
+            if Nkind (Comp_Unit) = N_Compilation_Unit
+              and then Private_Present (Comp_Unit)
+            then
+               Full_Vis := True;
+
+            elsif (Ekind (S) = E_Package
+                    or else Ekind (S) = E_Generic_Package)
+              and then (In_Private_Part (S)
+                         or else In_Package_Body (S))
+            then
+               Full_Vis := True;
+
+            elsif (Ekind (S) = E_Procedure
+                    or else Ekind (S) = E_Function)
+              and then Has_Completion (S)
+            then
+               Full_Vis := True;
+            else
+               Full_Vis := False;
+            end if;
+         else
+            Full_Vis := True;
+         end if;
+      end loop;
+   end Restore_Scope_Stack;
+
+   ----------------------
+   -- Save_Scope_Stack --
+   ----------------------
+
+   procedure Save_Scope_Stack is
+      E       : Entity_Id;
+      S       : Entity_Id;
+      SS_Last : constant Int := Scope_Stack.Last;
+
+   begin
+      if SS_Last >= Scope_Stack.First
+        and then Scope_Stack.Table (SS_Last).Entity /= Standard_Standard
+      then
+
+         --  If the call is from within a compilation unit, as when
+         --  called from Rtsfind, make current entries in scope stack
+         --  invisible while we analyze the new unit.
+
+         for J in reverse 0 .. SS_Last loop
+            exit when  Scope_Stack.Table (J).Entity = Standard_Standard
+               or else No (Scope_Stack.Table (J).Entity);
+
+            S := Scope_Stack.Table (J).Entity;
+            Set_Is_Immediately_Visible (S, False);
+            E := First_Entity (S);
+
+            while Present (E) loop
+               Set_Is_Immediately_Visible (E, False);
+               Next_Entity (E);
+            end loop;
+         end loop;
+
+      end if;
+   end Save_Scope_Stack;
+
+   -------------
+   -- Set_Use --
+   -------------
+
+   procedure Set_Use (L : List_Id) is
+      Decl      : Node_Id;
+      Pack_Name : Node_Id;
+      Pack      : Entity_Id;
+      Id        : Entity_Id;
+
+   begin
+      if Present (L) then
+         Decl := First (L);
+
+         while Present (Decl) loop
+            if Nkind (Decl) = N_Use_Package_Clause then
+               Chain_Use_Clause (Decl);
+               Pack_Name := First (Names (Decl));
+
+               while Present (Pack_Name) loop
+                  Pack := Entity (Pack_Name);
+
+                  if Ekind (Pack) = E_Package
+                    and then Applicable_Use (Pack_Name)
+                  then
+                     Use_One_Package (Pack, Decl);
+                  end if;
+
+                  Next (Pack_Name);
+               end loop;
+
+            elsif Nkind (Decl) = N_Use_Type_Clause  then
+               Chain_Use_Clause (Decl);
+               Id := First (Subtype_Marks (Decl));
+
+               while Present (Id) loop
+                  if Entity (Id) /= Any_Type then
+                     Use_One_Type (Id, Decl);
+                  end if;
+
+                  Next (Id);
+               end loop;
+            end if;
+
+            Next (Decl);
+         end loop;
+      end if;
+   end Set_Use;
+
+   ---------------------
+   -- Use_One_Package --
+   ---------------------
+
+   procedure Use_One_Package (P : Entity_Id; N : Node_Id) is
+      Id               : Entity_Id;
+      Prev             : Entity_Id;
+      Current_Instance : Entity_Id := Empty;
+      Real_P           : Entity_Id;
+
+   begin
+      if Ekind (P) /= E_Package then
+         return;
+      end if;
+
+      Set_In_Use (P);
+
+      if From_With_Type (P) then
+         Error_Msg_N ("imported package cannot appear in use clause", N);
+      end if;
+
+      --  Find enclosing instance, if any.
+
+      if In_Instance then
+         Current_Instance := Current_Scope;
+
+         while not Is_Generic_Instance (Current_Instance) loop
+            Current_Instance := Scope (Current_Instance);
+         end loop;
+
+         if No (Hidden_By_Use_Clause (N)) then
+            Set_Hidden_By_Use_Clause (N, New_Elmt_List);
+         end if;
+      end if;
+
+      --  If unit is a package renaming, indicate that the renamed
+      --  package is also in use (the flags on both entities must
+      --  remain consistent, and a subsequent use of either of them
+      --  should be recognized as redundant).
+
+      if Present (Renamed_Object (P)) then
+         Set_In_Use (Renamed_Object (P));
+         Real_P := Renamed_Object (P);
+      else
+         Real_P := P;
+      end if;
+
+      --  Loop through entities in one package making them potentially
+      --  use-visible.
+
+      Id := First_Entity (P);
+      while Present (Id)
+        and then Id /= First_Private_Entity (P)
+      loop
+         Prev := Current_Entity (Id);
+
+         while Present (Prev) loop
+            if Is_Immediately_Visible (Prev)
+              and then (not Is_Overloadable (Prev)
+                         or else not Is_Overloadable (Id)
+                         or else (Type_Conformant (Id, Prev)))
+            then
+               if No (Current_Instance) then
+
+                  --  Potentially use-visible entity remains hidden
+
+                  goto Next_Usable_Entity;
+
+               --  A use clause within an instance hides outer global
+               --  entities, which are not used to resolve local entities
+               --  in the instance. Note that the predefined entities in
+               --  Standard could not have been hidden in the generic by
+               --  a use clause, and therefore remain visible. Other
+               --  compilation units whose entities appear in Standard must
+               --  be hidden in an instance.
+
+               --  To determine whether an entity is external to the instance
+               --  we compare the scope depth of its scope with that of the
+               --  current instance. However, a generic actual of a subprogram
+               --  instance is declared in the wrapper package but will not be
+               --  hidden by a use-visible entity.
+
+               elsif not Is_Hidden (Id)
+                 and then not Is_Wrapper_Package (Scope (Prev))
+                 and then Scope_Depth (Scope (Prev)) <
+                          Scope_Depth (Current_Instance)
+                 and then (Scope (Prev) /= Standard_Standard
+                            or else Sloc (Prev) > Standard_Location)
+               then
+                  Set_Is_Potentially_Use_Visible (Id);
+                  Set_Is_Immediately_Visible (Prev, False);
+                  Append_Elmt (Prev, Hidden_By_Use_Clause (N));
+               end if;
+
+            --  A user-defined operator is not use-visible if the
+            --  predefined operator for the type is immediately visible,
+            --  which is the case if the type of the operand is in an open
+            --  scope. This does not apply to user-defined operators that
+            --  have operands of different types, because the predefined
+            --  mixed mode operations (multiplication and division) apply to
+            --  universal types and do not hide anything.
+
+            elsif Ekind (Prev) = E_Operator
+              and then Operator_Matches_Spec (Prev, Id)
+              and then In_Open_Scopes
+               (Scope (Base_Type (Etype (First_Formal (Id)))))
+              and then (No (Next_Formal (First_Formal (Id)))
+                         or else Etype (First_Formal (Id))
+                           = Etype (Next_Formal (First_Formal (Id)))
+                         or else Chars (Prev) = Name_Op_Expon)
+            then
+               goto Next_Usable_Entity;
+            end if;
+
+            Prev := Homonym (Prev);
+         end loop;
+
+         --  On exit, we know entity is not hidden, unless it is private.
+
+         if not Is_Hidden (Id)
+           and then ((not Is_Child_Unit (Id))
+                       or else Is_Visible_Child_Unit (Id))
+         then
+            Set_Is_Potentially_Use_Visible (Id);
+
+            if Is_Private_Type (Id)
+              and then Present (Full_View (Id))
+            then
+               Set_Is_Potentially_Use_Visible (Full_View (Id));
+            end if;
+         end if;
+
+         <<Next_Usable_Entity>>
+            Next_Entity (Id);
+      end loop;
+
+      --  Child units are also made use-visible by a use clause, but they
+      --  may appear after all visible declarations in the parent entity list.
+
+      while Present (Id) loop
+
+         if Is_Child_Unit (Id)
+           and then Is_Visible_Child_Unit (Id)
+         then
+            Set_Is_Potentially_Use_Visible (Id);
+         end if;
+
+         Next_Entity (Id);
+      end loop;
+
+      if Chars (Real_P) = Name_System
+        and then Scope (Real_P) = Standard_Standard
+        and then Present_System_Aux (N)
+      then
+         Use_One_Package (System_Aux_Id, N);
+      end if;
+
+   end Use_One_Package;
+
+   ------------------
+   -- Use_One_Type --
+   ------------------
+
+   procedure Use_One_Type (Id : Node_Id; N : Node_Id) is
+      T       : Entity_Id;
+      Op_List : Elist_Id;
+      Elmt    : Elmt_Id;
+
+   begin
+      --  It is the type determined by the subtype mark (8.4(8)) whose
+      --  operations become potentially use-visible.
+
+      T := Base_Type (Entity (Id));
+
+      --  Save current visibility status of type, before setting.
+
+      Set_Redundant_Use
+        (Id, In_Use (T) or else Is_Potentially_Use_Visible (T));
+
+      if In_Open_Scopes (Scope (T)) then
+         null;
+
+      elsif not Redundant_Use (Id) then
+         Set_In_Use (T);
+         Op_List := Collect_Primitive_Operations (T);
+         Elmt := First_Elmt (Op_List);
+
+         while Present (Elmt) loop
+
+            if (Nkind (Node (Elmt)) = N_Defining_Operator_Symbol
+                 or else Chars (Node (Elmt)) in Any_Operator_Name)
+              and then not Is_Hidden (Node (Elmt))
+            then
+               Set_Is_Potentially_Use_Visible (Node (Elmt));
+            end if;
+
+            Next_Elmt (Elmt);
+         end loop;
+      end if;
+
+   end Use_One_Type;
+
+   ----------------
+   -- Write_Info --
+   ----------------
+
+   procedure Write_Info is
+      Id : Entity_Id := First_Entity (Current_Scope);
+
+   begin
+      --  No point in dumping standard entities
+
+      if Current_Scope = Standard_Standard then
+         return;
+      end if;
+
+      Write_Str ("========================================================");
+      Write_Eol;
+      Write_Str ("        Defined Entities in ");
+      Write_Name (Chars (Current_Scope));
+      Write_Eol;
+      Write_Str ("========================================================");
+      Write_Eol;
+
+      if No (Id) then
+         Write_Str ("-- none --");
+         Write_Eol;
+
+      else
+         while Present (Id) loop
+            Write_Entity_Info (Id, " ");
+            Next_Entity (Id);
+         end loop;
+      end if;
+
+      if Scope (Current_Scope) = Standard_Standard then
+
+         --  Print information on the current unit itself
+
+         Write_Entity_Info (Current_Scope, " ");
+      end if;
+
+      Write_Eol;
+   end Write_Info;
+
+   -----------------
+   -- Write_Scopes --
+   -----------------
+
+   procedure Write_Scopes is
+      S : Entity_Id;
+
+   begin
+      for J in reverse 1 .. Scope_Stack.Last loop
+         S :=  Scope_Stack.Table (J).Entity;
+         Write_Int (Int (S));
+         Write_Str (" === ");
+         Write_Name (Chars (S));
+         Write_Eol;
+      end loop;
+   end Write_Scopes;
+
+end Sem_Ch8;
diff --git a/gcc/ada/sem_ch8.ads b/gcc/ada/sem_ch8.ads
new file mode 100644
index 00000000000..c2713657a4a
--- /dev/null
+++ b/gcc/ada/sem_ch8.ads
@@ -0,0 +1,190 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              S E M _ C H 8                               --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.33 $                             --
+--                                                                          --
+--          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 Sem_Ch8 is
+
+   -----------------------------------
+   -- Handling extensions of System --
+   -----------------------------------
+
+   --  For targets that define a much larger System package than given in
+   --  the RM, we use a child package containing additional declarations,
+   --  which is loaded when needed, and whose entities are conceptually
+   --  within System itself. The presence of this auxiliary package is
+   --  controlled with the pragma Extend_System. The following variable
+   --  holds the entity of the auxiliary package, to simplify the special
+   --  visibility rules that apply to it.
+
+   System_Aux_Id : Entity_Id := Empty;
+
+   -----------------
+   -- Subprograms --
+   -----------------
+
+   procedure Analyze_Exception_Renaming                 (N : Node_Id);
+   procedure Analyze_Expanded_Name                      (N : Node_Id);
+   procedure Analyze_Generic_Function_Renaming          (N : Node_Id);
+   procedure Analyze_Generic_Package_Renaming           (N : Node_Id);
+   procedure Analyze_Generic_Procedure_Renaming         (N : Node_Id);
+   procedure Analyze_Object_Renaming                    (N : Node_Id);
+   procedure Analyze_Package_Renaming                   (N : Node_Id);
+   procedure Analyze_Subprogram_Renaming                (N : Node_Id);
+   procedure Analyze_Use_Package                        (N : Node_Id);
+   procedure Analyze_Use_Type                           (N : Node_Id);
+
+   function Applicable_Use (Pack_Name : Node_Id) return Boolean;
+   --  Common code to Use_One_Package and Set_Use, to determine whether
+   --  use clause must be processed. Pack_Name is an entity name that
+   --  references the package in question.
+
+   procedure End_Scope;
+   --  Called at end of scope. On exit from blocks and bodies (subprogram,
+   --  package, task, and protected bodies), the name of the current scope
+   --  must be removed from the scope stack, and the local entities must be
+   --  removed from their homonym chains. On exit from record declarations,
+   --  from package specifications, and from tasks and protected type
+   --  specifications, more specialized procedures are invoked.
+
+   procedure End_Use_Clauses (Clause : Node_Id);
+   --  Invoked on scope exit, to undo the effect of local use clauses. U is
+   --  the first Use clause of a scope being exited. This can be the current
+   --  scope, or some enclosing scopes when building a clean environment to
+   --  compile an instance body for inlining.
+
+   procedure End_Use_Package (N : Node_Id);
+   procedure End_Use_Type    (N : Node_Id);
+   --  Subsidiaries of End_Use_Clauses.  Also called directly for use clauses
+   --  appearing in context clauses.
+
+   procedure Find_Direct_Name (N : Node_Id);
+   --  Given a direct name (Identifier or Operator_Symbol), this routine
+   --  scans the homonym chain for the name searching for corresponding
+   --  visible entities to find the referenced entity (or in the case of
+   --  overloading), entities. On return, the Entity, and Etype fields
+   --  are set. In the non-overloaded case, these are the correct final
+   --  entries. In the overloaded case, Is_Overloaded is set, Etype and
+   --  Entity refer to an arbitrary element of the overloads set, and
+   --  an appropriate list of entries has been made in the overload
+   --  interpretation table (to be disambiguated in the resolve phase).
+
+   procedure Find_Expanded_Name (N : Node_Id);
+   --  Selected component is known to be expanded name. Verify legality
+   --  of selector given the scope denoted by prefix.
+
+   procedure Find_Selected_Component (N : Node_Id);
+   --  Resolve various cases of selected components, recognize expanded names
+
+   procedure Find_Type (N : Node_Id);
+   --  Perform name resolution, and verify that the name found is that of a
+   --  type. On return the Entity and Etype fields of the node N are set
+   --  appropriately. If it is an incomplete type whose full declaration has
+   --  been seen, return the entity in the full declaration. Similarly, if
+   --  the type is private, it has receivd a full declaration, and we are
+   --  in the private part or body of the package, return the full
+   --  declaration as well. Special processing for Class types as well.
+
+   function Get_Full_View (T_Name : Entity_Id) return Entity_Id;
+   --  If T_Name is an incomplete type and the full declaration has been
+   --  seen, or is the name of a class_wide type whose root is incomplete.
+   --  return the corresponding full declaration.
+
+   function Has_Implicit_Operator (N : Node_Id) return Boolean;
+   --  N is an expanded name whose selector is an operator name (eg P."+").
+   --  A declarative part contains an implicit declaration of an operator
+   --  if it has a declaration of a type to which one of the predefined
+   --  operators apply. The existence of this routine is an artifact of
+   --  our implementation: a more straightforward but more space-consuming
+   --  choice would be to make all inherited operators explicit in the
+   --  symbol table.
+
+   procedure Initialize;
+   --  Initializes data structures used for visibility analysis. Must be
+   --  called before analyzing each new main source program.
+
+   procedure Install_Use_Clauses (Clause : Node_Id);
+   --  applies the use clauses appearing in a given declarative part,
+   --  when the corresponding scope has been placed back on the scope
+   --  stack after unstacking to compile a different context (subunit or
+   --  parent of generic body).
+
+   function In_Open_Scopes (S : Entity_Id) return Boolean;
+   --  S is the entity of a scope. This function determines if this scope
+   --  is currently open (i.e. it appears somewhere in the scope stack).
+
+   function Is_Appropriate_For_Record (T : Entity_Id) return Boolean;
+   --  Prefix is appropriate for record if it is of a record type, or
+   --  an access to such.
+
+   function Is_Appropriate_For_Entry_Prefix (T : Entity_Id) return Boolean;
+   --  True if it is of a task type, a protected type, or else an access
+   --  to one of these types.
+
+   procedure New_Scope (S : Entity_Id);
+   --  Make new scope stack entry, pushing S, the entity for a scope
+   --  onto the top of the scope table. The current setting of the scope
+   --  suppress flags is saved for restoration on exit.
+
+   procedure Pop_Scope;
+   --  Remove top entry from scope stack, restoring the saved setting
+   --  of the scope suppress flags.
+
+   function Present_System_Aux (N : Node_Id := Empty) return Boolean;
+   --  Return True if the auxiliary system file has been sucessfully loaded.
+   --  Otherwise attempt to load it, using the name supplied by a previous
+   --  Extend_System pragma, and report on the success of the load.
+   --  If N is present, it is a selected component whose prefix is System,
+   --  or else a with-clause on system. N is absent when the function is
+   --  called to find the visibility of implicit operators.
+
+   procedure Restore_Scope_Stack;
+   procedure Save_Scope_Stack;
+   --  These two procedures are called from Semantics, when a unit U1 is
+   --  to be compiled in the course of the compilation of another unit U2.
+   --  This happens whenever Rtsfind is called. U1, the unit retrieved by
+   --  Rtsfind, must be compiled in its own context, and the current scope
+   --  stack containing U2 and local scopes must be made unreachable. On
+   --  return, the contents of the scope stack must be made accessible again.
+
+   procedure Use_One_Package (P : Entity_Id; N : Node_Id);
+   --  Make visible entities declarated in package P potentially use-visible
+   --  in the current context. Also used in the analysis of subunits, when
+   --  re-installing use clauses of parent units. N is the use_clause that
+   --  names P (and possibly other packages).
+
+   procedure Use_One_Type (Id : Node_Id; N : Node_Id);
+   --  Id is the subtype mark from a use type clause. This procedure makes
+   --  the primitive operators of the type potentially use-visible.
+   --  N is the Use_Type_Clause that names Id.
+
+   procedure Set_Use (L : List_Id);
+   --  Find use clauses that are declarative items in a package declaration
+   --  and  set the potentially use-visible flags of imported entities before
+   --  analyzing the corresponding package body.
+
+end Sem_Ch8;
diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb
new file mode 100644
index 00000000000..2075e5e5342
--- /dev/null
+++ b/gcc/ada/sem_ch9.adb
@@ -0,0 +1,1705 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              S E M _ C H 9                               --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.235 $
+--                                                                          --
+--          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 Checks;   use Checks;
+with Einfo;    use Einfo;
+with Errout;   use Errout;
+with Exp_Ch9;
+with Elists;   use Elists;
+with Itypes;   use Itypes;
+with Lib.Xref; use Lib.Xref;
+with Nlists;   use Nlists;
+with Nmake;    use Nmake;
+with Opt;      use Opt;
+with Restrict; use Restrict;
+with Rtsfind;  use Rtsfind;
+with Sem;      use Sem;
+with Sem_Ch3;  use Sem_Ch3;
+with Sem_Ch5;  use Sem_Ch5;
+with Sem_Ch6;  use Sem_Ch6;
+with Sem_Ch8;  use Sem_Ch8;
+with Sem_Eval; use Sem_Eval;
+with Sem_Res;  use Sem_Res;
+with Sem_Type; use Sem_Type;
+with Sem_Util; use Sem_Util;
+with Sem_Warn; use Sem_Warn;
+with Snames;   use Snames;
+with Stand;    use Stand;
+with Sinfo;    use Sinfo;
+with Style;
+with Tbuild;   use Tbuild;
+with Uintp;    use Uintp;
+
+package body Sem_Ch9 is
+
+   -----------------------
+   -- Local Subprograms --
+   -----------------------
+
+   procedure Check_Max_Entries (Def : Node_Id; R : Restriction_Parameter_Id);
+   --  Given either a protected definition or a task definition in Def, check
+   --  the corresponding restriction parameter identifier R, and if it is set,
+   --  count the entries (checking the static requirement), and compare with
+   --  the given maximum.
+
+   function Find_Concurrent_Spec (Body_Id : Entity_Id) return Entity_Id;
+   --  Find entity in corresponding task or protected declaration. Use full
+   --  view if first declaration was for an incomplete type.
+
+   procedure Install_Declarations (Spec : Entity_Id);
+   --  Utility to make visible in corresponding body the entities defined
+   --  in task, protected type declaration, or entry declaration.
+
+   -----------------------------
+   -- Analyze_Abort_Statement --
+   -----------------------------
+
+   procedure Analyze_Abort_Statement (N : Node_Id) is
+      T_Name : Node_Id;
+
+   begin
+      Tasking_Used := True;
+      T_Name := First (Names (N));
+      while Present (T_Name) loop
+         Analyze (T_Name);
+
+         if not Is_Task_Type (Etype (T_Name)) then
+            Error_Msg_N ("expect task name for ABORT", T_Name);
+            return;
+         else
+            Resolve (T_Name,  Etype (T_Name));
+         end if;
+
+         Next (T_Name);
+      end loop;
+
+      Check_Restriction (No_Abort_Statements, N);
+      Check_Potentially_Blocking_Operation (N);
+   end Analyze_Abort_Statement;
+
+   --------------------------------
+   -- Analyze_Accept_Alternative --
+   --------------------------------
+
+   procedure Analyze_Accept_Alternative (N : Node_Id) is
+   begin
+      Tasking_Used := True;
+
+      if Present (Pragmas_Before (N)) then
+         Analyze_List (Pragmas_Before (N));
+      end if;
+
+      Analyze (Accept_Statement (N));
+
+      if Present (Condition (N)) then
+         Analyze_And_Resolve (Condition (N), Any_Boolean);
+      end if;
+
+      if Is_Non_Empty_List (Statements (N)) then
+         Analyze_Statements (Statements (N));
+      end if;
+   end Analyze_Accept_Alternative;
+
+   ------------------------------
+   -- Analyze_Accept_Statement --
+   ------------------------------
+
+   procedure Analyze_Accept_Statement (N : Node_Id) is
+      Nam       : constant Entity_Id := Entry_Direct_Name (N);
+      Formals   : constant List_Id   := Parameter_Specifications (N);
+      Index     : constant Node_Id   := Entry_Index (N);
+      Stats     : constant Node_Id   := Handled_Statement_Sequence (N);
+      Ityp      : Entity_Id;
+      Entry_Nam : Entity_Id;
+      E         : Entity_Id;
+      Kind      : Entity_Kind;
+      Task_Nam  : Entity_Id;
+
+      -----------------------
+      -- Actual_Index_Type --
+      -----------------------
+
+      function Actual_Index_Type (E : Entity_Id) return Entity_Id;
+      --  If the bounds of an entry family depend on task discriminants,
+      --  create a new index type where a discriminant is replaced by the
+      --  local variable that renames it in the task body.
+
+      function Actual_Index_Type (E : Entity_Id) return Entity_Id is
+         Typ   : Entity_Id := Entry_Index_Type (E);
+         Lo    : Node_Id := Type_Low_Bound  (Typ);
+         Hi    : Node_Id := Type_High_Bound (Typ);
+         New_T : Entity_Id;
+
+         function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id;
+         --  If bound is discriminant reference, replace with corresponding
+         --  local variable of the same name.
+
+         function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id is
+            Typ : Entity_Id := Etype (Bound);
+            Ref : Node_Id;
+
+         begin
+            if not Is_Entity_Name (Bound)
+              or else Ekind (Entity (Bound)) /= E_Discriminant
+            then
+               return Bound;
+
+            else
+               Ref := Make_Identifier (Sloc (N), Chars (Entity (Bound)));
+               Analyze (Ref);
+               Resolve (Ref, Typ);
+               return Ref;
+            end if;
+         end Actual_Discriminant_Ref;
+
+      --  Start of processing for Actual_Index_Type
+
+      begin
+         if not Has_Discriminants (Task_Nam)
+           or else (not Is_Entity_Name (Lo)
+                     and then not Is_Entity_Name (Hi))
+         then
+            return Entry_Index_Type (E);
+         else
+            New_T := Create_Itype (Ekind (Typ), N);
+            Set_Etype        (New_T, Base_Type (Typ));
+            Set_Size_Info    (New_T, Typ);
+            Set_RM_Size      (New_T, RM_Size (Typ));
+            Set_Scalar_Range (New_T,
+              Make_Range (Sloc (N),
+                Low_Bound  => Actual_Discriminant_Ref (Lo),
+                High_Bound => Actual_Discriminant_Ref (Hi)));
+
+            return New_T;
+         end if;
+      end Actual_Index_Type;
+
+   --  Start of processing for Analyze_Accept_Statement
+
+   begin
+      Tasking_Used := True;
+
+      --  Entry name is initialized to Any_Id. It should get reset to the
+      --  matching entry entity. An error is signalled if it is not reset.
+
+      Entry_Nam := Any_Id;
+
+      for J in reverse 0 .. Scope_Stack.Last loop
+         Task_Nam := Scope_Stack.Table (J).Entity;
+         exit when Ekind (Etype (Task_Nam)) = E_Task_Type;
+         Kind :=  Ekind (Task_Nam);
+
+         if Kind /= E_Block and then Kind /= E_Loop
+           and then not Is_Entry (Task_Nam)
+         then
+            Error_Msg_N ("enclosing body of accept must be a task", N);
+            return;
+         end if;
+      end loop;
+
+      if Ekind (Etype (Task_Nam)) /= E_Task_Type then
+         Error_Msg_N ("invalid context for accept statement",  N);
+         return;
+      end if;
+
+      --  In order to process the parameters, we create a defining
+      --  identifier that can be used as the name of the scope. The
+      --  name of the accept statement itself is not a defining identifier.
+
+      if Present (Index) then
+         Ityp := New_Internal_Entity
+           (E_Entry_Family, Current_Scope, Sloc (N), 'E');
+      else
+         Ityp := New_Internal_Entity
+           (E_Entry, Current_Scope, Sloc (N), 'E');
+      end if;
+
+      Set_Etype          (Ityp, Standard_Void_Type);
+      Set_Accept_Address (Ityp, New_Elmt_List);
+
+      if Present (Formals) then
+         New_Scope (Ityp);
+         Process_Formals (Ityp, Formals, N);
+         Create_Extra_Formals (Ityp);
+         End_Scope;
+      end if;
+
+      --  We set the default expressions processed flag because we don't
+      --  need default expression functions. This is really more like a
+      --  body entity than a spec entity anyway.
+
+      Set_Default_Expressions_Processed (Ityp);
+
+      E := First_Entity (Etype (Task_Nam));
+
+      while Present (E) loop
+         if Chars (E) = Chars (Nam)
+           and then (Ekind (E) = Ekind (Ityp))
+           and then Type_Conformant (Ityp, E)
+         then
+            Entry_Nam := E;
+            exit;
+         end if;
+
+         Next_Entity (E);
+      end loop;
+
+      if Entry_Nam = Any_Id then
+         Error_Msg_N ("no entry declaration matches accept statement",  N);
+         return;
+      else
+         Set_Entity (Nam, Entry_Nam);
+         Generate_Reference (Entry_Nam, Nam, 'b');
+         Style.Check_Identifier (Nam, Entry_Nam);
+      end if;
+
+      --  Verify that the entry is not hidden by a procedure declared in
+      --  the current block (pathological but possible).
+
+      if Current_Scope /= Task_Nam then
+         declare
+            E1 : Entity_Id;
+
+         begin
+            E1 := First_Entity (Current_Scope);
+
+            while Present (E1) loop
+
+               if Ekind (E1) = E_Procedure
+                 and then Type_Conformant (E1, Entry_Nam)
+               then
+                  Error_Msg_N ("entry name is not visible", N);
+               end if;
+
+               Next_Entity (E1);
+            end loop;
+         end;
+      end if;
+
+      Set_Convention (Ityp, Convention (Entry_Nam));
+      Check_Fully_Conformant (Ityp, Entry_Nam, N);
+
+      for J in reverse 0 .. Scope_Stack.Last loop
+         exit when Task_Nam = Scope_Stack.Table (J).Entity;
+
+         if Entry_Nam = Scope_Stack.Table (J).Entity then
+            Error_Msg_N ("duplicate accept statement for same entry", N);
+         end if;
+
+      end loop;
+
+      declare
+         P : Node_Id := N;
+      begin
+         loop
+            P := Parent (P);
+            case Nkind (P) is
+               when N_Task_Body | N_Compilation_Unit =>
+                  exit;
+               when N_Asynchronous_Select =>
+                  Error_Msg_N ("accept statements are not allowed within" &
+                               " an asynchronous select inner" &
+                               " to the enclosing task body", N);
+                  exit;
+               when others =>
+                  null;
+            end case;
+         end loop;
+      end;
+
+      if Ekind (E) = E_Entry_Family then
+         if No (Index) then
+            Error_Msg_N ("missing entry index in accept for entry family", N);
+         else
+            Analyze_And_Resolve (Index, Entry_Index_Type (E));
+            Apply_Range_Check (Index, Actual_Index_Type (E));
+         end if;
+
+      elsif Present (Index) then
+         Error_Msg_N ("invalid entry index in accept for simple entry", N);
+      end if;
+
+      --  If statements are present, they must be analyzed in the context
+      --  of the entry, so that references to formals are correctly resolved.
+      --  We also have to add the declarations that are required by the
+      --  expansion of the accept statement in this case if expansion active.
+
+      --  In the case of a select alternative of a selective accept,
+      --  the expander references the address declaration even if there
+      --  is no statement list.
+
+      Exp_Ch9.Expand_Accept_Declarations (N, Entry_Nam);
+
+      --  If label declarations present, analyze them. They are declared
+      --  in the enclosing task, but their enclosing scope is the entry itself,
+      --  so that goto's to the label are recognized as local to the accept.
+
+      if Present (Declarations (N)) then
+
+         declare
+            Decl : Node_Id;
+            Id   : Entity_Id;
+
+         begin
+            Decl := First (Declarations (N));
+
+            while Present (Decl) loop
+               Analyze (Decl);
+
+               pragma Assert
+                 (Nkind (Decl) = N_Implicit_Label_Declaration);
+
+               Id := Defining_Identifier (Decl);
+               Set_Enclosing_Scope (Id, Entry_Nam);
+               Next (Decl);
+            end loop;
+         end;
+      end if;
+
+      --  Set Not_Source_Assigned flag on all entry formals
+
+      E := First_Entity (Entry_Nam);
+
+      while Present (E) loop
+         Set_Not_Source_Assigned (E, True);
+         Next_Entity (E);
+      end loop;
+
+      --  Analyze statements if present
+
+      if Present (Stats) then
+         New_Scope (Entry_Nam);
+         Install_Declarations (Entry_Nam);
+
+         Set_Actual_Subtypes (N, Current_Scope);
+         Analyze (Stats);
+         Process_End_Label (Handled_Statement_Sequence (N), 't');
+         End_Scope;
+      end if;
+
+      --  Some warning checks
+
+      Check_Potentially_Blocking_Operation (N);
+      Check_References (Entry_Nam, N);
+      Set_Entry_Accepted (Entry_Nam);
+
+   end Analyze_Accept_Statement;
+
+   ---------------------------------
+   -- Analyze_Asynchronous_Select --
+   ---------------------------------
+
+   procedure Analyze_Asynchronous_Select (N : Node_Id) is
+   begin
+      Tasking_Used := True;
+      Check_Restriction (Max_Asynchronous_Select_Nesting, N);
+      Check_Restriction (No_Select_Statements, N);
+
+      Analyze (Triggering_Alternative (N));
+
+      Analyze_Statements (Statements (Abortable_Part (N)));
+   end Analyze_Asynchronous_Select;
+
+   ------------------------------------
+   -- Analyze_Conditional_Entry_Call --
+   ------------------------------------
+
+   procedure Analyze_Conditional_Entry_Call (N : Node_Id) is
+   begin
+      Check_Restriction (No_Select_Statements, N);
+      Tasking_Used := True;
+      Analyze (Entry_Call_Alternative (N));
+      Analyze_Statements (Else_Statements (N));
+   end Analyze_Conditional_Entry_Call;
+
+   --------------------------------
+   -- Analyze_Delay_Alternative  --
+   --------------------------------
+
+   procedure Analyze_Delay_Alternative (N : Node_Id) is
+      Expr : Node_Id;
+
+   begin
+      Tasking_Used := True;
+      Check_Restriction (No_Delay, N);
+
+      if Present (Pragmas_Before (N)) then
+         Analyze_List (Pragmas_Before (N));
+      end if;
+
+      if Nkind (Parent (N)) = N_Selective_Accept
+        or else Nkind (Parent (N)) = N_Timed_Entry_Call
+      then
+         Expr := Expression (Delay_Statement (N));
+
+         --  defer full analysis until the statement is expanded, to insure
+         --  that generated code does not move past the guard. The delay
+         --  expression is only evaluated if the guard is open.
+
+         if Nkind (Delay_Statement (N)) = N_Delay_Relative_Statement then
+            Pre_Analyze_And_Resolve (Expr, Standard_Duration);
+
+         else
+            Pre_Analyze_And_Resolve (Expr);
+         end if;
+
+         Check_Restriction (No_Fixed_Point, Expr);
+      else
+         Analyze (Delay_Statement (N));
+      end if;
+
+      if Present (Condition (N)) then
+         Analyze_And_Resolve (Condition (N), Any_Boolean);
+      end if;
+
+      if Is_Non_Empty_List (Statements (N)) then
+         Analyze_Statements (Statements (N));
+      end if;
+   end Analyze_Delay_Alternative;
+
+   ----------------------------
+   -- Analyze_Delay_Relative --
+   ----------------------------
+
+   procedure Analyze_Delay_Relative (N : Node_Id) is
+      E : constant Node_Id := Expression (N);
+
+   begin
+      Check_Restriction (No_Relative_Delay, N);
+      Tasking_Used := True;
+      Check_Restriction (No_Delay, N);
+      Check_Potentially_Blocking_Operation (N);
+      Analyze_And_Resolve (E, Standard_Duration);
+      Check_Restriction (No_Fixed_Point, E);
+   end Analyze_Delay_Relative;
+
+   -------------------------
+   -- Analyze_Delay_Until --
+   -------------------------
+
+   procedure Analyze_Delay_Until (N : Node_Id) is
+      E : constant Node_Id := Expression (N);
+
+   begin
+      Tasking_Used := True;
+      Check_Restriction (No_Delay, N);
+      Check_Potentially_Blocking_Operation (N);
+      Analyze (E);
+
+      if not Is_RTE (Base_Type (Etype (E)), RO_CA_Time) and then
+         not Is_RTE (Base_Type (Etype (E)), RO_RT_Time)
+      then
+         Error_Msg_N ("expect Time types for `DELAY UNTIL`", E);
+      end if;
+   end Analyze_Delay_Until;
+
+   ------------------------
+   -- Analyze_Entry_Body --
+   ------------------------
+
+   procedure Analyze_Entry_Body (N : Node_Id) is
+      Id         : constant Entity_Id := Defining_Identifier (N);
+      Decls      : constant List_Id   := Declarations (N);
+      Stats      : constant Node_Id   := Handled_Statement_Sequence (N);
+      Formals    : constant Node_Id   := Entry_Body_Formal_Part (N);
+      P_Type     : constant Entity_Id := Current_Scope;
+      Entry_Name : Entity_Id;
+      E          : Entity_Id;
+
+   begin
+      Tasking_Used := True;
+
+      --  Entry_Name is initialized to Any_Id. It should get reset to the
+      --  matching entry entity. An error is signalled if it is not reset
+
+      Entry_Name := Any_Id;
+
+      Analyze (Formals);
+
+      if Present (Entry_Index_Specification (Formals)) then
+         Set_Ekind (Id, E_Entry_Family);
+      else
+         Set_Ekind (Id, E_Entry);
+      end if;
+
+      Set_Scope          (Id, Current_Scope);
+      Set_Etype          (Id, Standard_Void_Type);
+      Set_Accept_Address (Id, New_Elmt_List);
+
+      E := First_Entity (P_Type);
+      while Present (E) loop
+         if Chars (E) = Chars (Id)
+           and then (Ekind (E) = Ekind (Id))
+           and then Type_Conformant (Id, E)
+         then
+            Entry_Name := E;
+            Set_Convention (Id, Convention (E));
+            Check_Fully_Conformant (Id, E, N);
+            exit;
+         end if;
+
+         Next_Entity (E);
+      end loop;
+
+      if Entry_Name = Any_Id then
+         Error_Msg_N ("no entry declaration matches entry body",  N);
+         return;
+
+      elsif Has_Completion (Entry_Name) then
+         Error_Msg_N ("duplicate entry body", N);
+         return;
+
+      else
+         Set_Has_Completion (Entry_Name);
+         Generate_Reference (Entry_Name, Id, 'b');
+         Style.Check_Identifier (Id, Entry_Name);
+      end if;
+
+      Exp_Ch9.Expand_Entry_Barrier (N, Entry_Name);
+      New_Scope (Entry_Name);
+
+      Exp_Ch9.Expand_Entry_Body_Declarations (N);
+      Install_Declarations (Entry_Name);
+      Set_Actual_Subtypes (N, Current_Scope);
+
+      --  The entity for the protected subprogram corresponding to the entry
+      --  has been created. We retain the name of this entity in the entry
+      --  body, for use when the corresponding subprogram body is created.
+      --  Note that entry bodies have to corresponding_spec, and there is no
+      --  easy link back in the tree between the entry body and the entity for
+      --  the entry itself.
+
+      Set_Protected_Body_Subprogram (Id,
+        Protected_Body_Subprogram (Entry_Name));
+
+      if Present (Decls) then
+         Analyze_Declarations (Decls);
+      end if;
+
+      if Present (Stats) then
+         Analyze (Stats);
+      end if;
+
+      Check_References (Entry_Name);
+      Process_End_Label (Handled_Statement_Sequence (N), 't');
+      End_Scope;
+
+      --  If this is an entry family, remove the loop created to provide
+      --  a scope for the entry index.
+
+      if Ekind (Id) = E_Entry_Family
+        and then Present (Entry_Index_Specification (Formals))
+      then
+         End_Scope;
+      end if;
+
+   end Analyze_Entry_Body;
+
+   ------------------------------------
+   -- Analyze_Entry_Body_Formal_Part --
+   ------------------------------------
+
+   procedure Analyze_Entry_Body_Formal_Part (N : Node_Id) is
+      Id      : constant Entity_Id := Defining_Identifier (Parent (N));
+      Index   : constant Node_Id   := Entry_Index_Specification (N);
+      Formals : constant List_Id   := Parameter_Specifications (N);
+
+   begin
+      Tasking_Used := True;
+
+      if Present (Index) then
+         Analyze (Index);
+      end if;
+
+      if Present (Formals) then
+         Set_Scope (Id, Current_Scope);
+         New_Scope (Id);
+         Process_Formals (Id, Formals, Parent (N));
+         End_Scope;
+      end if;
+
+   end Analyze_Entry_Body_Formal_Part;
+
+   ------------------------------------
+   -- Analyze_Entry_Call_Alternative --
+   ------------------------------------
+
+   procedure Analyze_Entry_Call_Alternative (N : Node_Id) is
+   begin
+      Tasking_Used := True;
+
+      if Present (Pragmas_Before (N)) then
+         Analyze_List (Pragmas_Before (N));
+      end if;
+
+      Analyze (Entry_Call_Statement (N));
+
+      if Is_Non_Empty_List (Statements (N)) then
+         Analyze_Statements (Statements (N));
+      end if;
+   end Analyze_Entry_Call_Alternative;
+
+   -------------------------------
+   -- Analyze_Entry_Declaration --
+   -------------------------------
+
+   procedure Analyze_Entry_Declaration (N : Node_Id) is
+      Id      : Entity_Id := Defining_Identifier (N);
+      D_Sdef  : Node_Id   := Discrete_Subtype_Definition (N);
+      Formals : List_Id   := Parameter_Specifications (N);
+
+   begin
+      Generate_Definition (Id);
+      Tasking_Used := True;
+
+      if No (D_Sdef) then
+         Set_Ekind (Id, E_Entry);
+      else
+         Enter_Name (Id);
+         Set_Ekind (Id, E_Entry_Family);
+         Analyze (D_Sdef);
+         Make_Index (D_Sdef, N, Id);
+      end if;
+
+      Set_Etype          (Id, Standard_Void_Type);
+      Set_Convention     (Id, Convention_Entry);
+      Set_Accept_Address (Id, New_Elmt_List);
+
+      if Present (Formals) then
+         Set_Scope (Id, Current_Scope);
+         New_Scope (Id);
+         Process_Formals (Id, Formals, N);
+         Create_Extra_Formals (Id);
+         End_Scope;
+      end if;
+
+      if Ekind (Id) = E_Entry then
+         New_Overloaded_Entity (Id);
+      end if;
+
+   end Analyze_Entry_Declaration;
+
+   ---------------------------------------
+   -- Analyze_Entry_Index_Specification --
+   ---------------------------------------
+
+   --  The defining_Identifier of the entry index specification is local
+   --  to the entry body, but must be available in the entry barrier,
+   --  which is evaluated outside of the entry body. The index is eventually
+   --  renamed as a run-time object, so is visibility is strictly a front-end
+   --  concern. In order to make it available to the barrier, we create
+   --  an additional scope, as for a loop, whose only declaration is the
+   --  index name. This loop is not attached to the tree and does not appear
+   --  as an entity local to the protected type, so its existence need only
+   --  be knwown to routines that process entry families.
+
+   procedure Analyze_Entry_Index_Specification (N : Node_Id) is
+      Iden    : constant Node_Id := Defining_Identifier (N);
+      Def     : constant Node_Id := Discrete_Subtype_Definition (N);
+      Loop_Id : Entity_Id :=
+                  Make_Defining_Identifier (Sloc (N),
+                    Chars => New_Internal_Name ('L'));
+
+   begin
+      Tasking_Used := True;
+      Analyze (Def);
+      Make_Index (Def, N);
+      Set_Ekind (Loop_Id, E_Loop);
+      Set_Scope (Loop_Id, Current_Scope);
+      New_Scope (Loop_Id);
+      Enter_Name (Iden);
+      Set_Ekind (Iden, E_Entry_Index_Parameter);
+      Set_Etype (Iden, Etype (Def));
+   end Analyze_Entry_Index_Specification;
+
+   ----------------------------
+   -- Analyze_Protected_Body --
+   ----------------------------
+
+   procedure Analyze_Protected_Body (N : Node_Id) is
+      Body_Id   : constant Entity_Id := Defining_Identifier (N);
+      Spec_Id   : Entity_Id;
+      Last_E    : Entity_Id;
+
+   begin
+      Tasking_Used := True;
+      Set_Ekind (Body_Id, E_Protected_Body);
+      Spec_Id := Find_Concurrent_Spec (Body_Id);
+
+      if Present (Spec_Id)
+        and then Ekind (Spec_Id) = E_Protected_Type
+      then
+         null;
+
+      elsif Present (Spec_Id)
+        and then Ekind (Etype (Spec_Id)) = E_Protected_Type
+        and then not Comes_From_Source (Etype (Spec_Id))
+      then
+         null;
+
+      else
+         Error_Msg_N ("missing specification for protected body", Body_Id);
+         return;
+      end if;
+
+      Generate_Reference (Spec_Id, Body_Id, 'b');
+      Style.Check_Identifier (Body_Id, Spec_Id);
+
+      --  The declarations are always attached to the type
+
+      if Ekind (Spec_Id) /= E_Protected_Type then
+         Spec_Id := Etype (Spec_Id);
+      end if;
+
+      New_Scope (Spec_Id);
+      Set_Corresponding_Spec (N, Spec_Id);
+      Set_Corresponding_Body (Parent (Spec_Id), Body_Id);
+      Set_Has_Completion (Spec_Id);
+      Install_Declarations (Spec_Id);
+
+      Exp_Ch9.Expand_Protected_Body_Declarations (N, Spec_Id);
+
+      Last_E := Last_Entity (Spec_Id);
+
+      Analyze_Declarations (Declarations (N));
+
+      --  For visibility purposes, all entities in the body are private.
+      --  Set First_Private_Entity accordingly, if there was no private
+      --  part in the protected declaration.
+
+      if No (First_Private_Entity (Spec_Id)) then
+         if Present (Last_E) then
+            Set_First_Private_Entity (Spec_Id, Next_Entity (Last_E));
+         else
+            Set_First_Private_Entity (Spec_Id, First_Entity (Spec_Id));
+         end if;
+      end if;
+
+      Check_Completion (Body_Id);
+      Check_References (Spec_Id);
+      Process_End_Label (N, 't');
+      End_Scope;
+   end Analyze_Protected_Body;
+
+   ----------------------------------
+   -- Analyze_Protected_Definition --
+   ----------------------------------
+
+   procedure Analyze_Protected_Definition (N : Node_Id) is
+      E : Entity_Id;
+      L : Entity_Id;
+
+   begin
+      Tasking_Used := True;
+      Analyze_Declarations (Visible_Declarations (N));
+
+      if Present (Private_Declarations (N))
+        and then not Is_Empty_List (Private_Declarations (N))
+      then
+         L := Last_Entity (Current_Scope);
+         Analyze_Declarations (Private_Declarations (N));
+
+         if Present (L) then
+            Set_First_Private_Entity (Current_Scope, Next_Entity (L));
+
+         else
+            Set_First_Private_Entity (Current_Scope,
+              First_Entity (Current_Scope));
+         end if;
+      end if;
+
+      E := First_Entity (Current_Scope);
+
+      while Present (E) loop
+
+         if Ekind (E) = E_Function
+           or else Ekind (E) = E_Procedure
+         then
+            Set_Convention (E, Convention_Protected);
+
+         elsif Is_Task_Type (Etype (E)) then
+            Set_Has_Task (Current_Scope);
+         end if;
+
+         Next_Entity (E);
+      end loop;
+
+      Check_Max_Entries (N, Max_Protected_Entries);
+      Process_End_Label (N, 'e');
+   end Analyze_Protected_Definition;
+
+   ----------------------------
+   -- Analyze_Protected_Type --
+   ----------------------------
+
+   procedure Analyze_Protected_Type (N : Node_Id) is
+      E      : Entity_Id;
+      T      : Entity_Id;
+      Def_Id : constant Entity_Id := Defining_Identifier (N);
+
+   begin
+      Tasking_Used := True;
+      Check_Restriction (No_Protected_Types, N);
+
+      T := Find_Type_Name (N);
+
+      if Ekind (T) = E_Incomplete_Type then
+         T := Full_View (T);
+      end if;
+
+      Set_Ekind              (T, E_Protected_Type);
+      Init_Size_Align        (T);
+      Set_Etype              (T, T);
+      Set_Is_First_Subtype   (T, True);
+      Set_Has_Delayed_Freeze (T, True);
+      Set_Girder_Constraint  (T, No_Elist);
+      New_Scope (T);
+
+      if Present (Discriminant_Specifications (N)) then
+         if Has_Discriminants (T) then
+
+            --  Install discriminants. Also, verify conformance of
+            --  discriminants of previous and current view.  ???
+
+            Install_Declarations (T);
+         else
+            Process_Discriminants (N);
+         end if;
+      end if;
+
+      Analyze (Protected_Definition (N));
+
+      --  Protected types with entries are controlled (because of the
+      --  Protection component if nothing else), same for any protected type
+      --  with interrupt handlers. Note that we need to analyze the protected
+      --  definition to set Has_Entries and such.
+
+      if (Abort_Allowed or else Restrictions (No_Entry_Queue) = False
+           or else Number_Entries (T) > 1)
+        and then
+          (Has_Entries (T)
+            or else Has_Interrupt_Handler (T)
+            or else Has_Attach_Handler (T))
+      then
+         Set_Has_Controlled_Component (T, True);
+      end if;
+
+      --  The Ekind of components is E_Void during analysis to detect
+      --  illegal uses. Now it can be set correctly.
+
+      E := First_Entity (Current_Scope);
+
+      while Present (E) loop
+         if Ekind (E) = E_Void then
+            Set_Ekind (E, E_Component);
+            Init_Component_Location (E);
+         end if;
+
+         Next_Entity (E);
+      end loop;
+
+      End_Scope;
+
+      if T /= Def_Id
+        and then Is_Private_Type (Def_Id)
+        and then Has_Discriminants (Def_Id)
+        and then Expander_Active
+      then
+         Exp_Ch9.Expand_N_Protected_Type_Declaration (N);
+         Process_Full_View (N, T, Def_Id);
+      end if;
+
+   end Analyze_Protected_Type;
+
+   ---------------------
+   -- Analyze_Requeue --
+   ---------------------
+
+   procedure Analyze_Requeue (N : Node_Id) is
+      Entry_Name : Node_Id := Name (N);
+      Entry_Id   : Entity_Id;
+      Found      : Boolean;
+      I          : Interp_Index;
+      It         : Interp;
+      Enclosing  : Entity_Id;
+      Target_Obj : Node_Id := Empty;
+      Req_Scope  : Entity_Id;
+      Outer_Ent  : Entity_Id;
+
+   begin
+      Check_Restriction (No_Requeue, N);
+      Check_Unreachable_Code (N);
+      Tasking_Used := True;
+
+      Enclosing := Empty;
+      for J in reverse 0 .. Scope_Stack.Last loop
+         Enclosing := Scope_Stack.Table (J).Entity;
+         exit when Is_Entry (Enclosing);
+
+         if Ekind (Enclosing) /= E_Block
+           and then Ekind (Enclosing) /= E_Loop
+         then
+            Error_Msg_N ("requeue must appear within accept or entry body", N);
+            return;
+         end if;
+      end loop;
+
+      Analyze (Entry_Name);
+
+      if Etype (Entry_Name) = Any_Type then
+         return;
+      end if;
+
+      if Nkind (Entry_Name) = N_Selected_Component then
+         Target_Obj := Prefix (Entry_Name);
+         Entry_Name := Selector_Name (Entry_Name);
+      end if;
+
+      --  If an explicit target object is given then we have to check
+      --  the restrictions of 9.5.4(6).
+
+      if Present (Target_Obj) then
+         --  Locate containing concurrent unit and determine
+         --  enclosing entry body or outermost enclosing accept
+         --  statement within the unit.
+
+         Outer_Ent := Empty;
+         for S in reverse 0 .. Scope_Stack.Last loop
+            Req_Scope := Scope_Stack.Table (S).Entity;
+
+            exit when Ekind (Req_Scope) in Task_Kind
+              or else Ekind (Req_Scope) in Protected_Kind;
+
+            if Is_Entry (Req_Scope) then
+               Outer_Ent := Req_Scope;
+            end if;
+         end loop;
+
+         pragma Assert (Present (Outer_Ent));
+
+         --  Check that the accessibility level of the target object
+         --  is not greater or equal to the outermost enclosing accept
+         --  statement (or entry body) unless it is a parameter of the
+         --  innermost enclosing accept statement (or entry body).
+
+         if Object_Access_Level (Target_Obj) >= Scope_Depth (Outer_Ent)
+           and then
+             (not Is_Entity_Name (Target_Obj)
+               or else Ekind (Entity (Target_Obj)) not in Formal_Kind
+               or else Enclosing /= Scope (Entity (Target_Obj)))
+         then
+            Error_Msg_N
+              ("target object has invalid level for requeue", Target_Obj);
+         end if;
+      end if;
+
+      --  Overloaded case, find right interpretation
+
+      if Is_Overloaded (Entry_Name) then
+         Get_First_Interp (Entry_Name, I, It);
+         Found := False;
+         Entry_Id := Empty;
+
+         while Present (It.Nam) loop
+
+            if No (First_Formal (It.Nam))
+              or else Subtype_Conformant (Enclosing, It.Nam)
+            then
+               if not Found then
+                  Found := True;
+                  Entry_Id := It.Nam;
+               else
+                  Error_Msg_N ("ambiguous entry name in requeue", N);
+                  return;
+               end if;
+            end if;
+
+            Get_Next_Interp (I, It);
+         end loop;
+
+         if not Found then
+            Error_Msg_N ("no entry matches context",  N);
+            return;
+         else
+            Set_Entity (Entry_Name, Entry_Id);
+         end if;
+
+      --  Non-overloaded cases
+
+      --  For the case of a reference to an element of an entry family,
+      --  the Entry_Name is an indexed component.
+
+      elsif Nkind (Entry_Name) = N_Indexed_Component then
+
+         --  Requeue to an entry out of the body
+
+         if Nkind (Prefix (Entry_Name)) = N_Selected_Component then
+            Entry_Id := Entity (Selector_Name (Prefix (Entry_Name)));
+
+         --  Requeue from within the body itself
+
+         elsif Nkind (Prefix (Entry_Name)) = N_Identifier then
+            Entry_Id := Entity (Prefix (Entry_Name));
+
+         else
+            Error_Msg_N ("invalid entry_name specified",  N);
+            return;
+         end if;
+
+      --  If we had a requeue of the form REQUEUE A (B), then the parser
+      --  accepted it (because it could have been a requeue on an entry
+      --  index. If A turns out not to be an entry family, then the analysis
+      --  of A (B) turned it into a function call.
+
+      elsif Nkind (Entry_Name) = N_Function_Call then
+         Error_Msg_N
+           ("arguments not allowed in requeue statement",
+            First (Parameter_Associations (Entry_Name)));
+         return;
+
+      --  Normal case of no entry family, no argument
+
+      else
+         Entry_Id := Entity (Entry_Name);
+      end if;
+
+      --  Resolve entry, and check that it is subtype conformant with the
+      --  enclosing construct if this construct has formals (RM 9.5.4(5)).
+
+      if not Is_Entry (Entry_Id) then
+         Error_Msg_N ("expect entry name in requeue statement", Name (N));
+      elsif Ekind (Entry_Id) = E_Entry_Family
+
+        and then Nkind (Entry_Name) /= N_Indexed_Component
+      then
+         Error_Msg_N ("missing index for entry family component", Name (N));
+
+      else
+         Resolve_Entry (Name (N));
+
+         if Present (First_Formal (Entry_Id)) then
+            Check_Subtype_Conformant (Enclosing, Entry_Id, Name (N));
+
+            --  Mark any output parameters as assigned
+
+            declare
+               Ent : Entity_Id := First_Formal (Enclosing);
+
+            begin
+               while Present (Ent) loop
+                  if Ekind (Ent) = E_Out_Parameter then
+                     Set_Not_Source_Assigned (Ent, False);
+                  end if;
+
+                  Next_Formal (Ent);
+               end loop;
+            end;
+         end if;
+      end if;
+
+   end Analyze_Requeue;
+
+   ------------------------------
+   -- Analyze_Selective_Accept --
+   ------------------------------
+
+   procedure Analyze_Selective_Accept (N : Node_Id) is
+      Alts : constant List_Id := Select_Alternatives (N);
+      Alt  : Node_Id;
+
+      Accept_Present    : Boolean := False;
+      Terminate_Present : Boolean := False;
+      Delay_Present     : Boolean := False;
+      Relative_Present  : Boolean := False;
+      Alt_Count         : Uint    := Uint_0;
+
+   begin
+      Check_Restriction (No_Select_Statements, N);
+      Tasking_Used := True;
+
+      Alt := First (Alts);
+      while Present (Alt) loop
+         Alt_Count := Alt_Count + 1;
+         Analyze (Alt);
+
+         if Nkind (Alt) = N_Delay_Alternative then
+            if Delay_Present then
+
+               if (Relative_Present /=
+                 (Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement))
+               then
+                  Error_Msg_N
+                    ("delay_until and delay_relative alternatives ", Alt);
+                  Error_Msg_N
+                    ("\cannot appear in the same selective_wait", Alt);
+               end if;
+
+            else
+               Delay_Present := True;
+               Relative_Present :=
+                 Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement;
+            end if;
+
+         elsif Nkind (Alt) = N_Terminate_Alternative then
+            if Terminate_Present then
+               Error_Msg_N ("Only one terminate alternative allowed", N);
+            else
+               Terminate_Present := True;
+               Check_Restriction (No_Terminate_Alternatives, N);
+            end if;
+
+         elsif Nkind (Alt) = N_Accept_Alternative then
+            Accept_Present := True;
+
+            --  Check for duplicate accept
+
+            declare
+               Alt1 : Node_Id;
+               Stm  : constant Node_Id := Accept_Statement (Alt);
+               EDN  : constant Node_Id := Entry_Direct_Name (Stm);
+               Ent  : Entity_Id;
+
+            begin
+               if Nkind (EDN) = N_Identifier
+                 and then No (Condition (Alt))
+                 and then Present (Entity (EDN)) -- defend against junk
+                 and then Ekind (Entity (EDN)) = E_Entry
+               then
+                  Ent := Entity (EDN);
+
+                  Alt1 := First (Alts);
+                  while Alt1 /= Alt loop
+                     if Nkind (Alt1) = N_Accept_Alternative
+                       and then No (Condition (Alt1))
+                     then
+                        declare
+                           Stm1 : constant Node_Id := Accept_Statement (Alt1);
+                           EDN1 : constant Node_Id := Entry_Direct_Name (Stm1);
+
+                        begin
+                           if Nkind (EDN1) = N_Identifier then
+                              if Entity (EDN1) = Ent then
+                                 Error_Msg_Sloc := Sloc (Stm1);
+                                 Error_Msg_N
+                                   ("?accept duplicates one on line#", Stm);
+                                 exit;
+                              end if;
+                           end if;
+                        end;
+                     end if;
+
+                     Next (Alt1);
+                  end loop;
+               end if;
+            end;
+         end if;
+
+         Next (Alt);
+      end loop;
+
+      Check_Restriction (Max_Select_Alternatives, Alt_Count, N);
+      Check_Potentially_Blocking_Operation (N);
+
+      if Terminate_Present and Delay_Present then
+         Error_Msg_N ("at most one of terminate or delay alternative", N);
+
+      elsif not Accept_Present then
+         Error_Msg_N
+           ("select must contain at least one accept alternative", N);
+      end if;
+
+      if Present (Else_Statements (N)) then
+         if Terminate_Present or Delay_Present then
+            Error_Msg_N ("else part not allowed with other alternatives", N);
+         end if;
+
+         Analyze_Statements (Else_Statements (N));
+      end if;
+   end Analyze_Selective_Accept;
+
+   ------------------------------
+   -- Analyze_Single_Protected --
+   ------------------------------
+
+   procedure Analyze_Single_Protected (N : Node_Id) is
+      Loc    : constant Source_Ptr := Sloc (N);
+      Id     : constant Node_Id    := Defining_Identifier (N);
+      T      : Entity_Id;
+      T_Decl : Node_Id;
+      O_Decl : Node_Id;
+      O_Name : constant Entity_Id := New_Copy (Id);
+
+   begin
+      Generate_Definition (Id);
+      Tasking_Used := True;
+
+      --  The node is rewritten as a protected type declaration,
+      --  in exact analogy with what is done with single tasks.
+
+      T :=
+        Make_Defining_Identifier (Sloc (Id),
+          New_External_Name (Chars (Id), 'T'));
+
+      T_Decl :=
+        Make_Protected_Type_Declaration (Loc,
+         Defining_Identifier => T,
+         Protected_Definition => Relocate_Node (Protected_Definition (N)));
+
+      O_Decl :=
+        Make_Object_Declaration (Loc,
+          Defining_Identifier => O_Name,
+          Object_Definition   => Make_Identifier (Loc,  Chars (T)));
+
+      Rewrite (N, T_Decl);
+      Insert_After (N, O_Decl);
+      Mark_Rewrite_Insertion (O_Decl);
+
+      --  Enter names of type and object before analysis, because the name
+      --  of the object may be used in its own body.
+
+      Enter_Name (T);
+      Set_Ekind (T, E_Protected_Type);
+      Set_Etype (T, T);
+
+      Enter_Name (O_Name);
+      Set_Ekind (O_Name, E_Variable);
+      Set_Etype (O_Name, T);
+
+      --  Instead of calling Analyze on the new node,  call directly
+      --  the proper analysis procedure. Otherwise the node would be
+      --  expanded twice, with disastrous result.
+
+      Analyze_Protected_Type (N);
+
+   end Analyze_Single_Protected;
+
+   -------------------------
+   -- Analyze_Single_Task --
+   -------------------------
+
+   procedure Analyze_Single_Task (N : Node_Id) is
+      Loc    : constant Source_Ptr := Sloc (N);
+      Id     : constant Node_Id    := Defining_Identifier (N);
+      T      : Entity_Id;
+      T_Decl : Node_Id;
+      O_Decl : Node_Id;
+      O_Name : constant Entity_Id := New_Copy (Id);
+
+   begin
+      Generate_Definition (Id);
+      Tasking_Used := True;
+
+      --  The node is rewritten as a task type declaration,  followed
+      --  by an object declaration of that anonymous task type.
+
+      T :=
+        Make_Defining_Identifier (Sloc (Id),
+          New_External_Name (Chars (Id), Suffix => "TK"));
+
+      T_Decl :=
+        Make_Task_Type_Declaration (Loc,
+          Defining_Identifier => T,
+          Task_Definition     => Relocate_Node (Task_Definition (N)));
+
+      O_Decl :=
+        Make_Object_Declaration (Loc,
+          Defining_Identifier => O_Name,
+          Object_Definition   => Make_Identifier (Loc, Chars (T)));
+
+      Rewrite (N, T_Decl);
+      Insert_After (N, O_Decl);
+      Mark_Rewrite_Insertion (O_Decl);
+
+      --  Enter names of type and object before analysis, because the name
+      --  of the object may be used in its own body.
+
+      Enter_Name (T);
+      Set_Ekind (T, E_Task_Type);
+      Set_Etype (T, T);
+
+      Enter_Name (O_Name);
+      Set_Ekind (O_Name, E_Variable);
+      Set_Etype (O_Name, T);
+
+      --  Instead of calling Analyze on the new node,  call directly
+      --  the proper analysis procedure. Otherwise the node would be
+      --  expanded twice, with disastrous result.
+
+      Analyze_Task_Type (N);
+
+   end Analyze_Single_Task;
+
+   -----------------------
+   -- Analyze_Task_Body --
+   -----------------------
+
+   procedure Analyze_Task_Body (N : Node_Id) is
+      Body_Id : constant Entity_Id := Defining_Identifier (N);
+      Spec_Id : Entity_Id;
+      Last_E  : Entity_Id;
+
+   begin
+      Tasking_Used := True;
+      Set_Ekind (Body_Id, E_Task_Body);
+      Set_Scope (Body_Id, Current_Scope);
+      Spec_Id := Find_Concurrent_Spec (Body_Id);
+
+      --  The spec is either a task type declaration, or a single task
+      --  declaration for which we have created an anonymous type.
+
+      if Present (Spec_Id)
+        and then Ekind (Spec_Id) = E_Task_Type
+      then
+         null;
+
+      elsif Present (Spec_Id)
+        and then Ekind (Etype (Spec_Id)) = E_Task_Type
+        and then not Comes_From_Source (Etype (Spec_Id))
+      then
+         null;
+
+      else
+         Error_Msg_N ("missing specification for task body", Body_Id);
+         return;
+      end if;
+
+      Generate_Reference (Spec_Id, Body_Id, 'b');
+      Style.Check_Identifier (Body_Id, Spec_Id);
+
+      --  Deal with case of body of single task (anonymous type was created)
+
+      if Ekind (Spec_Id) = E_Variable then
+         Spec_Id := Etype (Spec_Id);
+      end if;
+
+      New_Scope (Spec_Id);
+      Set_Corresponding_Spec (N, Spec_Id);
+      Set_Corresponding_Body (Parent (Spec_Id), Body_Id);
+      Set_Has_Completion (Spec_Id);
+      Install_Declarations (Spec_Id);
+      Last_E := Last_Entity (Spec_Id);
+
+      Analyze_Declarations (Declarations (N));
+
+      --  For visibility purposes, all entities in the body are private.
+      --  Set First_Private_Entity accordingly, if there was no private
+      --  part in the protected declaration.
+
+      if No (First_Private_Entity (Spec_Id)) then
+         if Present (Last_E) then
+            Set_First_Private_Entity (Spec_Id, Next_Entity (Last_E));
+         else
+            Set_First_Private_Entity (Spec_Id, First_Entity (Spec_Id));
+         end if;
+      end if;
+
+      Analyze (Handled_Statement_Sequence (N));
+      Check_Completion (Body_Id);
+      Check_References (Body_Id);
+
+      --  Check for entries with no corresponding accept
+
+      declare
+         Ent : Entity_Id;
+
+      begin
+         Ent := First_Entity (Spec_Id);
+
+         while Present (Ent) loop
+            if Is_Entry (Ent)
+              and then not Entry_Accepted (Ent)
+              and then Comes_From_Source (Ent)
+            then
+               Error_Msg_NE ("no accept for entry &?", N, Ent);
+            end if;
+
+            Next_Entity (Ent);
+         end loop;
+      end;
+
+      Process_End_Label (Handled_Statement_Sequence (N), 't');
+      End_Scope;
+   end Analyze_Task_Body;
+
+   -----------------------------
+   -- Analyze_Task_Definition --
+   -----------------------------
+
+   procedure Analyze_Task_Definition (N : Node_Id) is
+      L : Entity_Id;
+
+   begin
+      Tasking_Used := True;
+
+      if Present (Visible_Declarations (N)) then
+         Analyze_Declarations (Visible_Declarations (N));
+      end if;
+
+      if Present (Private_Declarations (N)) then
+         L := Last_Entity (Current_Scope);
+         Analyze_Declarations (Private_Declarations (N));
+
+         if Present (L) then
+            Set_First_Private_Entity
+              (Current_Scope, Next_Entity (L));
+         else
+            Set_First_Private_Entity
+              (Current_Scope, First_Entity (Current_Scope));
+         end if;
+      end if;
+
+      Check_Max_Entries (N, Max_Task_Entries);
+      Process_End_Label (N, 'e');
+   end Analyze_Task_Definition;
+
+   -----------------------
+   -- Analyze_Task_Type --
+   -----------------------
+
+   procedure Analyze_Task_Type (N : Node_Id) is
+      T      : Entity_Id;
+      Def_Id : constant Entity_Id := Defining_Identifier (N);
+
+   begin
+      Tasking_Used := True;
+      Check_Restriction (Max_Tasks, N);
+      T := Find_Type_Name (N);
+      Generate_Definition (T);
+
+      if Ekind (T) = E_Incomplete_Type then
+         T := Full_View (T);
+      end if;
+
+      Set_Ekind              (T, E_Task_Type);
+      Set_Is_First_Subtype   (T, True);
+      Set_Has_Task           (T, True);
+      Init_Size_Align        (T);
+      Set_Etype              (T, T);
+      Set_Has_Delayed_Freeze (T, True);
+      Set_Girder_Constraint (T, No_Elist);
+      New_Scope (T);
+
+      if Present (Discriminant_Specifications (N)) then
+         if Ada_83 and then Comes_From_Source (N) then
+            Error_Msg_N ("(Ada 83) task discriminant not allowed!", N);
+         end if;
+
+         if Has_Discriminants (T) then
+
+            --  Install discriminants. Also, verify conformance of
+            --  discriminants of previous and current view.  ???
+
+            Install_Declarations (T);
+         else
+            Process_Discriminants (N);
+         end if;
+      end if;
+
+      if Present (Task_Definition (N)) then
+         Analyze_Task_Definition (Task_Definition (N));
+      end if;
+
+      if not Is_Library_Level_Entity (T) then
+         Check_Restriction (No_Task_Hierarchy, N);
+      end if;
+
+      End_Scope;
+
+      if T /= Def_Id
+        and then Is_Private_Type (Def_Id)
+        and then Has_Discriminants (Def_Id)
+        and then Expander_Active
+      then
+         Exp_Ch9.Expand_N_Task_Type_Declaration (N);
+         Process_Full_View (N, T, Def_Id);
+      end if;
+   end Analyze_Task_Type;
+
+   -----------------------------------
+   -- Analyze_Terminate_Alternative --
+   -----------------------------------
+
+   procedure Analyze_Terminate_Alternative (N : Node_Id) is
+   begin
+      Tasking_Used := True;
+
+      if Present (Pragmas_Before (N)) then
+         Analyze_List (Pragmas_Before (N));
+      end if;
+
+      if Present (Condition (N)) then
+         Analyze_And_Resolve (Condition (N), Any_Boolean);
+      end if;
+   end Analyze_Terminate_Alternative;
+
+   ------------------------------
+   -- Analyze_Timed_Entry_Call --
+   ------------------------------
+
+   procedure Analyze_Timed_Entry_Call (N : Node_Id) is
+   begin
+      Check_Restriction (No_Select_Statements, N);
+      Tasking_Used := True;
+      Analyze (Entry_Call_Alternative (N));
+      Analyze (Delay_Alternative (N));
+   end Analyze_Timed_Entry_Call;
+
+   ------------------------------------
+   -- Analyze_Triggering_Alternative --
+   ------------------------------------
+
+   procedure Analyze_Triggering_Alternative (N : Node_Id) is
+      Trigger : Node_Id := Triggering_Statement (N);
+   begin
+      Tasking_Used := True;
+
+      if Present (Pragmas_Before (N)) then
+         Analyze_List (Pragmas_Before (N));
+      end if;
+
+      Analyze (Trigger);
+      if Comes_From_Source (Trigger)
+        and then Nkind (Trigger) /= N_Delay_Until_Statement
+        and then Nkind (Trigger) /= N_Delay_Relative_Statement
+        and then Nkind (Trigger) /= N_Entry_Call_Statement
+      then
+         Error_Msg_N
+          ("triggering statement must be delay or entry call", Trigger);
+      end if;
+
+      if Is_Non_Empty_List (Statements (N)) then
+         Analyze_Statements (Statements (N));
+      end if;
+   end Analyze_Triggering_Alternative;
+
+   -----------------------
+   -- Check_Max_Entries --
+   -----------------------
+
+   procedure Check_Max_Entries (Def : Node_Id; R : Restriction_Parameter_Id) is
+      Ecount : Uint;
+
+      procedure Count (L : List_Id);
+      --  Count entries in given declaration list
+
+      procedure Count (L : List_Id) is
+         D : Node_Id;
+
+      begin
+         if No (L) then
+            return;
+         end if;
+
+         D := First (L);
+         while Present (D) loop
+            if Nkind (D) = N_Entry_Declaration then
+               declare
+                  DSD : constant Node_Id :=
+                          Discrete_Subtype_Definition (D);
+
+               begin
+                  if No (DSD) then
+                     Ecount := Ecount + 1;
+
+                  elsif Is_OK_Static_Subtype (Etype (DSD)) then
+                     declare
+                        Lo : constant Uint :=
+                               Expr_Value
+                                 (Type_Low_Bound (Etype (DSD)));
+                        Hi : constant Uint :=
+                               Expr_Value
+                                 (Type_High_Bound (Etype (DSD)));
+
+                     begin
+                        if Hi >= Lo then
+                           Ecount := Ecount + Hi - Lo + 1;
+                        end if;
+                     end;
+
+                  else
+                     Error_Msg_N
+                       ("static subtype required by Restriction pragma", DSD);
+                  end if;
+               end;
+            end if;
+
+            Next (D);
+         end loop;
+      end Count;
+
+   --  Start of processing for Check_Max_Entries
+
+   begin
+      if Restriction_Parameters (R) >= 0 then
+         Ecount := Uint_0;
+         Count (Visible_Declarations (Def));
+         Count (Private_Declarations (Def));
+         Check_Restriction (R, Ecount, Def);
+      end if;
+   end Check_Max_Entries;
+
+   --------------------------
+   -- Find_Concurrent_Spec --
+   --------------------------
+
+   function Find_Concurrent_Spec (Body_Id : Entity_Id) return Entity_Id is
+      Spec_Id : Entity_Id := Current_Entity_In_Scope (Body_Id);
+
+   begin
+      --  The type may have been given by an incomplete type declaration.
+      --  Find full view now.
+
+      if Present (Spec_Id) and then Ekind (Spec_Id) = E_Incomplete_Type then
+         Spec_Id := Full_View (Spec_Id);
+      end if;
+
+      return Spec_Id;
+   end Find_Concurrent_Spec;
+
+   --------------------------
+   -- Install_Declarations --
+   --------------------------
+
+   procedure Install_Declarations (Spec : Entity_Id) is
+      E    : Entity_Id;
+      Prev : Entity_Id;
+
+   begin
+      E := First_Entity (Spec);
+
+      while Present (E) loop
+         Prev := Current_Entity (E);
+         Set_Current_Entity (E);
+         Set_Is_Immediately_Visible (E);
+         Set_Homonym (E, Prev);
+         Next_Entity (E);
+      end loop;
+   end Install_Declarations;
+
+end Sem_Ch9;
diff --git a/gcc/ada/sem_ch9.ads b/gcc/ada/sem_ch9.ads
new file mode 100644
index 00000000000..d4922b3a946
--- /dev/null
+++ b/gcc/ada/sem_ch9.ads
@@ -0,0 +1,58 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              S E M _ C H 9                               --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.8 $
+--                                                                          --
+--          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 Sem_Ch9  is
+   procedure Analyze_Abort_Statement                    (N : Node_Id);
+   procedure Analyze_Accept_Alternative                 (N : Node_Id);
+   procedure Analyze_Accept_Statement                   (N : Node_Id);
+   procedure Analyze_Asynchronous_Select                (N : Node_Id);
+   procedure Analyze_Conditional_Entry_Call             (N : Node_Id);
+   procedure Analyze_Delay_Alternative                  (N : Node_Id);
+   procedure Analyze_Delay_Relative                     (N : Node_Id);
+   procedure Analyze_Delay_Until                        (N : Node_Id);
+   procedure Analyze_Entry_Body                         (N : Node_Id);
+   procedure Analyze_Entry_Body_Formal_Part             (N : Node_Id);
+   procedure Analyze_Entry_Call_Alternative             (N : Node_Id);
+   procedure Analyze_Entry_Declaration                  (N : Node_Id);
+   procedure Analyze_Entry_Index_Specification          (N : Node_Id);
+   procedure Analyze_Protected_Body                     (N : Node_Id);
+   procedure Analyze_Protected_Definition               (N : Node_Id);
+   procedure Analyze_Protected_Type                     (N : Node_Id);
+   procedure Analyze_Requeue                            (N : Node_Id);
+   procedure Analyze_Selective_Accept                   (N : Node_Id);
+   procedure Analyze_Single_Protected                   (N : Node_Id);
+   procedure Analyze_Single_Task                        (N : Node_Id);
+   procedure Analyze_Task_Body                          (N : Node_Id);
+   procedure Analyze_Task_Definition                    (N : Node_Id);
+   procedure Analyze_Task_Type                          (N : Node_Id);
+   procedure Analyze_Terminate_Alternative              (N : Node_Id);
+   procedure Analyze_Timed_Entry_Call                   (N : Node_Id);
+   procedure Analyze_Triggering_Alternative             (N : Node_Id);
+end Sem_Ch9;
diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb
new file mode 100644
index 00000000000..31dae9026e9
--- /dev/null
+++ b/gcc/ada/sem_disp.adb
@@ -0,0 +1,992 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             S E M _ D I S P                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.114 $
+--                                                                          --
+--          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 Debug;    use Debug;
+with Elists;   use Elists;
+with Einfo;    use Einfo;
+with Exp_Disp; use Exp_Disp;
+with Errout;   use Errout;
+with Hostparm; use Hostparm;
+with Nlists;   use Nlists;
+with Output;   use Output;
+with Sem_Ch6;  use Sem_Ch6;
+with Sem_Eval; use Sem_Eval;
+with Sem_Util; use Sem_Util;
+with Sinfo;    use Sinfo;
+with Uintp;    use Uintp;
+
+package body Sem_Disp is
+
+   -----------------------
+   -- Local Subprograms --
+   -----------------------
+
+   procedure Override_Dispatching_Operation
+     (Tagged_Type : Entity_Id;
+      Prev_Op     : Entity_Id;
+      New_Op      : Entity_Id);
+   --  Replace an implicit dispatching operation with an  explicit one.
+   --  Prev_Op is an inherited primitive operation which is overridden
+   --  by the explicit declaration of New_Op.
+
+   procedure Add_Dispatching_Operation
+     (Tagged_Type : Entity_Id;
+      New_Op      : Entity_Id);
+   --  Add New_Op in the list of primitive operations of Tagged_Type
+
+   function Check_Controlling_Type
+     (T    : Entity_Id;
+      Subp : Entity_Id)
+      return Entity_Id;
+      --  T is the type of a formal parameter of subp. Returns the tagged
+      --  if the parameter can be a controlling argument, empty otherwise
+
+   --------------------------------
+   --  Add_Dispatching_Operation --
+   --------------------------------
+
+   procedure Add_Dispatching_Operation
+     (Tagged_Type : Entity_Id;
+      New_Op      : Entity_Id)
+   is
+      List : constant Elist_Id := Primitive_Operations (Tagged_Type);
+
+   begin
+      Append_Elmt (New_Op, List);
+   end Add_Dispatching_Operation;
+
+   -------------------------------
+   -- Check_Controlling_Formals --
+   -------------------------------
+
+   procedure Check_Controlling_Formals
+     (Typ  : Entity_Id;
+      Subp : Entity_Id)
+   is
+      Formal    : Entity_Id;
+      Ctrl_Type : Entity_Id;
+      Remote    : constant Boolean :=
+                    Is_Remote_Types (Current_Scope)
+                      and then Comes_From_Source (Subp)
+                      and then Scope (Typ) = Current_Scope;
+
+   begin
+      Formal := First_Formal (Subp);
+
+      while Present (Formal) loop
+         Ctrl_Type := Check_Controlling_Type (Etype (Formal), Subp);
+
+         if Present (Ctrl_Type) then
+            if Ctrl_Type = Typ then
+               Set_Is_Controlling_Formal (Formal);
+
+               --  Check that the parameter's nominal subtype statically
+               --  matches the first subtype.
+
+               if Ekind (Etype (Formal)) = E_Anonymous_Access_Type then
+                  if not Subtypes_Statically_Match
+                           (Typ, Designated_Type (Etype (Formal)))
+                  then
+                     Error_Msg_N
+                       ("parameter subtype does not match controlling type",
+                        Formal);
+                  end if;
+
+               elsif not Subtypes_Statically_Match (Typ, Etype (Formal)) then
+                  Error_Msg_N
+                    ("parameter subtype does not match controlling type",
+                     Formal);
+               end if;
+
+               if Present (Default_Value (Formal)) then
+                  if Ekind (Etype (Formal)) = E_Anonymous_Access_Type then
+                     Error_Msg_N
+                       ("default not allowed for controlling access parameter",
+                        Default_Value (Formal));
+
+                  elsif not Is_Tag_Indeterminate (Default_Value (Formal)) then
+                     Error_Msg_N
+                       ("default expression must be a tag indeterminate" &
+                        " function call", Default_Value (Formal));
+                  end if;
+               end if;
+
+            elsif Comes_From_Source (Subp) then
+               Error_Msg_N
+                 ("operation can be dispatching in only one type", Subp);
+            end if;
+
+         --  Verify that the restriction in E.2.2 (1) is obeyed.
+
+         elsif Remote
+           and then Ekind (Etype (Formal)) = E_Anonymous_Access_Type
+         then
+            Error_Msg_N
+              ("Access parameter of a remote subprogram must be controlling",
+                Formal);
+         end if;
+
+         Next_Formal (Formal);
+      end loop;
+
+      if Present (Etype (Subp)) then
+         Ctrl_Type := Check_Controlling_Type (Etype (Subp), Subp);
+
+         if Present (Ctrl_Type) then
+            if Ctrl_Type = Typ then
+               Set_Has_Controlling_Result (Subp);
+
+               --  Check that the result subtype statically matches
+               --  the first subtype.
+
+               if not Subtypes_Statically_Match (Typ, Etype (Subp)) then
+                  Error_Msg_N
+                    ("result subtype does not match controlling type", Subp);
+               end if;
+
+            elsif Comes_From_Source (Subp) then
+               Error_Msg_N
+                 ("operation can be dispatching in only one type", Subp);
+            end if;
+
+         --  The following check is clearly required, although the RM says
+         --  nothing about return types. If the return type is a limited
+         --  class-wide type declared in the current scope, there is no way
+         --  to declare stream procedures for it, so the return cannot be
+         --  marshalled.
+
+         elsif Remote
+           and then Is_Limited_Type (Typ)
+           and then Etype (Subp) = Class_Wide_Type (Typ)
+         then
+            Error_Msg_N ("return type has no stream attributes", Subp);
+         end if;
+      end if;
+   end Check_Controlling_Formals;
+
+   ----------------------------
+   -- Check_Controlling_Type --
+   ----------------------------
+
+   function Check_Controlling_Type
+     (T    : Entity_Id;
+      Subp : Entity_Id)
+      return Entity_Id
+   is
+      Tagged_Type : Entity_Id := Empty;
+
+   begin
+      if Is_Tagged_Type (T) then
+         if Is_First_Subtype (T) then
+            Tagged_Type := T;
+         else
+            Tagged_Type := Base_Type (T);
+         end if;
+
+      elsif Ekind (T) = E_Anonymous_Access_Type
+        and then Is_Tagged_Type (Designated_Type (T))
+        and then Ekind (Designated_Type (T)) /= E_Incomplete_Type
+      then
+         if Is_First_Subtype (Designated_Type (T)) then
+            Tagged_Type := Designated_Type (T);
+         else
+            Tagged_Type := Base_Type (Designated_Type (T));
+         end if;
+      end if;
+
+      if No (Tagged_Type)
+        or else Is_Class_Wide_Type (Tagged_Type)
+      then
+         return Empty;
+
+      --  The dispatching type and the primitive operation must be defined
+      --  in the same scope except for internal operations.
+
+      elsif (Scope (Subp) = Scope (Tagged_Type)
+              or else Is_Internal (Subp))
+        and then
+            (not Is_Generic_Type (Tagged_Type)
+              or else not Comes_From_Source (Subp))
+      then
+         return Tagged_Type;
+
+      else
+         return Empty;
+      end if;
+   end Check_Controlling_Type;
+
+   ----------------------------
+   -- Check_Dispatching_Call --
+   ----------------------------
+
+   procedure Check_Dispatching_Call (N : Node_Id) is
+      Actual  : Node_Id;
+      Control : Node_Id := Empty;
+      Func    : Entity_Id;
+
+      procedure Check_Dispatching_Context;
+      --  If the call is tag-indeterminate and the entity being called is
+      --  abstract, verify that the context is a call that will eventually
+      --  provide a tag for dispatching, or has provided one already.
+
+      -------------------------------
+      -- Check_Dispatching_Context --
+      -------------------------------
+
+      procedure Check_Dispatching_Context is
+         Func : constant Entity_Id := Entity (Name (N));
+         Par  : Node_Id;
+
+      begin
+         if Is_Abstract (Func)
+           and then No (Controlling_Argument (N))
+         then
+            Par := Parent (N);
+
+            while Present (Par) loop
+
+               if Nkind (Par) = N_Function_Call            or else
+                  Nkind (Par) = N_Procedure_Call_Statement or else
+                  Nkind (Par) = N_Assignment_Statement     or else
+                  Nkind (Par) = N_Op_Eq                    or else
+                  Nkind (Par) = N_Op_Ne
+               then
+                  return;
+
+               elsif Nkind (Par) = N_Qualified_Expression
+                 or else Nkind (Par) = N_Unchecked_Type_Conversion
+               then
+                  Par := Parent (Par);
+
+               else
+                  Error_Msg_N
+                    ("call to abstract function must be dispatching", N);
+                  return;
+               end if;
+            end loop;
+         end if;
+      end Check_Dispatching_Context;
+
+   --  Start of processing for Check_Dispatching_Call
+
+   begin
+      --  Find a controlling argument, if any
+
+      if Present (Parameter_Associations (N)) then
+         Actual := First_Actual (N);
+
+         while Present (Actual) loop
+            Control := Find_Controlling_Arg (Actual);
+            exit when Present (Control);
+            Next_Actual (Actual);
+         end loop;
+
+         if Present (Control) then
+
+            --  Verify that no controlling arguments are statically tagged
+
+            if Debug_Flag_E then
+               Write_Str ("Found Dispatching call");
+               Write_Int (Int (N));
+               Write_Eol;
+            end if;
+
+            Actual := First_Actual (N);
+
+            while Present (Actual) loop
+               if Actual /= Control then
+
+                  if not Is_Controlling_Actual (Actual) then
+                     null; -- can be anything
+
+                  elsif (Is_Dynamically_Tagged (Actual)) then
+                     null; --  valid parameter
+
+                  elsif Is_Tag_Indeterminate (Actual) then
+
+                     --  The tag is inherited from the enclosing call (the
+                     --  node we are currently analyzing). Explicitly expand
+                     --  the actual, since the previous call to Expand
+                     --  (from Resolve_Call) had no way of knowing about
+                     --  the required dispatching.
+
+                     Propagate_Tag (Control, Actual);
+
+                  else
+                     Error_Msg_N
+                       ("controlling argument is not dynamically tagged",
+                        Actual);
+                     return;
+                  end if;
+               end if;
+
+               Next_Actual (Actual);
+            end loop;
+
+            --  Mark call as a dispatching call
+
+            Set_Controlling_Argument (N, Control);
+
+         else
+            --  The call is not dispatching, check that there isn't any
+            --  tag indeterminate abstract call left
+
+            Actual := First_Actual (N);
+
+            while Present (Actual) loop
+               if Is_Tag_Indeterminate (Actual) then
+
+                  --  Function call case
+
+                  if Nkind (Original_Node (Actual)) = N_Function_Call then
+                     Func := Entity (Name (Original_Node (Actual)));
+
+                  --  Only other possibility is a qualified expression whose
+                  --  consituent expression is itself a call.
+
+                  else
+                     Func :=
+                       Entity (Name
+                         (Original_Node
+                           (Expression (Original_Node (Actual)))));
+                  end if;
+
+                  if Is_Abstract (Func) then
+                     Error_Msg_N (
+                       "call to abstract function must be dispatching", N);
+                  end if;
+               end if;
+
+               Next_Actual (Actual);
+            end loop;
+
+            Check_Dispatching_Context;
+         end if;
+
+      else
+         --  If dispatching on result, the enclosing call, if any, will
+         --  determine the controlling argument. Otherwise this is the
+         --  primitive operation of the root type.
+
+         Check_Dispatching_Context;
+      end if;
+   end Check_Dispatching_Call;
+
+   ---------------------------------
+   -- Check_Dispatching_Operation --
+   ---------------------------------
+
+   procedure Check_Dispatching_Operation (Subp, Old_Subp : Entity_Id) is
+      Tagged_Seen            : Entity_Id;
+      Has_Dispatching_Parent : Boolean := False;
+      Body_Is_Last_Primitive : Boolean := False;
+
+   begin
+      if Ekind (Subp) /= E_Procedure and then Ekind (Subp) /= E_Function then
+         return;
+      end if;
+
+      Set_Is_Dispatching_Operation (Subp, False);
+      Tagged_Seen := Find_Dispatching_Type (Subp);
+
+      --  If Subp is derived from a dispatching operation then it should
+      --  always be treated as dispatching. In this case various checks
+      --  below will be bypassed. Makes sure that late declarations for
+      --  inherited private subprograms are treated as dispatching, even
+      --  if the associated tagged type is already frozen.
+
+      Has_Dispatching_Parent := Present (Alias (Subp))
+        and then Is_Dispatching_Operation (Alias (Subp));
+
+      if No (Tagged_Seen) then
+         return;
+
+      --  The subprograms build internally after the freezing point (such as
+      --  the Init procedure) are not primitives
+
+      elsif Is_Frozen (Tagged_Seen)
+        and then not Comes_From_Source (Subp)
+        and then not Has_Dispatching_Parent
+      then
+         return;
+
+      --  The operation may be a child unit, whose scope is the defining
+      --  package, but which is not a primitive operation of the type.
+
+      elsif Is_Child_Unit (Subp) then
+         return;
+
+      --  If the subprogram is not defined in a package spec, the only case
+      --  where it can be a dispatching op is when it overrides an operation
+      --  before the freezing point of the type.
+
+      elsif ((not Is_Package (Scope (Subp)))
+              or else In_Package_Body (Scope (Subp)))
+        and then not Has_Dispatching_Parent
+      then
+         if not Comes_From_Source (Subp)
+           or else (Present (Old_Subp) and then not Is_Frozen (Tagged_Seen))
+         then
+            null;
+
+         --  If the type is already frozen, the overriding is not allowed
+         --  except when Old_Subp is not a dispatching operation (which
+         --  can occur when Old_Subp was inherited by an untagged type).
+         --  However, a body with no previous spec freezes the type "after"
+         --  its declaration, and therefore is a legal overriding (unless
+         --  the type has already been frozen). Only the first such body
+         --  is legal.
+
+         elsif Present (Old_Subp)
+           and then Is_Dispatching_Operation (Old_Subp)
+         then
+            if Nkind (Unit_Declaration_Node (Subp)) = N_Subprogram_Body
+              and then Comes_From_Source (Subp)
+            then
+               declare
+                  Subp_Body : constant Node_Id := Unit_Declaration_Node (Subp);
+                  Decl_Item : Node_Id := Next (Parent (Tagged_Seen));
+
+               begin
+                  --  ??? The checks here for whether the type has been
+                  --  frozen prior to the new body are not complete. It's
+                  --  not simple to check frozenness at this point since
+                  --  the body has already caused the type to be prematurely
+                  --  frozen in Analyze_Declarations, but we're forced to
+                  --  recheck this here because of the odd rule interpretation
+                  --  that allows the overriding if the type wasn't frozen
+                  --  prior to the body. The freezing action should probably
+                  --  be delayed until after the spec is seen, but that's
+                  --  a tricky change to the delicate freezing code.
+
+                  --  Look at each declaration following the type up
+                  --  until the new subprogram body. If any of the
+                  --  declarations is a body then the type has been
+                  --  frozen already so the overriding primitive is
+                  --  illegal.
+
+                  while Present (Decl_Item)
+                    and then (Decl_Item /= Subp_Body)
+                  loop
+                     if Comes_From_Source (Decl_Item)
+                       and then (Nkind (Decl_Item) in N_Proper_Body
+                                  or else Nkind (Decl_Item) in N_Body_Stub)
+                     then
+                        Error_Msg_N ("overriding of& is too late!", Subp);
+                        Error_Msg_N
+                          ("\spec should appear immediately after the type!",
+                           Subp);
+                        exit;
+                     end if;
+
+                     Next (Decl_Item);
+                  end loop;
+
+                  --  If the subprogram doesn't follow in the list of
+                  --  declarations including the type then the type
+                  --  has definitely been frozen already and the body
+                  --  is illegal.
+
+                  if not Present (Decl_Item) then
+                     Error_Msg_N ("overriding of& is too late!", Subp);
+                     Error_Msg_N
+                       ("\spec should appear immediately after the type!",
+                        Subp);
+
+                  elsif Is_Frozen (Subp) then
+
+                     --  the subprogram body declares a primitive operation.
+                     --  if the subprogram is already frozen, we must update
+                     --  its dispatching information explicitly here. The
+                     --  information is taken from the overridden subprogram.
+
+                     Body_Is_Last_Primitive := True;
+
+                     if Present (DTC_Entity (Old_Subp)) then
+                        Set_DTC_Entity (Subp, DTC_Entity (Old_Subp));
+                        Set_DT_Position (Subp, DT_Position (Old_Subp));
+                        Insert_After (
+                          Subp_Body, Fill_DT_Entry (Sloc (Subp_Body), Subp));
+                     end if;
+                  end if;
+               end;
+
+            else
+               Error_Msg_N ("overriding of& is too late!", Subp);
+               Error_Msg_N
+                 ("\subprogram spec should appear immediately after the type!",
+                  Subp);
+            end if;
+
+         --  If the type is not frozen yet and we are not in the overridding
+         --  case it looks suspiciously like an attempt to define a primitive
+         --  operation.
+
+         elsif not Is_Frozen (Tagged_Seen) then
+            Error_Msg_N
+              ("?not dispatching (must be defined in a package spec)", Subp);
+            return;
+
+         --  When the type is frozen, it is legitimate to define a new
+         --  non-primitive operation.
+
+         else
+            return;
+         end if;
+
+      --  Now, we are sure that the scope is a package spec. If the subprogram
+      --  is declared after the freezing point ot the type that's an error
+
+      elsif Is_Frozen (Tagged_Seen) and then not Has_Dispatching_Parent then
+         Error_Msg_N ("this primitive operation is declared too late", Subp);
+         Error_Msg_NE
+           ("?no primitive operations for& after this line",
+            Freeze_Node (Tagged_Seen),
+            Tagged_Seen);
+         return;
+      end if;
+
+      Check_Controlling_Formals (Tagged_Seen, Subp);
+
+      --  Now it should be a correct primitive operation, put it in the list
+
+      if Present (Old_Subp) then
+         Check_Subtype_Conformant (Subp, Old_Subp);
+         Override_Dispatching_Operation (Tagged_Seen, Old_Subp, Subp);
+
+      else
+         Add_Dispatching_Operation (Tagged_Seen, Subp);
+      end if;
+
+      Set_Is_Dispatching_Operation (Subp, True);
+
+      if not Body_Is_Last_Primitive then
+         Set_DT_Position (Subp, No_Uint);
+      end if;
+
+   end Check_Dispatching_Operation;
+
+   ------------------------------------------
+   -- Check_Operation_From_Incomplete_Type --
+   ------------------------------------------
+
+   procedure Check_Operation_From_Incomplete_Type
+     (Subp : Entity_Id;
+      Typ  : Entity_Id)
+   is
+      Full       : constant Entity_Id := Full_View (Typ);
+      Parent_Typ : constant Entity_Id := Etype (Full);
+      Old_Prim   : constant Elist_Id  := Primitive_Operations (Parent_Typ);
+      New_Prim   : constant Elist_Id  := Primitive_Operations (Full);
+      Op1, Op2   : Elmt_Id;
+      Prev       : Elmt_Id := No_Elmt;
+
+      function Derives_From (Proc : Entity_Id) return Boolean;
+      --  Check that Subp has the signature of an operation derived from Proc.
+      --  Subp has an access parameter that designates Typ.
+
+      ------------------
+      -- Derives_From --
+      ------------------
+
+      function Derives_From (Proc : Entity_Id) return Boolean is
+         F1, F2 : Entity_Id;
+
+      begin
+         if Chars (Proc) /= Chars (Subp) then
+            return False;
+         end if;
+
+         F1 := First_Formal (Proc);
+         F2 := First_Formal (Subp);
+
+         while Present (F1) and then Present (F2) loop
+
+            if Ekind (Etype (F1)) = E_Anonymous_Access_Type then
+
+               if Ekind (Etype (F2)) /= E_Anonymous_Access_Type then
+                  return False;
+
+               elsif Designated_Type (Etype (F1)) = Parent_Typ
+                 and then Designated_Type (Etype (F2)) /= Full
+               then
+                  return False;
+               end if;
+
+            elsif Ekind (Etype (F2)) = E_Anonymous_Access_Type then
+               return False;
+
+            elsif Etype (F1) /= Etype (F2) then
+               return False;
+            end if;
+
+            Next_Formal (F1);
+            Next_Formal (F2);
+         end loop;
+
+         return No (F1) and then No (F2);
+      end Derives_From;
+
+   --  Start of processing for Check_Operation_From_Incomplete_Type
+
+   begin
+      --  The operation may override an inherited one, or may be a new one
+      --  altogether. The inherited operation will have been hidden by the
+      --  current one at the point of the type derivation, so it does not
+      --  appear in the list of primitive operations of the type. We have to
+      --  find the proper place of insertion in the list of primitive opera-
+      --  tions by iterating over the list for the parent type.
+
+      Op1 := First_Elmt (Old_Prim);
+      Op2 := First_Elmt (New_Prim);
+
+      while Present (Op1) and then Present (Op2) loop
+
+         if Derives_From (Node (Op1)) then
+
+            if No (Prev) then
+               Prepend_Elmt (Subp, New_Prim);
+            else
+               Insert_Elmt_After (Subp, Prev);
+            end if;
+
+            return;
+         end if;
+
+         Prev := Op2;
+         Next_Elmt (Op1);
+         Next_Elmt (Op2);
+      end loop;
+
+      --  Operation is a new primitive.
+
+      Append_Elmt (Subp, New_Prim);
+
+   end Check_Operation_From_Incomplete_Type;
+
+   ---------------------------------------
+   -- Check_Operation_From_Private_View --
+   ---------------------------------------
+
+   procedure Check_Operation_From_Private_View (Subp, Old_Subp : Entity_Id) is
+      Tagged_Type : Entity_Id;
+
+   begin
+      if Is_Dispatching_Operation (Alias (Subp)) then
+         Set_Scope (Subp, Current_Scope);
+         Tagged_Type := Find_Dispatching_Type (Subp);
+
+         if Present (Tagged_Type) and then Is_Tagged_Type (Tagged_Type) then
+            Append_Elmt (Old_Subp, Primitive_Operations (Tagged_Type));
+
+            --  If Old_Subp isn't already marked as dispatching then
+            --  this is the case of an operation of an untagged private
+            --  type fulfilled by a tagged type that overrides an
+            --  inherited dispatching operation, so we set the necessary
+            --  dispatching attributes here.
+
+            if not Is_Dispatching_Operation (Old_Subp) then
+               Check_Controlling_Formals (Tagged_Type, Old_Subp);
+               Set_Is_Dispatching_Operation (Old_Subp, True);
+               Set_DT_Position (Old_Subp, No_Uint);
+            end if;
+
+            --  If the old subprogram is an explicit renaming of some other
+            --  entity, it is not overridden by the inherited subprogram.
+            --  Otherwise, update its alias and other attributes.
+
+            if Present (Alias (Old_Subp))
+              and then Nkind (Unit_Declaration_Node (Old_Subp))
+                /= N_Subprogram_Renaming_Declaration
+            then
+               Set_Alias (Old_Subp, Alias (Subp));
+
+               --  The derived subprogram should inherit the abstractness
+               --  of the parent subprogram (except in the case of a function
+               --  returning the type). This sets the abstractness properly
+               --  for cases where a private extension may have inherited
+               --  an abstract operation, but the full type is derived from
+               --  a descendant type and inherits a nonabstract version.
+
+               if Etype (Subp) /= Tagged_Type then
+                  Set_Is_Abstract (Old_Subp, Is_Abstract (Alias (Subp)));
+               end if;
+            end if;
+         end if;
+      end if;
+   end Check_Operation_From_Private_View;
+
+   --------------------------
+   -- Find_Controlling_Arg --
+   --------------------------
+
+   function Find_Controlling_Arg (N : Node_Id) return Node_Id is
+      Orig_Node : constant Node_Id := Original_Node (N);
+      Typ       : Entity_Id;
+
+   begin
+      if Nkind (Orig_Node) = N_Qualified_Expression then
+         return Find_Controlling_Arg (Expression (Orig_Node));
+      end if;
+
+      --  Dispatching on result case
+
+      if Nkind (Orig_Node) = N_Function_Call
+        and then Present (Controlling_Argument (Orig_Node))
+        and then Has_Controlling_Result (Entity (Name (Orig_Node)))
+      then
+         return Controlling_Argument (Orig_Node);
+
+      --  Normal case
+
+      elsif Is_Controlling_Actual (N) then
+         Typ := Etype (N);
+
+         if Is_Access_Type (Typ) then
+            --  In the case of an Access attribute, use the type of
+            --  the prefix, since in the case of an actual for an
+            --  access parameter, the attribute's type may be of a
+            --  specific designated type, even though the prefix
+            --  type is class-wide.
+
+            if Nkind (N) = N_Attribute_Reference then
+               Typ := Etype (Prefix (N));
+            else
+               Typ := Designated_Type (Typ);
+            end if;
+         end if;
+
+         if Is_Class_Wide_Type (Typ) then
+            return N;
+         end if;
+      end if;
+
+      return Empty;
+   end Find_Controlling_Arg;
+
+   ---------------------------
+   -- Find_Dispatching_Type --
+   ---------------------------
+
+   function Find_Dispatching_Type (Subp : Entity_Id) return Entity_Id is
+      Formal    : Entity_Id;
+      Ctrl_Type : Entity_Id;
+
+   begin
+      if Present (DTC_Entity (Subp)) then
+         return Scope (DTC_Entity (Subp));
+
+      else
+         Formal := First_Formal (Subp);
+         while Present (Formal) loop
+            Ctrl_Type := Check_Controlling_Type (Etype (Formal), Subp);
+
+            if Present (Ctrl_Type) then
+               return Ctrl_Type;
+            end if;
+
+            Next_Formal (Formal);
+         end loop;
+
+      --  The subprogram may also be dispatching on result
+
+         if Present (Etype (Subp)) then
+            Ctrl_Type := Check_Controlling_Type (Etype (Subp), Subp);
+
+            if Present (Ctrl_Type) then
+               return Ctrl_Type;
+            end if;
+         end if;
+      end if;
+
+      return Empty;
+   end Find_Dispatching_Type;
+
+   ---------------------------
+   -- Is_Dynamically_Tagged --
+   ---------------------------
+
+   function Is_Dynamically_Tagged (N : Node_Id) return Boolean is
+   begin
+      return Find_Controlling_Arg (N) /= Empty;
+   end Is_Dynamically_Tagged;
+
+   --------------------------
+   -- Is_Tag_Indeterminate --
+   --------------------------
+
+   function Is_Tag_Indeterminate (N : Node_Id) return Boolean is
+      Nam       : Entity_Id;
+      Actual    : Node_Id;
+      Orig_Node : constant Node_Id := Original_Node (N);
+
+   begin
+      if Nkind (Orig_Node) = N_Function_Call
+        and then Is_Entity_Name (Name (Orig_Node))
+      then
+         Nam := Entity (Name (Orig_Node));
+
+         if not Has_Controlling_Result (Nam) then
+            return False;
+
+         --  If there are no actuals, the call is tag-indeterminate
+
+         elsif No (Parameter_Associations (Orig_Node)) then
+            return True;
+
+         else
+            Actual := First_Actual (Orig_Node);
+
+            while Present (Actual) loop
+               if Is_Controlling_Actual (Actual)
+                 and then not Is_Tag_Indeterminate (Actual)
+               then
+                  return False; -- one operand is dispatching
+               end if;
+
+               Next_Actual (Actual);
+            end loop;
+
+            return True;
+
+         end if;
+
+      elsif Nkind (Orig_Node) = N_Qualified_Expression then
+         return Is_Tag_Indeterminate (Expression (Orig_Node));
+
+      else
+         return False;
+      end if;
+   end Is_Tag_Indeterminate;
+
+   ------------------------------------
+   -- Override_Dispatching_Operation --
+   ------------------------------------
+
+   procedure Override_Dispatching_Operation
+     (Tagged_Type : Entity_Id;
+      Prev_Op     : Entity_Id;
+      New_Op      : Entity_Id)
+   is
+      Op_Elmt   : Elmt_Id := First_Elmt (Primitive_Operations (Tagged_Type));
+
+   begin
+      --  Patch the primitive operation list
+
+      while Present (Op_Elmt)
+        and then Node (Op_Elmt) /= Prev_Op
+      loop
+         Next_Elmt (Op_Elmt);
+      end loop;
+
+      --  If there is no previous operation to override, the type declaration
+      --  was malformed, and an error must have been emitted already.
+
+      if No (Op_Elmt) then
+         return;
+      end if;
+
+      Replace_Elmt (Op_Elmt, New_Op);
+
+      if (not Is_Package (Current_Scope))
+        or else not In_Private_Part (Current_Scope)
+      then
+         --  Not a private primitive
+
+         null;
+
+      else pragma Assert (Is_Inherited_Operation (Prev_Op));
+
+         --  Make the overriding operation into an alias of the implicit one.
+         --  In this fashion a call from outside ends up calling the new
+         --  body even if non-dispatching, and a call from inside calls the
+         --  overriding operation because it hides the implicit one.
+         --  To indicate that the body of Prev_Op is never called, set its
+         --  dispatch table entity to Empty.
+
+         Set_Alias (Prev_Op, New_Op);
+         Set_DTC_Entity (Prev_Op, Empty);
+         return;
+      end if;
+   end Override_Dispatching_Operation;
+
+   -------------------
+   -- Propagate_Tag --
+   -------------------
+
+   procedure Propagate_Tag (Control : Node_Id; Actual : Node_Id) is
+      Call_Node : Node_Id;
+      Arg       : Node_Id;
+
+   begin
+      if Nkind (Actual) = N_Function_Call then
+         Call_Node := Actual;
+
+      elsif Nkind (Actual) = N_Identifier
+        and then Nkind (Original_Node (Actual)) = N_Function_Call
+      then
+         --  Call rewritten as object declaration when stack-checking
+         --  is enabled. Propagate tag to expression in declaration, which
+         --  is original call.
+
+         Call_Node := Expression (Parent (Entity (Actual)));
+
+      --  Only other possibility is parenthesized or qualified expression
+
+      else
+         Call_Node := Expression (Actual);
+      end if;
+
+      --  Do not set the Controlling_Argument if already set. This happens
+      --  in the special case of _Input (see Exp_Attr, case Input).
+
+      if No (Controlling_Argument (Call_Node)) then
+         Set_Controlling_Argument (Call_Node, Control);
+      end if;
+
+      Arg := First_Actual (Call_Node);
+
+      while Present (Arg) loop
+         if Is_Tag_Indeterminate (Arg) then
+            Propagate_Tag (Control,  Arg);
+         end if;
+
+         Next_Actual (Arg);
+      end loop;
+
+      --  Expansion of dispatching calls is suppressed when Java_VM, because
+      --  the JVM back end directly handles the generation of dispatching
+      --  calls and would have to undo any expansion to an indirect call.
+
+      if not Java_VM then
+         Expand_Dispatch_Call (Call_Node);
+      end if;
+   end Propagate_Tag;
+
+end Sem_Disp;
diff --git a/gcc/ada/sem_disp.ads b/gcc/ada/sem_disp.ads
new file mode 100644
index 00000000000..75f415800de
--- /dev/null
+++ b/gcc/ada/sem_disp.ads
@@ -0,0 +1,91 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             S E M _ D I S P                              --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.16 $                             --
+--                                                                          --
+--          Copyright (C) 1992-1999 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 contains routines involved in tagged types and dynamic
+--  dispatching.
+
+with Types; use Types;
+package Sem_Disp is
+
+   procedure Check_Controlling_Formals (Typ : Entity_Id; Subp : Entity_Id);
+   --  Check that all controlling parameters of Subp are of type Typ,
+   --  that defaults for controlling parameters are tag-indeterminate,
+   --  and that the nominal subtype of the parameters and result
+   --  statically match the first subtype of the controlling type.
+
+   procedure Check_Dispatching_Call (N : Node_Id);
+   --  Check if a call is a dispatching call. The subprogram is known to
+   --  be a dispatching operation. The call is dispatching if all the
+   --  controlling actuals are dynamically tagged. This procedure is called
+   --  after overload resolution, so the call is known to be unambiguous.
+
+   procedure Check_Dispatching_Operation (Subp, Old_Subp : Entity_Id);
+   --  Add "Subp" to the list of primitive operations of the corresponding type
+   --  if it has a parameter of this type and is defined at a proper place for
+   --  primitive operations. (new primitives are only defined in package spec,
+   --  overridden operation can be defined in any scope). If Old_Subp is not
+   --  Empty we are in the overriding case.
+
+   procedure Check_Operation_From_Incomplete_Type
+     (Subp : Entity_Id;
+      Typ  : Entity_Id);
+   --  If a primitive operation was defined for the incomplete view of the
+   --  type, and the full type declaration is a derived type definition,
+   --  the operation may override an inherited one.
+
+   procedure Check_Operation_From_Private_View (Subp, Old_Subp : Entity_Id);
+   --  Add "Old_Subp" to the list of primitive operations of the corresponding
+   --  tagged type if it is the full view of a private tagged type. The Alias
+   --  of "OldSubp" is adjusted to point to the inherited procedure of the
+   --  full view because it is always this one which has to be called.
+
+   function Find_Controlling_Arg (N : Node_Id) return Node_Id;
+   --  Returns the actual controlling argument if N is dynamically tagged,
+   --  and Empty if it is not dynamically tagged.
+
+   function Find_Dispatching_Type (Subp : Entity_Id) return Entity_Id;
+   --  Check whether a subprogram is dispatching, and find the tagged
+   --  type of the controlling argument or arguments.
+
+   function Is_Dynamically_Tagged (N : Node_Id) return Boolean;
+   --  Used to determine whether a call is dispatching, i.e. if is an
+   --  an expression of a class_Wide type, or a call to a function with
+   --  controlling result where at least one operand is dynamically tagged.
+
+   function Is_Tag_Indeterminate (N : Node_Id) return Boolean;
+   --  An expression is tag-indeterminate if it is a call that dispatches
+   --  on result, and all controlling operands are also indeterminate.
+   --  Such a function call may inherit a tag from an enclosing call.
+
+   procedure Propagate_Tag (Control : Node_Id; Actual : Node_Id);
+   --  If a function call is tag-indeterminate,  its controlling argument is
+   --  found in the context;  either an enclosing call, or the left-hand side
+   --  of the enclosing assignment statement. The tag must be propagated
+   --  recursively to the tag-indeterminate actuals of the call.
+
+end Sem_Disp;
diff --git a/gcc/ada/sem_dist.adb b/gcc/ada/sem_dist.adb
new file mode 100644
index 00000000000..f2b5c6c6bfa
--- /dev/null
+++ b/gcc/ada/sem_dist.adb
@@ -0,0 +1,686 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             S E M _ D I S T                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.182 $
+--                                                                          --
+--          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 Einfo;    use Einfo;
+with Errout;   use Errout;
+with Exp_Dist; use Exp_Dist;
+with Exp_Tss;  use Exp_Tss;
+with Nlists;   use Nlists;
+with Nmake;    use Nmake;
+with Namet;    use Namet;
+with Opt;      use Opt;
+with Rtsfind;  use Rtsfind;
+with Sem;      use Sem;
+with Sem_Res;  use Sem_Res;
+with Sem_Util; use Sem_Util;
+with Sinfo;    use Sinfo;
+with Snames;   use Snames;
+with Stand;    use Stand;
+with Stringt;  use Stringt;
+with Tbuild;   use Tbuild;
+with Uname;    use Uname;
+
+package body Sem_Dist is
+
+   -----------------------
+   -- Local Subprograms --
+   -----------------------
+
+   procedure RAS_E_Dereference (Pref : Node_Id);
+   --  Handles explicit dereference of Remote Access to Subprograms.
+
+   function Full_Qualified_Name (E : Entity_Id) return String_Id;
+   --  returns the full qualified name of the entity in lower case.
+
+   -------------------------
+   -- Add_Stub_Constructs --
+   -------------------------
+
+   procedure Add_Stub_Constructs (N : Node_Id) is
+      U    : constant Node_Id := Unit (N);
+      Spec : Entity_Id        := Empty;
+      Exp  : Node_Id          := U;         --  Unit that will be expanded
+
+   begin
+      pragma Assert (Distribution_Stub_Mode /= No_Stubs);
+
+      if Nkind (U) = N_Package_Declaration then
+         Spec := Defining_Entity (Specification (U));
+
+      elsif Nkind (U) = N_Package_Body then
+         Spec := Corresponding_Spec (U);
+
+      else pragma Assert (Nkind (U) = N_Package_Instantiation);
+         Exp  := Instance_Spec (U);
+         Spec := Defining_Entity (Specification (Exp));
+      end if;
+
+      pragma Assert (Is_Shared_Passive (Spec)
+        or else Is_Remote_Call_Interface (Spec));
+
+      if Distribution_Stub_Mode = Generate_Caller_Stub_Body then
+
+         if Is_Shared_Passive (Spec) then
+            null;
+         elsif Nkind (U) = N_Package_Body then
+            Error_Msg_N
+              ("Specification file expected from command line", U);
+         else
+            Expand_Calling_Stubs_Bodies (Exp);
+         end if;
+
+      else
+
+         if Is_Shared_Passive (Spec) then
+            Build_Passive_Partition_Stub (Exp);
+         else
+            Expand_Receiving_Stubs_Bodies (Exp);
+         end if;
+
+      end if;
+   end Add_Stub_Constructs;
+
+   -------------------------
+   -- Full_Qualified_Name --
+   -------------------------
+
+   function Full_Qualified_Name (E : Entity_Id) return String_Id is
+      Ent         : Entity_Id := E;
+      Parent_Name : String_Id := No_String;
+
+   begin
+      --  Deals properly with child units
+
+      if Nkind (Ent) = N_Defining_Program_Unit_Name then
+         Ent := Defining_Identifier (Ent);
+      end if;
+
+      --  Compute recursively the qualification. Only "Standard" has no scope.
+
+      if Present (Scope (Scope (Ent))) then
+         Parent_Name := Full_Qualified_Name (Scope (Ent));
+      end if;
+
+      --  Every entity should have a name except some expanded blocks
+      --  don't bother about those.
+
+      if Chars (Ent) = No_Name then
+         return Parent_Name;
+      end if;
+
+      --  Add a period between Name and qualification
+
+      if Parent_Name /= No_String then
+         Start_String (Parent_Name);
+         Store_String_Char (Get_Char_Code ('.'));
+
+      else
+         Start_String;
+      end if;
+
+      --  Generates the entity name in upper case
+
+      Get_Name_String (Chars (Ent));
+      Set_Casing (All_Lower_Case);
+      Store_String_Chars (Name_Buffer (1 .. Name_Len));
+      return End_String;
+   end Full_Qualified_Name;
+
+   -----------------------
+   -- Get_Subprogram_Id --
+   -----------------------
+
+   function Get_Subprogram_Id (E : Entity_Id) return Int is
+      Current_Declaration : Node_Id;
+      Result              : Int := 0;
+
+   begin
+      pragma Assert
+        (Is_Remote_Call_Interface (Scope (E))
+           and then
+             (Nkind (Parent (E)) = N_Procedure_Specification
+                or else
+              Nkind (Parent (E)) = N_Function_Specification));
+
+      Current_Declaration :=
+        First (Visible_Declarations
+          (Package_Specification_Of_Scope (Scope (E))));
+
+      while Current_Declaration /= Empty loop
+         if Nkind (Current_Declaration) = N_Subprogram_Declaration
+           and then Comes_From_Source (Current_Declaration)
+         then
+            if Defining_Unit_Name
+                 (Specification (Current_Declaration)) = E
+            then
+               return Result;
+            end if;
+
+            Result := Result + 1;
+         end if;
+
+         Next (Current_Declaration);
+      end loop;
+
+      --  Error if we do not find it
+
+      raise Program_Error;
+   end Get_Subprogram_Id;
+
+   ------------------------
+   -- Is_All_Remote_Call --
+   ------------------------
+
+   function Is_All_Remote_Call (N : Node_Id) return Boolean is
+      Par : Node_Id;
+
+   begin
+      if (Nkind (N) = N_Function_Call
+              or else Nkind (N) = N_Procedure_Call_Statement)
+        and then Nkind (Name (N)) in N_Has_Entity
+        and then Is_Remote_Call_Interface (Entity (Name (N)))
+        and then Has_All_Calls_Remote (Scope (Entity (Name (N))))
+        and then Comes_From_Source (N)
+      then
+         Par := Parent (Entity (Name (N)));
+
+         while Present (Par)
+           and then (Nkind (Par) /= N_Package_Specification
+                       or else Is_Wrapper_Package (Defining_Entity (Par)))
+         loop
+            Par := Parent (Par);
+         end loop;
+
+         if Present (Par) then
+            return
+              not Scope_Within_Or_Same (Current_Scope, Defining_Entity (Par));
+         else
+            return False;
+         end if;
+      else
+         return False;
+      end if;
+   end Is_All_Remote_Call;
+
+   ------------------------------------
+   -- Package_Specification_Of_Scope --
+   ------------------------------------
+
+   function Package_Specification_Of_Scope (E : Entity_Id) return Node_Id is
+      N : Node_Id := Parent (E);
+   begin
+      while Nkind (N) /= N_Package_Specification loop
+         N := Parent (N);
+      end loop;
+
+      return N;
+   end Package_Specification_Of_Scope;
+
+   --------------------------
+   -- Process_Partition_ID --
+   --------------------------
+
+   procedure Process_Partition_Id (N : Node_Id) is
+      Loc            : constant Source_Ptr := Sloc (N);
+      Ety            : Entity_Id;
+      Nd             : Node_Id;
+      Get_Pt_Id      : Node_Id;
+      Get_Pt_Id_Call : Node_Id;
+      Prefix_String  : String_Id;
+      Typ            : constant Entity_Id := Etype (N);
+
+   begin
+      Ety := Entity (Prefix (N));
+
+      --  In case prefix is not a library unit entity, get the entity
+      --  of library unit.
+
+      while (Present (Scope (Ety))
+        and then Scope (Ety) /= Standard_Standard)
+        and not Is_Child_Unit (Ety)
+      loop
+         Ety := Scope (Ety);
+      end loop;
+
+      Nd := Enclosing_Lib_Unit_Node (N);
+
+      --  Retrieve the proper function to call.
+
+      if Is_Remote_Call_Interface (Ety) then
+         Get_Pt_Id := New_Occurrence_Of
+           (RTE (RE_Get_Active_Partition_Id), Loc);
+
+      elsif Is_Shared_Passive (Ety) then
+         Get_Pt_Id := New_Occurrence_Of
+           (RTE (RE_Get_Passive_Partition_Id), Loc);
+
+      else
+         Get_Pt_Id := New_Occurrence_Of
+           (RTE (RE_Get_Local_Partition_Id), Loc);
+      end if;
+
+      --  Get and store the String_Id corresponding to the name of the
+      --  library unit whose Partition_Id is needed
+
+      Get_Unit_Name_String (Get_Unit_Name (Unit_Declaration_Node (Ety)));
+
+      --  Remove seven last character ("(spec)" or " (body)").
+      --  (this is a bit nasty, should have interface for this ???)
+
+      Name_Len := Name_Len - 7;
+
+      Start_String;
+      Store_String_Chars (Name_Buffer (1 .. Name_Len));
+      Prefix_String := End_String;
+
+      --  Build the function call which will replace the attribute
+
+      if Is_Remote_Call_Interface (Ety)
+        or else Is_Shared_Passive (Ety)
+      then
+         Get_Pt_Id_Call :=
+           Make_Function_Call (Loc,
+             Name => Get_Pt_Id,
+             Parameter_Associations =>
+               New_List (Make_String_Literal (Loc, Prefix_String)));
+
+      else
+         Get_Pt_Id_Call := Make_Function_Call (Loc, Get_Pt_Id);
+
+      end if;
+
+      --  Replace the attribute node by a conversion of the function call
+      --  to the target type.
+
+      Rewrite (N, Convert_To (Typ, Get_Pt_Id_Call));
+      Analyze_And_Resolve (N, Typ);
+
+   end Process_Partition_Id;
+
+   ----------------------------------
+   -- Process_Remote_AST_Attribute --
+   ----------------------------------
+
+   procedure Process_Remote_AST_Attribute
+     (N        : Node_Id;
+      New_Type : Entity_Id)
+   is
+      Loc                   : constant Source_Ptr := Sloc (N);
+      Remote_Subp           : Entity_Id;
+      Tick_Access_Conv_Call : Node_Id;
+      Remote_Subp_Decl      : Node_Id;
+      RAS_Decl              : Node_Id;
+      RS_Pkg_Specif         : Node_Id;
+      RS_Pkg_E              : Entity_Id;
+      RAS_Pkg_E             : Entity_Id;
+      RAS_Type              : Entity_Id;
+      RAS_Name              : Name_Id;
+      Async_E               : Entity_Id;
+      Subp_Id               : Int;
+      Attribute_Subp        : Entity_Id;
+      Parameter             : Node_Id;
+
+   begin
+      --  Check if we have to expand the access attribute
+
+      Remote_Subp := Entity (Prefix (N));
+
+      if not Expander_Active then
+         return;
+
+      elsif Ekind (New_Type) = E_Record_Type then
+         RAS_Type := New_Type;
+
+      else
+         --  If the remote type has not been constructed yet, create
+         --  it and its attributes now.
+
+         Attribute_Subp := TSS (New_Type, Name_uRAS_Access);
+
+         if No (Attribute_Subp) then
+            Add_RAST_Features (Parent (New_Type));
+         end if;
+
+         RAS_Type := Equivalent_Type (New_Type);
+      end if;
+
+      RAS_Name  := Chars (RAS_Type);
+      RAS_Decl := Parent (RAS_Type);
+      Attribute_Subp := TSS (RAS_Type, Name_uRAS_Access);
+
+      RAS_Pkg_E  := Defining_Entity (Parent (RAS_Decl));
+      Remote_Subp_Decl := Unit_Declaration_Node (Remote_Subp);
+
+      if Nkind (Remote_Subp_Decl) = N_Subprogram_Body then
+         Remote_Subp := Corresponding_Spec (Remote_Subp_Decl);
+         Remote_Subp_Decl := Unit_Declaration_Node (Remote_Subp);
+      end if;
+
+      RS_Pkg_Specif := Parent (Remote_Subp_Decl);
+      RS_Pkg_E := Defining_Entity (RS_Pkg_Specif);
+
+      Subp_Id := Get_Subprogram_Id (Remote_Subp);
+
+      if Ekind (Remote_Subp) = E_Procedure
+        and then Is_Asynchronous (Remote_Subp)
+      then
+         Async_E := Standard_True;
+      else
+         Async_E := Standard_False;
+      end if;
+
+      --  Right now, we do not call the Name_uAddress_Resolver subprogram,
+      --  which means that we end up with a Null_Address value in the ras
+      --  field: each dereference of an RAS will go through the PCS, which
+      --  is authorized but potentially not very efficient ???
+
+      Parameter := New_Occurrence_Of (RTE (RE_Null_Address), Loc);
+
+      Tick_Access_Conv_Call :=
+        Make_Function_Call (Loc,
+          Name => New_Occurrence_Of (Attribute_Subp, Loc),
+          Parameter_Associations =>
+            New_List (
+              Parameter,
+              Make_String_Literal (Loc, Full_Qualified_Name (RS_Pkg_E)),
+              Make_Integer_Literal (Loc, Subp_Id),
+              New_Occurrence_Of (Async_E, Loc)));
+
+      Rewrite (N, Tick_Access_Conv_Call);
+      Analyze_And_Resolve (N, RAS_Type);
+
+   end Process_Remote_AST_Attribute;
+
+   ------------------------------------
+   -- Process_Remote_AST_Declaration --
+   ------------------------------------
+
+   procedure Process_Remote_AST_Declaration (N : Node_Id) is
+      Loc           : constant Source_Ptr := Sloc (N);
+      User_Type     : constant Node_Id := Defining_Identifier (N);
+      Fat_Type      : constant Entity_Id :=
+                        Make_Defining_Identifier
+                          (Loc, Chars (User_Type));
+      New_Type_Decl : Node_Id;
+
+   begin
+      --  We add a record type declaration for the equivalent fat pointer type
+
+      New_Type_Decl :=
+        Make_Full_Type_Declaration (Loc,
+          Defining_Identifier => Fat_Type,
+          Type_Definition =>
+            Make_Record_Definition (Loc,
+              Component_List =>
+                Make_Component_List (Loc,
+                  Component_Items => New_List (
+
+                    Make_Component_Declaration (Loc,
+                      Defining_Identifier =>
+                        Make_Defining_Identifier (Loc,
+                          Chars => Name_Ras),
+                      Subtype_Indication =>
+                        New_Occurrence_Of
+                          (RTE (RE_Unsigned_64), Loc)),
+
+                    Make_Component_Declaration (Loc,
+                      Defining_Identifier =>
+                        Make_Defining_Identifier (Loc,
+                          Chars => Name_Origin),
+                      Subtype_Indication =>
+                        New_Reference_To
+                          (Standard_Integer,
+                           Loc)),
+
+                    Make_Component_Declaration (Loc,
+                      Defining_Identifier =>
+                        Make_Defining_Identifier (Loc,
+                          Chars => Name_Receiver),
+                      Subtype_Indication =>
+                        New_Reference_To
+                          (RTE (RE_Unsigned_64), Loc)),
+
+                    Make_Component_Declaration (Loc,
+                      Defining_Identifier =>
+                        Make_Defining_Identifier (Loc,
+                          Chars => Name_Subp_Id),
+                      Subtype_Indication =>
+                        New_Reference_To
+                          (Standard_Natural,
+                           Loc)),
+
+                    Make_Component_Declaration (Loc,
+                      Defining_Identifier =>
+                        Make_Defining_Identifier (Loc,
+                          Chars => Name_Async),
+                      Subtype_Indication =>
+                        New_Reference_To
+                          (Standard_Boolean,
+                           Loc))))));
+
+      Insert_After (N, New_Type_Decl);
+      Set_Equivalent_Type (User_Type, Fat_Type);
+      Set_Corresponding_Remote_Type (Fat_Type, User_Type);
+
+      --  The reason we suppress the initialization procedure is that we know
+      --  that no initialization is required (even if Initialize_Scalars mode
+      --  is active), and there are order of elaboration problems if we do try
+      --  to generate an Init_Proc for this created record type.
+
+      Set_Suppress_Init_Proc (Fat_Type);
+
+      if Expander_Active then
+         Add_RAST_Features (Parent (User_Type));
+      end if;
+
+   end Process_Remote_AST_Declaration;
+
+   -----------------------
+   -- RAS_E_Dereference --
+   -----------------------
+
+   procedure RAS_E_Dereference (Pref : Node_Id) is
+      Loc             : constant Source_Ptr := Sloc (Pref);
+      Call_Node       : Node_Id;
+      New_Type        : constant Entity_Id := Etype (Pref);
+      RAS             : constant Entity_Id :=
+                          Corresponding_Remote_Type (New_Type);
+      RAS_Decl        : constant Node_Id   := Parent (RAS);
+      Explicit_Deref  : constant Node_Id   := Parent (Pref);
+      Deref_Subp_Call : constant Node_Id   := Parent (Explicit_Deref);
+      Deref_Proc      : Entity_Id;
+      Params          : List_Id;
+
+   begin
+      if Nkind (Deref_Subp_Call) = N_Procedure_Call_Statement then
+         Params := Parameter_Associations (Deref_Subp_Call);
+
+         if Present (Params) then
+            Prepend (Pref, Params);
+         else
+            Params := New_List (Pref);
+         end if;
+
+      elsif Nkind (Deref_Subp_Call) = N_Indexed_Component then
+
+         Params := Expressions (Deref_Subp_Call);
+
+         if Present (Params) then
+            Prepend (Pref, Params);
+         else
+            Params := New_List (Pref);
+         end if;
+
+      else
+         --  Context is not a call.
+
+         return;
+      end if;
+
+      Deref_Proc := TSS (New_Type, Name_uRAS_Dereference);
+
+      if not Expander_Active then
+         return;
+
+      elsif No (Deref_Proc) then
+         Add_RAST_Features (RAS_Decl);
+         Deref_Proc := TSS (New_Type, Name_uRAS_Dereference);
+      end if;
+
+      if Ekind (Deref_Proc) = E_Function then
+         Call_Node :=
+           Make_Function_Call (Loc,
+              Name => New_Occurrence_Of (Deref_Proc, Loc),
+              Parameter_Associations => Params);
+
+      else
+         Call_Node :=
+           Make_Procedure_Call_Statement (Loc,
+              Name => New_Occurrence_Of (Deref_Proc, Loc),
+              Parameter_Associations => Params);
+      end if;
+
+      Rewrite (Deref_Subp_Call, Call_Node);
+      Analyze (Deref_Subp_Call);
+   end RAS_E_Dereference;
+
+   ------------------------------
+   -- Remote_AST_E_Dereference --
+   ------------------------------
+
+   function Remote_AST_E_Dereference (P : Node_Id) return Boolean
+   is
+      ET : constant Entity_Id  := Etype (P);
+
+   begin
+      --  Perform the changes only on original dereferences, and only if
+      --  we are generating code.
+
+      if Comes_From_Source (P)
+        and then Is_Record_Type (ET)
+        and then (Is_Remote_Call_Interface (ET)
+                   or else Is_Remote_Types (ET))
+        and then Present (Corresponding_Remote_Type (ET))
+        and then (Nkind (Parent (Parent (P))) = N_Procedure_Call_Statement
+                   or else Nkind (Parent (Parent (P))) = N_Indexed_Component)
+        and then Expander_Active
+      then
+         RAS_E_Dereference (P);
+         return True;
+      else
+         return False;
+      end if;
+   end Remote_AST_E_Dereference;
+
+   ------------------------------
+   -- Remote_AST_I_Dereference --
+   ------------------------------
+
+   function Remote_AST_I_Dereference (P : Node_Id) return Boolean
+   is
+      ET     : constant Entity_Id  := Etype (P);
+      Deref  : Node_Id;
+   begin
+
+      if Comes_From_Source (P)
+        and then (Is_Remote_Call_Interface (ET)
+                   or else Is_Remote_Types (ET))
+        and then Present (Corresponding_Remote_Type (ET))
+        and then Ekind (Entity (P)) /= E_Function
+      then
+         Deref :=
+           Make_Explicit_Dereference (Sloc (P),
+             Prefix => Relocate_Node (P));
+         Rewrite (P, Deref);
+         Set_Etype (P, ET);
+         RAS_E_Dereference (Prefix (P));
+         return True;
+      end if;
+
+      return False;
+   end Remote_AST_I_Dereference;
+
+   ---------------------------
+   -- Remote_AST_Null_Value --
+   ---------------------------
+
+   function Remote_AST_Null_Value
+     (N    : Node_Id;
+      Typ  : Entity_Id)
+      return Boolean
+   is
+      Loc         : constant Source_Ptr := Sloc (N);
+      Target_Type : Entity_Id;
+
+   begin
+      if not Expander_Active then
+         return False;
+
+      elsif Ekind (Typ) = E_Access_Subprogram_Type
+        and then (Is_Remote_Call_Interface (Typ)
+                    or else Is_Remote_Types (Typ))
+        and then Comes_From_Source (N)
+        and then Expander_Active
+      then
+         --  Any null that comes from source and is of the RAS type must
+         --  be expanded, except if expansion is not active (nothing
+         --  gets expanded into the equivalent record type).
+
+         Target_Type := Equivalent_Type (Typ);
+
+      elsif Ekind (Typ) = E_Record_Type
+        and then Present (Corresponding_Remote_Type (Typ))
+      then
+
+         --  This is a record type representing a RAS type, this must be
+         --  expanded.
+
+         Target_Type := Typ;
+
+      else
+         --  We do not have to handle this case
+
+         return False;
+
+      end if;
+
+      Rewrite (N,
+        Make_Aggregate (Loc,
+          Expressions => New_List (
+            Make_Integer_Literal (Loc, 0),                  -- Ras
+            Make_Integer_Literal (Loc, 0),                  -- Origin
+            Make_Integer_Literal (Loc, 0),                  -- Receiver
+            Make_Integer_Literal (Loc, 0),                  -- Subp_Id
+            New_Occurrence_Of (Standard_False, Loc))));     -- Asyn
+      Analyze_And_Resolve (N, Target_Type);
+      return True;
+   end Remote_AST_Null_Value;
+
+end Sem_Dist;
diff --git a/gcc/ada/sem_dist.ads b/gcc/ada/sem_dist.ads
new file mode 100644
index 00000000000..b5c823ddc79
--- /dev/null
+++ b/gcc/ada/sem_dist.ads
@@ -0,0 +1,95 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             S E M _ D I S T                              --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.56 $
+--                                                                          --
+--          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). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  Semantic processing for distribution annex facilities
+
+with Types; use Types;
+
+package Sem_Dist is
+
+   procedure Add_Stub_Constructs (N : Node_Id);
+   --  Create the stubs constructs for a remote call interface package
+   --  specification or body or for a shared passive specification. For
+   --  caller stubs, expansion takes place directly in the specification and
+   --  no additional compilation unit is created.
+
+   function Is_All_Remote_Call (N : Node_Id) return Boolean;
+   --  Check whether a function or procedure call should be expanded into
+   --  a remote call, because the entity is declared in a package decl that
+   --  is not currently in scope, and the proper pragmas apply.
+
+   procedure Process_Partition_Id (N : Node_Id);
+   --  Replace attribute reference with call to runtime function. The result
+   --  is converted to the context type, because the attribute yields a
+   --  universal integer value.
+
+   procedure Process_Remote_AST_Attribute (N : Node_Id; New_Type : Entity_Id);
+   --  Given N, an access attribute reference node whose prefix is a
+   --  remote subprogram, rewrite N with a call to a conversion function
+   --  whose return type is New_Type.
+
+   procedure Process_Remote_AST_Declaration (N : Node_Id);
+   --  Given N, an access to subprogram type declaration node in RCI or
+   --  remote types unit, build a new record (fat pointer) type declaration
+   --  using the old Defining_Identifier of N and a link to the old
+   --  declaration node N whose Defining_Identifier is changed.
+   --  We also construct declarations of two subprograms in the unit
+   --  specification which handle remote access to subprogram type
+   --  (fat pointer) dereference and the unit receiver that handles
+   --  remote calls (from remote access to subprogram type values.)
+
+   function Remote_AST_E_Dereference (P : Node_Id) return Boolean;
+   --  If the prefix of an explicit dereference is a record type that
+   --  represent the fat pointer for an Remote access to subprogram, in
+   --  the context of a call, rewrite the enclosing call node into a
+   --  remote call, the first actual of which is the fat pointer. Return
+   --  true if the context is correct and the transformation took place.
+
+   function Remote_AST_I_Dereference (P : Node_Id) return Boolean;
+   --  If P is a record type that represents the fat pointer for a remote
+   --  access to subprogram, and P is the prefix of a call, insert an
+   --  explicit dereference and perform the transformation described for
+   --  the previous function.
+
+   function Remote_AST_Null_Value
+     (N    : Node_Id;
+      Typ  : Entity_Id)
+      return Boolean;
+   --  If N is a null value and Typ a remote access to subprogram type,
+   --  this function will check if null needs to be replaced with an
+   --  aggregate and will return True in this case. Otherwise, it will
+   --  return False.
+
+   function Get_Subprogram_Id (E : Entity_Id) return Int;
+   --  Given a subprogram defined in a RCI package, get its subprogram id
+   --  which will be used for remote calls.
+
+   function Package_Specification_Of_Scope (E : Entity_Id) return Node_Id;
+   --  Return the N_Package_Specification corresponding to a scope E
+
+end Sem_Dist;
diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb
new file mode 100644
index 00000000000..555abb8ca88
--- /dev/null
+++ b/gcc/ada/sem_elab.adb
@@ -0,0 +1,2278 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             S E M _ E L A B                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.84 $
+--                                                                          --
+--          Copyright (C) 1997-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 Checks;   use Checks;
+with Debug;    use Debug;
+with Einfo;    use Einfo;
+with Elists;   use Elists;
+with Errout;   use Errout;
+with Exp_Util; use Exp_Util;
+with Expander; use Expander;
+with Fname;    use Fname;
+with Lib;      use Lib;
+with Lib.Load; use Lib.Load;
+with Namet;    use Namet;
+with Nlists;   use Nlists;
+with Nmake;    use Nmake;
+with Opt;      use Opt;
+with Output;   use Output;
+with Restrict; use Restrict;
+with Sem;      use Sem;
+with Sem_Cat;  use Sem_Cat;
+with Sem_Ch7;  use Sem_Ch7;
+with Sem_Ch8;  use Sem_Ch8;
+with Sem_Res;  use Sem_Res;
+with Sem_Util; use Sem_Util;
+with Sinfo;    use Sinfo;
+with Sinput;   use Sinput;
+with Snames;   use Snames;
+with Stand;    use Stand;
+with Table;
+with Tbuild;   use Tbuild;
+with Uname;    use Uname;
+
+package body Sem_Elab is
+
+   --  The following table records the recursive call chain for output
+   --  in the Output routine. Each entry records the call node and the
+   --  entity of the called routine. The number of entries in the table
+   --  (i.e. the value of Elab_Call.Last) indicates the current depth
+   --  of recursion and is used to identify the outer level.
+
+   type Elab_Call_Entry is record
+      Cloc : Source_Ptr;
+      Ent  : Entity_Id;
+   end record;
+
+   package Elab_Call is new Table.Table (
+     Table_Component_Type => Elab_Call_Entry,
+     Table_Index_Type     => Int,
+     Table_Low_Bound      => 1,
+     Table_Initial        => 50,
+     Table_Increment      => 100,
+     Table_Name           => "Elab_Call");
+
+   --  This table is initialized at the start of each outer level call.
+   --  It holds the entities for all subprograms that have been examined
+   --  for this particular outer level call, and is used to prevent both
+   --  infinite recursion, and useless reanalysis of bodies already seen
+
+   package Elab_Visited is new Table.Table (
+     Table_Component_Type => Entity_Id,
+     Table_Index_Type     => Int,
+     Table_Low_Bound      => 1,
+     Table_Initial        => 200,
+     Table_Increment      => 100,
+     Table_Name           => "Elab_Visited");
+
+   --  This table stores calls to Check_Internal_Call that are delayed
+   --  until all generics are instantiated, and in particular that all
+   --  generic bodies have been inserted. We need to delay, because we
+   --  need to be able to look through the inserted bodies.
+
+   type Delay_Element is record
+      N : Node_Id;
+      --  The parameter N from the call to Check_Internal_Call. Note that
+      --  this node may get rewritten over the delay period by expansion
+      --  in the call case (but not in the instantiation case).
+
+      E : Entity_Id;
+      --  The parameter E from the call to Check_Internal_Call
+
+      Orig_Ent : Entity_Id;
+      --  The parameter Orig_Ent from the call to Check_Internal_Call
+
+      Curscop : Entity_Id;
+      --  The current scope of the call. This is restored when we complete
+      --  the delayed call, so that we do this in the right scope.
+
+      From_Elab_Code : Boolean;
+      --  Save indication of whether this call is from elaboration code
+
+      Outer_Scope : Entity_Id;
+      --  Save scope of outer level call
+
+   end record;
+
+   package Delay_Check is new Table.Table (
+     Table_Component_Type => Delay_Element,
+     Table_Index_Type     => Int,
+     Table_Low_Bound      => 1,
+     Table_Initial        => 1000,
+     Table_Increment      => 100,
+     Table_Name           => "Delay_Check");
+
+   C_Scope : Entity_Id;
+   --  Top level scope of current scope. We need to compute this only
+   --  once at the outer level, i.e. for a call to Check_Elab_Call from
+   --  outside this unit.
+
+   Outer_Level_Sloc : Source_Ptr;
+   --  Save Sloc value for outer level call node for comparisons of source
+   --  locations. A body is too late if it appears after the *outer* level
+   --  call, not the particular call that is being analyzed.
+
+   From_Elab_Code : Boolean;
+   --  This flag shows whether the outer level call currently being examined
+   --  is or is not in elaboration code. We are only interested in calls to
+   --  routines in other units if this flag is True.
+
+   In_Task_Activation : Boolean := False;
+   --  This flag indicates whether we are performing elaboration checks on
+   --  task procedures, at the point of activation. If true, we do not trace
+   --  internal calls in these procedures, because all local bodies are known
+   --  to be elaborated.
+
+   Delaying_Elab_Checks : Boolean := True;
+   --  This is set True till the compilation is complete, including the
+   --  insertion of all instance bodies. Then when Check_Elab_Calls is
+   --  called, the delay table is used to make the delayed calls and
+   --  this flag is reset to False, so that the calls are processed
+
+   -----------------------
+   -- Local Subprograms --
+   -----------------------
+
+   --  Note: Outer_Scope in all these calls represents the scope of
+   --  interest of the outer level call. If it is set to Standard_Standard,
+   --  then it means the outer level call was at elaboration level, and that
+   --  thus all calls are of interest. If it was set to some other scope,
+   --  then the original call was an inner call, and we are not interested
+   --  in calls that go outside this scope.
+
+   procedure Check_A_Call
+     (N                 : Node_Id;
+      E                 : Entity_Id;
+      Outer_Scope       : Entity_Id;
+      Inter_Unit_Only   : Boolean;
+      Generate_Warnings : Boolean := True);
+   --  This is the internal recursive routine that is called to check for
+   --  a possible elaboration error. The argument N is a subprogram call
+   --  or generic instantiation to be checked, and E is the entity of
+   --  the called subprogram, or instantiated generic unit. The flag
+   --  Outer_Scope is the outer level scope for the original call.
+   --  Inter_Unit_Only is set if the call is only to be checked in the
+   --  case where it is to another unit (and skipped if within a unit).
+   --  Generate_Warnings is set to True to suppress warning messages
+   --  about missing pragma Elaborate_All's. These messages are not
+   --  wanted for inner calls in the dynamic model.
+
+   procedure Check_Bad_Instantiation (N : Node_Id);
+   --  N is a node for an instantiation (if called with any other node kind,
+   --  Check_Bad_Instantiation ignores the call). This subprogram checks for
+   --  the special case of a generic instantiation of a generic spec in the
+   --  same declarative part as the instantiation where a body is present and
+   --  has not yet been seen. This is an obvious error, but needs to be checked
+   --  specially at the time of the instantiation, since it is a case where we
+   --  cannot insert the body anywhere. If this case is detected, warnings are
+   --  generated, and a raise of Program_Error is inserted. In addition any
+   --  subprograms in the generic spec are stubbed, and the Bad_Instantiation
+   --  flag is set on the instantiation node. The caller in Sem_Ch12 uses this
+   --  flag as an indication that no attempt should be made to insert an
+   --  instance body.
+
+   procedure Check_Internal_Call
+     (N           : Node_Id;
+      E           : Entity_Id;
+      Outer_Scope : Entity_Id;
+      Orig_Ent    : Entity_Id);
+   --  N is a function call or procedure statement call node and E is
+   --  the entity of the called function, which is within the current
+   --  compilation unit (where subunits count as part of the parent).
+   --  This call checks if this call, or any call within any accessed
+   --  body could cause an ABE, and if so, outputs a warning. Orig_Ent
+   --  differs from E only in the case of renamings, and points to the
+   --  original name of the entity. This is used for error messages.
+   --  Outer_Scope is the outer level scope for the original call.
+
+   procedure Check_Internal_Call_Continue
+     (N           : Node_Id;
+      E           : Entity_Id;
+      Outer_Scope : Entity_Id;
+      Orig_Ent    : Entity_Id);
+   --  The processing for Check_Internal_Call is divided up into two phases,
+   --  and this represents the second phase. The second phase is delayed if
+   --  Delaying_Elab_Calls is set to True. In this delayed case, the first
+   --  phase makes an entry in the Delay_Check table, which is processed
+   --  when Check_Elab_Calls is called. N, E and Orig_Ent are as for the call
+   --  to Check_Internal_Call. Outer_Scope is the outer level scope for
+   --  the original call.
+
+   function Has_Generic_Body (N : Node_Id) return Boolean;
+   --  N is a generic package instantiation node, and this routine determines
+   --  if this package spec does in fact have a generic body. If so, then
+   --  True is returned, otherwise False. Note that this is not at all the
+   --  same as checking if the unit requires a body, since it deals with
+   --  the case of optional bodies accurately (i.e. if a body is optional,
+   --  then it looks to see if a body is actually present). Note: this
+   --  function can only do a fully correct job if in generating code mode
+   --  where all bodies have to be present. If we are operating in semantics
+   --  check only mode, then in some cases of optional bodies, a result of
+   --  False may incorrectly be given. In practice this simply means that
+   --  some cases of warnings for incorrect order of elaboration will only
+   --  be given when generating code, which is not a big problem (and is
+   --  inevitable, given the optional body semantics of Ada).
+
+   procedure Insert_Elab_Check (N : Node_Id; C : Node_Id := Empty);
+   --  Given code for an elaboration check (or unconditional raise if
+   --  the check is not needed), inserts the code in the appropriate
+   --  place. N is the call or instantiation node for which the check
+   --  code is required. C is the test whose failure triggers the raise.
+
+   procedure Output_Calls (N : Node_Id);
+   --  Outputs chain of calls stored in the Elab_Call table. The caller
+   --  has already generated the main warning message, so the warnings
+   --  generated are all continuation messages. The argument is the
+   --  call node at which the messages are to be placed.
+
+   function Same_Elaboration_Scope (Scop1, Scop2 : Entity_Id) return Boolean;
+   --  Given two scopes, determine whether they are the same scope from an
+   --  elaboration point of view, i.e. packages and blocks are ignored.
+
+   procedure Set_C_Scope;
+   --  On entry C_Scope is set to some scope. On return, C_Scope is reset
+   --  to be the enclosing compilation unit of this scope.
+
+   function Spec_Entity (E : Entity_Id) return Entity_Id;
+   --  Given a compilation unit entity, if it is a spec entity, it is
+   --  returned unchanged. If it is a body entity, then the spec for
+   --  the corresponding spec is returned
+
+   procedure Supply_Bodies (N : Node_Id);
+   --  Given a node, N, that is either a subprogram declaration or a package
+   --  declaration, this procedure supplies dummy bodies for the subprogram
+   --  or for all subprograms in the package. If the given node is not one
+   --  of these two possibilities, then Supply_Bodies does nothing. The
+   --  dummy body is supplied by setting the subprogram to be Imported with
+   --  convention Stubbed.
+
+   procedure Supply_Bodies (L : List_Id);
+   --  Calls Supply_Bodies for all elements of the given list L.
+
+   function Within (E1, E2 : Entity_Id) return Boolean;
+   --  Given two scopes E1 and E2, returns True if E1 is equal to E2, or
+   --  is one of its contained scopes, False otherwise.
+
+   ------------------
+   -- Check_A_Call --
+   ------------------
+
+   procedure Check_A_Call
+     (N                 : Node_Id;
+      E                 : Entity_Id;
+      Outer_Scope       : Entity_Id;
+      Inter_Unit_Only   : Boolean;
+      Generate_Warnings : Boolean := True)
+   is
+      Loc  : constant Source_Ptr := Sloc (N);
+      Ent  : Entity_Id;
+      Decl : Node_Id;
+
+      E_Scope : Entity_Id;
+      --  Top level scope of entity for called subprogram
+
+      Body_Acts_As_Spec : Boolean;
+      --  Set to true if call is to body acting as spec (no separate spec)
+
+      Inst_Case : constant Boolean := Nkind (N) in N_Generic_Instantiation;
+      --  Indicates if we have instantiation case
+
+      Caller_Unit_Internal : Boolean;
+      Callee_Unit_Internal : Boolean;
+
+      Inst_Caller : Source_Ptr;
+      Inst_Callee : Source_Ptr;
+
+      Unit_Caller : Unit_Number_Type;
+      Unit_Callee : Unit_Number_Type;
+
+      Cunit_SW : Boolean := False;
+      --  Set to suppress warnings for case of external reference where
+      --  one of the enclosing scopes has the Suppress_Elaboration_Warnings
+      --  flag set. For the internal case, we ignore this flag.
+
+      Cunit_SC : Boolean := False;
+      --  Set to suppress dynamic elaboration checks where one of the
+      --  enclosing scopes has Suppress_Elaboration_Checks set. For
+      --  the internal case, we ignore this flag.
+
+   begin
+      --  Go to parent for derived subprogram, or to original subprogram
+      --  in the case of a renaming (Alias covers both these cases)
+
+      Ent := E;
+      loop
+         if Suppress_Elaboration_Warnings (Ent) then
+            return;
+         end if;
+
+         --  Nothing to do for imported entities,
+
+         if Is_Imported (Ent) then
+            return;
+         end if;
+
+         exit when Inst_Case or else No (Alias (Ent));
+         Ent := Alias (Ent);
+      end loop;
+
+      Decl := Unit_Declaration_Node (Ent);
+
+      if Nkind (Decl) = N_Subprogram_Body then
+         Body_Acts_As_Spec := True;
+
+      elsif Nkind (Decl) = N_Subprogram_Declaration
+        or else Nkind (Decl) = N_Subprogram_Body_Stub
+        or else Inst_Case
+      then
+         Body_Acts_As_Spec := False;
+
+      --  If we have none of an instantiation, subprogram body or
+      --  subprogram declaration, then it is not a case that we want
+      --  to check. (One case is a call to a generic formal subprogram,
+      --  where we do not want the check in the template).
+
+      else
+         return;
+      end if;
+
+      E_Scope := Ent;
+      loop
+         if Suppress_Elaboration_Warnings (E_Scope) then
+            Cunit_SW := True;
+         end if;
+
+         if Suppress_Elaboration_Checks (E_Scope) then
+            Cunit_SC := True;
+         end if;
+
+         --  Exit when we get to compilation unit, not counting subunits
+
+         exit when Is_Compilation_Unit (E_Scope)
+           and then (Is_Child_Unit (E_Scope)
+                       or else Scope (E_Scope) = Standard_Standard);
+
+         --  If we did not find a compilation unit, other than standard,
+         --  then nothing to check (happens in some instantiation cases)
+
+         if E_Scope = Standard_Standard then
+            return;
+
+         --  Otherwise move up a scope looking for compilation unit
+
+         else
+            E_Scope := Scope (E_Scope);
+         end if;
+      end loop;
+
+      --  No checks needed for pure or preelaborated compilation units
+
+      if Is_Pure (E_Scope)
+        or else Is_Preelaborated (E_Scope)
+      then
+         return;
+      end if;
+
+      --  If the generic entity is within a deeper instance than we are, then
+      --  either the instantiation to which we refer itself caused an ABE, in
+      --  which case that will be handled separately. Otherwise, we know that
+      --  the body we need appears as needed at the point of the instantiation.
+      --  However, this assumption is only valid if we are in static mode.
+
+      if not Dynamic_Elaboration_Checks
+        and then Instantiation_Depth (Sloc (Ent)) >
+                 Instantiation_Depth (Sloc (N))
+      then
+         return;
+      end if;
+
+      --  Do not give a warning for a package with no body
+
+      if Ekind (Ent) = E_Generic_Package
+        and then not Has_Generic_Body (N)
+      then
+         return;
+      end if;
+
+      --  Case of entity is not in current unit (i.e. with'ed unit case)
+
+      if E_Scope /= C_Scope then
+
+         --  We are only interested in such calls if the outer call was from
+         --  elaboration code, or if we are in Dynamic_Elaboration_Checks mode.
+
+         if not From_Elab_Code and then not Dynamic_Elaboration_Checks then
+            return;
+         end if;
+
+         --  Nothing to do if some scope said to ignore warnings
+
+         if Cunit_SW then
+            return;
+         end if;
+
+         --  Nothing to do for a generic instance, because in this case
+         --  the checking was at the point of instantiation of the generic
+         --  However, this shortcut is only applicable in static mode.
+
+         if Is_Generic_Instance (Ent) and not Dynamic_Elaboration_Checks then
+            return;
+         end if;
+
+         --  Nothing to do if subprogram with no separate spec
+
+         if Body_Acts_As_Spec then
+            return;
+         end if;
+
+         --  Check cases of internal units
+
+         Callee_Unit_Internal :=
+           Is_Internal_File_Name
+             (Unit_File_Name (Get_Source_Unit (E_Scope)));
+
+         --  Do not give a warning if the with'ed unit is internal
+         --  and this is the generic instantiation case (this saves a
+         --  lot of hassle dealing with the Text_IO special child units)
+
+         if Callee_Unit_Internal and Inst_Case then
+            return;
+         end if;
+
+         if C_Scope = Standard_Standard then
+            Caller_Unit_Internal := False;
+         else
+            Caller_Unit_Internal :=
+              Is_Internal_File_Name
+                (Unit_File_Name (Get_Source_Unit (C_Scope)));
+         end if;
+
+         --  Do not give a warning if the with'ed unit is internal
+         --  and the caller is not internal (since the binder always
+         --  elaborates internal units first).
+
+         if Callee_Unit_Internal and (not Caller_Unit_Internal) then
+            return;
+         end if;
+
+         --  For now, if debug flag -gnatdE is not set, do no checking for
+         --  one internal unit withing another. This fixes the problem with
+         --  the sgi build and storage errors. To be resolved later ???
+
+         if (Callee_Unit_Internal and Caller_Unit_Internal)
+            and then not Debug_Flag_EE
+         then
+            return;
+         end if;
+
+         Ent := E;
+
+         --  If the call is in an instance, and the called entity is not
+         --  defined in the same instance, then the elaboration issue
+         --  focuses around the unit containing the template, it is
+         --  this unit which requires an Elaborate_All.
+
+         --  However, if we are doing dynamic elaboration, we need to
+         --  chase the call in the usual manner.
+
+         --  We do not handle the case of calling a generic formal correctly
+         --  in the static case. See test 4703-004 to explore this gap ???
+
+         Inst_Caller := Instantiation (Get_Source_File_Index (Sloc (N)));
+         Inst_Callee := Instantiation (Get_Source_File_Index (Sloc (Ent)));
+
+         if Inst_Caller = No_Location then
+            Unit_Caller := No_Unit;
+         else
+            Unit_Caller := Get_Source_Unit (N);
+         end if;
+
+         if Inst_Callee = No_Location then
+            Unit_Callee := No_Unit;
+         else
+            Unit_Callee := Get_Source_Unit (Ent);
+         end if;
+
+         if Unit_Caller /= No_Unit
+           and then Unit_Callee /= Unit_Caller
+           and then not Dynamic_Elaboration_Checks
+         then
+            E_Scope := Spec_Entity (Cunit_Entity (Unit_Caller));
+
+            --  If we don't get a spec entity, just ignore call. Not
+            --  quite clear why this check is necessary.
+
+            if No (E_Scope) then
+               return;
+            end if;
+
+            --  Otherwise step to enclosing compilation unit
+
+            while not Is_Compilation_Unit (E_Scope) loop
+               E_Scope := Scope (E_Scope);
+            end loop;
+
+         --  For the case of not in an instance, or call within instance
+         --  We recompute E_Scope for the error message, since we
+         --  do NOT want to go to the unit which has the ultimate
+         --  declaration in the case of renaming and derivation and
+         --  we also want to go to the generic unit in the case of
+         --  an instance, and no further.
+
+         else
+            --  Loop to carefully follow renamings and derivations
+            --  one step outside the current unit, but not further.
+
+            loop
+               E_Scope := Ent;
+               while not Is_Compilation_Unit (E_Scope) loop
+                  E_Scope := Scope (E_Scope);
+               end loop;
+
+               --  If E_Scope is the same as C_Scope, it means that there
+               --  definitely was a renaming or derivation, and we are
+               --  not yet out of the current unit.
+
+               exit when E_Scope /= C_Scope;
+               Ent := Alias (Ent);
+            end loop;
+         end if;
+
+         if not Suppress_Elaboration_Warnings (Ent)
+           and then not Suppress_Elaboration_Warnings (E_Scope)
+           and then Elab_Warnings
+           and then Generate_Warnings
+         then
+            Warn_On_Instance := True;
+
+            if Inst_Case then
+               Error_Msg_NE
+                 ("instantiation of& may raise Program_Error?", N, Ent);
+            else
+               Error_Msg_NE
+                 ("call to & may raise Program_Error?", N, Ent);
+            end if;
+
+            Error_Msg_Qual_Level := Nat'Last;
+            Error_Msg_NE
+              ("\missing pragma Elaborate_All for&?", N, E_Scope);
+            Error_Msg_Qual_Level := 0;
+            Output_Calls (N);
+            Warn_On_Instance := False;
+
+            --  Set flag to prevent further warnings for same unit
+            --  unless in All_Errors_Mode.
+
+            if not All_Errors_Mode and not Dynamic_Elaboration_Checks then
+               Set_Suppress_Elaboration_Warnings (E_Scope);
+            end if;
+         end if;
+
+         --  Check for runtime elaboration check required
+
+         if Dynamic_Elaboration_Checks then
+            if not Elaboration_Checks_Suppressed (Ent)
+              and then not Suppress_Elaboration_Checks (E_Scope)
+              and then not Cunit_SC
+            then
+               --  Runtime elaboration check required. generate check of the
+               --  elaboration Boolean for the unit containing the entity.
+
+               Insert_Elab_Check (N,
+                 Make_Attribute_Reference (Loc,
+                   Attribute_Name => Name_Elaborated,
+                   Prefix =>
+                     New_Occurrence_Of
+                       (Spec_Entity (E_Scope), Loc)));
+            end if;
+
+         --  If no dynamic check required, then ask binder to guarantee
+         --  that the necessary elaborations will be done properly!
+
+         else
+            if not Suppress_Elaboration_Warnings (E)
+              and then not Suppress_Elaboration_Warnings (E_Scope)
+              and then Elab_Warnings
+              and then Generate_Warnings
+              and then not Inst_Case
+            then
+               Error_Msg_Node_2 := E_Scope;
+               Error_Msg_NE ("call to& in elaboration code " &
+                  "requires pragma Elaborate_All on&?", N, E);
+            end if;
+
+            Set_Elaborate_All_Desirable (E_Scope);
+            Set_Suppress_Elaboration_Warnings (E_Scope);
+         end if;
+
+      --  Case of entity is in same unit as call or instantiation
+
+      elsif not Inter_Unit_Only then
+         Check_Internal_Call (N, Ent, Outer_Scope, E);
+      end if;
+
+   end Check_A_Call;
+
+   -----------------------------
+   -- Check_Bad_Instantiation --
+   -----------------------------
+
+   procedure Check_Bad_Instantiation (N : Node_Id) is
+      Nam : Node_Id;
+      Ent : Entity_Id;
+
+   begin
+      --  Nothing to do if we do not have an instantiation (happens in some
+      --  error cases, and also in the formal package declaration case)
+
+      if Nkind (N) not in N_Generic_Instantiation then
+         return;
+
+      --  Nothing to do if errors already detected (avoid cascaded errors)
+
+      elsif Errors_Detected /= 0 then
+         return;
+
+      --  Nothing to do if not in full analysis mode
+
+      elsif not Full_Analysis then
+         return;
+
+      --  Nothing to do if inside a generic template
+
+      elsif Inside_A_Generic then
+         return;
+
+      --  Nothing to do if a library level instantiation
+
+      elsif Nkind (Parent (N)) = N_Compilation_Unit then
+         return;
+
+      --  Nothing to do if we are compiling a proper body for semantic
+      --  purposes only. The generic body may be in another proper body.
+
+      elsif
+        Nkind (Parent (Unit_Declaration_Node (Main_Unit_Entity))) = N_Subunit
+      then
+         return;
+      end if;
+
+      Nam := Name (N);
+      Ent := Entity (Nam);
+
+      --  The case we are interested in is when the generic spec is in the
+      --  current declarative part
+
+      if not Same_Elaboration_Scope (Current_Scope, Scope (Ent))
+        or else not In_Same_Extended_Unit (Sloc (N), Sloc (Ent))
+      then
+         return;
+      end if;
+
+      --  If the generic entity is within a deeper instance than we are, then
+      --  either the instantiation to which we refer itself caused an ABE, in
+      --  which case that will be handled separately. Otherwise, we know that
+      --  the body we need appears as needed at the point of the instantiation.
+      --  If they are both at the same level but not within the same instance
+      --  then the body of the generic will be in the earlier instance.
+
+      declare
+         D1 : constant Int := Instantiation_Depth (Sloc (Ent));
+         D2 : constant Int := Instantiation_Depth (Sloc (N));
+
+      begin
+         if D1 > D2 then
+            return;
+
+         elsif D1 = D2
+           and then Is_Generic_Instance (Scope (Ent))
+           and then not In_Open_Scopes (Scope (Ent))
+         then
+            return;
+         end if;
+      end;
+
+      --  Now we can proceed, if the entity being called has a completion,
+      --  then we are definitely OK, since we have already seen the body.
+
+      if Has_Completion (Ent) then
+         return;
+      end if;
+
+      --  If there is no body, then nothing to do
+
+      if not Has_Generic_Body (N) then
+         return;
+      end if;
+
+      --  Here we definitely have a bad instantiation
+
+      Error_Msg_NE
+        ("?cannot instantiate& before body seen", N, Ent);
+
+      if Present (Instance_Spec (N)) then
+         Supply_Bodies (Instance_Spec (N));
+      end if;
+
+      Error_Msg_N
+        ("\?Program_Error will be raised at run time", N);
+      Insert_Elab_Check (N);
+      Set_ABE_Is_Certain (N);
+
+   end Check_Bad_Instantiation;
+
+   ---------------------
+   -- Check_Elab_Call --
+   ---------------------
+
+   procedure Check_Elab_Call
+     (N           : Node_Id;
+      Outer_Scope : Entity_Id := Empty)
+   is
+      Nam : Node_Id;
+      Ent : Entity_Id;
+      P   : Node_Id;
+
+   begin
+      --  For an entry call, check relevant restriction
+
+      if Nkind (N) = N_Entry_Call_Statement
+         and then not In_Subprogram_Or_Concurrent_Unit
+      then
+         Check_Restriction (No_Entry_Calls_In_Elaboration_Code, N);
+
+      --  Nothing to do if this is not a call (happens in some error
+      --  conditions, and in some cases where rewriting occurs).
+
+      elsif Nkind (N) /= N_Function_Call
+        and then Nkind (N) /= N_Procedure_Call_Statement
+      then
+         return;
+
+      --  Nothing to do if this is a call already rewritten for elab checking.
+
+      elsif Nkind (Parent (N)) = N_Conditional_Expression then
+         return;
+
+      --  Nothing to do if inside a generic template
+
+      elsif Inside_A_Generic
+        and then not Present (Enclosing_Generic_Body (N))
+      then
+         return;
+      end if;
+
+      --  Here we have a call at elaboration time which must be checked
+
+      if Debug_Flag_LL then
+         Write_Str ("  Check_Elab_Call: ");
+
+         if No (Name (N))
+           or else not Is_Entity_Name (Name (N))
+         then
+            Write_Str ("<<not entity name>> ");
+         else
+            Write_Name (Chars (Entity (Name (N))));
+         end if;
+
+         Write_Str ("  call at ");
+         Write_Location (Sloc (N));
+         Write_Eol;
+      end if;
+
+      --  Climb up the tree to make sure we are not inside a
+      --  default expression of a parameter specification or
+      --  a record component, since in both these cases, we
+      --  will be doing the actual call later, not now, and it
+      --  is at the time of the actual call (statically speaking)
+      --  that we must do our static check, not at the time of
+      --  its initial analysis).
+
+      P := Parent (N);
+      while Present (P) loop
+         if Nkind (P) = N_Parameter_Specification
+              or else
+            Nkind (P) = N_Component_Declaration
+         then
+            return;
+         else
+            P := Parent (P);
+         end if;
+      end loop;
+
+      --  Stuff that happens only at the outer level
+
+      if No (Outer_Scope) then
+         Elab_Visited.Set_Last (0);
+
+         --  Nothing to do if current scope is Standard (this is a bit
+         --  odd, but it happens in the case of generic instantiations).
+
+         C_Scope := Current_Scope;
+
+         if C_Scope = Standard_Standard then
+            return;
+         end if;
+
+         --  First case, we are in elaboration code
+
+         From_Elab_Code := not In_Subprogram_Or_Concurrent_Unit;
+
+         if From_Elab_Code then
+
+            --  Complain if call that comes from source in preelaborated
+            --  unit and we are not inside a subprogram (i.e. we are in
+            --  elab code)
+
+            if Comes_From_Source (N)
+              and then In_Preelaborated_Unit
+            then
+               Error_Msg_N
+                 ("non-static call not allowed in preelaborated unit", N);
+               return;
+            end if;
+
+         --  Second case, we are inside a subprogram or concurrent unit
+         --  i.e, we are not in elaboration code.
+
+         else
+            --  In this case, the issue is whether we are inside the
+            --  declarative part of the unit in which we live, or inside
+            --  its statements. In the latter case, there is no issue of
+            --  ABE calls at this level (a call from outside to the unit
+            --  in which we live might cause an ABE, but that will be
+            --  detected when we analyze that outer level call, as it
+            --  recurses into the called unit).
+
+            --  Climb up the tree, doing this test, and also testing
+            --  for being inside a default expression, which, as
+            --  discussed above, is not checked at this stage.
+
+            declare
+               P : Node_Id;
+               L : List_Id;
+
+            begin
+               P := N;
+               loop
+                  --  If we find a parentless subtree, it seems safe to
+                  --  assume that we are not in a declarative part and
+                  --  that no checking is required.
+
+                  if No (P) then
+                     return;
+                  end if;
+
+                  if Is_List_Member (P) then
+                     L := List_Containing (P);
+                     P := Parent (L);
+                  else
+                     L := No_List;
+                     P := Parent (P);
+                  end if;
+
+                  exit when Nkind (P) = N_Subunit;
+
+                  --  Filter out case of default expressions, where
+                  --  we do not do the check at this stage.
+
+                  if Nkind (P) = N_Parameter_Specification
+                       or else
+                     Nkind (P) = N_Component_Declaration
+                  then
+                     return;
+                  end if;
+
+                  if Nkind (P) = N_Subprogram_Body
+                       or else
+                     Nkind (P) = N_Protected_Body
+                       or else
+                     Nkind (P) = N_Task_Body
+                       or else
+                     Nkind (P) = N_Block_Statement
+                  then
+                     if L = Declarations (P) then
+                        exit;
+
+                     --  We are not in elaboration code, but we are doing
+                     --  dynamic elaboration checks, in this case, we still
+                     --  need to do the call, since the subprogram we are in
+                     --  could be called from another unit, also in dynamic
+                     --  elaboration check mode, at elaboration time.
+
+                     elsif Dynamic_Elaboration_Checks then
+
+                        --  This is a rather new check, going into version
+                        --  3.14a1 for the first time (V1.80 of this unit),
+                        --  so we provide a debug flag to enable it. That
+                        --  way we have an easy work around for regressions
+                        --  that are caused by this new check. This debug
+                        --  flag can be removed later.
+
+                        if Debug_Flag_DD then
+                           return;
+                        end if;
+
+                        --  Do the check in this case
+
+                        exit;
+
+                     --  Static model, call is not in elaboration code, we
+                     --  never need to worry, because in the static model
+                     --  the top level caller always takes care of things.
+
+                     else
+                        return;
+                     end if;
+                  end if;
+               end loop;
+            end;
+         end if;
+      end if;
+
+      --  Retrieve called entity. If this is a call to a protected subprogram,
+      --  the entity is a selected component.
+      --  The callable entity may be absent, in which case there is nothing
+      --  to do. This happens with non-analyzed calls in nested generics.
+
+      Nam := Name (N);
+
+      if No (Nam) then
+         return;
+
+      elsif Nkind (Nam) = N_Selected_Component then
+         Ent := Entity (Selector_Name (Nam));
+
+      elsif not Is_Entity_Name (Nam) then
+         return;
+
+      else
+         Ent := Entity (Nam);
+      end if;
+
+      if No (Ent) then
+         return;
+      end if;
+
+      --  Nothing to do if this is a recursive call (i.e. a call to
+      --  an entity that is already in the Elab_Call stack)
+
+      for J in 1 .. Elab_Visited.Last loop
+         if Ent = Elab_Visited.Table (J) then
+            return;
+         end if;
+      end loop;
+
+      --  See if we need to analyze this call. We analyze it if either of
+      --  the following conditions is met:
+
+      --    It is an inner level call (since in this case it was triggered
+      --    by an outer level call from elaboration code), but only if the
+      --    call is within the scope of the original outer level call.
+
+      --    It is an outer level call from elaboration code, or the called
+      --    entity is in the same elaboration scope.
+
+      --  And in these cases, we will check both inter-unit calls and
+      --  intra-unit (within a single unit) calls.
+
+      C_Scope := Current_Scope;
+
+      --  If not outer level call, then we follow it if it is within
+      --  the original scope of the outer call.
+
+      if Present (Outer_Scope)
+        and then Within (Scope (Ent), Outer_Scope)
+      then
+         Set_C_Scope;
+         Check_A_Call (N, Ent, Outer_Scope, Inter_Unit_Only => False);
+
+      elsif Elaboration_Checks_Suppressed (Current_Scope) then
+         null;
+
+      elsif From_Elab_Code then
+         Set_C_Scope;
+         Check_A_Call (N, Ent, Standard_Standard, Inter_Unit_Only => False);
+
+      elsif Same_Elaboration_Scope (C_Scope, Scope (Ent)) then
+         Set_C_Scope;
+         Check_A_Call (N, Ent, Scope (Ent), Inter_Unit_Only => False);
+
+      --  If none of those cases holds, but Dynamic_Elaboration_Checks mode
+      --  is set, then we will do the check, but only in the inter-unit case
+      --  (this is to accomodate unguarded elaboration calls from other units
+      --  in which this same mode is set). We don't want warnings in this case,
+      --  it would generate warnings having nothing to do with elaboration.
+
+      elsif Dynamic_Elaboration_Checks then
+         Set_C_Scope;
+         Check_A_Call
+           (N,
+            Ent,
+            Standard_Standard,
+            Inter_Unit_Only => True,
+            Generate_Warnings => False);
+
+      else
+         return;
+      end if;
+   end Check_Elab_Call;
+
+   ----------------------
+   -- Check_Elab_Calls --
+   ----------------------
+
+   procedure Check_Elab_Calls is
+   begin
+      --  If expansion is disabled, do not generate any checks. Also
+      --  skip checks if any subunits are missing because in either
+      --  case we lack the full information that we need, and no object
+      --  file will be created in any case.
+
+      if not Expander_Active or else Subunits_Missing then
+         return;
+      end if;
+
+      --  Skip delayed calls if we had any errors
+
+      if Errors_Detected = 0 then
+         Delaying_Elab_Checks := False;
+         Expander_Mode_Save_And_Set (True);
+
+         for J in Delay_Check.First .. Delay_Check.Last loop
+            New_Scope (Delay_Check.Table (J).Curscop);
+            From_Elab_Code := Delay_Check.Table (J).From_Elab_Code;
+
+            Check_Internal_Call_Continue (
+              N           => Delay_Check.Table (J).N,
+              E           => Delay_Check.Table (J).E,
+              Outer_Scope => Delay_Check.Table (J).Outer_Scope,
+              Orig_Ent    => Delay_Check.Table (J).Orig_Ent);
+
+            Pop_Scope;
+         end loop;
+
+         --  Set Delaying_Elab_Checks back on for next main compilation
+
+         Expander_Mode_Restore;
+         Delaying_Elab_Checks := True;
+      end if;
+   end Check_Elab_Calls;
+
+   ------------------------------
+   -- Check_Elab_Instantiation --
+   ------------------------------
+
+   procedure Check_Elab_Instantiation
+     (N           : Node_Id;
+      Outer_Scope : Entity_Id := Empty)
+   is
+      Nam     : Node_Id;
+      Ent     : Entity_Id;
+
+   begin
+      --  Check for and deal with bad instantiation case. There is some
+      --  duplicated code here, but we will worry about this later ???
+
+      Check_Bad_Instantiation (N);
+
+      if ABE_Is_Certain (N) then
+         return;
+      end if;
+
+      --  Nothing to do if we do not have an instantiation (happens in some
+      --  error cases, and also in the formal package declaration case)
+
+      if Nkind (N) not in N_Generic_Instantiation then
+         return;
+      end if;
+
+      --  Nothing to do if inside a generic template
+
+      if Inside_A_Generic then
+         return;
+      end if;
+
+      Nam := Name (N);
+      Ent := Entity (Nam);
+      From_Elab_Code := not In_Subprogram_Or_Concurrent_Unit;
+
+      --  See if we need to analyze this instantiation. We analyze it if
+      --  either of the following conditions is met:
+
+      --    It is an inner level instantiation (since in this case it was
+      --    triggered by an outer level call from elaboration code), but
+      --    only if the instantiation is within the scope of the original
+      --    outer level call.
+
+      --    It is an outer level instantiation from elaboration code, or the
+      --    instantiated entity is in the same elaboratoin scope.
+
+      --  And in these cases, we will check both the inter-unit case and
+      --  the intra-unit (within a single unit) case.
+
+      C_Scope := Current_Scope;
+
+      if Present (Outer_Scope)
+        and then Within (Scope (Ent), Outer_Scope)
+      then
+         Set_C_Scope;
+         Check_A_Call (N, Ent, Outer_Scope, Inter_Unit_Only => False);
+
+      elsif From_Elab_Code then
+         Set_C_Scope;
+         Check_A_Call (N, Ent, Standard_Standard, Inter_Unit_Only => False);
+
+      elsif Same_Elaboration_Scope (C_Scope, Scope (Ent)) then
+         Set_C_Scope;
+         Check_A_Call (N, Ent, Scope (Ent), Inter_Unit_Only => False);
+
+      --  If none of those cases holds, but Dynamic_Elaboration_Checks mode
+      --  is set, then we will do the check, but only in the inter-unit case
+      --  (this is to accomodate unguarded elaboration calls from other units
+      --  in which this same mode is set). We inhibit warnings in this case,
+      --  since this instantiation is not occurring in elaboration code.
+
+      elsif Dynamic_Elaboration_Checks then
+         Set_C_Scope;
+         Check_A_Call
+           (N,
+            Ent,
+            Standard_Standard,
+            Inter_Unit_Only => True,
+            Generate_Warnings => False);
+
+      else
+         return;
+      end if;
+   end Check_Elab_Instantiation;
+
+   -------------------------
+   -- Check_Internal_Call --
+   -------------------------
+
+   procedure Check_Internal_Call
+     (N           : Node_Id;
+      E           : Entity_Id;
+      Outer_Scope : Entity_Id;
+      Orig_Ent    : Entity_Id)
+   is
+      Inst_Case : constant Boolean := Nkind (N) in N_Generic_Instantiation;
+
+   begin
+      --  If not function or procedure call or instantiation, then ignore
+      --  call (this happens in some error case and rewriting cases)
+
+      if Nkind (N) /= N_Function_Call
+           and then
+         Nkind (N) /= N_Procedure_Call_Statement
+           and then
+         not Inst_Case
+      then
+         return;
+
+      --  Nothing to do if this is a call or instantiation that has
+      --  already been found to be a sure ABE
+
+      elsif ABE_Is_Certain (N) then
+         return;
+
+      --  Nothing to do if errors already detected (avoid cascaded errors)
+
+      elsif Errors_Detected /= 0 then
+         return;
+
+      --  Nothing to do if not in full analysis mode
+
+      elsif not Full_Analysis then
+         return;
+
+      --  Nothing to do if within a default expression, since the call
+      --  is not actualy being made at this time.
+
+      elsif In_Default_Expression then
+         return;
+
+      --  Nothing to do for call to intrinsic subprogram
+
+      elsif Is_Intrinsic_Subprogram (E) then
+         return;
+
+      --  No need to trace local calls if checking task activation, because
+      --  other local bodies are elaborated already.
+
+      elsif In_Task_Activation then
+         return;
+      end if;
+
+      --  Delay this call if we are still delaying calls
+
+      if Delaying_Elab_Checks then
+         Delay_Check.Increment_Last;
+         Delay_Check.Table (Delay_Check.Last) :=
+           (N              => N,
+            E              => E,
+            Orig_Ent       => Orig_Ent,
+            Curscop        => Current_Scope,
+            Outer_Scope    => Outer_Scope,
+            From_Elab_Code => From_Elab_Code);
+         return;
+
+      --  Otherwise, call phase 2 continuation right now
+
+      else
+         Check_Internal_Call_Continue (N, E, Outer_Scope, Orig_Ent);
+      end if;
+
+   end Check_Internal_Call;
+
+   ----------------------------------
+   -- Check_Internal_Call_Continue --
+   ----------------------------------
+
+   procedure Check_Internal_Call_Continue
+     (N           : Node_Id;
+      E           : Entity_Id;
+      Outer_Scope : Entity_Id;
+      Orig_Ent    : Entity_Id)
+   is
+      Loc       : constant Source_Ptr := Sloc (N);
+      Inst_Case : constant Boolean := Is_Generic_Unit (E);
+
+      Sbody : Node_Id;
+      Ebody : Entity_Id;
+
+      function Process (N : Node_Id) return Traverse_Result;
+      --  Function applied to each node as we traverse the body.
+      --  Checks for call that needs checking, and if so checks
+      --  it. Always returns OK, so entire tree is traversed.
+
+      function Process (N : Node_Id) return Traverse_Result is
+      begin
+         --  If user has specified that there are no entry calls in elaboration
+         --  code, do not trace past an accept statement, because the rendez-
+         --  vous will happen after elaboration.
+
+         if (Nkind (Original_Node (N)) = N_Accept_Statement
+              or else Nkind (Original_Node (N)) = N_Selective_Accept)
+           and then Restrictions (No_Entry_Calls_In_Elaboration_Code)
+         then
+            return Abandon;
+
+         --  If we have a subprogram call, check it
+
+         elsif Nkind (N) = N_Function_Call
+           or else Nkind (N) = N_Procedure_Call_Statement
+         then
+            Check_Elab_Call (N, Outer_Scope);
+            return OK;
+
+         --  If we have a generic instantiation, check it
+
+         elsif Nkind (N) in N_Generic_Instantiation then
+            Check_Elab_Instantiation (N, Outer_Scope);
+            return OK;
+
+         --  Skip subprogram bodies that come from source (wait for
+         --  call to analyze these). The reason for the come from
+         --  source test is to avoid catching task bodies.
+
+         --  For task bodies, we should really avoid these too, waiting
+         --  for the task activation, but that's too much trouble to
+         --  catch for now, so we go in unconditionally. This is not
+         --  so terrible, it means the error backtrace is not quite
+         --  complete, and we are too eager to scan bodies of tasks
+         --  that are unused, but this is hardly very significant!
+
+         elsif Nkind (N) = N_Subprogram_Body
+           and then Comes_From_Source (N)
+         then
+            return Skip;
+
+         else
+            return OK;
+         end if;
+      end Process;
+
+      procedure Traverse is new Atree.Traverse_Proc;
+      --  Traverse procedure using above Process function
+
+   --  Start of processing for Check_Internal_Call_Continue
+
+   begin
+      --  Save outer level call if at outer level
+
+      if Elab_Call.Last = 0 then
+         Outer_Level_Sloc := Loc;
+      end if;
+
+      Elab_Visited.Increment_Last;
+      Elab_Visited.Table (Elab_Visited.Last) := E;
+
+      --  If the call is to a function that renames a literal, no check
+      --  is needed.
+
+      if Ekind (E) = E_Enumeration_Literal then
+         return;
+      end if;
+
+      Sbody := Unit_Declaration_Node (E);
+
+      if Nkind (Sbody) /= N_Subprogram_Body
+           and then
+         Nkind (Sbody) /= N_Package_Body
+      then
+         Ebody := Corresponding_Body (Sbody);
+
+         if No (Ebody) then
+            return;
+         else
+            Sbody := Unit_Declaration_Node (Ebody);
+         end if;
+      end if;
+
+      --  If the body appears after the outer level call or
+      --  instantiation then we have an error case handled below.
+
+      if Earlier_In_Extended_Unit (Outer_Level_Sloc, Sloc (Sbody))
+        and then not In_Task_Activation
+      then
+         null;
+
+      --  If we have the instantiation case we are done, since we now
+      --  know that the body of the generic appeared earlier.
+
+      elsif Inst_Case then
+         return;
+
+      --  Otherwise we have a call, so we trace through the called
+      --  body to see if it has any problems ..
+
+      else
+         pragma Assert (Nkind (Sbody) = N_Subprogram_Body);
+
+         Elab_Call.Increment_Last;
+         Elab_Call.Table (Elab_Call.Last).Cloc := Loc;
+         Elab_Call.Table (Elab_Call.Last).Ent  := E;
+
+         if Debug_Flag_LL then
+            Write_Str ("Elab_Call.Last = ");
+            Write_Int (Int (Elab_Call.Last));
+            Write_Str ("   Ent = ");
+            Write_Name (Chars (E));
+            Write_Str ("   at ");
+            Write_Location (Sloc (N));
+            Write_Eol;
+         end if;
+
+         --  Now traverse declarations and statements of subprogram body.
+         --  Note that we cannot simply Traverse (Sbody), since traverse
+         --  does not normally visit subprogram bodies.
+
+         declare
+            Decl : Node_Id := First (Declarations (Sbody));
+
+         begin
+            while Present (Decl) loop
+               Traverse (Decl);
+               Next (Decl);
+            end loop;
+         end;
+
+         Traverse (Handled_Statement_Sequence (Sbody));
+
+         Elab_Call.Decrement_Last;
+         return;
+      end if;
+
+      --  Here is the case of calling a subprogram where the body has
+      --  not yet been encountered, a warning message is needed.
+
+      Warn_On_Instance := True;
+
+      --  If we have nothing in the call stack, then this is at the
+      --  outer level, and the ABE is bound to occur.
+
+      if Elab_Call.Last = 0 then
+
+         if Inst_Case then
+            Error_Msg_NE
+              ("?cannot instantiate& before body seen", N, Orig_Ent);
+         else
+            Error_Msg_NE
+              ("?cannot call& before body seen", N, Orig_Ent);
+         end if;
+
+         Error_Msg_N
+           ("\?Program_Error will be raised at run time", N);
+         Insert_Elab_Check (N);
+
+      --  Call is not at outer level
+
+      else
+         --  Deal with dynamic elaboration check
+
+         if not Elaboration_Checks_Suppressed (E) then
+            Set_Elaboration_Entity_Required (E);
+
+            --  Case of no elaboration entity allocated yet
+
+            if No (Elaboration_Entity (E)) then
+
+               --  Create object declaration for elaboration entity, and put it
+               --  just in front of the spec of the subprogram or generic unit,
+               --  in the same scope as this unit.
+
+               declare
+                  Loce : constant Source_Ptr := Sloc (E);
+                  Ent  : constant Entity_Id  :=
+                           Make_Defining_Identifier (Loc,
+                             Chars => New_External_Name (Chars (E), 'E'));
+
+               begin
+                  Set_Elaboration_Entity (E, Ent);
+                  New_Scope (Scope (E));
+
+                  Insert_Action (Declaration_Node (E),
+                    Make_Object_Declaration (Loce,
+                      Defining_Identifier => Ent,
+                      Object_Definition =>
+                        New_Occurrence_Of (Standard_Boolean, Loce),
+                      Expression => New_Occurrence_Of (Standard_False, Loce)));
+
+                  --  Set elaboration flag at the point of the body
+
+                  Set_Elaboration_Flag (Sbody, E);
+
+                  Pop_Scope;
+               end;
+            end if;
+
+            --  Generate check of the elaboration Boolean
+
+            Insert_Elab_Check (N,
+              New_Occurrence_Of (Elaboration_Entity (E), Loc));
+         end if;
+
+         --  Generate the warning
+
+         if not Suppress_Elaboration_Warnings (E) then
+            if Inst_Case then
+               Error_Msg_NE
+                 ("instantiation of& may occur before body is seen?",
+                  N, Orig_Ent);
+            else
+               Error_Msg_NE
+                 ("call to& may occur before body is seen?", N, Orig_Ent);
+            end if;
+
+            Error_Msg_N
+              ("\Program_Error may be raised at run time?", N);
+
+            Output_Calls (N);
+         end if;
+      end if;
+
+      Warn_On_Instance := False;
+
+      --  Set flag to suppress further warnings on same subprogram
+      --  unless in all errors mode
+
+      if not All_Errors_Mode then
+         Set_Suppress_Elaboration_Warnings (E);
+      end if;
+   end Check_Internal_Call_Continue;
+
+   ----------------------------
+   --  Check_Task_Activation --
+   ----------------------------
+
+   procedure Check_Task_Activation (N : Node_Id) is
+      Loc         : constant Source_Ptr := Sloc (N);
+      Ent         : Entity_Id;
+      P           : Entity_Id;
+      Task_Scope  : Entity_Id;
+      Cunit_SC    : Boolean := False;
+      Decl        : Node_Id;
+      Elmt        : Elmt_Id;
+      Inter_Procs : Elist_Id := New_Elmt_List;
+      Intra_Procs : Elist_Id := New_Elmt_List;
+      Enclosing   : Entity_Id;
+
+      procedure Add_Task_Proc (Typ : Entity_Id);
+      --  Add to Task_Procs the task body procedure(s) of task types in Typ.
+      --  For record types, this procedure recurses over component types.
+
+      procedure Collect_Tasks (Decls : List_Id);
+      --  Collect the types of the tasks that are to be activated in the given
+      --  list of declarations, in order to perform elaboration checks on the
+      --  corresponding task procedures which are called implicitly here.
+
+      function Outer_Unit (E : Entity_Id) return Entity_Id;
+      --  find enclosing compilation unit of Entity, ignoring subunits, or
+      --  else enclosing subprogram. If E is not a package, there is no need
+      --  for inter-unit elaboration checks.
+
+      -------------------
+      -- Add_Task_Proc --
+      -------------------
+
+      procedure Add_Task_Proc (Typ : Entity_Id) is
+         Comp : Entity_Id;
+         Proc : Entity_Id := Empty;
+
+      begin
+         if Is_Task_Type (Typ) then
+            Proc := Get_Task_Body_Procedure (Typ);
+
+         elsif Is_Array_Type (Typ)
+           and then Has_Task (Base_Type (Typ))
+         then
+            Add_Task_Proc (Component_Type (Typ));
+
+         elsif Is_Record_Type (Typ)
+           and then Has_Task (Base_Type (Typ))
+         then
+            Comp := First_Component (Typ);
+
+            while Present (Comp) loop
+               Add_Task_Proc (Etype (Comp));
+               Comp := Next_Component (Comp);
+            end loop;
+         end if;
+
+         --  If the task type is another unit, we will perform the usual
+         --  elaboration check on its enclosing unit. If the type is in the
+         --  same unit, we can trace the task body as for an internal call,
+         --  but we only need to examine other external calls, because at
+         --  the point the task is activated, internal subprogram bodies
+         --  will have been elaborated already. We keep separate lists for
+         --  each kind of task.
+
+         if Present (Proc) then
+            if Outer_Unit (Scope (Proc)) = Enclosing then
+
+               if No (Corresponding_Body (Unit_Declaration_Node (Proc)))
+                 and then
+                   (not Is_Generic_Instance (Scope (Proc))
+                      or else
+                    Scope (Proc) = Scope (Defining_Identifier (Decl)))
+               then
+                  Error_Msg_N
+                    ("task will be activated before elaboration of its body?",
+                      Decl);
+                  Error_Msg_N
+                    ("Program_Error will be raised at run-time?", Decl);
+
+               elsif
+                 Present (Corresponding_Body (Unit_Declaration_Node (Proc)))
+               then
+                  Append_Elmt (Proc, Intra_Procs);
+               end if;
+
+            else
+               Elmt := First_Elmt (Inter_Procs);
+
+               --  No need for multiple entries of the same type.
+
+               while Present (Elmt) loop
+                  if Node (Elmt) = Proc then
+                     return;
+                  end if;
+
+                  Next_Elmt (Elmt);
+               end loop;
+
+               Append_Elmt (Proc, Inter_Procs);
+            end if;
+         end if;
+      end Add_Task_Proc;
+
+      -------------------
+      -- Collect_Tasks --
+      -------------------
+
+      procedure Collect_Tasks (Decls : List_Id) is
+      begin
+         if Present (Decls) then
+            Decl := First (Decls);
+
+            while Present (Decl) loop
+
+               if Nkind (Decl) = N_Object_Declaration
+                 and then Has_Task (Etype (Defining_Identifier (Decl)))
+               then
+                  Add_Task_Proc (Etype (Defining_Identifier (Decl)));
+               end if;
+
+               Next (Decl);
+            end loop;
+         end if;
+      end Collect_Tasks;
+
+      ----------------
+      -- Outer_Unit --
+      ----------------
+
+      function Outer_Unit (E : Entity_Id) return Entity_Id is
+         Outer : Entity_Id := E;
+
+      begin
+         while Present (Outer) loop
+            if Suppress_Elaboration_Checks (Outer) then
+               Cunit_SC := True;
+            end if;
+
+            exit when Is_Child_Unit (Outer)
+              or else Scope (Outer) = Standard_Standard
+              or else Ekind (Outer) /= E_Package;
+            Outer := Scope (Outer);
+         end loop;
+
+         return Outer;
+      end Outer_Unit;
+
+   --  Start of processing for Check_Task_Activation
+
+   begin
+      Enclosing := Outer_Unit (Current_Scope);
+
+      --  Find all tasks declared in the current unit.
+
+      if Nkind (N) = N_Package_Body then
+         P := Unit_Declaration_Node (Corresponding_Spec (N));
+
+         Collect_Tasks (Declarations (N));
+         Collect_Tasks (Visible_Declarations (Specification (P)));
+         Collect_Tasks (Private_Declarations (Specification (P)));
+
+      elsif Nkind (N) = N_Package_Declaration then
+         Collect_Tasks (Visible_Declarations (Specification (N)));
+         Collect_Tasks (Private_Declarations (Specification (N)));
+
+      else
+         Collect_Tasks (Declarations (N));
+      end if;
+
+      --  We only perform detailed checks in all tasks are library level
+      --  entities. If the master is a subprogram or task, activation will
+      --  depend on the activation of the master itself.
+      --  Should dynamic checks be added in the more general case???
+
+      if Ekind (Enclosing) /= E_Package then
+         return;
+      end if;
+
+      --  For task types defined in other units, we want the unit containing
+      --  the task body to be elaborated before the current one.
+
+      Elmt := First_Elmt (Inter_Procs);
+
+      while Present (Elmt) loop
+         Ent := Node (Elmt);
+         Task_Scope := Outer_Unit (Scope (Ent));
+
+         if not Is_Compilation_Unit (Task_Scope) then
+            null;
+
+         elsif Suppress_Elaboration_Warnings (Task_Scope) then
+            null;
+
+         elsif Dynamic_Elaboration_Checks then
+            if not Elaboration_Checks_Suppressed (Ent)
+              and then not Cunit_SC
+              and then not Restrictions (No_Entry_Calls_In_Elaboration_Code)
+            then
+               --  Runtime elaboration check required. generate check of the
+               --  elaboration Boolean for the unit containing the entity.
+
+               Insert_Elab_Check (N,
+                 Make_Attribute_Reference (Loc,
+                   Attribute_Name => Name_Elaborated,
+                   Prefix =>
+                     New_Occurrence_Of
+                       (Spec_Entity (Task_Scope), Loc)));
+            end if;
+
+         else
+            --  Force the binder to elaborate other unit first.
+
+            if not Suppress_Elaboration_Warnings (Ent)
+              and then Elab_Warnings
+              and then not Suppress_Elaboration_Warnings (Task_Scope)
+            then
+               Error_Msg_Node_2 := Task_Scope;
+               Error_Msg_NE ("activation of an instance of task type&" &
+                  " requires pragma Elaborate_All on &?", N, Ent);
+            end if;
+
+            Set_Elaborate_All_Desirable (Task_Scope);
+            Set_Suppress_Elaboration_Warnings (Task_Scope);
+         end if;
+
+         Next_Elmt (Elmt);
+      end loop;
+
+      --  For tasks declared in the current unit, trace other calls within
+      --  the task procedure bodies, which are available.
+
+      In_Task_Activation := True;
+      Elmt := First_Elmt (Intra_Procs);
+
+      while Present (Elmt) loop
+         Ent := Node (Elmt);
+         Check_Internal_Call_Continue (N, Ent, Enclosing, Ent);
+         Next_Elmt (Elmt);
+      end loop;
+
+      In_Task_Activation := False;
+   end Check_Task_Activation;
+
+   ----------------------
+   -- Has_Generic_Body --
+   ----------------------
+
+   function Has_Generic_Body (N : Node_Id) return Boolean is
+      Ent  : constant Entity_Id := Entity (Name (N));
+      Decl : constant Node_Id   := Unit_Declaration_Node (Ent);
+      Scop : Entity_Id;
+
+      function Find_Body_In (E : Entity_Id; N : Node_Id) return Node_Id;
+      --  Determine if the list of nodes headed by N and linked by Next
+      --  contains a package body for the package spec entity E, and if
+      --  so return the package body. If not, then returns Empty.
+
+      function Load_Package_Body (Nam : Unit_Name_Type) return Node_Id;
+      --  This procedure is called load the unit whose name is given by Nam.
+      --  This unit is being loaded to see whether it contains an optional
+      --  generic body. The returned value is the loaded unit, which is
+      --  always a package body (only package bodies can contain other
+      --  entities in the sense in which Has_Generic_Body is interested).
+      --  We only attempt to load bodies if we are generating code. If we
+      --  are in semantics check only mode, then it would be wrong to load
+      --  bodies that are not required from a semantic point of view, so
+      --  in this case we return Empty. The result is that the caller may
+      --  incorrectly decide that a generic spec does not have a body when
+      --  in fact it does, but the only harm in this is that some warnings
+      --  on elaboration problems may be lost in semantic checks only mode,
+      --  which is not big loss. We also return Empty if we go for a body
+      --  and it is not there.
+
+      function Locate_Corresponding_Body (PE : Entity_Id) return Node_Id;
+      --  PE is the entity for a package spec. This function locates the
+      --  corresponding package body, returning Empty if none is found.
+      --  The package body returned is fully parsed but may not yet be
+      --  analyzed, so only syntactic fields should be referenced.
+
+      ------------------
+      -- Find_Body_In --
+      ------------------
+
+      function Find_Body_In (E : Entity_Id; N : Node_Id) return Node_Id is
+         Nod : Node_Id;
+
+      begin
+         Nod := N;
+         while Present (Nod) loop
+
+            --  If we found the package body we are looking for, return it
+
+            if Nkind (Nod) = N_Package_Body
+              and then Chars (Defining_Unit_Name (Nod)) = Chars (E)
+            then
+               return Nod;
+
+            --  If we found the stub for the body, go after the subunit,
+            --  loading it if necessary.
+
+            elsif Nkind (Nod) = N_Package_Body_Stub
+              and then Chars (Defining_Identifier (Nod)) = Chars (E)
+            then
+               if Present (Library_Unit (Nod)) then
+                  return Unit (Library_Unit (Nod));
+
+               else
+                  return Load_Package_Body (Get_Unit_Name (Nod));
+               end if;
+
+            --  If neither package body nor stub, keep looking on chain
+
+            else
+               Next (Nod);
+            end if;
+         end loop;
+
+         return Empty;
+      end Find_Body_In;
+
+      -----------------------
+      -- Load_Package_Body --
+      -----------------------
+
+      function Load_Package_Body (Nam : Unit_Name_Type) return Node_Id is
+         U : Unit_Number_Type;
+
+      begin
+         if Operating_Mode /= Generate_Code then
+            return Empty;
+         else
+            U :=
+              Load_Unit
+                (Load_Name  => Nam,
+                 Required   => False,
+                 Subunit    => False,
+                 Error_Node => N);
+
+            if U = No_Unit then
+               return Empty;
+            else
+               return Unit (Cunit (U));
+            end if;
+         end if;
+      end Load_Package_Body;
+
+      -------------------------------
+      -- Locate_Corresponding_Body --
+      -------------------------------
+
+      function Locate_Corresponding_Body (PE : Entity_Id) return Node_Id is
+         Spec  : constant Node_Id   := Declaration_Node (PE);
+         Decl  : constant Node_Id   := Parent (Spec);
+         Scop  : constant Entity_Id := Scope (PE);
+         PBody : Node_Id;
+
+      begin
+         if Is_Library_Level_Entity (PE) then
+
+            --  If package is a library unit that requires a body, we have
+            --  no choice but to go after that body because it might contain
+            --  an optional body for the original generic package.
+
+            if Unit_Requires_Body (PE) then
+
+               --  Load the body. Note that we are a little careful here to
+               --  use Spec to get the unit number, rather than PE or Decl,
+               --  since in the case where the package is itself a library
+               --  level instantiation, Spec will properly reference the
+               --  generic template, which is what we really want.
+
+               return
+                 Load_Package_Body
+                   (Get_Body_Name (Unit_Name (Get_Source_Unit (Spec))));
+
+            --  But if the package is a library unit that does NOT require
+            --  a body, then no body is permitted, so we are sure that there
+            --  is no body for the original generic package.
+
+            else
+               return Empty;
+            end if;
+
+         --  Otherwise look and see if we are embedded in a further package
+
+         elsif Is_Package (Scop) then
+
+            --  If so, get the body of the enclosing package, and look in
+            --  its package body for the package body we are looking for.
+
+            PBody := Locate_Corresponding_Body (Scop);
+
+            if No (PBody) then
+               return Empty;
+            else
+               return Find_Body_In (PE, First (Declarations (PBody)));
+            end if;
+
+         --  If we are not embedded in a further package, then the body
+         --  must be in the same declarative part as we are.
+
+         else
+            return Find_Body_In (PE, Next (Decl));
+         end if;
+      end Locate_Corresponding_Body;
+
+   --  Start of processing for Has_Generic_Body
+
+   begin
+      if Present (Corresponding_Body (Decl)) then
+         return True;
+
+      elsif Unit_Requires_Body (Ent) then
+         return True;
+
+      --  Compilation units cannot have optional bodies
+
+      elsif Is_Compilation_Unit (Ent) then
+         return False;
+
+      --  Otherwise look at what scope we are in
+
+      else
+         Scop := Scope (Ent);
+
+         --  Case of entity is in other than a package spec, in this case
+         --  the body, if present, must be in the same declarative part.
+
+         if not Is_Package (Scop) then
+            declare
+               P : Node_Id;
+
+            begin
+               P := Declaration_Node (Ent);
+
+               --  Declaration node may get us a spec, so if so, go to
+               --  the parent declaration.
+
+               while not Is_List_Member (P) loop
+                  P := Parent (P);
+               end loop;
+
+               return Present (Find_Body_In (Ent, Next (P)));
+            end;
+
+         --  If the entity is in a package spec, then we have to locate
+         --  the corresponding package body, and look there.
+
+         else
+            declare
+               PBody : constant Node_Id := Locate_Corresponding_Body (Scop);
+
+            begin
+               if No (PBody) then
+                  return False;
+               else
+                  return
+                    Present
+                      (Find_Body_In (Ent, (First (Declarations (PBody)))));
+               end if;
+            end;
+         end if;
+      end if;
+   end Has_Generic_Body;
+
+   -----------------------
+   -- Insert_Elab_Check --
+   -----------------------
+
+   procedure Insert_Elab_Check (N : Node_Id; C : Node_Id := Empty) is
+      Nod : Node_Id;
+      Loc : constant Source_Ptr := Sloc (N);
+
+   begin
+      --  If expansion is disabled, do not generate any checks. Also
+      --  skip checks if any subunits are missing because in either
+      --  case we lack the full information that we need, and no object
+      --  file will be created in any case.
+
+      if not Expander_Active or else Subunits_Missing then
+         return;
+      end if;
+
+      --  If we have a generic instantiation, where Instance_Spec is set,
+      --  then this field points to a generic instance spec that has
+      --  been inserted before the instantiation node itself, so that
+      --  is where we want to insert a check.
+
+      if Nkind (N) in N_Generic_Instantiation
+        and then Present (Instance_Spec (N))
+      then
+         Nod := Instance_Spec (N);
+      else
+         Nod := N;
+      end if;
+
+      --  If we are inserting at the top level, insert in Aux_Decls
+
+      if Nkind (Parent (Nod)) = N_Compilation_Unit then
+         declare
+            ADN : constant Node_Id := Aux_Decls_Node (Parent (Nod));
+            R   : Node_Id;
+
+         begin
+            if No (C) then
+               R :=  Make_Raise_Program_Error (Loc);
+            else
+               R := Make_Raise_Program_Error (Loc, Make_Op_Not (Loc, C));
+            end if;
+
+            if No (Declarations (ADN)) then
+               Set_Declarations (ADN, New_List (R));
+            else
+               Append_To (Declarations (ADN), R);
+            end if;
+
+            Analyze (R);
+         end;
+
+      --  Otherwise just insert before the node in question. However, if
+      --  the context of the call has already been analyzed, an insertion
+      --  will not work if it depends on subsequent expansion (e.g. a call in
+      --  a branch of a short-circuit). In that case we replace the call with
+      --  a conditional expression, or with a Raise if it is unconditional.
+      --  Unfortunately this does not work if the call has a dynamic size,
+      --  because gigi regards it as a dynamic-sized temporary. If such a call
+      --  appears in a short-circuit expression, the elaboration check will be
+      --  missed (rare enough ???).
+
+      else
+         if Nkind (N) = N_Function_Call
+           and then Analyzed (Parent (N))
+           and then Size_Known_At_Compile_Time (Etype (N))
+         then
+            declare
+               Typ : constant Entity_Id := Etype (N);
+               R   : constant Node_Id   := Make_Raise_Program_Error (Loc);
+               Chk : constant Boolean   := Do_Range_Check (N);
+
+            begin
+               Set_Etype (R, Typ);
+
+               if No (C) then
+                  Rewrite (N, R);
+
+               else
+                  Rewrite (N,
+                    Make_Conditional_Expression (Loc,
+                      Expressions => New_List (C, Relocate_Node (N), R)));
+               end if;
+
+               Analyze_And_Resolve (N, Typ);
+
+               --  If the original call requires a range check, so does the
+               --  conditional expression.
+
+               if Chk then
+                  Enable_Range_Check (N);
+               else
+                  Set_Do_Range_Check (N, False);
+               end if;
+            end;
+
+         else
+            if No (C) then
+               Insert_Action (Nod,
+                  Make_Raise_Program_Error (Loc));
+            else
+               Insert_Action (Nod,
+                  Make_Raise_Program_Error (Loc,
+                    Condition =>
+                      Make_Op_Not (Loc,
+                        Right_Opnd => C)));
+            end if;
+         end if;
+      end if;
+   end Insert_Elab_Check;
+
+   ------------------
+   -- Output_Calls --
+   ------------------
+
+   procedure Output_Calls (N : Node_Id) is
+      Ent : Entity_Id;
+
+      function Is_Printable_Error_Name (Nm : Name_Id) return Boolean;
+      --  An internal function, used to determine if a name, Nm, is either
+      --  a non-internal name, or is an internal name that is printable
+      --  by the error message circuits (i.e. it has a single upper
+      --  case letter at the end).
+
+      function Is_Printable_Error_Name (Nm : Name_Id) return Boolean is
+      begin
+         if not Is_Internal_Name (Nm) then
+            return True;
+
+         elsif Name_Len = 1 then
+            return False;
+
+         else
+            Name_Len := Name_Len - 1;
+            return not Is_Internal_Name;
+         end if;
+      end Is_Printable_Error_Name;
+
+   --  Start of processing for Output_Calls
+
+   begin
+      for J in reverse 1 .. Elab_Call.Last loop
+         Error_Msg_Sloc := Elab_Call.Table (J).Cloc;
+
+         Ent := Elab_Call.Table (J).Ent;
+
+         if Is_Generic_Unit (Ent) then
+            Error_Msg_NE ("\?& instantiated #", N, Ent);
+
+         elsif Chars (Ent) = Name_uInit_Proc then
+            Error_Msg_N ("\?initialization procedure called #", N);
+
+         elsif Is_Printable_Error_Name (Chars (Ent)) then
+            Error_Msg_NE ("\?& called #", N, Ent);
+
+         else
+            Error_Msg_N ("\? called #", N);
+         end if;
+      end loop;
+   end Output_Calls;
+
+   ----------------------------
+   -- Same_Elaboration_Scope --
+   ----------------------------
+
+   function Same_Elaboration_Scope (Scop1, Scop2 : Entity_Id) return Boolean is
+      S1 : Entity_Id := Scop1;
+      S2 : Entity_Id := Scop2;
+
+   begin
+      while S1 /= Standard_Standard
+        and then (Ekind (S1) = E_Package
+                    or else
+                  Ekind (S1) = E_Block)
+      loop
+         S1 := Scope (S1);
+      end loop;
+
+      while S2 /= Standard_Standard
+        and then (Ekind (S2) = E_Package
+                    or else
+                  Ekind (S2) = E_Protected_Type
+                    or else
+                  Ekind (S2) = E_Block)
+      loop
+         S2 := Scope (S2);
+      end loop;
+
+      return S1 = S2;
+   end Same_Elaboration_Scope;
+
+   -----------------
+   -- Set_C_Scope --
+   -----------------
+
+   procedure Set_C_Scope is
+   begin
+      while not Is_Compilation_Unit (C_Scope) loop
+         C_Scope := Scope (C_Scope);
+      end loop;
+   end Set_C_Scope;
+
+   -----------------
+   -- Spec_Entity --
+   -----------------
+
+   function Spec_Entity (E : Entity_Id) return Entity_Id is
+      Decl : Node_Id;
+
+   begin
+      --  Check for case of body entity
+      --  Why is the check for E_Void needed???
+
+      if Ekind (E) = E_Void
+        or else Ekind (E) = E_Subprogram_Body
+        or else Ekind (E) = E_Package_Body
+      then
+         Decl := E;
+
+         loop
+            Decl := Parent (Decl);
+            exit when Nkind (Decl) in N_Proper_Body;
+         end loop;
+
+         return Corresponding_Spec (Decl);
+
+      else
+         return E;
+      end if;
+   end Spec_Entity;
+
+   -------------------
+   -- Supply_Bodies --
+   -------------------
+
+   procedure Supply_Bodies (N : Node_Id) is
+   begin
+      if Nkind (N) = N_Subprogram_Declaration then
+         declare
+            Ent : constant Entity_Id := Defining_Unit_Name (Specification (N));
+
+         begin
+            Set_Is_Imported (Ent);
+            Set_Convention  (Ent, Convention_Stubbed);
+         end;
+
+      elsif Nkind (N) = N_Package_Declaration then
+         declare
+            Spec : constant Node_Id := Specification (N);
+
+         begin
+            New_Scope (Defining_Unit_Name (Spec));
+            Supply_Bodies (Visible_Declarations (Spec));
+            Supply_Bodies (Private_Declarations (Spec));
+            Pop_Scope;
+         end;
+      end if;
+   end Supply_Bodies;
+
+   procedure Supply_Bodies (L : List_Id) is
+      Elmt : Node_Id;
+
+   begin
+      if Present (L) then
+         Elmt := First (L);
+         while Present (Elmt) loop
+            Supply_Bodies (Elmt);
+            Next (Elmt);
+         end loop;
+      end if;
+   end Supply_Bodies;
+
+   ------------
+   -- Within --
+   ------------
+
+   function Within (E1, E2 : Entity_Id) return Boolean is
+      Scop : Entity_Id;
+
+   begin
+      Scop := E1;
+
+      loop
+         if Scop = E2 then
+            return True;
+
+         elsif Scop = Standard_Standard then
+            return False;
+
+         else
+            Scop := Scope (Scop);
+         end if;
+      end loop;
+
+      raise Program_Error;
+   end Within;
+
+end Sem_Elab;
diff --git a/gcc/ada/sem_elab.ads b/gcc/ada/sem_elab.ads
new file mode 100644
index 00000000000..87071c2005f
--- /dev/null
+++ b/gcc/ada/sem_elab.ads
@@ -0,0 +1,156 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             S E M _ E L A B                              --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.8 $
+--                                                                          --
+--          Copyright (C) 1997-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 contains the routines used to deal with issuing warnings
+--  for cases of calls that may require warnings about possible access
+--  before elaboration.
+
+with Types; use Types;
+
+package Sem_Elab is
+
+   -----------------------------
+   -- Description of Approach --
+   -----------------------------
+
+   --  Every non-static call that is encountered by Sem_Res results in
+   --  a call to Check_Elab_Call, with N being the call node, and Outer
+   --  set to its default value of True.
+
+   --  The goal of Check_Elab_Call is to determine whether or not the
+   --  call in question can generate an access before elaboration
+   --  error (raising Program_Error) either by directly calling a
+   --  subprogram whose body has not yet been elaborated, or indirectly,
+   --  by calling a subprogram whose body has been elaborated, but which
+   --  contains a call to such a subprogram.
+
+   --  The only calls that we need to look at at the outer level are
+   --  calls that occur in elaboration code. There are two cases. The
+   --  call can be at the outer level of elaboration code, or it can
+   --  be within another unit, e.g. the elaboration code of a subprogram.
+
+   --  In the case of an elaboration call at the outer level, we must
+   --  trace all calls to outer level routines either within the current
+   --  unit or to other units that are with'ed. For calls within the
+   --  current unit, we can determine if the body has been elaborated
+   --  or not, and if it has not, then a warning is generated.
+
+   --  Note that there are two subcases. If the original call directly
+   --  calls a subprogram whose body has not been elaborated, then we
+   --  know that an ABE will take place, and we replace the call by
+   --  a raise of Program_Error. If the call is indirect, then we don't
+   --  know that the PE will be raised, since the call might be guarded
+   --  by a conditional. In this case we set Do_Elab_Check on the call
+   --  so that a dynamic check is generated, and output a warning.
+
+   --  For calls to a subprogram in a with'ed unit, we require that
+   --  a pragma Elaborate_All or pragma Elaborate be present, or that
+   --  the referenced unit have a pragma Preelaborate, pragma Pure, or
+   --  pragma Elaborate_Body. If none of these conditions is met, then
+   --  a warning is generated that a pragma Elaborate_All may be needed.
+
+   --  For the case of an elaboration call at some inner level, we are
+   --  interested in tracing only calls to subprograms at the same level,
+   --  i.e. those that can be called during elaboration. Any calls to
+   --  outer level routines cannot cause ABE's as a result of the original
+   --  call (there might be an outer level call to the subprogram from
+   --  outside that causes the ABE, but that gets analyzed separately).
+
+   --  Note that we never trace calls to inner level subprograms, since
+   --  these cannot result in ABE's unless there is an elaboration problem
+   --  at a lower level, which will be separately detected.
+
+   --  Note on pragma Elaborate. The checking here assumes that a pragma
+   --  Elaborate on a with'ed unit guarantees that subprograms within the
+   --  unit can be called without causing an ABE. This is not in fact the
+   --  case since pragma Elaborate does not guarantee the transititive
+   --  coverage guaranteed by Elaborate_All. However, we leave this issue
+   --  up to the binder, which has generates warnings if there are possible
+   --  problems in the use of pragma Elaborate.
+
+   --------------------------------------
+   -- Instantiation Elaboration Errors --
+   --------------------------------------
+
+   --  A special case arises when an instantiation appears in a context
+   --  that is known to be before the body is elaborated, e.g.
+
+   --       generic package x is ...
+   --       ...
+   --       package xx is new x;
+   --       ...
+   --       package body x is ...
+
+   --  In this situation it is certain that an elaboration error will
+   --  occur, and an unconditional raise Program_Error statement is
+   --  inserted before the instantiation, and a warning generated.
+
+   --  The problem is that in this case we have no place to put the
+   --  body of the instantiation. We can't put it in the normal place,
+   --  because it is too early, and will cause errors to occur as a
+   --  result of referencing entities before they are declared.
+
+   --  Our approach in this case is simply to avoid creating the body
+   --  of the instantiation in such a case. The instantiation spec is
+   --  modified to include dummy bodies for all subprograms, so that
+   --  the resulting code does not contain subprogram specs with no
+   --  corresponding bodies.
+
+   procedure Check_Elab_Call (N : Node_Id; Outer_Scope : Entity_Id := Empty);
+   --  Check a call for possible elaboration problems. N is either an
+   --  N_Function_Call or N_Procedure_Call_Statement node, and Outer
+   --  indicates whether this is an outer level call from Sem_Res
+   --  (Outer_Scope set to Empty), or an internal recursive call
+   --  (Outer_Scope set to entity of outermost call, see body).
+
+   procedure Check_Elab_Calls;
+   --  Not all the processing for Check_Elab_Call can be done at the time
+   --  of calls to Check_Elab_Call. This is because for internal calls, we
+   --  need to wait to complete the check until all generic bodies have been
+   --  instantiated. The Check_Elab_Calls procedure cleans up these waiting
+   --  checks. It is called once after the completion of instantiation.
+
+   procedure Check_Elab_Instantiation
+     (N           : Node_Id;
+      Outer_Scope : Entity_Id := Empty);
+   --  Check an instantiation for possible elaboration problems. N is an
+   --  instantiation node (N_Package_Instantiation, N_Function_Instantiation,
+   --  or N_Procedure_Instantiation), and Outer_Scope indicates if this is
+   --  an outer level call from Sem_Ch12 (Outer_Scope set to Empty), or an
+   --  internal recursive call (Outer_Scope set to scope of outermost call,
+   --  see body for further details). The returned value is relevant only
+   --  for an outer level call, and is set to False if an elaboration error
+   --  is bound to occur on the instantiation, and True otherwise. This is
+   --  used by the caller to signal that the body of the instance should
+   --  not be generated (see detailed description in body).
+
+   procedure Check_Task_Activation (N : Node_Id);
+   --  at the point at which tasks are activated in a package body, check
+   --  that the bodies of the tasks are elaborated.
+
+end Sem_Elab;
diff --git a/gcc/ada/sem_elim.adb b/gcc/ada/sem_elim.adb
new file mode 100644
index 00000000000..e418657ec09
--- /dev/null
+++ b/gcc/ada/sem_elim.adb
@@ -0,0 +1,557 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             S E M _ E L I M                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.13 $
+--                                                                          --
+--          Copyright (C) 1997-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 Einfo;   use Einfo;
+with Errout;  use Errout;
+with Namet;   use Namet;
+with Nlists;  use Nlists;
+with Sinfo;   use Sinfo;
+with Snames;  use Snames;
+with Stand;   use Stand;
+with Stringt; use Stringt;
+
+with GNAT.HTable; use GNAT.HTable;
+package body Sem_Elim is
+
+   No_Elimination : Boolean;
+   --  Set True if no Eliminate pragmas active
+
+   ---------------------
+   -- Data Structures --
+   ---------------------
+
+   --  A single pragma Eliminate is represented by the following record
+
+   type Elim_Data;
+   type Access_Elim_Data is access Elim_Data;
+
+   type Names is array (Nat range <>) of Name_Id;
+   --  Type used to represent set of names. Used for names in Unit_Name
+   --  and also the set of names in Argument_Types.
+
+   type Access_Names is access Names;
+
+   type Elim_Data is record
+
+      Unit_Name : Access_Names;
+      --  Unit name, broken down into a set of names (e.g. A.B.C is
+      --  represented as Name_Id values for A, B, C in sequence).
+
+      Entity_Name : Name_Id;
+      --  Entity name if Entity parameter if present. If no Entity parameter
+      --  was supplied, then Entity_Node is set to Empty, and the Entity_Name
+      --  field contains the last identifier name in the Unit_Name.
+
+      Entity_Scope : Access_Names;
+      --  Static scope of the entity within the compilation unit represented by
+      --  Unit_Name.
+
+      Entity_Node : Node_Id;
+      --  Save node of entity argument, for posting error messages. Set
+      --  to Empty if there is no entity argument.
+
+      Parameter_Types : Access_Names;
+      --  Set to set of names given for parameter types. If no parameter
+      --  types argument is present, this argument is set to null.
+
+      Result_Type : Name_Id;
+      --  Result type name if Result_Types parameter present, No_Name if not
+
+      Hash_Link : Access_Elim_Data;
+      --  Link for hash table use
+
+      Homonym : Access_Elim_Data;
+      --  Pointer to next entry with same key
+
+   end record;
+
+   ----------------
+   -- Hash_Table --
+   ----------------
+
+   --  Setup hash table using the Entity_Name field as the hash key
+
+   subtype Element is Elim_Data;
+   subtype Elmt_Ptr is Access_Elim_Data;
+
+   subtype Key is Name_Id;
+
+   type Header_Num is range 0 .. 1023;
+
+   Null_Ptr : constant Elmt_Ptr := null;
+
+   ----------------------
+   -- Hash_Subprograms --
+   ----------------------
+
+   package Hash_Subprograms is
+
+      function Equal (F1, F2 : Key) return Boolean;
+      pragma Inline (Equal);
+
+      function Get_Key (E : Elmt_Ptr) return Key;
+      pragma Inline (Get_Key);
+
+      function Hash (F : Key) return Header_Num;
+      pragma Inline (Hash);
+
+      function Next (E : Elmt_Ptr) return Elmt_Ptr;
+      pragma Inline (Next);
+
+      procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr);
+      pragma Inline (Set_Next);
+
+   end Hash_Subprograms;
+
+   package body Hash_Subprograms is
+
+      -----------
+      -- Equal --
+      -----------
+
+      function Equal (F1, F2 : Key) return Boolean is
+      begin
+         return F1 = F2;
+      end Equal;
+
+      -------------
+      -- Get_Key --
+      -------------
+
+      function Get_Key (E : Elmt_Ptr) return Key is
+      begin
+         return E.Entity_Name;
+      end Get_Key;
+
+      ----------
+      -- Hash --
+      ----------
+
+      function Hash (F : Key) return Header_Num is
+      begin
+         return Header_Num (Int (F) mod 1024);
+      end Hash;
+
+      ----------
+      -- Next --
+      ----------
+
+      function Next (E : Elmt_Ptr) return Elmt_Ptr is
+      begin
+         return E.Hash_Link;
+      end Next;
+
+      --------------
+      -- Set_Next --
+      --------------
+
+      procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr) is
+      begin
+         E.Hash_Link := Next;
+      end Set_Next;
+   end Hash_Subprograms;
+
+   package Elim_Hash_Table is new Static_HTable (
+      Header_Num => Header_Num,
+      Element    => Element,
+      Elmt_Ptr   => Elmt_Ptr,
+      Null_Ptr   => Null_Ptr,
+      Set_Next   => Hash_Subprograms.Set_Next,
+      Next       => Hash_Subprograms.Next,
+      Key        => Key,
+      Get_Key    => Hash_Subprograms.Get_Key,
+      Hash       => Hash_Subprograms.Hash,
+      Equal      => Hash_Subprograms.Equal);
+
+   ----------------------
+   -- Check_Eliminated --
+   ----------------------
+
+   procedure Check_Eliminated (E : Entity_Id) is
+      Elmt : Access_Elim_Data;
+      Scop : Entity_Id;
+      Form : Entity_Id;
+
+   begin
+      if No_Elimination then
+         return;
+
+      --  Elimination of objects and types is not implemented yet.
+
+      elsif Ekind (E) not in Subprogram_Kind then
+         return;
+      end if;
+
+      Elmt := Elim_Hash_Table.Get (Chars (E));
+
+      --  Loop through homonyms for this key
+
+      while Elmt /= null loop
+
+         --  First we check that the name of the entity matches
+
+         if Elmt.Entity_Name /= Chars (E) then
+            goto Continue;
+         end if;
+
+         --  Then we need to see if the static scope matches within the
+         --  compilation unit.
+
+         Scop := Scope (E);
+         if Elmt.Entity_Scope /= null then
+            for J in reverse Elmt.Entity_Scope'Range loop
+               if Elmt.Entity_Scope (J) /= Chars (Scop) then
+                  goto Continue;
+               end if;
+
+               Scop := Scope (Scop);
+
+               if not Is_Compilation_Unit (Scop) and then J = 1 then
+                  goto Continue;
+               end if;
+            end loop;
+         end if;
+
+         --  Now see if compilation unit matches
+
+         for J in reverse Elmt.Unit_Name'Range loop
+            if Elmt.Unit_Name (J) /= Chars (Scop) then
+               goto Continue;
+            end if;
+
+            Scop := Scope (Scop);
+
+            if Scop /= Standard_Standard and then J = 1 then
+               goto Continue;
+            end if;
+         end loop;
+
+         if Scop /= Standard_Standard then
+            goto Continue;
+         end if;
+
+         --  Check for case of given entity is a library level subprogram
+         --  and we have the single parameter Eliminate case, a match!
+
+         if Is_Compilation_Unit (E)
+           and then Is_Subprogram (E)
+           and then No (Elmt.Entity_Node)
+         then
+            Set_Is_Eliminated (E);
+            return;
+
+         --  Check for case of type or object with two parameter case
+
+         elsif (Is_Type (E) or else Is_Object (E))
+           and then Elmt.Result_Type = No_Name
+           and then Elmt.Parameter_Types = null
+         then
+            Set_Is_Eliminated (E);
+            return;
+
+         --  Check for case of subprogram
+
+         elsif Ekind (E) = E_Function
+           or else Ekind (E) = E_Procedure
+         then
+            --  Two parameter case always matches
+
+            if Elmt.Result_Type = No_Name
+              and then Elmt.Parameter_Types = null
+            then
+               Set_Is_Eliminated (E);
+               return;
+
+            --  Here we have a profile, so see if it matches
+
+            else
+               if Ekind (E) = E_Function then
+                  if Chars (Etype (E)) /= Elmt.Result_Type then
+                     goto Continue;
+                  end if;
+               end if;
+
+               Form := First_Formal (E);
+
+               if No (Form) and then Elmt.Parameter_Types = null then
+                  Set_Is_Eliminated (E);
+                  return;
+
+               elsif Elmt.Parameter_Types = null then
+                  goto Continue;
+
+               else
+                  for J in Elmt.Parameter_Types'Range loop
+                     if No (Form)
+                       or else Chars (Etype (Form)) /= Elmt.Parameter_Types (J)
+                     then
+                        goto Continue;
+                     else
+                        Next_Formal (Form);
+                     end if;
+                  end loop;
+
+                  if Present (Form) then
+                     goto Continue;
+                  else
+                     Set_Is_Eliminated (E);
+                     return;
+                  end if;
+               end if;
+            end if;
+         end if;
+
+         <<Continue>> Elmt := Elmt.Homonym;
+      end loop;
+
+      return;
+   end Check_Eliminated;
+
+   ----------------
+   -- Initialize --
+   ----------------
+
+   procedure Initialize is
+   begin
+      Elim_Hash_Table.Reset;
+      No_Elimination := True;
+   end Initialize;
+
+   ------------------------------
+   -- Process_Eliminate_Pragma --
+   ------------------------------
+
+   procedure Process_Eliminate_Pragma
+     (Arg_Unit_Name       : Node_Id;
+      Arg_Entity          : Node_Id;
+      Arg_Parameter_Types : Node_Id;
+      Arg_Result_Type     : Node_Id)
+   is
+      Argx_Unit_Name       : Node_Id;
+      Argx_Entity          : Node_Id;
+      Argx_Parameter_Types : Node_Id;
+      Argx_Result_Type     : Node_Id;
+
+      Data : constant Access_Elim_Data := new Elim_Data;
+      --  Build result data here
+
+      Elmt : Access_Elim_Data;
+
+      Num_Names : Nat := 0;
+      --  Number of names in unit name
+
+      Lit : Node_Id;
+
+      function OK_Selected_Component (N : Node_Id) return Boolean;
+      --  Test if N is a selected component with all identifiers, or a
+      --  selected component whose selector is an operator symbol. As a
+      --  side effect if result is True, sets Num_Names to the number
+      --  of names present (identifiers and operator if any).
+
+      ---------------------------
+      -- OK_Selected_Component --
+      ---------------------------
+
+      function OK_Selected_Component (N : Node_Id) return Boolean is
+      begin
+         if Nkind (N) = N_Identifier
+           or else Nkind (N) = N_Operator_Symbol
+         then
+            Num_Names := Num_Names + 1;
+            return True;
+
+         elsif Nkind (N) = N_Selected_Component then
+            return OK_Selected_Component (Prefix (N))
+              and then OK_Selected_Component (Selector_Name (N));
+
+         else
+            return False;
+         end if;
+      end OK_Selected_Component;
+
+   --  Start of processing for Process_Eliminate_Pragma
+
+   begin
+      Error_Msg_Name_1 := Name_Eliminate;
+
+      --  Process Unit_Name argument
+
+      Argx_Unit_Name := Expression (Arg_Unit_Name);
+
+      if Nkind (Argx_Unit_Name) = N_Identifier then
+         Data.Unit_Name := new Names'(1 => Chars (Argx_Unit_Name));
+         Num_Names := 1;
+
+      elsif OK_Selected_Component (Argx_Unit_Name) then
+         Data.Unit_Name := new Names (1 .. Num_Names);
+
+         for J in reverse 2 .. Num_Names loop
+            Data.Unit_Name (J) := Chars (Selector_Name (Argx_Unit_Name));
+            Argx_Unit_Name := Prefix (Argx_Unit_Name);
+         end loop;
+
+         Data.Unit_Name (1) := Chars (Argx_Unit_Name);
+
+      else
+         Error_Msg_N
+           ("wrong form for Unit_Name parameter of pragma%",
+            Argx_Unit_Name);
+         return;
+      end if;
+
+      --  Process Entity argument
+
+      if Present (Arg_Entity) then
+         Argx_Entity := Expression (Arg_Entity);
+         Num_Names := 0;
+
+         if Nkind (Argx_Entity) = N_Identifier
+           or else Nkind (Argx_Entity) = N_Operator_Symbol
+         then
+            Data.Entity_Name  := Chars (Argx_Entity);
+            Data.Entity_Node  := Argx_Entity;
+            Data.Entity_Scope := null;
+
+         elsif OK_Selected_Component (Argx_Entity) then
+            Data.Entity_Scope := new Names (1 .. Num_Names - 1);
+            Data.Entity_Name  := Chars (Selector_Name (Argx_Entity));
+            Data.Entity_Node  := Argx_Entity;
+
+            Argx_Entity := Prefix (Argx_Entity);
+            for J in reverse 2 .. Num_Names - 1 loop
+               Data.Entity_Scope (J) := Chars (Selector_Name (Argx_Entity));
+               Argx_Entity := Prefix (Argx_Entity);
+            end loop;
+
+            Data.Entity_Scope (1) := Chars (Argx_Entity);
+
+         elsif Nkind (Argx_Entity) = N_String_Literal then
+            String_To_Name_Buffer (Strval (Argx_Entity));
+            Data.Entity_Name := Name_Find;
+            Data.Entity_Node := Argx_Entity;
+
+         else
+            Error_Msg_N
+              ("wrong form for Entity_Argument parameter of pragma%",
+              Argx_Unit_Name);
+            return;
+         end if;
+      else
+         Data.Entity_Node := Empty;
+         Data.Entity_Name := Data.Unit_Name (Num_Names);
+      end if;
+
+      --  Process Parameter_Types argument
+
+      if Present (Arg_Parameter_Types) then
+         Argx_Parameter_Types := Expression (Arg_Parameter_Types);
+
+         --  Case of one name, which looks like a parenthesized literal
+         --  rather than an aggregate.
+
+         if Nkind (Argx_Parameter_Types) = N_String_Literal
+           and then Paren_Count (Argx_Parameter_Types) = 1
+         then
+            String_To_Name_Buffer (Strval (Argx_Parameter_Types));
+            Data.Parameter_Types := new Names'(1 => Name_Find);
+
+         --  Otherwise must be an aggregate
+
+         elsif Nkind (Argx_Parameter_Types) /= N_Aggregate
+           or else Present (Component_Associations (Argx_Parameter_Types))
+           or else No (Expressions (Argx_Parameter_Types))
+         then
+            Error_Msg_N
+              ("Parameter_Types for pragma% must be list of string literals",
+               Argx_Parameter_Types);
+            return;
+
+         --  Here for aggregate case
+
+         else
+            Data.Parameter_Types :=
+              new Names
+                (1 .. List_Length (Expressions (Argx_Parameter_Types)));
+
+            Lit := First (Expressions (Argx_Parameter_Types));
+            for J in Data.Parameter_Types'Range loop
+               if Nkind (Lit) /= N_String_Literal then
+                  Error_Msg_N
+                    ("parameter types for pragma% must be string literals",
+                     Lit);
+                  return;
+               end if;
+
+               String_To_Name_Buffer (Strval (Lit));
+               Data.Parameter_Types (J) := Name_Find;
+               Next (Lit);
+            end loop;
+         end if;
+      end if;
+
+      --  Process Result_Types argument
+
+      if Present (Arg_Result_Type) then
+         Argx_Result_Type := Expression (Arg_Result_Type);
+
+         if Nkind (Argx_Result_Type) /= N_String_Literal then
+            Error_Msg_N
+              ("Result_Type argument for pragma% must be string literal",
+               Argx_Result_Type);
+            return;
+         end if;
+
+         String_To_Name_Buffer (Strval (Argx_Result_Type));
+         Data.Result_Type := Name_Find;
+
+      else
+         Data.Result_Type := No_Name;
+      end if;
+
+      --  Now link this new entry into the hash table
+
+      Elmt := Elim_Hash_Table.Get (Hash_Subprograms.Get_Key (Data));
+
+      --  If we already have an entry with this same key, then link
+      --  it into the chain of entries for this key.
+
+      if Elmt /= null then
+         Data.Homonym := Elmt.Homonym;
+         Elmt.Homonym := Data;
+
+      --  Otherwise create a new entry
+
+      else
+         Elim_Hash_Table.Set (Data);
+      end if;
+
+      No_Elimination := False;
+   end Process_Eliminate_Pragma;
+
+end Sem_Elim;
diff --git a/gcc/ada/sem_elim.ads b/gcc/ada/sem_elim.ads
new file mode 100644
index 00000000000..861ffc99686
--- /dev/null
+++ b/gcc/ada/sem_elim.ads
@@ -0,0 +1,54 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             S E M _ E L I M                              --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.1 $                              --
+--                                                                          --
+--             Copyright (C) 1997 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 contains the routines used to process the Eliminate pragma
+
+with Types; use Types;
+
+package Sem_Elim is
+
+   procedure Initialize;
+   --  Initialize for new main souce program
+
+   procedure Process_Eliminate_Pragma
+     (Arg_Unit_Name       : Node_Id;
+      Arg_Entity          : Node_Id;
+      Arg_Parameter_Types : Node_Id;
+      Arg_Result_Type     : Node_Id);
+   --  Process eliminate pragma. The number of arguments has been checked,
+   --  as well as possible optional identifiers, but no other checks have
+   --  been made. This subprogram completes the checking, and then if the
+   --  pragma is well formed, makes appropriate entries in the internal
+   --  tables used to keep track of Eliminate pragmas. The four arguments
+   --  are the possible pragma arguments (set to Empty if not present).
+
+   procedure Check_Eliminated (E : Entity_Id);
+   --  Checks if entity E is eliminated, and if so sets the Is_Eliminated
+   --  flag on the given entity.
+
+end Sem_Elim;
diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb
new file mode 100644
index 00000000000..dde46a4b487
--- /dev/null
+++ b/gcc/ada/sem_eval.adb
@@ -0,0 +1,3663 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             S E M _ E V A L                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.291 $
+--                                                                          --
+--          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 Checks;   use Checks;
+with Debug;    use Debug;
+with Einfo;    use Einfo;
+with Elists;   use Elists;
+with Errout;   use Errout;
+with Eval_Fat; use Eval_Fat;
+with Nmake;    use Nmake;
+with Nlists;   use Nlists;
+with Opt;      use Opt;
+with Sem;      use Sem;
+with Sem_Cat;  use Sem_Cat;
+with Sem_Ch8;  use Sem_Ch8;
+with Sem_Res;  use Sem_Res;
+with Sem_Util; use Sem_Util;
+with Sem_Type; use Sem_Type;
+with Sem_Warn; use Sem_Warn;
+with Sinfo;    use Sinfo;
+with Snames;   use Snames;
+with Stand;    use Stand;
+with Stringt;  use Stringt;
+
+package body Sem_Eval is
+
+   -----------------------------------------
+   -- Handling of Compile Time Evaluation --
+   -----------------------------------------
+
+   --  The compile time evaluation of expressions is distributed over several
+   --  Eval_xxx procedures. These procedures are called immediatedly after
+   --  a subexpression is resolved and is therefore accomplished in a bottom
+   --  up fashion. The flags are synthesized using the following approach.
+
+   --    Is_Static_Expression is determined by following the detailed rules
+   --    in RM 4.9(4-14). This involves testing the Is_Static_Expression
+   --    flag of the operands in many cases.
+
+   --    Raises_Constraint_Error is set if any of the operands have the flag
+   --    set or if an attempt to compute the value of the current expression
+   --    results in detection of a runtime constraint error.
+
+   --  As described in the spec, the requirement is that Is_Static_Expression
+   --  be accurately set, and in addition for nodes for which this flag is set,
+   --  Raises_Constraint_Error must also be set. Furthermore a node which has
+   --  Is_Static_Expression set, and Raises_Constraint_Error clear, then the
+   --  requirement is that the expression value must be precomputed, and the
+   --  node is either a literal, or the name of a constant entity whose value
+   --  is a static expression.
+
+   --  The general approach is as follows. First compute Is_Static_Expression.
+   --  If the node is not static, then the flag is left off in the node and
+   --  we are all done. Otherwise for a static node, we test if any of the
+   --  operands will raise constraint error, and if so, propagate the flag
+   --  Raises_Constraint_Error to the result node and we are done (since the
+   --  error was already posted at a lower level).
+
+   --  For the case of a static node whose operands do not raise constraint
+   --  error, we attempt to evaluate the node. If this evaluation succeeds,
+   --  then the node is replaced by the result of this computation. If the
+   --  evaluation raises constraint error, then we rewrite the node with
+   --  Apply_Compile_Time_Constraint_Error to raise the exception and also
+   --  to post appropriate error messages.
+
+   ----------------
+   -- Local Data --
+   ----------------
+
+   type Bits is array (Nat range <>) of Boolean;
+   --  Used to convert unsigned (modular) values for folding logical ops
+
+   -----------------------
+   -- Local Subprograms --
+   -----------------------
+
+   function OK_Bits (N : Node_Id; Bits : Uint) return Boolean;
+   --  Bits represents the number of bits in an integer value to be computed
+   --  (but the value has not been computed yet). If this value in Bits is
+   --  reasonable, a result of True is returned, with the implication that
+   --  the caller should go ahead and complete the calculation. If the value
+   --  in Bits is unreasonably large, then an error is posted on node N, and
+   --  False is returned (and the caller skips the proposed calculation).
+
+   function From_Bits (B : Bits; T : Entity_Id) return Uint;
+   --  Converts a bit string of length B'Length to a Uint value to be used
+   --  for a target of type T, which is a modular type. This procedure
+   --  includes the necessary reduction by the modulus in the case of a
+   --  non-binary modulus (for a binary modulus, the bit string is the
+   --  right length any way so all is well).
+
+   function Get_String_Val (N : Node_Id) return Node_Id;
+   --  Given a tree node for a folded string or character value, returns
+   --  the corresponding string literal or character literal (one of the
+   --  two must be available, or the operand would not have been marked
+   --  as foldable in the earlier analysis of the operation).
+
+   procedure Out_Of_Range (N : Node_Id);
+   --  This procedure is called if it is determined that node N, which
+   --  appears in a non-static context, is a compile time known value
+   --  which is outside its range, i.e. the range of Etype. This is used
+   --  in contexts where this is an illegality if N is static, and should
+   --  generate a warning otherwise.
+
+   procedure Rewrite_In_Raise_CE (N : Node_Id; Exp : Node_Id);
+   --  N and Exp are nodes representing an expression, Exp is known
+   --  to raise CE. N is rewritten in term of Exp in the optimal way.
+
+   function String_Type_Len (Stype : Entity_Id) return Uint;
+   --  Given a string type, determines the length of the index type, or,
+   --  if this index type is non-static, the length of the base type of
+   --  this index type. Note that if the string type is itself static,
+   --  then the index type is static, so the second case applies only
+   --  if the string type passed is non-static.
+
+   function Test (Cond : Boolean) return Uint;
+   pragma Inline (Test);
+   --  This function simply returns the appropriate Boolean'Pos value
+   --  corresponding to the value of Cond as a universal integer. It is
+   --  used for producing the result of the static evaluation of the
+   --  logical operators
+
+   procedure Test_Expression_Is_Foldable
+     (N    : Node_Id;
+      Op1  : Node_Id;
+      Stat : out Boolean;
+      Fold : out Boolean);
+   --  Tests to see if expression N whose single operand is Op1 is foldable,
+   --  i.e. the operand value is known at compile time. If the operation is
+   --  foldable, then Fold is True on return, and Stat indicates whether
+   --  the result is static (i.e. both operands were static). Note that it
+   --  is quite possible for Fold to be True, and Stat to be False, since
+   --  there are cases in which we know the value of an operand even though
+   --  it is not technically static (e.g. the static lower bound of a range
+   --  whose upper bound is non-static).
+   --
+   --  If Stat is set False on return, then Expression_Is_Foldable makes a
+   --  call to Check_Non_Static_Context on the operand. If Fold is False on
+   --  return, then all processing is complete, and the caller should
+   --  return, since there is nothing else to do.
+
+   procedure Test_Expression_Is_Foldable
+     (N    : Node_Id;
+      Op1  : Node_Id;
+      Op2  : Node_Id;
+      Stat : out Boolean;
+      Fold : out Boolean);
+   --  Same processing, except applies to an expression N with two operands
+   --  Op1 and Op2.
+
+   procedure To_Bits (U : Uint; B : out Bits);
+   --  Converts a Uint value to a bit string of length B'Length
+
+   ------------------------------
+   -- Check_Non_Static_Context --
+   ------------------------------
+
+   procedure Check_Non_Static_Context (N : Node_Id) is
+      T         : Entity_Id := Etype (N);
+      Checks_On : constant Boolean :=
+                    not Index_Checks_Suppressed (T)
+                      and not Range_Checks_Suppressed (T);
+
+   begin
+      --  We need the check only for static expressions not raising CE
+      --  We can also ignore cases in which the type is Any_Type
+
+      if not Is_OK_Static_Expression (N)
+        or else Etype (N) = Any_Type
+      then
+         return;
+
+      --  Skip this check for non-scalar expressions
+
+      elsif not Is_Scalar_Type (T) then
+         return;
+      end if;
+
+      --  Here we have the case of outer level static expression of
+      --  scalar type, where the processing of this procedure is needed.
+
+      --  For real types, this is where we convert the value to a machine
+      --  number (see RM 4.9(38)). Also see ACVC test C490001. We should
+      --  only need to do this if the parent is a constant declaration,
+      --  since in other cases, gigi should do the necessary conversion
+      --  correctly, but experimentation shows that this is not the case
+      --  on all machines, in particular if we do not convert all literals
+      --  to machine values in non-static contexts, then ACVC test C490001
+      --  fails on Sparc/Solaris and SGI/Irix.
+
+      if Nkind (N) = N_Real_Literal
+        and then not Is_Machine_Number (N)
+        and then not Is_Generic_Type (Etype (N))
+        and then Etype (N) /= Universal_Real
+        and then not Debug_Flag_S
+        and then (not Debug_Flag_T
+                    or else
+                      (Nkind (Parent (N)) = N_Object_Declaration
+                        and then Constant_Present (Parent (N))))
+      then
+         --  Check that value is in bounds before converting to machine
+         --  number, so as not to lose case where value overflows in the
+         --  least significant bit or less. See B490001.
+
+         if Is_Out_Of_Range (N, Base_Type (T)) then
+            Out_Of_Range (N);
+            return;
+         end if;
+
+         --  Note: we have to copy the node, to avoid problems with conformance
+         --  of very similar numbers (see ACVC tests B4A010C and B63103A).
+
+         Rewrite (N, New_Copy (N));
+
+         if not Is_Floating_Point_Type (T) then
+            Set_Realval
+              (N, Corresponding_Integer_Value (N) * Small_Value (T));
+
+         elsif not UR_Is_Zero (Realval (N)) then
+            declare
+               RT : constant Entity_Id := Base_Type (T);
+               X  : constant Ureal := Machine (RT, Realval (N), Round);
+
+            begin
+               --  Warn if result of static rounding actually differs from
+               --  runtime evaluation, which uses round to even.
+
+               if Warn_On_Biased_Rounding and Rounding_Was_Biased then
+                  Error_Msg_N ("static expression does not round to even"
+                    & " ('R'M 4.9(38))?", N);
+               end if;
+
+               Set_Realval (N, X);
+            end;
+         end if;
+
+         Set_Is_Machine_Number (N);
+      end if;
+
+      --  Check for out of range universal integer. This is a non-static
+      --  context, so the integer value must be in range of the runtime
+      --  representation of universal integers.
+
+      --  We do this only within an expression, because that is the only
+      --  case in which non-static universal integer values can occur, and
+      --  furthermore, Check_Non_Static_Context is currently (incorrectly???)
+      --  called in contexts like the expression of a number declaration where
+      --  we certainly want to allow out of range values.
+
+      if Etype (N) = Universal_Integer
+        and then Nkind (N) = N_Integer_Literal
+        and then Nkind (Parent (N)) in N_Subexpr
+        and then
+          (Intval (N) < Expr_Value (Type_Low_Bound (Universal_Integer))
+            or else
+           Intval (N) > Expr_Value (Type_High_Bound (Universal_Integer)))
+      then
+         Apply_Compile_Time_Constraint_Error
+           (N, "non-static universal integer value out of range?");
+
+      --  Check out of range of base type
+
+      elsif Is_Out_Of_Range (N, Base_Type (T)) then
+         Out_Of_Range (N);
+
+      --  Give warning if outside subtype (where one or both of the
+      --  bounds of the subtype is static). This warning is omitted
+      --  if the expression appears in a range that could be null
+      --  (warnings are handled elsewhere for this case).
+
+      elsif T /= Base_Type (T)
+        and then Nkind (Parent (N)) /= N_Range
+      then
+         if Is_In_Range (N, T) then
+            null;
+
+         elsif Is_Out_Of_Range (N, T) then
+            Apply_Compile_Time_Constraint_Error
+              (N, "value not in range of}?");
+
+         elsif Checks_On then
+            Enable_Range_Check (N);
+
+         else
+            Set_Do_Range_Check (N, False);
+         end if;
+      end if;
+   end Check_Non_Static_Context;
+
+   ---------------------------------
+   -- Check_String_Literal_Length --
+   ---------------------------------
+
+   procedure Check_String_Literal_Length (N : Node_Id; Ttype : Entity_Id) is
+   begin
+      if not Raises_Constraint_Error (N)
+        and then Is_Constrained (Ttype)
+      then
+         if
+           UI_From_Int (String_Length (Strval (N))) /= String_Type_Len (Ttype)
+         then
+            Apply_Compile_Time_Constraint_Error
+              (N, "string length wrong for}?",
+               Ent => Ttype,
+               Typ => Ttype);
+         end if;
+      end if;
+   end Check_String_Literal_Length;
+
+   --------------------------
+   -- Compile_Time_Compare --
+   --------------------------
+
+   function Compile_Time_Compare (L, R : Node_Id) return Compare_Result is
+      Ltyp : constant Entity_Id := Etype (L);
+      Rtyp : constant Entity_Id := Etype (R);
+
+      procedure Compare_Decompose
+        (N : Node_Id;
+         R : out Node_Id;
+         V : out Uint);
+      --  This procedure decomposes the node N into an expression node
+      --  and a signed offset, so that the value of N is equal to the
+      --  value of R plus the value V (which may be negative). If no
+      --  such decomposition is possible, then on return R is a copy
+      --  of N, and V is set to zero.
+
+      function Compare_Fixup (N : Node_Id) return Node_Id;
+      --  This function deals with replacing 'Last and 'First references
+      --  with their corresponding type bounds, which we then can compare.
+      --  The argument is the original node, the result is the identity,
+      --  unless we have a 'Last/'First reference in which case the value
+      --  returned is the appropriate type bound.
+
+      function Is_Same_Value (L, R : Node_Id) return Boolean;
+      --  Returns True iff L and R represent expressions that definitely
+      --  have identical (but not necessarily compile time known) values
+      --  Indeed the caller is expected to have already dealt with the
+      --  cases of compile time known values, so these are not tested here.
+
+      -----------------------
+      -- Compare_Decompose --
+      -----------------------
+
+      procedure Compare_Decompose
+        (N : Node_Id;
+         R : out Node_Id;
+         V : out Uint)
+      is
+      begin
+         if Nkind (N) = N_Op_Add
+           and then Nkind (Right_Opnd (N)) = N_Integer_Literal
+         then
+            R := Left_Opnd (N);
+            V := Intval (Right_Opnd (N));
+            return;
+
+         elsif Nkind (N) = N_Op_Subtract
+           and then Nkind (Right_Opnd (N)) = N_Integer_Literal
+         then
+            R := Left_Opnd (N);
+            V := UI_Negate (Intval (Right_Opnd (N)));
+            return;
+
+         elsif Nkind (N) = N_Attribute_Reference  then
+
+            if Attribute_Name (N) = Name_Succ then
+               R := First (Expressions (N));
+               V := Uint_1;
+               return;
+
+            elsif Attribute_Name (N) = Name_Pred then
+               R := First (Expressions (N));
+               V := Uint_Minus_1;
+               return;
+            end if;
+         end if;
+
+         R := N;
+         V := Uint_0;
+      end Compare_Decompose;
+
+      -------------------
+      -- Compare_Fixup --
+      -------------------
+
+      function Compare_Fixup (N : Node_Id) return Node_Id is
+         Indx : Node_Id;
+         Xtyp : Entity_Id;
+         Subs : Nat;
+
+      begin
+         if Nkind (N) = N_Attribute_Reference
+           and then (Attribute_Name (N) = Name_First
+                       or else
+                     Attribute_Name (N) = Name_Last)
+         then
+            Xtyp := Etype (Prefix (N));
+
+            --  If we have no type, then just abandon the attempt to do
+            --  a fixup, this is probably the result of some other error.
+
+            if No (Xtyp) then
+               return N;
+            end if;
+
+            --  Dereference an access type
+
+            if Is_Access_Type (Xtyp) then
+               Xtyp := Designated_Type (Xtyp);
+            end if;
+
+            --  If we don't have an array type at this stage, something
+            --  is peculiar, e.g. another error, and we abandon the attempt
+            --  at a fixup.
+
+            if not Is_Array_Type (Xtyp) then
+               return N;
+            end if;
+
+            --  Ignore unconstrained array, since bounds are not meaningful
+
+            if not Is_Constrained (Xtyp) then
+               return N;
+            end if;
+
+            --  Find correct index type
+
+            Indx := First_Index (Xtyp);
+
+            if Present (Expressions (N)) then
+               Subs := UI_To_Int (Expr_Value (First (Expressions (N))));
+
+               for J in 2 .. Subs loop
+                  Indx := Next_Index (Indx);
+               end loop;
+            end if;
+
+            Xtyp := Etype (Indx);
+
+            if Attribute_Name (N) = Name_First then
+               return Type_Low_Bound (Xtyp);
+
+            else -- Attribute_Name (N) = Name_Last
+               return Type_High_Bound (Xtyp);
+            end if;
+         end if;
+
+         return N;
+      end Compare_Fixup;
+
+      -------------------
+      -- Is_Same_Value --
+      -------------------
+
+      function Is_Same_Value (L, R : Node_Id) return Boolean is
+         Lf : constant Node_Id := Compare_Fixup (L);
+         Rf : constant Node_Id := Compare_Fixup (R);
+
+      begin
+         --  Values are the same if they are the same identifier and the
+         --  identifier refers to a constant object (E_Constant)
+
+         if Nkind (Lf) = N_Identifier and then Nkind (Rf) = N_Identifier
+           and then Entity (Lf) = Entity (Rf)
+           and then (Ekind (Entity (Lf)) = E_Constant     or else
+                     Ekind (Entity (Lf)) = E_In_Parameter or else
+                     Ekind (Entity (Lf)) = E_Loop_Parameter)
+         then
+            return True;
+
+         --  Or if they are compile time known and identical
+
+         elsif Compile_Time_Known_Value (Lf)
+                 and then
+               Compile_Time_Known_Value (Rf)
+           and then Expr_Value (Lf) = Expr_Value (Rf)
+         then
+            return True;
+
+         --  Or if they are both 'First or 'Last values applying to the
+         --  same entity (first and last don't change even if value does)
+
+         elsif Nkind (Lf) = N_Attribute_Reference
+                 and then
+               Nkind (Rf) = N_Attribute_Reference
+           and then Attribute_Name (Lf) = Attribute_Name (Rf)
+           and then (Attribute_Name (Lf) = Name_First
+                       or else
+                     Attribute_Name (Lf) = Name_Last)
+           and then Is_Entity_Name (Prefix (Lf))
+           and then Is_Entity_Name (Prefix (Rf))
+           and then Entity (Prefix (Lf)) = Entity (Prefix (Rf))
+         then
+            return True;
+
+         --  All other cases, we can't tell
+
+         else
+            return False;
+         end if;
+      end Is_Same_Value;
+
+   --  Start of processing for Compile_Time_Compare
+
+   begin
+      if L = R then
+         return EQ;
+
+      --  If expressions have no types, then do not attempt to determine
+      --  if they are the same, since something funny is going on. One
+      --  case in which this happens is during generic template analysis,
+      --  when bounds are not fully analyzed.
+
+      elsif No (Ltyp) or else No (Rtyp) then
+         return Unknown;
+
+      --  We only attempt compile time analysis for scalar values
+
+      elsif not Is_Scalar_Type (Ltyp)
+        or else Is_Packed_Array_Type (Ltyp)
+      then
+         return Unknown;
+
+      --  Case where comparison involves two compile time known values
+
+      elsif Compile_Time_Known_Value (L)
+        and then Compile_Time_Known_Value (R)
+      then
+         --  For the floating-point case, we have to be a little careful, since
+         --  at compile time we are dealing with universal exact values, but at
+         --  runtime, these will be in non-exact target form. That's why the
+         --  returned results are LE and GE below instead of LT and GT.
+
+         if Is_Floating_Point_Type (Ltyp)
+              or else
+            Is_Floating_Point_Type (Rtyp)
+         then
+            declare
+               Lo : constant Ureal := Expr_Value_R (L);
+               Hi : constant Ureal := Expr_Value_R (R);
+
+            begin
+               if Lo < Hi then
+                  return LE;
+               elsif Lo = Hi then
+                  return EQ;
+               else
+                  return GE;
+               end if;
+            end;
+
+         --  For the integer case we know exactly (note that this includes the
+         --  fixed-point case, where we know the run time integer values now)
+
+         else
+            declare
+               Lo : constant Uint := Expr_Value (L);
+               Hi : constant Uint := Expr_Value (R);
+
+            begin
+               if Lo < Hi then
+                  return LT;
+               elsif Lo = Hi then
+                  return EQ;
+               else
+                  return GT;
+               end if;
+            end;
+         end if;
+
+      --  Cases where at least one operand is not known at compile time
+
+      else
+         --  Here is where we check for comparisons against maximum bounds of
+         --  types, where we know that no value can be outside the bounds of
+         --  the subtype. Note that this routine is allowed to assume that all
+         --  expressions are within their subtype bounds. Callers wishing to
+         --  deal with possibly invalid values must in any case take special
+         --  steps (e.g. conversions to larger types) to avoid this kind of
+         --  optimization, which is always considered to be valid. We do not
+         --  attempt this optimization with generic types, since the type
+         --  bounds may not be meaningful in this case.
+
+         if Is_Discrete_Type (Ltyp)
+           and then not Is_Generic_Type (Ltyp)
+           and then not Is_Generic_Type (Rtyp)
+         then
+            if Is_Same_Value (R, Type_High_Bound (Ltyp)) then
+               return LE;
+
+            elsif Is_Same_Value (R, Type_Low_Bound (Ltyp)) then
+               return GE;
+
+            elsif Is_Same_Value (L, Type_High_Bound (Rtyp)) then
+               return GE;
+
+            elsif Is_Same_Value (L, Type_Low_Bound (Ltyp)) then
+               return LE;
+            end if;
+         end if;
+
+         --  Next attempt is to decompose the expressions to extract
+         --  a constant offset resulting from the use of any of the forms:
+
+         --     expr + literal
+         --     expr - literal
+         --     typ'Succ (expr)
+         --     typ'Pred (expr)
+
+         --  Then we see if the two expressions are the same value, and if so
+         --  the result is obtained by comparing the offsets.
+
+         declare
+            Lnode : Node_Id;
+            Loffs : Uint;
+            Rnode : Node_Id;
+            Roffs : Uint;
+
+         begin
+            Compare_Decompose (L, Lnode, Loffs);
+            Compare_Decompose (R, Rnode, Roffs);
+
+            if Is_Same_Value (Lnode, Rnode) then
+               if Loffs = Roffs then
+                  return EQ;
+
+               elsif Loffs < Roffs then
+                  return LT;
+
+               else
+                  return GT;
+               end if;
+
+            --  If the expressions are different, we cannot say at compile
+            --  time how they compare, so we return the Unknown indication.
+
+            else
+               return Unknown;
+            end if;
+         end;
+      end if;
+   end Compile_Time_Compare;
+
+   ------------------------------
+   -- Compile_Time_Known_Value --
+   ------------------------------
+
+   function Compile_Time_Known_Value (Op : Node_Id) return Boolean is
+      K : constant Node_Kind := Nkind (Op);
+
+   begin
+      --  Never known at compile time if bad type or raises constraint error
+      --  or empty (latter case occurs only as a result of a previous error)
+
+      if No (Op)
+        or else Op = Error
+        or else Etype (Op) = Any_Type
+        or else Raises_Constraint_Error (Op)
+      then
+         return False;
+      end if;
+
+      --  If we have an entity name, then see if it is the name of a constant
+      --  and if so, test the corresponding constant value, or the name of
+      --  an enumeration literal, which is always a constant.
+
+      if Present (Etype (Op)) and then Is_Entity_Name (Op) then
+         declare
+            E : constant Entity_Id := Entity (Op);
+            V : Node_Id;
+
+         begin
+            --  Never known at compile time if it is a packed array value.
+            --  We might want to try to evaluate these at compile time one
+            --  day, but we do not make that attempt now.
+
+            if Is_Packed_Array_Type (Etype (Op)) then
+               return False;
+            end if;
+
+            if Ekind (E) = E_Enumeration_Literal then
+               return True;
+
+            elsif Ekind (E) /= E_Constant then
+               return False;
+
+            else
+               V := Constant_Value (E);
+               return Present (V) and then Compile_Time_Known_Value (V);
+            end if;
+         end;
+
+      --  We have a value, see if it is compile time known
+
+      else
+         --  Literals and NULL are known at compile time
+
+         if K = N_Integer_Literal
+              or else
+            K = N_Character_Literal
+              or else
+            K = N_Real_Literal
+              or else
+            K = N_String_Literal
+              or else
+            K = N_Null
+         then
+            return True;
+
+         --  Any reference to Null_Parameter is known at compile time. No
+         --  other attribute references (that have not already been folded)
+         --  are known at compile time.
+
+         elsif K = N_Attribute_Reference then
+            return Attribute_Name (Op) = Name_Null_Parameter;
+
+         --  All other types of values are not known at compile time
+
+         else
+            return False;
+         end if;
+
+      end if;
+   end Compile_Time_Known_Value;
+
+   --------------------------------------
+   -- Compile_Time_Known_Value_Or_Aggr --
+   --------------------------------------
+
+   function Compile_Time_Known_Value_Or_Aggr (Op : Node_Id) return Boolean is
+   begin
+      --  If we have an entity name, then see if it is the name of a constant
+      --  and if so, test the corresponding constant value, or the name of
+      --  an enumeration literal, which is always a constant.
+
+      if Is_Entity_Name (Op) then
+         declare
+            E : constant Entity_Id := Entity (Op);
+            V : Node_Id;
+
+         begin
+            if Ekind (E) = E_Enumeration_Literal then
+               return True;
+
+            elsif Ekind (E) /= E_Constant then
+               return False;
+
+            else
+               V := Constant_Value (E);
+               return Present (V)
+                 and then Compile_Time_Known_Value_Or_Aggr (V);
+            end if;
+         end;
+
+      --  We have a value, see if it is compile time known
+
+      else
+         if Compile_Time_Known_Value (Op) then
+            return True;
+
+         elsif Nkind (Op) = N_Aggregate then
+
+            if Present (Expressions (Op)) then
+               declare
+                  Expr : Node_Id;
+
+               begin
+                  Expr := First (Expressions (Op));
+                  while Present (Expr) loop
+                     if not Compile_Time_Known_Value_Or_Aggr (Expr) then
+                        return False;
+                     end if;
+
+                     Next (Expr);
+                  end loop;
+               end;
+            end if;
+
+            if Present (Component_Associations (Op)) then
+               declare
+                  Cass : Node_Id;
+
+               begin
+                  Cass := First (Component_Associations (Op));
+                  while Present (Cass) loop
+                     if not
+                       Compile_Time_Known_Value_Or_Aggr (Expression (Cass))
+                     then
+                        return False;
+                     end if;
+
+                     Next (Cass);
+                  end loop;
+               end;
+            end if;
+
+            return True;
+
+         --  All other types of values are not known at compile time
+
+         else
+            return False;
+         end if;
+
+      end if;
+   end Compile_Time_Known_Value_Or_Aggr;
+
+   -----------------
+   -- Eval_Actual --
+   -----------------
+
+   --  This is only called for actuals of functions that are not predefined
+   --  operators (which have already been rewritten as operators at this
+   --  stage), so the call can never be folded, and all that needs doing for
+   --  the actual is to do the check for a non-static context.
+
+   procedure Eval_Actual (N : Node_Id) is
+   begin
+      Check_Non_Static_Context (N);
+   end Eval_Actual;
+
+   --------------------
+   -- Eval_Allocator --
+   --------------------
+
+   --  Allocators are never static, so all we have to do is to do the
+   --  check for a non-static context if an expression is present.
+
+   procedure Eval_Allocator (N : Node_Id) is
+      Expr : constant Node_Id := Expression (N);
+
+   begin
+      if Nkind (Expr) = N_Qualified_Expression then
+         Check_Non_Static_Context (Expression (Expr));
+      end if;
+   end Eval_Allocator;
+
+   ------------------------
+   -- Eval_Arithmetic_Op --
+   ------------------------
+
+   --  Arithmetic operations are static functions, so the result is static
+   --  if both operands are static (RM 4.9(7), 4.9(20)).
+
+   procedure Eval_Arithmetic_Op (N : Node_Id) is
+      Left  : constant Node_Id   := Left_Opnd (N);
+      Right : constant Node_Id   := Right_Opnd (N);
+      Ltype : constant Entity_Id := Etype (Left);
+      Rtype : constant Entity_Id := Etype (Right);
+      Stat  : Boolean;
+      Fold  : Boolean;
+
+   begin
+      --  If not foldable we are done
+
+      Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
+
+      if not Fold then
+         return;
+      end if;
+
+      --  Fold for cases where both operands are of integer type
+
+      if Is_Integer_Type (Ltype) and then Is_Integer_Type (Rtype) then
+         declare
+            Left_Int  : constant Uint := Expr_Value (Left);
+            Right_Int : constant Uint := Expr_Value (Right);
+            Result    : Uint;
+
+         begin
+            case Nkind (N) is
+
+               when N_Op_Add =>
+                  Result := Left_Int + Right_Int;
+
+               when N_Op_Subtract =>
+                  Result := Left_Int - Right_Int;
+
+               when N_Op_Multiply =>
+                  if OK_Bits
+                       (N, UI_From_Int
+                             (Num_Bits (Left_Int) + Num_Bits (Right_Int)))
+                  then
+                     Result := Left_Int * Right_Int;
+                  else
+                     Result := Left_Int;
+                  end if;
+
+               when N_Op_Divide =>
+
+                  --  The exception Constraint_Error is raised by integer
+                  --  division, rem and mod if the right operand is zero.
+
+                  if Right_Int = 0 then
+                     Apply_Compile_Time_Constraint_Error
+                       (N, "division by zero");
+                     return;
+                  else
+                     Result := Left_Int / Right_Int;
+                  end if;
+
+               when N_Op_Mod =>
+
+                  --  The exception Constraint_Error is raised by integer
+                  --  division, rem and mod if the right operand is zero.
+
+                  if Right_Int = 0 then
+                     Apply_Compile_Time_Constraint_Error
+                       (N, "mod with zero divisor");
+                     return;
+                  else
+                     Result := Left_Int mod Right_Int;
+                  end if;
+
+               when N_Op_Rem =>
+
+                  --  The exception Constraint_Error is raised by integer
+                  --  division, rem and mod if the right operand is zero.
+
+                  if Right_Int = 0 then
+                     Apply_Compile_Time_Constraint_Error
+                       (N, "rem with zero divisor");
+                     return;
+                  else
+                     Result := Left_Int rem Right_Int;
+                  end if;
+
+               when others =>
+                  raise Program_Error;
+            end case;
+
+            --  Adjust the result by the modulus if the type is a modular type
+
+            if Is_Modular_Integer_Type (Ltype) then
+               Result := Result mod Modulus (Ltype);
+            end if;
+
+            Fold_Uint (N, Result);
+         end;
+
+      --  Cases where at least one operand is a real. We handle the cases
+      --  of both reals, or mixed/real integer cases (the latter happen
+      --  only for divide and multiply, and the result is always real).
+
+      elsif Is_Real_Type (Ltype) or else Is_Real_Type (Rtype) then
+         declare
+            Left_Real  : Ureal;
+            Right_Real : Ureal;
+            Result     : Ureal;
+
+         begin
+            if Is_Real_Type (Ltype) then
+               Left_Real := Expr_Value_R (Left);
+            else
+               Left_Real := UR_From_Uint (Expr_Value (Left));
+            end if;
+
+            if Is_Real_Type (Rtype) then
+               Right_Real := Expr_Value_R (Right);
+            else
+               Right_Real := UR_From_Uint (Expr_Value (Right));
+            end if;
+
+            if Nkind (N) = N_Op_Add then
+               Result := Left_Real + Right_Real;
+
+            elsif Nkind (N) = N_Op_Subtract then
+               Result := Left_Real - Right_Real;
+
+            elsif Nkind (N) = N_Op_Multiply then
+               Result := Left_Real * Right_Real;
+
+            else pragma Assert (Nkind (N) = N_Op_Divide);
+               if UR_Is_Zero (Right_Real) then
+                  Apply_Compile_Time_Constraint_Error
+                    (N, "division by zero");
+                  return;
+               end if;
+
+               Result := Left_Real / Right_Real;
+            end if;
+
+            Fold_Ureal (N, Result);
+         end;
+      end if;
+
+      Set_Is_Static_Expression (N, Stat);
+
+   end Eval_Arithmetic_Op;
+
+   ----------------------------
+   -- Eval_Character_Literal --
+   ----------------------------
+
+   --  Nothing to be done!
+
+   procedure Eval_Character_Literal (N : Node_Id) is
+   begin
+      null;
+   end Eval_Character_Literal;
+
+   ------------------------
+   -- Eval_Concatenation --
+   ------------------------
+
+   --  Concatenation is a static function, so the result is static if
+   --  both operands are static (RM 4.9(7), 4.9(21)).
+
+   procedure Eval_Concatenation (N : Node_Id) is
+      Left  : constant Node_Id := Left_Opnd (N);
+      Right : constant Node_Id := Right_Opnd (N);
+      Stat  : Boolean;
+      Fold  : Boolean;
+      C_Typ : constant Entity_Id := Root_Type (Component_Type (Etype (N)));
+
+   begin
+      --  Concatenation is never static in Ada 83, so if Ada 83
+      --  check operand non-static context
+
+      if Ada_83
+        and then Comes_From_Source (N)
+      then
+         Check_Non_Static_Context (Left);
+         Check_Non_Static_Context (Right);
+         return;
+      end if;
+
+      --  If not foldable we are done. In principle concatenation that yields
+      --  any string type is static (i.e. an array type of character types).
+      --  However, character types can include enumeration literals, and
+      --  concatenation in that case cannot be described by a literal, so we
+      --  only consider the operation static if the result is an array of
+      --  (a descendant of) a predefined character type.
+
+      Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
+
+      if (C_Typ = Standard_Character
+            or else  C_Typ = Standard_Wide_Character)
+        and then Fold
+      then
+         null;
+      else
+         Set_Is_Static_Expression (N, False);
+         return;
+      end if;
+
+      --  Compile time string concatenation.
+
+      --  ??? Note that operands that are aggregates can be marked as
+      --  static, so we should attempt at a later stage to fold
+      --  concatenations with such aggregates.
+
+      declare
+         Left_Str  : constant Node_Id := Get_String_Val (Left);
+         Right_Str : constant Node_Id := Get_String_Val (Right);
+
+      begin
+         --  Establish new string literal, and store left operand. We make
+         --  sure to use the special Start_String that takes an operand if
+         --  the left operand is a string literal. Since this is optimized
+         --  in the case where that is the most recently created string
+         --  literal, we ensure efficient time/space behavior for the
+         --  case of a concatenation of a series of string literals.
+
+         if Nkind (Left_Str) = N_String_Literal then
+            Start_String (Strval (Left_Str));
+         else
+            Start_String;
+            Store_String_Char (Char_Literal_Value (Left_Str));
+         end if;
+
+         --  Now append the characters of the right operand
+
+         if Nkind (Right_Str) = N_String_Literal then
+            declare
+               S : constant String_Id := Strval (Right_Str);
+
+            begin
+               for J in 1 .. String_Length (S) loop
+                  Store_String_Char (Get_String_Char (S, J));
+               end loop;
+            end;
+         else
+            Store_String_Char (Char_Literal_Value (Right_Str));
+         end if;
+
+         Set_Is_Static_Expression (N, Stat);
+
+         if Stat then
+            Fold_Str (N, End_String);
+         end if;
+      end;
+   end Eval_Concatenation;
+
+   ---------------------------------
+   -- Eval_Conditional_Expression --
+   ---------------------------------
+
+   --  This GNAT internal construct can never be statically folded, so the
+   --  only required processing is to do the check for non-static context
+   --  for the two expression operands.
+
+   procedure Eval_Conditional_Expression (N : Node_Id) is
+      Condition : constant Node_Id := First (Expressions (N));
+      Then_Expr : constant Node_Id := Next (Condition);
+      Else_Expr : constant Node_Id := Next (Then_Expr);
+
+   begin
+      Check_Non_Static_Context (Then_Expr);
+      Check_Non_Static_Context (Else_Expr);
+   end Eval_Conditional_Expression;
+
+   ----------------------
+   -- Eval_Entity_Name --
+   ----------------------
+
+   --  This procedure is used for identifiers and expanded names other than
+   --  named numbers (see Eval_Named_Integer, Eval_Named_Real. These are
+   --  static if they denote a static constant (RM 4.9(6)) or if the name
+   --  denotes an enumeration literal (RM 4.9(22)).
+
+   procedure Eval_Entity_Name (N : Node_Id) is
+      Def_Id : constant Entity_Id := Entity (N);
+      Val    : Node_Id;
+
+   begin
+      --  Enumeration literals are always considered to be constants
+      --  and cannot raise constraint error (RM 4.9(22)).
+
+      if Ekind (Def_Id) = E_Enumeration_Literal then
+         Set_Is_Static_Expression (N);
+         return;
+
+      --  A name is static if it denotes a static constant (RM 4.9(5)), and
+      --  we also copy Raise_Constraint_Error. Notice that even if non-static,
+      --  it does not violate 10.2.1(8) here, since this is not a variable.
+
+      elsif Ekind (Def_Id) = E_Constant then
+
+         --  Deferred constants must always be treated as nonstatic
+         --  outside the scope of their full view.
+
+         if Present (Full_View (Def_Id))
+           and then not In_Open_Scopes (Scope (Def_Id))
+         then
+            Val := Empty;
+         else
+            Val := Constant_Value (Def_Id);
+         end if;
+
+         if Present (Val) then
+            Set_Is_Static_Expression
+              (N, Is_Static_Expression (Val)
+                    and then Is_Static_Subtype (Etype (Def_Id)));
+            Set_Raises_Constraint_Error (N, Raises_Constraint_Error (Val));
+
+            if not Is_Static_Expression (N)
+              and then not Is_Generic_Type (Etype (N))
+            then
+               Validate_Static_Object_Name (N);
+            end if;
+
+            return;
+         end if;
+      end if;
+
+      --  Fall through if the name is not static.
+
+      Validate_Static_Object_Name (N);
+   end Eval_Entity_Name;
+
+   ----------------------------
+   -- Eval_Indexed_Component --
+   ----------------------------
+
+   --  Indexed components are never static, so the only required processing
+   --  is to perform the check for non-static context on the index values.
+
+   procedure Eval_Indexed_Component (N : Node_Id) is
+      Expr : Node_Id;
+
+   begin
+      Expr := First (Expressions (N));
+      while Present (Expr) loop
+         Check_Non_Static_Context (Expr);
+         Next (Expr);
+      end loop;
+
+   end Eval_Indexed_Component;
+
+   --------------------------
+   -- Eval_Integer_Literal --
+   --------------------------
+
+   --  Numeric literals are static (RM 4.9(1)), and have already been marked
+   --  as static by the analyzer. The reason we did it that early is to allow
+   --  the possibility of turning off the Is_Static_Expression flag after
+   --  analysis, but before resolution, when integer literals are generated
+   --  in the expander that do not correspond to static expressions.
+
+   procedure Eval_Integer_Literal (N : Node_Id) is
+      T : constant Entity_Id := Etype (N);
+
+   begin
+      --  If the literal appears in a non-expression context, then it is
+      --  certainly appearing in a non-static context, so check it. This
+      --  is actually a redundant check, since Check_Non_Static_Context
+      --  would check it, but it seems worth while avoiding the call.
+
+      if Nkind (Parent (N)) not in N_Subexpr then
+         Check_Non_Static_Context (N);
+      end if;
+
+      --  Modular integer literals must be in their base range
+
+      if Is_Modular_Integer_Type (T)
+        and then Is_Out_Of_Range (N, Base_Type (T))
+      then
+         Out_Of_Range (N);
+      end if;
+   end Eval_Integer_Literal;
+
+   ---------------------
+   -- Eval_Logical_Op --
+   ---------------------
+
+   --  Logical operations are static functions, so the result is potentially
+   --  static if both operands are potentially static (RM 4.9(7), 4.9(20)).
+
+   procedure Eval_Logical_Op (N : Node_Id) is
+      Left  : constant Node_Id := Left_Opnd (N);
+      Right : constant Node_Id := Right_Opnd (N);
+      Stat  : Boolean;
+      Fold  : Boolean;
+
+   begin
+      --  If not foldable we are done
+
+      Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
+
+      if not Fold then
+         return;
+      end if;
+
+      --  Compile time evaluation of logical operation
+
+      declare
+         Left_Int  : constant Uint := Expr_Value (Left);
+         Right_Int : constant Uint := Expr_Value (Right);
+
+      begin
+         if Is_Modular_Integer_Type (Etype (N)) then
+            declare
+               Left_Bits  : Bits (0 .. UI_To_Int (Esize (Etype (N))) - 1);
+               Right_Bits : Bits (0 .. UI_To_Int (Esize (Etype (N))) - 1);
+
+            begin
+               To_Bits (Left_Int, Left_Bits);
+               To_Bits (Right_Int, Right_Bits);
+
+               --  Note: should really be able to use array ops instead of
+               --  these loops, but they weren't working at the time ???
+
+               if Nkind (N) = N_Op_And then
+                  for J in Left_Bits'Range loop
+                     Left_Bits (J) := Left_Bits (J) and Right_Bits (J);
+                  end loop;
+
+               elsif Nkind (N) = N_Op_Or then
+                  for J in Left_Bits'Range loop
+                     Left_Bits (J) := Left_Bits (J) or Right_Bits (J);
+                  end loop;
+
+               else
+                  pragma Assert (Nkind (N) = N_Op_Xor);
+
+                  for J in Left_Bits'Range loop
+                     Left_Bits (J) := Left_Bits (J) xor Right_Bits (J);
+                  end loop;
+               end if;
+
+               Fold_Uint (N, From_Bits (Left_Bits, Etype (N)));
+            end;
+
+         else
+            pragma Assert (Is_Boolean_Type (Etype (N)));
+
+            if Nkind (N) = N_Op_And then
+               Fold_Uint (N,
+                 Test (Is_True (Left_Int) and then Is_True (Right_Int)));
+
+            elsif Nkind (N) = N_Op_Or then
+               Fold_Uint (N,
+                 Test (Is_True (Left_Int) or else Is_True (Right_Int)));
+
+            else
+               pragma Assert (Nkind (N) = N_Op_Xor);
+               Fold_Uint (N,
+                 Test (Is_True (Left_Int) xor Is_True (Right_Int)));
+            end if;
+         end if;
+
+         Set_Is_Static_Expression (N, Stat);
+      end;
+   end Eval_Logical_Op;
+
+   ------------------------
+   -- Eval_Membership_Op --
+   ------------------------
+
+   --  A membership test is potentially static if the expression is static,
+   --  and the range is a potentially static range, or is a subtype mark
+   --  denoting a static subtype (RM 4.9(12)).
+
+   procedure Eval_Membership_Op (N : Node_Id) is
+      Left   : constant Node_Id := Left_Opnd (N);
+      Right  : constant Node_Id := Right_Opnd (N);
+      Def_Id : Entity_Id;
+      Lo     : Node_Id;
+      Hi     : Node_Id;
+      Result : Boolean;
+      Stat   : Boolean;
+      Fold   : Boolean;
+
+   begin
+      --  Ignore if error in either operand, except to make sure that
+      --  Any_Type is properly propagated to avoid junk cascaded errors.
+
+      if Etype (Left) = Any_Type
+        or else Etype (Right) = Any_Type
+      then
+         Set_Etype (N, Any_Type);
+         return;
+      end if;
+
+      --  Case of right operand is a subtype name
+
+      if Is_Entity_Name (Right) then
+         Def_Id := Entity (Right);
+
+         if (Is_Scalar_Type (Def_Id) or else Is_String_Type (Def_Id))
+           and then Is_OK_Static_Subtype (Def_Id)
+         then
+            Test_Expression_Is_Foldable (N, Left, Stat, Fold);
+
+            if not Fold or else not Stat then
+               return;
+            end if;
+         else
+            Check_Non_Static_Context (Left);
+            return;
+         end if;
+
+         --  For string membership tests we will check the length
+         --  further below.
+
+         if not Is_String_Type (Def_Id) then
+            Lo := Type_Low_Bound (Def_Id);
+            Hi := Type_High_Bound (Def_Id);
+
+         else
+            Lo := Empty;
+            Hi := Empty;
+         end if;
+
+      --  Case of right operand is a range
+
+      else
+         if Is_Static_Range (Right) then
+            Test_Expression_Is_Foldable (N, Left, Stat, Fold);
+
+            if not Fold or else not Stat then
+               return;
+
+            --  If one bound of range raises CE, then don't try to fold
+
+            elsif not Is_OK_Static_Range (Right) then
+               Check_Non_Static_Context (Left);
+               return;
+            end if;
+
+         else
+            Check_Non_Static_Context (Left);
+            return;
+         end if;
+
+         --  Here we know range is an OK static range
+
+         Lo := Low_Bound (Right);
+         Hi := High_Bound (Right);
+      end if;
+
+      --  For strings we check that the length of the string expression is
+      --  compatible with the string subtype if the subtype is constrained,
+      --  or if unconstrained then the test is always true.
+
+      if Is_String_Type (Etype (Right)) then
+         if not Is_Constrained (Etype (Right)) then
+            Result := True;
+
+         else
+            declare
+               Typlen : constant Uint := String_Type_Len (Etype (Right));
+               Strlen : constant Uint :=
+                 UI_From_Int (String_Length (Strval (Get_String_Val (Left))));
+            begin
+               Result := (Typlen = Strlen);
+            end;
+         end if;
+
+      --  Fold the membership test. We know we have a static range and Lo
+      --  and Hi are set to the expressions for the end points of this range.
+
+      elsif Is_Real_Type (Etype (Right)) then
+         declare
+            Leftval : constant Ureal := Expr_Value_R (Left);
+
+         begin
+            Result := Expr_Value_R (Lo) <= Leftval
+                        and then Leftval <= Expr_Value_R (Hi);
+         end;
+
+      else
+         declare
+            Leftval : constant Uint := Expr_Value (Left);
+
+         begin
+            Result := Expr_Value (Lo) <= Leftval
+                        and then Leftval <= Expr_Value (Hi);
+         end;
+      end if;
+
+      if Nkind (N) = N_Not_In then
+         Result := not Result;
+      end if;
+
+      Fold_Uint (N, Test (Result));
+      Warn_On_Known_Condition (N);
+
+   end Eval_Membership_Op;
+
+   ------------------------
+   -- Eval_Named_Integer --
+   ------------------------
+
+   procedure Eval_Named_Integer (N : Node_Id) is
+   begin
+      Fold_Uint (N,
+        Expr_Value (Expression (Declaration_Node (Entity (N)))));
+   end Eval_Named_Integer;
+
+   ---------------------
+   -- Eval_Named_Real --
+   ---------------------
+
+   procedure Eval_Named_Real (N : Node_Id) is
+   begin
+      Fold_Ureal (N,
+        Expr_Value_R (Expression (Declaration_Node (Entity (N)))));
+   end Eval_Named_Real;
+
+   -------------------
+   -- Eval_Op_Expon --
+   -------------------
+
+   --  Exponentiation is a static functions, so the result is potentially
+   --  static if both operands are potentially static (RM 4.9(7), 4.9(20)).
+
+   procedure Eval_Op_Expon (N : Node_Id) is
+      Left  : constant Node_Id := Left_Opnd (N);
+      Right : constant Node_Id := Right_Opnd (N);
+      Stat  : Boolean;
+      Fold  : Boolean;
+
+   begin
+      --  If not foldable we are done
+
+      Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
+
+      if not Fold then
+         return;
+      end if;
+
+      --  Fold exponentiation operation
+
+      declare
+         Right_Int : constant Uint := Expr_Value (Right);
+
+      begin
+         --  Integer case
+
+         if Is_Integer_Type (Etype (Left)) then
+            declare
+               Left_Int : constant Uint := Expr_Value (Left);
+               Result   : Uint;
+
+            begin
+               --  Exponentiation of an integer raises the exception
+               --  Constraint_Error for a negative exponent (RM 4.5.6)
+
+               if Right_Int < 0 then
+                  Apply_Compile_Time_Constraint_Error
+                    (N, "integer exponent negative");
+                  return;
+
+               else
+                  if OK_Bits (N, Num_Bits (Left_Int) * Right_Int) then
+                     Result := Left_Int ** Right_Int;
+                  else
+                     Result := Left_Int;
+                  end if;
+
+                  if Is_Modular_Integer_Type (Etype (N)) then
+                     Result := Result mod Modulus (Etype (N));
+                  end if;
+
+                  Fold_Uint (N, Result);
+               end if;
+            end;
+
+         --  Real case
+
+         else
+            declare
+               Left_Real : constant Ureal := Expr_Value_R (Left);
+
+            begin
+               --  Cannot have a zero base with a negative exponent
+
+               if UR_Is_Zero (Left_Real) then
+
+                  if Right_Int < 0 then
+                     Apply_Compile_Time_Constraint_Error
+                       (N, "zero ** negative integer");
+                     return;
+                  else
+                     Fold_Ureal (N, Ureal_0);
+                  end if;
+
+               else
+                  Fold_Ureal (N, Left_Real ** Right_Int);
+               end if;
+            end;
+         end if;
+
+         Set_Is_Static_Expression (N, Stat);
+      end;
+   end Eval_Op_Expon;
+
+   -----------------
+   -- Eval_Op_Not --
+   -----------------
+
+   --  The not operation is a  static functions, so the result is potentially
+   --  static if the operand is potentially static (RM 4.9(7), 4.9(20)).
+
+   procedure Eval_Op_Not (N : Node_Id) is
+      Right : constant Node_Id := Right_Opnd (N);
+      Stat  : Boolean;
+      Fold  : Boolean;
+
+   begin
+      --  If not foldable we are done
+
+      Test_Expression_Is_Foldable (N, Right, Stat, Fold);
+
+      if not Fold then
+         return;
+      end if;
+
+      --  Fold not operation
+
+      declare
+         Rint : constant Uint      := Expr_Value (Right);
+         Typ  : constant Entity_Id := Etype (N);
+
+      begin
+         --  Negation is equivalent to subtracting from the modulus minus
+         --  one. For a binary modulus this is equivalent to the ones-
+         --  component of the original value. For non-binary modulus this
+         --  is an arbitrary but consistent definition.
+
+         if Is_Modular_Integer_Type (Typ) then
+            Fold_Uint (N, Modulus (Typ) - 1 - Rint);
+
+         else
+            pragma Assert (Is_Boolean_Type (Typ));
+            Fold_Uint (N, Test (not Is_True (Rint)));
+         end if;
+
+         Set_Is_Static_Expression (N, Stat);
+      end;
+   end Eval_Op_Not;
+
+   -------------------------------
+   -- Eval_Qualified_Expression --
+   -------------------------------
+
+   --  A qualified expression is potentially static if its subtype mark denotes
+   --  a static subtype and its expression is potentially static (RM 4.9 (11)).
+
+   procedure Eval_Qualified_Expression (N : Node_Id) is
+      Operand     : constant Node_Id   := Expression (N);
+      Target_Type : constant Entity_Id := Entity (Subtype_Mark (N));
+
+      Stat  : Boolean;
+      Fold  : Boolean;
+
+   begin
+      --  Can only fold if target is string or scalar and subtype is static
+      --  Also, do not fold if our parent is an allocator (this is because
+      --  the qualified expression is really part of the syntactic structure
+      --  of an allocator, and we do not want to end up with something that
+      --  corresponds to "new 1" where the 1 is the result of folding a
+      --  qualified expression).
+
+      if not Is_Static_Subtype (Target_Type)
+        or else Nkind (Parent (N)) = N_Allocator
+      then
+         Check_Non_Static_Context (Operand);
+         return;
+      end if;
+
+      --  If not foldable we are done
+
+      Test_Expression_Is_Foldable (N, Operand, Stat, Fold);
+
+      if not Fold then
+         return;
+
+      --  Don't try fold if target type has constraint error bounds
+
+      elsif not Is_OK_Static_Subtype (Target_Type) then
+         Set_Raises_Constraint_Error (N);
+         return;
+      end if;
+
+      --  Fold the result of qualification
+
+      if Is_Discrete_Type (Target_Type) then
+         Fold_Uint (N, Expr_Value (Operand));
+         Set_Is_Static_Expression (N, Stat);
+
+      elsif Is_Real_Type (Target_Type) then
+         Fold_Ureal (N, Expr_Value_R (Operand));
+         Set_Is_Static_Expression (N, Stat);
+
+      else
+         Fold_Str (N, Strval (Get_String_Val (Operand)));
+
+         if not Stat then
+            Set_Is_Static_Expression (N, False);
+         else
+            Check_String_Literal_Length (N, Target_Type);
+         end if;
+
+         return;
+      end if;
+
+      if Is_Out_Of_Range (N, Etype (N)) then
+         Out_Of_Range (N);
+      end if;
+
+   end Eval_Qualified_Expression;
+
+   -----------------------
+   -- Eval_Real_Literal --
+   -----------------------
+
+   --  Numeric literals are static (RM 4.9(1)), and have already been marked
+   --  as static by the analyzer. The reason we did it that early is to allow
+   --  the possibility of turning off the Is_Static_Expression flag after
+   --  analysis, but before resolution, when integer literals are generated
+   --  in the expander that do not correspond to static expressions.
+
+   procedure Eval_Real_Literal (N : Node_Id) is
+   begin
+      --  If the literal appears in a non-expression context, then it is
+      --  certainly appearing in a non-static context, so check it.
+
+      if Nkind (Parent (N)) not in N_Subexpr then
+         Check_Non_Static_Context (N);
+      end if;
+
+   end Eval_Real_Literal;
+
+   ------------------------
+   -- Eval_Relational_Op --
+   ------------------------
+
+   --  Relational operations are static functions, so the result is static
+   --  if both operands are static (RM 4.9(7), 4.9(20)).
+
+   procedure Eval_Relational_Op (N : Node_Id) is
+      Left   : constant Node_Id   := Left_Opnd (N);
+      Right  : constant Node_Id   := Right_Opnd (N);
+      Typ    : constant Entity_Id := Etype (Left);
+      Result : Boolean;
+      Stat   : Boolean;
+      Fold   : Boolean;
+
+   begin
+      --  One special case to deal with first. If we can tell that
+      --  the result will be false because the lengths of one or
+      --  more index subtypes are compile time known and different,
+      --  then we can replace the entire result by False. We only
+      --  do this for one dimensional arrays, because the case of
+      --  multi-dimensional arrays is rare and too much trouble!
+
+      if Is_Array_Type (Typ)
+        and then Number_Dimensions (Typ) = 1
+        and then (Nkind (N) = N_Op_Eq
+                    or else Nkind (N) = N_Op_Ne)
+      then
+         if Raises_Constraint_Error (Left)
+           or else Raises_Constraint_Error (Right)
+         then
+            return;
+         end if;
+
+         declare
+            procedure Get_Static_Length (Op : Node_Id; Len : out Uint);
+            --  If Op is an expression for a constrained array with a
+            --  known at compile time length, then Len is set to this
+            --  (non-negative length). Otherwise Len is set to minus 1.
+
+            procedure Get_Static_Length (Op : Node_Id; Len : out Uint) is
+               T : Entity_Id;
+
+            begin
+               if Nkind (Op) = N_String_Literal then
+                  Len := UI_From_Int (String_Length (Strval (Op)));
+
+               elsif not Is_Constrained (Etype (Op)) then
+                  Len := Uint_Minus_1;
+
+               else
+                  T := Etype (First_Index (Etype (Op)));
+
+                  if Is_Discrete_Type (T)
+                    and then
+                      Compile_Time_Known_Value (Type_Low_Bound (T))
+                    and then
+                      Compile_Time_Known_Value (Type_High_Bound (T))
+                  then
+                     Len := UI_Max (Uint_0,
+                                     Expr_Value (Type_High_Bound (T)) -
+                                     Expr_Value (Type_Low_Bound  (T)) + 1);
+                  else
+                     Len := Uint_Minus_1;
+                  end if;
+               end if;
+            end Get_Static_Length;
+
+            Len_L : Uint;
+            Len_R : Uint;
+
+         begin
+            Get_Static_Length (Left,  Len_L);
+            Get_Static_Length (Right, Len_R);
+
+            if Len_L /= Uint_Minus_1
+              and then Len_R /= Uint_Minus_1
+              and then Len_L /= Len_R
+            then
+               Fold_Uint (N, Test (Nkind (N) = N_Op_Ne));
+               Set_Is_Static_Expression (N, False);
+               Warn_On_Known_Condition (N);
+               return;
+            end if;
+         end;
+      end if;
+
+      --  Can only fold if type is scalar (don't fold string ops)
+
+      if not Is_Scalar_Type (Typ) then
+         Check_Non_Static_Context (Left);
+         Check_Non_Static_Context (Right);
+         return;
+      end if;
+
+      --  If not foldable we are done
+
+      Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
+
+      if not Fold then
+         return;
+      end if;
+
+      --  Integer and Enumeration (discrete) type cases
+
+      if Is_Discrete_Type (Typ) then
+         declare
+            Left_Int  : constant Uint := Expr_Value (Left);
+            Right_Int : constant Uint := Expr_Value (Right);
+
+         begin
+            case Nkind (N) is
+               when N_Op_Eq => Result := Left_Int =  Right_Int;
+               when N_Op_Ne => Result := Left_Int /= Right_Int;
+               when N_Op_Lt => Result := Left_Int <  Right_Int;
+               when N_Op_Le => Result := Left_Int <= Right_Int;
+               when N_Op_Gt => Result := Left_Int >  Right_Int;
+               when N_Op_Ge => Result := Left_Int >= Right_Int;
+
+               when others =>
+                  raise Program_Error;
+            end case;
+
+            Fold_Uint (N, Test (Result));
+         end;
+
+      --  Real type case
+
+      else
+         pragma Assert (Is_Real_Type (Typ));
+
+         declare
+            Left_Real  : constant Ureal := Expr_Value_R (Left);
+            Right_Real : constant Ureal := Expr_Value_R (Right);
+
+         begin
+            case Nkind (N) is
+               when N_Op_Eq => Result := (Left_Real =  Right_Real);
+               when N_Op_Ne => Result := (Left_Real /= Right_Real);
+               when N_Op_Lt => Result := (Left_Real <  Right_Real);
+               when N_Op_Le => Result := (Left_Real <= Right_Real);
+               when N_Op_Gt => Result := (Left_Real >  Right_Real);
+               when N_Op_Ge => Result := (Left_Real >= Right_Real);
+
+               when others =>
+                  raise Program_Error;
+            end case;
+
+            Fold_Uint (N, Test (Result));
+         end;
+      end if;
+
+      Set_Is_Static_Expression (N, Stat);
+      Warn_On_Known_Condition (N);
+   end Eval_Relational_Op;
+
+   ----------------
+   -- Eval_Shift --
+   ----------------
+
+   --  Shift operations are intrinsic operations that can never be static,
+   --  so the only processing required is to perform the required check for
+   --  a non static context for the two operands.
+
+   --  Actually we could do some compile time evaluation here some time ???
+
+   procedure Eval_Shift (N : Node_Id) is
+   begin
+      Check_Non_Static_Context (Left_Opnd (N));
+      Check_Non_Static_Context (Right_Opnd (N));
+   end Eval_Shift;
+
+   ------------------------
+   -- Eval_Short_Circuit --
+   ------------------------
+
+   --  A short circuit operation is potentially static if both operands
+   --  are potentially static (RM 4.9 (13))
+
+   procedure Eval_Short_Circuit (N : Node_Id) is
+      Kind     : constant Node_Kind := Nkind (N);
+      Left     : constant Node_Id   := Left_Opnd (N);
+      Right    : constant Node_Id   := Right_Opnd (N);
+      Left_Int : Uint;
+      Rstat    : constant Boolean   :=
+                   Is_Static_Expression (Left)
+                     and then Is_Static_Expression (Right);
+
+   begin
+      --  Short circuit operations are never static in Ada 83
+
+      if Ada_83
+        and then Comes_From_Source (N)
+      then
+         Check_Non_Static_Context (Left);
+         Check_Non_Static_Context (Right);
+         return;
+      end if;
+
+      --  Now look at the operands, we can't quite use the normal call to
+      --  Test_Expression_Is_Foldable here because short circuit operations
+      --  are a special case, they can still be foldable, even if the right
+      --  operand raises constraint error.
+
+      --  If either operand is Any_Type, just propagate to result and
+      --  do not try to fold, this prevents cascaded errors.
+
+      if Etype (Left) = Any_Type or else Etype (Right) = Any_Type then
+         Set_Etype (N, Any_Type);
+         return;
+
+      --  If left operand raises constraint error, then replace node N with
+      --  the raise constraint error node, and we are obviously not foldable.
+      --  Is_Static_Expression is set from the two operands in the normal way,
+      --  and we check the right operand if it is in a non-static context.
+
+      elsif Raises_Constraint_Error (Left) then
+         if not Rstat then
+            Check_Non_Static_Context (Right);
+         end if;
+
+         Rewrite_In_Raise_CE (N, Left);
+         Set_Is_Static_Expression (N, Rstat);
+         return;
+
+      --  If the result is not static, then we won't in any case fold
+
+      elsif not Rstat then
+         Check_Non_Static_Context (Left);
+         Check_Non_Static_Context (Right);
+         return;
+      end if;
+
+      --  Here the result is static, note that, unlike the normal processing
+      --  in Test_Expression_Is_Foldable, we did *not* check above to see if
+      --  the right operand raises constraint error, that's because it is not
+      --  significant if the left operand is decisive.
+
+      Set_Is_Static_Expression (N);
+
+      --  It does not matter if the right operand raises constraint error if
+      --  it will not be evaluated. So deal specially with the cases where
+      --  the right operand is not evaluated. Note that we will fold these
+      --  cases even if the right operand is non-static, which is fine, but
+      --  of course in these cases the result is not potentially static.
+
+      Left_Int := Expr_Value (Left);
+
+      if (Kind = N_And_Then and then Is_False (Left_Int))
+        or else (Kind = N_Or_Else and Is_True (Left_Int))
+      then
+         Fold_Uint (N, Left_Int);
+         return;
+      end if;
+
+      --  If first operand not decisive, then it does matter if the right
+      --  operand raises constraint error, since it will be evaluated, so
+      --  we simply replace the node with the right operand. Note that this
+      --  properly propagates Is_Static_Expression and Raises_Constraint_Error
+      --  (both are set to True in Right).
+
+      if Raises_Constraint_Error (Right) then
+         Rewrite_In_Raise_CE (N, Right);
+         Check_Non_Static_Context (Left);
+         return;
+      end if;
+
+      --  Otherwise the result depends on the right operand
+
+      Fold_Uint (N, Expr_Value (Right));
+      return;
+
+   end Eval_Short_Circuit;
+
+   ----------------
+   -- Eval_Slice --
+   ----------------
+
+   --  Slices can never be static, so the only processing required is to
+   --  check for non-static context if an explicit range is given.
+
+   procedure Eval_Slice (N : Node_Id) is
+      Drange : constant Node_Id := Discrete_Range (N);
+
+   begin
+      if Nkind (Drange) = N_Range then
+         Check_Non_Static_Context (Low_Bound (Drange));
+         Check_Non_Static_Context (High_Bound (Drange));
+      end if;
+   end Eval_Slice;
+
+   -------------------------
+   -- Eval_String_Literal --
+   -------------------------
+
+   procedure Eval_String_Literal (N : Node_Id) is
+      T : constant Entity_Id := Etype (N);
+      B : constant Entity_Id := Base_Type (T);
+      I : Entity_Id;
+
+   begin
+      --  Nothing to do if error type (handles cases like default expressions
+      --  or generics where we have not yet fully resolved the type)
+
+      if B = Any_Type or else B = Any_String then
+         return;
+
+      --  String literals are static if the subtype is static (RM 4.9(2)), so
+      --  reset the static expression flag (it was set unconditionally in
+      --  Analyze_String_Literal) if the subtype is non-static. We tell if
+      --  the subtype is static by looking at the lower bound.
+
+      elsif not Is_OK_Static_Expression (String_Literal_Low_Bound (T)) then
+         Set_Is_Static_Expression (N, False);
+
+      elsif Nkind (Original_Node (N)) = N_Type_Conversion then
+         Set_Is_Static_Expression (N, False);
+
+      --  Test for illegal Ada 95 cases. A string literal is illegal in
+      --  Ada 95 if its bounds are outside the index base type and this
+      --  index type is static. This can hapen in only two ways. Either
+      --  the string literal is too long, or it is null, and the lower
+      --  bound is type'First. In either case it is the upper bound that
+      --  is out of range of the index type.
+
+      elsif Ada_95 then
+         if Root_Type (B) = Standard_String
+           or else Root_Type (B) = Standard_Wide_String
+         then
+            I := Standard_Positive;
+         else
+            I := Etype (First_Index (B));
+         end if;
+
+         if String_Literal_Length (T) > String_Type_Len (B) then
+            Apply_Compile_Time_Constraint_Error
+              (N, "string literal too long for}",
+               Ent => B,
+               Typ => First_Subtype (B));
+
+         elsif String_Literal_Length (T) = 0
+            and then not Is_Generic_Type (I)
+            and then Expr_Value (String_Literal_Low_Bound (T)) =
+                     Expr_Value (Type_Low_Bound (Base_Type (I)))
+         then
+            Apply_Compile_Time_Constraint_Error
+              (N, "null string literal not allowed for}",
+               Ent => B,
+               Typ => First_Subtype (B));
+         end if;
+      end if;
+
+   end Eval_String_Literal;
+
+   --------------------------
+   -- Eval_Type_Conversion --
+   --------------------------
+
+   --  A type conversion is potentially static if its subtype mark is for a
+   --  static scalar subtype, and its operand expression is potentially static
+   --  (RM 4.9 (10))
+
+   procedure Eval_Type_Conversion (N : Node_Id) is
+      Operand     : constant Node_Id   := Expression (N);
+      Source_Type : constant Entity_Id := Etype (Operand);
+      Target_Type : constant Entity_Id := Etype (N);
+
+      Stat   : Boolean;
+      Fold   : Boolean;
+
+      function To_Be_Treated_As_Integer (T : Entity_Id) return Boolean;
+      --  Returns true if type T is an integer type, or if it is a
+      --  fixed-point type to be treated as an integer (i.e. the flag
+      --  Conversion_OK is set on the conversion node).
+
+      function To_Be_Treated_As_Real (T : Entity_Id) return Boolean;
+      --  Returns true if type T is a floating-point type, or if it is a
+      --  fixed-point type that is not to be treated as an integer (i.e. the
+      --  flag Conversion_OK is not set on the conversion node).
+
+      function To_Be_Treated_As_Integer (T : Entity_Id) return Boolean is
+      begin
+         return
+           Is_Integer_Type (T)
+             or else (Is_Fixed_Point_Type (T) and then Conversion_OK (N));
+      end To_Be_Treated_As_Integer;
+
+      function To_Be_Treated_As_Real (T : Entity_Id) return Boolean is
+      begin
+         return
+           Is_Floating_Point_Type (T)
+             or else (Is_Fixed_Point_Type (T) and then not Conversion_OK (N));
+      end To_Be_Treated_As_Real;
+
+   --  Start of processing for Eval_Type_Conversion
+
+   begin
+      --  Cannot fold if target type is non-static or if semantic error.
+
+      if not Is_Static_Subtype (Target_Type) then
+         Check_Non_Static_Context (Operand);
+         return;
+
+      elsif Error_Posted (N) then
+         return;
+      end if;
+
+      --  If not foldable we are done
+
+      Test_Expression_Is_Foldable (N, Operand, Stat, Fold);
+
+      if not Fold then
+         return;
+
+      --  Don't try fold if target type has constraint error bounds
+
+      elsif not Is_OK_Static_Subtype (Target_Type) then
+         Set_Raises_Constraint_Error (N);
+         return;
+      end if;
+
+      --  Remaining processing depends on operand types. Note that in the
+      --  following type test, fixed-point counts as real unless the flag
+      --  Conversion_OK is set, in which case it counts as integer.
+
+      --  Fold conversion, case of string type. The result is not static.
+
+      if Is_String_Type (Target_Type) then
+         Fold_Str (N, Strval (Get_String_Val (Operand)));
+         Set_Is_Static_Expression (N, False);
+
+         return;
+
+      --  Fold conversion, case of integer target type
+
+      elsif To_Be_Treated_As_Integer (Target_Type) then
+         declare
+            Result : Uint;
+
+         begin
+            --  Integer to integer conversion
+
+            if To_Be_Treated_As_Integer (Source_Type) then
+               Result := Expr_Value (Operand);
+
+            --  Real to integer conversion
+
+            else
+               Result := UR_To_Uint (Expr_Value_R (Operand));
+            end if;
+
+            --  If fixed-point type (Conversion_OK must be set), then the
+            --  result is logically an integer, but we must replace the
+            --  conversion with the corresponding real literal, since the
+            --  type from a semantic point of view is still fixed-point.
+
+            if Is_Fixed_Point_Type (Target_Type) then
+               Fold_Ureal
+                 (N, UR_From_Uint (Result) * Small_Value (Target_Type));
+
+            --  Otherwise result is integer literal
+
+            else
+               Fold_Uint (N, Result);
+            end if;
+         end;
+
+      --  Fold conversion, case of real target type
+
+      elsif To_Be_Treated_As_Real (Target_Type) then
+         declare
+            Result : Ureal;
+
+         begin
+            if To_Be_Treated_As_Real (Source_Type) then
+               Result := Expr_Value_R (Operand);
+            else
+               Result := UR_From_Uint (Expr_Value (Operand));
+            end if;
+
+            Fold_Ureal (N, Result);
+         end;
+
+      --  Enumeration types
+
+      else
+         Fold_Uint (N, Expr_Value (Operand));
+      end if;
+
+      Set_Is_Static_Expression (N, Stat);
+
+      if Is_Out_Of_Range (N, Etype (N)) then
+         Out_Of_Range (N);
+      end if;
+
+   end Eval_Type_Conversion;
+
+   -------------------
+   -- Eval_Unary_Op --
+   -------------------
+
+   --  Predefined unary operators are static functions (RM 4.9(20)) and thus
+   --  are potentially static if the operand is potentially static (RM 4.9(7))
+
+   procedure Eval_Unary_Op (N : Node_Id) is
+      Right : constant Node_Id := Right_Opnd (N);
+      Stat  : Boolean;
+      Fold  : Boolean;
+
+   begin
+      --  If not foldable we are done
+
+      Test_Expression_Is_Foldable (N, Right, Stat, Fold);
+
+      if not Fold then
+         return;
+      end if;
+
+      --  Fold for integer case
+
+      if Is_Integer_Type (Etype (N)) then
+         declare
+            Rint   : constant Uint := Expr_Value (Right);
+            Result : Uint;
+
+         begin
+            --  In the case of modular unary plus and abs there is no need
+            --  to adjust the result of the operation since if the original
+            --  operand was in bounds the result will be in the bounds of the
+            --  modular type. However, in the case of modular unary minus the
+            --  result may go out of the bounds of the modular type and needs
+            --  adjustment.
+
+            if Nkind (N) = N_Op_Plus then
+               Result := Rint;
+
+            elsif Nkind (N) = N_Op_Minus then
+               if Is_Modular_Integer_Type (Etype (N)) then
+                  Result := (-Rint) mod Modulus (Etype (N));
+               else
+                  Result := (-Rint);
+               end if;
+
+            else
+               pragma Assert (Nkind (N) = N_Op_Abs);
+               Result := abs Rint;
+            end if;
+
+            Fold_Uint (N, Result);
+         end;
+
+      --  Fold for real case
+
+      elsif Is_Real_Type (Etype (N)) then
+         declare
+            Rreal  : constant Ureal := Expr_Value_R (Right);
+            Result : Ureal;
+
+         begin
+            if Nkind (N) = N_Op_Plus then
+               Result := Rreal;
+
+            elsif Nkind (N) = N_Op_Minus then
+               Result := UR_Negate (Rreal);
+
+            else
+               pragma Assert (Nkind (N) = N_Op_Abs);
+               Result := abs Rreal;
+            end if;
+
+            Fold_Ureal (N, Result);
+         end;
+      end if;
+
+      Set_Is_Static_Expression (N, Stat);
+
+   end Eval_Unary_Op;
+
+   -------------------------------
+   -- Eval_Unchecked_Conversion --
+   -------------------------------
+
+   --  Unchecked conversions can never be static, so the only required
+   --  processing is to check for a non-static context for the operand.
+
+   procedure Eval_Unchecked_Conversion (N : Node_Id) is
+   begin
+      Check_Non_Static_Context (Expression (N));
+   end Eval_Unchecked_Conversion;
+
+   --------------------
+   -- Expr_Rep_Value --
+   --------------------
+
+   function Expr_Rep_Value (N : Node_Id) return Uint is
+      Kind   : constant Node_Kind := Nkind (N);
+      Ent    : Entity_Id;
+
+   begin
+      if Is_Entity_Name (N) then
+         Ent := Entity (N);
+
+         --  An enumeration literal that was either in the source or
+         --  created as a result of static evaluation.
+
+         if Ekind (Ent) = E_Enumeration_Literal then
+            return Enumeration_Rep (Ent);
+
+         --  A user defined static constant
+
+         else
+            pragma Assert (Ekind (Ent) = E_Constant);
+            return Expr_Rep_Value (Constant_Value (Ent));
+         end if;
+
+      --  An integer literal that was either in the source or created
+      --  as a result of static evaluation.
+
+      elsif Kind = N_Integer_Literal then
+         return Intval (N);
+
+      --  A real literal for a fixed-point type. This must be the fixed-point
+      --  case, either the literal is of a fixed-point type, or it is a bound
+      --  of a fixed-point type, with type universal real. In either case we
+      --  obtain the desired value from Corresponding_Integer_Value.
+
+      elsif Kind = N_Real_Literal then
+
+         --  Apply the assertion to the Underlying_Type of the literal for
+         --  the benefit of calls to this function in the JGNAT back end,
+         --  where literal types can reflect private views.
+
+         pragma Assert (Is_Fixed_Point_Type (Underlying_Type (Etype (N))));
+         return Corresponding_Integer_Value (N);
+
+      else
+         pragma Assert (Kind = N_Character_Literal);
+         Ent := Entity (N);
+
+         --  Since Character literals of type Standard.Character don't
+         --  have any defining character literals built for them, they
+         --  do not have their Entity set, so just use their Char
+         --  code. Otherwise for user-defined character literals use
+         --  their Pos value as usual which is the same as the Rep value.
+
+         if No (Ent) then
+            return UI_From_Int (Int (Char_Literal_Value (N)));
+         else
+            return Enumeration_Rep (Ent);
+         end if;
+      end if;
+   end Expr_Rep_Value;
+
+   ----------------
+   -- Expr_Value --
+   ----------------
+
+   function Expr_Value (N : Node_Id) return Uint is
+      Kind : constant Node_Kind := Nkind (N);
+      Ent  : Entity_Id;
+
+   begin
+      if Is_Entity_Name (N) then
+         Ent := Entity (N);
+
+         --  An enumeration literal that was either in the source or
+         --  created as a result of static evaluation.
+
+         if Ekind (Ent) = E_Enumeration_Literal then
+            return Enumeration_Pos (Ent);
+
+         --  A user defined static constant
+
+         else
+            pragma Assert (Ekind (Ent) = E_Constant);
+            return Expr_Value (Constant_Value (Ent));
+         end if;
+
+      --  An integer literal that was either in the source or created
+      --  as a result of static evaluation.
+
+      elsif Kind = N_Integer_Literal then
+         return Intval (N);
+
+      --  A real literal for a fixed-point type. This must be the fixed-point
+      --  case, either the literal is of a fixed-point type, or it is a bound
+      --  of a fixed-point type, with type universal real. In either case we
+      --  obtain the desired value from Corresponding_Integer_Value.
+
+      elsif Kind = N_Real_Literal then
+
+         --  Apply the assertion to the Underlying_Type of the literal for
+         --  the benefit of calls to this function in the JGNAT back end,
+         --  where literal types can reflect private views.
+
+         pragma Assert (Is_Fixed_Point_Type (Underlying_Type (Etype (N))));
+         return Corresponding_Integer_Value (N);
+
+      --  Peculiar VMS case, if we have xxx'Null_Parameter, return zero
+
+      elsif Kind = N_Attribute_Reference
+        and then Attribute_Name (N) = Name_Null_Parameter
+      then
+         return Uint_0;
+
+      --  Otherwise must be character literal
+
+      else
+         pragma Assert (Kind = N_Character_Literal);
+         Ent := Entity (N);
+
+         --  Since Character literals of type Standard.Character don't
+         --  have any defining character literals built for them, they
+         --  do not have their Entity set, so just use their Char
+         --  code. Otherwise for user-defined character literals use
+         --  their Pos value as usual.
+
+         if No (Ent) then
+            return UI_From_Int (Int (Char_Literal_Value (N)));
+         else
+            return Enumeration_Pos (Ent);
+         end if;
+      end if;
+
+   end Expr_Value;
+
+   ------------------
+   -- Expr_Value_E --
+   ------------------
+
+   function Expr_Value_E (N : Node_Id) return Entity_Id is
+      Ent  : constant Entity_Id := Entity (N);
+
+   begin
+      if Ekind (Ent) = E_Enumeration_Literal then
+         return Ent;
+      else
+         pragma Assert (Ekind (Ent) = E_Constant);
+         return Expr_Value_E (Constant_Value (Ent));
+      end if;
+   end Expr_Value_E;
+
+   ------------------
+   -- Expr_Value_R --
+   ------------------
+
+   function Expr_Value_R (N : Node_Id) return Ureal is
+      Kind : constant Node_Kind := Nkind (N);
+      Ent  : Entity_Id;
+      Expr : Node_Id;
+
+   begin
+      if Kind = N_Real_Literal then
+         return Realval (N);
+
+      elsif Kind = N_Identifier or else Kind = N_Expanded_Name then
+         Ent := Entity (N);
+         pragma Assert (Ekind (Ent) = E_Constant);
+         return Expr_Value_R (Constant_Value (Ent));
+
+      elsif Kind = N_Integer_Literal then
+         return UR_From_Uint (Expr_Value (N));
+
+      --  Strange case of VAX literals, which are at this stage transformed
+      --  into Vax_Type!x_To_y(IEEE_Literal). See Expand_N_Real_Literal in
+      --  Exp_Vfpt for further details.
+
+      elsif Vax_Float (Etype (N))
+        and then Nkind (N) = N_Unchecked_Type_Conversion
+      then
+         Expr := Expression (N);
+
+         if Nkind (Expr) = N_Function_Call
+           and then Present (Parameter_Associations (Expr))
+         then
+            Expr := First (Parameter_Associations (Expr));
+
+            if Nkind (Expr) = N_Real_Literal then
+               return Realval (Expr);
+            end if;
+         end if;
+
+      --  Peculiar VMS case, if we have xxx'Null_Parameter, return 0.0
+
+      elsif Kind = N_Attribute_Reference
+        and then Attribute_Name (N) = Name_Null_Parameter
+      then
+         return Ureal_0;
+      end if;
+
+      --  If we fall through, we have a node that cannot be interepreted
+      --  as a compile time constant. That is definitely an error.
+
+      raise Program_Error;
+   end Expr_Value_R;
+
+   ------------------
+   -- Expr_Value_S --
+   ------------------
+
+   function Expr_Value_S (N : Node_Id) return Node_Id is
+   begin
+      if Nkind (N) = N_String_Literal then
+         return N;
+      else
+         pragma Assert (Ekind (Entity (N)) = E_Constant);
+         return Expr_Value_S (Constant_Value (Entity (N)));
+      end if;
+   end Expr_Value_S;
+
+   --------------
+   -- Fold_Str --
+   --------------
+
+   procedure Fold_Str (N : Node_Id; Val : String_Id) is
+      Loc : constant Source_Ptr := Sloc (N);
+      Typ : constant Entity_Id  := Etype (N);
+
+   begin
+      Rewrite (N, Make_String_Literal (Loc, Strval => Val));
+      Analyze_And_Resolve (N, Typ);
+   end Fold_Str;
+
+   ---------------
+   -- Fold_Uint --
+   ---------------
+
+   procedure Fold_Uint (N : Node_Id; Val : Uint) is
+      Loc : constant Source_Ptr := Sloc (N);
+      Typ : constant Entity_Id  := Etype (N);
+
+   begin
+      --  For a result of type integer, subsitute an N_Integer_Literal node
+      --  for the result of the compile time evaluation of the expression.
+
+      if Is_Integer_Type (Etype (N)) then
+         Rewrite (N, Make_Integer_Literal (Loc, Val));
+
+      --  Otherwise we have an enumeration type, and we substitute either
+      --  an N_Identifier or N_Character_Literal to represent the enumeration
+      --  literal corresponding to the given value, which must always be in
+      --  range, because appropriate tests have already been made for this.
+
+      else pragma Assert (Is_Enumeration_Type (Etype (N)));
+         Rewrite (N, Get_Enum_Lit_From_Pos (Etype (N), Val, Loc));
+      end if;
+
+      --  We now have the literal with the right value, both the actual type
+      --  and the expected type of this literal are taken from the expression
+      --  that was evaluated.
+
+      Analyze (N);
+      Set_Etype (N, Typ);
+      Resolve (N, Typ);
+   end Fold_Uint;
+
+   ----------------
+   -- Fold_Ureal --
+   ----------------
+
+   procedure Fold_Ureal (N : Node_Id; Val : Ureal) is
+      Loc : constant Source_Ptr := Sloc (N);
+      Typ : constant Entity_Id  := Etype (N);
+
+   begin
+      Rewrite (N, Make_Real_Literal (Loc, Realval => Val));
+      Analyze (N);
+
+      --  Both the actual and expected type comes from the original expression
+
+      Set_Etype (N, Typ);
+      Resolve (N, Typ);
+   end Fold_Ureal;
+
+   ---------------
+   -- From_Bits --
+   ---------------
+
+   function From_Bits (B : Bits; T : Entity_Id) return Uint is
+      V : Uint := Uint_0;
+
+   begin
+      for J in 0 .. B'Last loop
+         if B (J) then
+            V := V + 2 ** J;
+         end if;
+      end loop;
+
+      if Non_Binary_Modulus (T) then
+         V := V mod Modulus (T);
+      end if;
+
+      return V;
+   end From_Bits;
+
+   --------------------
+   -- Get_String_Val --
+   --------------------
+
+   function Get_String_Val (N : Node_Id) return Node_Id is
+   begin
+      if Nkind (N) = N_String_Literal then
+         return N;
+
+      elsif Nkind (N) = N_Character_Literal then
+         return N;
+
+      else
+         pragma Assert (Is_Entity_Name (N));
+         return Get_String_Val (Constant_Value (Entity (N)));
+      end if;
+   end Get_String_Val;
+
+   --------------------
+   -- In_Subrange_Of --
+   --------------------
+
+   function In_Subrange_Of
+     (T1        : Entity_Id;
+      T2        : Entity_Id;
+      Fixed_Int : Boolean := False)
+      return      Boolean
+   is
+      L1 : Node_Id;
+      H1 : Node_Id;
+
+      L2 : Node_Id;
+      H2 : Node_Id;
+
+   begin
+      if T1 = T2 or else Is_Subtype_Of (T1, T2) then
+         return True;
+
+      --  Never in range if both types are not scalar. Don't know if this can
+      --  actually happen, but just in case.
+
+      elsif not Is_Scalar_Type (T1) or else not Is_Scalar_Type (T1) then
+         return False;
+
+      else
+         L1 := Type_Low_Bound  (T1);
+         H1 := Type_High_Bound (T1);
+
+         L2 := Type_Low_Bound  (T2);
+         H2 := Type_High_Bound (T2);
+
+         --  Check bounds to see if comparison possible at compile time
+
+         if Compile_Time_Compare (L1, L2) in Compare_GE
+              and then
+            Compile_Time_Compare (H1, H2) in Compare_LE
+         then
+            return True;
+         end if;
+
+         --  If bounds not comparable at compile time, then the bounds of T2
+         --  must be compile time known or we cannot answer the query.
+
+         if not Compile_Time_Known_Value (L2)
+           or else not Compile_Time_Known_Value (H2)
+         then
+            return False;
+         end if;
+
+         --  If the bounds of T1 are know at compile time then use these
+         --  ones, otherwise use the bounds of the base type (which are of
+         --  course always static).
+
+         if not Compile_Time_Known_Value (L1) then
+            L1 := Type_Low_Bound (Base_Type (T1));
+         end if;
+
+         if not Compile_Time_Known_Value (H1) then
+            H1 := Type_High_Bound (Base_Type (T1));
+         end if;
+
+         --  Fixed point types should be considered as such only if
+         --  flag Fixed_Int is set to False.
+
+         if Is_Floating_Point_Type (T1) or else Is_Floating_Point_Type (T2)
+           or else (Is_Fixed_Point_Type (T1) and then not Fixed_Int)
+           or else (Is_Fixed_Point_Type (T2) and then not Fixed_Int)
+         then
+            return
+              Expr_Value_R (L2) <= Expr_Value_R (L1)
+                and then
+              Expr_Value_R (H2) >= Expr_Value_R (H1);
+
+         else
+            return
+              Expr_Value (L2) <= Expr_Value (L1)
+                and then
+              Expr_Value (H2) >= Expr_Value (H1);
+
+         end if;
+      end if;
+
+   --  If any exception occurs, it means that we have some bug in the compiler
+   --  possibly triggered by a previous error, or by some unforseen peculiar
+   --  occurrence. However, this is only an optimization attempt, so there is
+   --  really no point in crashing the compiler. Instead we just decide, too
+   --  bad, we can't figure out the answer in this case after all.
+
+   exception
+      when others =>
+
+         --  Debug flag K disables this behavior (useful for debugging)
+
+         if Debug_Flag_K then
+            raise;
+         else
+            return False;
+         end if;
+   end In_Subrange_Of;
+
+   -----------------
+   -- Is_In_Range --
+   -----------------
+
+   function Is_In_Range
+     (N         : Node_Id;
+      Typ       : Entity_Id;
+      Fixed_Int : Boolean := False;
+      Int_Real  : Boolean := False)
+      return      Boolean
+   is
+      Val  : Uint;
+      Valr : Ureal;
+
+   begin
+      --  Universal types have no range limits, so always in range.
+
+      if Typ = Universal_Integer or else Typ = Universal_Real then
+         return True;
+
+      --  Never in range if not scalar type. Don't know if this can
+      --  actually happen, but our spec allows it, so we must check!
+
+      elsif not Is_Scalar_Type (Typ) then
+         return False;
+
+      --  Never in range unless we have a compile time known value.
+
+      elsif not Compile_Time_Known_Value (N) then
+         return False;
+
+      else
+         declare
+            Lo       : constant Node_Id := Type_Low_Bound  (Typ);
+            Hi       : constant Node_Id := Type_High_Bound (Typ);
+            LB_Known : constant Boolean := Compile_Time_Known_Value (Lo);
+            UB_Known : constant Boolean := Compile_Time_Known_Value (Hi);
+
+         begin
+            --  Fixed point types should be considered as such only in
+            --  flag Fixed_Int is set to False.
+
+            if Is_Floating_Point_Type (Typ)
+              or else (Is_Fixed_Point_Type (Typ) and then not Fixed_Int)
+              or else Int_Real
+            then
+               Valr := Expr_Value_R (N);
+
+               if LB_Known and then Valr >= Expr_Value_R (Lo)
+                 and then UB_Known and then Valr <= Expr_Value_R (Hi)
+               then
+                  return True;
+               else
+                  return False;
+               end if;
+
+            else
+               Val := Expr_Value (N);
+
+               if         LB_Known and then Val >= Expr_Value (Lo)
+                 and then UB_Known and then Val <= Expr_Value (Hi)
+               then
+                  return True;
+               else
+                  return False;
+               end if;
+            end if;
+         end;
+      end if;
+   end Is_In_Range;
+
+   -------------------
+   -- Is_Null_Range --
+   -------------------
+
+   function Is_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean is
+      Typ : constant Entity_Id := Etype (Lo);
+
+   begin
+      if not Compile_Time_Known_Value (Lo)
+        or else not Compile_Time_Known_Value (Hi)
+      then
+         return False;
+      end if;
+
+      if Is_Discrete_Type (Typ) then
+         return Expr_Value (Lo) > Expr_Value (Hi);
+
+      else
+         pragma Assert (Is_Real_Type (Typ));
+         return Expr_Value_R (Lo) > Expr_Value_R (Hi);
+      end if;
+   end Is_Null_Range;
+
+   -----------------------------
+   -- Is_OK_Static_Expression --
+   -----------------------------
+
+   function Is_OK_Static_Expression (N : Node_Id) return Boolean is
+   begin
+      return Is_Static_Expression (N)
+        and then not Raises_Constraint_Error (N);
+   end Is_OK_Static_Expression;
+
+   ------------------------
+   -- Is_OK_Static_Range --
+   ------------------------
+
+   --  A static range is a range whose bounds are static expressions, or a
+   --  Range_Attribute_Reference equivalent to such a range (RM 4.9(26)).
+   --  We have already converted range attribute references, so we get the
+   --  "or" part of this rule without needing a special test.
+
+   function Is_OK_Static_Range (N : Node_Id) return Boolean is
+   begin
+      return Is_OK_Static_Expression (Low_Bound (N))
+        and then Is_OK_Static_Expression (High_Bound (N));
+   end Is_OK_Static_Range;
+
+   --------------------------
+   -- Is_OK_Static_Subtype --
+   --------------------------
+
+   --  Determines if Typ is a static subtype as defined in (RM 4.9(26))
+   --  where neither bound raises constraint error when evaluated.
+
+   function Is_OK_Static_Subtype (Typ : Entity_Id) return Boolean is
+      Base_T   : constant Entity_Id := Base_Type (Typ);
+      Anc_Subt : Entity_Id;
+
+   begin
+      --  First a quick check on the non static subtype flag. As described
+      --  in further detail in Einfo, this flag is not decisive in all cases,
+      --  but if it is set, then the subtype is definitely non-static.
+
+      if Is_Non_Static_Subtype (Typ) then
+         return False;
+      end if;
+
+      Anc_Subt := Ancestor_Subtype (Typ);
+
+      if Anc_Subt = Empty then
+         Anc_Subt := Base_T;
+      end if;
+
+      if Is_Generic_Type (Root_Type (Base_T))
+        or else Is_Generic_Actual_Type (Base_T)
+      then
+         return False;
+
+      --  String types
+
+      elsif Is_String_Type (Typ) then
+         return
+           Ekind (Typ) = E_String_Literal_Subtype
+             or else
+           (Is_OK_Static_Subtype (Component_Type (Typ))
+              and then Is_OK_Static_Subtype (Etype (First_Index (Typ))));
+
+      --  Scalar types
+
+      elsif Is_Scalar_Type (Typ) then
+         if Base_T = Typ then
+            return True;
+
+         else
+            --  Scalar_Range (Typ) might be an N_Subtype_Indication, so
+            --  use Get_Type_Low,High_Bound.
+
+            return     Is_OK_Static_Subtype (Anc_Subt)
+              and then Is_OK_Static_Expression (Type_Low_Bound (Typ))
+              and then Is_OK_Static_Expression (Type_High_Bound (Typ));
+         end if;
+
+      --  Types other than string and scalar types are never static
+
+      else
+         return False;
+      end if;
+   end Is_OK_Static_Subtype;
+
+   ---------------------
+   -- Is_Out_Of_Range --
+   ---------------------
+
+   function Is_Out_Of_Range
+     (N         : Node_Id;
+      Typ       : Entity_Id;
+      Fixed_Int : Boolean := False;
+      Int_Real  : Boolean := False)
+      return      Boolean
+   is
+      Val  : Uint;
+      Valr : Ureal;
+
+   begin
+      --  Universal types have no range limits, so always in range.
+
+      if Typ = Universal_Integer or else Typ = Universal_Real then
+         return False;
+
+      --  Never out of range if not scalar type. Don't know if this can
+      --  actually happen, but our spec allows it, so we must check!
+
+      elsif not Is_Scalar_Type (Typ) then
+         return False;
+
+      --  Never out of range if this is a generic type, since the bounds
+      --  of generic types are junk. Note that if we only checked for
+      --  static expressions (instead of compile time known values) below,
+      --  we would not need this check, because values of a generic type
+      --  can never be static, but they can be known at compile time.
+
+      elsif Is_Generic_Type (Typ) then
+         return False;
+
+      --  Never out of range unless we have a compile time known value.
+
+      elsif not Compile_Time_Known_Value (N) then
+         return False;
+
+      else
+         declare
+            Lo       : constant Node_Id := Type_Low_Bound  (Typ);
+            Hi       : constant Node_Id := Type_High_Bound (Typ);
+            LB_Known : constant Boolean := Compile_Time_Known_Value (Lo);
+            UB_Known : constant Boolean := Compile_Time_Known_Value (Hi);
+
+         begin
+            --  Real types (note that fixed-point types are not treated
+            --  as being of a real type if the flag Fixed_Int is set,
+            --  since in that case they are regarded as integer types).
+
+            if Is_Floating_Point_Type (Typ)
+              or else (Is_Fixed_Point_Type (Typ) and then not Fixed_Int)
+              or else Int_Real
+            then
+               Valr := Expr_Value_R (N);
+
+               if LB_Known and then Valr < Expr_Value_R (Lo) then
+                  return True;
+
+               elsif UB_Known and then Expr_Value_R (Hi) < Valr then
+                  return True;
+
+               else
+                  return False;
+               end if;
+
+            else
+               Val := Expr_Value (N);
+
+               if LB_Known and then Val < Expr_Value (Lo) then
+                  return True;
+
+               elsif UB_Known and then Expr_Value (Hi) < Val then
+                  return True;
+
+               else
+                  return False;
+               end if;
+            end if;
+         end;
+      end if;
+   end Is_Out_Of_Range;
+
+   ---------------------
+   -- Is_Static_Range --
+   ---------------------
+
+   --  A static range is a range whose bounds are static expressions, or a
+   --  Range_Attribute_Reference equivalent to such a range (RM 4.9(26)).
+   --  We have already converted range attribute references, so we get the
+   --  "or" part of this rule without needing a special test.
+
+   function Is_Static_Range (N : Node_Id) return Boolean is
+   begin
+      return Is_Static_Expression (Low_Bound (N))
+        and then Is_Static_Expression (High_Bound (N));
+   end Is_Static_Range;
+
+   -----------------------
+   -- Is_Static_Subtype --
+   -----------------------
+
+   --  Determines if Typ is a static subtype as defined in (RM 4.9(26)).
+
+   function Is_Static_Subtype (Typ : Entity_Id) return Boolean is
+      Base_T   : constant Entity_Id := Base_Type (Typ);
+      Anc_Subt : Entity_Id;
+
+   begin
+      --  First a quick check on the non static subtype flag. As described
+      --  in further detail in Einfo, this flag is not decisive in all cases,
+      --  but if it is set, then the subtype is definitely non-static.
+
+      if Is_Non_Static_Subtype (Typ) then
+         return False;
+      end if;
+
+      Anc_Subt := Ancestor_Subtype (Typ);
+
+      if Anc_Subt = Empty then
+         Anc_Subt := Base_T;
+      end if;
+
+      if Is_Generic_Type (Root_Type (Base_T))
+        or else Is_Generic_Actual_Type (Base_T)
+      then
+         return False;
+
+      --  String types
+
+      elsif Is_String_Type (Typ) then
+         return
+           Ekind (Typ) = E_String_Literal_Subtype
+             or else
+           (Is_Static_Subtype (Component_Type (Typ))
+              and then Is_Static_Subtype (Etype (First_Index (Typ))));
+
+      --  Scalar types
+
+      elsif Is_Scalar_Type (Typ) then
+         if Base_T = Typ then
+            return True;
+
+         else
+            return     Is_Static_Subtype (Anc_Subt)
+              and then Is_Static_Expression (Type_Low_Bound (Typ))
+              and then Is_Static_Expression (Type_High_Bound (Typ));
+         end if;
+
+      --  Types other than string and scalar types are never static
+
+      else
+         return False;
+      end if;
+   end Is_Static_Subtype;
+
+   --------------------
+   -- Not_Null_Range --
+   --------------------
+
+   function Not_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean is
+      Typ : constant Entity_Id := Etype (Lo);
+
+   begin
+      if not Compile_Time_Known_Value (Lo)
+        or else not Compile_Time_Known_Value (Hi)
+      then
+         return False;
+      end if;
+
+      if Is_Discrete_Type (Typ) then
+         return Expr_Value (Lo) <= Expr_Value (Hi);
+
+      else
+         pragma Assert (Is_Real_Type (Typ));
+
+         return Expr_Value_R (Lo) <= Expr_Value_R (Hi);
+      end if;
+   end Not_Null_Range;
+
+   -------------
+   -- OK_Bits --
+   -------------
+
+   function OK_Bits (N : Node_Id; Bits : Uint) return Boolean is
+   begin
+      --  We allow a maximum of 500,000 bits which seems a reasonable limit
+
+      if Bits < 500_000 then
+         return True;
+
+      else
+         Error_Msg_N ("static value too large, capacity exceeded", N);
+         return False;
+      end if;
+   end OK_Bits;
+
+   ------------------
+   -- Out_Of_Range --
+   ------------------
+
+   procedure Out_Of_Range (N : Node_Id) is
+   begin
+      --  If we have the static expression case, then this is an illegality
+      --  in Ada 95 mode, except that in an instance, we never generate an
+      --  error (if the error is legitimate, it was already diagnosed in
+      --  the template). The expression to compute the length of a packed
+      --  array is attached to the array type itself, and deserves a separate
+      --  message.
+
+      if Is_Static_Expression (N)
+        and then not In_Instance
+        and then Ada_95
+      then
+
+         if Nkind (Parent (N)) = N_Defining_Identifier
+           and then Is_Array_Type (Parent (N))
+           and then Present (Packed_Array_Type (Parent (N)))
+           and then Present (First_Rep_Item (Parent (N)))
+         then
+            Error_Msg_N
+             ("length of packed array must not exceed Integer''Last",
+              First_Rep_Item (Parent (N)));
+            Rewrite (N, Make_Integer_Literal (Sloc (N), Uint_1));
+
+         else
+            Apply_Compile_Time_Constraint_Error
+              (N, "value not in range of}");
+         end if;
+
+      --  Here we generate a warning for the Ada 83 case, or when we are
+      --  in an instance, or when we have a non-static expression case.
+
+      else
+         Warn_On_Instance := True;
+         Apply_Compile_Time_Constraint_Error
+           (N, "value not in range of}?");
+         Warn_On_Instance := False;
+      end if;
+   end Out_Of_Range;
+
+   -------------------------
+   -- Rewrite_In_Raise_CE --
+   -------------------------
+
+   procedure Rewrite_In_Raise_CE (N : Node_Id; Exp : Node_Id) is
+      Typ : constant Entity_Id := Etype (N);
+
+   begin
+      --  If we want to raise CE in the condition of a raise_CE node
+      --  we may as well get rid of the condition
+
+      if Present (Parent (N))
+        and then Nkind (Parent (N)) = N_Raise_Constraint_Error
+      then
+         Set_Condition (Parent (N), Empty);
+
+      --  If the expression raising CE is a N_Raise_CE node, we can use
+      --  that one. We just preserve the type of the context
+
+      elsif Nkind (Exp) = N_Raise_Constraint_Error then
+         Rewrite (N, Exp);
+         Set_Etype (N, Typ);
+
+      --  We have to build an explicit raise_ce node
+
+      else
+         Rewrite (N, Make_Raise_Constraint_Error (Sloc (Exp)));
+         Set_Raises_Constraint_Error (N);
+         Set_Etype (N, Typ);
+      end if;
+   end Rewrite_In_Raise_CE;
+
+   ---------------------
+   -- String_Type_Len --
+   ---------------------
+
+   function String_Type_Len (Stype : Entity_Id) return Uint is
+      NT : constant Entity_Id := Etype (First_Index (Stype));
+      T  : Entity_Id;
+
+   begin
+      if Is_OK_Static_Subtype (NT) then
+         T := NT;
+      else
+         T := Base_Type (NT);
+      end if;
+
+      return Expr_Value (Type_High_Bound (T)) -
+             Expr_Value (Type_Low_Bound (T)) + 1;
+   end String_Type_Len;
+
+   ------------------------------------
+   -- Subtypes_Statically_Compatible --
+   ------------------------------------
+
+   function Subtypes_Statically_Compatible
+     (T1   : Entity_Id;
+      T2   : Entity_Id)
+      return Boolean
+   is
+   begin
+      if Is_Scalar_Type (T1) then
+
+         --  Definitely compatible if we match
+
+         if Subtypes_Statically_Match (T1, T2) then
+            return True;
+
+         --  If either subtype is nonstatic then they're not compatible
+
+         elsif not Is_Static_Subtype (T1)
+           or else not Is_Static_Subtype (T2)
+         then
+            return False;
+
+         --  If either type has constraint error bounds, then consider that
+         --  they match to avoid junk cascaded errors here.
+
+         elsif not Is_OK_Static_Subtype (T1)
+           or else not Is_OK_Static_Subtype (T2)
+         then
+            return True;
+
+         --  Base types must match, but we don't check that (should
+         --  we???) but we do at least check that both types are
+         --  real, or both types are not real.
+
+         elsif (Is_Real_Type (T1) /= Is_Real_Type (T2)) then
+            return False;
+
+         --  Here we check the bounds
+
+         else
+            declare
+               LB1 : constant Node_Id := Type_Low_Bound  (T1);
+               HB1 : constant Node_Id := Type_High_Bound (T1);
+               LB2 : constant Node_Id := Type_Low_Bound  (T2);
+               HB2 : constant Node_Id := Type_High_Bound (T2);
+
+            begin
+               if Is_Real_Type (T1) then
+                  return
+                    (Expr_Value_R (LB1) > Expr_Value_R (HB1))
+                      or else
+                    (Expr_Value_R (LB2) <= Expr_Value_R (LB1)
+                       and then
+                     Expr_Value_R (HB1) <= Expr_Value_R (HB2));
+
+               else
+                  return
+                    (Expr_Value (LB1) > Expr_Value (HB1))
+                      or else
+                    (Expr_Value (LB2) <= Expr_Value (LB1)
+                       and then
+                     Expr_Value (HB1) <= Expr_Value (HB2));
+               end if;
+            end;
+         end if;
+
+      elsif Is_Access_Type (T1) then
+         return not Is_Constrained (T2)
+           or else Subtypes_Statically_Match
+                     (Designated_Type (T1), Designated_Type (T2));
+
+      else
+         return (Is_Composite_Type (T1) and then not Is_Constrained (T2))
+           or else Subtypes_Statically_Match (T1, T2);
+      end if;
+   end Subtypes_Statically_Compatible;
+
+   -------------------------------
+   -- Subtypes_Statically_Match --
+   -------------------------------
+
+   --  Subtypes statically match if they have statically matching constraints
+   --  (RM 4.9.1(2)). Constraints statically match if there are none, or if
+   --  they are the same identical constraint, or if they are static and the
+   --  values match (RM 4.9.1(1)).
+
+   function Subtypes_Statically_Match (T1, T2 : Entity_Id) return Boolean is
+   begin
+      --  A type always statically matches itself
+
+      if T1 = T2 then
+         return True;
+
+      --  Scalar types
+
+      elsif Is_Scalar_Type (T1) then
+
+         --  Base types must be the same
+
+         if Base_Type (T1) /= Base_Type (T2) then
+            return False;
+         end if;
+
+         --  A constrained numeric subtype never matches an unconstrained
+         --  subtype, i.e. both types must be constrained or unconstrained.
+
+         --  To understand the requirement for this test, see RM 4.9.1(1).
+         --  As is made clear in RM 3.5.4(11), type Integer, for example
+         --  is a constrained subtype with constraint bounds matching the
+         --  bounds of its corresponding uncontrained base type. In this
+         --  situation, Integer and Integer'Base do not statically match,
+         --  even though they have the same bounds.
+
+         --  We only apply this test to types in Standard and types that
+         --  appear in user programs. That way, we do not have to be
+         --  too careful about setting Is_Constrained right for itypes.
+
+         if Is_Numeric_Type (T1)
+           and then (Is_Constrained (T1) /= Is_Constrained (T2))
+           and then (Scope (T1) = Standard_Standard
+                      or else Comes_From_Source (T1))
+           and then (Scope (T2) = Standard_Standard
+                      or else Comes_From_Source (T2))
+         then
+            return False;
+         end if;
+
+         --  If there was an error in either range, then just assume
+         --  the types statically match to avoid further junk errors
+
+         if Error_Posted (Scalar_Range (T1))
+              or else
+            Error_Posted (Scalar_Range (T2))
+         then
+            return True;
+         end if;
+
+         --  Otherwise both types have bound that can be compared
+
+         declare
+            LB1 : constant Node_Id := Type_Low_Bound  (T1);
+            HB1 : constant Node_Id := Type_High_Bound (T1);
+            LB2 : constant Node_Id := Type_Low_Bound  (T2);
+            HB2 : constant Node_Id := Type_High_Bound (T2);
+
+         begin
+            --  If the bounds are the same tree node, then match
+
+            if LB1 = LB2 and then HB1 = HB2 then
+               return True;
+
+            --  Otherwise bounds must be static and identical value
+
+            else
+               if not Is_Static_Subtype (T1)
+                 or else not Is_Static_Subtype (T2)
+               then
+                  return False;
+
+               --  If either type has constraint error bounds, then say
+               --  that they match to avoid junk cascaded errors here.
+
+               elsif not Is_OK_Static_Subtype (T1)
+                 or else not Is_OK_Static_Subtype (T2)
+               then
+                  return True;
+
+               elsif Is_Real_Type (T1) then
+                  return
+                    (Expr_Value_R (LB1) = Expr_Value_R (LB2))
+                      and then
+                    (Expr_Value_R (HB1) = Expr_Value_R (HB2));
+
+               else
+                  return
+                    Expr_Value (LB1) = Expr_Value (LB2)
+                      and then
+                    Expr_Value (HB1) = Expr_Value (HB2);
+               end if;
+            end if;
+         end;
+
+      --  Type with discriminants
+
+      elsif Has_Discriminants (T1) or else Has_Discriminants (T2) then
+         if Has_Discriminants (T1) /= Has_Discriminants (T2) then
+            return False;
+         end if;
+
+         declare
+            DL1 : constant Elist_Id := Discriminant_Constraint (T1);
+            DL2 : constant Elist_Id := Discriminant_Constraint (T2);
+
+            DA1 : Elmt_Id := First_Elmt (DL1);
+            DA2 : Elmt_Id := First_Elmt (DL2);
+
+         begin
+            if DL1 = DL2 then
+               return True;
+
+            elsif Is_Constrained (T1) /= Is_Constrained (T2) then
+               return False;
+            end if;
+
+            while Present (DA1) loop
+               declare
+                  Expr1 : constant Node_Id := Node (DA1);
+                  Expr2 : constant Node_Id := Node (DA2);
+
+               begin
+                  if not Is_Static_Expression (Expr1)
+                    or else not Is_Static_Expression (Expr2)
+                  then
+                     return False;
+
+                  --  If either expression raised a constraint error,
+                  --  consider the expressions as matching, since this
+                  --  helps to prevent cascading errors.
+
+                  elsif Raises_Constraint_Error (Expr1)
+                    or else Raises_Constraint_Error (Expr2)
+                  then
+                     null;
+
+                  elsif Expr_Value (Expr1) /= Expr_Value (Expr2) then
+                     return False;
+                  end if;
+               end;
+
+               Next_Elmt (DA1);
+               Next_Elmt (DA2);
+            end loop;
+         end;
+
+         return True;
+
+      --  A definite type does not match an indefinite or classwide type.
+
+      elsif
+         Has_Unknown_Discriminants (T1) /= Has_Unknown_Discriminants (T2)
+      then
+         return False;
+
+      --  Array type
+
+      elsif Is_Array_Type (T1) then
+
+         --  If either subtype is unconstrained then both must be,
+         --  and if both are unconstrained then no further checking
+         --  is needed.
+
+         if not Is_Constrained (T1) or else not Is_Constrained (T2) then
+            return not (Is_Constrained (T1) or else Is_Constrained (T2));
+         end if;
+
+         --  Both subtypes are constrained, so check that the index
+         --  subtypes statically match.
+
+         declare
+            Index1 : Node_Id := First_Index (T1);
+            Index2 : Node_Id := First_Index (T2);
+
+         begin
+            while Present (Index1) loop
+               if not
+                 Subtypes_Statically_Match (Etype (Index1), Etype (Index2))
+               then
+                  return False;
+               end if;
+
+               Next_Index (Index1);
+               Next_Index (Index2);
+            end loop;
+
+            return True;
+         end;
+
+      elsif Is_Access_Type (T1) then
+         return Subtypes_Statically_Match
+                  (Designated_Type (T1),
+                   Designated_Type (T2));
+
+      --  All other types definitely match
+
+      else
+         return True;
+      end if;
+   end Subtypes_Statically_Match;
+
+   ----------
+   -- Test --
+   ----------
+
+   function Test (Cond : Boolean) return Uint is
+   begin
+      if Cond then
+         return Uint_1;
+      else
+         return Uint_0;
+      end if;
+   end Test;
+
+   ---------------------------------
+   -- Test_Expression_Is_Foldable --
+   ---------------------------------
+
+   --  One operand case
+
+   procedure Test_Expression_Is_Foldable
+     (N    : Node_Id;
+      Op1  : Node_Id;
+      Stat : out Boolean;
+      Fold : out Boolean)
+   is
+   begin
+      Stat := False;
+
+      --  If operand is Any_Type, just propagate to result and do not
+      --  try to fold, this prevents cascaded errors.
+
+      if Etype (Op1) = Any_Type then
+         Set_Etype (N, Any_Type);
+         Fold := False;
+         return;
+
+      --  If operand raises constraint error, then replace node N with the
+      --  raise constraint error node, and we are obviously not foldable.
+      --  Note that this replacement inherits the Is_Static_Expression flag
+      --  from the operand.
+
+      elsif Raises_Constraint_Error (Op1) then
+         Rewrite_In_Raise_CE (N, Op1);
+         Fold := False;
+         return;
+
+      --  If the operand is not static, then the result is not static, and
+      --  all we have to do is to check the operand since it is now known
+      --  to appear in a non-static context.
+
+      elsif not Is_Static_Expression (Op1) then
+         Check_Non_Static_Context (Op1);
+         Fold := Compile_Time_Known_Value (Op1);
+         return;
+
+      --   An expression of a formal modular type is not foldable because
+      --   the modulus is unknown.
+
+      elsif Is_Modular_Integer_Type (Etype (Op1))
+        and then Is_Generic_Type (Etype (Op1))
+      then
+         Check_Non_Static_Context (Op1);
+         Fold := False;
+         return;
+
+      --  Here we have the case of an operand whose type is OK, which is
+      --  static, and which does not raise constraint error, we can fold.
+
+      else
+         Set_Is_Static_Expression (N);
+         Fold := True;
+         Stat := True;
+      end if;
+   end Test_Expression_Is_Foldable;
+
+   --  Two operand case
+
+   procedure Test_Expression_Is_Foldable
+     (N    : Node_Id;
+      Op1  : Node_Id;
+      Op2  : Node_Id;
+      Stat : out Boolean;
+      Fold : out Boolean)
+   is
+      Rstat : constant Boolean := Is_Static_Expression (Op1)
+                                    and then Is_Static_Expression (Op2);
+
+   begin
+      Stat := False;
+
+      --  If either operand is Any_Type, just propagate to result and
+      --  do not try to fold, this prevents cascaded errors.
+
+      if Etype (Op1) = Any_Type or else Etype (Op2) = Any_Type then
+         Set_Etype (N, Any_Type);
+         Fold := False;
+         return;
+
+      --  If left operand raises constraint error, then replace node N with
+      --  the raise constraint error node, and we are obviously not foldable.
+      --  Is_Static_Expression is set from the two operands in the normal way,
+      --  and we check the right operand if it is in a non-static context.
+
+      elsif Raises_Constraint_Error (Op1) then
+         if not Rstat then
+            Check_Non_Static_Context (Op2);
+         end if;
+
+         Rewrite_In_Raise_CE (N, Op1);
+         Set_Is_Static_Expression (N, Rstat);
+         Fold := False;
+         return;
+
+      --  Similar processing for the case of the right operand. Note that
+      --  we don't use this routine for the short-circuit case, so we do
+      --  not have to worry about that special case here.
+
+      elsif Raises_Constraint_Error (Op2) then
+         if not Rstat then
+            Check_Non_Static_Context (Op1);
+         end if;
+
+         Rewrite_In_Raise_CE (N, Op2);
+         Set_Is_Static_Expression (N, Rstat);
+         Fold := False;
+         return;
+
+      --  Exclude expressions of a generic modular type, as above.
+
+      elsif Is_Modular_Integer_Type (Etype (Op1))
+        and then Is_Generic_Type (Etype (Op1))
+      then
+         Check_Non_Static_Context (Op1);
+         Fold := False;
+         return;
+
+      --  If result is not static, then check non-static contexts on operands
+      --  since one of them may be static and the other one may not be static
+
+      elsif not Rstat then
+         Check_Non_Static_Context (Op1);
+         Check_Non_Static_Context (Op2);
+         Fold := Compile_Time_Known_Value (Op1)
+                   and then Compile_Time_Known_Value (Op2);
+         return;
+
+      --  Else result is static and foldable. Both operands are static,
+      --  and neither raises constraint error, so we can definitely fold.
+
+      else
+         Set_Is_Static_Expression (N);
+         Fold := True;
+         Stat := True;
+         return;
+      end if;
+   end Test_Expression_Is_Foldable;
+
+   --------------
+   -- To_Bits --
+   --------------
+
+   procedure To_Bits (U : Uint; B : out Bits) is
+   begin
+      for J in 0 .. B'Last loop
+         B (J) := (U / (2 ** J)) mod 2 /= 0;
+      end loop;
+   end To_Bits;
+
+end Sem_Eval;
diff --git a/gcc/ada/sem_eval.ads b/gcc/ada/sem_eval.ads
new file mode 100644
index 00000000000..b693ffdb5c3
--- /dev/null
+++ b/gcc/ada/sem_eval.ads
@@ -0,0 +1,377 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             S E M _ E V A L                              --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.53 $
+--                                                                          --
+--          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 contains various subprograms involved in compile time
+--  evaluation of expressions and checks for staticness of expressions
+--  and types. It also contains the circuitry for checking for violations
+--  of pure and preelaborated conditions (this naturally goes here, since
+--  these rules involve consideration of staticness).
+
+--  Note: the static evaluation for attributes is found in Sem_Attr even
+--  though logically it belongs here. We have done this so that it is easier
+--  to add new attributes to GNAT.
+
+with Types;  use Types;
+with Uintp;  use Uintp;
+with Urealp; use Urealp;
+
+package Sem_Eval is
+
+   ------------------------------------
+   -- Handling of Static Expressions --
+   ------------------------------------
+
+   --  This package contains a set of routine that process individual
+   --  subexpression nodes with the objective of folding (precomputing)
+   --  the value of static expressions that are known at compile time and
+   --  properly computing the setting of two flags that appear in every
+   --  subexpression node:
+
+   --    Is_Static_Expression
+
+   --      This flag is set on any expression that is static according
+   --      to the rules in (RM 4.9(3-32)).
+
+   --    Raises_Constraint_Error
+
+   --      This flag indicatest that it is known at compile time that the
+   --      evaluation of an expression raises constraint error. If the
+   --      expression is static, and this flag is off, then it is also known
+   --      at compile time that the expression does not raise constraint error
+   --      (i.e. the flag is accurate for static expressions, and conservative
+   --      for non-static expressions.
+
+   --  If a static expression does not raise constraint error, then the
+   --  Raises_Constraint_Error flag is off, and the expression must be
+   --  computed at compile time, which means that it has the form of either
+   --  a literal, or a constant that is itself (recursively) either a literal
+   --  or a constant.
+
+   --  The above rules must be followed exactly in order for legality
+   --  checks to be accurate. For subexpressions that are not static
+   --  according to the RM definition, they are sometimes folded anyway,
+   --  but of course in this case Is_Static_Expression is not set.
+
+   -------------------------------
+   -- Compile-Time Known Values --
+   -------------------------------
+
+   --  For most legality checking purposes the flag Is_Static_Expression
+   --  defined in Sinfo should be used. This package also provides
+   --  a routine called Is_OK_Static_Expression which in addition of
+   --  checking that an expression is static in the RM 4.9 sense, it
+   --  checks that the expression does not raise constraint error. In
+   --  fact for certain legality checks not only do we need to ascertain
+   --  that the expression is static, but we must also ensure that it
+   --  does not raise constraint error.
+   --
+   --  Neither of Is_Static_Expression and Is_OK_Static_Expression should
+   --  be used for compile time evaluation purposes. In fact certain
+   --  expression whose value is known at compile time are not static
+   --  in the RM 4.9 sense. A typical example is:
+   --
+   --     C : constant Integer := Record_Type'Size;
+   --
+   --  The expression 'C' is not static in the technical RM sense, but for
+   --  many simple record types, the size is in fact known at compile time.
+   --  When we are trying to perform compile time constant folding (for
+   --  instance for expressions such as 'C + 1', Is_Static_Expression or
+   --  Is_OK_Static_Expression are not the right functions to test to see
+   --  if folding is possible. Instead, we use Compile_Time_Know_Value.
+   --  All static expressions that do not raise constraint error (i.e.
+   --  those for which Is_OK_Static_Expression is true) are known at
+   --  compile time, but as shown by the above example, there are cases
+   --  of non-static expressions which are known at compile time.
+
+   -----------------
+   -- Subprograms --
+   -----------------
+
+   procedure Check_Non_Static_Context (N : Node_Id);
+   --  Deals with the special check required for a static expression that
+   --  appears in a non-static context, i.e. is not part of a larger static
+   --  expression (see RM 4.9(35)), i.e. the value of the expression must be
+   --  within the base range of the base type of its expected type. A check
+   --  is also made for expressions that are inside the base range, but
+   --  outside the range of the expected subtype (this is a warning message
+   --  rather than an illegality).
+   --
+   --  Note: most cases of non-static context checks are handled within
+   --  Sem_Eval itself, including all cases of expressions at the outer
+   --  level (i.e. those that are not a subexpression). Currently the only
+   --  outside customer for this procedure is Sem_Attr (because Eval_Attribute
+   --  is there). There is also one special case arising from ranges (see body
+   --  of Resolve_Range).
+
+   procedure Check_String_Literal_Length (N : Node_Id; Ttype : Entity_Id);
+   --  N is either a string literal, or a constraint error node. In the latter
+   --  case, the situation is already dealt with, and the call has no effect.
+   --  In the former case, if the target type, Ttyp is constrained, then a
+   --  check is made to see if the string literal is of appropriate length.
+
+   type Compare_Result is (LT, LE, EQ, GT, GE, NE, Unknown);
+   subtype Compare_GE is Compare_Result range EQ .. GE;
+   subtype Compare_LE is Compare_Result range LT .. EQ;
+   function Compile_Time_Compare (L, R : Node_Id) return Compare_Result;
+   --  Given two expression nodes, finds out whether it can be determined
+   --  at compile time how the runtime values will compare. An Unknown
+   --  result means that the result of a comparison cannot be determined at
+   --  compile time, otherwise the returned result indicates the known result
+   --  of the comparison, given as tightly as possible (i.e. EQ or LT is a
+   --  preferred returned value to LE).
+
+   function Is_OK_Static_Expression (N : Node_Id) return Boolean;
+   --  An OK static expression is one that is static in the RM definition
+   --  sense and which does not raise constraint error. For most legality
+   --  checking purposes you should use Is_Static_Expression. For those
+   --  legality checks where the expression N should not raise constaint
+   --  error use this routine. This routine is *not* to be used in contexts
+   --  where the test is for compile time evaluation purposes. Use routine
+   --  Compile_Time_Known_Value instead (see section on "Compile-Time Known
+   --  Values" above).
+
+   function Is_Static_Range (N : Node_Id) return Boolean;
+   --  Determine if range is static, as defined in RM 4.9(26). The only
+   --  allowed argument is an N_Range node (but note that the semantic
+   --  analysis of equivalent range attribute references already turned
+   --  them into the equivalent range).
+
+   function Is_OK_Static_Range (N : Node_Id) return Boolean;
+   --  Like Is_Static_Range, but also makes sure that the bounds of the
+   --  range are compile-time evaluable (i.e. do not raise constraint error).
+   --  A result of true means that the bounds are compile time evaluable.
+   --  A result of false means they are not (either because the range is
+   --  not static, or because one or the other bound raises CE).
+
+   function Is_Static_Subtype (Typ : Entity_Id) return Boolean;
+   --  Determines whether a subtype fits the definition of an Ada static
+   --  subtype as given in (RM 4.9(26)).
+
+   function Is_OK_Static_Subtype (Typ : Entity_Id) return Boolean;
+   --  Like Is_Static_Subtype but also makes sure that the bounds of the
+   --  subtype are compile-time evaluable (i.e. do not raise constraint
+   --  error). A result of true means that the bounds are compile time
+   --  evaluable. A result of false means they are not (either because the
+   --  range is not static, or because one or the other bound raises CE).
+
+   function Subtypes_Statically_Compatible
+     (T1   : Entity_Id;
+      T2   : Entity_Id)
+      return Boolean;
+   --  Returns true if the subtypes are unconstrained or the constraint on
+   --  on T1 is statically compatible with T2 (as defined by 4.9.1(4)).
+   --  Otherwise returns false.
+
+   function Subtypes_Statically_Match (T1, T2 : Entity_Id) return Boolean;
+   --  Determine whether two types T1, T2, which have the same base type,
+   --  are statically matching subtypes (RM 4.9.1(1-2)).
+
+   function Compile_Time_Known_Value (Op : Node_Id) return Boolean;
+   --  Returns true if Op is an expression not raising constraint error
+   --  whose value is known at compile time. This is true if Op is a static
+   --  expression, but can also be true for expressions which are
+   --  technically non-static but which are in fact known at compile time,
+   --  such as the static lower bound of a non-static range or the value
+   --  of a constant object whose initial value is static. Note that this
+   --  routine is defended against unanalyzed expressions. Such expressions
+   --  will not cause a blowup, they may cause pessimistic (i.e. False)
+   --  results to be returned.
+
+   function Compile_Time_Known_Value_Or_Aggr (Op : Node_Id) return Boolean;
+   --  Similar to Compile_Time_Known_Value, but also returns True if the
+   --  value is a compile time known aggregate, i.e. an aggregate all of
+   --  whose constituent expressions are either compile time known values
+   --  or compile time known aggregates.
+
+   function Expr_Value (N : Node_Id) return Uint;
+   --  Returns the folded value of the expression N. This function is called
+   --  in instances where it has already been determined that the expression
+   --  is static or its value is known at compile time (ie the call to
+   --  Compile_Time_Known_Value (N) returns True). This version is used for
+   --  integer values, and enumeration or character literals. In the latter
+   --  two cases, the value returned is the Pos value in the relevant
+   --  enumeration type. It can also be used for fixed-point values, in
+   --  which case it returns the corresponding integer value. It cannot be
+   --  used for floating-point values.
+
+   function Expr_Value_E (N : Node_Id) return Entity_Id;
+   --  Returns the folded value of the expression. This function is called
+   --  in instances where it has already been determined that the expression
+   --  is static or its value known at compile time. This version is used
+   --  for enumeration types and returns the corresponding enumeration
+   --  literal.
+
+   function Expr_Value_R (N : Node_Id) return Ureal;
+   --  Returns the folded value of the expression. This function is called
+   --  in instances where it has already been determined that the expression
+   --  is static or its value known at compile time. This version is used
+   --  for real values (including both the floating-point and fixed-point
+   --  cases). In the case of a fixed-point type, the real value is returned
+   --  (cf above version returning Uint).
+
+   function Expr_Value_S (N : Node_Id) return Node_Id;
+   --  Returns the folded value of the expression. This function is called
+   --  in instances where it has already been determined that the expression
+   --  is static or its value is known at compile time. This version is used
+   --  for string types and returns the corresponding N_String_Literal node.
+
+   function Expr_Rep_Value (N : Node_Id) return Uint;
+   --  This is identical to Expr_Value, except in the case of enumeration
+   --  literals of types for which an enumeration representation clause has
+   --  been given, in which case it returns the representation value rather
+   --  than the pos value. This is the value that is needed for generating
+   --  code sequences, while the Expr_Value value is appropriate for compile
+   --  time constraint errors or getting the logical value. Note that this
+   --  function does NOT concern itself with biased values, if the caller
+   --  needs a properly biased value, the subtraction of the bias must be
+   --  handled explicitly.
+
+   procedure Eval_Actual                 (N : Node_Id);
+   procedure Eval_Allocator              (N : Node_Id);
+   procedure Eval_Arithmetic_Op          (N : Node_Id);
+   procedure Eval_Character_Literal      (N : Node_Id);
+   procedure Eval_Concatenation          (N : Node_Id);
+   procedure Eval_Conditional_Expression (N : Node_Id);
+   procedure Eval_Entity_Name            (N : Node_Id);
+   procedure Eval_Indexed_Component      (N : Node_Id);
+   procedure Eval_Integer_Literal        (N : Node_Id);
+   procedure Eval_Logical_Op             (N : Node_Id);
+   procedure Eval_Membership_Op          (N : Node_Id);
+   procedure Eval_Named_Integer          (N : Node_Id);
+   procedure Eval_Named_Real             (N : Node_Id);
+   procedure Eval_Op_Expon               (N : Node_Id);
+   procedure Eval_Op_Not                 (N : Node_Id);
+   procedure Eval_Real_Literal           (N : Node_Id);
+   procedure Eval_Relational_Op          (N : Node_Id);
+   procedure Eval_Shift                  (N : Node_Id);
+   procedure Eval_Short_Circuit          (N : Node_Id);
+   procedure Eval_Slice                  (N : Node_Id);
+   procedure Eval_String_Literal         (N : Node_Id);
+   procedure Eval_Qualified_Expression   (N : Node_Id);
+   procedure Eval_Type_Conversion        (N : Node_Id);
+   procedure Eval_Unary_Op               (N : Node_Id);
+   procedure Eval_Unchecked_Conversion   (N : Node_Id);
+
+   procedure Fold_Str (N : Node_Id; Val : String_Id);
+   --  Rewrite N with a new N_String_Literal node as the result of the
+   --  compile time evaluation of the node N. Val is the resulting string
+   --  value from the folding operation. The Is_Static_Expression flag is
+   --  set in the result node. The result is fully analyzed and resolved.
+
+   procedure Fold_Uint (N : Node_Id; Val : Uint);
+   --  Rewrite N with a (N_Integer_Literal, N_Identifier, N_Character_Literal)
+   --  node as the result of the compile time evaluation of the node N. Val
+   --  is the result in the integer case and is the position of the literal
+   --  in the literals list for the enumeration case. Is_Static_Expression
+   --  is set True in the result node. The result is fully analyzed/resolved.
+
+   procedure Fold_Ureal (N : Node_Id; Val : Ureal);
+   --  Rewrite N with a new N_Real_Literal node as the result of the compile
+   --  time evaluation of the node N. Val is the resulting real value from
+   --  the folding operation. The Is_Static_Expression flag is set in the
+   --  result node. The result is fully analyzed and result.
+
+   function Is_In_Range
+     (N         : Node_Id;
+      Typ       : Entity_Id;
+      Fixed_Int : Boolean := False;
+      Int_Real  : Boolean := False)
+      return      Boolean;
+   --  Returns True if it can be guaranteed at compile time that expression
+   --  N is known to be in range of the subtype Typ. If the values of N or
+   --  of either bouds of Type are unknown at compile time, False will
+   --  always be returned. A result of False does not mean that the
+   --  expression is out of range, merely that it cannot be determined at
+   --  compile time that it is in range. If Typ is a floating point type or
+   --  Int_Real is set, any integer value is treated as though it was a real
+   --  value (i.e. the underlying real value is used).  In this case we use
+   --  the corresponding real value, both for the bounds of Typ, and for the
+   --  value of the expression N. If Typ is a fixed type or a discrete type
+   --  and Int_Real is False but flag Fixed_Int is True then any fixed-point
+   --  value is treated as though it was a discrete value (i.e. the
+   --  underlying integer value is used).  In this case we use the
+   --  corresponding integer value, both for the bounds of Typ, and for the
+   --  value of the expression N. If Typ is a discret type and Fixed_Int as
+   --  well as Int_Real are false, intere values are used throughout.
+
+   function Is_Out_Of_Range
+     (N         : Node_Id;
+      Typ       : Entity_Id;
+      Fixed_Int : Boolean := False;
+      Int_Real  : Boolean := False)
+      return      Boolean;
+   --  Returns True if it can be guaranteed at compile time that expression
+   --  N is known to be out of range of the subtype Typ.  True is returned
+   --  if Typ is a scalar type, at least one of whose bounds is known at
+   --  compile time, and N is a compile time known expression which can be
+   --  determined to be outside a compile_time known bound of Typ. A result
+   --  of False does not mean that the expression is in range, merely that
+   --  it cannot be determined at compile time that it is out of range. Flags
+   --  Int_Real and Fixed_Int are used like in routine Is_In_Range above.
+
+   function In_Subrange_Of
+     (T1        : Entity_Id;
+      T2        : Entity_Id;
+      Fixed_Int : Boolean := False)
+      return      Boolean;
+   --  Returns True if it can be guaranteed at compile time that the range
+   --  of values for scalar type T1 are always in the range of scalar type
+   --  T2.  A result of False does not mean that T1 is not in T2's subrange,
+   --  only that it cannot be determined at compile time. Flag Fixed_Int is
+   --  used is like in routine Is_In_Range_Above.
+
+   function Is_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean;
+   --  Returns True if it can guarantee that Lo .. Hi is a null range.
+   --  If it cannot (because the value of Lo or Hi is not known at compile
+   --  time) then it returns False.
+
+   function Not_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean;
+   --  Returns True if it can guarantee that Lo .. Hi is not a null range.
+   --  If it cannot (because the value of Lo or Hi is not known at compile
+   --  time) then it returns False.
+
+private
+   --  The Eval routines are all marked inline, since they are called once
+
+   pragma Inline (Eval_Actual);
+   pragma Inline (Eval_Allocator);
+   pragma Inline (Eval_Character_Literal);
+   pragma Inline (Eval_Conditional_Expression);
+   pragma Inline (Eval_Indexed_Component);
+   pragma Inline (Eval_Integer_Literal);
+   pragma Inline (Eval_Named_Integer);
+   pragma Inline (Eval_Named_Real);
+   pragma Inline (Eval_Real_Literal);
+   pragma Inline (Eval_Shift);
+   pragma Inline (Eval_Slice);
+   pragma Inline (Eval_String_Literal);
+   pragma Inline (Eval_Unchecked_Conversion);
+
+   pragma Inline (Is_OK_Static_Expression);
+
+end Sem_Eval;
diff --git a/gcc/ada/sem_intr.adb b/gcc/ada/sem_intr.adb
new file mode 100644
index 00000000000..20b1918d60a
--- /dev/null
+++ b/gcc/ada/sem_intr.adb
@@ -0,0 +1,352 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             S E M _ I N T R                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.25 $
+--                                                                          --
+--          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). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  Processing for intrinsic subprogram declarations
+
+with Atree;    use Atree;
+with Einfo;    use Einfo;
+with Errout;   use Errout;
+with Fname;    use Fname;
+with Lib;      use Lib;
+with Namet;    use Namet;
+with Sem_Eval; use Sem_Eval;
+with Sem_Util; use Sem_Util;
+with Sinfo;    use Sinfo;
+with Snames;   use Snames;
+with Stand;    use Stand;
+with Stringt;  use Stringt;
+with Targparm; use Targparm;
+with Uintp;    use Uintp;
+
+package body Sem_Intr is
+
+   -----------------------
+   -- Local Subprograms --
+   -----------------------
+
+   procedure Check_Exception_Function (E : Entity_Id; N : Node_Id);
+   --  Check use of intrinsic Exception_Message, Exception_Info or
+   --  Exception_Name, as used in the DEC compatible Current_Exceptions
+   --  package. In each case we must have a parameterless function that
+   --  returns type String.
+
+   procedure Check_Intrinsic_Operator (E : Entity_Id; N : Node_Id);
+   --  Check that operator is one of the binary arithmetic operators, and
+   --  that the types involved have the same size.
+
+   procedure Check_Shift (E : Entity_Id; N : Node_Id);
+   --  Check intrinsic shift subprogram, the two arguments are the same
+   --  as for Check_Intrinsic_Subprogram (i.e. the entity of the subprogram
+   --  declaration, and the node for the pragma argument, used for messages)
+
+   procedure Errint (Msg : String; S : Node_Id; N : Node_Id);
+   --  Post error message for bad intrinsic, the message itself is posted
+   --  on the appropriate spec node and another message is placed on the
+   --  pragma itself, referring to the spec. S is the node in the spec on
+   --  which the message is to be placed, and N is the pragma argument node.
+
+   ------------------------------
+   -- Check_Exception_Function --
+   ------------------------------
+
+   procedure Check_Exception_Function (E : Entity_Id; N : Node_Id) is
+   begin
+      if Ekind (E) /= E_Function
+        and then Ekind (E) /= E_Generic_Function
+      then
+         Errint
+           ("intrinsic exception subprogram must be a function", E, N);
+
+      elsif Present (First_Formal (E)) then
+         Errint
+           ("intrinsic exception subprogram may not have parameters",
+            E, First_Formal (E));
+         return;
+
+      elsif Etype (E) /= Standard_String then
+         Errint
+           ("return type of exception subprogram must be String", E, N);
+         return;
+      end if;
+   end Check_Exception_Function;
+
+   --------------------------
+   -- Check_Intrinsic_Call --
+   --------------------------
+
+   procedure Check_Intrinsic_Call (N : Node_Id) is
+      Nam  : constant Entity_Id := Entity (Name (N));
+      Cnam : constant Name_Id   := Chars (Nam);
+      Arg1 : constant Node_Id   := First_Actual (N);
+
+   begin
+      --  For Import_xxx calls, argument must be static string
+
+      if Cnam = Name_Import_Address
+           or else
+         Cnam = Name_Import_Largest_Value
+           or else
+         Cnam = Name_Import_Value
+      then
+         if Etype (Arg1) = Any_Type
+           or else Raises_Constraint_Error (Arg1)
+         then
+            null;
+
+         elsif not Is_Static_Expression (Arg1) then
+            Error_Msg_NE
+              ("call to & requires static string argument", N, Nam);
+
+         elsif String_Length (Strval (Expr_Value_S (Arg1))) = 0 then
+            Error_Msg_NE
+              ("call to & does not permit null string", N, Nam);
+
+         elsif OpenVMS_On_Target
+           and then String_Length (Strval (Expr_Value_S (Arg1))) > 31
+         then
+            Error_Msg_NE
+              ("argument in call to & must be 31 characters or less", N, Nam);
+         end if;
+
+      --  For now, no other special checks are required
+
+      else
+         return;
+      end if;
+   end Check_Intrinsic_Call;
+
+   ------------------------------
+   -- Check_Intrinsic_Operator --
+   ------------------------------
+
+   procedure Check_Intrinsic_Operator (E : Entity_Id; N : Node_Id) is
+      Nam : Name_Id := Chars (E);
+      T1  : Entity_Id;
+      T2  : Entity_Id;
+      Ret : constant Entity_Id := Etype (E);
+
+   begin
+      if Nam = Name_Op_Add
+        or else Nam = Name_Op_Subtract
+        or else Nam = Name_Op_Multiply
+        or else Nam = Name_Op_Divide
+      then
+         T1 := Etype (First_Formal (E));
+
+         if No (Next_Formal (First_Formal (E))) then
+
+            --  previous error in declaration.
+            return;
+
+         else
+            T2 := Etype (Next_Formal (First_Formal (E)));
+         end if;
+
+         if Root_Type (T1) /= Root_Type (T2)
+           or else Root_Type (T1) /= Root_Type (Ret)
+         then
+            Errint (
+              "types of intrinsic operator must have the same size", E, N);
+
+         elsif not Is_Numeric_Type (T1) then
+            Errint (
+              " intrinsic operator can only apply to numeric types", E, N);
+         end if;
+
+      else
+         Errint ("incorrect context for ""Intrinsic"" convention", E, N);
+      end if;
+   end Check_Intrinsic_Operator;
+
+   --------------------------------
+   -- Check_Intrinsic_Subprogram --
+   --------------------------------
+
+   procedure Check_Intrinsic_Subprogram (E : Entity_Id; N : Node_Id) is
+      Spec : constant Node_Id := Specification (Unit_Declaration_Node (E));
+      Nam  : Name_Id;
+
+   begin
+      if Present (Spec)
+        and then Present (Generic_Parent (Spec))
+      then
+         Nam := Chars (Generic_Parent (Spec));
+      else
+         Nam := Chars (E);
+      end if;
+
+      --  Check name is valid intrinsic name
+
+      Get_Name_String (Nam);
+
+      if Name_Buffer (1) /= 'O'
+        and then Nam /= Name_Asm
+        and then Nam not in First_Intrinsic_Name .. Last_Intrinsic_Name
+      then
+         Errint ("unrecognized intrinsic subprogram", E, N);
+
+      --  We always allow intrinsic specifications in language defined units
+      --  and in expanded code. We assume that the GNAT implemetors know what
+      --  they are doing, and do not write or generate junk use of intrinsic!
+
+      elsif not Comes_From_Source (E)
+        or else not Comes_From_Source (N)
+        or else Is_Predefined_File_Name
+                  (Unit_File_Name (Get_Source_Unit (N)))
+      then
+         null;
+
+      --  Shift cases. We allow user specification of intrinsic shift
+      --  operators for any numeric types.
+
+      elsif
+        Nam = Name_Rotate_Left
+          or else
+        Nam = Name_Rotate_Right
+          or else
+        Nam = Name_Shift_Left
+          or else
+        Nam = Name_Shift_Right
+          or else
+        Nam = Name_Shift_Right_Arithmetic
+      then
+         Check_Shift (E, N);
+
+      elsif
+        Nam = Name_Exception_Information
+          or else
+        Nam = Name_Exception_Message
+          or else
+        Nam = Name_Exception_Name
+      then
+         Check_Exception_Function (E, N);
+
+      elsif Nkind (E) = N_Defining_Operator_Symbol then
+         Check_Intrinsic_Operator (E, N);
+
+      elsif Nam = Name_File
+        or else Nam = Name_Line
+        or else Nam = Name_Source_Location
+        or else Nam = Name_Enclosing_Entity
+      then
+         null;
+
+      --  For now, no other intrinsic subprograms are recognized in user code
+
+      else
+         Errint ("incorrect context for ""Intrinsic"" convention", E, N);
+      end if;
+   end Check_Intrinsic_Subprogram;
+
+   -----------------
+   -- Check_Shift --
+   -----------------
+
+   procedure Check_Shift (E : Entity_Id; N : Node_Id) is
+      Arg1  : Node_Id;
+      Arg2  : Node_Id;
+      Size  : Nat;
+      Typ1  : Entity_Id;
+      Typ2  : Entity_Id;
+      Ptyp1 : Node_Id;
+      Ptyp2 : Node_Id;
+
+   begin
+      if Ekind (E) /= E_Function
+        and then Ekind (E) /= E_Generic_Function
+      then
+         Errint ("intrinsic shift subprogram must be a function", E, N);
+         return;
+      end if;
+
+      Arg1 := First_Formal (E);
+
+      if Present (Arg1) then
+         Arg2 := Next_Formal (Arg1);
+      else
+         Arg2 := Empty;
+      end if;
+
+      if Arg1 = Empty or else Arg2 = Empty then
+         Errint ("intrinsic shift function must have two arguments", E, N);
+         return;
+      end if;
+
+      Typ1 := Etype (Arg1);
+      Typ2 := Etype (Arg2);
+
+      Ptyp1 := Parameter_Type (Parent (Arg1));
+      Ptyp2 := Parameter_Type (Parent (Arg2));
+
+      if not Is_Integer_Type (Typ1) then
+         Errint ("first argument to shift must be integer type", Ptyp1, N);
+         return;
+      end if;
+
+      if Typ2 /= Standard_Natural then
+         Errint ("second argument to shift must be type Natural", Ptyp2, N);
+         return;
+      end if;
+
+      Size := UI_To_Int (Esize (Typ1));
+
+      if Size /= 8
+        and then Size /= 16
+        and then Size /= 32
+        and then Size /= 64
+      then
+         Errint
+           ("first argument for shift must have size 8, 16, 32 or 64",
+             Ptyp1, N);
+         return;
+
+      elsif Is_Modular_Integer_Type (Typ1)
+        and then Non_Binary_Modulus (Typ1)
+      then
+         Errint
+           ("shifts not allowed for non-binary modular types",
+            Ptyp1, N);
+
+      elsif Etype (Arg1) /= Etype (E) then
+         Errint
+           ("first argument of shift must match return type", Ptyp1, N);
+         return;
+      end if;
+   end Check_Shift;
+
+   ------------
+   -- Errint --
+   ------------
+
+   procedure Errint (Msg : String; S : Node_Id; N : Node_Id) is
+   begin
+      Error_Msg_N (Msg, S);
+      Error_Msg_N ("incorrect intrinsic subprogram, see spec", N);
+   end Errint;
+
+end Sem_Intr;
diff --git a/gcc/ada/sem_intr.ads b/gcc/ada/sem_intr.ads
new file mode 100644
index 00000000000..3576ffb2c66
--- /dev/null
+++ b/gcc/ada/sem_intr.ads
@@ -0,0 +1,49 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             S E M _ I N T R                              --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.4 $                              --
+--                                                                          --
+--        Copyright (C) 1992,1993,1994 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). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  Processing for intrinsic subprogram declarations
+
+with Types; use Types;
+
+package Sem_Intr is
+
+   procedure Check_Intrinsic_Call (N : Node_Id);
+   --  Perform legality check for intrinsic call N (which is either function
+   --  call or a procedure call node). All the normal semantic checks have
+   --  been performed already. Check_Intrinsic_Call applies any additional
+   --  checks required by the fact that an intrinsic subprogram is involved.
+
+   procedure Check_Intrinsic_Subprogram (E : Entity_Id; N : Node_Id);
+   --  Special processing for pragma Import or pragma Interface when the
+   --  convention is Intrinsic. E is the Entity_Id of the spec of the
+   --  subprogram, and N is the second (subprogram) argument of the pragma.
+   --  Check_Intrinsic_Subprogram checks that the referenced subprogram is
+   --  known as an intrinsic and has an appropriate profile. If so the flag
+   --  Is_Intrinsic_Subprogram is set, otherwise an error message is posted.
+
+end Sem_Intr;
diff --git a/gcc/ada/sem_maps.adb b/gcc/ada/sem_maps.adb
new file mode 100644
index 00000000000..a876156c6ac
--- /dev/null
+++ b/gcc/ada/sem_maps.adb
@@ -0,0 +1,376 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             S E M _ M A P S                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                             $Revision: 1.3 $                             --
+--                                                                          --
+--          Copyright (C) 1996-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). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+with Atree;  use Atree;
+with Einfo;  use Einfo;
+with Namet;  use Namet;
+with Output; use Output;
+with Sinfo;  use Sinfo;
+with Uintp;  use Uintp;
+
+package body Sem_Maps is
+
+   -----------------------
+   -- Local Subprograms --
+   -----------------------
+
+   function Find_Assoc (M : Map; E : Entity_Id) return Assoc_Index;
+   --  Standard hash table search. M is the map to be searched, E is the
+   --  entity to be searched for, and Assoc_Index is the resulting
+   --  association, or is set to No_Assoc if there is no association.
+
+   function Find_Header_Size (N : Int) return Header_Index;
+   --  Find largest power of two smaller than the number of entries in
+   --  the table. This load factor of 2 may be adjusted later if needed.
+
+   procedure Write_Map (E : Entity_Id);
+   pragma Warnings (Off, Write_Map);
+   --  For debugging purposes.
+
+   ---------------------
+   -- Add_Association --
+   ---------------------
+
+   procedure Add_Association
+     (M    : in out Map;
+      O_Id : Entity_Id;
+      N_Id : Entity_Id;
+      Kind : Scope_Kind := S_Local)
+   is
+      Info : constant Map_Info      := Maps_Table.Table (M);
+      Offh : constant Header_Index  := Info.Header_Offset;
+      Offs : constant Header_Index  := Info.Header_Num;
+      J    : constant Header_Index  := Header_Index (O_Id) mod Offs;
+      K    : constant Assoc_Index   := Info.Assoc_Next;
+
+   begin
+      Associations_Table.Table (K) := (O_Id, N_Id, Kind, No_Assoc);
+      Maps_Table.Table (M).Assoc_Next := K + 1;
+
+      if Headers_Table.Table (Offh + J) /= No_Assoc then
+
+         --  Place new association at head of chain.
+
+         Associations_Table.Table (K).Next := Headers_Table.Table (Offh + J);
+      end if;
+
+      Headers_Table.Table (Offh + J) := K;
+   end Add_Association;
+
+   ------------------------
+   -- Build_Instance_Map --
+   ------------------------
+
+   function Build_Instance_Map (M : Map) return Map is
+      Info    : constant Map_Info     := Maps_Table.Table (M);
+      Res     : constant Map          := New_Map (Int (Info.Assoc_Num));
+      Offh1   : constant Header_Index := Info.Header_Offset;
+      Offa1   : constant Assoc_Index  := Info.Assoc_Offset;
+      Offh2   : constant Header_Index := Maps_Table.Table (Res).Header_Offset;
+      Offa2   : constant Assoc_Index  := Maps_Table.Table (Res).Assoc_Offset;
+      A       : Assoc;
+      A_Index : Assoc_Index;
+
+   begin
+      for J in 0 .. Info.Header_Num - 1 loop
+         A_Index := Headers_Table.Table (Offh1 + J);
+
+         if A_Index /= No_Assoc then
+            Headers_Table.Table (Offh2 + J) := A_Index + (Offa2 - Offa1);
+         end if;
+      end loop;
+
+      for J in 0 .. Info.Assoc_Num - 1 loop
+         A  := Associations_Table.Table (Offa1 + J);
+
+         --  For local entities that come from source, create the
+         --  corresponding local entities in the instance. Entities that
+         --  do not come from source are etypes, and new ones will be
+         --  generated when analyzing the instance.
+
+         if No (A.New_Id)
+           and then A.Kind = S_Local
+           and then Comes_From_Source (A.Old_Id)
+         then
+            A.New_Id := New_Copy (A.Old_Id);
+            A.New_Id := New_Entity (Nkind (A.Old_Id), Sloc (A.Old_Id));
+            Set_Chars (A.New_Id, Chars (A.Old_Id));
+         end if;
+
+         if A.Next /= No_Assoc then
+            A.Next := A.Next + (Offa2 - Offa1);
+         end if;
+
+         Associations_Table.Table (Offa2 + J) := A;
+      end loop;
+
+      Maps_Table.Table (Res).Assoc_Next := Associations_Table.Last;
+      return Res;
+   end Build_Instance_Map;
+
+   -------------
+   -- Compose --
+   -------------
+
+   function Compose (Orig_Map : Map; New_Map : Map) return Map is
+      Res : constant Map         := Copy (Orig_Map);
+      Off : constant Assoc_Index := Maps_Table.Table (Res).Assoc_Offset;
+      A   : Assoc;
+      K   : Assoc_Index;
+
+   begin
+      --  Iterate over the contents of Orig_Map, looking for entities
+      --  that are further mapped under New_Map.
+
+      for J in 0 .. Maps_Table.Table (Res).Assoc_Num - 1  loop
+         A := Associations_Table.Table (Off + J);
+         K := Find_Assoc (New_Map, A.New_Id);
+
+         if K /= No_Assoc then
+            Associations_Table.Table (Off + J).New_Id
+              := Associations_Table.Table (K).New_Id;
+         end if;
+      end loop;
+
+      return Res;
+   end Compose;
+
+   ----------
+   -- Copy --
+   ----------
+
+   function Copy (M : Map) return Map is
+      Info    : constant Map_Info     := Maps_Table.Table (M);
+      Res     : constant Map          := New_Map (Int (Info.Assoc_Num));
+      Offh1   : constant Header_Index := Info.Header_Offset;
+      Offa1   : constant Assoc_Index  := Info.Assoc_Offset;
+      Offh2   : constant Header_Index := Maps_Table.Table (Res).Header_Offset;
+      Offa2   : constant Assoc_Index  := Maps_Table.Table (Res).Assoc_Offset;
+      A       : Assoc;
+      A_Index : Assoc_Index;
+
+   begin
+      for J in 0 .. Info.Header_Num - 1 loop
+         A_Index := Headers_Table.Table (Offh1 + J) + (Offa2 - Offa1);
+
+         if A_Index /= No_Assoc then
+            Headers_Table.Table (Offh2 + J) := A_Index + (Offa2 - Offa1);
+         end if;
+      end loop;
+
+      for J in 0 .. Info.Assoc_Num - 1 loop
+         A := Associations_Table.Table (Offa1 + J);
+         A.Next := A.Next + (Offa2 - Offa1);
+         Associations_Table.Table (Offa2 + J) := A;
+      end loop;
+
+      Maps_Table.Table (Res).Assoc_Next := Associations_Table.Last;
+      return Res;
+   end Copy;
+
+   ----------------
+   -- Find_Assoc --
+   ----------------
+
+   function Find_Assoc (M : Map; E : Entity_Id) return Assoc_Index is
+      Offh    : constant Header_Index := Maps_Table.Table (M).Header_Offset;
+      Offs    : constant Header_Index := Maps_Table.Table (M).Header_Num;
+      J       : constant Header_Index := Header_Index (E) mod Offs;
+      A       : Assoc;
+      A_Index : Assoc_Index;
+
+   begin
+      A_Index := Headers_Table.Table (Offh + J);
+
+      if A_Index = No_Assoc then
+         return A_Index;
+
+      else
+         A := Associations_Table.Table (A_Index);
+
+         while Present (A.Old_Id) loop
+
+            if A.Old_Id = E then
+               return A_Index;
+
+            elsif A.Next = No_Assoc then
+               return No_Assoc;
+
+            else
+               A_Index := A.Next;
+               A := Associations_Table.Table (A.Next);
+            end if;
+         end loop;
+
+         return No_Assoc;
+      end if;
+   end Find_Assoc;
+
+   ----------------------
+   -- Find_Header_Size --
+   ----------------------
+
+   function Find_Header_Size (N : Int) return Header_Index is
+      Siz : Header_Index;
+
+   begin
+      Siz := 2;
+      while 2 * Siz < Header_Index (N) loop
+         Siz := 2 * Siz;
+      end loop;
+
+      return Siz;
+   end Find_Header_Size;
+
+   ------------
+   -- Lookup --
+   ------------
+
+   function Lookup (M : Map; E : Entity_Id) return Entity_Id is
+      Offh : constant Header_Index := Maps_Table.Table (M).Header_Offset;
+      Offs : constant Header_Index := Maps_Table.Table (M).Header_Num;
+      J    : constant Header_Index := Header_Index (E) mod Offs;
+      A    : Assoc;
+
+   begin
+      if Headers_Table.Table (Offh + J) = No_Assoc then
+         return Empty;
+
+      else
+         A := Associations_Table.Table (Headers_Table.Table (Offh + J));
+
+         while Present (A.Old_Id) loop
+
+            if A.Old_Id = E then
+               return A.New_Id;
+
+            elsif A.Next = No_Assoc then
+               return Empty;
+
+            else
+               A := Associations_Table.Table (A.Next);
+            end if;
+         end loop;
+
+         return Empty;
+      end if;
+   end Lookup;
+
+   -------------
+   -- New_Map --
+   -------------
+
+   function New_Map (Num_Assoc : Int) return Map is
+      Header_Size : Header_Index := Find_Header_Size (Num_Assoc);
+      Res         : Map_Info;
+
+   begin
+      --  Allocate the tables for the new map at the current end of the
+      --  global tables.
+
+      Associations_Table.Increment_Last;
+      Headers_Table.Increment_Last;
+      Maps_Table.Increment_Last;
+
+      Res.Header_Offset := Headers_Table.Last;
+      Res.Header_Num    := Header_Size;
+      Res.Assoc_Offset  := Associations_Table.Last;
+      Res.Assoc_Next    := Associations_Table.Last;
+      Res.Assoc_Num     := Assoc_Index (Num_Assoc);
+
+      Headers_Table.Set_Last (Headers_Table.Last + Header_Size);
+      Associations_Table.Set_Last
+        (Associations_Table.Last + Assoc_Index (Num_Assoc));
+      Maps_Table.Table (Maps_Table.Last) := Res;
+
+      for J in 1 .. Header_Size loop
+         Headers_Table.Table (Headers_Table.Last - J) := No_Assoc;
+      end loop;
+
+      return Maps_Table.Last;
+   end New_Map;
+
+   ------------------------
+   -- Update_Association --
+   ------------------------
+
+   procedure Update_Association
+     (M    : in out Map;
+      O_Id : Entity_Id;
+      N_Id : Entity_Id;
+      Kind : Scope_Kind := S_Local)
+   is
+      J : constant Assoc_Index := Find_Assoc (M, O_Id);
+
+   begin
+      Associations_Table.Table (J).New_Id := N_Id;
+      Associations_Table.Table (J).Kind := Kind;
+   end Update_Association;
+
+   ---------------
+   -- Write_Map --
+   ---------------
+
+   procedure Write_Map (E : Entity_Id) is
+      M    : constant Map          := Map (UI_To_Int (Renaming_Map (E)));
+      Info : constant Map_Info     := Maps_Table.Table (M);
+      Offh : constant Header_Index := Info.Header_Offset;
+      Offa : constant Assoc_Index  := Info.Assoc_Offset;
+      A    : Assoc;
+
+   begin
+      Write_Str ("Size : ");
+      Write_Int (Int (Info.Assoc_Num));
+      Write_Eol;
+
+      Write_Str ("Headers");
+      Write_Eol;
+
+      for J in 0 .. Info.Header_Num - 1 loop
+         Write_Int (Int (Offh + J));
+         Write_Str (" : ");
+         Write_Int (Int (Headers_Table.Table (Offh + J)));
+         Write_Eol;
+      end loop;
+
+      for J in 0 .. Info.Assoc_Num - 1 loop
+         A := Associations_Table.Table (Offa + J);
+         Write_Int (Int (Offa + J));
+         Write_Str (" : ");
+         Write_Name (Chars (A.Old_Id));
+         Write_Str ("  ");
+         Write_Int (Int (A.Old_Id));
+         Write_Str (" ==> ");
+         Write_Int (Int (A.New_Id));
+         Write_Str (" next = ");
+         Write_Int (Int (A.Next));
+         Write_Eol;
+      end loop;
+   end Write_Map;
+
+end Sem_Maps;
diff --git a/gcc/ada/sem_maps.ads b/gcc/ada/sem_maps.ads
new file mode 100644
index 00000000000..3033f890ff7
--- /dev/null
+++ b/gcc/ada/sem_maps.ads
@@ -0,0 +1,170 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             S E M _ M A P S                              --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                              $Revision: 1.4 $
+--                                                                          --
+--          Copyright (C) 1996-1999 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 contains the operations on the renaming maps used for
+--  generic analysis and instantiation. Renaming maps are created when
+--  a generic unit is analyzed, in order to capture all references to
+--  global variables within the unit. The renaming map of a generic unit
+--  copied prior to each instantiation, and then updated by mapping the
+--  formals into the actuals and the local entities into entities local to
+--  the instance. When the generic tree is copied to produce the instance,
+--  all references are updated by means of the renaming map.
+
+--  Map composition of renaming maps takes place for nested instantiations,
+--  for generic child units, and for formal packages.
+
+--  For additional details, see the documentation in sem_ch12.
+
+with Table;
+with Types; use Types;
+
+package Sem_Maps is
+
+   type Map is new Int;
+
+   type Assoc is private;
+
+   type Scope_Kind is (S_Global, S_Formal, S_Local);
+
+   function New_Map (Num_Assoc : Int) return Map;
+   --  Build empty map with the given number of associations, and a
+   --  headers table of the appropriate size.
+
+   function Compose (Orig_Map : Map; New_Map : Map) return Map;
+   --  Update the associations in Orig_Map, so that if Orig_Map (e1) = e2
+   --  and New_Map (e2) = e3, then the image of e1 under the result is e3.
+
+   function Copy (M : Map) return Map;
+   --  Full copy of contents and headers.
+
+   function Lookup (M : Map; E : Entity_Id) return Entity_Id;
+   --  Retrieve image of E under M, Empty if undefined.
+
+   procedure Add_Association
+     (M    : in out Map;
+      O_Id : Entity_Id;
+      N_Id : Entity_Id;
+      Kind : Scope_Kind := S_Local);
+   --  Update M in place. On entry M (O_Id) must not be defined.
+
+   procedure Update_Association
+     (M    : in out Map;
+      O_Id : Entity_Id;
+      N_Id : Entity_Id;
+      Kind : Scope_Kind := S_Local);
+   --  Update the entry in M for O_Id.
+
+   function Build_Instance_Map (M : Map) return Map;
+   --  Copy renaming map of generic, and create new entities for all the
+   --  local entities within.
+
+private
+
+   --  New maps are created when a generic is analyzed, and for each of
+   --  its instantiations. Maps are also updated for nested generics, for
+   --  child units, and for formal packages. As a result we need to allocate
+   --  maps dynamically.
+
+   --  When analyzing a generic, we do not know how many references are
+   --  in it. We build an initial map after generic analysis, using a static
+   --  structure that relies on the compiler's extensible table mechanism.
+   --  After constructing this initial map, all subsequent uses and updates
+   --  of this map do not modify its domain, so that dynamically allocated
+   --  maps have a fixed size and never need to be reallocated. Furthermore,
+   --  the headers of the hash table of a dynamically allocated map can be
+   --  chosen according to the total number of entries in the map, to
+   --  accomodate efficiently generic units of different sizes (Unchecked_
+   --  Conversion vs. Generic_Elementary_Functions, for example). So in
+   --  fact both components of a map have fixed size, and can be allocated
+   --  using the standard table mechanism. A Maps_Table holds records that
+   --  contain indices into the global Headers table and the Associations
+   --  table, and a Map is an index into the Maps_Table.
+   --
+   --              Maps_Table          Headers_Table     Associations_Table
+   --
+   --                                    |_____|          |___________ |
+   --               |_____|              |     |          |            |
+   --        ------>|Map  |------------------------------>|Associations|
+   --               |Info |------------->|     |=========>| for one    |
+   --               |_____|              |     |====|     |   unit     |
+   --               |     |              |     |    |====>|            |
+   --                                    |_____|          |____________|
+   --                                    |     |          |            |
+   type Header_Index is new Int;
+   type Assoc_Index  is new Int;
+   No_Assoc : constant Assoc_Index := -1;
+
+   type Map_Info is record
+      Header_Offset : Header_Index;
+      Header_Num    : Header_Index;
+      Assoc_Offset  : Assoc_Index;
+      Assoc_Num     : Assoc_Index;
+      Assoc_Next    : Assoc_Index;
+   end record;
+
+   type Assoc is record
+      Old_Id : Entity_Id   := Empty;
+      New_Id : Entity_Id   := Empty;
+      Kind   : Scope_Kind  := S_Local;
+      Next   : Assoc_Index := No_Assoc;
+   end record;
+
+   --  All maps are accessed through the following table. The map attribute
+   --  of a generic unit or an instance is an index into this table.
+
+   package Maps_Table is new Table.Table (
+      Table_Component_Type => Map_Info,
+      Table_Index_Type     => Map,
+      Table_Low_Bound      => 0,
+      Table_Initial        => 100,
+      Table_Increment      => 10,
+      Table_Name           => "Maps_Table");
+
+   --  All headers for hash tables are allocated in one global table. Each
+   --  map stores the offset into this table at which its own headers start.
+
+   package Headers_Table is new Table.Table (
+      Table_Component_Type => Assoc_Index,
+      Table_Index_Type     => Header_Index,
+      Table_Low_Bound      => 0,
+      Table_Initial        => 1000,
+      Table_Increment      => 10,
+      Table_Name           => "Headers_Table");
+
+   --  All associations are allocated in one global table. Each map stores
+   --  the offset into this table at which its own associations start.
+
+   package Associations_Table is new Table.Table (
+      Table_Component_Type => Assoc,
+      Table_Index_Type     => Assoc_Index,
+      Table_Low_Bound      => 1,
+      Table_Initial        => 1000,
+      Table_Increment      => 10,
+      Table_Name           => "Associations_Table");
+
+end Sem_Maps;
diff --git a/gcc/ada/sem_mech.adb b/gcc/ada/sem_mech.adb
new file mode 100644
index 00000000000..800a5e82dc4
--- /dev/null
+++ b/gcc/ada/sem_mech.adb
@@ -0,0 +1,437 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             S E M _ M E C H                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.16 $
+--                                                                          --
+--          Copyright (C) 1996-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 Einfo;    use Einfo;
+with Errout;   use Errout;
+with Targparm; use Targparm;
+with Nlists;   use Nlists;
+with Sem;      use Sem;
+with Sem_Util; use Sem_Util;
+with Sinfo;    use Sinfo;
+with Snames;   use Snames;
+with Stand;    use Stand;
+
+package body Sem_Mech is
+
+   -------------------------
+   -- Set_Mechanism_Value --
+   -------------------------
+
+   procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is
+      Class : Node_Id;
+      Param : Node_Id;
+
+      procedure Bad_Class;
+      --  Signal bad descriptor class name
+
+      procedure Bad_Mechanism;
+      --  Signal bad mechanism name
+
+      procedure Bad_Class is
+      begin
+         Error_Msg_N ("unrecognized descriptor class name", Class);
+      end Bad_Class;
+
+      procedure Bad_Mechanism is
+      begin
+         Error_Msg_N ("unrecognized mechanism name", Mech_Name);
+      end Bad_Mechanism;
+
+   --  Start of processing for Set_Mechanism_Value
+
+   begin
+      if Mechanism (Ent) /= Default_Mechanism then
+         Error_Msg_NE
+           ("mechanism for & has already been set", Mech_Name, Ent);
+      end if;
+
+      --  MECHANISM_NAME ::= value | reference | descriptor
+
+      if Nkind (Mech_Name) = N_Identifier then
+         if Chars (Mech_Name) = Name_Value then
+            Set_Mechanism_With_Checks (Ent, By_Copy, Mech_Name);
+            return;
+
+         elsif Chars (Mech_Name) = Name_Reference then
+            Set_Mechanism_With_Checks (Ent, By_Reference, Mech_Name);
+            return;
+
+         elsif Chars (Mech_Name) = Name_Descriptor then
+            Check_VMS (Mech_Name);
+            Set_Mechanism_With_Checks (Ent, By_Descriptor, Mech_Name);
+            return;
+
+         elsif Chars (Mech_Name) = Name_Copy then
+            Error_Msg_N
+              ("bad mechanism name, Value assumed", Mech_Name);
+            Set_Mechanism (Ent, By_Copy);
+
+         else
+            Bad_Mechanism;
+            return;
+         end if;
+
+      --  MECHANISM_NAME ::= descriptor (CLASS_NAME)
+      --  CLASS_NAME     ::= ubs | ubsb | uba | s | sb | a | nca
+
+      --  Note: this form is parsed as an indexed component
+
+      elsif Nkind (Mech_Name) = N_Indexed_Component then
+         Class := First (Expressions (Mech_Name));
+
+         if Nkind (Prefix (Mech_Name)) /= N_Identifier
+           or else Chars (Prefix (Mech_Name)) /= Name_Descriptor
+           or else Present (Next (Class))
+         then
+            Bad_Mechanism;
+            return;
+         end if;
+
+      --  MECHANISM_NAME ::= descriptor (Class => CLASS_NAME)
+      --  CLASS_NAME     ::= ubs | ubsb | uba | s | sb | a | nca
+
+      --  Note: this form is parsed as a function call
+
+      elsif Nkind (Mech_Name) = N_Function_Call then
+
+         Param := First (Parameter_Associations (Mech_Name));
+
+         if Nkind (Name (Mech_Name)) /= N_Identifier
+           or else Chars (Name (Mech_Name)) /= Name_Descriptor
+           or else Present (Next (Param))
+           or else No (Selector_Name (Param))
+           or else Chars (Selector_Name (Param)) /= Name_Class
+         then
+            Bad_Mechanism;
+            return;
+         else
+            Class := Explicit_Actual_Parameter (Param);
+         end if;
+
+      else
+         Bad_Mechanism;
+         return;
+      end if;
+
+      --  Fall through here with Class set to descriptor class name
+
+      Check_VMS (Mech_Name);
+
+      if Nkind (Class) /= N_Identifier then
+         Bad_Class;
+         return;
+
+      elsif Chars (Class) = Name_UBS then
+         Set_Mechanism_With_Checks (Ent, By_Descriptor_UBS,  Mech_Name);
+
+      elsif Chars (Class) = Name_UBSB then
+         Set_Mechanism_With_Checks (Ent, By_Descriptor_UBSB, Mech_Name);
+
+      elsif Chars (Class) = Name_UBA then
+         Set_Mechanism_With_Checks (Ent, By_Descriptor_UBA,  Mech_Name);
+
+      elsif Chars (Class) = Name_S then
+         Set_Mechanism_With_Checks (Ent, By_Descriptor_S,    Mech_Name);
+
+      elsif Chars (Class) = Name_SB then
+         Set_Mechanism_With_Checks (Ent, By_Descriptor_SB,   Mech_Name);
+
+      elsif Chars (Class) = Name_A then
+         Set_Mechanism_With_Checks (Ent, By_Descriptor_A,    Mech_Name);
+
+      elsif Chars (Class) = Name_NCA then
+         Set_Mechanism_With_Checks (Ent, By_Descriptor_NCA,  Mech_Name);
+
+      else
+         Bad_Class;
+         return;
+      end if;
+
+   end Set_Mechanism_Value;
+
+   -------------------------------
+   -- Set_Mechanism_With_Checks --
+   -------------------------------
+
+   procedure Set_Mechanism_With_Checks
+     (Ent  : Entity_Id;
+      Mech : Mechanism_Type;
+      Enod : Node_Id)
+   is
+   begin
+      --  Right now we only do some checks for functions returning arguments
+      --  by desctiptor. Probably mode checks need to be added here ???
+
+      if Mech in Descriptor_Codes and then not Is_Formal (Ent) then
+         if Is_Record_Type (Etype (Ent)) then
+            Error_Msg_N ("?records cannot be returned by Descriptor", Enod);
+            return;
+         end if;
+      end if;
+
+      --  If we fall through, all checks have passed
+
+      Set_Mechanism (Ent, Mech);
+   end Set_Mechanism_With_Checks;
+
+   --------------------
+   -- Set_Mechanisms --
+   --------------------
+
+   procedure Set_Mechanisms (E : Entity_Id) is
+      Formal : Entity_Id;
+      Typ    : Entity_Id;
+
+   begin
+      --  Skip this processing if inside a generic template. Not only is
+      --  it uneccessary (since neither extra formals nor mechanisms are
+      --  relevant for the template itself), but at least at the moment,
+      --  procedures get frozen early inside a template so attempting to
+      --  look at the formal types does not work too well if they are
+      --  private types that have not been frozen yet.
+
+      if Inside_A_Generic then
+         return;
+      end if;
+
+      --  Loop through formals
+
+      Formal := First_Formal (E);
+      while Present (Formal) loop
+
+         if Mechanism (Formal) = Default_Mechanism then
+            Typ := Underlying_Type (Etype (Formal));
+
+            --  If there is no underlying type, then skip this processing and
+            --  leave the convention set to Default_Mechanism. It seems odd
+            --  that there should ever be such cases but there are (see
+            --  comments for filed regression tests 1418-001 and 1912-009) ???
+
+            if No (Typ) then
+               goto Skip_Formal;
+            end if;
+
+            case Convention (E) is
+
+               ---------
+               -- Ada --
+               ---------
+
+               --  Note: all RM defined conventions are treated the same
+               --  from the point of view of parameter passing mechanims
+
+               when Convention_Ada       |
+                    Convention_Intrinsic |
+                    Convention_Entry     |
+                    Convention_Protected |
+                    Convention_Stubbed   =>
+
+                  --  By reference types are passed by reference (RM 6.2(4))
+
+                  if Is_By_Reference_Type (Typ) then
+                     Set_Mechanism (Formal, By_Reference);
+
+                  --  By copy types are passed by copy (RM 6.2(3))
+
+                  elsif Is_By_Copy_Type (Typ) then
+                     Set_Mechanism (Formal, By_Copy);
+
+                  --  All other types we leave the Default_Mechanism set, so
+                  --  that the backend can choose the appropriate method.
+
+                  else
+                     null;
+                  end if;
+
+               -------
+               -- C --
+               -------
+
+               --  Note: Assembler, C++, Java, Stdcall also use C conventions
+
+               when Convention_Assembler |
+                    Convention_C         |
+                    Convention_CPP       |
+                    Convention_Java      |
+                    Convention_Stdcall   =>
+
+                  --  The following values are passed by copy
+
+                  --    IN Scalar parameters (RM B.3(66))
+                  --    IN parameters of access types (RM B.3(67))
+                  --    Access parameters (RM B.3(68))
+                  --    Access to subprogram types (RM B.3(71))
+
+                  --  Note: in the case of access parameters, it is the
+                  --  pointer that is passed by value. In GNAT access
+                  --  parameters are treated as IN parameters of an
+                  --  anonymous access type, so this falls out free.
+
+                  --  The bottom line is that all IN elementary types
+                  --  are passed by copy in GNAT.
+
+                  if Is_Elementary_Type (Typ) then
+                     if Ekind (Formal) = E_In_Parameter then
+                        Set_Mechanism (Formal, By_Copy);
+
+                     --  OUT and IN OUT parameters of elementary types are
+                     --  passed by reference (RM B.3(68)). Note that we are
+                     --  not following the advice to pass the address of a
+                     --  copy to preserve by copy semantics.
+
+                     else
+                        Set_Mechanism (Formal, By_Reference);
+                     end if;
+
+                  --  Records are normally passed by reference (RM B.3(69)).
+                  --  However, this can be overridden by the use of the
+                  --  C_Pass_By_Copy pragma or C_Pass_By_Copy convention.
+
+                  elsif Is_Record_Type (Typ) then
+
+                     --  If the record is not convention C, then we always
+                     --  pass by reference, C_Pass_By_Copy does not apply.
+
+                     if Convention (Typ) /= Convention_C then
+                        Set_Mechanism (Formal, By_Reference);
+
+                     --  If convention C_Pass_By_Copy was specified for
+                     --  the record type, then we pass by copy.
+
+                     elsif C_Pass_By_Copy (Typ) then
+                        Set_Mechanism (Formal, By_Copy);
+
+                     --  Otherwise, for a C convention record, we set the
+                     --  convention in accordance with a possible use of
+                     --  the C_Pass_By_Copy pragma. Note that the value of
+                     --  Default_C_Record_Mechanism in the absence of such
+                     --  a pragma is By_Reference.
+
+                     else
+                        Set_Mechanism (Formal, Default_C_Record_Mechanism);
+                     end if;
+
+                  --  Array types are passed by reference (B.3 (71))
+
+                  elsif Is_Array_Type (Typ) then
+                     Set_Mechanism (Formal, By_Reference);
+
+                  --  For all other types, use Default_Mechanism mechanism
+
+                  else
+                     null;
+                  end if;
+
+               -----------
+               -- COBOL --
+               -----------
+
+               when Convention_COBOL =>
+
+                  --  Access parameters (which in GNAT look like IN parameters
+                  --  of an access type) are passed by copy (RM B.4(96)) as
+                  --  are all other IN parameters of scalar type (RM B.4(97)).
+
+                  --  For now we pass these parameters by reference as well.
+                  --  The RM specifies the intent BY_CONTENT, but gigi does
+                  --  not currently transform By_Copy properly. If we pass by
+                  --  reference, it will be imperative to introduce copies ???
+
+                  if Is_Elementary_Type (Typ)
+                    and then Ekind (Formal) = E_In_Parameter
+                  then
+                     Set_Mechanism (Formal, By_Reference);
+
+                  --  All other parameters (i.e. all non-scalar types, and
+                  --  all OUT or IN OUT parameters) are passed by reference.
+                  --  Note that at the moment we are not bothering to make
+                  --  copies of scalar types as recommended in the RM.
+
+                  else
+                     Set_Mechanism (Formal, By_Reference);
+                  end if;
+
+               -------------
+               -- Fortran --
+               -------------
+
+               when Convention_Fortran =>
+
+                  --  In OpenVMS, pass a character of array of character
+                  --  value using Descriptor(S). Should this also test
+                  --  Debug_Flag_M ???
+
+                  if OpenVMS_On_Target
+                    and then (Root_Type (Typ) = Standard_Character
+                               or else
+                                 (Is_Array_Type (Typ)
+                                   and then
+                                     Root_Type (Component_Type (Typ)) =
+                                                     Standard_Character))
+                  then
+                     Set_Mechanism (Formal, By_Descriptor_S);
+
+                  --  Access types are passed by default (presumably this
+                  --  will mean they are passed by copy)
+
+                  elsif Is_Access_Type (Typ) then
+                     null;
+
+                  --  For now, we pass all other parameters by reference.
+                  --  It is not clear that this is right in the long run,
+                  --  but it seems to correspond to what gnu f77 wants.
+
+
+                  else
+                     Set_Mechanism (Formal, By_Reference);
+                  end if;
+
+            end case;
+         end if;
+
+         <<Skip_Formal>> -- remove this when problem above is fixed ???
+
+         Next_Formal (Formal);
+      end loop;
+
+      --  Now deal with return type, we always leave the default mechanism
+      --  set except for the case of returning a By_Reference type for an
+      --  Ada convention, where we force return by reference
+
+      if Ekind (E) = E_Function
+        and then Mechanism (E) = Default_Mechanism
+        and then not Has_Foreign_Convention (E)
+        and then Is_By_Reference_Type (Etype (E))
+      then
+         Set_Mechanism (E, By_Reference);
+      end if;
+
+   end Set_Mechanisms;
+
+end Sem_Mech;
diff --git a/gcc/ada/sem_mech.ads b/gcc/ada/sem_mech.ads
new file mode 100644
index 00000000000..4b0993db3ba
--- /dev/null
+++ b/gcc/ada/sem_mech.ads
@@ -0,0 +1,173 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             S E M _ M E C H                              --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.6 $                              --
+--                                                                          --
+--          Copyright (C) 1996-1997 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 contains the routine used to establish calling mechanisms
+--  The reason we separate this off into its own package is that it is
+--  entirely possible that it may need some target specific specialization.
+
+with Types; use Types;
+
+package Sem_Mech is
+
+   -------------------------------------------------
+   -- Definitions for Parameter Mechanism Control --
+   -------------------------------------------------
+
+   --  For parameters passed to subprograms, and for function return values,
+   --  as passing mechanism is defined. The entity attribute Mechanism returns
+   --  an indication of the mechanism, and Set_Mechanism can be used to set
+   --  the mechanism. At the program level, there are three ways to explicitly
+   --  set the mechanism:
+
+   --    An Import_xxx or Export_xxx pragma (where xxx is Function, Procedure,
+   --    or Valued_Procedure) can explicitly set the mechanism for either a
+   --    parameter or a function return value. A mechanism explicitly set by
+   --    such a pragma overrides the effect of C_Pass_By_Copy described below.
+
+   --    If convention C_Pass_By_Copy is set for a record, and the record type
+   --    is used as the formal type of a subprogram with a foreign convention,
+   --    then the mechanism is set to By_Copy.
+
+   --    If a pragma C_Pass_By_Copy applies, and a record type has Convention
+   --    C, and the record type is used as the formal type of a subprogram
+   --    with a foreign convention, then the mechanism is set to use By_Copy
+   --    if the size of the record is sufficiently small (as determined by
+   --    the value of the parameter to pragma C_Pass_By_Copy).
+
+   --  The subtype Mechanism_Type (declared in Types) is used to describe
+   --  the mechanism to be used. The following special values of this type
+   --  specify the mechanism, as follows.
+
+   Default_Mechanism : constant Mechanism_Type := 0;
+   --  The default setting indicates that the backend will choose the proper
+   --  default mechanism. This depends on the convention of the subprogram
+   --  involved, and is generally target dependent. In the compiler, the
+   --  backend chooses the mechanism in this case in accordance with any
+   --  requirements imposed by the ABI. Note that Default is never used for
+   --  record types on foreign convention subprograms, since By_Reference
+   --  is forced for such types unless one of the above described approaches
+   --  is used to explicitly force By_Copy.
+
+   By_Copy : constant Mechanism_Type := -1;
+   --  Passing by copy is forced. The exact meaning of By_Copy (e.g. whether
+   --  at a low level the value is passed in registers, or the value is copied
+   --  and a pointer is passed), is determined by the backend in accordance
+   --  with requirements imposed by the ABI. Note that in the extended import
+   --  and export pragma mechanisms, this is called Value, rather than Copy.
+
+   By_Reference : constant Mechanism_Type := -2;
+   --  Passing by reference is forced. This is always equivalent to passing
+   --  a simple pointer in the case of subprograms with a foreign convention.
+   --  For unconstrained arrays passed to foreign convention subprograms, the
+   --  address of the first element of the array is passed. For convention
+   --  Ada, the result is logically to pass a reference, but the precise
+   --  mechanism (e.g. to pass bounds of unconstrained types and other needed
+   --  special information) is determined by the backend in accordance with
+   --  requirements imposed by the ABI as interpreted for Ada.
+
+   By_Descriptor      : constant Mechanism_Type := -3;
+   By_Descriptor_UBS  : constant Mechanism_Type := -4;
+   By_Descriptor_UBSB : constant Mechanism_Type := -5;
+   By_Descriptor_UBA  : constant Mechanism_Type := -6;
+   By_Descriptor_S    : constant Mechanism_Type := -7;
+   By_Descriptor_SB   : constant Mechanism_Type := -8;
+   By_Descriptor_A    : constant Mechanism_Type := -9;
+   By_Descriptor_NCA  : constant Mechanism_Type := -10;
+   --  These values are used only in OpenVMS ports of GNAT. Pass by descriptor
+   --  is forced, as described in the OpenVMS ABI. The suffix indicates the
+   --  descriptor type:
+   --
+   --     UBS    unaligned bit string
+   --     UBSB   aligned bit string with arbitrary bounds
+   --     UBA    unaligned bit array
+   --     S      string, also a scalar or access type parameter
+   --     SB     string with arbitrary bounds
+   --     A      contiguous array
+   --     NCA    non-contiguous array
+   --
+   --  Note: the form with no suffix is used if the Import/Export pragma
+   --  uses the simple form of the mechanism name where no descriptor
+   --  type is supplied. In this case the back end assigns a descriptor
+   --  type based on the Ada type in accordance with the OpenVMS ABI.
+
+   subtype Descriptor_Codes is Mechanism_Type
+     range By_Descriptor_NCA .. By_Descriptor;
+   --  Subtype including all descriptor mechanisms
+
+   --  All the above special values are non-positive. Positive values for
+   --  Mechanism_Type values have a special meaning. They are used only in
+   --  the case of records, as a result of the use of the C_Pass_By_Copy
+   --  pragma, and the meaning is that if the size of the record is known
+   --  at compile time and does not exceed the mechanism type value, then
+   --  By_Copy passing is forced, otherwise By_Reference is forced.
+
+   ----------------------
+   -- Global Variables --
+   ----------------------
+
+   Default_C_Record_Mechanism : Mechanism_Type := By_Reference;
+   --  This value is the default mechanism used for C convention records
+   --  in foreign-convention subprograms if no mechanism is otherwise
+   --  specified. This value is modified appropriately by the occurrence
+   --  of a C_Pass_By_Copy configuration pragma.
+
+   -----------------
+   -- Subprograms --
+   -----------------
+
+   procedure Set_Mechanisms (E : Entity_Id);
+   --  E is a subprogram or subprogram type that has been frozen, so the
+   --  convention of the subprogram and all its formal types and result
+   --  type in the case of a function are established. The function of
+   --  this call is to set mechanism values for formals and for the
+   --  function return if they have not already been explicitly set by
+   --  a use of an extended Import or Export pragma. The idea is to set
+   --  mechanism values whereever the semantics is dictated by either
+   --  requirements or implementation advice in the RM, and to leave
+   --  the mechanism set to Default if there is no requirement, so that
+   --  the back-end is free to choose the most efficient method.
+
+   procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id);
+   --  Mech is a parameter passing mechanism (see Import_Function syntax
+   --  for MECHANISM_NAME). This routine checks that the mechanism argument
+   --  has the right form, and if not issues an error message. If the
+   --  argument has the right form then the Mechanism field of Ent is
+   --  set appropriately. It also performs some error checks. Note that
+   --  the mechanism name has not been analyzed (and cannot indeed be
+   --  analyzed, since it is semantic nonsense), so we get it in the
+   --  exact form created by the parser.
+
+   procedure Set_Mechanism_With_Checks
+     (Ent  : Entity_Id;
+      Mech : Mechanism_Type;
+      Enod : Node_Id);
+   --  Sets the mechanism of Ent to the given Mech value, after first checking
+   --  that the request makes sense. If it does not make sense, a warning is
+   --  posted on node Enod, and the Mechanism of Ent is unchanged.
+
+end Sem_Mech;
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
new file mode 100644
index 00000000000..4910c7842ac
--- /dev/null
+++ b/gcc/ada/sem_prag.adb
@@ -0,0 +1,8796 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             S E M _ P R A G                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.558 $
+--                                                                          --
+--          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 unit contains the semantic processing for all pragmas, both language
+--  and implementation defined. For most pragmas, the parser only does the
+--  most basic job of checking the syntax, so Sem_Prag also contains the code
+--  to complete the syntax checks. Certain pragmas are handled partially or
+--  completely by the parser (see Par.Prag for further details).
+
+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 Errout;   use Errout;
+with Expander; use Expander;
+with Exp_Dist; use Exp_Dist;
+with Fname;    use Fname;
+with Hostparm; use Hostparm;
+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 Restrict; use Restrict;
+with Rtsfind;  use Rtsfind;
+with Sem;      use Sem;
+with Sem_Ch8;  use Sem_Ch8;
+with Sem_Ch13; use Sem_Ch13;
+with Sem_Disp; use Sem_Disp;
+with Sem_Elim; use Sem_Elim;
+with Sem_Eval; use Sem_Eval;
+with Sem_Intr; use Sem_Intr;
+with Sem_Mech; use Sem_Mech;
+with Sem_Res;  use Sem_Res;
+with Sem_Type; use Sem_Type;
+with Sem_Util; use Sem_Util;
+with Sem_VFpt; use Sem_VFpt;
+with Stand;    use Stand;
+with Sinfo;    use Sinfo;
+with Sinfo.CN; use Sinfo.CN;
+with Sinput;   use Sinput;
+with Snames;   use Snames;
+with Stringt;  use Stringt;
+with Stylesw;  use Stylesw;
+with Targparm; use Targparm;
+with Tbuild;   use Tbuild;
+with Ttypes;
+with Uintp;    use Uintp;
+with Urealp;   use Urealp;
+with Validsw;  use Validsw;
+
+package body Sem_Prag is
+
+   ----------------------------------------------
+   -- Common Handling of Import-Export Pragmas --
+   ----------------------------------------------
+
+   --  In the following section, a number of Import_xxx and Export_xxx
+   --  pragmas are defined by GNAT. These are compatible with the DEC
+   --  pragmas of the same name, and all have the following common
+   --  form and processing:
+
+   --  pragma Export_xxx
+   --        [Internal                 =>] LOCAL_NAME,
+   --     [, [External                 =>] EXTERNAL_SYMBOL]
+   --     [, other optional parameters   ]);
+
+   --  pragma Import_xxx
+   --        [Internal                 =>] LOCAL_NAME,
+   --     [, [External                 =>] EXTERNAL_SYMBOL]
+   --     [, other optional parameters   ]);
+
+   --   EXTERNAL_SYMBOL ::=
+   --     IDENTIFIER
+   --   | static_string_EXPRESSION
+
+   --  The internal LOCAL_NAME designates the entity that is imported or
+   --  exported, and must refer to an entity in the current declarative
+   --  part (as required by the rules for LOCAL_NAME).
+
+   --  The external linker name is designated by the External parameter
+   --  if given, or the Internal parameter if not (if there is no External
+   --  parameter, the External parameter is a copy of the Internal name).
+
+   --  If the External parameter is given as a string, then this string
+   --  is treated as an external name (exactly as though it had been given
+   --  as an External_Name parameter for a normal Import pragma).
+
+   --  If the External parameter is given as an identifier (or there is no
+   --  External parameter, so that the Internal identifier is used), then
+   --  the external name is the characters of the identifier, translated
+   --  to all upper case letters for OpenVMS versions of GNAT, and to all
+   --  lower case letters for all other versions
+
+   --  Note: the external name specified or implied by any of these special
+   --  Import_xxx or Export_xxx pragmas override an external or link name
+   --  specified in a previous Import or Export pragma.
+
+   --  Note: these and all other DEC-compatible GNAT pragmas allow full
+   --  use of named notation, following the standard rules for subprogram
+   --  calls, i.e. parameters can be given in any order if named notation
+   --  is used, and positional and named notation can be mixed, subject to
+   --  the rule that all positional parameters must appear first.
+
+   --  Note: All these pragmas are implemented exactly following the DEC
+   --  design and implementation and are intended to be fully compatible
+   --  with the use of these pragmas in the DEC Ada compiler.
+
+   -------------------------------------
+   -- Local Subprograms and Variables --
+   -------------------------------------
+
+   function Adjust_External_Name_Case (N : Node_Id) return Node_Id;
+   --  This routine is used for possible casing adjustment of an explicit
+   --  external name supplied as a string literal (the node N), according
+   --  to the casing requirement of Opt.External_Name_Casing. If this is
+   --  set to As_Is, then the string literal is returned unchanged, but if
+   --  it is set to Uppercase or Lowercase, then a new string literal with
+   --  appropriate casing is constructed.
+
+   function Is_Generic_Subprogram (Id : Entity_Id) return Boolean;
+   --  Return True if Id is a generic procedure or a function
+
+   function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id;
+   --  If Def_Id refers to a renamed subprogram, then the base subprogram
+   --  (the original one, following the renaming chain) is returned.
+   --  Otherwise the entity is returned unchanged. Should be in Einfo???
+
+   procedure Set_Unit_Name (N : Node_Id; With_Item : Node_Id);
+   --  Place semantic information on the argument of an Elaborate or
+   --  Elaborate_All pragma. Entity name for unit and its parents is
+   --  taken from item in previous with_clause that mentions the unit.
+
+   Locking_Policy_Sloc          : Source_Ptr := No_Location;
+   Queuing_Policy_Sloc          : Source_Ptr := No_Location;
+   Task_Dispatching_Policy_Sloc : Source_Ptr := No_Location;
+   --  These global variables remember the location of a previous locking,
+   --  queuing or task dispatching policy pragma, so that appropriate error
+   --  messages can be generated for inconsistent pragmas. Note that it is
+   --  fine that these are global locations, because the check for consistency
+   --  is over the entire program.
+
+   -------------------------------
+   -- Adjust_External_Name_Case --
+   -------------------------------
+
+   function Adjust_External_Name_Case (N : Node_Id) return Node_Id is
+      CC : Char_Code;
+
+   begin
+      --  Adjust case of literal if required
+
+      if Opt.External_Name_Exp_Casing = As_Is then
+         return N;
+
+      else
+         --  Copy existing string
+
+         Start_String;
+
+         --  Set proper casing
+
+         for J in 1 .. String_Length (Strval (N)) loop
+            CC := Get_String_Char (Strval (N), J);
+
+            if Opt.External_Name_Exp_Casing = Uppercase
+              and then CC >= Get_Char_Code ('a')
+              and then CC <= Get_Char_Code ('z')
+            then
+               Store_String_Char (CC - 32);
+
+            elsif Opt.External_Name_Exp_Casing = Lowercase
+              and then CC >= Get_Char_Code ('A')
+              and then CC <= Get_Char_Code ('Z')
+            then
+               Store_String_Char (CC + 32);
+
+            else
+               Store_String_Char (CC);
+            end if;
+         end loop;
+
+         return
+           Make_String_Literal (Sloc (N),
+             Strval => End_String);
+      end if;
+   end Adjust_External_Name_Case;
+
+   --------------------
+   -- Analyze_Pragma --
+   --------------------
+
+   procedure Analyze_Pragma (N : Node_Id) is
+      Loc     : constant Source_Ptr := Sloc (N);
+      Prag_Id : Pragma_Id;
+
+      Pragma_Exit : exception;
+      --  This exception is used to exit pragma processing completely. It
+      --  is used when an error is detected, and in other situations where
+      --  it is known that no further processing is required.
+
+      Arg_Count : Nat;
+      --  Number of pragma argument associations
+
+      Arg1 : Node_Id;
+      Arg2 : Node_Id;
+      Arg3 : Node_Id;
+      Arg4 : Node_Id;
+      --  First four pragma arguments (pragma argument association nodes,
+      --  or Empty if the corresponding argument does not exist).
+
+      procedure Check_Ada_83_Warning;
+      --  Issues a warning message for the current pragma if operating in Ada
+      --  83 mode (used for language pragmas that are not a standard part of
+      --  Ada 83). This procedure does not raise Error_Pragma. Also notes use
+      --  of 95 pragma.
+
+      procedure Check_Arg_Count (Required : Nat);
+      --  Check argument count for pragma is equal to given parameter.
+      --  If not, then issue an error message and raise Pragma_Exit.
+
+      --  Note: all routines whose name is Check_Arg_Is_xxx take an
+      --  argument Arg which can either be a pragma argument association,
+      --  in which case the check is applied to the expression of the
+      --  association or an expression directly.
+
+      procedure Check_Arg_Is_Identifier (Arg : Node_Id);
+      --  Check the specified argument Arg to make sure that it is an
+      --  identifier. If not give error and raise Pragma_Exit.
+
+      procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id);
+      --  Check the specified argument Arg to make sure that it is an
+      --  integer literal. If not give error and raise Pragma_Exit.
+
+      procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id);
+      --  Check the specified argument Arg to make sure that it has the
+      --  proper syntactic form for a local name and meets the semantic
+      --  requirements for a local name. The local name is analyzed as
+      --  part of the processing for this call. In addition, the local
+      --  name is required to represent an entity at the library level.
+
+      procedure Check_Arg_Is_Local_Name (Arg : Node_Id);
+      --  Check the specified argument Arg to make sure that it has the
+      --  proper syntactic form for a local name and meets the semantic
+      --  requirements for a local name. The local name is analyzed as
+      --  part of the processing for this call.
+
+      procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id);
+      --  Check the specified argument Arg to make sure that it is a valid
+      --  locking policy name. If not give error and raise Pragma_Exit.
+
+      procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id);
+      procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2, N3 : Name_Id);
+      --  Check the specified argument Arg to make sure that it is an
+      --  identifier whose name matches either N1 or N2 (or N3 if present).
+      --  If not then give error and raise Pragma_Exit.
+
+      procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id);
+      --  Check the specified argument Arg to make sure that it is a valid
+      --  queuing policy name. If not give error and raise Pragma_Exit.
+
+      procedure Check_Arg_Is_Static_Expression
+        (Arg : Node_Id;
+         Typ : Entity_Id);
+      --  Check the specified argument Arg to make sure that it is a static
+      --  expression of the given type (i.e. it will be analyzed and resolved
+      --  using this type, which can be any valid argument to Resolve, e.g.
+      --  Any_Integer is OK). If not, given error and raise Pragma_Exit.
+
+      procedure Check_Arg_Is_String_Literal (Arg : Node_Id);
+      --  Check the specified argument Arg to make sure that it is a
+      --  string literal. If not give error and raise Pragma_Exit
+
+      procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id);
+      --  Check the specified argument Arg to make sure that it is a valid
+      --  valid task dispatching policy name. If not give error and raise
+      --  Pragma_Exit.
+
+      procedure Check_At_Least_N_Arguments (N : Nat);
+      --  Check there are at least N arguments present
+
+      procedure Check_At_Most_N_Arguments (N : Nat);
+      --  Check there are no more than N arguments present
+
+      procedure Check_First_Subtype (Arg : Node_Id);
+      --  Checks that Arg, whose expression is an entity name referencing
+      --  a subtype, does not reference a type that is not a first subtype.
+
+      procedure Check_In_Main_Program;
+      --  Common checks for pragmas that appear within a main program
+      --  (Priority, Main_Storage, Time_Slice).
+
+      procedure Check_Interrupt_Or_Attach_Handler;
+      --  Common processing for first argument of pragma Interrupt_Handler
+      --  or pragma Attach_Handler.
+
+      procedure Check_Is_In_Decl_Part_Or_Package_Spec;
+      --  Check that pragma appears in a declarative part, or in a package
+      --  specification, i.e. that it does not occur in a statement sequence
+      --  in a body.
+
+      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
+      --  Pragma_Exit is raised.
+
+      procedure Check_No_Identifiers;
+      --  Checks that none of the arguments to the pragma has an identifier.
+      --  If any argument has an identifier, then an error message is issued,
+      --  and Pragma_Exit is raised.
+
+      procedure Check_Non_Overloaded_Function (Arg : Node_Id);
+      --  Check that the given argument is the name of a local function of
+      --  one argument that is not overloaded in the current local scope.
+
+      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_Pragmas raised.
+
+      procedure Check_Optional_Identifier (Arg : Node_Id; Id : String);
+      --  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_Pragmas raised.
+      --  In this version of the procedure, the identifier name is given as
+      --  a string with lower case letters.
+
+      procedure Check_Static_Constraint (Constr : Node_Id);
+      --  Constr is a constraint from an N_Subtype_Indication node from a
+      --  component constraint in an Unchecked_Union type. This routine checks
+      --  that the constraint is static as required by the restrictions for
+      --  Unchecked_Union.
+
+      procedure Check_Valid_Configuration_Pragma;
+      --  Legality checks for placement of a configuration pragma
+
+      procedure Check_Valid_Library_Unit_Pragma;
+      --  Legality checks for library unit pragmas. A special case arises for
+      --  pragmas in generic instances that come from copies of the original
+      --  library unit pragmas in the generic templates. In the case of other
+      --  than library level instantiations these can appear in contexts which
+      --  would normally be invalid (they only apply to the original template
+      --  and to library level instantiations), and they are simply ignored,
+      --  which is implemented by rewriting them as null statements.
+
+      procedure Error_Pragma (Msg : String);
+      pragma No_Return (Error_Pragma);
+      --  Outputs error message for current pragma. The message contains an %
+      --  that will be replaced with the pragma name, and the flag is placed
+      --  on the pragma itself. Pragma_Exit is then raised.
+
+      procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id);
+      pragma No_Return (Error_Pragma_Arg);
+      --  Outputs error message for current pragma. The message may contain
+      --  a % that will be replaced with the pragma name. The parameter Arg
+      --  may either be a pragma argument association, in which case the flag
+      --  is placed on the expression of this association, or an expression,
+      --  in which case the flag is placed directly on the expression. The
+      --  message is placed using Error_Msg_N, so the message may also contain
+      --  an & insertion character which will reference the given Arg value.
+      --  After placing the message, Pragma_Exit is raised.
+
+      procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id);
+      pragma No_Return (Error_Pragma_Arg);
+      --  Similar to above form of Error_Pragma_Arg except that two messages
+      --  are provided, the second is a continuation comment starting with \.
+
+      procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id);
+      pragma No_Return (Error_Pragma_Arg_Ident);
+      --  Outputs error message for current pragma. The message may contain
+      --  a % that will be replaced with the pragma name. The parameter Arg
+      --  must be a pragma argument association with a non-empty identifier
+      --  (i.e. its Chars field must be set), and the error message is placed
+      --  on the identifier. The message is placed using Error_Msg_N so
+      --  the message may also contain an & insertion character which will
+      --  reference the identifier. After placing the message, Pragma_Exit
+      --  is raised.
+
+      function Find_Lib_Unit_Name return Entity_Id;
+      --  Used for a library unit pragma to find the entity to which the
+      --  library unit pragma applies, returns the entity found.
+
+      procedure Find_Program_Unit_Name (Id : Node_Id);
+      --  If the pragma is a compilation unit pragma, the id must denote the
+      --  compilation unit in the same compilation, and the pragma must appear
+      --  in the list of preceding or trailing pragmas. If it is a program
+      --  unit pragma that is not a compilation unit pragma, then the
+      --  identifier must be visible.
+
+      type Name_List is array (Natural range <>) of Name_Id;
+      type Args_List is array (Natural range <>) of Node_Id;
+      procedure Gather_Associations
+        (Names : Name_List;
+         Args  : out Args_List);
+      --  This procedure is used to gather the arguments for a pragma that
+      --  permits arbitrary ordering of parameters using the normal rules
+      --  for named and positional parameters. The Names argument is a list
+      --  of Name_Id values that corresponds to the allowed pragma argument
+      --  association identifiers in order. The result returned in Args is
+      --  a list of corresponding expressions that are the pragma arguments.
+      --  Note that this is a list of expressions, not of pragma argument
+      --  associations (Gather_Associations has completely checked all the
+      --  optional identifiers when it returns). An entry in Args is Empty
+      --  on return if the corresponding argument is not present.
+
+      function Get_Pragma_Arg (Arg : Node_Id) return Node_Id;
+      --  All the routines that check pragma arguments take either a pragma
+      --  argument association (in which case the expression of the argument
+      --  association is checked), or the expression directly. The function
+      --  Get_Pragma_Arg is a utility used to deal with these two cases. If
+      --  Arg is a pragma argument association node, then its expression is
+      --  returned, otherwise Arg is returned unchanged.
+
+      procedure GNAT_Pragma;
+      --  Called for all GNAT defined pragmas to note the use of the feature,
+      --  and also check the relevant restriction (No_Implementation_Pragmas).
+
+      function Is_Before_First_Decl
+        (Pragma_Node : Node_Id;
+         Decls       : List_Id)
+         return        Boolean;
+      --  Return True if Pragma_Node is before the first declarative item in
+      --  Decls where Decls is the list of declarative items.
+
+      function Is_Configuration_Pragma return Boolean;
+      --  Deterermines if the placement of the current pragma is appropriate
+      --  for a configuration pragma (precedes the current compilation unit)
+
+      procedure Pragma_Misplaced;
+      --  Issue fatal error message for misplaced pragma
+
+      procedure Process_Atomic_Shared_Volatile;
+      --  Common processing for pragmas Atomic, Shared, Volatile. Note that
+      --  Shared is an obsolete Ada 83 pragma, treated as being identical
+      --  in effect to pragma Atomic.
+
+      procedure Process_Convention (C : out Convention_Id; E : out Entity_Id);
+      --  Common procesing for Convention, Interface, Import and Export.
+      --  Checks first two arguments of pragma, and sets the appropriate
+      --  convention value in the specified entity or entities. On return
+      --  C is the convention, E is the referenced entity.
+
+      procedure Process_Extended_Import_Export_Exception_Pragma
+        (Arg_Internal : Node_Id;
+         Arg_External : Node_Id;
+         Arg_Form     : Node_Id;
+         Arg_Code     : Node_Id);
+      --  Common processing for the pragmas Import/Export_Exception.
+      --  The three arguments correspond to the three named parameters of
+      --  the pragma. An argument is empty if the corresponding parameter
+      --  is not present in the pragma.
+
+      procedure Process_Extended_Import_Export_Object_Pragma
+        (Arg_Internal : Node_Id;
+         Arg_External : Node_Id;
+         Arg_Size     : Node_Id);
+      --  Common processing for the pragmass Import/Export_Object.
+      --  The three arguments correspond to the three named parameters
+      --  of the pragmas. An argument is empty if the corresponding
+      --  parameter is not present in the pragma.
+
+      procedure Process_Extended_Import_Export_Internal_Arg
+        (Arg_Internal : Node_Id := Empty);
+      --  Common processing for all extended Import and Export pragmas. The
+      --  argument is the pragma parameter for the Internal argument. If
+      --  Arg_Internal is empty or inappropriate, an error message is posted.
+      --  Otherwise, on normal return, the Entity_Field of Arg_Internal is
+      --  set to identify the referenced entity.
+
+      procedure Process_Extended_Import_Export_Subprogram_Pragma
+        (Arg_Internal                 : Node_Id;
+         Arg_External                 : Node_Id;
+         Arg_Parameter_Types          : Node_Id;
+         Arg_Result_Type              : Node_Id := Empty;
+         Arg_Mechanism                : Node_Id;
+         Arg_Result_Mechanism         : Node_Id := Empty;
+         Arg_First_Optional_Parameter : Node_Id := Empty);
+      --  Common processing for all extended Import and Export pragmas
+      --  applying to subprograms. The caller omits any arguments that do
+      --  bnot apply to the pragma in question (for example, Arg_Result_Type
+      --  can be non-Empty only in the Import_Function and Export_Function
+      --  cases). The argument names correspond to the allowed pragma
+      --  association identifiers.
+
+      procedure Process_Generic_List;
+      --  Common processing for Share_Generic and Inline_Generic
+
+      procedure Process_Import_Or_Interface;
+      --  Common processing for Import of Interface
+
+      procedure Process_Inline (Active : Boolean);
+      --  Common processing for Inline and Inline_Always. The parameter
+      --  indicates if the inline pragma is active, i.e. if it should
+      --  actually cause inlining to occur.
+
+      procedure Process_Interface_Name
+        (Subprogram_Def : Entity_Id;
+         Ext_Arg        : Node_Id;
+         Link_Arg       : Node_Id);
+      --  Given the last two arguments of pragma Import, pragma Export, or
+      --  pragma Interface_Name, performs validity checks and sets the
+      --  Interface_Name field of the given subprogram entity to the
+      --  appropriate external or link name, depending on the arguments
+      --  given. Ext_Arg is always present, but Link_Arg may be missing.
+      --  Note that Ext_Arg may represent the Link_Name if Link_Arg is
+      --  missing, and appropriate named notation is used for Ext_Arg.
+      --  If neither Ext_Arg nor Link_Arg is present, the interface name
+      --  is set to the default from the subprogram name.
+
+      procedure Process_Interrupt_Or_Attach_Handler;
+      --  Attach the pragmas to the rep item chain.
+
+      procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean);
+      --  Common processing for Suppress and Unsuppress. The boolean parameter
+      --  Suppress_Case is True for the Suppress case, and False for the
+      --  Unsuppress case.
+
+      procedure Set_Exported (E : Entity_Id; Arg : Node_Id);
+      --  This procedure sets the Is_Exported flag for the given entity,
+      --  checking that the entity was not previously imported. Arg is
+      --  the argument that specified the entity.
+
+      procedure Set_Extended_Import_Export_External_Name
+        (Internal_Ent : Entity_Id;
+         Arg_External : Node_Id);
+      --  Common processing for all extended import export pragmas. The first
+      --  argument, Internal_Ent, is the internal entity, which has already
+      --  been checked for validity by the caller. Arg_External is from the
+      --  Import or Export pragma, and may be null if no External parameter
+      --  was present. If Arg_External is present and is a non-null string
+      --  (a null string is treated as the default), then the Interface_Name
+      --  field of Internal_Ent is set appropriately.
+
+      procedure Set_Imported (E : Entity_Id);
+      --  This procedure sets the Is_Imported flag for the given entity,
+      --  checking that it is not previously exported or imported.
+
+      procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id);
+      --  Mech is a parameter passing mechanism (see Import_Function syntax
+      --  for MECHANISM_NAME). This routine checks that the mechanism argument
+      --  has the right form, and if not issues an error message. If the
+      --  argument has the right form then the Mechanism field of Ent is
+      --  set appropriately.
+
+      --------------------------
+      -- Check_Ada_83_Warning --
+      --------------------------
+
+      procedure Check_Ada_83_Warning is
+      begin
+         GNAT_Pragma;
+
+         if Ada_83 and then Comes_From_Source (N) then
+            Error_Msg_N ("(Ada 83) pragma& is non-standard?", N);
+         end if;
+      end Check_Ada_83_Warning;
+
+      ---------------------
+      -- Check_Arg_Count --
+      ---------------------
+
+      procedure Check_Arg_Count (Required : Nat) is
+      begin
+         if Arg_Count /= Required then
+            Error_Pragma ("wrong number of arguments for pragma%");
+         end if;
+      end Check_Arg_Count;
+
+      -----------------------------
+      -- Check_Arg_Is_Identifier --
+      -----------------------------
+
+      procedure Check_Arg_Is_Identifier (Arg : Node_Id) is
+         Argx : constant Node_Id := Get_Pragma_Arg (Arg);
+
+      begin
+         if Nkind (Argx) /= N_Identifier then
+            Error_Pragma_Arg
+              ("argument for pragma% must be identifier", Argx);
+         end if;
+      end Check_Arg_Is_Identifier;
+
+      ----------------------------------
+      -- Check_Arg_Is_Integer_Literal --
+      ----------------------------------
+
+      procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id) is
+         Argx : constant Node_Id := Get_Pragma_Arg (Arg);
+
+      begin
+         if Nkind (Argx) /= N_Integer_Literal then
+            Error_Pragma_Arg
+              ("argument for pragma% must be integer literal", Argx);
+         end if;
+      end Check_Arg_Is_Integer_Literal;
+
+      -------------------------------------------
+      -- Check_Arg_Is_Library_Level_Local_Name --
+      -------------------------------------------
+
+      --  LOCAL_NAME ::=
+      --    DIRECT_NAME
+      --  | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
+      --  | library_unit_NAME
+
+      procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id) is
+      begin
+         Check_Arg_Is_Local_Name (Arg);
+
+         if not Is_Library_Level_Entity (Entity (Expression (Arg)))
+           and then Comes_From_Source (N)
+         then
+            Error_Pragma_Arg
+              ("argument for pragma% must be library level entity", Arg);
+         end if;
+      end Check_Arg_Is_Library_Level_Local_Name;
+
+      -----------------------------
+      -- Check_Arg_Is_Local_Name --
+      -----------------------------
+
+      --  LOCAL_NAME ::=
+      --    DIRECT_NAME
+      --  | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
+      --  | library_unit_NAME
+
+      procedure Check_Arg_Is_Local_Name (Arg : Node_Id) is
+         Argx : constant Node_Id := Get_Pragma_Arg (Arg);
+
+      begin
+         Analyze (Argx);
+
+         if Nkind (Argx) not in N_Direct_Name
+           and then (Nkind (Argx) /= N_Attribute_Reference
+                      or else Present (Expressions (Argx))
+                      or else Nkind (Prefix (Argx)) /= N_Identifier)
+           and then (not Is_Entity_Name (Argx)
+                      or else not Is_Compilation_Unit (Entity (Argx)))
+         then
+            Error_Pragma_Arg ("argument for pragma% must be local name", Argx);
+         end if;
+
+         if Is_Entity_Name (Argx)
+           and then Scope (Entity (Argx)) /= Current_Scope
+         then
+            Error_Pragma_Arg
+              ("pragma% argument must be in same declarative part", Arg);
+         end if;
+      end Check_Arg_Is_Local_Name;
+
+      ---------------------------------
+      -- Check_Arg_Is_Locking_Policy --
+      ---------------------------------
+
+      procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id) is
+         Argx : constant Node_Id := Get_Pragma_Arg (Arg);
+
+      begin
+         Check_Arg_Is_Identifier (Argx);
+
+         if not Is_Locking_Policy_Name (Chars (Argx)) then
+            Error_Pragma_Arg
+              ("& is not a valid locking policy name", Argx);
+         end if;
+      end Check_Arg_Is_Locking_Policy;
+
+      -------------------------
+      -- Check_Arg_Is_One_Of --
+      -------------------------
+
+      procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
+         Argx : constant Node_Id := Get_Pragma_Arg (Arg);
+
+      begin
+         Check_Arg_Is_Identifier (Argx);
+
+         if Chars (Argx) /= N1 and then Chars (Argx) /= N2 then
+            Error_Msg_Name_2 := N1;
+            Error_Msg_Name_3 := N2;
+            Error_Pragma_Arg ("argument for pragma% must be% or%", Argx);
+         end if;
+      end Check_Arg_Is_One_Of;
+
+      procedure Check_Arg_Is_One_Of
+        (Arg        : Node_Id;
+         N1, N2, N3 : Name_Id)
+      is
+         Argx : constant Node_Id := Get_Pragma_Arg (Arg);
+
+      begin
+         Check_Arg_Is_Identifier (Argx);
+
+         if Chars (Argx) /= N1
+           and then Chars (Argx) /= N2
+           and then Chars (Argx) /= N3
+         then
+            Error_Pragma_Arg ("invalid argument for pragma%", Argx);
+         end if;
+      end Check_Arg_Is_One_Of;
+
+      ---------------------------------
+      -- Check_Arg_Is_Queuing_Policy --
+      ---------------------------------
+
+      procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id) is
+         Argx : constant Node_Id := Get_Pragma_Arg (Arg);
+
+      begin
+         Check_Arg_Is_Identifier (Argx);
+
+         if not Is_Queuing_Policy_Name (Chars (Argx)) then
+            Error_Pragma_Arg
+              ("& is not a valid queuing policy name", Argx);
+         end if;
+      end Check_Arg_Is_Queuing_Policy;
+
+      ------------------------------------
+      -- Check_Arg_Is_Static_Expression --
+      ------------------------------------
+
+      procedure Check_Arg_Is_Static_Expression
+        (Arg : Node_Id;
+         Typ : Entity_Id)
+      is
+         Argx : constant Node_Id := Get_Pragma_Arg (Arg);
+
+      begin
+         Analyze_And_Resolve (Argx, Typ);
+
+         if Is_OK_Static_Expression (Argx) then
+            return;
+
+         elsif Etype (Argx) = Any_Type then
+            raise Pragma_Exit;
+
+         --  An interesting special case, if we have a string literal and
+         --  we are in Ada 83 mode, then we allow it even though it will
+         --  not be flagged as static. This allows the use of Ada 95
+         --  pragmas like Import in Ada 83 mode. They will of course be
+         --  flagged with warnings as usual, but will not cause errors.
+
+         elsif Ada_83 and then Nkind (Argx) = N_String_Literal then
+            return;
+
+         --  Static expression that raises Constraint_Error. This has
+         --  already been flagged, so just exit from pragma processing.
+
+         elsif Is_Static_Expression (Argx) then
+            raise Pragma_Exit;
+
+         --  Finally, we have a real error
+
+         else
+            Error_Pragma_Arg
+              ("argument for pragma% must be a static expression", Argx);
+         end if;
+
+      end Check_Arg_Is_Static_Expression;
+
+      ---------------------------------
+      -- Check_Arg_Is_String_Literal --
+      ---------------------------------
+
+      procedure Check_Arg_Is_String_Literal (Arg : Node_Id) is
+         Argx : constant Node_Id := Get_Pragma_Arg (Arg);
+
+      begin
+         if Nkind (Argx) /= N_String_Literal then
+            Error_Pragma_Arg
+              ("argument for pragma% must be string literal", Argx);
+         end if;
+
+      end Check_Arg_Is_String_Literal;
+
+      ------------------------------------------
+      -- Check_Arg_Is_Task_Dispatching_Policy --
+      ------------------------------------------
+
+      procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id) is
+         Argx : constant Node_Id := Get_Pragma_Arg (Arg);
+
+      begin
+         Check_Arg_Is_Identifier (Argx);
+
+         if not Is_Task_Dispatching_Policy_Name (Chars (Argx)) then
+            Error_Pragma_Arg
+              ("& is not a valid task dispatching policy name", Argx);
+         end if;
+      end Check_Arg_Is_Task_Dispatching_Policy;
+
+      --------------------------------
+      -- Check_At_Least_N_Arguments --
+      --------------------------------
+
+      procedure Check_At_Least_N_Arguments (N : Nat) is
+      begin
+         if Arg_Count < N then
+            Error_Pragma ("too few arguments for pragma%");
+         end if;
+      end Check_At_Least_N_Arguments;
+
+      -------------------------------
+      -- Check_At_Most_N_Arguments --
+      -------------------------------
+
+      procedure Check_At_Most_N_Arguments (N : Nat) is
+         Arg : Node_Id;
+
+      begin
+         if Arg_Count > N then
+            Arg := Arg1;
+
+            for J in 1 .. N loop
+               Next (Arg);
+               Error_Pragma_Arg ("too many arguments for pragma%", Arg);
+            end loop;
+         end if;
+      end Check_At_Most_N_Arguments;
+
+      -------------------------
+      -- Check_First_Subtype --
+      -------------------------
+
+      procedure Check_First_Subtype (Arg : Node_Id) is
+         Argx : constant Node_Id := Get_Pragma_Arg (Arg);
+
+      begin
+         if not Is_First_Subtype (Entity (Argx)) then
+            Error_Pragma_Arg
+              ("pragma% cannot apply to subtype", Argx);
+         end if;
+      end Check_First_Subtype;
+
+      ---------------------------
+      -- Check_In_Main_Program --
+      ---------------------------
+
+      procedure Check_In_Main_Program is
+         P : constant Node_Id := Parent (N);
+
+      begin
+         --  Must be at in subprogram body
+
+         if Nkind (P) /= N_Subprogram_Body then
+            Error_Pragma ("% pragma allowed only in subprogram");
+
+         --  Otherwise warn if obviously not main program
+
+         elsif Present (Parameter_Specifications (Specification (P)))
+           or else not Is_Library_Level_Entity (Defining_Entity (P))
+         then
+            Error_Msg_Name_1 := Chars (N);
+            Error_Msg_N
+              ("?pragma% is only effective in main program", N);
+         end if;
+      end Check_In_Main_Program;
+
+      ---------------------------------------
+      -- Check_Interrupt_Or_Attach_Handler --
+      ---------------------------------------
+
+      procedure Check_Interrupt_Or_Attach_Handler is
+         Arg1_X : constant Node_Id := Expression (Arg1);
+
+      begin
+         Analyze (Arg1_X);
+
+         if not Is_Entity_Name (Arg1_X) then
+            Error_Pragma_Arg
+              ("argument of pragma% must be entity name", Arg1);
+
+         elsif Prag_Id = Pragma_Interrupt_Handler then
+            Check_Restriction (No_Dynamic_Interrupts, N);
+         end if;
+
+         declare
+            Prot_Proc : Entity_Id := Empty;
+            Prot_Type : Entity_Id;
+            Found     : Boolean := False;
+
+         begin
+            if not Is_Overloaded (Arg1_X) then
+               Prot_Proc := Entity (Arg1_X);
+
+            else
+               declare
+                  It    : Interp;
+                  Index : Interp_Index;
+
+               begin
+                  Get_First_Interp (Arg1_X, Index, It);
+                  while Present (It.Nam) loop
+                     Prot_Proc := It.Nam;
+
+                     if Ekind (Prot_Proc) = E_Procedure
+                       and then No (First_Formal (Prot_Proc))
+                     then
+                        if not Found then
+                           Found := True;
+                           Set_Entity (Arg1_X, Prot_Proc);
+                           Set_Is_Overloaded (Arg1_X, False);
+                        else
+                           Error_Pragma_Arg
+                             ("ambiguous handler name for pragma% ", Arg1);
+                        end if;
+                     end if;
+
+                     Get_Next_Interp (Index, It);
+                  end loop;
+
+                  if not Found then
+                     Error_Pragma_Arg
+                       ("argument of pragma% must be parameterless procedure",
+                        Arg1);
+                  else
+                     Prot_Proc := Entity (Arg1_X);
+                  end if;
+               end;
+            end if;
+
+            Prot_Type := Scope (Prot_Proc);
+
+            if Ekind (Prot_Proc) /= E_Procedure
+              or else Ekind (Prot_Type) /= E_Protected_Type
+            then
+               Error_Pragma_Arg
+                 ("argument of pragma% must be protected procedure",
+                  Arg1);
+            end if;
+
+            if not Is_Library_Level_Entity (Prot_Type) then
+               Error_Pragma_Arg
+                 ("pragma% requires library level entity", Arg1);
+            end if;
+
+            if Present (First_Formal (Prot_Proc)) then
+               Error_Pragma_Arg
+                 ("argument of pragma% must be parameterless procedure",
+                  Arg1);
+            end if;
+
+            if Parent (N) /=
+                 Protected_Definition (Parent (Prot_Type))
+            then
+               Error_Pragma ("pragma% must be in protected definition");
+            end if;
+
+         end;
+      end Check_Interrupt_Or_Attach_Handler;
+
+      -------------------------------------------
+      -- Check_Is_In_Decl_Part_Or_Package_Spec --
+      -------------------------------------------
+
+      procedure Check_Is_In_Decl_Part_Or_Package_Spec is
+         P : Node_Id;
+
+      begin
+         P := Parent (N);
+         loop
+            if No (P) then
+               exit;
+
+            elsif Nkind (P) = N_Handled_Sequence_Of_Statements then
+               exit;
+
+            elsif Nkind (P) = N_Package_Specification then
+               return;
+
+            elsif Nkind (P) = N_Block_Statement then
+               return;
+
+            --  Note: the following tests seem a little peculiar, because
+            --  they test for bodies, but if we were in the statement part
+            --  of the body, we would already have hit the handled statement
+            --  sequence, so the only way we get here is by being in the
+            --  declarative part of the body.
+
+            elsif Nkind (P) = N_Subprogram_Body
+              or else Nkind (P) = N_Package_Body
+              or else Nkind (P) = N_Task_Body
+              or else Nkind (P) = N_Entry_Body
+            then
+               return;
+            end if;
+
+            P := Parent (P);
+         end loop;
+
+         Error_Pragma ("pragma% is not in declarative part or package spec");
+
+      end Check_Is_In_Decl_Part_Or_Package_Spec;
+
+      -------------------------
+      -- Check_No_Identifier --
+      -------------------------
+
+      procedure Check_No_Identifier (Arg : Node_Id) is
+      begin
+         if Chars (Arg) /= No_Name then
+            Error_Pragma_Arg_Ident
+              ("pragma% does not permit identifier& here", Arg);
+         end if;
+      end Check_No_Identifier;
+
+      --------------------------
+      -- Check_No_Identifiers --
+      --------------------------
+
+      procedure Check_No_Identifiers is
+         Arg_Node : Node_Id;
+
+      begin
+         if Arg_Count > 0 then
+            Arg_Node := Arg1;
+
+            while Present (Arg_Node) loop
+               Check_No_Identifier (Arg_Node);
+               Next (Arg_Node);
+            end loop;
+         end if;
+      end Check_No_Identifiers;
+
+      -----------------------------------
+      -- Check_Non_Overloaded_Function --
+      -----------------------------------
+
+      procedure Check_Non_Overloaded_Function (Arg : Node_Id) is
+         Ent : Entity_Id;
+
+      begin
+         Check_Arg_Is_Local_Name (Arg);
+         Ent := Entity (Expression (Arg));
+
+         if Present (Homonym (Ent))
+           and then Scope (Homonym (Ent)) = Current_Scope
+         then
+            Error_Pragma_Arg
+              ("argument for pragma% may not be overloaded", Arg);
+         end if;
+
+         if Ekind (Ent) /= E_Function
+           or else No (First_Formal (Ent))
+           or else Present (Next_Formal (First_Formal (Ent)))
+         then
+            Error_Pragma_Arg
+              ("argument for pragma% must be function of one argument", Arg);
+         end if;
+      end Check_Non_Overloaded_Function;
+
+      -------------------------------
+      -- 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_1 := Chars (N);
+               Error_Msg_Name_2 := Id;
+               Error_Msg_N ("pragma% argument expects identifier%", Arg);
+               raise Pragma_Exit;
+            end if;
+         end if;
+      end Check_Optional_Identifier;
+
+      procedure Check_Optional_Identifier (Arg : Node_Id; Id : String) is
+      begin
+         Name_Buffer (1 .. Id'Length) := Id;
+         Name_Len := Id'Length;
+         Check_Optional_Identifier (Arg, Name_Find);
+      end Check_Optional_Identifier;
+
+      -----------------------------
+      -- Check_Static_Constraint --
+      -----------------------------
+
+      --  Note: for convenience in writing this procedure, in addition to
+      --  the officially (i.e. by spec) allowed argument which is always
+      --  a constraint, it also allows ranges and discriminant associations.
+
+      procedure Check_Static_Constraint (Constr : Node_Id) is
+
+         --------------------
+         -- Require_Static --
+         --------------------
+
+         procedure Require_Static (E : Node_Id);
+         --  Require given expression to be static expression
+
+         procedure Require_Static (E : Node_Id) is
+         begin
+            if not Is_OK_Static_Expression (E) then
+               Error_Msg_N
+                 ("non-static constraint not allowed in Unchecked_Union", E);
+               raise Pragma_Exit;
+            end if;
+         end Require_Static;
+
+      --  Start of processing for Check_Static_Constraint
+
+      begin
+         case Nkind (Constr) is
+            when N_Discriminant_Association =>
+               Require_Static (Expression (Constr));
+
+            when N_Range =>
+               Require_Static (Low_Bound (Constr));
+               Require_Static (High_Bound (Constr));
+
+            when N_Attribute_Reference =>
+               Require_Static (Type_Low_Bound  (Etype (Prefix (Constr))));
+               Require_Static (Type_High_Bound (Etype (Prefix (Constr))));
+
+            when N_Range_Constraint =>
+               Check_Static_Constraint (Range_Expression (Constr));
+
+            when N_Index_Or_Discriminant_Constraint =>
+               declare
+                  IDC : Entity_Id := First (Constraints (Constr));
+
+               begin
+                  while Present (IDC) loop
+                     Check_Static_Constraint (IDC);
+                     Next (IDC);
+                  end loop;
+               end;
+
+            when others =>
+               null;
+         end case;
+      end Check_Static_Constraint;
+
+      --------------------------------------
+      -- Check_Valid_Configuration_Pragma --
+      --------------------------------------
+
+      --  A configuration pragma must appear in the context clause of
+      --  a compilation unit, at the start of the list (i.e. only other
+      --  pragmas may precede it).
+
+      procedure Check_Valid_Configuration_Pragma is
+      begin
+         if not Is_Configuration_Pragma then
+            Error_Pragma ("incorrect placement for configuration pragma%");
+         end if;
+      end Check_Valid_Configuration_Pragma;
+
+      -------------------------------------
+      -- Check_Valid_Library_Unit_Pragma --
+      -------------------------------------
+
+      procedure Check_Valid_Library_Unit_Pragma is
+         Plist       : List_Id;
+         Parent_Node : Node_Id;
+         Unit_Name   : Entity_Id;
+         Valid       : Boolean := True;
+         Unit_Kind   : Node_Kind;
+         Unit_Node   : Node_Id;
+         Sindex      : Source_File_Index;
+
+      begin
+         if not Is_List_Member (N) then
+            Pragma_Misplaced;
+            Valid := False;
+
+         else
+            Plist := List_Containing (N);
+            Parent_Node := Parent (Plist);
+
+            if Parent_Node = Empty then
+               Pragma_Misplaced;
+
+            --  Case of pragma appearing after a compilation unit. In this
+            --  case it must have an argument with the corresponding name
+            --  and must be part of the following pragmas of its parent.
+
+            elsif Nkind (Parent_Node) = N_Compilation_Unit_Aux then
+               if Plist /= Pragmas_After (Parent_Node) then
+                  Pragma_Misplaced;
+
+               elsif Arg_Count = 0 then
+                  Error_Pragma
+                    ("argument required if outside compilation unit");
+
+               else
+                  Check_No_Identifiers;
+                  Check_Arg_Count (1);
+                  Unit_Node := Unit (Parent (Parent_Node));
+                  Unit_Kind := Nkind (Unit_Node);
+
+                  Analyze (Expression (Arg1));
+
+                  if        Unit_Kind = N_Generic_Subprogram_Declaration
+                    or else Unit_Kind = N_Subprogram_Declaration
+                  then
+                     Unit_Name := Defining_Entity (Unit_Node);
+
+                  elsif     Unit_Kind = N_Function_Instantiation
+                    or else Unit_Kind = N_Package_Instantiation
+                    or else Unit_Kind = N_Procedure_Instantiation
+                  then
+                     Unit_Name := Defining_Entity (Unit_Node);
+
+                  else
+                     Unit_Name := Cunit_Entity (Current_Sem_Unit);
+                  end if;
+
+                  if Chars (Unit_Name) /=
+                     Chars (Entity (Expression (Arg1)))
+                  then
+                     Error_Pragma_Arg
+                       ("pragma% argument is not current unit name", Arg1);
+                  end if;
+
+                  if Ekind (Unit_Name) = E_Package
+                    and then Present (Renamed_Entity (Unit_Name))
+                  then
+                     Error_Pragma ("pragma% not allowed for renamed package");
+                  end if;
+               end if;
+
+            --  Pragma appears other than after a compilation unit
+
+            else
+               --  Here we check for the generic instantiation case and also
+               --  for the case of processing a generic formal package. We
+               --  detect these cases by noting that the Sloc on the node
+               --  does not belong to the current compilation unit.
+
+               Sindex := Source_Index (Current_Sem_Unit);
+
+               if Loc not in Source_First (Sindex) .. Source_Last (Sindex) then
+                  Rewrite (N, Make_Null_Statement (Loc));
+                  return;
+
+               --  If before first declaration, the pragma applies to the
+               --  enclosing unit, and the name if present must be this name.
+
+               elsif Is_Before_First_Decl (N, Plist) then
+                  Unit_Node := Unit_Declaration_Node (Current_Scope);
+                  Unit_Kind := Nkind (Unit_Node);
+
+                  if Nkind (Parent (Unit_Node)) /= N_Compilation_Unit then
+                     Pragma_Misplaced;
+
+                  elsif Unit_Kind = N_Subprogram_Body
+                    and then not Acts_As_Spec (Unit_Node)
+                  then
+                     Pragma_Misplaced;
+
+                  elsif Nkind (Parent_Node) = N_Package_Body then
+                     Pragma_Misplaced;
+
+                  elsif Nkind (Parent_Node) = N_Package_Specification
+                    and then Plist = Private_Declarations (Parent_Node)
+                  then
+                     Pragma_Misplaced;
+
+                  elsif (Nkind (Parent_Node) = N_Generic_Package_Declaration
+                          or else Nkind (Parent_Node)
+                            = N_Generic_Subprogram_Declaration)
+                    and then Plist = Generic_Formal_Declarations (Parent_Node)
+                  then
+                     Pragma_Misplaced;
+
+                  elsif Arg_Count > 0 then
+                     Analyze (Expression (Arg1));
+
+                     if Entity (Expression (Arg1)) /= Current_Scope then
+                        Error_Pragma_Arg
+                          ("name in pragma% must be enclosing unit", Arg1);
+                     end if;
+
+                  --  It is legal to have no argument in this context
+
+                  else
+                     return;
+                  end if;
+
+               --  Error if not before first declaration. This is because a
+               --  library unit pragma argument must be the name of a library
+               --  unit (RM 10.1.5(7)), but the only names permitted in this
+               --  context are (RM 10.1.5(6)) names of subprogram declarations,
+               --  generic subprogram declarations or generic instantiations.
+
+               else
+                  Error_Pragma
+                    ("pragma% misplaced, must be before first declaration");
+               end if;
+            end if;
+         end if;
+
+      end Check_Valid_Library_Unit_Pragma;
+
+      ------------------
+      -- Error_Pragma --
+      ------------------
+
+      procedure Error_Pragma (Msg : String) is
+      begin
+         Error_Msg_Name_1 := Chars (N);
+         Error_Msg_N (Msg, N);
+         raise Pragma_Exit;
+      end Error_Pragma;
+
+      ----------------------
+      -- Error_Pragma_Arg --
+      ----------------------
+
+      procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id) is
+      begin
+         Error_Msg_Name_1 := Chars (N);
+         Error_Msg_N (Msg, Get_Pragma_Arg (Arg));
+         raise Pragma_Exit;
+      end Error_Pragma_Arg;
+
+      procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id) is
+      begin
+         Error_Msg_Name_1 := Chars (N);
+         Error_Msg_N (Msg1, Get_Pragma_Arg (Arg));
+         Error_Pragma_Arg (Msg2, Arg);
+      end Error_Pragma_Arg;
+
+      ----------------------------
+      -- Error_Pragma_Arg_Ident --
+      ----------------------------
+
+      procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id) is
+      begin
+         Error_Msg_Name_1 := Chars (N);
+         Error_Msg_N (Msg, Arg);
+         raise Pragma_Exit;
+      end Error_Pragma_Arg_Ident;
+
+      ------------------------
+      -- Find_Lib_Unit_Name --
+      ------------------------
+
+      function Find_Lib_Unit_Name return Entity_Id is
+      begin
+         --  Return inner compilation unit entity, for case of nested
+         --  categorization pragmas. This happens in generic unit.
+
+         if Nkind (Parent (N)) = N_Package_Specification
+           and then Defining_Entity (Parent (N)) /= Current_Scope
+         then
+            return Defining_Entity (Parent (N));
+
+         else
+            return Current_Scope;
+         end if;
+      end Find_Lib_Unit_Name;
+
+      ----------------------------
+      -- Find_Program_Unit_Name --
+      ----------------------------
+
+      procedure Find_Program_Unit_Name (Id : Node_Id) is
+         Unit_Name : Entity_Id;
+         Unit_Kind : Node_Kind;
+         P         : constant Node_Id := Parent (N);
+
+      begin
+         if Nkind (P) = N_Compilation_Unit then
+            Unit_Kind := Nkind (Unit (P));
+
+            if Unit_Kind = N_Subprogram_Declaration
+              or else Unit_Kind = N_Package_Declaration
+              or else Unit_Kind in N_Generic_Declaration
+            then
+               Unit_Name := Defining_Entity (Unit (P));
+
+               if Chars (Id) = Chars (Unit_Name) then
+                  Set_Entity (Id, Unit_Name);
+                  Set_Etype (Id, Etype (Unit_Name));
+               else
+                  Set_Etype (Id, Any_Type);
+                  Error_Pragma
+                    ("cannot find program unit referenced by pragma%");
+               end if;
+
+            else
+               Set_Etype (Id, Any_Type);
+               Error_Pragma ("pragma% inapplicable to this unit");
+            end if;
+
+         else
+            Analyze (Id);
+         end if;
+
+      end Find_Program_Unit_Name;
+
+      -------------------------
+      -- Gather_Associations --
+      -------------------------
+
+      procedure Gather_Associations
+        (Names : Name_List;
+         Args  : out Args_List)
+      is
+         Arg : Node_Id;
+
+      begin
+         --  Initialize all parameters to Empty
+
+         for J in Args'Range loop
+            Args (J) := Empty;
+         end loop;
+
+         --  That's all we have to do if there are no argument associations
+
+         if No (Pragma_Argument_Associations (N)) then
+            return;
+         end if;
+
+         --  Otherwise first deal with any positional parameters present
+
+         Arg := First (Pragma_Argument_Associations (N));
+
+         for Index in Args'Range loop
+            exit when No (Arg) or else Chars (Arg) /= No_Name;
+            Args (Index) := Expression (Arg);
+            Next (Arg);
+         end loop;
+
+         --  Positional parameters all processed, if any left, then we
+         --  have too many positional parameters.
+
+         if Present (Arg) and then Chars (Arg) = No_Name then
+            Error_Pragma_Arg
+              ("too many positional associations for pragma%", Arg);
+         end if;
+
+         --  Process named parameters if any are present
+
+         while Present (Arg) loop
+            if Chars (Arg) = No_Name then
+               Error_Pragma_Arg
+                 ("positional association cannot follow named association",
+                  Arg);
+
+            else
+               for Index in Names'Range loop
+                  if Names (Index) = Chars (Arg) then
+                     if Present (Args (Index)) then
+                        Error_Pragma_Arg
+                          ("duplicate argument association for pragma%", Arg);
+                     else
+                        Args (Index) := Expression (Arg);
+                        exit;
+                     end if;
+                  end if;
+
+                  if Index = Names'Last then
+                     Error_Pragma_Arg_Ident
+                       ("pragma% does not allow & argument", Arg);
+                  end if;
+               end loop;
+            end if;
+
+            Next (Arg);
+         end loop;
+      end Gather_Associations;
+
+      --------------------
+      -- Get_Pragma_Arg --
+      --------------------
+
+      function Get_Pragma_Arg (Arg : Node_Id) return Node_Id is
+      begin
+         if Nkind (Arg) = N_Pragma_Argument_Association then
+            return Expression (Arg);
+         else
+            return Arg;
+         end if;
+      end Get_Pragma_Arg;
+
+      -----------------
+      -- GNAT_Pragma --
+      -----------------
+
+      procedure GNAT_Pragma is
+      begin
+         Check_Restriction (No_Implementation_Pragmas, N);
+      end GNAT_Pragma;
+
+      --------------------------
+      -- Is_Before_First_Decl --
+      --------------------------
+
+      function Is_Before_First_Decl
+        (Pragma_Node : Node_Id;
+         Decls       : List_Id)
+         return        Boolean
+      is
+         Item : Node_Id := First (Decls);
+
+      begin
+         --  Only other pragmas can come before this pragma
+
+         loop
+            if No (Item) or else Nkind (Item) /= N_Pragma then
+               return False;
+
+            elsif Item = Pragma_Node then
+               return True;
+            end if;
+
+            Next (Item);
+         end loop;
+
+      end Is_Before_First_Decl;
+
+      -----------------------------
+      -- Is_Configuration_Pragma --
+      -----------------------------
+
+      --  A configuration pragma must appear in the context clause of
+      --  a compilation unit, at the start of the list (i.e. only other
+      --  pragmas may precede it).
+
+      function Is_Configuration_Pragma return Boolean is
+         Lis : constant List_Id := List_Containing (N);
+         Par : constant Node_Id := Parent (N);
+         Prg : Node_Id;
+
+      begin
+         --  If no parent, then we are in the configuration pragma file,
+         --  so the placement is definitely appropriate.
+
+         if No (Par) then
+            return True;
+
+         --  Otherwise we must be in the context clause of a compilation unit
+         --  and the only thing allowed before us in the context list is more
+         --  configuration pragmas.
+
+         elsif Nkind (Par) = N_Compilation_Unit
+           and then Context_Items (Par) = Lis
+         then
+            Prg := First (Lis);
+
+            loop
+               if Prg = N then
+                  return True;
+               elsif Nkind (Prg) /= N_Pragma then
+                  return False;
+               end if;
+
+               Next (Prg);
+            end loop;
+
+         else
+            return False;
+         end if;
+
+      end Is_Configuration_Pragma;
+
+      ----------------------
+      -- Pragma_Misplaced --
+      ----------------------
+
+      procedure Pragma_Misplaced is
+      begin
+         Error_Pragma ("incorrect placement of pragma%");
+      end Pragma_Misplaced;
+
+      ------------------------------------
+      -- Process Atomic_Shared_Volatile --
+      ------------------------------------
+
+      procedure Process_Atomic_Shared_Volatile is
+         E_Id : Node_Id;
+         E    : Entity_Id;
+         D    : Node_Id;
+         K    : Node_Kind;
+
+      begin
+         GNAT_Pragma;
+         Check_Ada_83_Warning;
+         Check_No_Identifiers;
+         Check_Arg_Count (1);
+         Check_Arg_Is_Local_Name (Arg1);
+         E_Id := Expression (Arg1);
+
+         if Etype (E_Id) = Any_Type then
+            return;
+         end if;
+
+         E := Entity (E_Id);
+         D := Declaration_Node (E);
+         K := Nkind (D);
+
+         if Is_Type (E) then
+            if Rep_Item_Too_Early (E, N)
+                 or else
+               Rep_Item_Too_Late (E, N)
+            then
+               return;
+            else
+               Check_First_Subtype (Arg1);
+            end if;
+
+            if Prag_Id /= Pragma_Volatile then
+               Set_Is_Atomic (E);
+               Set_Is_Atomic (Underlying_Type (E));
+            end if;
+
+            Set_Is_Volatile (E);
+            Set_Is_Volatile (Underlying_Type (E));
+
+         elsif K = N_Object_Declaration
+           or else (K = N_Component_Declaration
+                     and then Original_Record_Component (E) = E)
+         then
+            if Rep_Item_Too_Late (E, N) then
+               return;
+            end if;
+
+            if Prag_Id /= Pragma_Volatile then
+               Set_Is_Atomic (E);
+            end if;
+
+            Set_Is_Volatile (E);
+
+         else
+            Error_Pragma_Arg
+              ("inappropriate entity for pragma%", Arg1);
+         end if;
+      end Process_Atomic_Shared_Volatile;
+
+      ------------------------
+      -- Process_Convention --
+      ------------------------
+
+      procedure Process_Convention
+        (C : out Convention_Id;
+         E : out Entity_Id)
+      is
+         Id        : Node_Id;
+         E1        : Entity_Id;
+         Comp_Unit : Unit_Number_Type;
+         Cname     : Name_Id;
+
+         procedure Set_Convention_From_Pragma (E : Entity_Id);
+         --  Set convention in entity E, and also flag that the entity has a
+         --  convention pragma. If entity is for a private or incomplete type,
+         --  also set convention and flag on underlying type. This procedure
+         --  also deals with the special case of C_Pass_By_Copy convention.
+
+         --------------------------------
+         -- Set_Convention_From_Pragma --
+         --------------------------------
+
+         procedure Set_Convention_From_Pragma (E : Entity_Id) is
+         begin
+            Set_Convention (E, C);
+            Set_Has_Convention_Pragma (E);
+
+            if Is_Incomplete_Or_Private_Type (E) then
+               Set_Convention            (Underlying_Type (E), C);
+               Set_Has_Convention_Pragma (Underlying_Type (E), True);
+            end if;
+
+            --  A class-wide type should inherit the convention of
+            --  the specific root type (although this isn't specified
+            --  clearly by the RM).
+
+            if Is_Type (E) and then Present (Class_Wide_Type (E)) then
+               Set_Convention (Class_Wide_Type (E), C);
+            end if;
+
+            --  If the entity is a record type, then check for special case
+            --  of C_Pass_By_Copy, which is treated the same as C except that
+            --  the special record flag is set. This convention is also only
+            --  permitted on record types (see AI95-00131).
+
+            if Cname = Name_C_Pass_By_Copy then
+               if Is_Record_Type (E) then
+                  Set_C_Pass_By_Copy (Base_Type (E));
+               elsif Is_Incomplete_Or_Private_Type (E)
+                 and then Is_Record_Type (Underlying_Type (E))
+               then
+                  Set_C_Pass_By_Copy (Base_Type (Underlying_Type (E)));
+               else
+                  Error_Pragma_Arg
+                    ("C_Pass_By_Copy convention allowed only for record type",
+                     Arg2);
+               end if;
+            end if;
+
+            --  If the entity is a derived boolean type, check for the
+            --  special case of convention C, C++, or Fortran, where we
+            --  consider any nonzero value to represent true.
+
+            if Is_Discrete_Type (E)
+              and then Root_Type (Etype (E)) = Standard_Boolean
+              and then
+                (C = Convention_C
+                   or else
+                 C = Convention_CPP
+                   or else
+                 C = Convention_Fortran)
+            then
+               Set_Nonzero_Is_True (Base_Type (E));
+            end if;
+         end Set_Convention_From_Pragma;
+
+      --  Start of processing for Process_Convention
+
+      begin
+         Check_At_Least_N_Arguments (2);
+         Check_Arg_Is_Identifier (Arg1);
+         Check_Optional_Identifier (Arg1, Name_Convention);
+         Cname := Chars (Expression (Arg1));
+
+         --  C_Pass_By_Copy is treated as a synonym for convention C
+         --  (this is tested again below to set the critical flag)
+
+         if Cname = Name_C_Pass_By_Copy then
+            C := Convention_C;
+
+         --  Otherwise we must have something in the standard convention list
+
+         elsif Is_Convention_Name (Cname) then
+            C := Get_Convention_Id (Chars (Expression (Arg1)));
+
+         --  In DEC VMS, it seems that there is an undocumented feature
+         --  that any unrecognized convention is treated as the default,
+         --  which for us is convention C. It does not seem so terrible
+         --  to do this unconditionally, silently in the VMS case, and
+         --  with a warning in the non-VMS case.
+
+         else
+            if not OpenVMS_On_Target then
+               Error_Msg_N
+                 ("?unrecognized convention name, C assumed",
+                  Expression (Arg1));
+            end if;
+
+            C := Convention_C;
+         end if;
+
+         Check_Arg_Is_Local_Name (Arg2);
+         Check_Optional_Identifier (Arg2, Name_Entity);
+
+         Id := Expression (Arg2);
+         Analyze (Id);
+
+         if not Is_Entity_Name (Id) then
+            Error_Pragma_Arg ("entity name required", Arg2);
+         end if;
+
+         E := Entity (Id);
+
+         --  Go to renamed subprogram if present, since convention applies
+         --  to the actual renamed entity, not to the renaming entity.
+
+         if Is_Subprogram (E)
+           and then Present (Alias (E))
+           and then Nkind (Parent (Declaration_Node (E))) =
+                      N_Subprogram_Renaming_Declaration
+         then
+            E := Alias (E);
+         end if;
+
+         --  Check that we not applying this to a specless body
+
+         if Is_Subprogram (E)
+           and then Nkind (Parent (Declaration_Node (E))) = N_Subprogram_Body
+         then
+            Error_Pragma
+              ("pragma% requires separate spec and must come before body");
+         end if;
+
+         --  Check that we are not applying this to a named constant
+
+         if Ekind (E) = E_Named_Integer
+              or else
+            Ekind (E) = E_Named_Real
+         then
+            Error_Msg_Name_1 := Chars (N);
+            Error_Msg_N
+              ("cannot apply pragma% to named constant!",
+               Get_Pragma_Arg (Arg2));
+            Error_Pragma_Arg
+              ("\supply appropriate type for&!", Arg2);
+         end if;
+
+         if Etype (E) = Any_Type
+           or else Rep_Item_Too_Early (E, N)
+         then
+            raise Pragma_Exit;
+         else
+            E := Underlying_Type (E);
+         end if;
+
+         if Rep_Item_Too_Late (E, N) then
+            raise Pragma_Exit;
+         end if;
+
+         if Has_Convention_Pragma (E) then
+            Error_Pragma_Arg
+              ("at most one Convention/Export/Import pragma is allowed", Arg2);
+
+         elsif Convention (E) = Convention_Protected
+           or else Ekind (Scope (E)) = E_Protected_Type
+         then
+            Error_Pragma_Arg
+              ("a protected operation cannot be given a different convention",
+                Arg2);
+         end if;
+
+         --  For Intrinsic, a subprogram is required
+
+         if C = Convention_Intrinsic
+           and then not Is_Subprogram (E)
+           and then not Is_Generic_Subprogram (E)
+         then
+            Error_Pragma_Arg
+              ("second argument of pragma% must be a subprogram", Arg2);
+         end if;
+
+         --  For Stdcall, a subprogram, variable or subprogram type is required
+
+         if C = Convention_Stdcall
+           and then not Is_Subprogram (E)
+           and then not Is_Generic_Subprogram (E)
+           and then Ekind (E) /= E_Variable
+           and then not
+             (Is_Access_Type (E)
+              and then Ekind (Designated_Type (E)) = E_Subprogram_Type)
+         then
+            Error_Pragma_Arg
+              ("second argument of pragma% must be subprogram (type)",
+               Arg2);
+         end if;
+
+         if not Is_Subprogram (E)
+           and then not Is_Generic_Subprogram (E)
+         then
+            Set_Convention_From_Pragma (E);
+
+            if Is_Type (E) then
+
+               Check_First_Subtype (Arg2);
+               Set_Convention_From_Pragma (Base_Type (E));
+
+               --  For subprograms, we must set the convention on the
+               --  internally generated directly designated type as well.
+
+               if Ekind (E) = E_Access_Subprogram_Type then
+                  Set_Convention_From_Pragma (Directly_Designated_Type (E));
+               end if;
+            end if;
+
+         --  For the subprogram case, set proper convention for all homonyms
+         --  in same compilation unit.
+         --  Is the test of compilation unit really necessary ???
+         --  What about subprogram renamings here???
+
+         else
+            Comp_Unit := Get_Source_Unit (E);
+            Set_Convention_From_Pragma (E);
+
+            E1 := E;
+            loop
+               E1 := Homonym (E1);
+               exit when No (E1) or else Scope (E1) /= Current_Scope;
+
+               --  Note: below we are missing a check for Rep_Item_Too_Late.
+               --  That is deliberate, we cannot chain the rep item on more
+               --  than one Rep_Item chain, to be fixed later ???
+
+               if Comp_Unit = Get_Source_Unit (E1) then
+                  Set_Convention_From_Pragma (E1);
+               end if;
+            end loop;
+         end if;
+
+      end Process_Convention;
+
+      -----------------------------------------------------
+      -- Process_Extended_Import_Export_Exception_Pragma --
+      -----------------------------------------------------
+
+      procedure Process_Extended_Import_Export_Exception_Pragma
+        (Arg_Internal : Node_Id;
+         Arg_External : Node_Id;
+         Arg_Form     : Node_Id;
+         Arg_Code     : Node_Id)
+      is
+         Def_Id   : Entity_Id;
+         Code_Val : Uint;
+
+      begin
+         Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
+         Def_Id := Entity (Arg_Internal);
+
+         if Ekind (Def_Id) /= E_Exception then
+            Error_Pragma_Arg
+              ("pragma% must refer to declared exception", Arg_Internal);
+         end if;
+
+         Set_Extended_Import_Export_External_Name (Def_Id, Arg_External);
+
+         if Present (Arg_Form) then
+            Check_Arg_Is_One_Of (Arg_Form, Name_Ada, Name_VMS);
+         end if;
+
+         if Present (Arg_Form)
+           and then Chars (Arg_Form) = Name_Ada
+         then
+            null;
+         else
+            Set_Is_VMS_Exception (Def_Id);
+            Set_Exception_Code (Def_Id, No_Uint);
+         end if;
+
+         if Present (Arg_Code) then
+            if not Is_VMS_Exception (Def_Id) then
+               Error_Pragma_Arg
+                 ("Code option for pragma% not allowed for Ada case",
+                  Arg_Code);
+            end if;
+
+            Check_Arg_Is_Static_Expression (Arg_Code, Any_Integer);
+            Code_Val := Expr_Value (Arg_Code);
+
+            if not UI_Is_In_Int_Range (Code_Val) then
+               Error_Pragma_Arg
+                 ("Code option for pragma% must be in 32-bit range",
+                  Arg_Code);
+
+            else
+               Set_Exception_Code (Def_Id, Code_Val);
+            end if;
+         end if;
+
+      end Process_Extended_Import_Export_Exception_Pragma;
+
+      -------------------------------------------------
+      -- Process_Extended_Import_Export_Internal_Arg --
+      -------------------------------------------------
+
+      procedure Process_Extended_Import_Export_Internal_Arg
+        (Arg_Internal : Node_Id := Empty)
+      is
+      begin
+         GNAT_Pragma;
+
+         if No (Arg_Internal) then
+            Error_Pragma ("Internal parameter required for pragma%");
+         end if;
+
+         if Nkind (Arg_Internal) = N_Identifier then
+            null;
+
+         elsif Nkind (Arg_Internal) = N_Operator_Symbol
+           and then (Prag_Id = Pragma_Import_Function
+                       or else
+                     Prag_Id = Pragma_Export_Function)
+         then
+            null;
+
+         else
+            Error_Pragma_Arg
+              ("wrong form for Internal parameter for pragma%", Arg_Internal);
+         end if;
+
+         Check_Arg_Is_Local_Name (Arg_Internal);
+
+      end Process_Extended_Import_Export_Internal_Arg;
+
+      --------------------------------------------------
+      -- Process_Extended_Import_Export_Object_Pragma --
+      --------------------------------------------------
+
+      procedure Process_Extended_Import_Export_Object_Pragma
+        (Arg_Internal : Node_Id;
+         Arg_External : Node_Id;
+         Arg_Size     : Node_Id)
+      is
+         Def_Id   : Entity_Id;
+
+      begin
+         Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
+         Def_Id := Entity (Arg_Internal);
+
+         if Ekind (Def_Id) /= E_Constant
+           and then Ekind (Def_Id) /= E_Variable
+         then
+            Error_Pragma_Arg
+              ("pragma% must designate an object", Arg_Internal);
+         end if;
+
+         if Is_Psected (Def_Id) then
+            Error_Pragma_Arg
+              ("previous Psect_Object applies, pragma % not permitted",
+               Arg_Internal);
+         end if;
+
+         if Rep_Item_Too_Late (Def_Id, N) then
+            raise Pragma_Exit;
+         end if;
+
+         Set_Extended_Import_Export_External_Name (Def_Id, Arg_External);
+
+         if Present (Arg_Size)
+           and then Nkind (Arg_Size) /= N_Identifier
+           and then Nkind (Arg_Size) /= N_String_Literal
+         then
+            Error_Pragma_Arg
+              ("pragma% Size argument must be identifier or string literal",
+               Arg_Size);
+         end if;
+
+         --  Export_Object case
+
+         if Prag_Id = Pragma_Export_Object then
+
+            if not Is_Library_Level_Entity (Def_Id) then
+               Error_Pragma_Arg
+                 ("argument for pragma% must be library level entity",
+                  Arg_Internal);
+            end if;
+
+            if Ekind (Current_Scope) = E_Generic_Package then
+               Error_Pragma ("pragma& cannot appear in a generic unit");
+            end if;
+
+            if not Size_Known_At_Compile_Time (Etype (Def_Id)) then
+               Error_Pragma_Arg
+                 ("exported object must have compile time known size",
+                  Arg_Internal);
+            end if;
+
+            if Is_Exported (Def_Id) then
+               Error_Msg_N
+                 ("?duplicate Export_Object pragma", N);
+            else
+               Set_Exported (Def_Id, Arg_Internal);
+            end if;
+
+         --  Import_Object case
+
+         else
+            if Is_Concurrent_Type (Etype (Def_Id)) then
+               Error_Pragma_Arg
+                 ("cannot use pragma% for task/protected object",
+                  Arg_Internal);
+            end if;
+
+            if Ekind (Def_Id) = E_Constant then
+               Error_Pragma_Arg
+                 ("cannot import a constant", Arg_Internal);
+            end if;
+
+            if Has_Discriminants (Etype (Def_Id)) then
+               Error_Msg_N
+                 ("imported value must be initialized?", Arg_Internal);
+            end if;
+
+            if Is_Access_Type (Etype (Def_Id)) then
+               Error_Pragma_Arg
+                 ("cannot import object of an access type?", Arg_Internal);
+            end if;
+
+            if Is_Imported (Def_Id) then
+               Error_Msg_N
+                 ("?duplicate Import_Object pragma", N);
+            else
+               Set_Imported (Def_Id);
+            end if;
+         end if;
+
+      end Process_Extended_Import_Export_Object_Pragma;
+
+      ------------------------------------------------------
+      -- Process_Extended_Import_Export_Subprogram_Pragma --
+      ------------------------------------------------------
+
+      procedure Process_Extended_Import_Export_Subprogram_Pragma
+        (Arg_Internal                 : Node_Id;
+         Arg_External                 : Node_Id;
+         Arg_Parameter_Types          : Node_Id;
+         Arg_Result_Type              : Node_Id := Empty;
+         Arg_Mechanism                : Node_Id;
+         Arg_Result_Mechanism         : Node_Id := Empty;
+         Arg_First_Optional_Parameter : Node_Id := Empty)
+      is
+         Ent       : Entity_Id;
+         Def_Id    : Entity_Id;
+         Hom_Id    : Entity_Id;
+         Formal    : Entity_Id;
+         Ambiguous : Boolean;
+         Match     : Boolean;
+         Dval      : Node_Id;
+
+         function Same_Base_Type (Ptype, Formal : Entity_Id) return Boolean;
+         --  Determines if Ptype references the type of Formal. Note that
+         --  only the base types need to match according to the spec.
+
+         function Same_Base_Type (Ptype, Formal : Entity_Id) return Boolean is
+         begin
+            Find_Type (Ptype);
+
+            if not Is_Entity_Name (Ptype)
+              or else Entity (Ptype) = Any_Type
+            then
+               raise Pragma_Exit;
+            end if;
+
+            return Base_Type (Entity (Ptype)) = Base_Type (Etype (Formal));
+         end Same_Base_Type;
+
+      --  Start of processing for
+      --  Process_Extended_Import_Export_Subprogram_Pragma
+
+      begin
+         Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
+         Hom_Id := Entity (Arg_Internal);
+         Ent := Empty;
+         Ambiguous := False;
+
+         --  Loop through homonyms (overloadings) of Hom_Id
+
+         while Present (Hom_Id) loop
+            Def_Id := Get_Base_Subprogram (Hom_Id);
+
+            --  We need a subprogram in the current scope
+
+            if not Is_Subprogram (Def_Id)
+              or else Scope (Def_Id) /= Current_Scope
+            then
+               null;
+
+            else
+               Match := True;
+
+               --  Pragma cannot apply to subprogram body
+
+               if Is_Subprogram (Def_Id)
+                 and then
+                   Nkind (Parent
+                     (Declaration_Node (Def_Id))) = N_Subprogram_Body
+               then
+                  Error_Pragma
+                    ("pragma% requires separate spec"
+                      & " and must come before body");
+               end if;
+
+               --  Test result type if given, note that the result type
+               --  parameter can only be present for the function cases.
+
+               if Present (Arg_Result_Type)
+                 and then not Same_Base_Type (Arg_Result_Type, Def_Id)
+               then
+                  Match := False;
+
+               --  Test parameter types if given. Note that this parameter
+               --  has not been analyzed (and must not be, since it is
+               --  semantic nonsense), so we get it as the parser left it.
+
+               elsif Present (Arg_Parameter_Types) then
+                  Check_Matching_Types : declare
+                     Formal : Entity_Id;
+                     Ptype  : Node_Id;
+
+                  begin
+                     Formal := First_Formal (Def_Id);
+
+                     if Nkind (Arg_Parameter_Types) = N_Null then
+                        if Present (Formal) then
+                           Match := False;
+                        end if;
+
+                     --  A list of one type, e.g. (List) is parsed as
+                     --  a parenthesized expression.
+
+                     elsif Nkind (Arg_Parameter_Types) /= N_Aggregate
+                       and then Paren_Count (Arg_Parameter_Types) = 1
+                     then
+                        if No (Formal)
+                          or else Present (Next_Formal (Formal))
+                        then
+                           Match := False;
+                        else
+                           Match :=
+                             Same_Base_Type (Arg_Parameter_Types, Formal);
+                        end if;
+
+                     --  A list of more than one type is parsed as a aggregate
+
+                     elsif Nkind (Arg_Parameter_Types) = N_Aggregate
+                       and then Paren_Count (Arg_Parameter_Types) = 0
+                     then
+                        Ptype := First (Expressions (Arg_Parameter_Types));
+
+                        while Present (Ptype) or else Present (Formal) loop
+                           if No (Ptype)
+                             or else No (Formal)
+                             or else not Same_Base_Type (Ptype, Formal)
+                           then
+                              Match := False;
+                              exit;
+                           else
+                              Next_Formal (Formal);
+                              Next (Ptype);
+                           end if;
+                        end loop;
+
+                     --  Anything else is of the wrong form
+
+                     else
+                        Error_Pragma_Arg
+                          ("wrong form for Parameter_Types parameter",
+                           Arg_Parameter_Types);
+                     end if;
+                  end Check_Matching_Types;
+               end if;
+
+               --  Match is now False if the entry we found did not match
+               --  either a supplied Parameter_Types or Result_Types argument
+
+               if Match then
+                  if No (Ent) then
+                     Ent := Def_Id;
+
+                  --  Ambiguous case, the flag Ambiguous shows if we already
+                  --  detected this and output the initial messages.
+
+                  else
+                     if not Ambiguous then
+                        Ambiguous := True;
+                        Error_Msg_Name_1 := Chars (N);
+                        Error_Msg_N
+                          ("pragma% does not uniquely identify subprogram!",
+                           N);
+                        Error_Msg_Sloc := Sloc (Ent);
+                        Error_Msg_N ("matching subprogram #!", N);
+                        Ent := Empty;
+                     end if;
+
+                     Error_Msg_Sloc := Sloc (Def_Id);
+                     Error_Msg_N ("matching subprogram #!", N);
+                  end if;
+               end if;
+            end if;
+
+            Hom_Id := Homonym (Hom_Id);
+         end loop;
+
+         --  See if we found an entry
+
+         if No (Ent) then
+            if not Ambiguous then
+               if Is_Generic_Subprogram (Entity (Arg_Internal)) then
+                  Error_Pragma
+                    ("pragma% cannot be given for generic subprogram");
+
+               else
+                  Error_Pragma
+                    ("pragma% does not identify local subprogram");
+               end if;
+            end if;
+
+            return;
+         end if;
+
+         --  Import pragmas must be be for imported entities
+
+         if (Prag_Id = Pragma_Import_Function
+               or else
+             Prag_Id = Pragma_Import_Procedure
+               or else
+             Prag_Id = Pragma_Import_Valued_Procedure)
+         then
+            if not Is_Imported (Ent) then
+               Error_Pragma
+                 ("pragma Import or Interface must precede pragma%");
+            end if;
+
+         --  For the Export cases, the pragma Export is sufficient to set
+         --  the entity as exported, if it is not exported already. We
+         --  leave the default Ada convention in this case.
+
+         else
+            Set_Exported (Ent, Arg_Internal);
+         end if;
+
+         --  Special processing for Valued_Procedure cases
+
+         if Prag_Id = Pragma_Import_Valued_Procedure
+           or else
+            Prag_Id = Pragma_Export_Valued_Procedure
+         then
+            Formal := First_Formal (Ent);
+
+            if No (Formal) then
+               Error_Pragma
+                 ("at least one parameter required for pragma%");
+
+            elsif Ekind (Formal) /= E_Out_Parameter then
+               Error_Pragma
+                 ("first parameter must have mode out for pragma%");
+
+            else
+               Set_Is_Valued_Procedure (Ent);
+            end if;
+         end if;
+
+         Set_Extended_Import_Export_External_Name (Ent, Arg_External);
+
+         --  Process Result_Mechanism argument if present. We have already
+         --  checked that this is only allowed for the function case.
+
+         if Present (Arg_Result_Mechanism) then
+            Set_Mechanism_Value (Ent, Arg_Result_Mechanism);
+         end if;
+
+         --  Process Mechanism parameter if present. Note that this parameter
+         --  is not analyzed, and must not be analyzed since it is semantic
+         --  nonsense, so we get it in exactly as the parser left it.
+
+         if Present (Arg_Mechanism) then
+
+            declare
+               Formal : Entity_Id;
+               Massoc : Node_Id;
+               Mname  : Node_Id;
+               Choice : Node_Id;
+
+            begin
+               --  A single mechanism association without a formal parameter
+               --  name is parsed as a parenthesized expression. All other
+               --  cases are parsed as aggregates, so we rewrite the single
+               --  parameter case as an aggregate for consistency.
+
+               if Nkind (Arg_Mechanism) /= N_Aggregate
+                 and then Paren_Count (Arg_Mechanism) = 1
+               then
+                  Rewrite (Arg_Mechanism,
+                    Make_Aggregate (Sloc (Arg_Mechanism),
+                      Expressions => New_List (
+                        Relocate_Node (Arg_Mechanism))));
+               end if;
+
+               --  Case of only mechanism name given, applies to all formals
+
+               if Nkind (Arg_Mechanism) /= N_Aggregate then
+                  Formal := First_Formal (Ent);
+                  while Present (Formal) loop
+                     Set_Mechanism_Value (Formal, Arg_Mechanism);
+                     Next_Formal (Formal);
+                  end loop;
+
+               --  Case of list of mechanism associations given
+
+               else
+                  if Null_Record_Present (Arg_Mechanism) then
+                     Error_Pragma_Arg
+                       ("inappropriate form for Mechanism parameter",
+                        Arg_Mechanism);
+                  end if;
+
+                  --  Deal with positional ones first
+
+                  Formal := First_Formal (Ent);
+                  if Present (Expressions (Arg_Mechanism)) then
+                     Mname := First (Expressions (Arg_Mechanism));
+
+                     while Present (Mname) loop
+                        if No (Formal) then
+                           Error_Pragma_Arg
+                             ("too many mechanism associations", Mname);
+                        end if;
+
+                        Set_Mechanism_Value (Formal, Mname);
+                        Next_Formal (Formal);
+                        Next (Mname);
+                     end loop;
+                  end if;
+
+                  --  Deal with named entries
+
+                  if Present (Component_Associations (Arg_Mechanism)) then
+                     Massoc := First (Component_Associations (Arg_Mechanism));
+
+                     while Present (Massoc) loop
+                        Choice := First (Choices (Massoc));
+
+                        if Nkind (Choice) /= N_Identifier
+                          or else Present (Next (Choice))
+                        then
+                           Error_Pragma_Arg
+                             ("incorrect form for mechanism association",
+                              Massoc);
+                        end if;
+
+                        Formal := First_Formal (Ent);
+                        loop
+                           if No (Formal) then
+                              Error_Pragma_Arg
+                                ("parameter name & not present", Choice);
+                           end if;
+
+                           if Chars (Choice) = Chars (Formal) then
+                              Set_Mechanism_Value
+                                (Formal, Expression (Massoc));
+                              exit;
+                           end if;
+
+                           Next_Formal (Formal);
+                        end loop;
+
+                        Next (Massoc);
+                     end loop;
+                  end if;
+               end if;
+            end;
+         end if;
+
+         --  Process First_Optional_Parameter argument if present. We have
+         --  already checked that this is only allowed for the Import case.
+
+         if Present (Arg_First_Optional_Parameter) then
+            if Nkind (Arg_First_Optional_Parameter) /= N_Identifier then
+               Error_Pragma_Arg
+                 ("first optional parameter must be formal parameter name",
+                  Arg_First_Optional_Parameter);
+            end if;
+
+            Formal := First_Formal (Ent);
+            loop
+               if No (Formal) then
+                  Error_Pragma_Arg
+                    ("specified formal parameter& not found",
+                     Arg_First_Optional_Parameter);
+               end if;
+
+               exit when Chars (Formal) =
+                         Chars (Arg_First_Optional_Parameter);
+
+               Next_Formal (Formal);
+            end loop;
+
+            Set_First_Optional_Parameter (Ent, Formal);
+
+            --  Check specified and all remaining formals have right form
+
+            while Present (Formal) loop
+               if Ekind (Formal) /= E_In_Parameter then
+                  Error_Msg_NE
+                    ("optional formal& is not of mode in!",
+                     Arg_First_Optional_Parameter, Formal);
+
+               else
+                  Dval := Default_Value (Formal);
+
+                  if not Present (Dval) then
+                     Error_Msg_NE
+                       ("optional formal& does not have default value!",
+                        Arg_First_Optional_Parameter, Formal);
+
+                  elsif Compile_Time_Known_Value_Or_Aggr (Dval) then
+                     null;
+
+                  else
+                     Error_Msg_NE
+                       ("default value for optional formal& is non-static!",
+                        Arg_First_Optional_Parameter, Formal);
+                  end if;
+               end if;
+
+               Set_Is_Optional_Parameter (Formal);
+               Next_Formal (Formal);
+            end loop;
+         end if;
+
+      end Process_Extended_Import_Export_Subprogram_Pragma;
+
+      --------------------------
+      -- Process_Generic_List --
+      --------------------------
+
+      procedure Process_Generic_List is
+         Arg : Node_Id;
+         Exp : Node_Id;
+
+      begin
+         GNAT_Pragma;
+         Check_No_Identifiers;
+         Check_At_Least_N_Arguments (1);
+
+         Arg := Arg1;
+         while Present (Arg) loop
+            Exp := Expression (Arg);
+            Analyze (Exp);
+
+            if not Is_Entity_Name (Exp)
+              or else
+                (not Is_Generic_Instance (Entity (Exp))
+                  and then
+                 not Is_Generic_Unit (Entity (Exp)))
+            then
+               Error_Pragma_Arg
+                 ("pragma% argument must be name of generic unit/instance",
+                  Arg);
+            end if;
+
+            Next (Arg);
+         end loop;
+      end Process_Generic_List;
+
+      ---------------------------------
+      -- Process_Import_Or_Interface --
+      ---------------------------------
+
+      procedure Process_Import_Or_Interface is
+         C      : Convention_Id;
+         Def_Id : Entity_Id;
+         Hom_Id : Entity_Id;
+
+      begin
+         Process_Convention (C, Def_Id);
+         Kill_Size_Check_Code (Def_Id);
+         Note_Possible_Modification (Expression (Arg2));
+
+         if Ekind (Def_Id) = E_Variable
+              or else
+            Ekind (Def_Id) = E_Constant
+         then
+            --  User initialization is not allowed for imported object, but
+            --  the object declaration may contain a default initialization,
+            --  that will be discarded.
+
+            if Present (Expression (Parent (Def_Id)))
+               and then Comes_From_Source (Expression (Parent (Def_Id)))
+            then
+               Error_Msg_Sloc := Sloc (Def_Id);
+               Error_Pragma_Arg
+                 ("no initialization allowed for declaration of& #",
+                  "\imported entities cannot be initialized ('R'M' 'B.1(24))",
+                  Arg2);
+
+            else
+               Set_Imported (Def_Id);
+               Set_Is_Public (Def_Id);
+               Process_Interface_Name (Def_Id, Arg3, Arg4);
+            end if;
+
+         elsif Is_Subprogram (Def_Id)
+           or else Is_Generic_Subprogram (Def_Id)
+         then
+            --  If the name is overloaded, pragma applies to all of the
+            --  denoted entities in the same declarative part.
+
+            Hom_Id := Def_Id;
+
+            while Present (Hom_Id) loop
+               Def_Id := Get_Base_Subprogram (Hom_Id);
+
+               --  Ignore inherited subprograms because the pragma will
+               --  apply to the parent operation, which is the one called.
+
+               if Is_Overloadable (Def_Id)
+                 and then Present (Alias (Def_Id))
+               then
+                  null;
+
+               --  Verify that the homonym is in the same declarative
+               --  part (not just the same scope).
+
+               elsif Parent (Unit_Declaration_Node (Def_Id)) /= Parent (N)
+                 and then Nkind (Parent (N)) /= N_Compilation_Unit_Aux
+               then
+                  exit;
+
+               else
+                  Set_Imported (Def_Id);
+
+                  --  If Import intrinsic, set intrinsic flag
+                  --  and verify that it is known as such.
+
+                  if C = Convention_Intrinsic then
+                     Set_Is_Intrinsic_Subprogram (Def_Id);
+                     Check_Intrinsic_Subprogram
+                       (Def_Id, Expression (Arg2));
+                  end if;
+
+                  --  All interfaced procedures need an external
+                  --  symbol created for them since they are
+                  --  always referenced from another object file.
+
+                  Set_Is_Public (Def_Id);
+                  Set_Has_Completion (Def_Id);
+                  Process_Interface_Name (Def_Id, Arg3, Arg4);
+               end if;
+
+               if Is_Compilation_Unit (Hom_Id) then
+
+                  --  Its possible homonyms are not affected by the pragma.
+                  --  Such homonyms might be present in the context of other
+                  --  units being compiled.
+
+                  exit;
+
+               else
+                  Hom_Id := Homonym (Hom_Id);
+               end if;
+            end loop;
+
+         --  When the convention is Java, we also allow Import to be given
+         --  for packages, exceptions, and record components.
+
+         elsif C = Convention_Java
+           and then (Ekind (Def_Id) = E_Package
+                     or else Ekind (Def_Id) = E_Exception
+                     or else Nkind (Parent (Def_Id)) = N_Component_Declaration)
+         then
+            Set_Imported (Def_Id);
+            Set_Is_Public (Def_Id);
+            Process_Interface_Name (Def_Id, Arg3, Arg4);
+
+         else
+            Error_Pragma_Arg
+              ("second argument of pragma% must be object or subprogram",
+               Arg2);
+         end if;
+
+         --  If this pragma applies to a compilation unit, then the unit,
+         --  which is a subprogram, does not require (or allow) a body.
+         --  We also do not need to elaborate imported procedures.
+
+         if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
+            declare
+               Cunit : constant Node_Id := Parent (Parent (N));
+
+            begin
+               Set_Body_Required    (Cunit, False);
+            end;
+         end if;
+
+      end Process_Import_Or_Interface;
+
+      --------------------
+      -- Process_Inline --
+      --------------------
+
+      procedure Process_Inline (Active : Boolean) is
+         Assoc   : Node_Id;
+         Decl    : Node_Id;
+         Subp_Id : Node_Id;
+         Subp    : Entity_Id;
+         Applies : Boolean;
+
+         procedure Make_Inline (Subp : Entity_Id);
+         --  Subp is the defining unit name of the subprogram
+         --  declaration. Set the flag, as well as the flag in the
+         --  corresponding body, if there is one present.
+
+         procedure Set_Inline_Flags (Subp : Entity_Id);
+         --  Sets Is_Inlined and Has_Pragma_Inline flags for Subp
+
+         -----------------
+         -- Make_Inline --
+         -----------------
+
+         procedure Make_Inline (Subp : Entity_Id) is
+            Kind       : Entity_Kind := Ekind (Subp);
+            Inner_Subp : Entity_Id   := Subp;
+
+         begin
+            if Etype (Subp) = Any_Type then
+               return;
+
+            --  Here we have a candidate for inlining, but we must exclude
+            --  derived operations. Otherwise we will end up trying to
+            --  inline a phantom declaration, and the result would be to
+            --  drag in a body which has no direct inlining associated with
+            --  it. That would not only be inefficient but would also result
+            --  in the backend doing cross-unit inlining in cases where it
+            --  was definitely inappropriate to do so.
+
+            --  However, a simple Comes_From_Source test is insufficient,
+            --  since we do want to allow inlining of generic instances,
+            --  which also do not come from source. Predefined operators do
+            --  not come from source but are not inlineable either.
+
+            elsif not Comes_From_Source (Subp)
+              and then not Is_Generic_Instance (Subp)
+              and then Scope (Subp) /= Standard_Standard
+            then
+               Applies := True;
+               return;
+
+            --  The referenced entity must either be the enclosing entity,
+            --  or an entity declared within the current open scope.
+
+            elsif Present (Scope (Subp))
+              and then Scope (Subp) /= Current_Scope
+              and then Subp /= Current_Scope
+            then
+               Error_Pragma_Arg
+                 ("argument of% must be entity in current scope", Assoc);
+               return;
+            end if;
+
+            --  Processing for procedure, operator or function.
+            --  If subprogram is aliased (as for an instance) indicate
+            --  that the renamed entity is inlined.
+
+            if Kind = E_Procedure
+              or else Kind = E_Function
+              or else Kind = E_Operator
+            then
+               while Present (Alias (Inner_Subp)) loop
+                  Inner_Subp := Alias (Inner_Subp);
+               end loop;
+
+               Set_Inline_Flags (Inner_Subp);
+
+               Decl := Parent (Parent (Inner_Subp));
+
+               if Nkind (Decl) = N_Subprogram_Declaration
+                 and then Present (Corresponding_Body (Decl))
+               then
+                  Set_Inline_Flags (Corresponding_Body (Decl));
+               end if;
+
+               Applies := True;
+
+            --  For a generic subprogram set flag as well, for use at
+            --  the point of instantiation, to determine whether the
+            --  body should be generated.
+
+            elsif Kind = E_Generic_Procedure
+              or else Kind = E_Generic_Function
+            then
+               Set_Inline_Flags (Subp);
+               Applies := True;
+
+            --  Literals are by definition inlined.
+
+            elsif Kind = E_Enumeration_Literal then
+               null;
+
+            --  Anything else is an error
+
+            else
+               Error_Pragma_Arg
+                 ("expect subprogram name for pragma%", Assoc);
+            end if;
+         end Make_Inline;
+
+         ----------------------
+         -- Set_Inline_Flags --
+         ----------------------
+
+         procedure Set_Inline_Flags (Subp : Entity_Id) is
+         begin
+            if Active then
+               Set_Is_Inlined (Subp, True);
+            end if;
+
+            if not Has_Pragma_Inline (Subp) then
+               Set_Has_Pragma_Inline (Subp);
+               Set_Next_Rep_Item (N, First_Rep_Item (Subp));
+               Set_First_Rep_Item (Subp, N);
+            end if;
+         end Set_Inline_Flags;
+
+      --  Start of processing for Process_Inline
+
+      begin
+         Check_No_Identifiers;
+         Check_At_Least_N_Arguments (1);
+
+         if Active then
+            Inline_Processing_Required := True;
+         end if;
+
+         Assoc := Arg1;
+         while Present (Assoc) loop
+            Subp_Id := Expression (Assoc);
+            Analyze (Subp_Id);
+            Applies := False;
+
+            if Is_Entity_Name (Subp_Id) then
+               Subp := Entity (Subp_Id);
+
+               if Subp = Any_Id then
+                  Applies := True;
+
+               else
+                  Make_Inline (Subp);
+
+                  while Present (Homonym (Subp))
+                    and then Scope (Homonym (Subp)) = Current_Scope
+                  loop
+                     Make_Inline (Homonym (Subp));
+                     Subp := Homonym (Subp);
+                  end loop;
+               end if;
+            end if;
+
+            if not Applies then
+               Error_Pragma_Arg
+                 ("inappropriate argument for pragma%", Assoc);
+            end if;
+
+            Next (Assoc);
+         end loop;
+
+      end Process_Inline;
+
+      ----------------------------
+      -- Process_Interface_Name --
+      ----------------------------
+
+      procedure Process_Interface_Name
+        (Subprogram_Def : Entity_Id;
+         Ext_Arg        : Node_Id;
+         Link_Arg       : Node_Id)
+      is
+         Ext_Nam    : Node_Id;
+         Link_Nam   : Node_Id;
+         String_Val : String_Id;
+
+         procedure Check_Form_Of_Interface_Name (SN : Node_Id);
+         --  SN is a string literal node for an interface name. This routine
+         --  performs some minimal checks that the name is reasonable. In
+         --  particular that no spaces or other obviously incorrect characters
+         --  appear. This is only a warning, since any characters are allowed.
+
+         procedure Check_Form_Of_Interface_Name (SN : Node_Id) is
+            S  : constant String_Id := Strval (Expr_Value_S (SN));
+            SL : constant Nat       := String_Length (S);
+            C  : Char_Code;
+
+         begin
+            if SL = 0 then
+               Error_Msg_N ("interface name cannot be null string", SN);
+            end if;
+
+            for J in 1 .. SL loop
+               C := Get_String_Char (S, J);
+
+               if not In_Character_Range (C)
+                 or else Get_Character (C) = ' '
+                 or else Get_Character (C) = ','
+               then
+                  Error_Msg_N
+                    ("?interface name contains illegal character", SN);
+               end if;
+            end loop;
+         end Check_Form_Of_Interface_Name;
+
+      --  Start of processing for Process_Interface_Name
+
+      begin
+         if No (Link_Arg) then
+            if No (Ext_Arg) then
+               return;
+
+            elsif Chars (Ext_Arg) = Name_Link_Name then
+               Ext_Nam  := Empty;
+               Link_Nam := Expression (Ext_Arg);
+
+            else
+               Check_Optional_Identifier (Ext_Arg, Name_External_Name);
+               Ext_Nam  := Expression (Ext_Arg);
+               Link_Nam := Empty;
+            end if;
+
+         else
+            Check_Optional_Identifier (Ext_Arg,  Name_External_Name);
+            Check_Optional_Identifier (Link_Arg, Name_Link_Name);
+            Ext_Nam  := Expression (Ext_Arg);
+            Link_Nam := Expression (Link_Arg);
+         end if;
+
+         --  Check expressions for external name and link name are static
+
+         if Present (Ext_Nam) then
+            Check_Arg_Is_Static_Expression (Ext_Nam, Standard_String);
+            Check_Form_Of_Interface_Name (Ext_Nam);
+
+            --  Verify that the external name is not the name of a local
+            --  entity, which would hide the imported one and lead to
+            --  run-time surprises. The problem can only arise for entities
+            --  declared in a package body (otherwise the external name is
+            --  fully qualified and won't conflict).
+
+            declare
+               Nam : Name_Id;
+               E   : Entity_Id;
+               Par : Node_Id;
+
+            begin
+               if Prag_Id = Pragma_Import then
+                  String_To_Name_Buffer (Strval (Expr_Value_S (Ext_Nam)));
+                  Nam := Name_Find;
+                  E   := Entity_Id (Get_Name_Table_Info (Nam));
+
+                  if Nam /= Chars (Subprogram_Def)
+                    and then Present (E)
+                    and then not Is_Overloadable (E)
+                    and then Is_Immediately_Visible (E)
+                    and then not Is_Imported (E)
+                    and then Ekind (Scope (E)) = E_Package
+                  then
+                     Par := Parent (E);
+
+                     while Present (Par) loop
+                        if Nkind (Par) = N_Package_Body then
+                           Error_Msg_Sloc  := Sloc (E);
+                           Error_Msg_NE
+                             ("imported entity is hidden by & declared#",
+                                 Ext_Arg, E);
+                           exit;
+                        end if;
+
+                        Par := Parent (Par);
+                     end loop;
+                  end if;
+               end if;
+            end;
+         end if;
+
+         if Present (Link_Nam) then
+            Check_Arg_Is_Static_Expression (Link_Nam, Standard_String);
+            Check_Form_Of_Interface_Name (Link_Nam);
+         end if;
+
+         --  If there is no link name, just set the external name
+
+         if No (Link_Nam) then
+            Set_Encoded_Interface_Name
+              (Get_Base_Subprogram (Subprogram_Def),
+               Adjust_External_Name_Case (Expr_Value_S (Ext_Nam)));
+
+         --  For the Link_Name case, the given literal is preceded by an
+         --  asterisk, which indicates to GCC that the given name should
+         --  be taken literally, and in particular that no prepending of
+         --  underlines should occur, even in systems where this is the
+         --  normal default.
+
+         else
+            Start_String;
+            Store_String_Char (Get_Char_Code ('*'));
+            String_Val := Strval (Expr_Value_S (Link_Nam));
+
+            for J in 1 .. String_Length (String_Val) loop
+               Store_String_Char (Get_String_Char (String_Val, J));
+            end loop;
+
+            Link_Nam :=
+              Make_String_Literal (Sloc (Link_Nam), End_String);
+
+            Set_Encoded_Interface_Name
+              (Get_Base_Subprogram (Subprogram_Def), Link_Nam);
+         end if;
+      end Process_Interface_Name;
+
+      -----------------------------------------
+      -- Process_Interrupt_Or_Attach_Handler --
+      -----------------------------------------
+
+      procedure Process_Interrupt_Or_Attach_Handler is
+         Arg1_X    : constant Node_Id   := Expression (Arg1);
+         Prot_Proc : constant Entity_Id := Entity (Arg1_X);
+         Prot_Type : constant Entity_Id := Scope (Prot_Proc);
+
+      begin
+         Set_Is_Interrupt_Handler (Prot_Proc);
+
+         if Prag_Id = Pragma_Interrupt_Handler
+           or Prag_Id = Pragma_Attach_Handler
+         then
+            Record_Rep_Item (Prot_Type, N);
+         end if;
+
+      end Process_Interrupt_Or_Attach_Handler;
+
+      ---------------------------------
+      -- Process_Suppress_Unsuppress --
+      ---------------------------------
+
+      procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean) is
+         C         : Check_Id;
+         E_Id      : Node_Id;
+         E         : Entity_Id;
+         Effective : Boolean;
+
+         procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id);
+         --  Used to suppress a single check on the given entity
+
+         procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id) is
+         begin
+            --  First set appropriate suppress flags in the entity
+
+            case C is
+               when Access_Check =>
+                  Effective := Suppress_Access_Checks (E);
+                  Set_Suppress_Access_Checks (E, Suppress_Case);
+
+               when Accessibility_Check =>
+                  Effective := Suppress_Accessibility_Checks (E);
+                  Set_Suppress_Accessibility_Checks (E, Suppress_Case);
+
+               when Discriminant_Check =>
+                  Effective := Suppress_Discriminant_Checks  (E);
+                  Set_Suppress_Discriminant_Checks (E, Suppress_Case);
+
+               when Division_Check =>
+                  Effective := Suppress_Division_Checks (E);
+                  Set_Suppress_Division_Checks (E, Suppress_Case);
+
+               when Elaboration_Check =>
+                  Effective := Suppress_Elaboration_Checks (E);
+                  Set_Suppress_Elaboration_Checks (E, Suppress_Case);
+
+               when Index_Check =>
+                  Effective := Suppress_Index_Checks (E);
+                  Set_Suppress_Index_Checks (E, Suppress_Case);
+
+               when Length_Check =>
+                  Effective := Suppress_Length_Checks (E);
+                  Set_Suppress_Length_Checks (E, Suppress_Case);
+
+               when Overflow_Check =>
+                  Effective := Suppress_Overflow_Checks (E);
+                  Set_Suppress_Overflow_Checks (E, Suppress_Case);
+
+               when Range_Check =>
+                  Effective := Suppress_Range_Checks (E);
+                  Set_Suppress_Range_Checks (E, Suppress_Case);
+
+               when Storage_Check =>
+                  Effective := Suppress_Storage_Checks (E);
+                  Set_Suppress_Storage_Checks (E, Suppress_Case);
+
+               when Tag_Check =>
+                  Effective := Suppress_Tag_Checks (E);
+                  Set_Suppress_Tag_Checks (E, Suppress_Case);
+
+               when All_Checks =>
+                  Suppress_Unsuppress_Echeck (E, Access_Check);
+                  Suppress_Unsuppress_Echeck (E, Accessibility_Check);
+                  Suppress_Unsuppress_Echeck (E, Discriminant_Check);
+                  Suppress_Unsuppress_Echeck (E, Division_Check);
+                  Suppress_Unsuppress_Echeck (E, Elaboration_Check);
+                  Suppress_Unsuppress_Echeck (E, Index_Check);
+                  Suppress_Unsuppress_Echeck (E, Length_Check);
+                  Suppress_Unsuppress_Echeck (E, Overflow_Check);
+                  Suppress_Unsuppress_Echeck (E, Range_Check);
+                  Suppress_Unsuppress_Echeck (E, Storage_Check);
+                  Suppress_Unsuppress_Echeck (E, Tag_Check);
+            end case;
+
+            --  If the entity is not declared in the current scope, then we
+            --  make an entry in the Entity_Suppress table so that the flag
+            --  will be removed on exit. This entry is only made if the
+            --  suppress did something (i.e. the flag was not already set).
+
+            if Effective and then Scope (E) /= Current_Scope then
+               Entity_Suppress.Increment_Last;
+               Entity_Suppress.Table
+                 (Entity_Suppress.Last).Entity := E;
+               Entity_Suppress.Table
+                 (Entity_Suppress.Last).Check  := C;
+            end if;
+
+            --  If this is a first subtype, and the base type is distinct,
+            --  then also set the suppress flags on the base type.
+
+            if Is_First_Subtype (E)
+              and then Etype (E) /= E
+            then
+               Suppress_Unsuppress_Echeck (Etype (E), C);
+            end if;
+         end Suppress_Unsuppress_Echeck;
+
+      --  Start of processing for Process_Suppress_Unsuppress
+
+      begin
+         --  Suppress/Unsuppress can appear as a configuration pragma,
+         --  or in a declarative part or a package spec (RM 11.5(5))
+
+         if not Is_Configuration_Pragma then
+            Check_Is_In_Decl_Part_Or_Package_Spec;
+         end if;
+
+         Check_At_Least_N_Arguments (1);
+         Check_At_Most_N_Arguments (2);
+         Check_No_Identifier (Arg1);
+         Check_Arg_Is_Identifier (Arg1);
+
+         if not Is_Check_Name (Chars (Expression (Arg1))) then
+            Error_Pragma_Arg
+              ("argument of pragma% is not valid check name", Arg1);
+
+         else
+            C := Get_Check_Id (Chars (Expression (Arg1)));
+         end if;
+
+         if Arg_Count = 1 then
+            case C is
+               when Access_Check =>
+                  Scope_Suppress.Access_Checks := Suppress_Case;
+
+               when Accessibility_Check =>
+                  Scope_Suppress.Accessibility_Checks := Suppress_Case;
+
+               when Discriminant_Check =>
+                  Scope_Suppress.Discriminant_Checks := Suppress_Case;
+
+               when Division_Check =>
+                  Scope_Suppress.Division_Checks := Suppress_Case;
+
+               when Elaboration_Check =>
+                  Scope_Suppress.Elaboration_Checks := Suppress_Case;
+
+               when Index_Check =>
+                  Scope_Suppress.Index_Checks := Suppress_Case;
+
+               when Length_Check =>
+                  Scope_Suppress.Length_Checks := Suppress_Case;
+
+               when Overflow_Check =>
+                  Scope_Suppress.Overflow_Checks := Suppress_Case;
+
+               when Range_Check =>
+                  Scope_Suppress.Range_Checks := Suppress_Case;
+
+               when Storage_Check =>
+                  Scope_Suppress.Storage_Checks := Suppress_Case;
+
+               when Tag_Check =>
+                  Scope_Suppress.Tag_Checks := Suppress_Case;
+
+               when All_Checks =>
+                  Scope_Suppress := (others => Suppress_Case);
+
+            end case;
+
+         --  Case of two arguments present, where the check is
+         --  suppressed for a specified entity (given as the second
+         --  argument of the pragma)
+
+         else
+            Check_Optional_Identifier (Arg2, Name_On);
+            E_Id := Expression (Arg2);
+            Analyze (E_Id);
+
+            if not Is_Entity_Name (E_Id) then
+               Error_Pragma_Arg
+                 ("second argument of pragma% must be entity name", Arg2);
+            end if;
+
+            E := Entity (E_Id);
+
+            if E = Any_Id then
+               return;
+            else
+               loop
+                  Suppress_Unsuppress_Echeck (E, C);
+
+                  if Is_Generic_Instance (E)
+                    and then Is_Subprogram (E)
+                    and then Present (Alias (E))
+                  then
+                     Suppress_Unsuppress_Echeck (Alias (E), C);
+                  end if;
+
+                  if C = Elaboration_Check and then Suppress_Case then
+                     Set_Suppress_Elaboration_Warnings (E);
+                  end if;
+
+                  --  If we are within a package specification, the
+                  --  pragma only applies to homonyms in the same scope.
+
+                  exit when No (Homonym (E))
+                    or else (Scope (Homonym (E)) /= Current_Scope
+                              and then Ekind (Current_Scope) = E_Package
+                              and then not In_Package_Body (Current_Scope));
+
+                  E := Homonym (E);
+               end loop;
+            end if;
+         end if;
+
+      end Process_Suppress_Unsuppress;
+
+      ------------------
+      -- Set_Exported --
+      ------------------
+
+      procedure Set_Exported (E : Entity_Id; Arg : Node_Id) is
+      begin
+         if Is_Imported (E) then
+            Error_Pragma_Arg
+              ("cannot export entity& that was previously imported", Arg);
+
+         elsif Present (Address_Clause (E)) then
+            Error_Pragma_Arg
+              ("cannot export entity& that has an address clause", Arg);
+         end if;
+
+         Set_Is_Exported (E);
+
+         --  Deal with exporting non-library level entity
+
+         if not Is_Library_Level_Entity (E) then
+
+            --  Not allowed at all for subprograms
+
+            if Is_Subprogram (E) then
+               Error_Pragma_Arg ("local subprogram& cannot be exported", Arg);
+
+            --  Otherwise set public and statically allocated
+
+            else
+               Set_Is_Public (E);
+               Set_Is_Statically_Allocated (E);
+            end if;
+         end if;
+
+         if Inside_A_Generic then
+            Error_Msg_NE
+              ("all instances of& will have the same external name?", Arg, E);
+         end if;
+
+      end Set_Exported;
+
+      ----------------------------------------------
+      -- Set_Extended_Import_Export_External_Name --
+      ----------------------------------------------
+
+      procedure Set_Extended_Import_Export_External_Name
+        (Internal_Ent : Entity_Id;
+         Arg_External : Node_Id)
+      is
+         Old_Name : constant Node_Id := Interface_Name (Internal_Ent);
+         New_Name : Node_Id;
+
+      begin
+         if No (Arg_External) then
+            return;
+
+         elsif Nkind (Arg_External) = N_String_Literal then
+            if String_Length (Strval (Arg_External)) = 0 then
+               return;
+            else
+               New_Name := Adjust_External_Name_Case (Arg_External);
+            end if;
+
+         elsif Nkind (Arg_External) = N_Identifier then
+            New_Name := Get_Default_External_Name (Arg_External);
+
+         else
+            Error_Pragma_Arg
+              ("incorrect form for External parameter for pragma%",
+               Arg_External);
+         end if;
+
+         --  If we already have an external name set (by a prior normal
+         --  Import or Export pragma), then the external names must match
+
+         if Present (Interface_Name (Internal_Ent)) then
+            declare
+               S1 : constant String_Id := Strval (Old_Name);
+               S2 : constant String_Id := Strval (New_Name);
+
+               procedure Mismatch;
+               --  Called if names do not match
+
+               procedure Mismatch is
+               begin
+                  Error_Msg_Sloc := Sloc (Old_Name);
+                  Error_Pragma_Arg
+                    ("external name does not match that given #",
+                     Arg_External);
+               end Mismatch;
+
+            begin
+               if String_Length (S1) /= String_Length (S2) then
+                  Mismatch;
+
+               else
+                  for J in 1 .. String_Length (S1) loop
+                     if Get_String_Char (S1, J) /= Get_String_Char (S2, J) then
+                        Mismatch;
+                     end if;
+                  end loop;
+               end if;
+            end;
+
+         --  Otherwise set the given name
+
+         else
+            Set_Encoded_Interface_Name (Internal_Ent, New_Name);
+         end if;
+
+      end Set_Extended_Import_Export_External_Name;
+
+      ------------------
+      -- Set_Imported --
+      ------------------
+
+      procedure Set_Imported (E : Entity_Id) is
+      begin
+         Error_Msg_Sloc  := Sloc (E);
+
+         if Is_Exported (E) or else Is_Imported (E) then
+            Error_Msg_NE ("import of& declared# not allowed", N, E);
+
+            if Is_Exported (E) then
+               Error_Msg_N ("\entity was previously exported", N);
+            else
+               Error_Msg_N ("\entity was previously imported", N);
+            end if;
+
+            Error_Pragma ("\(pragma% applies to all previous entities)");
+
+         else
+            Set_Is_Imported (E);
+
+            --  If the entity is an object that is not at the library
+            --  level, then it is statically allocated. We do not worry
+            --  about objects with address clauses in this context since
+            --  they are not really imported in the linker sense.
+
+            if Is_Object (E)
+              and then not Is_Library_Level_Entity (E)
+              and then No (Address_Clause (E))
+            then
+               Set_Is_Statically_Allocated (E);
+            end if;
+         end if;
+      end Set_Imported;
+
+      -------------------------
+      -- Set_Mechanism_Value --
+      -------------------------
+
+      --  Note: the mechanism name has not been analyzed (and cannot indeed
+      --  be analyzed, since it is semantic nonsense), so we get it in the
+      --  exact form created by the parser.
+
+      procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is
+         Class : Node_Id;
+         Param : Node_Id;
+
+         procedure Bad_Class;
+         --  Signal bad descriptor class name
+
+         procedure Bad_Mechanism;
+         --  Signal bad mechanism name
+
+         procedure Bad_Class is
+         begin
+            Error_Pragma_Arg ("unrecognized descriptor class name", Class);
+         end Bad_Class;
+
+         procedure Bad_Mechanism is
+         begin
+            Error_Pragma_Arg ("unrecognized mechanism name", Mech_Name);
+         end Bad_Mechanism;
+
+      --  Start of processing for Set_Mechanism_Value
+
+      begin
+         if Mechanism (Ent) /= Default_Mechanism then
+            Error_Msg_NE
+              ("mechanism for & has already been set", Mech_Name, Ent);
+         end if;
+
+         --  MECHANISM_NAME ::= value | reference | descriptor
+
+         if Nkind (Mech_Name) = N_Identifier then
+            if Chars (Mech_Name) = Name_Value then
+               Set_Mechanism (Ent, By_Copy);
+               return;
+
+            elsif Chars (Mech_Name) = Name_Reference then
+               Set_Mechanism (Ent, By_Reference);
+               return;
+
+            elsif Chars (Mech_Name) = Name_Descriptor then
+               Check_VMS (Mech_Name);
+               Set_Mechanism (Ent, By_Descriptor);
+               return;
+
+            elsif Chars (Mech_Name) = Name_Copy then
+               Error_Pragma_Arg
+                 ("bad mechanism name, Value assumed", Mech_Name);
+
+            else
+               Bad_Mechanism;
+            end if;
+
+         --  MECHANISM_NAME ::= descriptor (CLASS_NAME)
+         --  CLASS_NAME     ::= ubs | ubsb | uba | s | sb | a | nca
+
+         --  Note: this form is parsed as an indexed component
+
+         elsif Nkind (Mech_Name) = N_Indexed_Component then
+            Class := First (Expressions (Mech_Name));
+
+            if Nkind (Prefix (Mech_Name)) /= N_Identifier
+              or else Chars (Prefix (Mech_Name)) /= Name_Descriptor
+              or else Present (Next (Class))
+            then
+               Bad_Mechanism;
+            end if;
+
+         --  MECHANISM_NAME ::= descriptor (Class => CLASS_NAME)
+         --  CLASS_NAME     ::= ubs | ubsb | uba | s | sb | a | nca
+
+         --  Note: this form is parsed as a function call
+
+         elsif Nkind (Mech_Name) = N_Function_Call then
+
+            Param := First (Parameter_Associations (Mech_Name));
+
+            if Nkind (Name (Mech_Name)) /= N_Identifier
+              or else Chars (Name (Mech_Name)) /= Name_Descriptor
+              or else Present (Next (Param))
+              or else No (Selector_Name (Param))
+              or else Chars (Selector_Name (Param)) /= Name_Class
+            then
+               Bad_Mechanism;
+            else
+               Class := Explicit_Actual_Parameter (Param);
+            end if;
+
+         else
+            Bad_Mechanism;
+         end if;
+
+         --  Fall through here with Class set to descriptor class name
+
+         Check_VMS (Mech_Name);
+
+         if Nkind (Class) /= N_Identifier then
+            Bad_Class;
+
+         elsif Chars (Class) = Name_UBS then
+            Set_Mechanism (Ent, By_Descriptor_UBS);
+
+         elsif Chars (Class) = Name_UBSB then
+            Set_Mechanism (Ent, By_Descriptor_UBSB);
+
+         elsif Chars (Class) = Name_UBA then
+            Set_Mechanism (Ent, By_Descriptor_UBA);
+
+         elsif Chars (Class) = Name_S then
+            Set_Mechanism (Ent, By_Descriptor_S);
+
+         elsif Chars (Class) = Name_SB then
+            Set_Mechanism (Ent, By_Descriptor_SB);
+
+         elsif Chars (Class) = Name_A then
+            Set_Mechanism (Ent, By_Descriptor_A);
+
+         elsif Chars (Class) = Name_NCA then
+            Set_Mechanism (Ent, By_Descriptor_NCA);
+
+         else
+            Bad_Class;
+         end if;
+
+      end Set_Mechanism_Value;
+
+   --  Start of processing for Analyze_Pragma
+
+   begin
+      if not Is_Pragma_Name (Chars (N)) then
+         Error_Pragma ("unrecognized pragma%!?");
+      else
+         Prag_Id := Get_Pragma_Id (Chars (N));
+      end if;
+
+      --  Preset arguments
+
+      Arg1 := Empty;
+      Arg2 := Empty;
+      Arg3 := Empty;
+      Arg4 := Empty;
+
+      if Present (Pragma_Argument_Associations (N)) then
+         Arg1 := First (Pragma_Argument_Associations (N));
+
+         if Present (Arg1) then
+            Arg2 := Next (Arg1);
+
+            if Present (Arg2) then
+               Arg3 := Next (Arg2);
+
+               if Present (Arg3) then
+                  Arg4 := Next (Arg3);
+               end if;
+            end if;
+         end if;
+      end if;
+
+      --  Count number of arguments
+
+      declare
+         Arg_Node : Node_Id;
+
+      begin
+         Arg_Count := 0;
+         Arg_Node := Arg1;
+
+         while Present (Arg_Node) loop
+            Arg_Count := Arg_Count + 1;
+            Next (Arg_Node);
+         end loop;
+      end;
+
+      --  An enumeration type defines the pragmas that are supported by the
+      --  implementation. Get_Pragma_Id (in package Prag) transorms a name
+      --  into the corresponding enumeration value for the following case.
+
+      case Prag_Id is
+
+         -----------------
+         -- Abort_Defer --
+         -----------------
+
+         --  pragma Abort_Defer;
+
+         when Pragma_Abort_Defer =>
+            GNAT_Pragma;
+            Check_Arg_Count (0);
+
+            --  The only required semantic processing is to check the
+            --  placement. This pragma must appear at the start of the
+            --  statement sequence of a handled sequence of statements.
+
+            if Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements
+              or else N /= First (Statements (Parent (N)))
+            then
+               Pragma_Misplaced;
+            end if;
+
+         ------------
+         -- Ada_83 --
+         ------------
+
+         --  pragma Ada_83;
+
+         --  Note: this pragma also has some specific processing in Par.Prag
+         --  because we want to set the Ada 83 mode switch during parsing.
+
+         when Pragma_Ada_83 =>
+            GNAT_Pragma;
+            Ada_83 := True;
+            Ada_95 := False;
+            Check_Arg_Count (0);
+
+         ------------
+         -- Ada_95 --
+         ------------
+
+         --  pragma Ada_95;
+
+         --  Note: this pragma also has some specific processing in Par.Prag
+         --  because we want to set the Ada 83 mode switch during parsing.
+
+         when Pragma_Ada_95 =>
+            GNAT_Pragma;
+            Ada_83 := False;
+            Ada_95 := True;
+            Check_Arg_Count (0);
+
+         ----------------------
+         -- All_Calls_Remote --
+         ----------------------
+
+         --  pragma All_Calls_Remote [(library_package_NAME)];
+
+         when Pragma_All_Calls_Remote => All_Calls_Remote : declare
+            Lib_Entity : Entity_Id;
+
+         begin
+            Check_Ada_83_Warning;
+            Check_Valid_Library_Unit_Pragma;
+
+            if Nkind (N) = N_Null_Statement then
+               return;
+            end if;
+
+            Lib_Entity := Find_Lib_Unit_Name;
+
+            --  This pragma should only apply to a RCI unit (RM E.2.3(23)).
+
+            if Present (Lib_Entity)
+              and then not Debug_Flag_U
+            then
+               if not Is_Remote_Call_Interface (Lib_Entity) then
+                  Error_Pragma ("pragma% only apply to rci unit");
+
+               --  Set flag for entity of the library unit
+
+               else
+                  Set_Has_All_Calls_Remote (Lib_Entity);
+               end if;
+
+            end if;
+         end All_Calls_Remote;
+
+         --------------
+         -- Annotate --
+         --------------
+
+         --  pragma Annotate (IDENTIFIER {, ARG});
+         --  ARG ::= NAME | EXPRESSION
+
+         when Pragma_Annotate => Annotate : begin
+            GNAT_Pragma;
+            Check_At_Least_N_Arguments (1);
+            Check_Arg_Is_Identifier (Arg1);
+
+            declare
+               Arg : Node_Id := Arg2;
+               Exp : Node_Id;
+
+            begin
+               while Present (Arg) loop
+                  Exp := Expression (Arg);
+                  Analyze (Exp);
+
+                  if Is_Entity_Name (Exp) then
+                     null;
+
+                  elsif Nkind (Exp) = N_String_Literal then
+                     Resolve (Exp, Standard_String);
+
+                  elsif Is_Overloaded (Exp) then
+                     Error_Pragma_Arg ("ambiguous argument for pragma%", Exp);
+
+                  else
+                     Resolve (Exp, Etype (Exp));
+                  end if;
+
+                  Next (Arg);
+               end loop;
+            end;
+         end Annotate;
+
+         ------------
+         -- Assert --
+         ------------
+
+         --  pragma Assert (Boolean_EXPRESSION [, static_string_EXPRESSION]);
+
+         when Pragma_Assert =>
+            GNAT_Pragma;
+            Check_No_Identifiers;
+
+            if Arg_Count > 1 then
+               Check_Arg_Count (2);
+               Check_Arg_Is_Static_Expression (Arg2, Standard_String);
+            end if;
+
+            --  If expansion is active and assertions are inactive, then
+            --  we rewrite the Assertion as:
+
+            --    if False and then condition then
+            --       null;
+            --    end if;
+
+            --  The reason we do this rewriting during semantic analysis
+            --  rather than as part of normal expansion is that we cannot
+            --  analyze and expand the code for the boolean expression
+            --  directly, or it may cause insertion of actions that would
+            --  escape the attempt to suppress the assertion code.
+
+            if Expander_Active and not Assertions_Enabled then
+               Rewrite (N,
+                 Make_If_Statement (Loc,
+                   Condition =>
+                     Make_And_Then (Loc,
+                       Left_Opnd  => New_Occurrence_Of (Standard_False, Loc),
+                       Right_Opnd => Get_Pragma_Arg (Arg1)),
+                   Then_Statements => New_List (
+                     Make_Null_Statement (Loc))));
+
+               Analyze (N);
+
+            --  Otherwise (if assertions are enabled, or if we are not
+            --  operating with expansion active), then we just analyze
+            --  and resolve the expression.
+
+            else
+               Analyze_And_Resolve (Expression (Arg1), Any_Boolean);
+            end if;
+
+         ---------------
+         -- AST_Entry --
+         ---------------
+
+         --  pragma AST_Entry (entry_IDENTIFIER);
+
+         when Pragma_AST_Entry => AST_Entry : declare
+            Ent : Node_Id;
+
+         begin
+            GNAT_Pragma;
+            Check_VMS (N);
+            Check_Arg_Count (1);
+            Check_No_Identifiers;
+            Check_Arg_Is_Local_Name (Arg1);
+            Ent := Entity (Expression (Arg1));
+
+            --  Note: the implementation of the AST_Entry pragma could handle
+            --  the entry family case fine, but for now we are consistent with
+            --  the DEC rules, and do not allow the pragma, which of course
+            --  has the effect of also forbidding the attribute.
+
+            if Ekind (Ent) /= E_Entry then
+               Error_Pragma_Arg
+                 ("pragma% argument must be simple entry name", Arg1);
+
+            elsif Is_AST_Entry (Ent) then
+               Error_Pragma_Arg
+                 ("duplicate % pragma for entry", Arg1);
+
+            elsif Has_Homonym (Ent) then
+               Error_Pragma_Arg
+                 ("pragma% argument cannot specify overloaded entry", Arg1);
+
+            else
+               declare
+                  FF : constant Entity_Id := First_Formal (Ent);
+
+               begin
+                  if Present (FF) then
+                     if Present (Next_Formal (FF)) then
+                        Error_Pragma_Arg
+                          ("entry for pragma% can have only one argument",
+                           Arg1);
+
+                     elsif Parameter_Mode (FF) /= E_In_Parameter then
+                        Error_Pragma_Arg
+                          ("entry parameter for pragma% must have mode IN",
+                           Arg1);
+                     end if;
+                  end if;
+               end;
+
+               Set_Is_AST_Entry (Ent);
+            end if;
+         end AST_Entry;
+
+         ------------------
+         -- Asynchronous --
+         ------------------
+
+         --  pragma Asynchronous (LOCAL_NAME);
+
+         when Pragma_Asynchronous => Asynchronous : declare
+            Nm     : Entity_Id;
+            C_Ent  : Entity_Id;
+            L      : List_Id;
+            S      : Node_Id;
+            N      : Node_Id;
+            Formal : Entity_Id;
+
+            procedure Process_Async_Pragma;
+            --  Common processing for procedure and access-to-procedure case
+
+            --------------------------
+            -- Process_Async_Pragma --
+            --------------------------
+
+            procedure Process_Async_Pragma is
+            begin
+               if not Present (L) then
+                  Set_Is_Asynchronous (Nm);
+                  return;
+               end if;
+
+               --  The formals should be of mode IN (RM E.4.1(6))
+
+               S := First (L);
+               while Present (S) loop
+                  Formal := Defining_Identifier (S);
+
+                  if Nkind (Formal) = N_Defining_Identifier
+                    and then Ekind (Formal) /= E_In_Parameter
+                  then
+                     Error_Pragma_Arg
+                       ("pragma% procedure can only have IN parameter",
+                        Arg1);
+                  end if;
+
+                  Next (S);
+               end loop;
+
+               Set_Is_Asynchronous (Nm);
+            end Process_Async_Pragma;
+
+         --  Start of processing for pragma Asynchronous
+
+         begin
+            Check_Ada_83_Warning;
+            Check_No_Identifiers;
+            Check_Arg_Count (1);
+            Check_Arg_Is_Local_Name (Arg1);
+
+            if Debug_Flag_U then
+               return;
+            end if;
+
+            C_Ent := Cunit_Entity (Current_Sem_Unit);
+            Analyze (Expression (Arg1));
+            Nm := Entity (Expression (Arg1));
+
+            if not Is_Remote_Call_Interface (C_Ent)
+              and then not Is_Remote_Types (C_Ent)
+            then
+               --  This pragma should only appear in an RCI or Remote Types
+               --  unit (RM E.4.1(4))
+
+               Error_Pragma
+                 ("pragma% not in Remote_Call_Interface or " &
+                  "Remote_Types unit");
+            end if;
+
+            if Ekind (Nm) = E_Procedure
+              and then Nkind (Parent (Nm)) = N_Procedure_Specification
+            then
+               if not Is_Remote_Call_Interface (Nm) then
+                  Error_Pragma_Arg
+                    ("pragma% cannot be applied on non-remote procedure",
+                     Arg1);
+               end if;
+
+               L := Parameter_Specifications (Parent (Nm));
+               Process_Async_Pragma;
+               return;
+
+            elsif Ekind (Nm) = E_Function then
+               Error_Pragma_Arg
+                 ("pragma% cannot be applied to function", Arg1);
+
+            elsif Ekind (Nm) = E_Record_Type
+              and then Present (Corresponding_Remote_Type (Nm))
+            then
+               N := Declaration_Node (Corresponding_Remote_Type (Nm));
+
+               if Nkind (N) = N_Full_Type_Declaration
+                 and then Nkind (Type_Definition (N)) =
+                                     N_Access_Procedure_Definition
+               then
+                  L := Parameter_Specifications (Type_Definition (N));
+                  Process_Async_Pragma;
+
+               else
+                  Error_Pragma_Arg
+                    ("pragma% cannot reference access-to-function type",
+                    Arg1);
+               end if;
+
+            --  Only other possibility is Access-to-class-wide type
+
+            elsif Is_Access_Type (Nm)
+              and then Is_Class_Wide_Type (Designated_Type (Nm))
+            then
+               Check_First_Subtype (Arg1);
+               Set_Is_Asynchronous (Nm);
+               if Expander_Active then
+                  RACW_Type_Is_Asynchronous (Nm);
+               end if;
+
+            else
+               Error_Pragma_Arg ("inappropriate argument for pragma%", Arg1);
+            end if;
+
+         end Asynchronous;
+
+         ------------
+         -- Atomic --
+         ------------
+
+         --  pragma Atomic (LOCAL_NAME);
+
+         when Pragma_Atomic =>
+            Process_Atomic_Shared_Volatile;
+
+         -----------------------
+         -- Atomic_Components --
+         -----------------------
+
+         --  pragma Atomic_Components (array_LOCAL_NAME);
+
+         --  This processing is shared by Volatile_Components
+
+         when Pragma_Atomic_Components   |
+              Pragma_Volatile_Components =>
+
+         Atomic_Components : declare
+            E_Id : Node_Id;
+            E    : Entity_Id;
+            D    : Node_Id;
+            K    : Node_Kind;
+
+         begin
+            GNAT_Pragma;
+            Check_Ada_83_Warning;
+            Check_No_Identifiers;
+            Check_Arg_Count (1);
+            Check_Arg_Is_Local_Name (Arg1);
+            E_Id := Expression (Arg1);
+
+            if Etype (E_Id) = Any_Type then
+               return;
+            end if;
+
+            E := Entity (E_Id);
+
+            if Rep_Item_Too_Early (E, N)
+                 or else
+               Rep_Item_Too_Late (E, N)
+            then
+               return;
+            end if;
+
+            D := Declaration_Node (E);
+            K := Nkind (D);
+
+            if (K = N_Full_Type_Declaration and then Is_Array_Type (E))
+              or else
+                ((Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
+                   and then Nkind (D) = N_Object_Declaration
+                   and then Nkind (Object_Definition (D)) =
+                                       N_Constrained_Array_Definition)
+            then
+               --  The flag is set on the object, or on the base type
+
+               if Nkind (D) /= N_Object_Declaration then
+                  E := Base_Type (E);
+               end if;
+
+               Set_Has_Volatile_Components (E);
+
+               if Prag_Id = Pragma_Atomic_Components then
+                  Set_Has_Atomic_Components (E);
+
+                  if Is_Packed (E) then
+                     Set_Is_Packed (E, False);
+
+                     Error_Pragma_Arg
+                       ("?Pack canceled, cannot pack atomic components",
+                        Arg1);
+                  end if;
+               end if;
+
+            else
+               Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
+            end if;
+         end Atomic_Components;
+
+         --------------------
+         -- Attach_Handler --
+         --------------------
+
+         --  pragma Attach_Handler (handler_NAME, EXPRESSION);
+
+         when Pragma_Attach_Handler =>
+            Check_Ada_83_Warning;
+            Check_No_Identifiers;
+            Check_Arg_Count (2);
+            Check_Interrupt_Or_Attach_Handler;
+            Analyze_And_Resolve (Expression (Arg2), RTE (RE_Interrupt_Id));
+            Process_Interrupt_Or_Attach_Handler;
+
+         --------------------
+         -- C_Pass_By_Copy --
+         --------------------
+
+         --  pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
+
+         when Pragma_C_Pass_By_Copy => C_Pass_By_Copy : declare
+            Arg : Node_Id;
+            Val : Uint;
+
+         begin
+            GNAT_Pragma;
+            Check_Valid_Configuration_Pragma;
+            Check_Arg_Count (1);
+            Check_Optional_Identifier (Arg1, "max_size");
+
+            Arg := Expression (Arg1);
+            Check_Arg_Is_Static_Expression (Arg, Any_Integer);
+
+            Val := Expr_Value (Arg);
+
+            if Val <= 0 then
+               Error_Pragma_Arg
+                 ("maximum size for pragma% must be positive", Arg1);
+
+            elsif UI_Is_In_Int_Range (Val) then
+               Default_C_Record_Mechanism := UI_To_Int (Val);
+
+            --  If a giant value is given, Int'Last will do well enough.
+            --  If sometime someone complains that a record larger than
+            --  two gigabytes is not copied, we will worry about it then!
+
+            else
+               Default_C_Record_Mechanism := Mechanism_Type'Last;
+            end if;
+         end C_Pass_By_Copy;
+
+         -------------
+         -- Comment --
+         -------------
+
+         --  pragma Comment (static_string_EXPRESSION)
+
+         --  Processing for pragma Comment shares the circuitry for
+         --  pragma Ident. The only differences are that Ident enforces
+         --  a limit of 31 characters on its argument, and also enforces
+         --  limitations on placement for DEC compatibility. Pragma
+         --  Comment shares neither of these restrictions.
+
+         -------------------
+         -- Common_Object --
+         -------------------
+
+         --  pragma Common_Object (
+         --        [Internal =>] LOCAL_NAME,
+         --     [, [External =>] EXTERNAL_SYMBOL]
+         --     [, [Size     =>] EXTERNAL_SYMBOL]);
+
+         --  Processing for this pragma is shared with Psect_Object
+
+         ----------------------------
+         -- Complex_Representation --
+         ----------------------------
+
+         --  pragma Complex_Representation ([Entity =>] LOCAL_NAME);
+
+         when Pragma_Complex_Representation => Complex_Representation : declare
+            E_Id : Entity_Id;
+            E    : Entity_Id;
+            Ent  : Entity_Id;
+
+         begin
+            GNAT_Pragma;
+            Check_Arg_Count (1);
+            Check_Optional_Identifier (Arg1, Name_Entity);
+            Check_Arg_Is_Local_Name (Arg1);
+            E_Id := Expression (Arg1);
+
+            if Etype (E_Id) = Any_Type then
+               return;
+            end if;
+
+            E := Entity (E_Id);
+
+            if not Is_Record_Type (E) then
+               Error_Pragma_Arg
+                 ("argument for pragma% must be record type", Arg1);
+            end if;
+
+            Ent := First_Entity (E);
+
+            if No (Ent)
+              or else No (Next_Entity (Ent))
+              or else Present (Next_Entity (Next_Entity (Ent)))
+              or else not Is_Floating_Point_Type (Etype (Ent))
+              or else Etype (Ent) /= Etype (Next_Entity (Ent))
+            then
+               Error_Pragma_Arg
+                 ("record for pragma% must have two fields of same fpt type",
+                  Arg1);
+
+            else
+               Set_Has_Complex_Representation (Base_Type (E));
+            end if;
+         end Complex_Representation;
+
+         -------------------------
+         -- Component_Alignment --
+         -------------------------
+
+         --  pragma Component_Alignment (
+         --        [Form =>] ALIGNMENT_CHOICE
+         --     [, [Name =>] type_LOCAL_NAME]);
+         --
+         --   ALIGNMENT_CHOICE ::=
+         --     Component_Size
+         --   | Component_Size_4
+         --   | Storage_Unit
+         --   | Default
+
+         when Pragma_Component_Alignment => Component_AlignmentP : declare
+            Args  : Args_List (1 .. 2);
+            Names : Name_List (1 .. 2) := (
+                      Name_Form,
+                      Name_Name);
+
+            Form  : Node_Id renames Args (1);
+            Name  : Node_Id renames Args (2);
+
+            Atype : Component_Alignment_Kind;
+            Typ   : Entity_Id;
+
+         begin
+            GNAT_Pragma;
+            Gather_Associations (Names, Args);
+
+            if No (Form) then
+               Error_Pragma ("missing Form argument for pragma%");
+            end if;
+
+            Check_Arg_Is_Identifier (Form);
+
+            --  Get proper alignment, note that Default = Component_Size
+            --  on all machines we have so far, and we want to set this
+            --  value rather than the default value to indicate that it
+            --  has been explicitly set (and thus will not get overridden
+            --  by the default component alignment for the current scope)
+
+            if Chars (Form) = Name_Component_Size then
+               Atype := Calign_Component_Size;
+
+            elsif Chars (Form) = Name_Component_Size_4 then
+               Atype := Calign_Component_Size_4;
+
+            elsif Chars (Form) = Name_Default then
+               Atype := Calign_Component_Size;
+
+            elsif Chars (Form) = Name_Storage_Unit then
+               Atype := Calign_Storage_Unit;
+
+            else
+               Error_Pragma_Arg
+                 ("invalid Form parameter for pragma%", Form);
+            end if;
+
+            --  Case with no name, supplied, affects scope table entry
+
+            if No (Name) then
+               Scope_Stack.Table
+                 (Scope_Stack.Last).Component_Alignment_Default := Atype;
+
+            --  Case of name supplied
+
+            else
+               Check_Arg_Is_Local_Name (Name);
+               Find_Type (Name);
+               Typ := Entity (Name);
+
+               if Typ = Any_Type
+                 or else Rep_Item_Too_Early (Typ, N)
+               then
+                  return;
+               else
+                  Typ := Underlying_Type (Typ);
+               end if;
+
+               if not Is_Record_Type (Typ)
+                 and then not Is_Array_Type (Typ)
+               then
+                  Error_Pragma_Arg
+                    ("Name parameter of pragma% must identify record or " &
+                     "array type", Name);
+               end if;
+
+               --  An explicit Component_Alignment pragma overrides an
+               --  implicit pragma Pack, but not an explicit one.
+
+               if not Has_Pragma_Pack (Base_Type (Typ)) then
+                  Set_Is_Packed (Base_Type (Typ), False);
+                  Set_Component_Alignment (Base_Type (Typ), Atype);
+               end if;
+            end if;
+
+         end Component_AlignmentP;
+
+         ----------------
+         -- Controlled --
+         ----------------
+
+         --  pragma Controlled (first_subtype_LOCAL_NAME);
+
+         when Pragma_Controlled => Controlled : declare
+            Arg : Node_Id;
+
+         begin
+            Check_No_Identifiers;
+            Check_Arg_Count (1);
+            Check_Arg_Is_Local_Name (Arg1);
+            Arg := Expression (Arg1);
+
+            if not Is_Entity_Name (Arg)
+              or else not Is_Access_Type (Entity (Arg))
+            then
+               Error_Pragma_Arg ("pragma% requires access type", Arg1);
+            else
+               Set_Has_Pragma_Controlled (Base_Type (Entity (Arg)));
+            end if;
+         end Controlled;
+
+         ----------------
+         -- Convention --
+         ----------------
+
+         --  pragma Convention ([Convention =>] convention_IDENTIFIER,
+         --    [Entity =>] LOCAL_NAME);
+
+         when Pragma_Convention => Convention : declare
+            C : Convention_Id;
+            E : Entity_Id;
+
+         begin
+            Check_Ada_83_Warning;
+            Check_Arg_Count (2);
+            Process_Convention (C, E);
+         end Convention;
+
+         ---------------
+         -- CPP_Class --
+         ---------------
+
+         --  pragma CPP_Class ([Entity =>] local_NAME)
+
+         when Pragma_CPP_Class => CPP_Class : declare
+            Arg         : Node_Id;
+            Typ         : Entity_Id;
+            Default_DTC : Entity_Id := Empty;
+            VTP_Type    : constant Entity_Id  := RTE (RE_Vtable_Ptr);
+            C           : Entity_Id;
+            Tag_C       : Entity_Id;
+
+         begin
+            GNAT_Pragma;
+            Check_Arg_Count (1);
+            Check_Optional_Identifier (Arg1, Name_Entity);
+            Check_Arg_Is_Local_Name (Arg1);
+
+            Arg := Expression (Arg1);
+            Analyze (Arg);
+
+            if Etype (Arg) = Any_Type then
+               return;
+            end if;
+
+            if not Is_Entity_Name (Arg)
+              or else not Is_Type (Entity (Arg))
+            then
+               Error_Pragma_Arg ("pragma% requires a type mark", Arg1);
+            end if;
+
+            Typ := Entity (Arg);
+
+            if not Is_Record_Type (Typ) then
+               Error_Pragma_Arg ("pragma% applicable to a record, "
+                 & "tagged record or record extension", Arg1);
+            end if;
+
+            Default_DTC := First_Component (Typ);
+            while Present (Default_DTC)
+              and then Etype (Default_DTC) /= VTP_Type
+            loop
+               Next_Component (Default_DTC);
+            end loop;
+
+            --  Case of non tagged type
+
+            if not Is_Tagged_Type (Typ) then
+               Set_Is_CPP_Class (Typ);
+
+               if Present (Default_DTC) then
+                  Error_Pragma_Arg
+                    ("only tagged records can contain vtable pointers", Arg1);
+               end if;
+
+            --  Case of tagged type with no vtable ptr
+
+            --  What is test for Typ = Root_Typ (Typ) about here ???
+
+            elsif Is_Tagged_Type (Typ)
+              and then Typ = Root_Type (Typ)
+              and then No (Default_DTC)
+            then
+               Error_Pragma_Arg
+                 ("a cpp_class must contain a vtable pointer", Arg1);
+
+            --  Tagged type that has a vtable ptr
+
+            elsif Present (Default_DTC) then
+               Set_Is_CPP_Class (Typ);
+               Set_Is_Limited_Record (Typ);
+               Set_Is_Tag (Default_DTC);
+               Set_DT_Entry_Count (Default_DTC, No_Uint);
+
+               --  Since a CPP type has no direct link to its associated tag
+               --  most tags checks cannot be performed
+
+               Set_Suppress_Tag_Checks (Typ);
+               Set_Suppress_Tag_Checks (Class_Wide_Type (Typ));
+
+               --  Get rid of the _tag component when there was one.
+               --  It is only useful for regular tagged types
+
+               if Expander_Active and then Typ = Root_Type (Typ) then
+
+                  Tag_C := Tag_Component (Typ);
+                  C := First_Entity (Typ);
+
+                  if C = Tag_C then
+                     Set_First_Entity (Typ, Next_Entity (Tag_C));
+
+                  else
+                     while Next_Entity (C) /= Tag_C loop
+                        Next_Entity (C);
+                     end loop;
+
+                     Set_Next_Entity (C, Next_Entity (Tag_C));
+                  end if;
+               end if;
+            end if;
+         end CPP_Class;
+
+         ---------------------
+         -- CPP_Constructor --
+         ---------------------
+
+         --  pragma CPP_Constructor ([Entity =>] LOCAL_NAME);
+
+         when Pragma_CPP_Constructor => CPP_Constructor : declare
+            Id     : Entity_Id;
+            Def_Id : Entity_Id;
+
+         begin
+            GNAT_Pragma;
+            Check_Arg_Count (1);
+            Check_Optional_Identifier (Arg1, Name_Entity);
+            Check_Arg_Is_Local_Name (Arg1);
+
+            Id := Expression (Arg1);
+            Find_Program_Unit_Name (Id);
+
+            --  If we did not find the name, we are done
+
+            if Etype (Id) = Any_Type then
+               return;
+            end if;
+
+            Def_Id := Entity (Id);
+
+            if Ekind (Def_Id) = E_Function
+              and then Is_Class_Wide_Type (Etype (Def_Id))
+              and then Is_CPP_Class (Etype (Etype (Def_Id)))
+            then
+               --  What the heck is this??? this pragma allows only 1 arg
+
+               if Arg_Count >= 2 then
+                  Check_At_Most_N_Arguments (3);
+                  Process_Interface_Name (Def_Id, Arg2, Arg3);
+               end if;
+
+               if No (Parameter_Specifications (Parent (Def_Id))) then
+                  Set_Has_Completion (Def_Id);
+                  Set_Is_Constructor (Def_Id);
+               else
+                  Error_Pragma_Arg
+                    ("non-default constructors not implemented", Arg1);
+               end if;
+
+            else
+               Error_Pragma_Arg
+                 ("pragma% requires function returning a 'C'P'P_Class type",
+                   Arg1);
+            end if;
+         end CPP_Constructor;
+
+         -----------------
+         -- CPP_Virtual --
+         -----------------
+
+         --  pragma CPP_Virtual
+         --      [Entity =>]       LOCAL_NAME
+         --    [ [Vtable_Ptr =>]   LOCAL_NAME,
+         --      [Position =>]     static_integer_EXPRESSION]);
+
+         when Pragma_CPP_Virtual => CPP_Virtual : declare
+            Arg      : Node_Id;
+            Typ      : Entity_Id;
+            Subp     : Entity_Id;
+            VTP_Type : constant Entity_Id  := RTE (RE_Vtable_Ptr);
+            DTC      : Entity_Id;
+            V        : Uint;
+
+         begin
+            GNAT_Pragma;
+
+            if Arg_Count = 3 then
+               Check_Optional_Identifier (Arg2, "vtable_ptr");
+
+               --  We allow Entry_Count as well as Position for the third
+               --  parameter for back compatibility with versions of GNAT
+               --  before version 3.12. The documentation has always said
+               --  Position, but the code up to 3.12 said Entry_Count.
+
+               if Chars (Arg3) /= Name_Position then
+                  Check_Optional_Identifier (Arg3, "entry_count");
+               end if;
+
+            else
+               Check_Arg_Count (1);
+            end if;
+
+            Check_Optional_Identifier (Arg1, Name_Entity);
+            Check_Arg_Is_Local_Name (Arg1);
+
+            --  First argument must be a subprogram name
+
+            Arg := Expression (Arg1);
+            Find_Program_Unit_Name (Arg);
+
+            if Etype (Arg) = Any_Type then
+               return;
+            else
+               Subp := Entity (Arg);
+            end if;
+
+            if not (Is_Subprogram (Subp)
+                     and then Is_Dispatching_Operation (Subp))
+            then
+               Error_Pragma_Arg
+                 ("pragma% must reference a primitive operation", Arg1);
+            end if;
+
+            Typ := Find_Dispatching_Type (Subp);
+
+            --  If only one Argument defaults are :
+            --    . DTC_Entity is the default Vtable pointer
+            --    . DT_Position will be set at the freezing point
+
+            if Arg_Count = 1 then
+               Set_DTC_Entity (Subp, Tag_Component (Typ));
+               return;
+            end if;
+
+            --  Second argument is a component name of type Vtable_Ptr
+
+            Arg := Expression (Arg2);
+
+            if Nkind (Arg) /= N_Identifier then
+               Error_Msg_NE ("must be a& component name", Arg, Typ);
+               raise Pragma_Exit;
+            end if;
+
+            DTC := First_Component (Typ);
+            while Present (DTC) and then Chars (DTC) /= Chars (Arg) loop
+               Next_Component (DTC);
+            end loop;
+
+            if No (DTC) then
+               Error_Msg_NE ("must be a& component name", Arg, Typ);
+               raise Pragma_Exit;
+
+            elsif Etype (DTC) /= VTP_Type then
+               Wrong_Type (Arg, VTP_Type);
+               return;
+            end if;
+
+            --  Third argument is an integer (DT_Position)
+
+            Arg := Expression (Arg3);
+            Analyze_And_Resolve (Arg, Any_Integer);
+
+            if not Is_Static_Expression (Arg) then
+               Error_Pragma_Arg
+                 ("third argument of pragma% must be a static expression",
+                  Arg3);
+
+            else
+               V := Expr_Value (Expression (Arg3));
+
+               if V <= 0 then
+                  Error_Pragma_Arg
+                    ("third argument of pragma% must be positive",
+                     Arg3);
+
+               else
+                  Set_DTC_Entity (Subp, DTC);
+                  Set_DT_Position (Subp, V);
+               end if;
+            end if;
+         end CPP_Virtual;
+
+         ----------------
+         -- CPP_Vtable --
+         ----------------
+
+         --  pragma CPP_Vtable (
+         --    [Entity =>]       LOCAL_NAME
+         --    [Vtable_Ptr =>]   LOCAL_NAME,
+         --    [Entry_Count =>]  static_integer_EXPRESSION);
+
+         when Pragma_CPP_Vtable => CPP_Vtable : declare
+            Arg      : Node_Id;
+            Typ      : Entity_Id;
+            VTP_Type : constant Entity_Id  := RTE (RE_Vtable_Ptr);
+            DTC      : Entity_Id;
+            V        : Uint;
+            Elmt     : Elmt_Id;
+
+         begin
+            GNAT_Pragma;
+            Check_Arg_Count (3);
+            Check_Optional_Identifier (Arg1, Name_Entity);
+            Check_Optional_Identifier (Arg2, "vtable_ptr");
+            Check_Optional_Identifier (Arg3, "entry_count");
+            Check_Arg_Is_Local_Name (Arg1);
+
+            --  First argument is a record type name
+
+            Arg := Expression (Arg1);
+            Analyze (Arg);
+
+            if Etype (Arg) = Any_Type then
+               return;
+            else
+               Typ := Entity (Arg);
+            end if;
+
+            if not (Is_Tagged_Type (Typ) and then Is_CPP_Class (Typ)) then
+               Error_Pragma_Arg ("'C'P'P_Class tagged type expected", Arg1);
+            end if;
+
+            --  Second argument is a component name of type Vtable_Ptr
+
+            Arg := Expression (Arg2);
+
+            if Nkind (Arg) /= N_Identifier then
+               Error_Msg_NE ("must be a& component name", Arg, Typ);
+               raise Pragma_Exit;
+            end if;
+
+            DTC := First_Component (Typ);
+            while Present (DTC) and then Chars (DTC) /= Chars (Arg) loop
+               Next_Component (DTC);
+            end loop;
+
+            if No (DTC) then
+               Error_Msg_NE ("must be a& component name", Arg, Typ);
+               raise Pragma_Exit;
+
+            elsif Etype (DTC) /= VTP_Type then
+               Wrong_Type (DTC, VTP_Type);
+               return;
+
+            --  If it is the first pragma Vtable, This becomes the default tag
+
+            elsif (not Is_Tag (DTC))
+              and then DT_Entry_Count (Tag_Component (Typ)) = No_Uint
+            then
+               Set_Is_Tag (Tag_Component (Typ), False);
+               Set_Is_Tag (DTC, True);
+               Set_DT_Entry_Count (DTC, No_Uint);
+            end if;
+
+            --  Those pragmas must appear before any primitive operation
+            --  definition (except inherited ones) otherwise the default
+            --  may be wrong
+
+            Elmt := First_Elmt (Primitive_Operations (Typ));
+            while Present (Elmt) loop
+               if No (Alias (Node (Elmt))) then
+                  Error_Msg_Sloc := Sloc (Node (Elmt));
+                  Error_Pragma
+                    ("pragma% must appear before this primitive operation");
+               end if;
+
+               Next_Elmt (Elmt);
+            end loop;
+
+            --  Third argument is an integer (DT_Entry_Count)
+
+            Arg := Expression (Arg3);
+            Analyze_And_Resolve (Arg, Any_Integer);
+
+            if not Is_Static_Expression (Arg) then
+               Error_Pragma_Arg
+                 ("entry count for pragma% must be a static expression", Arg3);
+
+            else
+               V := Expr_Value (Expression (Arg3));
+
+               if V <= 0 then
+                  Error_Pragma_Arg
+                    ("entry count for pragma% must be positive", Arg3);
+               else
+                  Set_DT_Entry_Count (DTC, V);
+               end if;
+            end if;
+
+         end CPP_Vtable;
+
+         -----------
+         -- Debug --
+         -----------
+
+         --  pragma Debug (PROCEDURE_CALL_STATEMENT);
+
+         when Pragma_Debug => Debug : begin
+            GNAT_Pragma;
+
+            --  If assertions are enabled, and we are expanding code, then
+            --  we rewrite the pragma with its corresponding procedure call
+            --  and then analyze the call.
+
+            if Assertions_Enabled and Expander_Active then
+               Rewrite (N, Relocate_Node (Debug_Statement (N)));
+               Analyze (N);
+
+            --  Otherwise we work a bit to get a tree that makes sense
+            --  for ASIS purposes, namely a pragma with an analyzed
+            --  argument that looks like a procedure call.
+
+            else
+               Expander_Mode_Save_And_Set (False);
+               Rewrite (N, Relocate_Node (Debug_Statement (N)));
+               Analyze (N);
+               Rewrite (N,
+                 Make_Pragma (Loc,
+                   Chars => Name_Debug,
+                   Pragma_Argument_Associations =>
+                     New_List (Relocate_Node (N))));
+               Expander_Mode_Restore;
+            end if;
+         end Debug;
+
+         -------------------
+         -- Discard_Names --
+         -------------------
+
+         --  pragma Discard_Names [([On =>] LOCAL_NAME)];
+
+         when Pragma_Discard_Names => Discard_Names : declare
+            E_Id : Entity_Id;
+            E    : Entity_Id;
+
+         begin
+            GNAT_Pragma;
+            Check_Ada_83_Warning;
+
+            --  Deal with configuration pragma case
+
+            if Arg_Count = 0 and then Is_Configuration_Pragma then
+               Global_Discard_Names := True;
+               return;
+
+            --  Otherwise, check correct appropriate context
+
+            else
+               Check_Is_In_Decl_Part_Or_Package_Spec;
+
+               if Arg_Count = 0 then
+
+                  --  If there is no parameter, then from now on this pragma
+                  --  applies to any enumeration, exception or tagged type
+                  --  defined in the current declarative part.
+
+                  Set_Discard_Names (Current_Scope);
+                  return;
+
+               else
+                  Check_Arg_Count (1);
+                  Check_Optional_Identifier (Arg1, Name_On);
+                  Check_Arg_Is_Local_Name (Arg1);
+                  E_Id := Expression (Arg1);
+
+                  if Etype (E_Id) = Any_Type then
+                     return;
+                  else
+                     E := Entity (E_Id);
+                  end if;
+
+                  if (Is_First_Subtype (E)
+                       and then (Is_Enumeration_Type (E)
+                                  or else Is_Tagged_Type (E)))
+                    or else Ekind (E) = E_Exception
+                  then
+                     Set_Discard_Names (E);
+                  else
+                     Error_Pragma_Arg
+                       ("inappropriate entity for pragma%", Arg1);
+                  end if;
+               end if;
+            end if;
+         end Discard_Names;
+
+         ---------------
+         -- Elaborate --
+         ---------------
+
+         --  pragma Elaborate (library_unit_NAME {, library_unit_NAME});
+
+         when Pragma_Elaborate => Elaborate : declare
+            Plist       : List_Id;
+            Parent_Node : Node_Id;
+            Arg         : Node_Id;
+            Citem       : Node_Id;
+
+         begin
+            --  Pragma must be in context items list of a compilation unit
+
+            if not Is_List_Member (N) then
+               Pragma_Misplaced;
+               return;
+
+            else
+               Plist := List_Containing (N);
+               Parent_Node := Parent (Plist);
+
+               if Parent_Node = Empty
+                 or else Nkind (Parent_Node) /= N_Compilation_Unit
+                 or else Context_Items (Parent_Node) /= Plist
+               then
+                  Pragma_Misplaced;
+                  return;
+               end if;
+            end if;
+
+            --  Must be at least one argument
+
+            if Arg_Count = 0 then
+               Error_Pragma ("pragma% requires at least one argument");
+            end if;
+
+            --  In Ada 83 mode, there can be no items following it in the
+            --  context list except other pragmas and implicit with clauses
+            --  (e.g. those added by use of Rtsfind). In Ada 95 mode, this
+            --  placement rule does not apply.
+
+            if Ada_83 and then Comes_From_Source (N) then
+               Citem := Next (N);
+
+               while Present (Citem) loop
+                  if Nkind (Citem) = N_Pragma
+                    or else (Nkind (Citem) = N_With_Clause
+                              and then Implicit_With (Citem))
+                  then
+                     null;
+                  else
+                     Error_Pragma
+                       ("(Ada 83) pragma% must be at end of context clause");
+                  end if;
+
+                  Next (Citem);
+               end loop;
+            end if;
+
+            --  Finally, the arguments must all be units mentioned in a with
+            --  clause in the same context clause. Note we already checked
+            --  (in Par.Prag) that the arguments are either identifiers or
+
+            Arg := Arg1;
+            Outer : while Present (Arg) loop
+               Citem := First (Plist);
+
+               Inner : while Citem /= N loop
+                  if Nkind (Citem) = N_With_Clause
+                    and then Same_Name (Name (Citem), Expression (Arg))
+                  then
+                     Set_Elaborate_Present (Citem, True);
+                     Set_Unit_Name (Expression (Arg), Name (Citem));
+                     Set_Suppress_Elaboration_Warnings (Entity (Name (Citem)));
+                     exit Inner;
+                  end if;
+
+                  Next (Citem);
+               end loop Inner;
+
+               if Citem = N then
+                  Error_Pragma_Arg
+                    ("argument of pragma% is not with'ed unit", Arg);
+               end if;
+
+               Next (Arg);
+            end loop Outer;
+         end Elaborate;
+
+         -------------------
+         -- Elaborate_All --
+         -------------------
+
+         --  pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
+
+         when Pragma_Elaborate_All => Elaborate_All : declare
+            Plist       : List_Id;
+            Parent_Node : Node_Id;
+            Arg         : Node_Id;
+            Citem       : Node_Id;
+
+         begin
+            Check_Ada_83_Warning;
+
+            --  Pragma must be in context items list of a compilation unit
+
+            if not Is_List_Member (N) then
+               Pragma_Misplaced;
+               return;
+
+            else
+               Plist := List_Containing (N);
+               Parent_Node := Parent (Plist);
+
+               if Parent_Node = Empty
+                 or else Nkind (Parent_Node) /= N_Compilation_Unit
+                 or else Context_Items (Parent_Node) /= Plist
+               then
+                  Pragma_Misplaced;
+                  return;
+               end if;
+            end if;
+
+            --  Must be at least one argument
+
+            if Arg_Count = 0 then
+               Error_Pragma ("pragma% requires at least one argument");
+            end if;
+
+            --  Note: unlike pragma Elaborate, pragma Elaborate_All does not
+            --  have to appear at the end of the context clause, but may
+            --  appear mixed in with other items, even in Ada 83 mode.
+
+            --  Final check: the arguments must all be units mentioned in
+            --  a with clause in the same context clause. Note that we
+            --  already checked (in Par.Prag) that all the arguments are
+            --  either identifiers or selected components.
+
+            Arg := Arg1;
+            Outr : while Present (Arg) loop
+               Citem := First (Plist);
+
+               Innr : while Citem /= N loop
+                  if Nkind (Citem) = N_With_Clause
+                    and then Same_Name (Name (Citem), Expression (Arg))
+                  then
+                     Set_Elaborate_All_Present (Citem, True);
+                     Set_Unit_Name (Expression (Arg), Name (Citem));
+                     Set_Suppress_Elaboration_Warnings (Entity (Name (Citem)));
+                     exit Innr;
+                  end if;
+
+                  Next (Citem);
+               end loop Innr;
+
+               if Citem = N then
+                  Error_Pragma_Arg
+                    ("argument of pragma% is not with'ed unit", Arg);
+               end if;
+
+               Next (Arg);
+            end loop Outr;
+         end Elaborate_All;
+
+         --------------------
+         -- Elaborate_Body --
+         --------------------
+
+         --  pragma Elaborate_Body [( library_unit_NAME )];
+
+         when Pragma_Elaborate_Body => Elaborate_Body : declare
+            Cunit_Node : Node_Id;
+            Cunit_Ent  : Entity_Id;
+
+         begin
+            Check_Ada_83_Warning;
+            Check_Valid_Library_Unit_Pragma;
+
+            if Nkind (N) = N_Null_Statement then
+               return;
+            end if;
+
+            Cunit_Node := Cunit (Current_Sem_Unit);
+            Cunit_Ent  := Cunit_Entity (Current_Sem_Unit);
+
+            if Nkind (Unit (Cunit_Node)) = N_Package_Body
+                 or else
+               Nkind (Unit (Cunit_Node)) = N_Subprogram_Body
+            then
+               Error_Pragma ("pragma% must refer to a spec, not a body");
+            else
+               Set_Body_Required (Cunit_Node, True);
+               Set_Has_Pragma_Elaborate_Body     (Cunit_Ent);
+
+               --  If we are in dynamic elaboration mode, then we suppress
+               --  elaboration warnings for the unit, since it is definitely
+               --  fine NOT to do dynamic checks at the first level (and such
+               --  checks will be suppressed because no elaboration boolean
+               --  is created for Elaborate_Body packages).
+
+               --  But in the static model of elaboration, Elaborate_Body is
+               --  definitely NOT good enough to ensure elaboration safety on
+               --  its own, since the body may WITH other units that are not
+               --  safe from an elaboration point of view, so a client must
+               --  still do an Elaborate_All on such units.
+
+               --  Debug flag -gnatdD restores the old behavior of 3.13,
+               --  where Elaborate_Body always suppressed elab warnings.
+
+               if Dynamic_Elaboration_Checks or Debug_Flag_DD then
+                  Set_Suppress_Elaboration_Warnings (Cunit_Ent);
+               end if;
+            end if;
+         end Elaborate_Body;
+
+         ------------------------
+         -- Elaboration_Checks --
+         ------------------------
+
+         --  pragma Elaboration_Checks (Static | Dynamic);
+
+         when Pragma_Elaboration_Checks =>
+            GNAT_Pragma;
+            Check_Arg_Count (1);
+            Check_Arg_Is_One_Of (Arg1, Name_Static, Name_Dynamic);
+            Dynamic_Elaboration_Checks :=
+              (Chars (Get_Pragma_Arg (Arg1)) = Name_Dynamic);
+
+         ---------------
+         -- Eliminate --
+         ---------------
+
+         --  pragma Eliminate (
+         --      [Unit_Name       =>]  IDENTIFIER |
+         --                            SELECTED_COMPONENT
+         --    [,[Entity          =>]  IDENTIFIER |
+         --                            SELECTED_COMPONENT |
+         --                            STRING_LITERAL]
+         --    [,[Parameter_Types =>]  PARAMETER_TYPES]
+         --    [,[Result_Type     =>]  result_SUBTYPE_MARK]);
+
+         --  PARAMETER_TYPES ::=
+         --    null
+         --    (SUBTYPE_MARK, SUBTYPE_MARK, ...)
+
+         when Pragma_Eliminate => Eliminate : begin
+            GNAT_Pragma;
+            Check_Ada_83_Warning;
+            Check_Valid_Configuration_Pragma;
+            Check_At_Least_N_Arguments (1);
+            Check_At_Most_N_Arguments (4);
+
+            if Arg_Count = 3
+              and then Chars (Arg3) = Name_Result_Type
+            then
+               Arg4 := Arg3;
+               Arg3 := Empty;
+
+            else
+               Check_Optional_Identifier (Arg1, "unit_name");
+               Check_Optional_Identifier (Arg2, Name_Entity);
+               Check_Optional_Identifier (Arg3, Name_Parameter_Types);
+               Check_Optional_Identifier (Arg4, Name_Result_Type);
+            end if;
+
+            Process_Eliminate_Pragma (Arg1, Arg2, Arg3, Arg4);
+         end Eliminate;
+
+         ------------
+         -- Export --
+         ------------
+
+         --  pragma Export (
+         --    [   Convention    =>] convention_IDENTIFIER,
+         --    [   Entity        =>] local_NAME
+         --    [, [External_Name =>] static_string_EXPRESSION ]
+         --    [, [Link_Name     =>] static_string_EXPRESSION ]);
+
+         when Pragma_Export => Export : declare
+            C      : Convention_Id;
+            Def_Id : Entity_Id;
+
+         begin
+            Check_Ada_83_Warning;
+            Check_At_Least_N_Arguments (2);
+            Check_At_Most_N_Arguments  (4);
+            Process_Convention (C, Def_Id);
+            Note_Possible_Modification (Expression (Arg2));
+            Process_Interface_Name (Def_Id, Arg3, Arg4);
+            Set_Exported (Def_Id, Arg2);
+         end Export;
+
+         ----------------------
+         -- Export_Exception --
+         ----------------------
+
+         --  pragma Export_Exception (
+         --        [Internal         =>] LOCAL_NAME,
+         --     [, [External         =>] EXTERNAL_SYMBOL,]
+         --     [, [Form     =>] Ada | VMS]
+         --     [, [Code     =>] static_integer_EXPRESSION]);
+
+         when Pragma_Export_Exception => Export_Exception : declare
+            Args  : Args_List (1 .. 4);
+            Names : Name_List (1 .. 4) := (
+                      Name_Internal,
+                      Name_External,
+                      Name_Form,
+                      Name_Code);
+
+            Internal : Node_Id renames Args (1);
+            External : Node_Id renames Args (2);
+            Form     : Node_Id renames Args (3);
+            Code     : Node_Id renames Args (4);
+
+         begin
+            GNAT_Pragma;
+
+            if Inside_A_Generic then
+               Error_Pragma ("pragma% cannot be used for generic entities");
+            end if;
+
+            Gather_Associations (Names, Args);
+            Process_Extended_Import_Export_Exception_Pragma (
+              Arg_Internal => Internal,
+              Arg_External => External,
+              Arg_Form     => Form,
+              Arg_Code     => Code);
+
+            if not Is_VMS_Exception (Entity (Internal)) then
+               Set_Exported (Entity (Internal), Internal);
+            end if;
+
+         end Export_Exception;
+
+         ---------------------
+         -- Export_Function --
+         ---------------------
+
+         --  pragma Export_Function (
+         --        [Internal         =>] LOCAL_NAME,
+         --     [, [External         =>] EXTERNAL_SYMBOL,]
+         --     [, [Parameter_Types  =>] (PARAMETER_TYPES)]
+         --     [, [Result_Type      =>] SUBTYPE_MARK]
+         --     [, [Mechanism        =>] MECHANISM]
+         --     [, [Result_Mechanism =>] MECHANISM_NAME]);
+
+         when Pragma_Export_Function => Export_Function : declare
+            Args  : Args_List (1 .. 6);
+            Names : Name_List (1 .. 6) := (
+                      Name_Internal,
+                      Name_External,
+                      Name_Parameter_Types,
+                      Name_Result_Type,
+                      Name_Mechanism,
+                      Name_Result_Mechanism);
+
+            Internal         : Node_Id renames Args (1);
+            External         : Node_Id renames Args (2);
+            Parameter_Types  : Node_Id renames Args (3);
+            Result_Type      : Node_Id renames Args (4);
+            Mechanism        : Node_Id renames Args (5);
+            Result_Mechanism : Node_Id renames Args (6);
+
+         begin
+            GNAT_Pragma;
+            Gather_Associations (Names, Args);
+            Process_Extended_Import_Export_Subprogram_Pragma (
+              Arg_Internal         => Internal,
+              Arg_External         => External,
+              Arg_Parameter_Types  => Parameter_Types,
+              Arg_Result_Type      => Result_Type,
+              Arg_Mechanism        => Mechanism,
+              Arg_Result_Mechanism => Result_Mechanism);
+         end Export_Function;
+
+         -------------------
+         -- Export_Object --
+         -------------------
+
+         --  pragma Export_Object (
+         --        [Internal =>] LOCAL_NAME,
+         --     [, [External =>] EXTERNAL_SYMBOL]
+         --     [, [Size     =>] EXTERNAL_SYMBOL]);
+
+         when Pragma_Export_Object => Export_Object : declare
+            Args  : Args_List (1 .. 3);
+            Names : Name_List (1 .. 3) := (
+                      Name_Internal,
+                      Name_External,
+                      Name_Size);
+
+            Internal : Node_Id renames Args (1);
+            External : Node_Id renames Args (2);
+            Size     : Node_Id renames Args (3);
+
+         begin
+            GNAT_Pragma;
+            Gather_Associations (Names, Args);
+            Process_Extended_Import_Export_Object_Pragma (
+              Arg_Internal => Internal,
+              Arg_External => External,
+              Arg_Size     => Size);
+         end Export_Object;
+
+         ----------------------
+         -- Export_Procedure --
+         ----------------------
+
+         --  pragma Export_Procedure (
+         --        [Internal         =>] LOCAL_NAME,
+         --     [, [External         =>] EXTERNAL_SYMBOL,]
+         --     [, [Parameter_Types  =>] (PARAMETER_TYPES)]
+         --     [, [Mechanism        =>] MECHANISM]);
+
+         when Pragma_Export_Procedure => Export_Procedure : declare
+            Args  : Args_List (1 .. 4);
+            Names : Name_List (1 .. 4) := (
+                      Name_Internal,
+                      Name_External,
+                      Name_Parameter_Types,
+                      Name_Mechanism);
+
+            Internal        : Node_Id renames Args (1);
+            External        : Node_Id renames Args (2);
+            Parameter_Types : Node_Id renames Args (3);
+            Mechanism       : Node_Id renames Args (4);
+
+         begin
+            GNAT_Pragma;
+            Gather_Associations (Names, Args);
+            Process_Extended_Import_Export_Subprogram_Pragma (
+              Arg_Internal        => Internal,
+              Arg_External        => External,
+              Arg_Parameter_Types => Parameter_Types,
+              Arg_Mechanism       => Mechanism);
+         end Export_Procedure;
+
+         -----------------------------
+         -- Export_Valued_Procedure --
+         -----------------------------
+
+         --  pragma Export_Valued_Procedure (
+         --        [Internal         =>] LOCAL_NAME,
+         --     [, [External         =>] EXTERNAL_SYMBOL,]
+         --     [, [Parameter_Types  =>] (PARAMETER_TYPES)]
+         --     [, [Mechanism        =>] MECHANISM]);
+
+         when Pragma_Export_Valued_Procedure =>
+         Export_Valued_Procedure : declare
+            Args  : Args_List (1 .. 4);
+            Names : Name_List (1 .. 4) := (
+                      Name_Internal,
+                      Name_External,
+                      Name_Parameter_Types,
+                      Name_Mechanism);
+
+            Internal        : Node_Id renames Args (1);
+            External        : Node_Id renames Args (2);
+            Parameter_Types : Node_Id renames Args (3);
+            Mechanism       : Node_Id renames Args (4);
+
+         begin
+            GNAT_Pragma;
+            Gather_Associations (Names, Args);
+            Process_Extended_Import_Export_Subprogram_Pragma (
+              Arg_Internal        => Internal,
+              Arg_External        => External,
+              Arg_Parameter_Types => Parameter_Types,
+              Arg_Mechanism       => Mechanism);
+         end Export_Valued_Procedure;
+
+         -------------------
+         -- Extend_System --
+         -------------------
+
+         --  pragma Extend_System ([Name =>] Identifier);
+
+         when Pragma_Extend_System => Extend_System : declare
+         begin
+            GNAT_Pragma;
+            Check_Valid_Configuration_Pragma;
+            Check_Arg_Count (1);
+            Check_Optional_Identifier (Arg1, Name_Name);
+            Check_Arg_Is_Identifier (Arg1);
+
+            Get_Name_String (Chars (Expression (Arg1)));
+
+            if Name_Len > 4
+              and then Name_Buffer (1 .. 4) = "aux_"
+            then
+               if Present (System_Extend_Pragma_Arg) then
+                  if Chars (Expression (Arg1)) =
+                     Chars (Expression (System_Extend_Pragma_Arg))
+                  then
+                     null;
+                  else
+                     Error_Msg_Sloc := Sloc (System_Extend_Pragma_Arg);
+                     Error_Pragma ("pragma% conflicts with that at#");
+                  end if;
+
+               else
+                  System_Extend_Pragma_Arg := Arg1;
+               end if;
+            else
+               Error_Pragma ("incorrect name for pragma%, must be Aux_xxx");
+            end if;
+         end Extend_System;
+
+         ------------------------
+         -- Extensions_Allowed --
+         ------------------------
+
+         --  pragma Extensions_Allowed (ON | OFF);
+
+         when Pragma_Extensions_Allowed =>
+            GNAT_Pragma;
+            Check_Arg_Count (1);
+            Check_No_Identifiers;
+            Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
+            Extensions_Allowed := (Chars (Expression (Arg1)) = Name_On);
+
+         --------------------------
+         -- External_Name_Casing --
+         --------------------------
+
+         --  pragma External_Name_Casing (
+         --    UPPERCASE | LOWERCASE
+         --    [, AS_IS | UPPERCASE | LOWERCASE]);
+
+         when Pragma_External_Name_Casing =>
+
+         External_Name_Casing : declare
+         begin
+            GNAT_Pragma;
+            Check_No_Identifiers;
+
+            if Arg_Count = 2 then
+               Check_Arg_Is_One_Of
+                 (Arg2, Name_As_Is, Name_Uppercase, Name_Lowercase);
+
+               case Chars (Get_Pragma_Arg (Arg2)) is
+                  when Name_As_Is     =>
+                     Opt.External_Name_Exp_Casing := As_Is;
+
+                  when Name_Uppercase =>
+                     Opt.External_Name_Exp_Casing := Uppercase;
+
+                  when Name_Lowercase =>
+                     Opt.External_Name_Exp_Casing := Lowercase;
+
+                  when others =>
+                     null;
+               end case;
+
+            else
+               Check_Arg_Count (1);
+            end if;
+
+            Check_Arg_Is_One_Of (Arg1, Name_Uppercase, Name_Lowercase);
+
+            case Chars (Get_Pragma_Arg (Arg1)) is
+               when Name_Uppercase =>
+                  Opt.External_Name_Imp_Casing := Uppercase;
+
+               when Name_Lowercase =>
+                  Opt.External_Name_Imp_Casing := Lowercase;
+
+               when others =>
+                  null;
+            end case;
+
+         end External_Name_Casing;
+
+         ---------------------------
+         -- Finalize_Storage_Only --
+         ---------------------------
+
+         --  pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
+
+         when Pragma_Finalize_Storage_Only => Finalize_Storage : declare
+            Assoc   : Node_Id := Arg1;
+            Type_Id : Node_Id := Expression (Assoc);
+            Typ     : Entity_Id;
+
+         begin
+            Check_No_Identifiers;
+            Check_Arg_Count (1);
+            Check_Arg_Is_Local_Name (Arg1);
+
+            Find_Type (Type_Id);
+            Typ := Entity (Type_Id);
+
+            if Typ = Any_Type
+              or else Rep_Item_Too_Early (Typ, N)
+            then
+               return;
+            else
+               Typ := Underlying_Type (Typ);
+            end if;
+
+            if not Is_Controlled (Typ) then
+               Error_Pragma ("pragma% must specify controlled type");
+            end if;
+
+            Check_First_Subtype (Arg1);
+
+            if Finalize_Storage_Only (Typ) then
+               Error_Pragma ("duplicate pragma%, only one allowed");
+
+            elsif not Rep_Item_Too_Late (Typ, N) then
+               Set_Finalize_Storage_Only (Typ, True);
+            end if;
+         end Finalize_Storage;
+
+         --------------------------
+         -- Float_Representation --
+         --------------------------
+
+         --  pragma Float_Representation (VAX_Float | IEEE_Float);
+
+         when Pragma_Float_Representation => Float_Representation : declare
+            Argx : Node_Id;
+            Digs : Nat;
+            Ent  : Entity_Id;
+
+         begin
+            GNAT_Pragma;
+
+            if Arg_Count = 1 then
+               Check_Valid_Configuration_Pragma;
+            else
+               Check_Arg_Count (2);
+               Check_Optional_Identifier (Arg2, Name_Entity);
+               Check_Arg_Is_Local_Name (Arg2);
+            end if;
+
+            Check_No_Identifier (Arg1);
+            Check_Arg_Is_One_Of (Arg1, Name_VAX_Float, Name_IEEE_Float);
+
+            if not OpenVMS_On_Target then
+               if Chars (Expression (Arg1)) = Name_VAX_Float then
+                  Error_Pragma
+                    ("?pragma% ignored (applies only to Open'V'M'S)");
+               end if;
+
+               return;
+            end if;
+
+            --  One argument case
+
+            if Arg_Count = 1 then
+
+               if Chars (Expression (Arg1)) = Name_VAX_Float then
+
+                  if Opt.Float_Format = 'I' then
+                     Error_Pragma ("'I'E'E'E format previously specified");
+                  end if;
+
+                  Opt.Float_Format := 'V';
+
+               else
+                  if Opt.Float_Format = 'V' then
+                     Error_Pragma ("'V'A'X format previously specified");
+                  end if;
+
+                  Opt.Float_Format := 'I';
+               end if;
+
+               Set_Standard_Fpt_Formats;
+
+            --  Two argument case
+
+            else
+               Argx := Get_Pragma_Arg (Arg2);
+
+               if not Is_Entity_Name (Argx)
+                 or else not Is_Floating_Point_Type (Entity (Argx))
+               then
+                  Error_Pragma_Arg
+                    ("second argument of% pragma must be floating-point type",
+                     Arg2);
+               end if;
+
+               Ent  := Entity (Argx);
+               Digs := UI_To_Int (Digits_Value (Ent));
+
+               --  Two arguments, VAX_Float case
+
+               if Chars (Expression (Arg1)) = Name_VAX_Float then
+
+                  case Digs is
+                     when  6 => Set_F_Float (Ent);
+                     when  9 => Set_D_Float (Ent);
+                     when 15 => Set_G_Float (Ent);
+
+                     when others =>
+                        Error_Pragma_Arg
+                          ("wrong digits value, must be 6,9 or 15", Arg2);
+                  end case;
+
+               --  Two arguments, IEEE_Float case
+
+               else
+                  case Digs is
+                     when  6 => Set_IEEE_Short (Ent);
+                     when 15 => Set_IEEE_Long  (Ent);
+
+                     when others =>
+                        Error_Pragma_Arg
+                          ("wrong digits value, must be 6 or 15", Arg2);
+                  end case;
+               end if;
+            end if;
+
+         end Float_Representation;
+
+         -----------
+         -- Ident --
+         -----------
+
+         --  pragma Ident (static_string_EXPRESSION)
+
+         --  Note: pragma Comment shares this processing. Pragma Comment
+         --  is identical to Ident, except that the restriction of the
+         --  argument to 31 characters and the placement restrictions
+         --  are not enforced for pragma Comment.
+
+         when Pragma_Ident | Pragma_Comment => Ident : declare
+            Str : Node_Id;
+
+         begin
+            GNAT_Pragma;
+            Check_Arg_Count (1);
+            Check_No_Identifiers;
+            Check_Arg_Is_Static_Expression (Arg1, Standard_String);
+
+            --  For pragma Ident, preserve DEC compatibility by requiring
+            --  the pragma to appear in a declarative part or package spec.
+
+            if Prag_Id = Pragma_Ident then
+               Check_Is_In_Decl_Part_Or_Package_Spec;
+            end if;
+
+            Str := Expr_Value_S (Expression (Arg1));
+
+            --  For pragma Ident, preserve DEC compatibility by limiting
+            --  the length to 31 characters.
+
+            if Prag_Id = Pragma_Ident
+              and then String_Length (Strval (Str)) > 31
+            then
+               Error_Pragma_Arg
+                 ("argument for pragma% is too long, maximum is 31", Arg1);
+            end if;
+
+            declare
+               CS : Node_Id;
+               GP : Node_Id;
+
+            begin
+               GP := Parent (Parent (N));
+
+               if Nkind (GP) = N_Package_Declaration
+                    or else
+                  Nkind (GP) = N_Generic_Package_Declaration
+               then
+                  GP := Parent (GP);
+               end if;
+
+               --  If we have a compilation unit, then record the ident
+               --  value, checking for improper duplication.
+
+               if Nkind (GP) = N_Compilation_Unit then
+                  CS := Ident_String (Current_Sem_Unit);
+
+                  if Present (CS) then
+
+                     --  For Ident, we do not permit multiple instances
+
+                     if Prag_Id = Pragma_Ident then
+                        Error_Pragma ("duplicate% pragma not permitted");
+
+                     --  For Comment, we concatenate the string, unless we
+                     --  want to preserve the tree structure for ASIS.
+
+                     elsif not Tree_Output then
+                        Start_String (Strval (CS));
+                        Store_String_Char (' ');
+                        Store_String_Chars (Strval (Str));
+                        Set_Strval (CS, End_String);
+                     end if;
+
+                  else
+                     --  In VMS, the effect of IDENT is achieved by passing
+                     --  IDENTIFICATION=name as a --for-linker switch.
+
+                     if OpenVMS_On_Target then
+                        Start_String;
+                        Store_String_Chars
+                          ("--for-linker=IDENTIFICATION=");
+                        String_To_Name_Buffer (Strval (Str));
+                        Store_String_Chars (Name_Buffer (1 .. Name_Len));
+
+                        --  Only the last processed IDENT is saved. The main
+                        --  purpose is so an IDENT associated with a main
+                        --  procedure will be used in preference to an IDENT
+                        --  associated with a with'd package.
+
+                        Replace_Linker_Option_String
+                          (End_String, "--for-linker=IDENTIFICATION=");
+                     end if;
+
+                     Set_Ident_String (Current_Sem_Unit, Str);
+                  end if;
+
+               --  For subunits, we just ignore the Ident, since in GNAT
+               --  these are not separate object files, and hence not
+               --  separate units in the unit table.
+
+               elsif Nkind (GP) = N_Subunit then
+                  null;
+
+               --  Otherwise we have a misplaced pragma Ident, but we ignore
+               --  this if we are in an instantiation, since it comes from
+               --  a generic, and has no relevance to the instantiation.
+
+               elsif Prag_Id = Pragma_Ident then
+                  if Instantiation_Location (Loc) = No_Location then
+                     Error_Pragma ("pragma% only allowed at outer level");
+                  end if;
+               end if;
+            end;
+         end Ident;
+
+         ------------
+         -- Import --
+         ------------
+
+         --  pragma Import (
+         --    [   Convention    =>] convention_IDENTIFIER,
+         --    [   Entity        =>] local_NAME
+         --    [, [External_Name =>] static_string_EXPRESSION ]
+         --    [, [Link_Name     =>] static_string_EXPRESSION ]);
+
+         when Pragma_Import =>
+            Check_Ada_83_Warning;
+            Check_At_Least_N_Arguments (2);
+            Check_At_Most_N_Arguments  (4);
+            Process_Import_Or_Interface;
+
+         ----------------------
+         -- Import_Exception --
+         ----------------------
+
+         --  pragma Import_Exception (
+         --        [Internal         =>] LOCAL_NAME,
+         --     [, [External         =>] EXTERNAL_SYMBOL,]
+         --     [, [Form     =>] Ada | VMS]
+         --     [, [Code     =>] static_integer_EXPRESSION]);
+
+         when Pragma_Import_Exception => Import_Exception : declare
+            Args  : Args_List (1 .. 4);
+            Names : Name_List (1 .. 4) := (
+                      Name_Internal,
+                      Name_External,
+                      Name_Form,
+                      Name_Code);
+
+            Internal : Node_Id renames Args (1);
+            External : Node_Id renames Args (2);
+            Form     : Node_Id renames Args (3);
+            Code     : Node_Id renames Args (4);
+
+         begin
+            GNAT_Pragma;
+            Gather_Associations (Names, Args);
+
+            if Present (External) and then Present (Code) then
+               Error_Pragma
+                 ("cannot give both External and Code options for pragma%");
+            end if;
+
+            Process_Extended_Import_Export_Exception_Pragma (
+              Arg_Internal => Internal,
+              Arg_External => External,
+              Arg_Form     => Form,
+              Arg_Code     => Code);
+
+            if not Is_VMS_Exception (Entity (Internal)) then
+               Set_Imported (Entity (Internal));
+            end if;
+
+         end Import_Exception;
+
+         ---------------------
+         -- Import_Function --
+         ---------------------
+
+         --  pragma Import_Function (
+         --        [Internal                 =>] LOCAL_NAME,
+         --     [, [External                 =>] EXTERNAL_SYMBOL]
+         --     [, [Parameter_Types          =>] (PARAMETER_TYPES)]
+         --     [, [Result_Type              =>] SUBTYPE_MARK]
+         --     [, [Mechanism                =>] MECHANISM]
+         --     [, [Result_Mechanism         =>] MECHANISM_NAME]
+         --     [, [First_Optional_Parameter =>] IDENTIFIER]);
+
+         when Pragma_Import_Function => Import_Function : declare
+            Args  : Args_List (1 .. 7);
+            Names : Name_List (1 .. 7) := (
+                      Name_Internal,
+                      Name_External,
+                      Name_Parameter_Types,
+                      Name_Result_Type,
+                      Name_Mechanism,
+                      Name_Result_Mechanism,
+                      Name_First_Optional_Parameter);
+
+            Internal                 : Node_Id renames Args (1);
+            External                 : Node_Id renames Args (2);
+            Parameter_Types          : Node_Id renames Args (3);
+            Result_Type              : Node_Id renames Args (4);
+            Mechanism                : Node_Id renames Args (5);
+            Result_Mechanism         : Node_Id renames Args (6);
+            First_Optional_Parameter : Node_Id renames Args (7);
+
+         begin
+            GNAT_Pragma;
+            Gather_Associations (Names, Args);
+            Process_Extended_Import_Export_Subprogram_Pragma (
+              Arg_Internal                 => Internal,
+              Arg_External                 => External,
+              Arg_Parameter_Types          => Parameter_Types,
+              Arg_Result_Type              => Result_Type,
+              Arg_Mechanism                => Mechanism,
+              Arg_Result_Mechanism         => Result_Mechanism,
+              Arg_First_Optional_Parameter => First_Optional_Parameter);
+         end Import_Function;
+
+         -------------------
+         -- Import_Object --
+         -------------------
+
+         --  pragma Import_Object (
+         --        [Internal =>] LOCAL_NAME,
+         --     [, [External =>] EXTERNAL_SYMBOL]
+         --     [, [Size     =>] EXTERNAL_SYMBOL]);
+
+         when Pragma_Import_Object => Import_Object : declare
+            Args  : Args_List (1 .. 3);
+            Names : Name_List (1 .. 3) := (
+                      Name_Internal,
+                      Name_External,
+                      Name_Size);
+
+            Internal : Node_Id renames Args (1);
+            External : Node_Id renames Args (2);
+            Size     : Node_Id renames Args (3);
+
+         begin
+            GNAT_Pragma;
+            Gather_Associations (Names, Args);
+            Process_Extended_Import_Export_Object_Pragma (
+              Arg_Internal => Internal,
+              Arg_External => External,
+              Arg_Size     => Size);
+         end Import_Object;
+
+         ----------------------
+         -- Import_Procedure --
+         ----------------------
+
+         --  pragma Import_Procedure (
+         --        [Internal                 =>] LOCAL_NAME,
+         --     [, [External                 =>] EXTERNAL_SYMBOL]
+         --     [, [Parameter_Types          =>] (PARAMETER_TYPES)]
+         --     [, [Mechanism                =>] MECHANISM]
+         --     [, [First_Optional_Parameter =>] IDENTIFIER]);
+
+         when Pragma_Import_Procedure => Import_Procedure : declare
+            Args  : Args_List (1 .. 5);
+            Names : Name_List (1 .. 5) := (
+                      Name_Internal,
+                      Name_External,
+                      Name_Parameter_Types,
+                      Name_Mechanism,
+                      Name_First_Optional_Parameter);
+
+            Internal                 : Node_Id renames Args (1);
+            External                 : Node_Id renames Args (2);
+            Parameter_Types          : Node_Id renames Args (3);
+            Mechanism                : Node_Id renames Args (4);
+            First_Optional_Parameter : Node_Id renames Args (5);
+
+         begin
+            GNAT_Pragma;
+            Gather_Associations (Names, Args);
+            Process_Extended_Import_Export_Subprogram_Pragma (
+              Arg_Internal                 => Internal,
+              Arg_External                 => External,
+              Arg_Parameter_Types          => Parameter_Types,
+              Arg_Mechanism                => Mechanism,
+              Arg_First_Optional_Parameter => First_Optional_Parameter);
+         end Import_Procedure;
+
+         -----------------------------
+         -- Import_Valued_Procedure --
+         -----------------------------
+
+         --  pragma Import_Valued_Procedure (
+         --        [Internal                 =>] LOCAL_NAME,
+         --     [, [External                 =>] EXTERNAL_SYMBOL]
+         --     [, [Parameter_Types          =>] (PARAMETER_TYPES)]
+         --     [, [Mechanism                =>] MECHANISM]
+         --     [, [First_Optional_Parameter =>] IDENTIFIER]);
+
+         when Pragma_Import_Valued_Procedure =>
+         Import_Valued_Procedure : declare
+            Args  : Args_List (1 .. 5);
+            Names : Name_List (1 .. 5) := (
+                      Name_Internal,
+                      Name_External,
+                      Name_Parameter_Types,
+                      Name_Mechanism,
+                      Name_First_Optional_Parameter);
+
+            Internal                 : Node_Id renames Args (1);
+            External                 : Node_Id renames Args (2);
+            Parameter_Types          : Node_Id renames Args (3);
+            Mechanism                : Node_Id renames Args (4);
+            First_Optional_Parameter : Node_Id renames Args (5);
+
+         begin
+            GNAT_Pragma;
+            Gather_Associations (Names, Args);
+            Process_Extended_Import_Export_Subprogram_Pragma (
+              Arg_Internal                 => Internal,
+              Arg_External                 => External,
+              Arg_Parameter_Types          => Parameter_Types,
+              Arg_Mechanism                => Mechanism,
+              Arg_First_Optional_Parameter => First_Optional_Parameter);
+         end Import_Valued_Procedure;
+
+         ------------------------
+         -- Initialize_Scalars --
+         ------------------------
+
+         --  pragma Initialize_Scalars;
+
+         when Pragma_Initialize_Scalars =>
+            GNAT_Pragma;
+            Check_Arg_Count (0);
+            Check_Valid_Configuration_Pragma;
+            Init_Or_Norm_Scalars := True;
+            Initialize_Scalars := True;
+
+         ------------
+         -- Inline --
+         ------------
+
+         --  pragma Inline ( NAME {, NAME} );
+
+         when Pragma_Inline =>
+
+            --  Pragma is active if inlining option is active
+
+            if Inline_Active then
+               Process_Inline (True);
+
+            --  Pragma is active in a predefined file in no run time mode
+
+            elsif No_Run_Time
+              and then
+                Is_Predefined_File_Name (Unit_File_Name (Current_Sem_Unit))
+            then
+               Process_Inline (True);
+
+            else
+               Process_Inline (False);
+            end if;
+
+         -------------------
+         -- Inline_Always --
+         -------------------
+
+         --  pragma Inline_Always ( NAME {, NAME} );
+
+         when Pragma_Inline_Always =>
+            Process_Inline (True);
+
+         --------------------
+         -- Inline_Generic --
+         --------------------
+
+         --  pragma Inline_Generic (NAME {, NAME});
+
+         when Pragma_Inline_Generic =>
+            Process_Generic_List;
+
+         ----------------------
+         -- Inspection_Point --
+         ----------------------
+
+         --  pragma Inspection_Point [(object_NAME {, object_NAME})];
+
+         when Pragma_Inspection_Point => Inspection_Point : declare
+            Arg : Node_Id;
+            Exp : Node_Id;
+
+         begin
+            if Arg_Count > 0 then
+               Arg := Arg1;
+               loop
+                  Exp := Expression (Arg);
+                  Analyze (Exp);
+
+                  if not Is_Entity_Name (Exp)
+                    or else not Is_Object (Entity (Exp))
+                  then
+                     Error_Pragma_Arg ("object name required", Arg);
+                  end if;
+
+                  Next (Arg);
+                  exit when No (Arg);
+               end loop;
+            end if;
+         end Inspection_Point;
+
+         ---------------
+         -- Interface --
+         ---------------
+
+         --  pragma Interface (
+         --    convention_IDENTIFIER,
+         --    local_NAME );
+
+         when Pragma_Interface =>
+            GNAT_Pragma;
+            Check_Arg_Count (2);
+            Check_No_Identifiers;
+            Process_Import_Or_Interface;
+
+         --------------------
+         -- Interface_Name --
+         --------------------
+
+         --  pragma Interface_Name (
+         --    [  Entity        =>] local_NAME
+         --    [,[External_Name =>] static_string_EXPRESSION ]
+         --    [,[Link_Name     =>] static_string_EXPRESSION ]);
+
+         when Pragma_Interface_Name => Interface_Name : declare
+            Id     : Node_Id;
+            Def_Id : Entity_Id;
+            Hom_Id : Entity_Id;
+            Found  : Boolean;
+
+         begin
+            GNAT_Pragma;
+            Check_At_Least_N_Arguments (2);
+            Check_At_Most_N_Arguments  (3);
+            Id := Expression (Arg1);
+            Analyze (Id);
+
+            if not Is_Entity_Name (Id) then
+               Error_Pragma_Arg
+                 ("first argument for pragma% must be entity name", Arg1);
+            elsif Etype (Id) = Any_Type then
+               return;
+            else
+               Def_Id := Entity (Id);
+            end if;
+
+            --  Special DEC-compatible processing for the object case,
+            --  forces object to be imported.
+
+            if Ekind (Def_Id) = E_Variable then
+               Kill_Size_Check_Code (Def_Id);
+               Note_Possible_Modification (Id);
+
+               --  Initialization is not allowed for imported variable
+
+               if Present (Expression (Parent (Def_Id)))
+                 and then Comes_From_Source (Expression (Parent (Def_Id)))
+               then
+                  Error_Msg_Sloc := Sloc (Def_Id);
+                  Error_Pragma_Arg
+                    ("no initialization allowed for declaration of& #",
+                     Arg2);
+
+               else
+                  --  For compatibility, support VADS usage of providing both
+                  --  pragmas Interface and Interface_Name to obtain the effect
+                  --  of a single Import pragma.
+
+                  if Is_Imported (Def_Id)
+                    and then Present (First_Rep_Item (Def_Id))
+                    and then Nkind (First_Rep_Item (Def_Id)) = N_Pragma
+                    and then Chars (First_Rep_Item (Def_Id)) = Name_Interface
+                  then
+                     null;
+                  else
+                     Set_Imported (Def_Id);
+                  end if;
+
+                  Set_Is_Public (Def_Id);
+                  Process_Interface_Name (Def_Id, Arg2, Arg3);
+               end if;
+
+            --  Otherwise must be subprogram
+
+            elsif not Is_Subprogram (Def_Id) then
+               Error_Pragma_Arg
+                 ("argument of pragma% is not subprogram", Arg1);
+
+            else
+               Check_At_Most_N_Arguments (3);
+               Hom_Id := Def_Id;
+               Found := False;
+
+               --  Loop through homonyms
+
+               loop
+                  Def_Id := Get_Base_Subprogram (Hom_Id);
+
+                  if Is_Imported (Def_Id) then
+                     Process_Interface_Name (Def_Id, Arg2, Arg3);
+                     Found := True;
+                  end if;
+
+                  Hom_Id := Homonym (Hom_Id);
+
+                  exit when No (Hom_Id)
+                    or else Scope (Hom_Id) /= Current_Scope;
+               end loop;
+
+               if not Found then
+                  Error_Pragma_Arg
+                    ("argument of pragma% is not imported subprogram",
+                     Arg1);
+               end if;
+            end if;
+         end Interface_Name;
+
+         -----------------------
+         -- Interrupt_Handler --
+         -----------------------
+
+         --  pragma Interrupt_Handler (handler_NAME);
+
+         when Pragma_Interrupt_Handler =>
+            Check_Ada_83_Warning;
+            Check_Arg_Count (1);
+            Check_No_Identifiers;
+            Check_Interrupt_Or_Attach_Handler;
+            Process_Interrupt_Or_Attach_Handler;
+
+         ------------------------
+         -- Interrupt_Priority --
+         ------------------------
+
+         --  pragma Interrupt_Priority [(EXPRESSION)];
+
+         when Pragma_Interrupt_Priority => Interrupt_Priority : declare
+            P   : constant Node_Id := Parent (N);
+            Arg : Node_Id;
+
+         begin
+            Check_Ada_83_Warning;
+
+            if Arg_Count /= 0 then
+               Arg := Expression (Arg1);
+               Check_Arg_Count (1);
+               Check_No_Identifiers;
+
+               --  Set In_Default_Expression for per-object case???
+
+               Analyze_And_Resolve (Arg, Standard_Integer);
+               if Expander_Active then
+                  Rewrite (Arg,
+                    Convert_To (RTE (RE_Interrupt_Priority), Arg));
+               end if;
+            end if;
+
+            if Nkind (P) /= N_Task_Definition
+              and then Nkind (P) /= N_Protected_Definition
+            then
+               Pragma_Misplaced;
+               return;
+
+            elsif Has_Priority_Pragma (P) then
+               Error_Pragma ("duplicate pragma% not allowed");
+
+            else
+               Set_Has_Priority_Pragma (P, True);
+               Record_Rep_Item (Defining_Identifier (Parent (P)), N);
+            end if;
+         end Interrupt_Priority;
+
+         ----------------------
+         -- Java_Constructor --
+         ----------------------
+
+         --  pragma Java_Constructor ([Entity =>] LOCAL_NAME);
+
+         when Pragma_Java_Constructor => Java_Constructor : declare
+            Id     : Entity_Id;
+            Def_Id : Entity_Id;
+            Hom_Id : Entity_Id;
+
+         begin
+            GNAT_Pragma;
+            Check_Arg_Count (1);
+            Check_Optional_Identifier (Arg1, Name_Entity);
+            Check_Arg_Is_Local_Name (Arg1);
+
+            Id := Expression (Arg1);
+            Find_Program_Unit_Name (Id);
+
+            --  If we did not find the name, we are done
+
+            if Etype (Id) = Any_Type then
+               return;
+            end if;
+
+            Hom_Id := Entity (Id);
+
+            --  Loop through homonyms
+
+            loop
+               Def_Id := Get_Base_Subprogram (Hom_Id);
+
+               --  The constructor is required to be a function returning
+               --  an access type whose designated type has convention Java.
+
+               if Ekind (Def_Id) = E_Function
+                 and then Ekind (Etype (Def_Id)) in Access_Kind
+                 and then
+                   (Atree.Convention
+                      (Designated_Type (Etype (Def_Id))) = Convention_Java
+                   or else
+                     Atree.Convention
+                      (Root_Type (Designated_Type (Etype (Def_Id))))
+                        = Convention_Java)
+               then
+                  Set_Is_Constructor (Def_Id);
+                  Set_Convention     (Def_Id, Convention_Java);
+
+               else
+                  Error_Pragma_Arg
+                    ("pragma% requires function returning a 'Java access type",
+                      Arg1);
+               end if;
+
+               Hom_Id := Homonym (Hom_Id);
+
+               exit when No (Hom_Id) or else Scope (Hom_Id) /= Current_Scope;
+            end loop;
+         end Java_Constructor;
+
+         ----------------------
+         -- Java_Interface --
+         ----------------------
+
+         --  pragma Java_Interface ([Entity =>] LOCAL_NAME);
+
+         when Pragma_Java_Interface => Java_Interface : declare
+            Arg : Node_Id;
+            Typ : Entity_Id;
+
+         begin
+            GNAT_Pragma;
+            Check_Arg_Count (1);
+            Check_Optional_Identifier (Arg1, Name_Entity);
+            Check_Arg_Is_Local_Name (Arg1);
+
+            Arg := Expression (Arg1);
+            Analyze (Arg);
+
+            if Etype (Arg) = Any_Type then
+               return;
+            end if;
+
+            if not Is_Entity_Name (Arg)
+              or else not Is_Type (Entity (Arg))
+            then
+               Error_Pragma_Arg ("pragma% requires a type mark", Arg1);
+            end if;
+
+            Typ := Underlying_Type (Entity (Arg));
+
+            --  For now we simply check some of the semantic constraints
+            --  on the type. This currently leaves out some restrictions
+            --  on interface types, namely that the parent type must be
+            --  java.lang.Object.Typ and that all primitives of the type
+            --  should be declared abstract. ???
+
+            if not Is_Tagged_Type (Typ) or else not Is_Abstract (Typ) then
+               Error_Pragma_Arg ("pragma% requires an abstract "
+                 & "tagged type", Arg1);
+
+            elsif not Has_Discriminants (Typ)
+              or else Ekind (Etype (First_Discriminant (Typ)))
+                        /= E_Anonymous_Access_Type
+              or else
+                not Is_Class_Wide_Type
+                      (Designated_Type (Etype (First_Discriminant (Typ))))
+            then
+               Error_Pragma_Arg
+                 ("type must have a class-wide access discriminant", Arg1);
+            end if;
+         end Java_Interface;
+
+         -------------
+         -- License --
+         -------------
+
+         --  pragma License (RESTRICTED | UNRESRICTED | GPL | MODIFIED_GPL);
+
+         when Pragma_License =>
+            GNAT_Pragma;
+            Check_Arg_Count (1);
+            Check_No_Identifiers;
+            Check_Valid_Configuration_Pragma;
+            Check_Arg_Is_Identifier (Arg1);
+
+            declare
+               Sind : constant Source_File_Index :=
+                        Source_Index (Current_Sem_Unit);
+
+            begin
+               case Chars (Get_Pragma_Arg (Arg1)) is
+                  when Name_GPL =>
+                     Set_License (Sind, GPL);
+
+                  when Name_Modified_GPL =>
+                     Set_License (Sind, Modified_GPL);
+
+                  when Name_Restricted =>
+                     Set_License (Sind, Restricted);
+
+                  when Name_Unrestricted =>
+                     Set_License (Sind, Unrestricted);
+
+                  when others =>
+                     Error_Pragma_Arg ("invalid license name", Arg1);
+               end case;
+            end;
+
+         ---------------
+         -- Link_With --
+         ---------------
+
+         --  pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
+
+         when Pragma_Link_With => Link_With : declare
+            Arg : Node_Id;
+
+         begin
+            GNAT_Pragma;
+
+            if Operating_Mode = Generate_Code
+              and then In_Extended_Main_Source_Unit (N)
+            then
+               Check_At_Least_N_Arguments (1);
+               Check_No_Identifiers;
+               Check_Is_In_Decl_Part_Or_Package_Spec;
+               Check_Arg_Is_Static_Expression (Arg1, Standard_String);
+               Start_String;
+
+               Arg := Arg1;
+               while Present (Arg) loop
+                  Check_Arg_Is_Static_Expression (Arg, Standard_String);
+
+                  --  Store argument, converting sequences of spaces to
+                  --  a single null character (this is the difference in
+                  --  processing between Link_With, and Linker_Options).
+
+                  declare
+                     C : constant Char_Code := Get_Char_Code (' ');
+                     S : constant String_Id :=
+                           Strval (Expr_Value_S (Expression (Arg)));
+
+                     F : Nat := 1;
+                     L : Nat := String_Length (S);
+
+                     procedure Skip_Spaces;
+                     --  Advance F past any spaces
+
+                     procedure Skip_Spaces is
+                     begin
+                        while F <= L and then Get_String_Char (S, F) = C loop
+                           F := F + 1;
+                        end loop;
+                     end Skip_Spaces;
+
+                  begin
+                     Skip_Spaces; -- skip leading spaces
+
+                     --  Loop through characters, changing any embedded
+                     --  sequence of spaces to a single null character
+                     --  (this is how Link_With/Linker_Options differ)
+
+                     while F <= L loop
+                        if Get_String_Char (S, F) = C then
+                           Skip_Spaces;
+                           exit when F > L;
+                           Store_String_Char (ASCII.NUL);
+
+                        else
+                           Store_String_Char (Get_String_Char (S, F));
+                           F := F + 1;
+                        end if;
+                     end loop;
+                  end;
+
+                  Arg := Next (Arg);
+
+                  if Present (Arg) then
+                     Store_String_Char (ASCII.NUL);
+                  end if;
+               end loop;
+
+               Store_Linker_Option_String (End_String);
+            end if;
+         end Link_With;
+
+         ------------------
+         -- Linker_Alias --
+         ------------------
+
+         --  pragma Linker_Alias (
+         --      [Entity =>]  LOCAL_NAME
+         --      [Alias  =>]  static_string_EXPRESSION);
+
+         when Pragma_Linker_Alias =>
+            GNAT_Pragma;
+            Check_Arg_Count (2);
+            Check_Optional_Identifier (Arg1, Name_Entity);
+            Check_Optional_Identifier (Arg2, "alias");
+            Check_Arg_Is_Library_Level_Local_Name (Arg1);
+            Check_Arg_Is_Static_Expression (Arg2, Standard_String);
+
+            --  The only processing required is to link this item on to the
+            --  list of rep items for the given entity. This is accomplished
+            --  by the call to Rep_Item_Too_Late (when no error is detected
+            --  and False is returned).
+
+            if Rep_Item_Too_Late (Entity (Expression (Arg1)), N) then
+               return;
+            else
+               Set_Has_Gigi_Rep_Item (Entity (Expression (Arg1)));
+            end if;
+
+         --------------------
+         -- Linker_Options --
+         --------------------
+
+         --  pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
+
+         --  Note: the use of multiple arguments is a GNAT extension
+
+         when Pragma_Linker_Options => Linker_Options : declare
+            Arg : Node_Id;
+
+         begin
+            if Operating_Mode = Generate_Code
+              and then In_Extended_Main_Source_Unit (N)
+            then
+               Check_Ada_83_Warning;
+               Check_At_Least_N_Arguments (1);
+               Check_No_Identifiers;
+               Check_Is_In_Decl_Part_Or_Package_Spec;
+               Check_Arg_Is_Static_Expression (Arg1, Standard_String);
+               Start_String (Strval (Expr_Value_S (Expression (Arg1))));
+
+               Arg := Arg2;
+               while Present (Arg) loop
+                  Check_Arg_Is_Static_Expression (Arg, Standard_String);
+                  Store_String_Char (ASCII.NUL);
+                  Store_String_Chars
+                    (Strval (Expr_Value_S (Expression (Arg))));
+                  Arg := Next (Arg);
+               end loop;
+
+               Store_Linker_Option_String (End_String);
+            end if;
+         end Linker_Options;
+
+         --------------------
+         -- Linker_Section --
+         --------------------
+
+         --  pragma Linker_Section (
+         --      [Entity  =>]  LOCAL_NAME
+         --      [Section =>]  static_string_EXPRESSION);
+
+         when Pragma_Linker_Section =>
+            GNAT_Pragma;
+            Check_Arg_Count (2);
+            Check_Optional_Identifier (Arg1, Name_Entity);
+            Check_Optional_Identifier (Arg2, Name_Section);
+            Check_Arg_Is_Library_Level_Local_Name (Arg1);
+            Check_Arg_Is_Static_Expression (Arg2, Standard_String);
+
+            --  The only processing required is to link this item on to the
+            --  list of rep items for the given entity. This is accomplished
+            --  by the call to Rep_Item_Too_Late (when no error is detected
+            --  and False is returned).
+
+            if Rep_Item_Too_Late (Entity (Expression (Arg1)), N) then
+               return;
+            else
+               Set_Has_Gigi_Rep_Item (Entity (Expression (Arg1)));
+            end if;
+
+         ----------
+         -- List --
+         ----------
+
+         --  pragma List (On | Off)
+
+         --  There is nothing to do here, since we did all the processing
+         --  for this pragma in Par.Prag (so that it works properly even in
+         --  syntax only mode)
+
+         when Pragma_List =>
+            null;
+
+         --------------------
+         -- Locking_Policy --
+         --------------------
+
+         --  pragma Locking_Policy (policy_IDENTIFIER);
+
+         when Pragma_Locking_Policy => declare
+            LP : Character;
+
+         begin
+            Check_Ada_83_Warning;
+            Check_Arg_Count (1);
+            Check_No_Identifiers;
+            Check_Arg_Is_Locking_Policy (Arg1);
+            Check_Valid_Configuration_Pragma;
+            Get_Name_String (Chars (Expression (Arg1)));
+            LP := Fold_Upper (Name_Buffer (1));
+
+            if Locking_Policy /= ' '
+              and then Locking_Policy /= LP
+            then
+               Error_Msg_Sloc := Locking_Policy_Sloc;
+               Error_Pragma ("locking policy incompatible with policy#");
+            else
+               Locking_Policy := LP;
+               Locking_Policy_Sloc := Loc;
+            end if;
+         end;
+
+         ----------------
+         -- Long_Float --
+         ----------------
+
+         --  pragma Long_Float (D_Float | G_Float);
+
+         when Pragma_Long_Float =>
+            GNAT_Pragma;
+            Check_Valid_Configuration_Pragma;
+            Check_Arg_Count (1);
+            Check_No_Identifier (Arg1);
+            Check_Arg_Is_One_Of (Arg1, Name_D_Float, Name_G_Float);
+
+            if not OpenVMS_On_Target then
+               Error_Pragma ("?pragma% ignored (applies only to Open'V'M'S)");
+            end if;
+
+            --  D_Float case
+
+            if Chars (Expression (Arg1)) = Name_D_Float then
+               if Opt.Float_Format_Long = 'G' then
+                  Error_Pragma ("G_Float previously specified");
+               end if;
+
+               Opt.Float_Format_Long := 'D';
+
+            --  G_Float case (this is the default, does not need overriding)
+
+            else
+               if Opt.Float_Format_Long = 'D' then
+                  Error_Pragma ("D_Float previously specified");
+               end if;
+
+               Opt.Float_Format_Long := 'G';
+            end if;
+
+            Set_Standard_Fpt_Formats;
+
+         -----------------------
+         -- Machine_Attribute --
+         -----------------------
+
+         --  pragma Machine_Attribute (
+         --    [Entity         =>] LOCAL_NAME,
+         --    [Attribute_Name =>] static_string_EXPRESSION
+         --  [,[Info           =>] static_string_EXPRESSION] );
+
+         when Pragma_Machine_Attribute => Machine_Attribute : declare
+            Def_Id : Entity_Id;
+
+         begin
+            GNAT_Pragma;
+
+            if Arg_Count = 3 then
+               Check_Optional_Identifier (Arg3, "info");
+               Check_Arg_Is_Static_Expression (Arg3, Standard_String);
+            else
+               Check_Arg_Count (2);
+            end if;
+
+            Check_Arg_Is_Local_Name (Arg1);
+            Check_Optional_Identifier (Arg2, "attribute_name");
+            Check_Optional_Identifier (Arg1, Name_Entity);
+            Check_Arg_Is_Static_Expression (Arg2, Standard_String);
+            Def_Id := Entity (Expression (Arg1));
+
+            if Is_Access_Type (Def_Id) then
+               Def_Id := Designated_Type (Def_Id);
+            end if;
+
+            if Rep_Item_Too_Early (Def_Id, N) then
+               return;
+            end if;
+
+            Def_Id := Underlying_Type (Def_Id);
+
+            --  The only processing required is to link this item on to the
+            --  list of rep items for the given entity. This is accomplished
+            --  by the call to Rep_Item_Too_Late (when no error is detected
+            --  and False is returned).
+
+            if Rep_Item_Too_Late (Def_Id, N) then
+               return;
+            else
+               Set_Has_Gigi_Rep_Item (Entity (Expression (Arg1)));
+            end if;
+         end Machine_Attribute;
+
+         ----------
+         -- Main --
+         ----------
+
+         --  pragma Main_Storage
+         --   (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
+
+         --  MAIN_STORAGE_OPTION ::=
+         --    [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
+         --  | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
+
+         when Pragma_Main => Main : declare
+            Args  : Args_List (1 .. 3);
+            Names : Name_List (1 .. 3) := (
+                      Name_Stack_Size,
+                      Name_Task_Stack_Size_Default,
+                      Name_Time_Slicing_Enabled);
+
+            Nod : Node_Id;
+
+         begin
+            GNAT_Pragma;
+            Gather_Associations (Names, Args);
+
+            for J in 1 .. 2 loop
+               if Present (Args (J)) then
+                  Check_Arg_Is_Static_Expression (Args (J), Any_Integer);
+               end if;
+            end loop;
+
+            if Present (Args (3)) then
+               Check_Arg_Is_Static_Expression (Args (3), Standard_Boolean);
+            end if;
+
+            Nod := Next (N);
+            while Present (Nod) loop
+               if Nkind (Nod) = N_Pragma
+                 and then Chars (Nod) = Name_Main
+               then
+                  Error_Msg_Name_1 := Chars (N);
+                  Error_Msg_N ("duplicate pragma% not permitted", Nod);
+               end if;
+
+               Next (Nod);
+            end loop;
+         end Main;
+
+         ------------------
+         -- Main_Storage --
+         ------------------
+
+         --  pragma Main_Storage
+         --   (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
+
+         --  MAIN_STORAGE_OPTION ::=
+         --    [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
+         --  | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
+
+         when Pragma_Main_Storage => Main_Storage : declare
+            Args  : Args_List (1 .. 2);
+            Names : Name_List (1 .. 2) := (
+                      Name_Working_Storage,
+                      Name_Top_Guard);
+
+            Nod : Node_Id;
+
+         begin
+            GNAT_Pragma;
+            Gather_Associations (Names, Args);
+
+            for J in 1 .. 2 loop
+               if Present (Args (J)) then
+                  Check_Arg_Is_Static_Expression (Args (J), Any_Integer);
+               end if;
+            end loop;
+
+            Check_In_Main_Program;
+
+            Nod := Next (N);
+            while Present (Nod) loop
+               if Nkind (Nod) = N_Pragma
+                 and then Chars (Nod) = Name_Main_Storage
+               then
+                  Error_Msg_Name_1 := Chars (N);
+                  Error_Msg_N ("duplicate pragma% not permitted", Nod);
+               end if;
+
+               Next (Nod);
+            end loop;
+
+         end Main_Storage;
+
+         -----------------
+         -- Memory_Size --
+         -----------------
+
+         --  pragma Memory_Size (NUMERIC_LITERAL)
+
+         when Pragma_Memory_Size =>
+            GNAT_Pragma;
+
+            --  Memory size is simply ignored
+
+            Check_No_Identifiers;
+            Check_Arg_Count (1);
+            Check_Arg_Is_Integer_Literal (Arg1);
+
+         ---------------
+         -- No_Return --
+         ---------------
+
+         --  pragma No_Return (procedure_LOCAL_NAME);
+
+         when Pragma_No_Return => declare
+            Id    : Node_Id;
+            E     : Entity_Id;
+            Found : Boolean;
+
+         begin
+            GNAT_Pragma;
+            Check_Arg_Count (1);
+            Check_No_Identifiers;
+            Check_Arg_Is_Local_Name (Arg1);
+            Id := Expression (Arg1);
+            Analyze (Id);
+
+            if not Is_Entity_Name (Id) then
+               Error_Pragma_Arg ("entity name required", Arg1);
+            end if;
+
+            if Etype (Id) = Any_Type then
+               raise Pragma_Exit;
+            end if;
+
+            E := Entity (Id);
+
+            Found := False;
+            while Present (E)
+              and then Scope (E) = Current_Scope
+            loop
+               if Ekind (E) = E_Procedure
+                 or else Ekind (E) = E_Generic_Procedure
+               then
+                  Set_No_Return (E);
+                  Found := True;
+               end if;
+
+               E := Homonym (E);
+            end loop;
+
+            if not Found then
+               Error_Pragma ("no procedures found for pragma%");
+            end if;
+         end;
+
+         -----------------
+         -- No_Run_Time --
+         -----------------
+
+         --  pragma No_Run_Time
+
+         when Pragma_No_Run_Time =>
+            GNAT_Pragma;
+            Check_Valid_Configuration_Pragma;
+            Check_Arg_Count (0);
+            Set_No_Run_Time_Mode;
+
+         -----------------------
+         -- Normalize_Scalars --
+         -----------------------
+
+         --  pragma Normalize_Scalars;
+
+         when Pragma_Normalize_Scalars =>
+            Check_Ada_83_Warning;
+            Check_Arg_Count (0);
+            Check_Valid_Configuration_Pragma;
+            Normalize_Scalars := True;
+            Init_Or_Norm_Scalars := True;
+
+         --------------
+         -- Optimize --
+         --------------
+
+         --  pragma Optimize (Time | Space);
+
+         --  The actual check for optimize is done in Gigi. Note that this
+         --  pragma does not actually change the optimization setting, it
+         --  simply checks that it is consistent with the pragma.
+
+         when Pragma_Optimize =>
+            Check_No_Identifiers;
+            Check_Arg_Count (1);
+            Check_Arg_Is_One_Of (Arg1, Name_Time, Name_Space, Name_Off);
+
+         ----------
+         -- Pack --
+         ----------
+
+         --  pragma Pack (first_subtype_LOCAL_NAME);
+
+         when Pragma_Pack => Pack : declare
+            Assoc   : Node_Id := Arg1;
+            Type_Id : Node_Id;
+            Typ     : Entity_Id;
+
+         begin
+            Check_No_Identifiers;
+            Check_Arg_Count (1);
+            Check_Arg_Is_Local_Name (Arg1);
+
+            Type_Id := Expression (Assoc);
+            Find_Type (Type_Id);
+            Typ := Entity (Type_Id);
+
+            if Typ = Any_Type
+              or else Rep_Item_Too_Early (Typ, N)
+            then
+               return;
+            else
+               Typ := Underlying_Type (Typ);
+            end if;
+
+            if not Is_Array_Type (Typ) and then not Is_Record_Type (Typ) then
+               Error_Pragma ("pragma% must specify array or record type");
+            end if;
+
+            Check_First_Subtype (Arg1);
+
+            if Has_Pragma_Pack (Typ) then
+               Error_Pragma ("duplicate pragma%, only one allowed");
+
+            --  Array type. We set the Has_Pragma_Pack flag, and Is_Packed,
+            --  but not Has_Non_Standard_Rep, because we don't actually know
+            --  till freeze time if the array can have packed representation.
+            --  That's because in the general case we do not know enough about
+            --  the component type until it in turn is frozen, which certainly
+            --  happens before the array type is frozen, but not necessarily
+            --  till that point (i.e. right now it may be unfrozen).
+
+            elsif Is_Array_Type (Typ) then
+
+               if Has_Aliased_Components (Base_Type (Typ)) then
+                  Error_Pragma
+                    ("pragma% ignored, cannot pack aliased components?");
+
+               elsif Has_Atomic_Components (Typ) then
+                  Error_Pragma
+                    ("?pragma% ignored, cannot pack atomic components");
+
+               elsif not Rep_Item_Too_Late (Typ, N) then
+                  Set_Is_Packed            (Base_Type (Typ));
+                  Set_Has_Pragma_Pack      (Base_Type (Typ));
+                  Set_Has_Non_Standard_Rep (Base_Type (Typ));
+               end if;
+
+            --  Record type. For record types, the pack is always effective
+
+            else -- Is_Record_Type (Typ)
+               if not Rep_Item_Too_Late (Typ, N) then
+                  Set_Has_Pragma_Pack      (Base_Type (Typ));
+                  Set_Is_Packed            (Base_Type (Typ));
+                  Set_Has_Non_Standard_Rep (Base_Type (Typ));
+               end if;
+            end if;
+         end Pack;
+
+         ----------
+         -- Page --
+         ----------
+
+         --  pragma Page;
+
+         --  There is nothing to do here, since we did all the processing
+         --  for this pragma in Par.Prag (so that it works properly even in
+         --  syntax only mode)
+
+         when Pragma_Page =>
+            null;
+
+         -------------
+         -- Passive --
+         -------------
+
+         --  pragma Passive [(PASSIVE_FORM)];
+
+         --   PASSIVE_FORM ::= Semaphore | No
+
+         when Pragma_Passive =>
+            GNAT_Pragma;
+
+            if Nkind (Parent (N)) /= N_Task_Definition then
+               Error_Pragma ("pragma% must be within task definition");
+            end if;
+
+            if Arg_Count /= 0 then
+               Check_Arg_Count (1);
+               Check_Arg_Is_One_Of (Arg1, Name_Semaphore, Name_No);
+            end if;
+
+         -------------
+         -- Polling --
+         -------------
+
+         --  pragma Polling (ON | OFF);
+
+         when Pragma_Polling =>
+            GNAT_Pragma;
+            Check_Arg_Count (1);
+            Check_No_Identifiers;
+            Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
+            Polling_Required := (Chars (Expression (Arg1)) = Name_On);
+
+         ------------------
+         -- Preelaborate --
+         ------------------
+
+         --  pragma Preelaborate [(library_unit_NAME)];
+
+         --  Set the flag Is_Preelaborated of program unit name entity
+
+         when Pragma_Preelaborate => Preelaborate : declare
+            Ent : Entity_Id;
+            Pa  : Node_Id   := Parent (N);
+            Pk  : Node_Kind := Nkind (Pa);
+
+         begin
+            Check_Ada_83_Warning;
+            Check_Valid_Library_Unit_Pragma;
+
+            if Nkind (N) = N_Null_Statement then
+               return;
+            end if;
+
+            Ent := Find_Lib_Unit_Name;
+
+            --  This filters out pragmas inside generic parent then
+            --  show up inside instantiation
+
+            if Present (Ent)
+              and then not (Pk = N_Package_Specification
+                             and then Present (Generic_Parent (Pa)))
+            then
+               if not Debug_Flag_U then
+                  Set_Is_Preelaborated (Ent);
+                  Set_Suppress_Elaboration_Warnings (Ent);
+               end if;
+            end if;
+         end Preelaborate;
+
+         --------------
+         -- Priority --
+         --------------
+
+         --  pragma Priority (EXPRESSION);
+
+         when Pragma_Priority => Priority : declare
+            P   : constant Node_Id := Parent (N);
+            Arg : Node_Id;
+
+         begin
+            Check_No_Identifiers;
+            Check_Arg_Count (1);
+
+            Arg := Expression (Arg1);
+            Analyze_And_Resolve (Arg, Standard_Integer);
+
+            if not Is_Static_Expression (Arg) then
+               Check_Restriction (Static_Priorities, Arg);
+            end if;
+
+            --  Subprogram case
+
+            if Nkind (P) = N_Subprogram_Body then
+               Check_In_Main_Program;
+
+               --  Must be static
+
+               if not Is_Static_Expression (Arg) then
+                  Error_Pragma_Arg
+                    ("main subprogram priority is not static", Arg1);
+
+               --  If constraint error, then we already signalled an error
+
+               elsif Raises_Constraint_Error (Arg) then
+                  null;
+
+               --  Otherwise check in range
+
+               else
+                  declare
+                     Val : constant Uint := Expr_Value (Arg);
+
+                  begin
+                     if Val < 0
+                       or else Val > Expr_Value (Expression
+                                       (Parent (RTE (RE_Max_Priority))))
+                     then
+                        Error_Pragma_Arg
+                          ("main subprogram priority is out of range", Arg1);
+                     end if;
+                  end;
+               end if;
+
+               Set_Main_Priority
+                 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
+
+            --  Task or Protected, must be of type Integer
+
+            elsif Nkind (P) = N_Protected_Definition
+                    or else
+                  Nkind (P) = N_Task_Definition
+            then
+               if Expander_Active then
+                  Rewrite (Arg,
+                    Convert_To (RTE (RE_Any_Priority), Arg));
+               end if;
+
+            --  Anything else is incorrect
+
+            else
+               Pragma_Misplaced;
+            end if;
+
+            if Has_Priority_Pragma (P) then
+               Error_Pragma ("duplicate pragma% not allowed");
+            else
+               Set_Has_Priority_Pragma (P, True);
+
+               if Nkind (P) = N_Protected_Definition
+                    or else
+                  Nkind (P) = N_Task_Definition
+               then
+                  Record_Rep_Item (Defining_Identifier (Parent (P)), N);
+                  --  exp_ch9 should use this ???
+               end if;
+            end if;
+
+         end Priority;
+
+         --------------------------
+         -- Propagate_Exceptions --
+         --------------------------
+
+         --  pragma Propagate_Exceptions;
+
+         when Pragma_Propagate_Exceptions =>
+            GNAT_Pragma;
+            Check_Arg_Count (0);
+
+            if In_Extended_Main_Source_Unit (N) then
+               Propagate_Exceptions := True;
+            end if;
+
+         ------------------
+         -- Psect_Object --
+         ------------------
+
+         --  pragma Psect_Object (
+         --        [Internal =>] LOCAL_NAME,
+         --     [, [External =>] EXTERNAL_SYMBOL]
+         --     [, [Size     =>] EXTERNAL_SYMBOL]);
+
+         when Pragma_Psect_Object | Pragma_Common_Object =>
+         Psect_Object : declare
+            Args  : Args_List (1 .. 3);
+            Names : Name_List (1 .. 3) := (
+                      Name_Internal,
+                      Name_External,
+                      Name_Size);
+
+            Internal : Node_Id renames Args (1);
+            External : Node_Id renames Args (2);
+            Size     : Node_Id renames Args (3);
+
+            R_Internal : Node_Id;
+            R_External : Node_Id;
+
+            MA       : Node_Id;
+            Str      : String_Id;
+
+            Def_Id   : Entity_Id;
+
+            procedure Check_Too_Long (Arg : Node_Id);
+            --  Posts message if the argument is an identifier with more
+            --  than 31 characters, or a string literal with more than
+            --  31 characters, and we are operating under VMS
+
+            procedure Check_Too_Long (Arg : Node_Id) is
+               X : Node_Id := Original_Node (Arg);
+
+            begin
+               if Nkind (X) /= N_String_Literal
+                    and then
+                  Nkind (X) /= N_Identifier
+               then
+                  Error_Pragma_Arg
+                    ("inappropriate argument for pragma %", Arg);
+               end if;
+
+               if OpenVMS_On_Target then
+                  if (Nkind (X) = N_String_Literal
+                       and then String_Length (Strval (X)) > 31)
+                    or else
+                     (Nkind (X) = N_Identifier
+                       and then Length_Of_Name (Chars (X)) > 31)
+                  then
+                     Error_Pragma_Arg
+                       ("argument for pragma % is longer than 31 characters",
+                        Arg);
+                  end if;
+               end if;
+            end Check_Too_Long;
+
+         --  Start of processing for Common_Object/Psect_Object
+
+         begin
+            GNAT_Pragma;
+            Gather_Associations (Names, Args);
+            Process_Extended_Import_Export_Internal_Arg (Internal);
+
+            R_Internal := Relocate_Node (Internal);
+
+            Def_Id := Entity (R_Internal);
+
+            if Ekind (Def_Id) /= E_Constant
+              and then Ekind (Def_Id) /= E_Variable
+            then
+               Error_Pragma_Arg
+                 ("pragma% must designate an object", Internal);
+            end if;
+
+            Check_Too_Long (R_Internal);
+
+            if Is_Imported (Def_Id) or else Is_Exported (Def_Id) then
+               Error_Pragma_Arg
+                 ("cannot use pragma% for imported/exported object",
+                  R_Internal);
+            end if;
+
+            if Is_Concurrent_Type (Etype (R_Internal)) then
+               Error_Pragma_Arg
+                 ("cannot specify pragma % for task/protected object",
+                  R_Internal);
+            end if;
+
+            if Is_Psected (Def_Id) then
+               Error_Msg_N ("?duplicate Psect_Object pragma", N);
+            else
+               Set_Is_Psected (Def_Id);
+            end if;
+
+            if Ekind (Def_Id) = E_Constant then
+               Error_Pragma_Arg
+                 ("cannot specify pragma % for a constant", R_Internal);
+            end if;
+
+            if Is_Record_Type (Etype (R_Internal)) then
+               declare
+                  Ent  : Entity_Id;
+                  Decl : Entity_Id;
+
+               begin
+                  Ent := First_Entity (Etype (R_Internal));
+                  while Present (Ent) loop
+                     Decl := Declaration_Node (Ent);
+
+                     if Ekind (Ent) = E_Component
+                       and then Nkind (Decl) = N_Component_Declaration
+                       and then Present (Expression (Decl))
+                     then
+                        Error_Msg_N
+                          ("?object for pragma % has defaults", R_Internal);
+                        exit;
+
+                     else
+                        Next_Entity (Ent);
+                     end if;
+                  end loop;
+               end;
+            end if;
+
+            if Present (Size) then
+               Check_Too_Long (Size);
+            end if;
+
+            --  Make Psect case-insensitive.
+
+            if Present (External) then
+               Check_Too_Long (External);
+
+               if Nkind (External) = N_String_Literal then
+                  String_To_Name_Buffer (Strval (External));
+               else
+                  Get_Name_String (Chars (External));
+               end if;
+
+               Set_All_Upper_Case;
+               Start_String;
+               Store_String_Chars (Name_Buffer (1 .. Name_Len));
+               Str := End_String;
+               R_External := Make_String_Literal
+                 (Sloc => Sloc (External), Strval => Str);
+            else
+               Get_Name_String (Chars (Internal));
+               Set_All_Upper_Case;
+               Start_String;
+               Store_String_Chars (Name_Buffer (1 .. Name_Len));
+               Str := End_String;
+               R_External := Make_String_Literal
+                 (Sloc => Sloc (Internal), Strval => Str);
+            end if;
+
+            --  Transform into pragma Linker_Section, add attributes to
+            --  match what DEC Ada does. Ignore size for now?
+
+            Rewrite (N,
+               Make_Pragma
+                 (Sloc (N),
+                  Name_Linker_Section,
+                  New_List
+                    (Make_Pragma_Argument_Association
+                       (Sloc => Sloc (R_Internal),
+                        Expression => R_Internal),
+                     Make_Pragma_Argument_Association
+                       (Sloc => Sloc (R_External),
+                        Expression => R_External))));
+
+            Analyze (N);
+
+            --  Add Machine_Attribute of "overlaid", so the section overlays
+            --  other sections of the same name.
+
+            Start_String;
+            Store_String_Chars ("overlaid");
+            Str := End_String;
+
+            MA :=
+               Make_Pragma
+                 (Sloc (N),
+                  Name_Machine_Attribute,
+                  New_List
+                    (Make_Pragma_Argument_Association
+                       (Sloc => Sloc (R_Internal),
+                        Expression => R_Internal),
+                     Make_Pragma_Argument_Association
+                       (Sloc => Sloc (R_External),
+                        Expression =>
+                          Make_String_Literal
+                            (Sloc => Sloc (R_External),
+                             Strval => Str))));
+            Analyze (MA);
+
+            --  Add Machine_Attribute of "global", so the section is visible
+            --  everywhere
+
+            Start_String;
+            Store_String_Chars ("global");
+            Str := End_String;
+
+            MA :=
+               Make_Pragma
+                 (Sloc (N),
+                  Name_Machine_Attribute,
+                  New_List
+                    (Make_Pragma_Argument_Association
+                       (Sloc => Sloc (R_Internal),
+                        Expression => R_Internal),
+                     Make_Pragma_Argument_Association
+                       (Sloc => Sloc (R_External),
+                        Expression =>
+                          Make_String_Literal
+                            (Sloc => Sloc (R_External),
+                             Strval => Str))));
+            Analyze (MA);
+
+            --  Add Machine_Attribute of "initialize", so the section is
+            --  demand zeroed.
+
+            Start_String;
+            Store_String_Chars ("initialize");
+            Str := End_String;
+
+            MA :=
+               Make_Pragma
+                 (Sloc (N),
+                  Name_Machine_Attribute,
+                  New_List
+                    (Make_Pragma_Argument_Association
+                       (Sloc => Sloc (R_Internal),
+                        Expression => R_Internal),
+                     Make_Pragma_Argument_Association
+                       (Sloc => Sloc (R_External),
+                        Expression =>
+                          Make_String_Literal
+                            (Sloc => Sloc (R_External),
+                             Strval => Str))));
+            Analyze (MA);
+
+         end Psect_Object;
+
+         ----------
+         -- Pure --
+         ----------
+
+         --  pragma Pure [(library_unit_NAME)];
+
+         when Pragma_Pure => Pure : declare
+            Ent : Entity_Id;
+         begin
+            Check_Ada_83_Warning;
+            Check_Valid_Library_Unit_Pragma;
+
+            if Nkind (N) = N_Null_Statement then
+               return;
+            end if;
+
+            Ent := Find_Lib_Unit_Name;
+            Set_Is_Pure (Ent);
+            Set_Suppress_Elaboration_Warnings (Ent);
+         end Pure;
+
+         -------------------
+         -- Pure_Function --
+         -------------------
+
+         --  pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
+
+         when Pragma_Pure_Function => Pure_Function : declare
+            E_Id   : Node_Id;
+            E      : Entity_Id;
+            Def_Id : Entity_Id;
+
+         begin
+            GNAT_Pragma;
+            Check_Arg_Count (1);
+            Check_Optional_Identifier (Arg1, Name_Entity);
+            Check_Arg_Is_Local_Name (Arg1);
+            E_Id := Expression (Arg1);
+
+            if Error_Posted (E_Id) then
+               return;
+            end if;
+
+            --  Loop through homonyms (overloadings) of referenced entity
+
+            E := Entity (E_Id);
+            while Present (E) loop
+               Def_Id := Get_Base_Subprogram (E);
+
+               if Ekind (Def_Id) /= E_Function
+                 and then Ekind (Def_Id) /= E_Generic_Function
+                 and then Ekind (Def_Id) /= E_Operator
+               then
+                  Error_Pragma_Arg ("pragma% requires a function name", Arg1);
+               end if;
+
+               Set_Is_Pure (Def_Id);
+               E := Homonym (E);
+            end loop;
+         end Pure_Function;
+
+         --------------------
+         -- Queuing_Policy --
+         --------------------
+
+         --  pragma Queuing_Policy (policy_IDENTIFIER);
+
+         when Pragma_Queuing_Policy => declare
+            QP : Character;
+
+         begin
+            Check_Ada_83_Warning;
+            Check_Arg_Count (1);
+            Check_No_Identifiers;
+            Check_Arg_Is_Queuing_Policy (Arg1);
+            Check_Valid_Configuration_Pragma;
+            Get_Name_String (Chars (Expression (Arg1)));
+            QP := Fold_Upper (Name_Buffer (1));
+
+            if Queuing_Policy /= ' '
+              and then Queuing_Policy /= QP
+            then
+               Error_Msg_Sloc := Queuing_Policy_Sloc;
+               Error_Pragma ("queuing policy incompatible with policy#");
+            else
+               Queuing_Policy := QP;
+               Queuing_Policy_Sloc := Loc;
+            end if;
+         end;
+
+         ---------------------------
+         -- Remote_Call_Interface --
+         ---------------------------
+
+         --  pragma Remote_Call_Interface [(library_unit_NAME)];
+
+         when Pragma_Remote_Call_Interface => Remote_Call_Interface : declare
+            Cunit_Node : Node_Id;
+            Cunit_Ent  : Entity_Id;
+            K          : Node_Kind;
+
+         begin
+            Check_Ada_83_Warning;
+            Check_Valid_Library_Unit_Pragma;
+
+            if Nkind (N) = N_Null_Statement then
+               return;
+            end if;
+
+            Cunit_Node := Cunit (Current_Sem_Unit);
+            K          := Nkind (Unit (Cunit_Node));
+            Cunit_Ent  := Cunit_Entity (Current_Sem_Unit);
+
+            if K = N_Package_Declaration
+              or else K = N_Generic_Package_Declaration
+              or else K = N_Subprogram_Declaration
+              or else K = N_Generic_Subprogram_Declaration
+              or else (K = N_Subprogram_Body
+                         and then Acts_As_Spec (Unit (Cunit_Node)))
+            then
+               null;
+            else
+               Error_Pragma (
+                 "pragma% must apply to package or subprogram declaration");
+            end if;
+
+            Set_Is_Remote_Call_Interface (Cunit_Ent);
+         end Remote_Call_Interface;
+
+         ------------------
+         -- Remote_Types --
+         ------------------
+
+         --  pragma Remote_Types [(library_unit_NAME)];
+
+         when Pragma_Remote_Types => Remote_Types : declare
+            Cunit_Node : Node_Id;
+            Cunit_Ent  : Entity_Id;
+
+         begin
+            Check_Ada_83_Warning;
+            Check_Valid_Library_Unit_Pragma;
+
+            if Nkind (N) = N_Null_Statement then
+               return;
+            end if;
+
+            Cunit_Node := Cunit (Current_Sem_Unit);
+            Cunit_Ent  := Cunit_Entity (Current_Sem_Unit);
+
+            if Nkind (Unit (Cunit_Node)) /= N_Package_Declaration
+              and then
+              Nkind (Unit (Cunit_Node)) /= N_Generic_Package_Declaration
+            then
+               Error_Pragma (
+                 "pragma% can only apply to a package declaration");
+            end if;
+
+            Set_Is_Remote_Types (Cunit_Ent);
+         end Remote_Types;
+
+         ---------------
+         -- Ravenscar --
+         ---------------
+
+         when Pragma_Ravenscar =>
+            GNAT_Pragma;
+            Check_Arg_Count (0);
+            Check_Valid_Configuration_Pragma;
+            Set_Ravenscar;
+
+         -------------------------
+         -- Restricted_Run_Time --
+         -------------------------
+
+         when Pragma_Restricted_Run_Time =>
+            GNAT_Pragma;
+            Check_Arg_Count (0);
+            Check_Valid_Configuration_Pragma;
+            Set_Restricted_Profile;
+
+         ------------------
+         -- Restrictions --
+         ------------------
+
+         --  pragma Restrictions (RESTRICTION {, RESTRICTION});
+
+         --  RESTRICTION ::=
+         --    restriction_IDENTIFIER
+         --  | restriction_parameter_IDENTIFIER => EXPRESSION
+
+         when Pragma_Restrictions => Restrictions_Pragma : declare
+            Arg   : Node_Id;
+            R_Id  : Restriction_Id;
+            RP_Id : Restriction_Parameter_Id;
+            Id    : Name_Id;
+            Expr  : Node_Id;
+            Val   : Uint;
+
+         begin
+            Check_Ada_83_Warning;
+            Check_At_Least_N_Arguments (1);
+            Check_Valid_Configuration_Pragma;
+
+            Arg := Arg1;
+
+            while Present (Arg) loop
+               Id := Chars (Arg);
+               Expr := Expression (Arg);
+
+               --  Case of no restriction identifier
+
+               if Id = No_Name then
+                  if Nkind (Expr) /= N_Identifier then
+                     Error_Pragma_Arg
+                       ("invalid form for restriction", Arg);
+
+                  else
+                     R_Id := Get_Restriction_Id (Chars (Expr));
+
+                     if R_Id = Not_A_Restriction_Id then
+                        Error_Pragma_Arg
+                          ("invalid restriction identifier", Arg);
+
+                     --  Restriction is active
+
+                     else
+                        Restrictions (R_Id) := True;
+                        Restrictions_Loc (R_Id) := Sloc (N);
+
+                        --  Record the restriction if we are in the main unit,
+                        --  or in the extended main unit. The reason that we
+                        --  test separately for Main_Unit is that gnat.adc is
+                        --  processed with Current_Sem_Unit = Main_Unit, but
+                        --  nodes in gnat.adc do not appear to be the extended
+                        --  main source unit (they probably should do ???)
+
+                        if Current_Sem_Unit = Main_Unit
+                          or else In_Extended_Main_Source_Unit (N)
+                        then
+                           Main_Restrictions (R_Id) := True;
+                        end if;
+
+                        --  A very special case that must be processed here:
+                        --  pragma Restrictions (No_Exceptions) turns off all
+                        --  run-time checking. This is a bit dubious in terms
+                        --  of the formal language definition, but it is what
+                        --  is intended by the wording of RM H.4(12).
+
+                        if R_Id = No_Exceptions then
+                           Scope_Suppress := (others => True);
+                        end if;
+                     end if;
+                  end if;
+
+               --  Case of restriction identifier present
+
+               else
+                  RP_Id := Get_Restriction_Parameter_Id (Id);
+                  Analyze_And_Resolve (Expr, Any_Integer);
+
+                  if RP_Id = Not_A_Restriction_Parameter_Id then
+                     Error_Pragma_Arg
+                       ("invalid restriction parameter identifier", Arg);
+
+                  elsif not Is_OK_Static_Expression (Expr)
+                    or else not Is_Integer_Type (Etype (Expr))
+                    or else Expr_Value (Expr) < 0
+                  then
+                     Error_Pragma_Arg
+                       ("value must be non-negative static integer", Arg);
+
+                  --  Restriction pragma is active
+
+                  else
+                     Val := Expr_Value (Expr);
+
+                     --  Record pragma if most restrictive so far
+
+                     if Restriction_Parameters (RP_Id) = No_Uint
+                       or else Val < Restriction_Parameters (RP_Id)
+                     then
+                        Restriction_Parameters (RP_Id) := Expr_Value (Expr);
+                        Restriction_Parameters_Loc (RP_Id) := Sloc (N);
+                     end if;
+                  end if;
+               end if;
+
+               Next (Arg);
+            end loop;
+         end Restrictions_Pragma;
+
+         ----------------
+         -- Reviewable --
+         ----------------
+
+         --  pragma Reviewable;
+
+         when Pragma_Reviewable =>
+            Check_Ada_83_Warning;
+            Check_Arg_Count (0);
+
+         -------------------
+         -- Share_Generic --
+         -------------------
+
+         --  pragma Share_Generic (NAME {, NAME});
+
+         when Pragma_Share_Generic =>
+            GNAT_Pragma;
+            Process_Generic_List;
+
+         ------------
+         -- Shared --
+         ------------
+
+         --  pragma Shared (LOCAL_NAME);
+
+         when Pragma_Shared =>
+            Process_Atomic_Shared_Volatile;
+
+         --------------------
+         -- Shared_Passive --
+         --------------------
+
+         --  pragma Shared_Passive [(library_unit_NAME)];
+
+         --  Set the flag Is_Shared_Passive of program unit name entity
+
+         when Pragma_Shared_Passive => Shared_Passive : declare
+            Cunit_Node : Node_Id;
+            Cunit_Ent  : Entity_Id;
+
+         begin
+            Check_Ada_83_Warning;
+            Check_Valid_Library_Unit_Pragma;
+
+            if Nkind (N) = N_Null_Statement then
+               return;
+            end if;
+
+            Cunit_Node := Cunit (Current_Sem_Unit);
+            Cunit_Ent  := Cunit_Entity (Current_Sem_Unit);
+
+            if Nkind (Unit (Cunit_Node)) /= N_Package_Declaration
+              and then
+              Nkind (Unit (Cunit_Node)) /= N_Generic_Package_Declaration
+            then
+               Error_Pragma (
+                 "pragma% can only apply to a package declaration");
+            end if;
+
+            Set_Is_Shared_Passive (Cunit_Ent);
+         end Shared_Passive;
+
+         ----------------------
+         -- Source_File_Name --
+         ----------------------
+
+         --  pragma Source_File_Name (
+         --    [UNIT_NAME =>] unit_NAME,
+         --    [BODY_FILE_NAME | SPEC_FILE_NAME] => STRING_LITERAL);
+
+         --  No processing here. Processing was completed during parsing,
+         --  since we need to have file names set as early as possible.
+         --  Units are loaded well before semantic processing starts.
+
+         --  The only processing we defer to this point is the check
+         --  for correct placement.
+
+         when Pragma_Source_File_Name =>
+            GNAT_Pragma;
+            Check_Valid_Configuration_Pragma;
+
+         ----------------------
+         -- Source_Reference --
+         ----------------------
+
+         --  pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
+
+         --  Nothing to do, all processing completed in Par.Prag, since we
+         --  need the information for possible parser messages that are output
+
+         when Pragma_Source_Reference =>
+            GNAT_Pragma;
+
+         ------------------
+         -- Storage_Size --
+         ------------------
+
+         --  pragma Storage_Size (EXPRESSION);
+
+         when Pragma_Storage_Size => Storage_Size : declare
+            P : constant Node_Id := Parent (N);
+            X : Node_Id;
+
+         begin
+            Check_No_Identifiers;
+            Check_Arg_Count (1);
+
+            --  Set In_Default_Expression for per-object case???
+
+            X := Expression (Arg1);
+            Analyze_And_Resolve (X, Any_Integer);
+
+            if not Is_Static_Expression (X) then
+               Check_Restriction (Static_Storage_Size, X);
+            end if;
+
+            if Nkind (P) /= N_Task_Definition then
+               Pragma_Misplaced;
+               return;
+
+            else
+               if Has_Storage_Size_Pragma (P) then
+                  Error_Pragma ("duplicate pragma% not allowed");
+               else
+                  Set_Has_Storage_Size_Pragma (P, True);
+               end if;
+
+               Record_Rep_Item (Defining_Identifier (Parent (P)), N);
+               --  ???  exp_ch9 should use this!
+            end if;
+         end Storage_Size;
+
+         ------------------
+         -- Storage_Unit --
+         ------------------
+
+         --  pragma Storage_Unit (NUMERIC_LITERAL);
+
+         --  Only permitted argument is System'Storage_Unit value
+
+         when Pragma_Storage_Unit =>
+            Check_No_Identifiers;
+            Check_Arg_Count (1);
+            Check_Arg_Is_Integer_Literal (Arg1);
+
+            if Intval (Expression (Arg1)) /=
+              UI_From_Int (Ttypes.System_Storage_Unit)
+            then
+               Error_Msg_Uint_1 := UI_From_Int (Ttypes.System_Storage_Unit);
+               Error_Pragma_Arg
+                 ("the only allowed argument for pragma% is ^", Arg1);
+            end if;
+
+         --------------------
+         -- Stream_Convert --
+         --------------------
+
+         --  pragma Stream_Convert (
+         --    [Entity =>] type_LOCAL_NAME,
+         --    [Read   =>] function_NAME,
+         --    [Write  =>] function NAME);
+
+         when Pragma_Stream_Convert => Stream_Convert : begin
+            GNAT_Pragma;
+            Check_Arg_Count (3);
+            Check_Optional_Identifier (Arg1, Name_Entity);
+            Check_Optional_Identifier (Arg2, Name_Read);
+            Check_Optional_Identifier (Arg3, Name_Write);
+            Check_Arg_Is_Local_Name (Arg1);
+            Check_Non_Overloaded_Function (Arg2);
+            Check_Non_Overloaded_Function (Arg3);
+
+            declare
+               Typ   : constant Entity_Id :=
+                         Underlying_Type (Entity (Expression (Arg1)));
+               Read  : constant Entity_Id := Entity (Expression (Arg2));
+               Write : constant Entity_Id := Entity (Expression (Arg3));
+
+            begin
+               if Etype (Typ) = Any_Type
+                    or else
+                  Etype (Read) = Any_Type
+                    or else
+                  Etype (Write) = Any_Type
+               then
+                  return;
+               end if;
+
+               Check_First_Subtype (Arg1);
+
+               if Rep_Item_Too_Early (Typ, N)
+                    or else
+                  Rep_Item_Too_Late (Typ, N)
+               then
+                  return;
+               end if;
+
+               if Underlying_Type (Etype (Read)) /= Typ then
+                  Error_Pragma_Arg
+                    ("incorrect return type for function&", Arg2);
+               end if;
+
+               if Underlying_Type (Etype (First_Formal (Write))) /= Typ then
+                  Error_Pragma_Arg
+                    ("incorrect parameter type for function&", Arg3);
+               end if;
+
+               if Underlying_Type (Etype (First_Formal (Read))) /=
+                  Underlying_Type (Etype (Write))
+               then
+                  Error_Pragma_Arg
+                    ("result type of & does not match Read parameter type",
+                     Arg3);
+               end if;
+            end;
+         end Stream_Convert;
+
+         -------------------------
+         -- 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. This
+         --  means that we don't need to issue error messages here.
+
+         when Pragma_Style_Checks => Style_Checks : declare
+            A  : constant Node_Id   := Expression (Arg1);
+            S  : String_Id;
+            C  : Char_Code;
+
+         begin
+            GNAT_Pragma;
+            Check_No_Identifiers;
+
+            --  Two argument form
+
+            if Arg_Count = 2 then
+               Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
+
+               declare
+                  E_Id : Node_Id;
+                  E    : Entity_Id;
+
+               begin
+                  E_Id := Expression (Arg2);
+                  Analyze (E_Id);
+
+                  if not Is_Entity_Name (E_Id) then
+                     Error_Pragma_Arg
+                       ("second argument of pragma% must be entity name",
+                        Arg2);
+                  end if;
+
+                  E := Entity (E_Id);
+
+                  if E = Any_Id then
+                     return;
+                  else
+                     loop
+                        Set_Suppress_Style_Checks (E,
+                          (Chars (Expression (Arg1)) = Name_Off));
+                        exit when No (Homonym (E));
+                        E := Homonym (E);
+                     end loop;
+                  end if;
+               end;
+
+            --  One argument form
+
+            else
+               Check_Arg_Count (1);
+
+               if Nkind (A) = N_String_Literal then
+                  S   := Strval (A);
+
+                  declare
+                     Slen    : Natural := Natural (String_Length (S));
+                     Options : String (1 .. Slen);
+                     J       : Natural;
+
+                  begin
+                     J := 1;
+                     loop
+                        C := Get_String_Char (S, Int (J));
+                        exit when not In_Character_Range (C);
+                        Options (J) := Get_Character (C);
+
+                        if J = Slen then
+                           Set_Style_Check_Options (Options);
+                           exit;
+                        else
+                           J := J + 1;
+                        end if;
+                     end loop;
+                  end;
+
+               elsif Nkind (A) = N_Identifier then
+
+                  if Chars (A) = Name_All_Checks then
+                     Set_Default_Style_Check_Options;
+
+                  elsif Chars (A) = Name_On then
+                     Style_Check := True;
+
+                  elsif Chars (A) = Name_Off then
+                     Style_Check := False;
+
+                  end if;
+               end if;
+            end if;
+         end Style_Checks;
+
+         --------------
+         -- Subtitle --
+         --------------
+
+         --  pragma Subtitle ([Subtitle =>] STRING_LITERAL);
+
+         when Pragma_Subtitle =>
+            GNAT_Pragma;
+            Check_Arg_Count (1);
+            Check_Optional_Identifier (Arg1, Name_Subtitle);
+            Check_Arg_Is_String_Literal (Arg1);
+
+         --------------
+         -- Suppress --
+         --------------
+
+         --  pragma Suppress (IDENTIFIER [, [On =>] NAME]);
+
+         when Pragma_Suppress =>
+            Process_Suppress_Unsuppress (True);
+
+         ------------------
+         -- Suppress_All --
+         ------------------
+
+         --  pragma Suppress_All;
+
+         --  The only check made here is that the pragma appears in the
+         --  proper place, i.e. following a compilation unit. If indeed
+         --  it appears in this context, then the parser has already
+         --  inserted an equivalent pragma Suppress (All_Checks) to get
+         --  the required effect.
+
+         when Pragma_Suppress_All =>
+            GNAT_Pragma;
+            Check_Arg_Count (0);
+
+            if Nkind (Parent (N)) /= N_Compilation_Unit_Aux
+              or else not Is_List_Member (N)
+              or else List_Containing (N) /= Pragmas_After (Parent (N))
+            then
+               Error_Pragma
+                 ("misplaced pragma%, must follow compilation unit");
+            end if;
+
+         -------------------------
+         -- Suppress_Debug_Info --
+         -------------------------
+
+         --  pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
+
+         when Pragma_Suppress_Debug_Info =>
+            GNAT_Pragma;
+            Check_Arg_Count (1);
+            Check_Arg_Is_Local_Name (Arg1);
+            Check_Optional_Identifier (Arg1, Name_Entity);
+            Set_Debug_Info_Off (Entity (Get_Pragma_Arg (Arg1)));
+
+         -----------------------------
+         -- Suppress_Initialization --
+         -----------------------------
+
+         --  pragma Suppress_Initialization ([Entity =>] type_Name);
+
+         when Pragma_Suppress_Initialization => Suppress_Init : declare
+            E_Id : Node_Id;
+            E    : Entity_Id;
+
+         begin
+            GNAT_Pragma;
+            Check_Arg_Count (1);
+            Check_Optional_Identifier (Arg1, Name_Entity);
+            Check_Arg_Is_Local_Name (Arg1);
+
+            E_Id := Expression (Arg1);
+
+            if Etype (E_Id) = Any_Type then
+               return;
+            end if;
+
+            E := Entity (E_Id);
+
+            if Is_Type (E) then
+               if Is_Incomplete_Or_Private_Type (E) then
+                  if No (Full_View (Base_Type (E))) then
+                     Error_Pragma_Arg
+                       ("argument of pragma% cannot be an incomplete type",
+                         Arg1);
+                  else
+                     Set_Suppress_Init_Proc (Full_View (Base_Type (E)));
+                  end if;
+               else
+                  Set_Suppress_Init_Proc (Base_Type (E));
+               end if;
+
+            else
+               Error_Pragma_Arg
+                 ("pragma% requires argument that is a type name", Arg1);
+            end if;
+         end Suppress_Init;
+
+         -----------------
+         -- System_Name --
+         -----------------
+
+         --  pragma System_Name (DIRECT_NAME);
+
+         --  Syntax check: one argument, which must be the identifier GNAT
+         --  or the identifier GCC, no other identifiers are acceptable.
+
+         when Pragma_System_Name =>
+            Check_No_Identifiers;
+            Check_Arg_Count (1);
+            Check_Arg_Is_One_Of (Arg1, Name_Gcc, Name_Gnat);
+
+         -----------------------------
+         -- Task_Dispatching_Policy --
+         -----------------------------
+
+         --  pragma Task_Dispatching_Policy (policy_IDENTIFIER);
+
+         when Pragma_Task_Dispatching_Policy => declare
+            DP : Character;
+
+         begin
+            Check_Ada_83_Warning;
+            Check_Arg_Count (1);
+            Check_No_Identifiers;
+            Check_Arg_Is_Task_Dispatching_Policy (Arg1);
+            Check_Valid_Configuration_Pragma;
+            Get_Name_String (Chars (Expression (Arg1)));
+            DP := Fold_Upper (Name_Buffer (1));
+
+            if Task_Dispatching_Policy /= ' '
+              and then Task_Dispatching_Policy /= DP
+            then
+               Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
+               Error_Pragma
+                 ("task dispatching policy incompatible with policy#");
+            else
+               Task_Dispatching_Policy := DP;
+               Task_Dispatching_Policy_Sloc := Loc;
+            end if;
+         end;
+
+         --------------
+         -- Task_Info --
+         --------------
+
+         --  pragma Task_Info (EXPRESSION);
+
+         when Pragma_Task_Info => Task_Info : declare
+            P : constant Node_Id := Parent (N);
+
+         begin
+            GNAT_Pragma;
+
+            if Nkind (P) /= N_Task_Definition then
+               Error_Pragma ("pragma% must appear in task definition");
+            end if;
+
+            Check_No_Identifiers;
+            Check_Arg_Count (1);
+
+            Analyze_And_Resolve (Expression (Arg1), RTE (RE_Task_Info_Type));
+
+            if Etype (Expression (Arg1)) = Any_Type then
+               return;
+            end if;
+
+            if Has_Task_Info_Pragma (P) then
+               Error_Pragma ("duplicate pragma% not allowed");
+            else
+               Set_Has_Task_Info_Pragma (P, True);
+            end if;
+
+         end Task_Info;
+
+         ---------------
+         -- Task_Name --
+         ---------------
+
+         --  pragma Task_Name (string_EXPRESSION);
+
+         when Pragma_Task_Name => Task_Name : declare
+         --  pragma Priority (EXPRESSION);
+
+            P   : constant Node_Id := Parent (N);
+            Arg : Node_Id;
+
+         begin
+            Check_No_Identifiers;
+            Check_Arg_Count (1);
+
+            Arg := Expression (Arg1);
+            Analyze_And_Resolve (Arg, Standard_String);
+
+            if Nkind (P) /= N_Task_Definition then
+               Pragma_Misplaced;
+            end if;
+
+            if Has_Task_Name_Pragma (P) then
+               Error_Pragma ("duplicate pragma% not allowed");
+            else
+               Set_Has_Task_Name_Pragma (P, True);
+               Record_Rep_Item (Defining_Identifier (Parent (P)), N);
+            end if;
+
+         end Task_Name;
+
+         ------------------
+         -- Task_Storage --
+         ------------------
+
+         --  pragma Task_Storage (
+         --     [Task_Type =>] LOCAL_NAME,
+         --     [Top_Guard =>] static_integer_EXPRESSION);
+
+         when Pragma_Task_Storage => Task_Storage : declare
+            Args  : Args_List (1 .. 2);
+            Names : Name_List (1 .. 2) := (
+                      Name_Task_Type,
+                      Name_Top_Guard);
+
+            Task_Type : Node_Id renames Args (1);
+            Top_Guard : Node_Id renames Args (2);
+
+            Ent : Entity_Id;
+
+         begin
+            GNAT_Pragma;
+            Gather_Associations (Names, Args);
+            Check_Arg_Is_Local_Name (Task_Type);
+
+            Ent := Entity (Task_Type);
+
+            if not Is_Task_Type (Ent) then
+               Error_Pragma_Arg
+                 ("argument for pragma% must be task type", Task_Type);
+            end if;
+
+            if No (Top_Guard) then
+               Error_Pragma_Arg
+                 ("pragma% takes two arguments", Task_Type);
+            else
+               Check_Arg_Is_Static_Expression (Top_Guard, Any_Integer);
+            end if;
+
+            Check_First_Subtype (Task_Type);
+
+            if Rep_Item_Too_Late (Ent, N) then
+               raise Pragma_Exit;
+            end if;
+
+         end Task_Storage;
+
+         ----------------
+         -- Time_Slice --
+         ----------------
+
+         --  pragma Time_Slice (static_duration_EXPRESSION);
+
+         when Pragma_Time_Slice => Time_Slice : declare
+            Val : Ureal;
+            Nod : Node_Id;
+
+         begin
+            GNAT_Pragma;
+            Check_Arg_Count (1);
+            Check_No_Identifiers;
+            Check_In_Main_Program;
+            Check_Arg_Is_Static_Expression (Arg1, Standard_Duration);
+
+            if not Error_Posted (Arg1) then
+               Nod := Next (N);
+               while Present (Nod) loop
+                  if Nkind (Nod) = N_Pragma
+                    and then Chars (Nod) = Name_Time_Slice
+                  then
+                     Error_Msg_Name_1 := Chars (N);
+                     Error_Msg_N ("duplicate pragma% not permitted", Nod);
+                  end if;
+
+                  Next (Nod);
+               end loop;
+            end if;
+
+            --  Process only if in main unit
+
+            if Get_Source_Unit (Loc) = Main_Unit then
+               Opt.Time_Slice_Set := True;
+               Val := Expr_Value_R (Expression (Arg1));
+
+               if Val <= Ureal_0 then
+                  Opt.Time_Slice_Value := 0;
+
+               elsif Val > UR_From_Uint (UI_From_Int (1000)) then
+                  Opt.Time_Slice_Value := 1_000_000_000;
+
+               else
+                  Opt.Time_Slice_Value :=
+                    UI_To_Int (UR_To_Uint (Val * UI_From_Int (1_000_000)));
+               end if;
+            end if;
+         end Time_Slice;
+
+         -----------
+         -- Title --
+         -----------
+
+         --  pragma Title (TITLING_OPTION [, TITLING OPTION]);
+
+         --   TITLING_OPTION ::=
+         --     [Title =>] STRING_LITERAL
+         --   | [Subtitle =>] STRING_LITERAL
+
+         when Pragma_Title => Title : declare
+            Args  : Args_List (1 .. 2);
+            Names : Name_List (1 .. 2) := (
+                      Name_Title,
+                      Name_Subtitle);
+
+         begin
+            GNAT_Pragma;
+            Gather_Associations (Names, Args);
+
+            for J in 1 .. 2 loop
+               if Present (Args (J)) then
+                  Check_Arg_Is_String_Literal (Args (J));
+               end if;
+            end loop;
+         end Title;
+
+         ---------------------
+         -- Unchecked_Union --
+         ---------------------
+
+         --  pragma Unchecked_Union (first_subtype_LOCAL_NAME)
+
+         when Pragma_Unchecked_Union => Unchecked_Union : declare
+            Assoc   : Node_Id := Arg1;
+            Type_Id : Node_Id := Expression (Assoc);
+            Typ     : Entity_Id;
+            Discr   : Entity_Id;
+            Tdef    : Node_Id;
+            Clist   : Node_Id;
+            Vpart   : Node_Id;
+            Comp    : Node_Id;
+            Variant : Node_Id;
+
+         begin
+            GNAT_Pragma;
+            Check_No_Identifiers;
+            Check_Arg_Count (1);
+            Check_Arg_Is_Local_Name (Arg1);
+
+            Find_Type (Type_Id);
+            Typ := Entity (Type_Id);
+
+            if Typ = Any_Type
+              or else Rep_Item_Too_Early (Typ, N)
+            then
+               return;
+            else
+               Typ := Underlying_Type (Typ);
+            end if;
+
+            if Rep_Item_Too_Late (Typ, N) then
+               return;
+            end if;
+
+            Check_First_Subtype (Arg1);
+
+            --  Note remaining cases are references to a type in the current
+            --  declarative part. If we find an error, we post the error on
+            --  the relevant type declaration at an appropriate point.
+
+            if not Is_Record_Type (Typ) then
+               Error_Msg_N ("Unchecked_Union must be record type", Typ);
+               return;
+
+            elsif Is_Tagged_Type (Typ) then
+               Error_Msg_N ("Unchecked_Union must not be tagged", Typ);
+               return;
+
+            elsif Is_Limited_Type (Typ) then
+               Error_Msg_N
+                 ("Unchecked_Union must not be limited record type", Typ);
+               return;
+
+            else
+               if not Has_Discriminants (Typ) then
+                  Error_Msg_N
+                    ("Unchecked_Union must have one discriminant", Typ);
+                  return;
+               end if;
+
+               Discr := First_Discriminant (Typ);
+
+               if Present (Next_Discriminant (Discr)) then
+                  Error_Msg_N
+                    ("Unchecked_Union must have exactly one discriminant",
+                     Next_Discriminant (Discr));
+                  return;
+               end if;
+
+               if No (Discriminant_Default_Value (Discr)) then
+                  Error_Msg_N
+                    ("Unchecked_Union discriminant must have default value",
+                     Discr);
+               end if;
+
+               Tdef  := Type_Definition (Declaration_Node (Typ));
+               Clist := Component_List (Tdef);
+
+               if No (Clist) or else No (Variant_Part (Clist)) then
+                  Error_Msg_N
+                    ("Unchecked_Union must have variant part",
+                     Tdef);
+                  return;
+               end if;
+
+               Vpart := Variant_Part (Clist);
+
+               if Is_Non_Empty_List (Component_Items (Clist)) then
+                  Error_Msg_N
+                    ("components before variant not allowed " &
+                     "in Unchecked_Union",
+                     First (Component_Items (Clist)));
+               end if;
+
+               Variant := First (Variants (Vpart));
+               while Present (Variant) loop
+                  Clist := Component_List (Variant);
+
+                  if Present (Variant_Part (Clist)) then
+                     Error_Msg_N
+                       ("Unchecked_Union may not have nested variants",
+                        Variant_Part (Clist));
+                  end if;
+
+                  if not Is_Non_Empty_List (Component_Items (Clist)) then
+                     Error_Msg_N
+                       ("Unchecked_Union may not have empty component list",
+                        Variant);
+                     return;
+                  end if;
+
+                  Comp := First (Component_Items (Clist));
+
+                  if Nkind (Comp) = N_Component_Declaration then
+
+                     if Present (Expression (Comp)) then
+                        Error_Msg_N
+                          ("default initialization not allowed " &
+                           "in Unchecked_Union",
+                           Expression (Comp));
+                     end if;
+
+                     declare
+                        Sindic : constant Node_Id :=
+                                   Subtype_Indication (Comp);
+
+                     begin
+                        if Nkind (Sindic) = N_Subtype_Indication then
+                           Check_Static_Constraint (Constraint (Sindic));
+                        end if;
+                     end;
+                  end if;
+
+                  if Present (Next (Comp)) then
+                     Error_Msg_N
+                       ("Unchecked_Union variant can have only one component",
+                        Next (Comp));
+                  end if;
+
+                  Next (Variant);
+               end loop;
+            end if;
+
+            Set_Is_Unchecked_Union           (Typ, True);
+            Set_Suppress_Discriminant_Checks (Typ, True);
+            Set_Convention                   (Typ, Convention_C);
+
+            Set_Has_Unchecked_Union (Base_Type (Typ), True);
+            Set_Is_Unchecked_Union  (Base_Type (Typ), True);
+
+         end Unchecked_Union;
+
+         ------------------------
+         -- Unimplemented_Unit --
+         ------------------------
+
+         --  pragma Unimplemented_Unit;
+
+         --  Note: this only gives an error if we are generating code,
+         --  or if we are in a generic library unit (where the pragma
+         --  appears in the body, not in the spec).
+
+         when Pragma_Unimplemented_Unit => Unimplemented_Unit : declare
+            Cunitent : Entity_Id := Cunit_Entity (Get_Source_Unit (Loc));
+            Ent_Kind : Entity_Kind := Ekind (Cunitent);
+
+         begin
+            GNAT_Pragma;
+            Check_Arg_Count (0);
+
+            if Operating_Mode = Generate_Code
+              or else Ent_Kind = E_Generic_Function
+              or else Ent_Kind = E_Generic_Procedure
+              or else Ent_Kind = E_Generic_Package
+            then
+               Get_Name_String (Chars (Cunitent));
+               Set_Casing (Mixed_Case);
+               Write_Str (Name_Buffer (1 .. Name_Len));
+               Write_Str (" is not implemented");
+               Write_Eol;
+               raise Unrecoverable_Error;
+            end if;
+         end Unimplemented_Unit;
+
+         ------------------------------
+         -- Unreserve_All_Interrupts --
+         ------------------------------
+
+         --  pragma Unreserve_All_Interrupts;
+
+         when Pragma_Unreserve_All_Interrupts =>
+            GNAT_Pragma;
+            Check_Arg_Count (0);
+
+            if In_Extended_Main_Code_Unit (Main_Unit_Entity) then
+               Unreserve_All_Interrupts := True;
+            end if;
+
+         ----------------
+         -- Unsuppress --
+         ----------------
+
+         --  pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
+
+         when Pragma_Unsuppress =>
+            GNAT_Pragma;
+            Process_Suppress_Unsuppress (False);
+
+         -------------------
+         -- Use_VADS_Size --
+         -------------------
+
+         --  pragma Use_VADS_Size;
+
+         when Pragma_Use_VADS_Size =>
+            GNAT_Pragma;
+            Check_Arg_Count (0);
+            Check_Valid_Configuration_Pragma;
+            Use_VADS_Size := True;
+
+         ---------------------
+         -- Validity_Checks --
+         ---------------------
+
+         --  pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
+
+         when Pragma_Validity_Checks => Validity_Checks : declare
+            A  : constant Node_Id   := Expression (Arg1);
+            S  : String_Id;
+            C  : Char_Code;
+
+         begin
+            GNAT_Pragma;
+            Check_Arg_Count (1);
+            Check_Valid_Configuration_Pragma;
+            Check_No_Identifiers;
+
+            if Nkind (A) = N_String_Literal then
+               S   := Strval (A);
+
+               declare
+                  Slen    : Natural := Natural (String_Length (S));
+                  Options : String (1 .. Slen);
+                  J       : Natural;
+
+               begin
+                  J := 1;
+                  loop
+                     C := Get_String_Char (S, Int (J));
+                     exit when not In_Character_Range (C);
+                     Options (J) := Get_Character (C);
+
+                     if J = Slen then
+                        Set_Validity_Check_Options (Options);
+                        exit;
+                     else
+                        J := J + 1;
+                     end if;
+                  end loop;
+               end;
+
+            elsif Nkind (A) = N_Identifier then
+
+               if Chars (A) = Name_All_Checks then
+                  Set_Validity_Check_Options ("a");
+
+               elsif Chars (A) = Name_On then
+                  Validity_Checks_On := True;
+
+               elsif Chars (A) = Name_Off then
+                  Validity_Checks_On := False;
+
+               end if;
+            end if;
+         end Validity_Checks;
+
+         --------------
+         -- Volatile --
+         --------------
+
+         --  pragma Volatile (LOCAL_NAME);
+
+         when Pragma_Volatile =>
+            Process_Atomic_Shared_Volatile;
+
+         -------------------------
+         -- Volatile_Components --
+         -------------------------
+
+         --  pragma Volatile_Components (array_LOCAL_NAME);
+
+         --  Volatile is handled by the same circuit as Atomic_Components
+
+         --------------
+         -- Warnings --
+         --------------
+
+         --  pragma Warnings (On | Off, [LOCAL_NAME])
+
+         when Pragma_Warnings =>
+            GNAT_Pragma;
+            Check_At_Least_N_Arguments (1);
+            Check_At_Most_N_Arguments (2);
+            Check_No_Identifiers;
+
+            --  One argument case was processed by parser in Par.Prag
+
+            if Arg_Count /= 1 then
+               Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
+               Check_Arg_Count (2);
+
+               declare
+                  E_Id : Node_Id;
+                  E    : Entity_Id;
+
+               begin
+                  E_Id := Expression (Arg2);
+                  Analyze (E_Id);
+
+                  if not Is_Entity_Name (E_Id) then
+                     Error_Pragma_Arg
+                       ("second argument of pragma% must be entity name",
+                        Arg2);
+                  end if;
+
+                  E := Entity (E_Id);
+
+                  if E = Any_Id then
+                     return;
+                  else
+                     loop
+                        Set_Warnings_Off (E,
+                          (Chars (Expression (Arg1)) = Name_Off));
+
+                        if Is_Enumeration_Type (E) then
+                           declare
+                              Lit : Entity_Id := First_Literal (E);
+
+                           begin
+                              while Present (Lit) loop
+                                 Set_Warnings_Off (Lit);
+                                 Next_Literal (Lit);
+                              end loop;
+                           end;
+                        end if;
+
+                        exit when No (Homonym (E));
+                        E := Homonym (E);
+                     end loop;
+                  end if;
+               end;
+            end if;
+
+         -------------------
+         -- Weak_External --
+         -------------------
+
+         --  pragma Weak_External ([Entity =>] LOCAL_NAME);
+
+         when Pragma_Weak_External => Weak_External : declare
+            Ent : Entity_Id;
+
+         begin
+            GNAT_Pragma;
+            Check_Arg_Count (1);
+            Check_Optional_Identifier (Arg1, Name_Entity);
+            Check_Arg_Is_Library_Level_Local_Name (Arg1);
+            Ent := Entity (Expression (Arg1));
+
+            if Rep_Item_Too_Early (Ent, N) then
+               return;
+            else
+               Ent := Underlying_Type (Ent);
+            end if;
+
+            --  The only processing required is to link this item on to the
+            --  list of rep items for the given entity. This is accomplished
+            --  by the call to Rep_Item_Too_Late (when no error is detected
+            --  and False is returned).
+
+            if Rep_Item_Too_Late (Ent, N) then
+               return;
+            else
+               Set_Has_Gigi_Rep_Item (Ent);
+            end if;
+         end Weak_External;
+
+      end case;
+
+   exception
+      when Pragma_Exit => null;
+
+   end Analyze_Pragma;
+
+   -------------------------
+   -- Get_Base_Subprogram --
+   -------------------------
+
+   function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id is
+      Result : Entity_Id;
+
+   begin
+      Result := Def_Id;
+
+      --  Follow subprogram renaming chain
+
+      while Is_Subprogram (Result)
+        and then
+          (Is_Generic_Instance (Result)
+            or else Nkind (Parent (Declaration_Node (Result))) =
+              N_Subprogram_Renaming_Declaration)
+        and then Present (Alias (Result))
+      loop
+         Result := Alias (Result);
+      end loop;
+
+      return Result;
+   end Get_Base_Subprogram;
+
+   ---------------------------
+   -- Is_Generic_Subprogram --
+   ---------------------------
+
+   function Is_Generic_Subprogram (Id : Entity_Id) return Boolean is
+   begin
+      return  Ekind (Id) = E_Generic_Procedure
+        or else Ekind (Id) = E_Generic_Function;
+   end Is_Generic_Subprogram;
+
+   ------------------------------
+   -- Is_Pragma_String_Literal --
+   ------------------------------
+
+   --  This function returns true if the corresponding pragma argument is
+   --  a static string expression. These are the only cases in which string
+   --  literals can appear as pragma arguments. We also allow a string
+   --  literal as the first argument to pragma Assert (although it will
+   --  of course always generate a type error).
+
+   function Is_Pragma_String_Literal (Par : Node_Id) return Boolean is
+      Pragn : constant Node_Id := Parent (Par);
+      Assoc : constant List_Id := Pragma_Argument_Associations (Pragn);
+      Pname : constant Name_Id := Chars (Pragn);
+      Argn  : Natural;
+      N     : Node_Id;
+
+   begin
+      Argn := 1;
+      N := First (Assoc);
+      loop
+         exit when N = Par;
+         Argn := Argn + 1;
+         Next (N);
+      end loop;
+
+      if Pname = Name_Assert then
+         return True;
+
+      elsif Pname = Name_Export then
+         return Argn > 2;
+
+      elsif Pname = Name_Ident then
+         return Argn = 1;
+
+      elsif Pname = Name_Import then
+         return Argn > 2;
+
+      elsif Pname = Name_Interface_Name then
+         return Argn > 1;
+
+      elsif Pname = Name_Linker_Alias then
+         return Argn = 2;
+
+      elsif Pname = Name_Linker_Section then
+         return Argn = 2;
+
+      elsif Pname = Name_Machine_Attribute then
+         return Argn = 2;
+
+      elsif Pname = Name_Source_File_Name then
+         return True;
+
+      elsif Pname = Name_Source_Reference then
+         return Argn = 2;
+
+      elsif Pname = Name_Title then
+         return True;
+
+      elsif Pname = Name_Subtitle then
+         return True;
+
+      else
+         return False;
+      end if;
+
+   end Is_Pragma_String_Literal;
+
+   --------------------------------------
+   -- Process_Compilation_Unit_Pragmas --
+   --------------------------------------
+
+   procedure Process_Compilation_Unit_Pragmas (N : Node_Id) is
+   begin
+      --  A special check for pragma Suppress_All. This is a strange DEC
+      --  pragma, strange because it comes at the end of the unit. If we
+      --  have a pragma Suppress_All in the Pragmas_After of the current
+      --  unit, then we insert a pragma Suppress (All_Checks) at the start
+      --  of the context clause to ensure the correct processing.
+
+      declare
+         PA : constant List_Id := Pragmas_After (Aux_Decls_Node (N));
+         P  : Node_Id;
+
+      begin
+         if Present (PA) then
+            P := First (PA);
+            while Present (P) loop
+               if Chars (P) = Name_Suppress_All then
+                  Prepend_To (Context_Items (N),
+                    Make_Pragma (Sloc (P),
+                      Chars => Name_Suppress,
+                      Pragma_Argument_Associations => New_List (
+                        Make_Pragma_Argument_Association (Sloc (P),
+                          Expression =>
+                            Make_Identifier (Sloc (P),
+                              Chars => Name_All_Checks)))));
+                  exit;
+               end if;
+
+               Next (P);
+            end loop;
+         end if;
+      end;
+   end Process_Compilation_Unit_Pragmas;
+
+   --------------------------------
+   -- Set_Encoded_Interface_Name --
+   --------------------------------
+
+   procedure Set_Encoded_Interface_Name (E : Entity_Id; S : Node_Id) is
+      Str : constant String_Id := Strval (S);
+      Len : constant Int       := String_Length (Str);
+      CC  : Char_Code;
+      C   : Character;
+      J   : Int;
+
+      Hex : constant array (0 .. 15) of Character := "0123456789abcdef";
+
+      procedure Encode;
+      --  Stores encoded value of character code CC. The encoding we
+      --  use an underscore followed by four lower case hex digits.
+
+      procedure Encode is
+      begin
+         Store_String_Char (Get_Char_Code ('_'));
+         Store_String_Char
+           (Get_Char_Code (Hex (Integer (CC / 2 ** 12))));
+         Store_String_Char
+           (Get_Char_Code (Hex (Integer (CC / 2 ** 8 and 16#0F#))));
+         Store_String_Char
+           (Get_Char_Code (Hex (Integer (CC / 2 ** 4 and 16#0F#))));
+         Store_String_Char
+           (Get_Char_Code (Hex (Integer (CC and 16#0F#))));
+      end Encode;
+
+   --  Start of processing for Set_Encoded_Interface_Name
+
+   begin
+      --  If first character is asterisk, this is a link name, and we
+      --  leave it completely unmodified. We also ignore null strings
+      --  (the latter case happens only in error cases) and no encoding
+      --  should occur for Java interface names.
+
+      if Len = 0
+        or else Get_String_Char (Str, 1) = Get_Char_Code ('*')
+        or else Java_VM
+      then
+         Set_Interface_Name (E, S);
+
+      else
+         J := 1;
+         loop
+            CC := Get_String_Char (Str, J);
+
+            exit when not In_Character_Range (CC);
+
+            C := Get_Character (CC);
+
+            exit when C /= '_' and then C /= '$'
+              and then C not in '0' .. '9'
+              and then C not in 'a' .. 'z'
+              and then C not in 'A' .. 'Z';
+
+            if J = Len then
+               Set_Interface_Name (E, S);
+               return;
+
+            else
+               J := J + 1;
+            end if;
+         end loop;
+
+         --  Here we need to encode. The encoding we use as follows:
+         --     three underscores  + four hex digits (lower case)
+
+         Start_String;
+
+         for J in 1 .. String_Length (Str) loop
+            CC := Get_String_Char (Str, J);
+
+            if not In_Character_Range (CC) then
+               Encode;
+            else
+               C := Get_Character (CC);
+
+               if C = '_' or else C = '$'
+                 or else C in '0' .. '9'
+                 or else C in 'a' .. 'z'
+                 or else C in 'A' .. 'Z'
+               then
+                  Store_String_Char (CC);
+               else
+                  Encode;
+               end if;
+            end if;
+         end loop;
+
+         Set_Interface_Name (E,
+           Make_String_Literal (Sloc (S),
+             Strval => End_String));
+      end if;
+   end Set_Encoded_Interface_Name;
+
+   -------------------
+   -- Set_Unit_Name --
+   -------------------
+
+   procedure Set_Unit_Name (N : Node_Id; With_Item : Node_Id) is
+      Pref : Node_Id;
+      Scop : Entity_Id;
+
+   begin
+      if Nkind (N) = N_Identifier
+        and then Nkind (With_Item) = N_Identifier
+      then
+         Set_Entity (N, Entity (With_Item));
+
+      elsif Nkind (N) = N_Selected_Component then
+         Change_Selected_Component_To_Expanded_Name (N);
+         Set_Entity (N, Entity (With_Item));
+         Set_Entity (Selector_Name (N), Entity (N));
+
+         Pref := Prefix (N);
+         Scop := Scope (Entity (N));
+
+         while Nkind (Pref) = N_Selected_Component loop
+            Change_Selected_Component_To_Expanded_Name (Pref);
+            Set_Entity (Selector_Name (Pref), Scop);
+            Set_Entity (Pref, Scop);
+            Pref := Prefix (Pref);
+            Scop := Scope (Scop);
+         end loop;
+
+         Set_Entity (Pref, Scop);
+      end if;
+   end Set_Unit_Name;
+
+end Sem_Prag;
diff --git a/gcc/ada/sem_prag.ads b/gcc/ada/sem_prag.ads
new file mode 100644
index 00000000000..fca13a6f3de
--- /dev/null
+++ b/gcc/ada/sem_prag.ads
@@ -0,0 +1,62 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             S E M _ P R A G                              --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.6 $                              --
+--                                                                          --
+--          Copyright (C) 1992-1997 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 handling is isolated in a separate package
+--  (logically this processing belongs in chapter 4)
+
+with Types; use Types;
+package Sem_Prag is
+
+   procedure Analyze_Pragma (N : Node_Id);
+   --  Analyze procedure for pragma reference node N
+
+   function Is_Pragma_String_Literal (Par : Node_Id) return Boolean;
+   --  Given an N_Pragma_Argument_Association node, Par, which has the form
+   --  of an operator symbol, determines whether or not it should be treated
+   --  as an string literal. This is called by Sem_Ch6.Analyze_Operator_Symbol.
+   --  If True is returned, the argument is converted to a string literal. If
+   --  False is returned, then the argument is treated as an entity reference
+   --  to the operator.
+
+   procedure Process_Compilation_Unit_Pragmas (N : Node_Id);
+   --  Called at the start of processing compilation unit N to deal with
+   --  any special issues regarding pragmas. In particular, we have to
+   --  deal with Suppress_All at this stage, since it appears after the
+   --  unit instead of before.
+
+   procedure Set_Encoded_Interface_Name (E : Entity_Id; S : Node_Id);
+   --  This routine is used to set an encoded interface name. The node
+   --  S is an N_String_Literal node for the external name to be set, and
+   --  E is an entity whose Interface_Name field is to be set. In the
+   --  normal case where S contains a name that is a valid C identifier,
+   --  then S is simply set as the value of the Interface_Name. Otherwise
+   --  it is encoded. See the body for details of the encoding. This
+   --  encoding is only done on VMS systems, since it seems pretty silly,
+   --  but is needed to pass some dubious tests in the test suite.
+
+end Sem_Prag;
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
new file mode 100644
index 00000000000..641b120eb7b
--- /dev/null
+++ b/gcc/ada/sem_res.adb
@@ -0,0 +1,6403 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              S E M _ R E S                               --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.717 $
+--                                                                          --
+--          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 Checks;   use Checks;
+with Debug;    use Debug;
+with Debug_A;  use Debug_A;
+with Einfo;    use Einfo;
+with Errout;   use Errout;
+with Expander; use Expander;
+with Exp_Ch7;  use Exp_Ch7;
+with Exp_Util; use Exp_Util;
+with Freeze;   use Freeze;
+with Itypes;   use Itypes;
+with Lib;      use Lib;
+with Lib.Xref; use Lib.Xref;
+with Namet;    use Namet;
+with Nmake;    use Nmake;
+with Nlists;   use Nlists;
+with Opt;      use Opt;
+with Output;   use Output;
+with Restrict; use Restrict;
+with Rtsfind;  use Rtsfind;
+with Sem;      use Sem;
+with Sem_Aggr; use Sem_Aggr;
+with Sem_Attr; use Sem_Attr;
+with Sem_Cat;  use Sem_Cat;
+with Sem_Ch4;  use Sem_Ch4;
+with Sem_Ch6;  use Sem_Ch6;
+with Sem_Ch8;  use Sem_Ch8;
+with Sem_Disp; use Sem_Disp;
+with Sem_Dist; use Sem_Dist;
+with Sem_Elab; use Sem_Elab;
+with Sem_Eval; use Sem_Eval;
+with Sem_Intr; use Sem_Intr;
+with Sem_Util; use Sem_Util;
+with Sem_Type; use Sem_Type;
+with Sem_Warn; use Sem_Warn;
+with Sinfo;    use Sinfo;
+with Stand;    use Stand;
+with Stringt;  use Stringt;
+with Targparm; use Targparm;
+with Tbuild;   use Tbuild;
+with Uintp;    use Uintp;
+with Urealp;   use Urealp;
+
+package body Sem_Res is
+
+   -----------------------
+   -- Local Subprograms --
+   -----------------------
+
+   --  Second pass (top-down) type checking and overload resolution procedures
+   --  Typ is the type required by context. These procedures propagate the
+   --  type information recursively to the descendants of N. If the node
+   --  is not overloaded, its Etype is established in the first pass. If
+   --  overloaded,  the Resolve routines set the correct type. For arith.
+   --  operators, the Etype is the base type of the context.
+
+   --  Note that Resolve_Attribute is separated off in Sem_Attr
+
+   procedure Ambiguous_Character (C : Node_Id);
+   --  Give list of candidate interpretations when a character literal cannot
+   --  be resolved.
+
+   procedure Check_Discriminant_Use (N : Node_Id);
+   --  Enforce the restrictions on the use of discriminants when constraining
+   --  a component of a discriminated type (record or concurrent type).
+
+   procedure Check_For_Visible_Operator (N : Node_Id; T : Entity_Id);
+   --  Given a node for an operator associated with type T, check that
+   --  the operator is visible. Operators all of whose operands are
+   --  universal must be checked for visibility during resolution
+   --  because their type is not determinable based on their operands.
+
+   function Check_Infinite_Recursion (N : Node_Id) return Boolean;
+   --  Given a call node, N, which is known to occur immediately within the
+   --  subprogram being called, determines whether it is a detectable case of
+   --  an infinite recursion, and if so, outputs appropriate messages. Returns
+   --  True if an infinite recursion is detected, and False otherwise.
+
+   procedure Check_Initialization_Call (N : Entity_Id; Nam : Entity_Id);
+   --  If the type of the object being initialized uses the secondary stack
+   --  directly or indirectly, create a transient scope for the call to the
+   --  Init_Proc. This is because we do not create transient scopes for the
+   --  initialization of individual components within the init_proc itself.
+   --  Could be optimized away perhaps?
+
+   function Is_Predefined_Op (Nam : Entity_Id) return Boolean;
+   --  Utility to check whether the name in the call is a predefined
+   --  operator, in which case the call is made into an operator node.
+   --  An instance of an intrinsic conversion operation may be given
+   --  an operator name, but is not treated like an operator.
+
+   procedure Replace_Actual_Discriminants (N : Node_Id; Default : Node_Id);
+   --  If a default expression in entry call N depends on the discriminants
+   --  of the task, it must be replaced with a reference to the discriminant
+   --  of the task being called.
+
+   procedure Resolve_Allocator                 (N : Node_Id; Typ : Entity_Id);
+   procedure Resolve_Arithmetic_Op             (N : Node_Id; Typ : Entity_Id);
+   procedure Resolve_Call                      (N : Node_Id; Typ : Entity_Id);
+   procedure Resolve_Character_Literal         (N : Node_Id; Typ : Entity_Id);
+   procedure Resolve_Comparison_Op             (N : Node_Id; Typ : Entity_Id);
+   procedure Resolve_Conditional_Expression    (N : Node_Id; Typ : Entity_Id);
+   procedure Resolve_Equality_Op               (N : Node_Id; Typ : Entity_Id);
+   procedure Resolve_Explicit_Dereference      (N : Node_Id; Typ : Entity_Id);
+   procedure Resolve_Entity_Name               (N : Node_Id; Typ : Entity_Id);
+   procedure Resolve_Indexed_Component         (N : Node_Id; Typ : Entity_Id);
+   procedure Resolve_Integer_Literal           (N : Node_Id; Typ : Entity_Id);
+   procedure Resolve_Logical_Op                (N : Node_Id; Typ : Entity_Id);
+   procedure Resolve_Membership_Op             (N : Node_Id; Typ : Entity_Id);
+   procedure Resolve_Null                      (N : Node_Id; Typ : Entity_Id);
+   procedure Resolve_Operator_Symbol           (N : Node_Id; Typ : Entity_Id);
+   procedure Resolve_Op_Concat                 (N : Node_Id; Typ : Entity_Id);
+   procedure Resolve_Op_Expon                  (N : Node_Id; Typ : Entity_Id);
+   procedure Resolve_Op_Not                    (N : Node_Id; Typ : Entity_Id);
+   procedure Resolve_Qualified_Expression      (N : Node_Id; Typ : Entity_Id);
+   procedure Resolve_Range                     (N : Node_Id; Typ : Entity_Id);
+   procedure Resolve_Real_Literal              (N : Node_Id; Typ : Entity_Id);
+   procedure Resolve_Reference                 (N : Node_Id; Typ : Entity_Id);
+   procedure Resolve_Selected_Component        (N : Node_Id; Typ : Entity_Id);
+   procedure Resolve_Shift                     (N : Node_Id; Typ : Entity_Id);
+   procedure Resolve_Short_Circuit             (N : Node_Id; Typ : Entity_Id);
+   procedure Resolve_Slice                     (N : Node_Id; Typ : Entity_Id);
+   procedure Resolve_String_Literal            (N : Node_Id; Typ : Entity_Id);
+   procedure Resolve_Subprogram_Info           (N : Node_Id; Typ : Entity_Id);
+   procedure Resolve_Type_Conversion           (N : Node_Id; Typ : Entity_Id);
+   procedure Resolve_Unary_Op                  (N : Node_Id; Typ : Entity_Id);
+   procedure Resolve_Unchecked_Expression      (N : Node_Id; Typ : Entity_Id);
+   procedure Resolve_Unchecked_Type_Conversion (N : Node_Id; Typ : Entity_Id);
+
+   function Operator_Kind
+     (Op_Name   : Name_Id;
+      Is_Binary : Boolean)
+      return      Node_Kind;
+   --  Utility to map the name of an operator into the corresponding Node. Used
+   --  by other node rewriting procedures.
+
+   procedure Resolve_Actuals (N : Node_Id; Nam : Entity_Id);
+   --  Resolve actuals of call, and add default expressions for missing ones.
+
+   procedure Resolve_Entry_Call (N : Node_Id; Typ : Entity_Id);
+   --  Called from Resolve_Call, when the prefix denotes an entry or element
+   --  of entry family. Actuals are resolved as for subprograms, and the node
+   --  is rebuilt as an entry call. Also called for protected operations. Typ
+   --  is the context type, which is used when the operation is a protected
+   --  function with no arguments, and the return value is indexed.
+
+   procedure Resolve_Intrinsic_Operator (N : Node_Id; Typ : Entity_Id);
+   --  A call to a user-defined intrinsic operator is rewritten as a call
+   --  to the corresponding predefined operator, with suitable conversions.
+
+   procedure Rewrite_Operator_As_Call (N : Node_Id; Nam : Entity_Id);
+   --  If an operator node resolves to a call to a user-defined operator,
+   --  rewrite the node as a function call.
+
+   procedure Make_Call_Into_Operator
+     (N     : Node_Id;
+      Typ   : Entity_Id;
+      Op_Id : Entity_Id);
+   --  Inverse transformation: if an operator is given in functional notation,
+   --  then after resolving the node, transform into an operator node, so
+   --  that operands are resolved properly. Recall that predefined operators
+   --  do not have a full signature and special resolution rules apply.
+
+   procedure Rewrite_Renamed_Operator (N : Node_Id; Op : Entity_Id);
+   --  An operator can rename another, e.g. in  an instantiation. In that
+   --  case, the proper operator node must be constructed.
+
+   procedure Set_String_Literal_Subtype (N : Node_Id; Typ : Entity_Id);
+   --  The String_Literal_Subtype is built for all strings that are not
+   --  operands of a static concatenation operation. If the argument is not
+   --  a String the function is a no-op.
+
+   procedure Set_Slice_Subtype (N : Node_Id);
+   --  Build subtype of array type, with the range specified by the slice.
+
+   function Unique_Fixed_Point_Type (N : Node_Id) return Entity_Id;
+   --  A universal_fixed expression in an universal context is unambiguous if
+   --  there is only one applicable fixed point type. Determining whether
+   --  there is only one requires a search over all visible entities, and
+   --  happens only in very pathological cases (see 6115-006).
+
+   function Valid_Conversion
+     (N       : Node_Id;
+      Target  : Entity_Id;
+      Operand : Node_Id)
+      return    Boolean;
+   --  Verify legality rules given in 4.6 (8-23). Target is the target
+   --  type of the conversion, which may be an implicit conversion of
+   --  an actual parameter to an anonymous access type (in which case
+   --  N denotes the actual parameter and N = Operand).
+
+   -------------------------
+   -- Ambiguous_Character --
+   -------------------------
+
+   procedure Ambiguous_Character (C : Node_Id) is
+      E : Entity_Id;
+
+   begin
+      if Nkind (C) = N_Character_Literal then
+         Error_Msg_N ("ambiguous character literal", C);
+         Error_Msg_N
+           ("\possible interpretations: Character, Wide_Character!", C);
+
+         E := Current_Entity (C);
+
+         if Present (E) then
+
+            while Present (E) loop
+               Error_Msg_NE ("\possible interpretation:}!", C, Etype (E));
+               E := Homonym (E);
+            end loop;
+         end if;
+      end if;
+   end Ambiguous_Character;
+
+   -------------------------
+   -- Analyze_And_Resolve --
+   -------------------------
+
+   procedure Analyze_And_Resolve (N : Node_Id) is
+   begin
+      Analyze (N);
+      Resolve (N, Etype (N));
+   end Analyze_And_Resolve;
+
+   procedure Analyze_And_Resolve (N : Node_Id; Typ : Entity_Id) is
+   begin
+      Analyze (N);
+      Resolve (N, Typ);
+   end Analyze_And_Resolve;
+
+   --  Version withs check(s) suppressed
+
+   procedure Analyze_And_Resolve
+     (N        : Node_Id;
+      Typ      : Entity_Id;
+      Suppress : Check_Id)
+   is
+      Scop : Entity_Id := Current_Scope;
+
+   begin
+      if Suppress = All_Checks then
+         declare
+            Svg : constant Suppress_Record := Scope_Suppress;
+
+         begin
+            Scope_Suppress := (others => True);
+            Analyze_And_Resolve (N, Typ);
+            Scope_Suppress := Svg;
+         end;
+
+      else
+         declare
+            Svg : constant Boolean := Get_Scope_Suppress (Suppress);
+
+         begin
+            Set_Scope_Suppress (Suppress, True);
+            Analyze_And_Resolve (N, Typ);
+            Set_Scope_Suppress (Suppress, Svg);
+         end;
+      end if;
+
+      if Current_Scope /= Scop
+        and then Scope_Is_Transient
+      then
+         --  This can only happen if a transient scope was created
+         --  for an inner expression, which will be removed upon
+         --  completion of the analysis of an enclosing construct.
+         --  The transient scope must have the suppress status of
+         --  the enclosing environment, not of this Analyze call.
+
+         Scope_Stack.Table (Scope_Stack.Last).Save_Scope_Suppress :=
+           Scope_Suppress;
+      end if;
+   end Analyze_And_Resolve;
+
+   procedure Analyze_And_Resolve
+     (N        : Node_Id;
+      Suppress : Check_Id)
+   is
+      Scop : Entity_Id := Current_Scope;
+
+   begin
+      if Suppress = All_Checks then
+         declare
+            Svg : constant Suppress_Record := Scope_Suppress;
+
+         begin
+            Scope_Suppress := (others => True);
+            Analyze_And_Resolve (N);
+            Scope_Suppress := Svg;
+         end;
+
+      else
+         declare
+            Svg : constant Boolean := Get_Scope_Suppress (Suppress);
+
+         begin
+            Set_Scope_Suppress (Suppress, True);
+            Analyze_And_Resolve (N);
+            Set_Scope_Suppress (Suppress, Svg);
+         end;
+      end if;
+
+      if Current_Scope /= Scop
+        and then Scope_Is_Transient
+      then
+         Scope_Stack.Table (Scope_Stack.Last).Save_Scope_Suppress :=
+           Scope_Suppress;
+      end if;
+   end Analyze_And_Resolve;
+
+   ----------------------------
+   -- Check_Discriminant_Use --
+   ----------------------------
+
+   procedure Check_Discriminant_Use (N : Node_Id) is
+      PN   : constant Node_Id   := Parent (N);
+      Disc : constant Entity_Id := Entity (N);
+      P    : Node_Id;
+      D    : Node_Id;
+
+   begin
+      --  Any use in a default expression is legal.
+
+      if In_Default_Expression then
+         null;
+
+      elsif Nkind (PN) = N_Range then
+
+         --  Discriminant cannot be used to constrain a scalar type.
+
+         P := Parent (PN);
+
+         if Nkind (P) = N_Range_Constraint
+           and then Nkind (Parent (P)) = N_Subtype_Indication
+           and then Nkind (Parent (Parent (P))) = N_Component_Declaration
+         then
+            Error_Msg_N ("discriminant cannot constrain scalar type", N);
+
+         elsif Nkind (P) = N_Index_Or_Discriminant_Constraint then
+
+            --  The following check catches the unusual case where
+            --  a discriminant appears within an index constraint
+            --  that is part of a larger expression within a constraint
+            --  on a component, e.g. "C : Int range 1 .. F (new A(1 .. D))".
+            --  For now we only check case of record components, and
+            --  note that a similar check should also apply in the
+            --  case of discriminant constraints below. ???
+
+            --  Note that the check for N_Subtype_Declaration below is to
+            --  detect the valid use of discriminants in the constraints of a
+            --  subtype declaration when this subtype declaration appears
+            --  inside the scope of a record type (which is syntactically
+            --  illegal, but which may be created as part of derived type
+            --  processing for records). See Sem_Ch3.Build_Derived_Record_Type
+            --  for more info.
+
+            if Ekind (Current_Scope) = E_Record_Type
+              and then Scope (Disc) = Current_Scope
+              and then not
+                (Nkind (Parent (P)) = N_Subtype_Indication
+                 and then
+                  (Nkind (Parent (Parent (P))) = N_Component_Declaration
+                   or else Nkind (Parent (Parent (P))) = N_Subtype_Declaration)
+                  and then Paren_Count (N) = 0)
+            then
+               Error_Msg_N
+                 ("discriminant must appear alone in component constraint", N);
+               return;
+            end if;
+
+            --   Detect a common beginner error:
+            --   type R (D : Positive := 100) is record
+            --     Name: String (1 .. D);
+            --   end record;
+
+            --  The default value causes an object of type R to be
+            --  allocated with room for Positive'Last characters.
+
+            declare
+               SI : Node_Id;
+               T  : Entity_Id;
+               TB : Node_Id;
+               CB : Entity_Id;
+
+               function Large_Storage_Type (T : Entity_Id) return Boolean;
+               --  Return True if type T has a large enough range that
+               --  any array whose index type covered the whole range of
+               --  the type would likely raise Storage_Error.
+
+               function Large_Storage_Type (T : Entity_Id) return Boolean is
+               begin
+                  return
+                    T = Standard_Integer
+                      or else
+                    T = Standard_Positive
+                      or else
+                    T = Standard_Natural;
+               end Large_Storage_Type;
+
+            begin
+               --  Check that the Disc has a large range
+
+               if not Large_Storage_Type (Etype (Disc)) then
+                  goto No_Danger;
+               end if;
+
+               --  If the enclosing type is limited, we allocate only the
+               --  default value, not the maximum, and there is no need for
+               --  a warning.
+
+               if Is_Limited_Type (Scope (Disc)) then
+                  goto No_Danger;
+               end if;
+
+               --  Check that it is the high bound
+
+               if N /= High_Bound (PN)
+                 or else not Present (Discriminant_Default_Value (Disc))
+               then
+                  goto No_Danger;
+               end if;
+
+               --  Check the array allows a large range at this bound.
+               --  First find the array
+
+               SI := Parent (P);
+
+               if Nkind (SI) /= N_Subtype_Indication then
+                  goto No_Danger;
+               end if;
+
+               T := Entity (Subtype_Mark (SI));
+
+               if not Is_Array_Type (T) then
+                  goto No_Danger;
+               end if;
+
+               --  Next, find the dimension
+
+               TB := First_Index (T);
+               CB := First (Constraints (P));
+               while True
+                 and then Present (TB)
+                 and then Present (CB)
+                 and then CB /= PN
+               loop
+                  Next_Index (TB);
+                  Next (CB);
+               end loop;
+
+               if CB /= PN then
+                  goto No_Danger;
+               end if;
+
+               --  Now, check the dimension has a large range
+
+               if not Large_Storage_Type (Etype (TB)) then
+                  goto No_Danger;
+               end if;
+
+               --  Warn about the danger
+
+               Error_Msg_N
+                 ("creation of object of this type may raise Storage_Error?",
+                  N);
+
+               <<No_Danger>>
+                  null;
+
+            end;
+         end if;
+
+      --  Legal case is in index or discriminant constraint
+
+      elsif Nkind (PN) = N_Index_Or_Discriminant_Constraint
+        or else Nkind (PN) = N_Discriminant_Association
+      then
+         if Paren_Count (N) > 0 then
+            Error_Msg_N
+              ("discriminant in constraint must appear alone",  N);
+         end if;
+
+         return;
+
+      --  Otherwise, context is an expression. It should not be within
+      --  (i.e. a subexpression of) a constraint for a component.
+
+      else
+         D := PN;
+         P := Parent (PN);
+
+         while Nkind (P) /= N_Component_Declaration
+           and then Nkind (P) /= N_Subtype_Indication
+           and then Nkind (P) /= N_Entry_Declaration
+         loop
+            D := P;
+            P := Parent (P);
+            exit when No (P);
+         end loop;
+
+         --  If the discriminant is used in an expression that is a bound
+         --  of a scalar type, an Itype is created and the bounds are attached
+         --  to its range,  not to the original subtype indication. Such use
+         --  is of course a double fault.
+
+         if (Nkind (P) = N_Subtype_Indication
+              and then
+                (Nkind (Parent (P)) = N_Component_Declaration
+                  or else Nkind (Parent (P)) = N_Derived_Type_Definition)
+              and then D = Constraint (P))
+
+         --  The constraint itself may be given by a subtype indication,
+         --  rather than by a more common discrete range.
+
+           or else (Nkind (P) = N_Subtype_Indication
+             and then Nkind (Parent (P)) = N_Index_Or_Discriminant_Constraint)
+
+           or else Nkind (P) = N_Entry_Declaration
+           or else Nkind (D) = N_Defining_Identifier
+         then
+            Error_Msg_N
+              ("discriminant in constraint must appear alone",  N);
+         end if;
+      end if;
+   end Check_Discriminant_Use;
+
+   --------------------------------
+   -- Check_For_Visible_Operator --
+   --------------------------------
+
+   procedure Check_For_Visible_Operator (N : Node_Id; T : Entity_Id) is
+      Orig_Node : Node_Id := Original_Node (N);
+
+   begin
+      if Comes_From_Source (Orig_Node)
+        and then not In_Open_Scopes (Scope (T))
+        and then not Is_Potentially_Use_Visible (T)
+        and then not In_Use (T)
+        and then not In_Use (Scope (T))
+        and then (not Present (Entity (N))
+                   or else Ekind (Entity (N)) /= E_Function)
+        and then (Nkind (Orig_Node) /= N_Function_Call
+                   or else Nkind (Name (Orig_Node)) /= N_Expanded_Name
+                   or else Entity (Prefix (Name (Orig_Node))) /= Scope (T))
+        and then not In_Instance
+      then
+         Error_Msg_NE
+           ("operator for} is not directly visible!", N, First_Subtype (T));
+         Error_Msg_N ("use clause would make operation legal!", N);
+      end if;
+   end Check_For_Visible_Operator;
+
+   ------------------------------
+   -- Check_Infinite_Recursion --
+   ------------------------------
+
+   function Check_Infinite_Recursion (N : Node_Id) return Boolean is
+      P : Node_Id;
+      C : Node_Id;
+
+   begin
+      --  Loop moving up tree, quitting if something tells us we are
+      --  definitely not in an infinite recursion situation.
+
+      C := N;
+      loop
+         P := Parent (C);
+         exit when Nkind (P) = N_Subprogram_Body;
+
+         if Nkind (P) = N_Or_Else        or else
+            Nkind (P) = N_And_Then       or else
+            Nkind (P) = N_If_Statement   or else
+            Nkind (P) = N_Case_Statement
+         then
+            return False;
+
+         elsif Nkind (P) = N_Handled_Sequence_Of_Statements
+           and then C /= First (Statements (P))
+         then
+            return False;
+
+         else
+            C := P;
+         end if;
+      end loop;
+
+      Warn_On_Instance := True;
+      Error_Msg_N ("possible infinite recursion?", N);
+      Error_Msg_N ("\Storage_Error may be raised at run time?", N);
+      Warn_On_Instance := False;
+
+      return True;
+   end Check_Infinite_Recursion;
+
+   -------------------------------
+   -- Check_Initialization_Call --
+   -------------------------------
+
+   procedure Check_Initialization_Call (N : Entity_Id; Nam : Entity_Id) is
+      Typ : Entity_Id := Etype (First_Formal (Nam));
+
+      function Uses_SS (T : Entity_Id) return Boolean;
+
+      function Uses_SS (T : Entity_Id) return Boolean is
+         Comp : Entity_Id;
+         Expr : Node_Id;
+
+      begin
+         if Is_Controlled (T)
+           or else Has_Controlled_Component (T)
+           or else Functions_Return_By_DSP_On_Target
+         then
+            return False;
+
+         elsif Is_Array_Type (T) then
+            return Uses_SS (Component_Type (T));
+
+         elsif Is_Record_Type (T) then
+            Comp := First_Component (T);
+
+            while Present (Comp) loop
+
+               if Ekind (Comp) = E_Component
+                 and then Nkind (Parent (Comp)) = N_Component_Declaration
+               then
+                  Expr := Expression (Parent (Comp));
+
+                  if Nkind (Expr) = N_Function_Call
+                    and then Requires_Transient_Scope (Etype (Expr))
+                  then
+                     return True;
+
+                  elsif Uses_SS (Etype (Comp)) then
+                     return True;
+                  end if;
+               end if;
+
+               Next_Component (Comp);
+            end loop;
+
+            return False;
+
+         else
+            return False;
+         end if;
+      end Uses_SS;
+
+   begin
+      if Uses_SS (Typ) then
+         Establish_Transient_Scope (First_Actual (N), Sec_Stack => True);
+      end if;
+   end Check_Initialization_Call;
+
+   ------------------------------
+   -- Check_Parameterless_Call --
+   ------------------------------
+
+   procedure Check_Parameterless_Call (N : Node_Id) is
+      Nam : Node_Id;
+
+   begin
+      if Nkind (N) in N_Has_Etype and then Etype (N) = Any_Type then
+         return;
+      end if;
+
+      --  Rewrite as call if overloadable entity that is (or could be, in
+      --  the overloaded case) a function call. If we know for sure that
+      --  the entity is an enumeration literal, we do not rewrite it.
+
+      if (Is_Entity_Name (N)
+            and then Is_Overloadable (Entity (N))
+            and then (Ekind (Entity (N)) /= E_Enumeration_Literal
+                        or else Is_Overloaded (N)))
+
+      --  Rewrite as call if it is an explicit deference of an expression of
+      --  a subprogram access type, and the suprogram type is not that of a
+      --  procedure or entry.
+
+      or else
+        (Nkind (N) = N_Explicit_Dereference
+          and then Ekind (Etype (N)) = E_Subprogram_Type
+          and then Base_Type (Etype (Etype (N))) /= Standard_Void_Type)
+
+      --  Rewrite as call if it is a selected component which is a function,
+      --  this is the case of a call to a protected function (which may be
+      --  overloaded with other protected operations).
+
+      or else
+        (Nkind (N) = N_Selected_Component
+          and then (Ekind (Entity (Selector_Name (N))) = E_Function
+            or else ((Ekind (Entity (Selector_Name (N))) = E_Entry
+                       or else
+                      Ekind (Entity (Selector_Name (N))) = E_Procedure)
+              and then Is_Overloaded (Selector_Name (N)))))
+
+      --  If one of the above three conditions is met, rewrite as call.
+      --  Apply the rewriting only once.
+
+      then
+         if Nkind (Parent (N)) /= N_Function_Call
+           or else N /= Name (Parent (N))
+         then
+            Nam := New_Copy (N);
+
+            --  If overloaded, overload set belongs to new copy.
+
+            Save_Interps (N, Nam);
+
+            --  Change node to parameterless function call (note that the
+            --  Parameter_Associations associations field is left set to Empty,
+            --  its normal default value since there are no parameters)
+
+            Change_Node (N, N_Function_Call);
+            Set_Name (N, Nam);
+            Set_Sloc (N, Sloc (Nam));
+            Analyze_Call (N);
+         end if;
+
+      elsif Nkind (N) = N_Parameter_Association then
+         Check_Parameterless_Call (Explicit_Actual_Parameter (N));
+      end if;
+   end Check_Parameterless_Call;
+
+   ----------------------
+   -- Is_Predefined_Op --
+   ----------------------
+
+   function Is_Predefined_Op (Nam : Entity_Id) return Boolean is
+   begin
+      return Is_Intrinsic_Subprogram (Nam)
+        and then not Is_Generic_Instance (Nam)
+        and then Chars (Nam) in Any_Operator_Name
+        and then (No (Alias (Nam))
+                   or else Is_Predefined_Op (Alias (Nam)));
+   end Is_Predefined_Op;
+
+   -----------------------------
+   -- Make_Call_Into_Operator --
+   -----------------------------
+
+   procedure Make_Call_Into_Operator
+     (N     : Node_Id;
+      Typ   : Entity_Id;
+      Op_Id : Entity_Id)
+   is
+      Op_Name   : constant Name_Id := Chars (Op_Id);
+      Act1      : Node_Id := First_Actual (N);
+      Act2      : Node_Id := Next_Actual (Act1);
+      Error     : Boolean := False;
+      Is_Binary : constant Boolean := Present (Act2);
+      Op_Node   : Node_Id;
+      Opnd_Type : Entity_Id;
+      Orig_Type : Entity_Id := Empty;
+      Pack      : Entity_Id;
+
+      type Kind_Test is access function (E : Entity_Id) return Boolean;
+
+      function Is_Definite_Access_Type (E : Entity_Id) return Boolean;
+      --  Determine whether E is an acess type declared by an access decla-
+      --  ration, and  not an (anonymous) allocator type.
+
+      function Operand_Type_In_Scope (S : Entity_Id) return Boolean;
+      --  If the operand is not universal, and the operator is given by a
+      --  expanded name,  verify that the operand has an interpretation with
+      --  a type defined in the given scope of the operator.
+
+      function Type_In_P (Test : Kind_Test) return Entity_Id;
+      --  Find a type of the given class in the package Pack that contains
+      --  the operator.
+
+      -----------------------------
+      -- Is_Definite_Access_Type --
+      -----------------------------
+
+      function Is_Definite_Access_Type (E : Entity_Id) return Boolean is
+         Btyp : constant Entity_Id := Base_Type (E);
+      begin
+         return Ekind (Btyp) = E_Access_Type
+           or else (Ekind (Btyp) = E_Access_Subprogram_Type
+                     and then Comes_From_Source (Btyp));
+      end Is_Definite_Access_Type;
+
+      ---------------------------
+      -- Operand_Type_In_Scope --
+      ---------------------------
+
+      function Operand_Type_In_Scope (S : Entity_Id) return Boolean is
+         Nod : constant Node_Id := Right_Opnd (Op_Node);
+         I   : Interp_Index;
+         It  : Interp;
+
+      begin
+         if not Is_Overloaded (Nod) then
+            return Scope (Base_Type (Etype (Nod))) = S;
+
+         else
+            Get_First_Interp (Nod, I, It);
+
+            while Present (It.Typ) loop
+
+               if Scope (Base_Type (It.Typ)) = S then
+                  return True;
+               end if;
+
+               Get_Next_Interp (I, It);
+            end loop;
+
+            return False;
+         end if;
+      end Operand_Type_In_Scope;
+
+      ---------------
+      -- Type_In_P --
+      ---------------
+
+      function Type_In_P (Test : Kind_Test) return Entity_Id is
+         E : Entity_Id;
+
+         function In_Decl return Boolean;
+         --  Verify that node is not part of the type declaration for the
+         --  candidate type, which would otherwise be invisible.
+
+         -------------
+         -- In_Decl --
+         -------------
+
+         function In_Decl return Boolean is
+            Decl_Node : constant Node_Id := Parent (E);
+            N2        : Node_Id;
+
+         begin
+            N2 := N;
+
+            if Etype (E) = Any_Type then
+               return True;
+
+            elsif No (Decl_Node) then
+               return False;
+
+            else
+               while Present (N2)
+                 and then Nkind (N2) /= N_Compilation_Unit
+               loop
+                  if N2 = Decl_Node then
+                     return True;
+                  else
+                     N2 := Parent (N2);
+                  end if;
+               end loop;
+
+               return False;
+            end if;
+         end In_Decl;
+
+      --  Start of processing for Type_In_P
+
+      begin
+         --  If the context type is declared in the prefix package, this
+         --  is the desired base type.
+
+         if Scope (Base_Type (Typ)) = Pack
+           and then Test (Typ)
+         then
+            return Base_Type (Typ);
+
+         else
+            E := First_Entity (Pack);
+
+            while Present (E) loop
+
+               if Test (E)
+                 and then not In_Decl
+               then
+                  return E;
+               end if;
+
+               Next_Entity (E);
+            end loop;
+
+            return Empty;
+         end if;
+      end Type_In_P;
+
+      ---------------------------
+      -- Operand_Type_In_Scope --
+      ---------------------------
+
+   --  Start of processing for Make_Call_Into_Operator
+
+   begin
+      Op_Node := New_Node (Operator_Kind (Op_Name, Is_Binary), Sloc (N));
+
+      --  Binary operator
+
+      if Is_Binary then
+         Set_Left_Opnd  (Op_Node, Relocate_Node (Act1));
+         Set_Right_Opnd (Op_Node, Relocate_Node (Act2));
+         Save_Interps (Act1, Left_Opnd  (Op_Node));
+         Save_Interps (Act2, Right_Opnd (Op_Node));
+         Act1 := Left_Opnd (Op_Node);
+         Act2 := Right_Opnd (Op_Node);
+
+      --  Unary operator
+
+      else
+         Set_Right_Opnd (Op_Node, Relocate_Node (Act1));
+         Save_Interps (Act1, Right_Opnd (Op_Node));
+         Act1 := Right_Opnd (Op_Node);
+      end if;
+
+      --  If the operator is denoted by an expanded name, and the prefix is
+      --  not Standard, but the operator is a predefined one whose scope is
+      --  Standard, then this is an implicit_operator, inserted as an
+      --  interpretation by the procedure of the same name. This procedure
+      --  overestimates the presence of implicit operators, because it does
+      --  not examine the type of the operands. Verify now that the operand
+      --  type appears in the given scope. If right operand is universal,
+      --  check the other operand. In the case of concatenation, either
+      --  argument can be the component type, so check the type of the result.
+      --  If both arguments are literals, look for a type of the right kind
+      --  defined in the given scope. This elaborate nonsense is brought to
+      --  you courtesy of b33302a. The type itself must be frozen, so we must
+      --  find the type of the proper class in the given scope.
+
+      --  A final wrinkle is the multiplication operator for fixed point
+      --  types, which is defined in Standard only, and not in the scope of
+      --  the fixed_point type itself.
+
+      if Nkind (Name (N)) = N_Expanded_Name then
+         Pack := Entity (Prefix (Name (N)));
+
+         --  If the entity being called is defined in the given package,
+         --  it is a renaming of a predefined operator, and known to be
+         --  legal.
+
+         if Scope (Entity (Name (N))) = Pack
+            and then Pack /= Standard_Standard
+         then
+            null;
+
+         elsif (Op_Name =  Name_Op_Multiply
+              or else Op_Name = Name_Op_Divide)
+           and then Is_Fixed_Point_Type (Etype (Left_Opnd  (Op_Node)))
+           and then Is_Fixed_Point_Type (Etype (Right_Opnd (Op_Node)))
+         then
+            if Pack /= Standard_Standard then
+               Error := True;
+            end if;
+
+         else
+            Opnd_Type := Base_Type (Etype (Right_Opnd (Op_Node)));
+
+            if Op_Name = Name_Op_Concat then
+               Opnd_Type := Base_Type (Typ);
+
+            elsif (Scope (Opnd_Type) = Standard_Standard
+                     and then Is_Binary)
+              or else (Nkind (Right_Opnd (Op_Node)) = N_Attribute_Reference
+                        and then Is_Binary
+                        and then not Comes_From_Source (Opnd_Type))
+            then
+               Opnd_Type := Base_Type (Etype (Left_Opnd (Op_Node)));
+            end if;
+
+            if Scope (Opnd_Type) = Standard_Standard then
+
+               --  Verify that the scope contains a type that corresponds to
+               --  the given literal. Optimize the case where Pack is Standard.
+
+               if Pack /= Standard_Standard then
+
+                  if Opnd_Type = Universal_Integer then
+                     Orig_Type :=  Type_In_P (Is_Integer_Type'Access);
+
+                  elsif Opnd_Type = Universal_Real then
+                     Orig_Type := Type_In_P (Is_Real_Type'Access);
+
+                  elsif Opnd_Type = Any_String then
+                     Orig_Type := Type_In_P (Is_String_Type'Access);
+
+                  elsif Opnd_Type = Any_Access then
+                     Orig_Type :=  Type_In_P (Is_Definite_Access_Type'Access);
+
+                  elsif Opnd_Type = Any_Composite then
+                     Orig_Type := Type_In_P (Is_Composite_Type'Access);
+
+                     if Present (Orig_Type) then
+                        if Has_Private_Component (Orig_Type) then
+                           Orig_Type := Empty;
+                        else
+                           Set_Etype (Act1, Orig_Type);
+
+                           if Is_Binary then
+                              Set_Etype (Act2, Orig_Type);
+                           end if;
+                        end if;
+                     end if;
+
+                  else
+                     Orig_Type := Empty;
+                  end if;
+
+                  Error := No (Orig_Type);
+               end if;
+
+            elsif Ekind (Opnd_Type) = E_Allocator_Type
+               and then No (Type_In_P (Is_Definite_Access_Type'Access))
+            then
+               Error := True;
+
+            --  If the type is defined elsewhere, and the operator is not
+            --  defined in the given scope (by a renaming declaration, e.g.)
+            --  then this is an error as well. If an extension of System is
+            --  present, and the type may be defined there, Pack must be
+            --  System itself.
+
+            elsif Scope (Opnd_Type) /= Pack
+              and then Scope (Op_Id) /= Pack
+              and then (No (System_Aux_Id)
+                         or else Scope (Opnd_Type) /= System_Aux_Id
+                         or else Pack /= Scope (System_Aux_Id))
+            then
+               Error := True;
+
+            elsif Pack = Standard_Standard
+              and then not Operand_Type_In_Scope (Standard_Standard)
+            then
+               Error := True;
+            end if;
+         end if;
+
+         if Error then
+            Error_Msg_Node_2 := Pack;
+            Error_Msg_NE
+              ("& not declared in&", N, Selector_Name (Name (N)));
+            Set_Etype (N, Any_Type);
+            return;
+         end if;
+      end if;
+
+      Set_Chars  (Op_Node, Op_Name);
+      Set_Etype  (Op_Node, Base_Type (Etype (N)));
+      Set_Entity (Op_Node, Op_Id);
+      Generate_Reference (Op_Id, N, ' ');
+      Rewrite (N,  Op_Node);
+      Resolve (N, Typ);
+
+      --  For predefined operators on literals, the operation freezes
+      --  their type.
+
+      if Present (Orig_Type) then
+         Set_Etype (Act1, Orig_Type);
+         Freeze_Expression (Act1);
+      end if;
+   end Make_Call_Into_Operator;
+
+   -------------------
+   -- Operator_Kind --
+   -------------------
+
+   function Operator_Kind
+     (Op_Name   : Name_Id;
+      Is_Binary : Boolean)
+      return      Node_Kind
+   is
+      Kind : Node_Kind;
+
+   begin
+      if Is_Binary then
+         if    Op_Name =  Name_Op_And      then Kind := N_Op_And;
+         elsif Op_Name =  Name_Op_Or       then Kind := N_Op_Or;
+         elsif Op_Name =  Name_Op_Xor      then Kind := N_Op_Xor;
+         elsif Op_Name =  Name_Op_Eq       then Kind := N_Op_Eq;
+         elsif Op_Name =  Name_Op_Ne       then Kind := N_Op_Ne;
+         elsif Op_Name =  Name_Op_Lt       then Kind := N_Op_Lt;
+         elsif Op_Name =  Name_Op_Le       then Kind := N_Op_Le;
+         elsif Op_Name =  Name_Op_Gt       then Kind := N_Op_Gt;
+         elsif Op_Name =  Name_Op_Ge       then Kind := N_Op_Ge;
+         elsif Op_Name =  Name_Op_Add      then Kind := N_Op_Add;
+         elsif Op_Name =  Name_Op_Subtract then Kind := N_Op_Subtract;
+         elsif Op_Name =  Name_Op_Concat   then Kind := N_Op_Concat;
+         elsif Op_Name =  Name_Op_Multiply then Kind := N_Op_Multiply;
+         elsif Op_Name =  Name_Op_Divide   then Kind := N_Op_Divide;
+         elsif Op_Name =  Name_Op_Mod      then Kind := N_Op_Mod;
+         elsif Op_Name =  Name_Op_Rem      then Kind := N_Op_Rem;
+         elsif Op_Name =  Name_Op_Expon    then Kind := N_Op_Expon;
+         else
+            raise Program_Error;
+         end if;
+
+      --  Unary operators
+
+      else
+         if    Op_Name =  Name_Op_Add      then Kind := N_Op_Plus;
+         elsif Op_Name =  Name_Op_Subtract then Kind := N_Op_Minus;
+         elsif Op_Name =  Name_Op_Abs      then Kind := N_Op_Abs;
+         elsif Op_Name =  Name_Op_Not      then Kind := N_Op_Not;
+         else
+            raise Program_Error;
+         end if;
+      end if;
+
+      return Kind;
+   end Operator_Kind;
+
+   -----------------------------
+   -- Pre_Analyze_And_Resolve --
+   -----------------------------
+
+   procedure Pre_Analyze_And_Resolve (N : Node_Id; T : Entity_Id) is
+      Save_Full_Analysis : constant Boolean := Full_Analysis;
+
+   begin
+      Full_Analysis := False;
+      Expander_Mode_Save_And_Set (False);
+
+      --  We suppress all checks for this analysis, since the checks will
+      --  be applied properly, and in the right location, when the default
+      --  expression is reanalyzed and reexpanded later on.
+
+      Analyze_And_Resolve (N, T, Suppress => All_Checks);
+
+      Expander_Mode_Restore;
+      Full_Analysis := Save_Full_Analysis;
+   end Pre_Analyze_And_Resolve;
+
+   --  Version without context type.
+
+   procedure Pre_Analyze_And_Resolve (N : Node_Id) is
+      Save_Full_Analysis : constant Boolean := Full_Analysis;
+
+   begin
+      Full_Analysis := False;
+      Expander_Mode_Save_And_Set (False);
+
+      Analyze (N);
+      Resolve (N, Etype (N), Suppress => All_Checks);
+
+      Expander_Mode_Restore;
+      Full_Analysis := Save_Full_Analysis;
+   end Pre_Analyze_And_Resolve;
+
+   ----------------------------------
+   -- Replace_Actual_Discriminants --
+   ----------------------------------
+
+   procedure Replace_Actual_Discriminants (N : Node_Id; Default : Node_Id) is
+      Loc : constant Source_Ptr := Sloc (N);
+      Tsk : Node_Id := Empty;
+
+      function Process_Discr (Nod : Node_Id) return Traverse_Result;
+
+      -------------------
+      -- Process_Discr --
+      -------------------
+
+      function Process_Discr (Nod : Node_Id) return Traverse_Result is
+         Ent : Entity_Id;
+
+      begin
+         if Nkind (Nod) = N_Identifier then
+            Ent := Entity (Nod);
+
+            if Present (Ent)
+              and then Ekind (Ent) = E_Discriminant
+            then
+               Rewrite (Nod,
+                 Make_Selected_Component (Loc,
+                   Prefix        => New_Copy_Tree (Tsk, New_Sloc => Loc),
+                   Selector_Name => Make_Identifier (Loc, Chars (Ent))));
+
+               Set_Etype (Nod, Etype (Ent));
+            end if;
+
+         end if;
+
+         return OK;
+      end Process_Discr;
+
+      procedure Replace_Discrs is new Traverse_Proc (Process_Discr);
+
+   --  Start of processing for Replace_Actual_Discriminants
+
+   begin
+      if not Expander_Active then
+         return;
+      end if;
+
+      if Nkind (Name (N)) = N_Selected_Component then
+         Tsk := Prefix (Name (N));
+
+      elsif Nkind (Name (N)) = N_Indexed_Component then
+         Tsk := Prefix (Prefix (Name (N)));
+      end if;
+
+      if No (Tsk) then
+         return;
+      else
+         Replace_Discrs (Default);
+      end if;
+   end Replace_Actual_Discriminants;
+
+   -------------
+   -- Resolve --
+   -------------
+
+   procedure Resolve (N : Node_Id; Typ : Entity_Id) is
+      I         : Interp_Index;
+      I1        : Interp_Index := 0; -- prevent junk warning
+      It        : Interp;
+      It1       : Interp;
+      Found     : Boolean   := False;
+      Seen      : Entity_Id := Empty; -- prevent junk warning
+      Ctx_Type  : Entity_Id := Typ;
+      Expr_Type : Entity_Id := Empty; -- prevent junk warning
+      Ambiguous : Boolean   := False;
+
+      procedure Patch_Up_Value (N : Node_Id; Typ : Entity_Id);
+      --  Try and fix up a literal so that it matches its expected type. New
+      --  literals are manufactured if necessary to avoid cascaded errors.
+
+      procedure Resolution_Failed;
+      --  Called when attempt at resolving current expression fails
+
+      --------------------
+      -- Patch_Up_Value --
+      --------------------
+
+      procedure Patch_Up_Value (N : Node_Id; Typ : Entity_Id) is
+      begin
+         if Nkind (N) = N_Integer_Literal
+           and then Is_Real_Type (Typ)
+         then
+            Rewrite (N,
+              Make_Real_Literal (Sloc (N),
+                Realval => UR_From_Uint (Intval (N))));
+            Set_Etype (N, Universal_Real);
+            Set_Is_Static_Expression (N);
+
+         elsif Nkind (N) = N_Real_Literal
+           and then Is_Integer_Type (Typ)
+         then
+            Rewrite (N,
+              Make_Integer_Literal (Sloc (N),
+                Intval => UR_To_Uint (Realval (N))));
+            Set_Etype (N, Universal_Integer);
+            Set_Is_Static_Expression (N);
+         elsif Nkind (N) = N_String_Literal
+           and then Is_Character_Type (Typ)
+         then
+            Set_Character_Literal_Name (Char_Code (Character'Pos ('A')));
+            Rewrite (N,
+              Make_Character_Literal (Sloc (N),
+                Chars => Name_Find,
+                Char_Literal_Value => Char_Code (Character'Pos ('A'))));
+            Set_Etype (N, Any_Character);
+            Set_Is_Static_Expression (N);
+
+         elsif Nkind (N) /= N_String_Literal
+           and then Is_String_Type (Typ)
+         then
+            Rewrite (N,
+              Make_String_Literal (Sloc (N),
+                Strval => End_String));
+
+         elsif Nkind (N) = N_Range then
+            Patch_Up_Value (Low_Bound (N), Typ);
+            Patch_Up_Value (High_Bound (N), Typ);
+         end if;
+      end Patch_Up_Value;
+
+      -----------------------
+      -- Resolution_Failed --
+      -----------------------
+
+      procedure Resolution_Failed is
+      begin
+         Patch_Up_Value (N, Typ);
+         Set_Etype (N, Typ);
+         Debug_A_Exit ("resolving  ", N, " (done, resolution failed)");
+         Set_Is_Overloaded (N, False);
+
+         --  The caller will return without calling the expander, so we need
+         --  to set the analyzed flag. Note that it is fine to set Analyzed
+         --  to True even if we are in the middle of a shallow analysis,
+         --  (see the spec of sem for more details) since this is an error
+         --  situation anyway, and there is no point in repeating the
+         --  analysis later (indeed it won't work to repeat it later, since
+         --  we haven't got a clear resolution of which entity is being
+         --  referenced.)
+
+         Set_Analyzed (N, True);
+         return;
+      end Resolution_Failed;
+
+   --  Start of processing for Resolve
+
+   begin
+      --  Access attribute on remote subprogram cannot be used for
+      --  a non-remote access-to-subprogram type.
+
+      if Nkind (N) = N_Attribute_Reference
+        and then (Attribute_Name (N) = Name_Access
+          or else Attribute_Name (N) = Name_Unrestricted_Access
+          or else Attribute_Name (N) = Name_Unchecked_Access)
+        and then Comes_From_Source (N)
+        and then Is_Entity_Name (Prefix (N))
+        and then Is_Subprogram (Entity (Prefix (N)))
+        and then Is_Remote_Call_Interface (Entity (Prefix (N)))
+        and then not Is_Remote_Access_To_Subprogram_Type (Typ)
+      then
+         Error_Msg_N
+           ("prefix must statically denote a non-remote subprogram", N);
+      end if;
+
+      --  If the context is a Remote_Access_To_Subprogram, access attributes
+      --  must be resolved with the corresponding fat pointer. There is no need
+      --  to check for the attribute name since the return type of an
+      --  attribute is never a remote type.
+
+      if Nkind (N) = N_Attribute_Reference
+        and then Comes_From_Source (N)
+        and then (Is_Remote_Call_Interface (Typ)
+                    or else Is_Remote_Types (Typ))
+      then
+         declare
+            Attr      : constant Attribute_Id :=
+                          Get_Attribute_Id (Attribute_Name (N));
+            Pref      : constant Node_Id      := Prefix (N);
+            Decl      : Node_Id;
+            Spec      : Node_Id;
+            Is_Remote : Boolean := True;
+
+         begin
+            --  Check that Typ is a fat pointer with a reference to a RAS as
+            --  original access type.
+
+            if
+              (Ekind (Typ) = E_Access_Subprogram_Type
+                 and then Present (Equivalent_Type (Typ)))
+              or else
+                (Ekind (Typ) = E_Record_Type
+                   and then Present (Corresponding_Remote_Type (Typ)))
+
+            then
+               --  Prefix (N) must statically denote a remote subprogram
+               --  declared in a package specification.
+
+               if Attr = Attribute_Access then
+                  Decl := Unit_Declaration_Node (Entity (Pref));
+
+                  if Nkind (Decl) = N_Subprogram_Body then
+                     Spec := Corresponding_Spec (Decl);
+
+                     if not No (Spec) then
+                        Decl := Unit_Declaration_Node (Spec);
+                     end if;
+                  end if;
+
+                  Spec := Parent (Decl);
+
+                  if not Is_Entity_Name (Prefix (N))
+                    or else Nkind (Spec) /= N_Package_Specification
+                    or else
+                      not Is_Remote_Call_Interface (Defining_Entity (Spec))
+                  then
+                     Is_Remote := False;
+                     Error_Msg_N
+                       ("prefix must statically denote a remote subprogram ",
+                        N);
+                  end if;
+               end if;
+
+               if Attr = Attribute_Access
+                 or else Attr = Attribute_Unchecked_Access
+                 or else Attr = Attribute_Unrestricted_Access
+               then
+                  Check_Subtype_Conformant
+                    (New_Id  => Entity (Prefix (N)),
+                     Old_Id  => Designated_Type
+                       (Corresponding_Remote_Type (Typ)),
+                     Err_Loc => N);
+                  if Is_Remote then
+                     Process_Remote_AST_Attribute (N, Typ);
+                  end if;
+               end if;
+            end if;
+         end;
+      end if;
+
+      Debug_A_Entry ("resolving  ", N);
+
+      if Is_Fixed_Point_Type (Typ) then
+         Check_Restriction (No_Fixed_Point, N);
+
+      elsif Is_Floating_Point_Type (Typ)
+        and then Typ /= Universal_Real
+        and then Typ /= Any_Real
+      then
+         Check_Restriction (No_Floating_Point, N);
+      end if;
+
+      --  Return if already analyzed
+
+      if Analyzed (N) then
+         Debug_A_Exit ("resolving  ", N, "  (done, already analyzed)");
+         return;
+
+      --  Return if type = Any_Type (previous error encountered)
+
+      elsif Etype (N) = Any_Type then
+         Debug_A_Exit ("resolving  ", N, "  (done, Etype = Any_Type)");
+         return;
+      end if;
+
+      Check_Parameterless_Call (N);
+
+      --  If not overloaded, then we know the type, and all that needs doing
+      --  is to check that this type is compatible with the context.
+
+      if not Is_Overloaded (N) then
+         Found := Covers (Typ, Etype (N));
+         Expr_Type := Etype (N);
+
+      --  In the overloaded case, we must select the interpretation that
+      --  is compatible with the context (i.e. the type passed to Resolve)
+
+      else
+         Get_First_Interp (N, I, It);
+
+         --  Loop through possible interpretations
+
+         Interp_Loop : while Present (It.Typ) loop
+
+            --  We are only interested in interpretations that are compatible
+            --  with the expected type, any other interpretations are ignored
+
+            if Covers (Typ, It.Typ) then
+
+               --  First matching interpretation
+
+               if not Found then
+                  Found := True;
+                  I1    := I;
+                  Seen  := It.Nam;
+                  Expr_Type := It.Typ;
+
+               --  Matching intepretation that is not the first, maybe an
+               --  error, but there are some cases where preference rules are
+               --  used to choose between the two possibilities. These and
+               --  some more obscure cases are handled in Disambiguate.
+
+               else
+                  Error_Msg_Sloc := Sloc (Seen);
+                  It1 := Disambiguate (N, I1, I, Typ);
+
+                  if It1 = No_Interp then
+
+                     --  Before we issue an ambiguity complaint, check for
+                     --  the case of a subprogram call where at least one
+                     --  of the arguments is Any_Type, and if so, suppress
+                     --  the message, since it is a cascaded error.
+
+                     if Nkind (N) = N_Function_Call
+                       or else Nkind (N) = N_Procedure_Call_Statement
+                     then
+                        declare
+                           A : Node_Id := First_Actual (N);
+                           E : Node_Id;
+
+                        begin
+                           while Present (A) loop
+                              E := A;
+
+                              if Nkind (E) = N_Parameter_Association then
+                                 E := Explicit_Actual_Parameter (E);
+                              end if;
+
+                              if Etype (E) = Any_Type then
+                                 if Debug_Flag_V then
+                                    Write_Str ("Any_Type in call");
+                                    Write_Eol;
+                                 end if;
+
+                                 exit Interp_Loop;
+                              end if;
+
+                              Next_Actual (A);
+                           end loop;
+                        end;
+
+                     elsif Nkind (N) in  N_Binary_Op
+                       and then (Etype (Left_Opnd (N)) = Any_Type
+                                  or else Etype (Right_Opnd (N)) = Any_Type)
+                     then
+                        exit Interp_Loop;
+
+                     elsif Nkind (N) in  N_Unary_Op
+                       and then Etype (Right_Opnd (N)) = Any_Type
+                     then
+                        exit Interp_Loop;
+                     end if;
+
+                     --  Not that special case, so issue message using the
+                     --  flag Ambiguous to control printing of the header
+                     --  message only at the start of an ambiguous set.
+
+                     if not Ambiguous then
+                        Error_Msg_NE
+                          ("ambiguous expression (cannot resolve&)!",
+                           N, It.Nam);
+                        Error_Msg_N
+                          ("possible interpretation#!", N);
+                        Ambiguous := True;
+                     end if;
+
+                     Error_Msg_Sloc := Sloc (It.Nam);
+                     Error_Msg_N ("possible interpretation#!", N);
+
+                  --  Disambiguation has succeeded. Skip the remaining
+                  --  interpretations.
+                  else
+                     Seen := It1.Nam;
+                     Expr_Type := It1.Typ;
+
+                     while Present (It.Typ) loop
+                        Get_Next_Interp (I, It);
+                     end loop;
+                  end if;
+               end if;
+
+               --  We have a matching interpretation, Expr_Type is the
+               --  type from this interpretation, and Seen is the entity.
+
+               --  For an operator, just set the entity name. The type will
+               --  be set by the specific operator resolution routine.
+
+               if Nkind (N) in N_Op then
+                  Set_Entity (N, Seen);
+                  Generate_Reference (Seen, N);
+
+               elsif Nkind (N) = N_Character_Literal then
+                  Set_Etype (N, Expr_Type);
+
+               --  For an explicit dereference, attribute reference, range,
+               --  short-circuit form (which is not an operator node),
+               --  or a call with a name that is an explicit dereference,
+               --  there is nothing to be done at this point.
+
+               elsif     Nkind (N) = N_Explicit_Dereference
+                 or else Nkind (N) = N_Attribute_Reference
+                 or else Nkind (N) = N_And_Then
+                 or else Nkind (N) = N_Indexed_Component
+                 or else Nkind (N) = N_Or_Else
+                 or else Nkind (N) = N_Range
+                 or else Nkind (N) = N_Selected_Component
+                 or else Nkind (N) = N_Slice
+                 or else Nkind (Name (N)) = N_Explicit_Dereference
+               then
+                  null;
+
+               --  For procedure or function calls, set the type of the
+               --  name, and also the entity pointer for the prefix
+
+               elsif (Nkind (N) = N_Procedure_Call_Statement
+                       or else Nkind (N) = N_Function_Call)
+                 and then (Is_Entity_Name (Name (N))
+                            or else Nkind (Name (N)) = N_Operator_Symbol)
+               then
+                  Set_Etype  (Name (N), Expr_Type);
+                  Set_Entity (Name (N), Seen);
+                  Generate_Reference (Seen, Name (N));
+
+               elsif Nkind (N) = N_Function_Call
+                 and then Nkind (Name (N)) = N_Selected_Component
+               then
+                  Set_Etype (Name (N), Expr_Type);
+                  Set_Entity (Selector_Name (Name (N)), Seen);
+                  Generate_Reference (Seen, Selector_Name (Name (N)));
+
+               --  For all other cases, just set the type of the Name
+
+               else
+                  Set_Etype (Name (N), Expr_Type);
+               end if;
+
+            --  Here if interpetation is incompatible with context type
+
+            else
+               if Debug_Flag_V then
+                  Write_Str ("    intepretation incompatible with context");
+                  Write_Eol;
+               end if;
+            end if;
+
+            --  Move to next interpretation
+
+            exit Interp_Loop when not Present (It.Typ);
+
+            Get_Next_Interp (I, It);
+         end loop Interp_Loop;
+      end if;
+
+      --  At this stage Found indicates whether or not an acceptable
+      --  interpretation exists. If not, then we have an error, except
+      --  that if the context is Any_Type as a result of some other error,
+      --  then we suppress the error report.
+
+      if not Found then
+         if Typ /= Any_Type then
+
+            --  If type we are looking for is Void, then this is the
+            --  procedure call case, and the error is simply that what
+            --  we gave is not a procedure name (we think of procedure
+            --  calls as expressions with types internally, but the user
+            --  doesn't think of them this way!)
+
+            if Typ = Standard_Void_Type then
+               Error_Msg_N ("expect procedure name in procedure call", N);
+               Found := True;
+
+            --  Otherwise we do have a subexpression with the wrong type
+
+            --  Check for the case of an allocator which uses an access
+            --  type instead of the designated type. This is a common
+            --  error and we specialize the message, posting an error
+            --  on the operand of the allocator, complaining that we
+            --  expected the designated type of the allocator.
+
+            elsif Nkind (N) = N_Allocator
+              and then Ekind (Typ) in Access_Kind
+              and then Ekind (Etype (N)) in Access_Kind
+              and then Designated_Type (Etype (N)) = Typ
+            then
+               Wrong_Type (Expression (N), Designated_Type (Typ));
+               Found := True;
+
+            --  Check for an aggregate. Sometimes we can get bogus
+            --  aggregates from misuse of parentheses, and we are
+            --  about to complain about the aggregate without even
+            --  looking inside it.
+
+            --  Instead, if we have an aggregate of type Any_Composite,
+            --  then analyze and resolve the component fields, and then
+            --  only issue another message if we get no errors doing
+            --  this (otherwise assume that the errors in the aggregate
+            --  caused the problem).
+
+            elsif Nkind (N) = N_Aggregate
+              and then Etype (N) = Any_Composite
+            then
+
+               --  Disable expansion in any case. If there is a type mismatch
+               --  it may be fatal to try to expand the aggregate. The flag
+               --  would otherwise be set to false when the error is posted.
+
+               Expander_Active := False;
+
+               declare
+                  procedure Check_Aggr (Aggr : Node_Id);
+                  --  Check one aggregate, and set Found to True if we
+                  --  have a definite error in any of its elements
+
+                  procedure Check_Elmt (Aelmt : Node_Id);
+                  --  Check one element of aggregate and set Found to
+                  --  True if we definitely have an error in the element.
+
+                  procedure Check_Aggr (Aggr : Node_Id) is
+                     Elmt : Node_Id;
+
+                  begin
+                     if Present (Expressions (Aggr)) then
+                        Elmt := First (Expressions (Aggr));
+                        while Present (Elmt) loop
+                           Check_Elmt (Elmt);
+                           Next (Elmt);
+                        end loop;
+                     end if;
+
+                     if Present (Component_Associations (Aggr)) then
+                        Elmt := First (Component_Associations (Aggr));
+                        while Present (Elmt) loop
+                           Check_Elmt (Expression (Elmt));
+                           Next (Elmt);
+                        end loop;
+                     end if;
+                  end Check_Aggr;
+
+                  procedure Check_Elmt (Aelmt : Node_Id) is
+                  begin
+                     --  If we have a nested aggregate, go inside it (to
+                     --  attempt a naked analyze-resolve of the aggregate
+                     --  can cause undesirable cascaded errors). Do not
+                     --  resolve expression if it needs a type from context,
+                     --  as for integer * fixed expression.
+
+                     if Nkind (Aelmt) = N_Aggregate then
+                        Check_Aggr (Aelmt);
+
+                     else
+                        Analyze (Aelmt);
+
+                        if not Is_Overloaded (Aelmt)
+                          and then Etype (Aelmt) /= Any_Fixed
+                        then
+                           Resolve (Aelmt, Etype (Aelmt));
+                        end if;
+
+                        if Etype (Aelmt) = Any_Type then
+                           Found := True;
+                        end if;
+                     end if;
+                  end Check_Elmt;
+
+               begin
+                  Check_Aggr (N);
+               end;
+            end if;
+
+            --  If an error message was issued already, Found got reset
+            --  to True, so if it is still False, issue the standard
+            --  Wrong_Type message.
+
+            if not Found then
+               if Is_Overloaded (N)
+                 and then Nkind (N) = N_Function_Call
+               then
+                  Error_Msg_Node_2 := Typ;
+                  Error_Msg_NE ("no visible interpretation of&" &
+                    " matches expected type&", N, Name (N));
+
+                  if All_Errors_Mode then
+                     declare
+                        Index : Interp_Index;
+                        It    : Interp;
+
+                     begin
+                        Error_Msg_N ("\possible interpretations:", N);
+                        Get_First_Interp (Name (N), Index, It);
+
+                        while Present (It.Nam) loop
+
+                              Error_Msg_Sloc := Sloc (It.Nam);
+                              Error_Msg_Node_2 := It.Typ;
+                              Error_Msg_NE ("\&  declared#, type&",
+                                N, It.Nam);
+
+                           Get_Next_Interp (Index, It);
+                        end loop;
+                     end;
+                  else
+                     Error_Msg_N ("\use -gnatf for details", N);
+                  end if;
+               else
+                  Wrong_Type (N, Typ);
+               end if;
+            end if;
+         end if;
+
+         Resolution_Failed;
+         return;
+
+      --  Test if we have more than one interpretation for the context
+
+      elsif Ambiguous then
+         Resolution_Failed;
+         return;
+
+      --  Here we have an acceptable interpretation for the context
+
+      else
+         --  A user-defined operator is tranformed into a function call at
+         --  this point, so that further processing knows that operators are
+         --  really operators (i.e. are predefined operators). User-defined
+         --  operators that are intrinsic are just renamings of the predefined
+         --  ones, and need not be turned into calls either, but if they rename
+         --  a different operator, we must transform the node accordingly.
+         --  Instantiations of Unchecked_Conversion are intrinsic but are
+         --  treated as functions, even if given an operator designator.
+
+         if Nkind (N) in N_Op
+           and then Present (Entity (N))
+           and then Ekind (Entity (N)) /= E_Operator
+         then
+
+            if not Is_Predefined_Op (Entity (N)) then
+               Rewrite_Operator_As_Call (N, Entity (N));
+
+            elsif Present (Alias (Entity (N))) then
+               Rewrite_Renamed_Operator (N, Alias (Entity (N)));
+            end if;
+         end if;
+
+         --  Propagate type information and normalize tree for various
+         --  predefined operations. If the context only imposes a class of
+         --  types, rather than a specific type, propagate the actual type
+         --  downward.
+
+         if Typ = Any_Integer
+           or else Typ = Any_Boolean
+           or else Typ = Any_Modular
+           or else Typ = Any_Real
+           or else Typ = Any_Discrete
+         then
+            Ctx_Type := Expr_Type;
+
+            --  Any_Fixed is legal in a real context only if a specific
+            --  fixed point type is imposed. If Norman Cohen can be
+            --  confused by this, it deserves a separate message.
+
+            if Typ = Any_Real
+              and then Expr_Type = Any_Fixed
+            then
+               Error_Msg_N ("Illegal context for mixed mode operation", N);
+               Set_Etype (N, Universal_Real);
+               Ctx_Type := Universal_Real;
+            end if;
+         end if;
+
+         case N_Subexpr'(Nkind (N)) is
+
+            when N_Aggregate => Resolve_Aggregate                (N, Ctx_Type);
+
+            when N_Allocator => Resolve_Allocator                (N, Ctx_Type);
+
+            when N_And_Then | N_Or_Else
+                             => Resolve_Short_Circuit            (N, Ctx_Type);
+
+            when N_Attribute_Reference
+                             => Resolve_Attribute                (N, Ctx_Type);
+
+            when N_Character_Literal
+                             => Resolve_Character_Literal        (N, Ctx_Type);
+
+            when N_Conditional_Expression
+                             => Resolve_Conditional_Expression   (N, Ctx_Type);
+
+            when N_Expanded_Name
+                             => Resolve_Entity_Name              (N, Ctx_Type);
+
+            when N_Extension_Aggregate
+                             => Resolve_Extension_Aggregate      (N, Ctx_Type);
+
+            when N_Explicit_Dereference
+                             => Resolve_Explicit_Dereference     (N, Ctx_Type);
+
+            when N_Function_Call
+                             => Resolve_Call                     (N, Ctx_Type);
+
+            when N_Identifier
+                             => Resolve_Entity_Name              (N, Ctx_Type);
+
+            when N_In | N_Not_In
+                             => Resolve_Membership_Op            (N, Ctx_Type);
+
+            when N_Indexed_Component
+                             => Resolve_Indexed_Component        (N, Ctx_Type);
+
+            when N_Integer_Literal
+                             => Resolve_Integer_Literal          (N, Ctx_Type);
+
+            when N_Null      => Resolve_Null                     (N, Ctx_Type);
+
+            when N_Op_And | N_Op_Or | N_Op_Xor
+                             => Resolve_Logical_Op               (N, Ctx_Type);
+
+            when N_Op_Eq | N_Op_Ne
+                             => Resolve_Equality_Op              (N, Ctx_Type);
+
+            when N_Op_Lt | N_Op_Le | N_Op_Gt | N_Op_Ge
+                             => Resolve_Comparison_Op            (N, Ctx_Type);
+
+            when N_Op_Not    => Resolve_Op_Not                   (N, Ctx_Type);
+
+            when N_Op_Add    | N_Op_Subtract | N_Op_Multiply |
+                 N_Op_Divide | N_Op_Mod      | N_Op_Rem
+
+                             => Resolve_Arithmetic_Op            (N, Ctx_Type);
+
+            when N_Op_Concat => Resolve_Op_Concat                (N, Ctx_Type);
+
+            when N_Op_Expon  => Resolve_Op_Expon                 (N, Ctx_Type);
+
+            when N_Op_Plus | N_Op_Minus  | N_Op_Abs
+                             => Resolve_Unary_Op                 (N, Ctx_Type);
+
+            when N_Op_Shift  => Resolve_Shift                    (N, Ctx_Type);
+
+            when N_Procedure_Call_Statement
+                             => Resolve_Call                     (N, Ctx_Type);
+
+            when N_Operator_Symbol
+                             => Resolve_Operator_Symbol          (N, Ctx_Type);
+
+            when N_Qualified_Expression
+                             => Resolve_Qualified_Expression     (N, Ctx_Type);
+
+            when N_Raise_xxx_Error
+                             => Set_Etype (N, Ctx_Type);
+
+            when N_Range     => Resolve_Range                    (N, Ctx_Type);
+
+            when N_Real_Literal
+                             => Resolve_Real_Literal             (N, Ctx_Type);
+
+            when N_Reference => Resolve_Reference                (N, Ctx_Type);
+
+            when N_Selected_Component
+                             => Resolve_Selected_Component       (N, Ctx_Type);
+
+            when N_Slice     => Resolve_Slice                    (N, Ctx_Type);
+
+            when N_String_Literal
+                             => Resolve_String_Literal           (N, Ctx_Type);
+
+            when N_Subprogram_Info
+                             => Resolve_Subprogram_Info          (N, Ctx_Type);
+
+            when N_Type_Conversion
+                             => Resolve_Type_Conversion          (N, Ctx_Type);
+
+            when N_Unchecked_Expression =>
+               Resolve_Unchecked_Expression                      (N, Ctx_Type);
+
+            when N_Unchecked_Type_Conversion =>
+               Resolve_Unchecked_Type_Conversion                 (N, Ctx_Type);
+
+         end case;
+
+         --  If the subexpression was replaced by a non-subexpression, then
+         --  all we do is to expand it. The only legitimate case we know of
+         --  is converting procedure call statement to entry call statements,
+         --  but there may be others, so we are making this test general.
+
+         if Nkind (N) not in N_Subexpr then
+            Debug_A_Exit ("resolving  ", N, "  (done)");
+            Expand (N);
+            return;
+         end if;
+
+         --  The expression is definitely NOT overloaded at this point, so
+         --  we reset the Is_Overloaded flag to avoid any confusion when
+         --  reanalyzing the node.
+
+         Set_Is_Overloaded (N, False);
+
+         --  Freeze expression type, entity if it is a name, and designated
+         --  type if it is an allocator (RM 13.14(9,10)).
+
+         --  Now that the resolution of the type of the node is complete,
+         --  and we did not detect an error, we can expand this node. We
+         --  skip the expand call if we are in a default expression, see
+         --  section "Handling of Default Expressions" in Sem spec.
+
+         Debug_A_Exit ("resolving  ", N, "  (done)");
+
+         --  We unconditionally freeze the expression, even if we are in
+         --  default expression mode (the Freeze_Expression routine tests
+         --  this flag and only freezes static types if it is set).
+
+         Freeze_Expression (N);
+
+         --  Now we can do the expansion
+
+         Expand (N);
+      end if;
+
+   end Resolve;
+
+   --  Version with check(s) suppressed
+
+   procedure Resolve (N : Node_Id; Typ : Entity_Id; Suppress : Check_Id) is
+   begin
+      if Suppress = All_Checks then
+         declare
+            Svg : constant Suppress_Record := Scope_Suppress;
+
+         begin
+            Scope_Suppress := (others => True);
+            Resolve (N, Typ);
+            Scope_Suppress := Svg;
+         end;
+
+      else
+         declare
+            Svg : constant Boolean := Get_Scope_Suppress (Suppress);
+
+         begin
+            Set_Scope_Suppress (Suppress, True);
+            Resolve (N, Typ);
+            Set_Scope_Suppress (Suppress, Svg);
+         end;
+      end if;
+   end Resolve;
+
+   ---------------------
+   -- Resolve_Actuals --
+   ---------------------
+
+   procedure Resolve_Actuals (N : Node_Id; Nam : Entity_Id) is
+      Loc    : constant Source_Ptr := Sloc (N);
+      A      : Node_Id;
+      F      : Entity_Id;
+      A_Typ  : Entity_Id;
+      F_Typ  : Entity_Id;
+      Prev   : Node_Id := Empty;
+
+      procedure Insert_Default;
+      --  If the actual is missing in a call, insert in the actuals list
+      --  an instance of the default expression. The insertion is always
+      --  a named association.
+
+      --------------------
+      -- Insert_Default --
+      --------------------
+
+      procedure Insert_Default is
+         Actval : Node_Id;
+         Assoc  : Node_Id;
+
+      begin
+         --  Note that we do a full New_Copy_Tree, so that any associated
+         --  Itypes are properly copied. This may not be needed any more,
+         --  but it does no harm as a safety measure! Defaults of a generic
+         --  formal may be out of bounds of the corresponding actual (see
+         --  cc1311b) and an additional check may be required.
+
+         if Present (Default_Value (F)) then
+
+            Actval := New_Copy_Tree (Default_Value (F),
+                        New_Scope => Current_Scope, New_Sloc => Loc);
+
+            if Is_Concurrent_Type (Scope (Nam))
+              and then Has_Discriminants (Scope (Nam))
+            then
+               Replace_Actual_Discriminants (N, Actval);
+            end if;
+
+            if Is_Overloadable (Nam)
+              and then Present (Alias (Nam))
+            then
+               if Base_Type (Etype (F)) /= Base_Type (Etype (Actval))
+                 and then not Is_Tagged_Type (Etype (F))
+               then
+                  --  If default is a real literal, do not introduce a
+                  --  conversion whose effect may depend on the run-time
+                  --  size of universal real.
+
+                  if Nkind (Actval) = N_Real_Literal then
+                     Set_Etype (Actval, Base_Type (Etype (F)));
+                  else
+                     Actval := Unchecked_Convert_To (Etype (F), Actval);
+                  end if;
+               end if;
+
+               if Is_Scalar_Type (Etype (F)) then
+                  Enable_Range_Check (Actval);
+               end if;
+
+               Set_Parent (Actval, N);
+               Analyze_And_Resolve (Actval, Etype (Actval));
+            else
+               Set_Parent (Actval, N);
+
+               --  Resolve aggregates with their base type, to avoid scope
+               --  anomalies: the subtype was first built in the suprogram
+               --  declaration, and the current call may be nested.
+
+               if Nkind (Actval) = N_Aggregate
+                 and then Has_Discriminants (Etype (Actval))
+               then
+                  Analyze_And_Resolve (Actval, Base_Type (Etype (Actval)));
+               else
+                  Analyze_And_Resolve (Actval, Etype (Actval));
+               end if;
+            end if;
+
+            --  If default is a tag indeterminate function call, propagate
+            --  tag to obtain proper dispatching.
+
+            if Is_Controlling_Formal (F)
+              and then Nkind (Default_Value (F)) = N_Function_Call
+            then
+               Set_Is_Controlling_Actual (Actval);
+            end if;
+
+         else
+            --  Missing argument in call, nothing to insert.
+            return;
+         end if;
+
+         --  If the default expression raises constraint error, then just
+         --  silently replace it with an N_Raise_Constraint_Error node,
+         --  since we already gave the warning on the subprogram spec.
+
+         if Raises_Constraint_Error (Actval) then
+            Rewrite (Actval,
+              Make_Raise_Constraint_Error (Loc));
+            Set_Raises_Constraint_Error (Actval);
+            Set_Etype (Actval, Etype (F));
+         end if;
+
+         Assoc :=
+           Make_Parameter_Association (Loc,
+             Explicit_Actual_Parameter => Actval,
+             Selector_Name => Make_Identifier (Loc, Chars (F)));
+
+         --  Case of insertion is first named actual
+
+         if No (Prev) or else
+            Nkind (Parent (Prev)) /= N_Parameter_Association
+         then
+            Set_Next_Named_Actual (Assoc, First_Named_Actual (N));
+            Set_First_Named_Actual (N, Actval);
+
+            if No (Prev) then
+               if not Present (Parameter_Associations (N)) then
+                  Set_Parameter_Associations (N, New_List (Assoc));
+               else
+                  Append (Assoc, Parameter_Associations (N));
+               end if;
+
+            else
+               Insert_After (Prev, Assoc);
+            end if;
+
+         --  Case of insertion is not first named actual
+
+         else
+            Set_Next_Named_Actual
+              (Assoc, Next_Named_Actual (Parent (Prev)));
+            Set_Next_Named_Actual (Parent (Prev), Actval);
+            Append (Assoc, Parameter_Associations (N));
+         end if;
+
+         Mark_Rewrite_Insertion (Assoc);
+         Mark_Rewrite_Insertion (Actval);
+
+         Prev := Actval;
+      end Insert_Default;
+
+   --  Start of processing for Resolve_Actuals
+
+   begin
+      A := First_Actual (N);
+      F := First_Formal (Nam);
+
+      while Present (F) loop
+
+         if Present (A)
+           and then (Nkind (Parent (A)) /= N_Parameter_Association
+                       or else
+                     Chars (Selector_Name (Parent (A))) = Chars (F))
+         then
+            --  If the formal is Out or In_Out, do not resolve and expand the
+            --  conversion, because it is subsequently expanded into explicit
+            --  temporaries and assignments. However, the object of the
+            --  conversion can be resolved. An exception is the case of
+            --  a tagged type conversion with a class-wide actual. In that
+            --  case we want the tag check to occur and no temporary will
+            --  will be needed (no representation change can occur) and
+            --  the parameter is passed by reference, so we go ahead and
+            --  resolve the type conversion.
+
+            if Ekind (F) /= E_In_Parameter
+              and then Nkind (A) = N_Type_Conversion
+              and then not Is_Class_Wide_Type (Etype (Expression (A)))
+            then
+               if Conversion_OK (A)
+                 or else Valid_Conversion (A, Etype (A), Expression (A))
+               then
+                  Resolve (Expression (A), Etype (Expression (A)));
+               end if;
+
+            else
+               Resolve (A, Etype (F));
+            end if;
+
+            A_Typ := Etype (A);
+            F_Typ := Etype (F);
+
+            if Ekind (F) /= E_In_Parameter
+              and then not Is_OK_Variable_For_Out_Formal (A)
+            then
+               --  Specialize error message for protected procedure call
+               --  within function call of the same protected object.
+
+               if Is_Entity_Name (A)
+                 and then Chars (Entity (A)) = Name_uObject
+                 and then Ekind (Current_Scope) = E_Function
+                 and then Convention (Current_Scope) = Convention_Protected
+                 and then Ekind (Nam) /= E_Function
+               then
+                  Error_Msg_N ("within protected function, protected " &
+                    "object is constant", A);
+                  Error_Msg_N ("\cannot call operation that may modify it", A);
+               else
+                  Error_Msg_NE ("actual for& must be a variable", A, F);
+               end if;
+            end if;
+
+            if Ekind (F) /= E_Out_Parameter then
+               Check_Unset_Reference (A);
+
+               if Ada_83
+                 and then Is_Entity_Name (A)
+                 and then Ekind (Entity (A)) = E_Out_Parameter
+               then
+                  Error_Msg_N ("(Ada 83) illegal reading of out parameter", A);
+               end if;
+            end if;
+
+            --  Apply appropriate range checks for in, out, and in-out
+            --  parameters. Out and in-out parameters also need a separate
+            --  check, if there is a type conversion, to make sure the return
+            --  value meets the constraints of the variable before the
+            --  conversion.
+
+            --  Gigi looks at the check flag and uses the appropriate types.
+            --  For now since one flag is used there is an optimization which
+            --  might not be done in the In Out case since Gigi does not do
+            --  any analysis. More thought required about this ???
+
+            if Ekind (F) = E_In_Parameter
+              or else Ekind (F) = E_In_Out_Parameter
+            then
+               if Is_Scalar_Type (Etype (A)) then
+                  Apply_Scalar_Range_Check (A, F_Typ);
+
+               elsif Is_Array_Type (Etype (A)) then
+                  Apply_Length_Check (A, F_Typ);
+
+               elsif Is_Record_Type (F_Typ)
+                 and then Has_Discriminants (F_Typ)
+                 and then Is_Constrained (F_Typ)
+                 and then (not Is_Derived_Type (F_Typ)
+                             or else Comes_From_Source (Nam))
+               then
+                  Apply_Discriminant_Check (A, F_Typ);
+
+               elsif Is_Access_Type (F_Typ)
+                 and then Is_Array_Type (Designated_Type (F_Typ))
+                 and then Is_Constrained (Designated_Type (F_Typ))
+               then
+                  Apply_Length_Check (A, F_Typ);
+
+               elsif Is_Access_Type (F_Typ)
+                 and then Has_Discriminants (Designated_Type (F_Typ))
+                 and then Is_Constrained (Designated_Type (F_Typ))
+               then
+                  Apply_Discriminant_Check (A, F_Typ);
+
+               else
+                  Apply_Range_Check (A, F_Typ);
+               end if;
+            end if;
+
+            if Ekind (F) = E_Out_Parameter
+              or else Ekind (F) = E_In_Out_Parameter
+            then
+
+               if Nkind (A) = N_Type_Conversion then
+                  if Is_Scalar_Type (A_Typ) then
+                     Apply_Scalar_Range_Check
+                       (Expression (A), Etype (Expression (A)), A_Typ);
+                  else
+                     Apply_Range_Check
+                       (Expression (A), Etype (Expression (A)), A_Typ);
+                  end if;
+
+               else
+                  if Is_Scalar_Type (F_Typ) then
+                     Apply_Scalar_Range_Check (A, A_Typ, F_Typ);
+
+                  elsif Is_Array_Type (F_Typ)
+                    and then Ekind (F) = E_Out_Parameter
+                  then
+                     Apply_Length_Check (A, F_Typ);
+
+                  else
+                     Apply_Range_Check (A, A_Typ, F_Typ);
+                  end if;
+               end if;
+            end if;
+
+            --  An actual associated with an access parameter is implicitly
+            --  converted to the anonymous access type of the formal and
+            --  must satisfy the legality checks for access conversions.
+
+            if Ekind (F_Typ) = E_Anonymous_Access_Type then
+               if not Valid_Conversion (A, F_Typ, A) then
+                  Error_Msg_N
+                    ("invalid implicit conversion for access parameter", A);
+               end if;
+            end if;
+
+            --  Check bad case of atomic/volatile argument (RM C.6(12))
+
+            if Is_By_Reference_Type (Etype (F))
+              and then Comes_From_Source (N)
+            then
+               if Is_Atomic_Object (A)
+                 and then not Is_Atomic (Etype (F))
+               then
+                  Error_Msg_N
+                    ("cannot pass atomic argument to non-atomic formal",
+                     N);
+
+               elsif Is_Volatile_Object (A)
+                 and then not Is_Volatile (Etype (F))
+               then
+                  Error_Msg_N
+                    ("cannot pass volatile argument to non-volatile formal",
+                     N);
+               end if;
+            end if;
+
+            --  Check that subprograms don't have improper controlling
+            --  arguments (RM 3.9.2 (9))
+
+            if Is_Controlling_Formal (F) then
+               Set_Is_Controlling_Actual (A);
+            elsif Nkind (A) = N_Explicit_Dereference then
+               Validate_Remote_Access_To_Class_Wide_Type (A);
+            end if;
+
+            if (Is_Class_Wide_Type (A_Typ) or else Is_Dynamically_Tagged (A))
+              and then not Is_Class_Wide_Type (F_Typ)
+              and then not Is_Controlling_Formal (F)
+            then
+               Error_Msg_N ("class-wide argument not allowed here!", A);
+               if Is_Subprogram (Nam) then
+                  Error_Msg_Node_2 := F_Typ;
+                  Error_Msg_NE
+                    ("& is not a primitive operation of &!", A, Nam);
+               end if;
+
+            elsif Is_Access_Type (A_Typ)
+              and then Is_Access_Type (F_Typ)
+              and then Ekind (F_Typ) /= E_Access_Subprogram_Type
+              and then (Is_Class_Wide_Type (Designated_Type (A_Typ))
+                or else (Nkind (A) = N_Attribute_Reference
+                          and then Is_Class_Wide_Type (Etype (Prefix (A)))))
+              and then not Is_Class_Wide_Type (Designated_Type (F_Typ))
+              and then not Is_Controlling_Formal (F)
+            then
+               Error_Msg_N
+                 ("access to class-wide argument not allowed here!", A);
+               if Is_Subprogram (Nam) then
+                  Error_Msg_Node_2 := Designated_Type (F_Typ);
+                  Error_Msg_NE
+                    ("& is not a primitive operation of &!", A, Nam);
+               end if;
+            end if;
+
+            Eval_Actual (A);
+
+            --  If it is a named association, treat the selector_name as
+            --  a proper identifier, and mark the corresponding entity.
+
+            if Nkind (Parent (A)) = N_Parameter_Association then
+               Set_Entity (Selector_Name (Parent (A)), F);
+               Generate_Reference (F, Selector_Name (Parent (A)));
+               Set_Etype (Selector_Name (Parent (A)), F_Typ);
+               Generate_Reference (F_Typ, N, ' ');
+            end if;
+
+            Prev := A;
+            Next_Actual (A);
+
+         else
+            Insert_Default;
+         end if;
+
+         Next_Formal (F);
+      end loop;
+
+   end Resolve_Actuals;
+
+   -----------------------
+   -- Resolve_Allocator --
+   -----------------------
+
+   procedure Resolve_Allocator (N : Node_Id; Typ : Entity_Id) is
+      E        : constant Node_Id := Expression (N);
+      Subtyp   : Entity_Id;
+      Discrim  : Entity_Id;
+      Constr   : Node_Id;
+      Disc_Exp : Node_Id;
+
+   begin
+      --  Replace general access with specific type
+
+      if Ekind (Etype (N)) = E_Allocator_Type then
+         Set_Etype (N, Base_Type (Typ));
+      end if;
+
+      if Is_Abstract (Typ) then
+         Error_Msg_N ("type of allocator cannot be abstract",  N);
+      end if;
+
+      --  For qualified expression, resolve the expression using the
+      --  given subtype (nothing to do for type mark, subtype indication)
+
+      if Nkind (E) = N_Qualified_Expression then
+         if Is_Class_Wide_Type (Etype (E))
+           and then not Is_Class_Wide_Type (Designated_Type (Typ))
+         then
+            Error_Msg_N
+              ("class-wide allocator not allowed for this access type", N);
+         end if;
+
+         Resolve (Expression (E), Etype (E));
+         Check_Unset_Reference (Expression (E));
+
+      --  For a subtype mark or subtype indication, freeze the subtype
+
+      else
+         Freeze_Expression (E);
+
+         if Is_Access_Constant (Typ) and then not No_Initialization (N) then
+            Error_Msg_N
+              ("initialization required for access-to-constant allocator", N);
+         end if;
+
+         --  A special accessibility check is needed for allocators that
+         --  constrain access discriminants. The level of the type of the
+         --  expression used to contrain an access discriminant cannot be
+         --  deeper than the type of the allocator (in constrast to access
+         --  parameters, where the level of the actual can be arbitrary).
+         --  We can't use Valid_Conversion to perform this check because
+         --  in general the type of the allocator is unrelated to the type
+         --  of the access discriminant. Note that specialized checks are
+         --  needed for the cases of a constraint expression which is an
+         --  access attribute or an access discriminant.
+
+         if Nkind (Original_Node (E)) = N_Subtype_Indication
+           and then Ekind (Typ) /= E_Anonymous_Access_Type
+         then
+            Subtyp := Entity (Subtype_Mark (Original_Node (E)));
+
+            if Has_Discriminants (Subtyp) then
+               Discrim := First_Discriminant (Base_Type (Subtyp));
+               Constr := First (Constraints (Constraint (Original_Node (E))));
+
+               while Present (Discrim) and then Present (Constr) loop
+                  if Ekind (Etype (Discrim)) = E_Anonymous_Access_Type then
+                     if Nkind (Constr) = N_Discriminant_Association then
+                        Disc_Exp := Original_Node (Expression (Constr));
+                     else
+                        Disc_Exp := Original_Node (Constr);
+                     end if;
+
+                     if Type_Access_Level (Etype (Disc_Exp))
+                       > Type_Access_Level (Typ)
+                     then
+                        Error_Msg_N
+                          ("operand type has deeper level than allocator type",
+                           Disc_Exp);
+
+                     elsif Nkind (Disc_Exp) = N_Attribute_Reference
+                       and then Get_Attribute_Id (Attribute_Name (Disc_Exp))
+                                  = Attribute_Access
+                       and then Object_Access_Level (Prefix (Disc_Exp))
+                                  > Type_Access_Level (Typ)
+                     then
+                        Error_Msg_N
+                          ("prefix of attribute has deeper level than"
+                              & " allocator type", Disc_Exp);
+
+                     --  When the operand is an access discriminant the check
+                     --  is against the level of the prefix object.
+
+                     elsif Ekind (Etype (Disc_Exp)) = E_Anonymous_Access_Type
+                       and then Nkind (Disc_Exp) = N_Selected_Component
+                       and then Object_Access_Level (Prefix (Disc_Exp))
+                                  > Type_Access_Level (Typ)
+                     then
+                        Error_Msg_N
+                          ("access discriminant has deeper level than"
+                              & " allocator type", Disc_Exp);
+                     end if;
+                  end if;
+                  Next_Discriminant (Discrim);
+                  Next (Constr);
+               end loop;
+            end if;
+         end if;
+      end if;
+
+      --  Check for allocation from an empty storage pool
+
+      if No_Pool_Assigned (Typ) then
+         declare
+            Loc : constant Source_Ptr := Sloc (N);
+
+         begin
+            Error_Msg_N ("?allocation from empty storage pool!", N);
+            Error_Msg_N ("?Storage_Error will be raised at run time!", N);
+            Insert_Action (N,
+              Make_Raise_Storage_Error (Loc));
+         end;
+      end if;
+   end Resolve_Allocator;
+
+   ---------------------------
+   -- Resolve_Arithmetic_Op --
+   ---------------------------
+
+   --  Used for resolving all arithmetic operators except exponentiation
+
+   procedure Resolve_Arithmetic_Op (N : Node_Id; Typ : Entity_Id) is
+      L  : constant Node_Id := Left_Opnd (N);
+      R  : constant Node_Id := Right_Opnd (N);
+      T  : Entity_Id;
+      TL : Entity_Id := Base_Type (Etype (L));
+      TR : Entity_Id := Base_Type (Etype (R));
+
+      B_Typ : constant Entity_Id := Base_Type (Typ);
+      --  We do the resolution using the base type, because intermediate values
+      --  in expressions always are of the base type, not a subtype of it.
+
+      function Is_Integer_Or_Universal (N : Node_Id) return Boolean;
+      --  Return True iff given type is Integer or universal real/integer
+
+      procedure Set_Mixed_Mode_Operand (N : Node_Id; T : Entity_Id);
+      --  Choose type of integer literal in fixed-point operation to conform
+      --  to available fixed-point type. T is the type of the other operand,
+      --  which is needed to determine the expected type of N.
+
+      procedure Set_Operand_Type (N : Node_Id);
+      --  Set operand type to T if universal
+
+      function Universal_Interpretation (N : Node_Id) return Entity_Id;
+      --  Find universal type of operand, if any.
+
+      -----------------------------
+      -- Is_Integer_Or_Universal --
+      -----------------------------
+
+      function Is_Integer_Or_Universal (N : Node_Id) return Boolean is
+         T     : Entity_Id;
+         Index : Interp_Index;
+         It    : Interp;
+
+      begin
+         if not Is_Overloaded (N) then
+            T := Etype (N);
+            return Base_Type (T) = Base_Type (Standard_Integer)
+              or else T = Universal_Integer
+              or else T = Universal_Real;
+         else
+            Get_First_Interp (N, Index, It);
+
+            while Present (It.Typ) loop
+
+               if Base_Type (It.Typ) = Base_Type (Standard_Integer)
+                 or else It.Typ = Universal_Integer
+                 or else It.Typ = Universal_Real
+               then
+                  return True;
+               end if;
+
+               Get_Next_Interp (Index, It);
+            end loop;
+         end if;
+
+         return False;
+      end Is_Integer_Or_Universal;
+
+      ----------------------------
+      -- Set_Mixed_Mode_Operand --
+      ----------------------------
+
+      procedure Set_Mixed_Mode_Operand (N : Node_Id; T : Entity_Id) is
+         Index : Interp_Index;
+         It    : Interp;
+
+      begin
+         if Universal_Interpretation (N) = Universal_Integer then
+
+            --  A universal integer literal is resolved as standard integer
+            --  except in the case of a fixed-point result, where we leave
+            --  it as universal (to be handled by Exp_Fixd later on)
+
+            if Is_Fixed_Point_Type (T) then
+               Resolve (N, Universal_Integer);
+            else
+               Resolve (N, Standard_Integer);
+            end if;
+
+         elsif Universal_Interpretation (N) = Universal_Real
+           and then (T = Base_Type (Standard_Integer)
+                      or else T = Universal_Integer
+                      or else T = Universal_Real)
+         then
+            --  A universal real can appear in a fixed-type context. We resolve
+            --  the literal with that context, even though this might raise an
+            --  exception prematurely (the other operand may be zero).
+
+            Resolve (N, B_Typ);
+
+         elsif Etype (N) = Base_Type (Standard_Integer)
+           and then T = Universal_Real
+           and then Is_Overloaded (N)
+         then
+            --  Integer arg in mixed-mode operation. Resolve with universal
+            --  type, in case preference rule must be applied.
+
+            Resolve (N, Universal_Integer);
+
+         elsif Etype (N) = T
+           and then B_Typ /= Universal_Fixed
+         then
+            --  Not a mixed-mode operation. Resolve with context.
+
+            Resolve (N, B_Typ);
+
+         elsif Etype (N) = Any_Fixed then
+
+            --  N may itself be a mixed-mode operation, so use context type.
+
+            Resolve (N, B_Typ);
+
+         elsif Is_Fixed_Point_Type (T)
+           and then B_Typ = Universal_Fixed
+           and then Is_Overloaded (N)
+         then
+            --  Must be (fixed * fixed) operation, operand must have one
+            --  compatible interpretation.
+
+            Resolve (N, Any_Fixed);
+
+         elsif Is_Fixed_Point_Type (B_Typ)
+           and then (T = Universal_Real
+                      or else Is_Fixed_Point_Type (T))
+           and then Is_Overloaded (N)
+         then
+            --  C * F(X) in a fixed context, where C is a real literal or a
+            --  fixed-point expression. F must have either a fixed type
+            --  interpretation or an integer interpretation, but not both.
+
+            Get_First_Interp (N, Index, It);
+
+            while Present (It.Typ) loop
+
+               if Base_Type (It.Typ) = Base_Type (Standard_Integer) then
+
+                  if Analyzed (N) then
+                     Error_Msg_N ("ambiguous operand in fixed operation", N);
+                  else
+                     Resolve (N, Standard_Integer);
+                  end if;
+
+               elsif Is_Fixed_Point_Type (It.Typ) then
+
+                  if Analyzed (N) then
+                     Error_Msg_N ("ambiguous operand in fixed operation", N);
+                  else
+                     Resolve (N, It.Typ);
+                  end if;
+               end if;
+
+               Get_Next_Interp (Index, It);
+            end loop;
+
+            --  Reanalyze the literal with the fixed type of the context.
+
+            if N = L then
+               Set_Analyzed (R, False);
+               Resolve (R, B_Typ);
+            else
+               Set_Analyzed (L, False);
+               Resolve (L, B_Typ);
+            end if;
+
+         else
+            Resolve (N, Etype (N));
+         end if;
+      end Set_Mixed_Mode_Operand;
+
+      ----------------------
+      -- Set_Operand_Type --
+      ----------------------
+
+      procedure Set_Operand_Type (N : Node_Id) is
+      begin
+         if Etype (N) = Universal_Integer
+           or else Etype (N) = Universal_Real
+         then
+            Set_Etype (N, T);
+         end if;
+      end Set_Operand_Type;
+
+      ------------------------------
+      -- Universal_Interpretation --
+      ------------------------------
+
+      function Universal_Interpretation (N : Node_Id) return Entity_Id is
+         Index : Interp_Index;
+         It    : Interp;
+
+      begin
+         if not Is_Overloaded (N) then
+
+            if Etype (N) = Universal_Integer
+               or else Etype (N) = Universal_Real
+            then
+               return Etype (N);
+            else
+               return Empty;
+            end if;
+
+         else
+            Get_First_Interp (N, Index, It);
+
+            while Present (It.Typ) loop
+
+               if It.Typ = Universal_Integer
+                  or else It.Typ = Universal_Real
+               then
+                  return It.Typ;
+               end if;
+
+               Get_Next_Interp (Index, It);
+            end loop;
+
+            return Empty;
+         end if;
+      end Universal_Interpretation;
+
+   --  Start of processing for Resolve_Arithmetic_Op
+
+   begin
+      if Comes_From_Source (N)
+        and then Ekind (Entity (N)) = E_Function
+        and then Is_Imported (Entity (N))
+        and then Present (First_Rep_Item (Entity (N)))
+      then
+         Resolve_Intrinsic_Operator (N, Typ);
+         return;
+
+      --  Special-case for mixed-mode universal expressions or fixed point
+      --  type operation: each argument is resolved separately. The same
+      --  treatment is required if one of the operands of a fixed point
+      --  operation is universal real, since in this case we don't do a
+      --  conversion to a specific fixed-point type (instead the expander
+      --  takes care of the case).
+
+      elsif (B_Typ = Universal_Integer
+           or else B_Typ = Universal_Real)
+        and then Present (Universal_Interpretation (L))
+        and then Present (Universal_Interpretation (R))
+      then
+         Resolve (L, Universal_Interpretation (L));
+         Resolve (R, Universal_Interpretation (R));
+         Set_Etype (N, B_Typ);
+
+      elsif (B_Typ = Universal_Real
+           or else Etype (N) = Universal_Fixed
+           or else (Etype (N) = Any_Fixed
+                     and then Is_Fixed_Point_Type (B_Typ))
+           or else (Is_Fixed_Point_Type (B_Typ)
+                     and then (Is_Integer_Or_Universal (L)
+                                 or else
+                               Is_Integer_Or_Universal (R))))
+        and then (Nkind (N) = N_Op_Multiply or else
+                  Nkind (N) = N_Op_Divide)
+      then
+         if TL = Universal_Integer or else TR = Universal_Integer then
+            Check_For_Visible_Operator (N, B_Typ);
+         end if;
+
+         --  If context is a fixed type and one operand is integer, the
+         --  other is resolved with the type of the context.
+
+         if Is_Fixed_Point_Type (B_Typ)
+           and then (Base_Type (TL) = Base_Type (Standard_Integer)
+                      or else TL = Universal_Integer)
+         then
+            Resolve (R, B_Typ);
+            Resolve (L, TL);
+
+         elsif Is_Fixed_Point_Type (B_Typ)
+           and then (Base_Type (TR) = Base_Type (Standard_Integer)
+                      or else TR = Universal_Integer)
+         then
+            Resolve (L, B_Typ);
+            Resolve (R, TR);
+
+         else
+            Set_Mixed_Mode_Operand (L, TR);
+            Set_Mixed_Mode_Operand (R, TL);
+         end if;
+
+         if Etype (N) = Universal_Fixed
+           or else Etype (N) = Any_Fixed
+         then
+            if B_Typ = Universal_Fixed
+              and then Nkind (Parent (N)) /= N_Type_Conversion
+              and then Nkind (Parent (N)) /= N_Unchecked_Type_Conversion
+            then
+               Error_Msg_N
+                 ("type cannot be determined from context!", N);
+               Error_Msg_N
+                 ("\explicit conversion to result type required", N);
+
+               Set_Etype (L, Any_Type);
+               Set_Etype (R, Any_Type);
+
+            else
+               if Ada_83
+                  and then Etype (N) = Universal_Fixed
+                  and then Nkind (Parent (N)) /= N_Type_Conversion
+                  and then Nkind (Parent (N)) /= N_Unchecked_Type_Conversion
+               then
+                  Error_Msg_N
+                    ("(Ada 83) fixed-point operation " &
+                     "needs explicit conversion",
+                     N);
+               end if;
+
+               Set_Etype (N, B_Typ);
+            end if;
+
+         elsif Is_Fixed_Point_Type (B_Typ)
+           and then (Is_Integer_Or_Universal (L)
+                       or else Nkind (L) = N_Real_Literal
+                       or else Nkind (R) = N_Real_Literal
+                       or else
+                     Is_Integer_Or_Universal (R))
+         then
+            Set_Etype (N, B_Typ);
+
+         elsif Etype (N) = Any_Fixed then
+
+            --  If no previous errors, this is only possible if one operand
+            --  is overloaded and the context is universal. Resolve as such.
+
+            Set_Etype (N, B_Typ);
+         end if;
+
+      else
+         if (TL = Universal_Integer or else TL = Universal_Real)
+           and then (TR = Universal_Integer or else TR = Universal_Real)
+         then
+            Check_For_Visible_Operator (N, B_Typ);
+         end if;
+
+         --  If the context is Universal_Fixed and the operands are also
+         --  universal fixed, this is an error, unless there is only one
+         --  applicable fixed_point type (usually duration).
+
+         if B_Typ = Universal_Fixed
+           and then Etype (L) = Universal_Fixed
+         then
+            T := Unique_Fixed_Point_Type (N);
+
+            if T  = Any_Type then
+               Set_Etype (N, T);
+               return;
+            else
+               Resolve (L, T);
+               Resolve (R, T);
+            end if;
+
+         else
+            Resolve (L, B_Typ);
+            Resolve (R, B_Typ);
+         end if;
+
+         --  If one of the arguments was resolved to a non-universal type.
+         --  label the result of the operation itself with the same type.
+         --  Do the same for the universal argument, if any.
+
+         T := Intersect_Types (L, R);
+         Set_Etype (N, Base_Type (T));
+         Set_Operand_Type (L);
+         Set_Operand_Type (R);
+      end if;
+
+      Generate_Operator_Reference (N);
+      Eval_Arithmetic_Op (N);
+
+      --  Set overflow and division checking bit. Much cleverer code needed
+      --  here eventually and perhaps the Resolve routines should be separated
+      --  for the various arithmetic operations, since they will need
+      --  different processing. ???
+
+      if Nkind (N) in N_Op then
+         if not Overflow_Checks_Suppressed (Etype (N)) then
+            Set_Do_Overflow_Check (N);
+         end if;
+
+         if (Nkind (N) = N_Op_Divide
+             or else Nkind (N) = N_Op_Rem
+             or else Nkind (N) = N_Op_Mod)
+           and then not Division_Checks_Suppressed (Etype (N))
+         then
+            Set_Do_Division_Check (N);
+         end if;
+      end if;
+
+      Check_Unset_Reference (L);
+      Check_Unset_Reference (R);
+
+   end Resolve_Arithmetic_Op;
+
+   ------------------
+   -- Resolve_Call --
+   ------------------
+
+   procedure Resolve_Call (N : Node_Id; Typ : Entity_Id) is
+      Loc     : constant Source_Ptr := Sloc (N);
+      Subp    : constant Node_Id    := Name (N);
+      Nam     : Entity_Id;
+      I       : Interp_Index;
+      It      : Interp;
+      Norm_OK : Boolean;
+      Scop    : Entity_Id;
+
+   begin
+      --  The context imposes a unique interpretation with type Typ on
+      --  a procedure or function call. Find the entity of the subprogram
+      --  that yields the expected type, and propagate the corresponding
+      --  formal constraints on the actuals. The caller has established
+      --  that an interpretation exists, and emitted an error if not unique.
+
+      --  First deal with the case of a call to an access-to-subprogram,
+      --  dereference made explicit in Analyze_Call.
+
+      if Ekind (Etype (Subp)) = E_Subprogram_Type then
+
+         if not Is_Overloaded (Subp) then
+            Nam := Etype (Subp);
+
+         else
+            --  Find the interpretation whose type (a subprogram type)
+            --  has a return type that is compatible with the context.
+            --  Analysis of the node has established that one exists.
+
+            Get_First_Interp (Subp,  I, It);
+            Nam := Empty;
+
+            while Present (It.Typ) loop
+
+               if Covers (Typ, Etype (It.Typ)) then
+                  Nam := It.Typ;
+                  exit;
+               end if;
+
+               Get_Next_Interp (I, It);
+            end loop;
+
+            if No (Nam) then
+               raise Program_Error;
+            end if;
+         end if;
+
+         --  If the prefix is not an entity, then resolve it
+
+         if not Is_Entity_Name (Subp) then
+            Resolve (Subp, Nam);
+         end if;
+
+      --  If this is a procedure call which is really an entry call, do
+      --  the conversion of the procedure call to an entry call. Protected
+      --  operations use the same circuitry because the name in the call
+      --  can be an arbitrary expression with special resolution rules.
+
+      elsif Nkind (Subp) = N_Selected_Component
+        or else Nkind (Subp) = N_Indexed_Component
+        or else (Is_Entity_Name (Subp)
+                  and then Ekind (Entity (Subp)) = E_Entry)
+      then
+         Resolve_Entry_Call (N, Typ);
+         Check_Elab_Call (N);
+         return;
+
+      --  Normal subprogram call with name established in Resolve
+
+      elsif not (Is_Type (Entity (Subp))) then
+         Nam := Entity (Subp);
+         Set_Entity_With_Style_Check (Subp, Nam);
+         Generate_Reference (Nam, Subp);
+
+      --  Otherwise we must have the case of an overloaded call
+
+      else
+         pragma Assert (Is_Overloaded (Subp));
+         Nam := Empty;  --  We know that it will be assigned in loop below.
+
+         Get_First_Interp (Subp,  I, It);
+
+         while Present (It.Typ) loop
+            if Covers (Typ, It.Typ) then
+               Nam := It.Nam;
+               Set_Entity_With_Style_Check (Subp, Nam);
+               Generate_Reference (Nam, Subp);
+               exit;
+            end if;
+
+            Get_Next_Interp (I, It);
+         end loop;
+      end if;
+
+      --  Check that a call to Current_Task does not occur in an entry body
+
+      if Is_RTE (Nam, RE_Current_Task) then
+         declare
+            P : Node_Id;
+
+         begin
+            P := N;
+            loop
+               P := Parent (P);
+               exit when No (P);
+
+               if Nkind (P) = N_Entry_Body then
+                  Error_Msg_NE
+                    ("& should not be used in entry body ('R'M C.7(17))",
+                     N, Nam);
+                  exit;
+               end if;
+            end loop;
+         end;
+      end if;
+
+      --  Check that a procedure call does not occur in the context
+      --  of the entry call statement of a conditional or timed
+      --  entry call. Note that the case of a call to a subprogram
+      --  renaming of an entry will also be rejected. The test
+      --  for N not being an N_Entry_Call_Statement is defensive,
+      --  covering the possibility that the processing of entry
+      --  calls might reach this point due to later modifications
+      --  of the code above.
+
+      if Nkind (Parent (N)) = N_Entry_Call_Alternative
+        and then Nkind (N) /= N_Entry_Call_Statement
+        and then Entry_Call_Statement (Parent (N)) = N
+      then
+         Error_Msg_N ("entry call required in select statement", N);
+      end if;
+
+      --  Freeze the subprogram name if not in default expression. Note
+      --  that we freeze procedure calls as well as function calls.
+      --  Procedure calls are not frozen according to the rules (RM
+      --  13.14(14)) because it is impossible to have a procedure call to
+      --  a non-frozen procedure in pure Ada, but in the code that we
+      --  generate in the expander, this rule needs extending because we
+      --  can generate procedure calls that need freezing.
+
+      if Is_Entity_Name (Subp) and then not In_Default_Expression then
+         Freeze_Expression (Subp);
+      end if;
+
+      --  For a predefined operator, the type of the result is the type
+      --  imposed by context, except for a predefined operation on universal
+      --  fixed. Otherwise The type of the call is the type returned by the
+      --  subprogram being called.
+
+      if Is_Predefined_Op (Nam) then
+
+         if Etype (N) /= Universal_Fixed then
+            Set_Etype (N, Typ);
+         end if;
+
+      --  If the subprogram returns an array type, and the context
+      --  requires the component type of that array type, the node is
+      --  really an indexing of the parameterless call. Resolve as such.
+
+      elsif Needs_No_Actuals (Nam)
+        and then
+          ((Is_Array_Type (Etype (Nam))
+                   and then Covers (Typ, Component_Type (Etype (Nam))))
+             or else (Is_Access_Type (Etype (Nam))
+                        and then Is_Array_Type (Designated_Type (Etype (Nam)))
+                        and then
+                          Covers (Typ,
+                            Component_Type (Designated_Type (Etype (Nam))))))
+      then
+         declare
+            Index_Node : Node_Id;
+
+         begin
+            Check_Elab_Call (N);
+
+            if Component_Type (Etype (Nam)) /= Any_Type then
+               Index_Node :=
+                 Make_Indexed_Component (Loc,
+                   Prefix =>
+                     Make_Function_Call (Loc,
+                       Name => New_Occurrence_Of (Nam, Loc)),
+                   Expressions => Parameter_Associations (N));
+
+               --  Since we are correcting a node classification error made by
+               --  the parser, we call Replace rather than Rewrite.
+
+               Replace (N, Index_Node);
+               Set_Etype (Prefix (N), Etype (Nam));
+               Set_Etype (N, Typ);
+               Resolve_Indexed_Component (N, Typ);
+            end if;
+
+            return;
+         end;
+
+      else
+         Set_Etype (N, Etype (Nam));
+      end if;
+
+      --  In the case where the call is to an overloaded subprogram, Analyze
+      --  calls Normalize_Actuals once per overloaded subprogram. Therefore in
+      --  such a case Normalize_Actuals needs to be called once more to order
+      --  the actuals correctly. Otherwise the call will have the ordering
+      --  given by the last overloaded subprogram whether this is the correct
+      --  one being called or not.
+
+      if Is_Overloaded (Subp) then
+         Normalize_Actuals (N, Nam, False, Norm_OK);
+         pragma Assert (Norm_OK);
+      end if;
+
+      --  In any case, call is fully resolved now. Reset Overload flag, to
+      --  prevent subsequent overload resolution if node is analyzed again
+
+      Set_Is_Overloaded (Subp, False);
+      Set_Is_Overloaded (N, False);
+
+      --  If we are calling the current subprogram from immediately within
+      --  its body, then that is the case where we can sometimes detect
+      --  cases of infinite recursion statically. Do not try this in case
+      --  restriction No_Recursion is in effect anyway.
+
+      Scop := Current_Scope;
+
+      if Nam = Scop
+        and then not Restrictions (No_Recursion)
+        and then Check_Infinite_Recursion (N)
+      then
+         --  Here we detected and flagged an infinite recursion, so we do
+         --  not need to test the case below for further warnings.
+
+         null;
+
+      --  If call is to immediately containing subprogram, then check for
+      --  the case of a possible run-time detectable infinite recursion.
+
+      else
+         while Scop /= Standard_Standard loop
+            if Nam = Scop then
+               --  Although in general recursion is not statically checkable,
+               --  the case of calling an immediately containing subprogram
+               --  is easy to catch.
+
+               Check_Restriction (No_Recursion, N);
+
+               --  If the recursive call is to a parameterless procedure, then
+               --  even if we can't statically detect infinite recursion, this
+               --  is pretty suspicious, and we output a warning. Furthermore,
+               --  we will try later to detect some cases here at run time by
+               --  expanding checking code (see Detect_Infinite_Recursion in
+               --  package Exp_Ch6).
+               --  If the recursive call is within a handler we do not emit a
+               --  warning, because this is a common idiom: loop until input
+               --  is correct, catch illegal input in handler and restart.
+
+               if No (First_Formal (Nam))
+                 and then Etype (Nam) = Standard_Void_Type
+                 and then not Error_Posted (N)
+                 and then Nkind (Parent (N)) /= N_Exception_Handler
+               then
+                  Set_Has_Recursive_Call (Nam);
+                  Error_Msg_N ("possible infinite recursion?", N);
+                  Error_Msg_N ("Storage_Error may be raised at run time?", N);
+               end if;
+
+               exit;
+            end if;
+
+            Scop := Scope (Scop);
+         end loop;
+      end if;
+
+      --  If subprogram name is a predefined operator, it was given in
+      --  functional notation. Replace call node with operator node, so
+      --  that actuals can be resolved appropriately.
+
+      if Is_Predefined_Op (Nam) or else Ekind (Nam) = E_Operator then
+         Make_Call_Into_Operator (N, Typ, Entity (Name (N)));
+         return;
+
+      elsif Present (Alias (Nam))
+        and then Is_Predefined_Op (Alias (Nam))
+      then
+         Resolve_Actuals (N, Nam);
+         Make_Call_Into_Operator (N, Typ, Alias (Nam));
+         return;
+      end if;
+
+      --  Create a transient scope if the resulting type requires it.
+      --  There are 3 notable exceptions: in init_procs, the transient scope
+      --  overhead is not needed and even incorrect due to the actual expansion
+      --  of adjust calls; the second case is enumeration literal pseudo calls,
+      --  the other case is intrinsic subprograms (Unchecked_Conversion and
+      --  source information functions) that do not use the secondary stack
+      --  even though the return type is unconstrained.
+
+      --  If this is an initialization call for a type whose initialization
+      --  uses the secondary stack, we also need to create a transient scope
+      --  for it, precisely because we will not do it within the init_proc
+      --  itself.
+
+      if Expander_Active
+        and then Is_Type (Etype (Nam))
+        and then Requires_Transient_Scope (Etype (Nam))
+        and then Ekind (Nam) /= E_Enumeration_Literal
+        and then not Within_Init_Proc
+        and then not Is_Intrinsic_Subprogram (Nam)
+      then
+         Establish_Transient_Scope
+           (N, Sec_Stack => not Functions_Return_By_DSP_On_Target);
+
+      elsif Chars (Nam) = Name_uInit_Proc
+        and then not Within_Init_Proc
+      then
+         Check_Initialization_Call (N, Nam);
+      end if;
+
+      --  A protected function cannot be called within the definition of the
+      --  enclosing protected type.
+
+      if Is_Protected_Type (Scope (Nam))
+        and then In_Open_Scopes (Scope (Nam))
+        and then not Has_Completion (Scope (Nam))
+      then
+         Error_Msg_NE
+           ("& cannot be called before end of protected definition", N, Nam);
+      end if;
+
+      --  Propagate interpretation to actuals, and add default expressions
+      --  where needed.
+
+      if Present (First_Formal (Nam)) then
+         Resolve_Actuals (N, Nam);
+
+         --  Overloaded literals are rewritten as function calls, for
+         --  purpose of resolution. After resolution, we can replace
+         --  the call with the literal itself.
+
+      elsif Ekind (Nam) = E_Enumeration_Literal then
+         Copy_Node (Subp, N);
+         Resolve_Entity_Name (N, Typ);
+
+         --  Avoid validation, since it is a static function call.
+
+         return;
+      end if;
+
+      --  If the subprogram is a primitive operation, check whether or not
+      --  it is a correct dispatching call.
+
+      if Is_Overloadable (Nam)
+        and then Is_Dispatching_Operation (Nam)
+      then
+         Check_Dispatching_Call (N);
+
+            --  If the subprogram is abstract, check that the call has a
+            --  controlling argument (i.e. is dispatching) or is disptaching on
+            --  result
+
+         if Is_Abstract (Nam)
+           and then No (Controlling_Argument (N))
+           and then not Is_Class_Wide_Type (Typ)
+           and then not Is_Tag_Indeterminate (N)
+         then
+            Error_Msg_N ("call to abstract subprogram must be dispatching", N);
+         end if;
+
+      elsif Is_Abstract (Nam)
+        and then not In_Instance
+      then
+         Error_Msg_NE ("cannot call abstract subprogram &!", N, Nam);
+      end if;
+
+      if Is_Intrinsic_Subprogram (Nam) then
+         Check_Intrinsic_Call (N);
+      end if;
+
+      --  If we fall through we definitely have a non-static call
+
+      Check_Elab_Call (N);
+
+   end Resolve_Call;
+
+   -------------------------------
+   -- Resolve_Character_Literal --
+   -------------------------------
+
+   procedure Resolve_Character_Literal (N : Node_Id; Typ : Entity_Id) is
+      B_Typ : constant Entity_Id := Base_Type (Typ);
+      C     : Entity_Id;
+
+   begin
+      --  Verify that the character does belong to the type of the context
+
+      Set_Etype (N, B_Typ);
+      Eval_Character_Literal (N);
+
+      --  Wide_Character literals must always be defined, since the set of
+      --  wide character literals is complete, i.e. if a character literal
+      --  is accepted by the parser, then it is OK for wide character.
+
+      if Root_Type (B_Typ) = Standard_Wide_Character then
+         return;
+
+      --  Always accept character literal for type Any_Character, which
+      --  occurs in error situations and in comparisons of literals, both
+      --  of which should accept all literals.
+
+      elsif B_Typ = Any_Character then
+         return;
+
+      --  For Standard.Character or a type derived from it, check that
+      --  the literal is in range
+
+      elsif Root_Type (B_Typ) = Standard_Character then
+         if In_Character_Range (Char_Literal_Value (N)) then
+            return;
+         end if;
+
+      --  If the entity is already set, this has already been resolved in
+      --  a generic context, or comes from expansion. Nothing else to do.
+
+      elsif Present (Entity (N)) then
+         return;
+
+      --  Otherwise we have a user defined character type, and we can use
+      --  the standard visibility mechanisms to locate the referenced entity
+
+      else
+         C := Current_Entity (N);
+
+         while Present (C) loop
+            if Etype (C) = B_Typ then
+               Set_Entity_With_Style_Check (N, C);
+               Generate_Reference (C, N);
+               return;
+            end if;
+
+            C := Homonym (C);
+         end loop;
+      end if;
+
+      --  If we fall through, then the literal does not match any of the
+      --  entries of the enumeration type. This isn't just a constraint
+      --  error situation, it is an illegality (see RM 4.2).
+
+      Error_Msg_NE
+        ("character not defined for }", N, First_Subtype (B_Typ));
+
+   end Resolve_Character_Literal;
+
+   ---------------------------
+   -- Resolve_Comparison_Op --
+   ---------------------------
+
+   --  Context requires a boolean type, and plays no role in resolution.
+   --  Processing identical to that for equality operators.
+
+   procedure Resolve_Comparison_Op (N : Node_Id; Typ : Entity_Id) is
+      L : constant Node_Id := Left_Opnd (N);
+      R : constant Node_Id := Right_Opnd (N);
+      T : Entity_Id;
+
+   begin
+      --  If this is an intrinsic operation which is not predefined, use
+      --  the types of its declared arguments to resolve the possibly
+      --  overloaded operands. Otherwise the operands are unambiguous and
+      --  specify the expected type.
+
+      if Scope (Entity (N)) /= Standard_Standard then
+         T := Etype (First_Entity (Entity (N)));
+      else
+         T := Find_Unique_Type (L, R);
+
+         if T = Any_Fixed then
+            T := Unique_Fixed_Point_Type (L);
+         end if;
+      end if;
+
+      Set_Etype (N, Typ);
+      Generate_Reference (T, N, ' ');
+
+      if T /= Any_Type then
+
+         if T = Any_String
+           or else T = Any_Composite
+           or else T = Any_Character
+         then
+            if T = Any_Character then
+               Ambiguous_Character (L);
+            else
+               Error_Msg_N ("ambiguous operands for comparison", N);
+            end if;
+
+            Set_Etype (N, Any_Type);
+            return;
+
+         else
+            if Comes_From_Source (N)
+              and then Has_Unchecked_Union (T)
+            then
+               Error_Msg_N
+                ("cannot compare Unchecked_Union values", N);
+            end if;
+
+            Resolve (L, T);
+            Resolve (R, T);
+            Check_Unset_Reference (L);
+            Check_Unset_Reference (R);
+            Generate_Operator_Reference (N);
+            Eval_Relational_Op (N);
+         end if;
+      end if;
+
+   end Resolve_Comparison_Op;
+
+   ------------------------------------
+   -- Resolve_Conditional_Expression --
+   ------------------------------------
+
+   procedure Resolve_Conditional_Expression (N : Node_Id; Typ : Entity_Id) is
+      Condition : constant Node_Id := First (Expressions (N));
+      Then_Expr : constant Node_Id := Next (Condition);
+      Else_Expr : constant Node_Id := Next (Then_Expr);
+
+   begin
+      Resolve (Condition, Standard_Boolean);
+      Resolve (Then_Expr, Typ);
+      Resolve (Else_Expr, Typ);
+
+      Set_Etype (N, Typ);
+      Eval_Conditional_Expression (N);
+   end Resolve_Conditional_Expression;
+
+   -----------------------------------------
+   -- Resolve_Discrete_Subtype_Indication --
+   -----------------------------------------
+
+   procedure Resolve_Discrete_Subtype_Indication
+     (N   : Node_Id;
+      Typ : Entity_Id)
+   is
+      R : Node_Id;
+      S : Entity_Id;
+
+   begin
+      Analyze (Subtype_Mark (N));
+      S := Entity (Subtype_Mark (N));
+
+      if Nkind (Constraint (N)) /= N_Range_Constraint then
+         Error_Msg_N ("expect range constraint for discrete type", N);
+         Set_Etype (N, Any_Type);
+
+      else
+         R := Range_Expression (Constraint (N));
+         Analyze (R);
+
+         if Base_Type (S) /= Base_Type (Typ) then
+            Error_Msg_NE
+              ("expect subtype of }", N, First_Subtype (Typ));
+
+            --  Rewrite the constraint as a range of Typ
+            --  to allow compilation to proceed further.
+
+            Set_Etype (N, Typ);
+            Rewrite (Low_Bound (R),
+              Make_Attribute_Reference (Sloc (Low_Bound (R)),
+                Prefix =>         New_Occurrence_Of (Typ, Sloc (R)),
+                Attribute_Name => Name_First));
+            Rewrite (High_Bound (R),
+              Make_Attribute_Reference (Sloc (High_Bound (R)),
+                Prefix =>         New_Occurrence_Of (Typ, Sloc (R)),
+                Attribute_Name => Name_First));
+
+         else
+            Resolve (R, Typ);
+            Set_Etype (N, Etype (R));
+
+            --  Additionally, we must check that the bounds are compatible
+            --  with the given subtype, which might be different from the
+            --  type of the context.
+
+            Apply_Range_Check (R, S);
+
+            --  ??? If the above check statically detects a Constraint_Error
+            --  it replaces the offending bound(s) of the range R with a
+            --  Constraint_Error node. When the itype which uses these bounds
+            --  is frozen the resulting call to Duplicate_Subexpr generates
+            --  a new temporary for the bounds.
+
+            --  Unfortunately there are other itypes that are also made depend
+            --  on these bounds, so when Duplicate_Subexpr is called they get
+            --  a forward reference to the newly created temporaries and Gigi
+            --  aborts on such forward references. This is probably sign of a
+            --  more fundamental problem somewhere else in either the order of
+            --  itype freezing or the way certain itypes are constructed.
+
+            --  To get around this problem we call Remove_Side_Effects right
+            --  away if either bounds of R are a Constraint_Error.
+
+            declare
+               L : Node_Id := Low_Bound (R);
+               H : Node_Id := High_Bound (R);
+
+            begin
+               if Nkind (L) = N_Raise_Constraint_Error then
+                  Remove_Side_Effects (L);
+               end if;
+
+               if Nkind (H) = N_Raise_Constraint_Error then
+                  Remove_Side_Effects (H);
+               end if;
+            end;
+
+            Check_Unset_Reference (Low_Bound  (R));
+            Check_Unset_Reference (High_Bound (R));
+         end if;
+      end if;
+   end Resolve_Discrete_Subtype_Indication;
+
+   -------------------------
+   -- Resolve_Entity_Name --
+   -------------------------
+
+   --  Used to resolve identifiers and expanded names
+
+   procedure Resolve_Entity_Name (N : Node_Id; Typ : Entity_Id) is
+      E : constant Entity_Id := Entity (N);
+
+   begin
+      --  Replace named numbers by corresponding literals. Note that this is
+      --  the one case where Resolve_Entity_Name must reset the Etype, since
+      --  it is currently marked as universal.
+
+      if Ekind (E) = E_Named_Integer then
+         Set_Etype (N, Typ);
+         Eval_Named_Integer (N);
+
+      elsif Ekind (E) = E_Named_Real then
+         Set_Etype (N, Typ);
+         Eval_Named_Real (N);
+
+      --  Allow use of subtype only if it is a concurrent type where we are
+      --  currently inside the body. This will eventually be expanded
+      --  into a call to Self (for tasks) or _object (for protected
+      --  objects). Any other use of a subtype is invalid.
+
+      elsif Is_Type (E) then
+         if Is_Concurrent_Type (E)
+           and then In_Open_Scopes (E)
+         then
+            null;
+         else
+            Error_Msg_N
+               ("Invalid use of subtype mark in expression or call", N);
+         end if;
+
+      --  Check discriminant use if entity is discriminant in current scope,
+      --  i.e. discriminant of record or concurrent type currently being
+      --  analyzed. Uses in corresponding body are unrestricted.
+
+      elsif Ekind (E) = E_Discriminant
+        and then Scope (E) = Current_Scope
+        and then not Has_Completion (Current_Scope)
+      then
+         Check_Discriminant_Use (N);
+
+      --  A parameterless generic function cannot appear in a context that
+      --  requires resolution.
+
+      elsif Ekind (E) = E_Generic_Function then
+         Error_Msg_N ("illegal use of generic function", N);
+
+      elsif Ekind (E) = E_Out_Parameter
+        and then Ada_83
+        and then (Nkind (Parent (N)) in N_Op
+                    or else (Nkind (Parent (N)) = N_Assignment_Statement
+                              and then N = Expression (Parent (N)))
+                    or else Nkind (Parent (N)) = N_Explicit_Dereference)
+      then
+         Error_Msg_N ("(Ada 83) illegal reading of out parameter", N);
+
+      --  In all other cases, just do the possible static evaluation
+
+      else
+         --  A deferred constant that appears in an expression must have
+         --  a completion, unless it has been removed by in-place expansion
+         --  of an aggregate.
+
+         if Ekind (E) = E_Constant
+           and then Comes_From_Source (E)
+           and then No (Constant_Value (E))
+           and then Is_Frozen (Etype (E))
+           and then not In_Default_Expression
+           and then not Is_Imported (E)
+         then
+
+            if No_Initialization (Parent (E))
+              or else (Present (Full_View (E))
+                        and then No_Initialization (Parent (Full_View (E))))
+            then
+               null;
+            else
+               Error_Msg_N (
+                 "deferred constant is frozen before completion", N);
+            end if;
+         end if;
+
+         Eval_Entity_Name (N);
+      end if;
+   end Resolve_Entity_Name;
+
+   -------------------
+   -- Resolve_Entry --
+   -------------------
+
+   procedure Resolve_Entry (Entry_Name : Node_Id) is
+      Loc    : constant Source_Ptr := Sloc (Entry_Name);
+      Nam    : Entity_Id;
+      New_N  : Node_Id;
+      S      : Entity_Id;
+      Tsk    : Entity_Id;
+      E_Name : Node_Id;
+      Index  : Node_Id;
+
+      function Actual_Index_Type (E : Entity_Id) return Entity_Id;
+      --  If the bounds of the entry family being called depend on task
+      --  discriminants, build a new index subtype where a discriminant is
+      --  replaced with the value of the discriminant of the target task.
+      --  The target task is the prefix of the entry name in the call.
+
+      -----------------------
+      -- Actual_Index_Type --
+      -----------------------
+
+      function Actual_Index_Type (E : Entity_Id) return Entity_Id is
+         Typ   : Entity_Id := Entry_Index_Type (E);
+         Tsk   : Entity_Id := Scope (E);
+         Lo    : Node_Id := Type_Low_Bound  (Typ);
+         Hi    : Node_Id := Type_High_Bound (Typ);
+         New_T : Entity_Id;
+
+         function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id;
+         --  If the bound is given by a discriminant, replace with a reference
+         --  to the discriminant of the same name in the target task.
+         --  If the entry name is the target of a requeue statement and the
+         --  entry is in the current protected object, the bound to be used
+         --  is the discriminal of the object (see apply_range_checks for
+         --  details of the transformation).
+
+         -----------------------------
+         -- Actual_Discriminant_Ref --
+         -----------------------------
+
+         function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id is
+            Typ : Entity_Id := Etype (Bound);
+            Ref : Node_Id;
+
+         begin
+            Remove_Side_Effects (Bound);
+
+            if not Is_Entity_Name (Bound)
+              or else Ekind (Entity (Bound)) /= E_Discriminant
+            then
+               return Bound;
+
+            elsif Is_Protected_Type (Tsk)
+              and then In_Open_Scopes (Tsk)
+              and then Nkind (Parent (Entry_Name)) = N_Requeue_Statement
+            then
+               return New_Occurrence_Of (Discriminal (Entity (Bound)), Loc);
+
+            else
+               Ref :=
+                 Make_Selected_Component (Loc,
+                   Prefix => New_Copy_Tree (Prefix (Prefix (Entry_Name))),
+                   Selector_Name => New_Occurrence_Of (Entity (Bound), Loc));
+               Analyze (Ref);
+               Resolve (Ref, Typ);
+               return Ref;
+            end if;
+         end Actual_Discriminant_Ref;
+
+      --  Start of processing for Actual_Index_Type
+
+      begin
+         if not Has_Discriminants (Tsk)
+           or else (not Is_Entity_Name (Lo)
+                     and then not Is_Entity_Name (Hi))
+         then
+            return Entry_Index_Type (E);
+
+         else
+            New_T := Create_Itype (Ekind (Typ), Parent (Entry_Name));
+            Set_Etype        (New_T, Base_Type (Typ));
+            Set_Size_Info    (New_T, Typ);
+            Set_RM_Size      (New_T, RM_Size (Typ));
+            Set_Scalar_Range (New_T,
+              Make_Range (Sloc (Entry_Name),
+                Low_Bound  => Actual_Discriminant_Ref (Lo),
+                High_Bound => Actual_Discriminant_Ref (Hi)));
+
+            return New_T;
+         end if;
+      end Actual_Index_Type;
+
+   --  Start of processing of Resolve_Entry
+
+   begin
+      --  Find name of entry being called, and resolve prefix of name
+      --  with its own type. The prefix can be overloaded, and the name
+      --  and signature of the entry must be taken into account.
+
+      if Nkind (Entry_Name) = N_Indexed_Component then
+
+         --  Case of dealing with entry family within the current tasks
+
+         E_Name := Prefix (Entry_Name);
+
+      else
+         E_Name := Entry_Name;
+      end if;
+
+      if Is_Entity_Name (E_Name) then
+         --  Entry call to an entry (or entry family) in the current task.
+         --  This is legal even though the task will deadlock. Rewrite as
+         --  call to current task.
+
+         --  This can also be a call to an entry in  an enclosing task.
+         --  If this is a single task, we have to retrieve its name,
+         --  because the scope of the entry is the task type, not the
+         --  object. If the enclosing task is a task type, the identity
+         --  of the task is given by its own self variable.
+
+         --  Finally this can be a requeue on an entry of the same task
+         --  or protected object.
+
+         S := Scope (Entity (E_Name));
+
+         for J in reverse 0 .. Scope_Stack.Last loop
+
+            if Is_Task_Type (Scope_Stack.Table (J).Entity)
+              and then not Comes_From_Source (S)
+            then
+               --  S is an enclosing task or protected object. The concurrent
+               --  declaration has been converted into a type declaration, and
+               --  the object itself has an object declaration that follows
+               --  the type in the same declarative part.
+
+               Tsk := Next_Entity (S);
+
+               while Etype (Tsk) /= S loop
+                  Next_Entity (Tsk);
+               end loop;
+
+               S := Tsk;
+               exit;
+
+            elsif S = Scope_Stack.Table (J).Entity then
+
+               --  Call to current task. Will be transformed into call to Self
+
+               exit;
+
+            end if;
+         end loop;
+
+         New_N :=
+           Make_Selected_Component (Loc,
+             Prefix => New_Occurrence_Of (S, Loc),
+             Selector_Name =>
+               New_Occurrence_Of (Entity (E_Name), Loc));
+         Rewrite (E_Name, New_N);
+         Analyze (E_Name);
+
+      elsif Nkind (Entry_Name) = N_Selected_Component
+        and then Is_Overloaded (Prefix (Entry_Name))
+      then
+         --  Use the entry name (which must be unique at this point) to
+         --  find the prefix that returns the corresponding task type or
+         --  protected type.
+
+         declare
+            Pref : Node_Id := Prefix (Entry_Name);
+            I    : Interp_Index;
+            It   : Interp;
+            Ent  : Entity_Id :=  Entity (Selector_Name (Entry_Name));
+
+         begin
+            Get_First_Interp (Pref, I, It);
+
+            while Present (It.Typ) loop
+
+               if Scope (Ent) = It.Typ then
+                  Set_Etype (Pref, It.Typ);
+                  exit;
+               end if;
+
+               Get_Next_Interp (I, It);
+            end loop;
+         end;
+      end if;
+
+      if Nkind (Entry_Name) = N_Selected_Component then
+         Resolve (Prefix (Entry_Name), Etype (Prefix (Entry_Name)));
+
+      else pragma Assert (Nkind (Entry_Name) = N_Indexed_Component);
+         Nam := Entity (Selector_Name (Prefix (Entry_Name)));
+         Resolve (Prefix (Prefix (Entry_Name)),
+                   Etype (Prefix (Prefix (Entry_Name))));
+
+         Index :=  First (Expressions (Entry_Name));
+         Resolve (Index, Entry_Index_Type (Nam));
+
+         --  Up to this point the expression could have been the actual
+         --  in a simple entry call, and be given by a named association.
+
+         if Nkind (Index) = N_Parameter_Association then
+            Error_Msg_N ("expect expression for entry index", Index);
+         else
+            Apply_Range_Check (Index, Actual_Index_Type (Nam));
+         end if;
+      end if;
+
+   end Resolve_Entry;
+
+   ------------------------
+   -- Resolve_Entry_Call --
+   ------------------------
+
+   procedure Resolve_Entry_Call (N : Node_Id; Typ : Entity_Id) is
+      Entry_Name  : constant Node_Id    := Name (N);
+      Loc         : constant Source_Ptr := Sloc (Entry_Name);
+      Actuals     : List_Id;
+      First_Named : Node_Id;
+      Nam         : Entity_Id;
+      Norm_OK     : Boolean;
+      Obj         : Node_Id;
+      Was_Over    : Boolean;
+
+   begin
+      --  Processing of the name is similar for entry calls and protected
+      --  operation calls. Once the entity is determined, we can complete
+      --  the resolution of the actuals.
+
+      --  The selector may be overloaded, in the case of a protected object
+      --  with overloaded functions. The type of the context is used for
+      --  resolution.
+
+      if Nkind (Entry_Name) = N_Selected_Component
+        and then Is_Overloaded (Selector_Name (Entry_Name))
+        and then Typ /= Standard_Void_Type
+      then
+         declare
+            I  : Interp_Index;
+            It : Interp;
+
+         begin
+            Get_First_Interp (Selector_Name (Entry_Name), I, It);
+
+            while Present (It.Typ) loop
+
+               if Covers (Typ, It.Typ) then
+                  Set_Entity (Selector_Name (Entry_Name), It.Nam);
+                  Set_Etype  (Entry_Name, It.Typ);
+
+                  Generate_Reference (It.Typ, N, ' ');
+               end if;
+
+               Get_Next_Interp (I, It);
+            end loop;
+         end;
+      end if;
+
+      Resolve_Entry (Entry_Name);
+
+      if Nkind (Entry_Name) = N_Selected_Component then
+
+         --  Simple entry call.
+
+         Nam := Entity (Selector_Name (Entry_Name));
+         Obj := Prefix (Entry_Name);
+         Was_Over := Is_Overloaded (Selector_Name (Entry_Name));
+
+      else pragma Assert (Nkind (Entry_Name) = N_Indexed_Component);
+
+         --  Call to member of entry family.
+
+         Nam := Entity (Selector_Name (Prefix (Entry_Name)));
+         Obj := Prefix (Prefix (Entry_Name));
+         Was_Over := Is_Overloaded (Selector_Name (Prefix (Entry_Name)));
+      end if;
+
+      --  Use context type to disambiguate a protected function that can be
+      --  called without actuals and that returns an array type, and where
+      --  the argument list may be an indexing of the returned value.
+
+      if Ekind (Nam) = E_Function
+        and then Needs_No_Actuals (Nam)
+        and then Present (Parameter_Associations (N))
+        and then
+          ((Is_Array_Type (Etype (Nam))
+             and then Covers (Typ, Component_Type (Etype (Nam))))
+
+            or else (Is_Access_Type (Etype (Nam))
+                      and then Is_Array_Type (Designated_Type (Etype (Nam)))
+                      and then Covers (Typ,
+                        Component_Type (Designated_Type (Etype (Nam))))))
+      then
+         declare
+            Index_Node : Node_Id;
+
+         begin
+            Index_Node :=
+              Make_Indexed_Component (Loc,
+                Prefix =>
+                  Make_Function_Call (Loc,
+                    Name => Relocate_Node (Entry_Name)),
+                Expressions => Parameter_Associations (N));
+
+            --  Since we are correcting a node classification error made by
+            --  the parser, we call Replace rather than Rewrite.
+
+            Replace (N, Index_Node);
+            Set_Etype (Prefix (N), Etype (Nam));
+            Set_Etype (N, Typ);
+            Resolve_Indexed_Component (N, Typ);
+            return;
+         end;
+      end if;
+
+      --  The operation name may have been overloaded. Order the actuals
+      --  according to the formals of the resolved entity.
+
+      if Was_Over then
+         Normalize_Actuals (N, Nam, False, Norm_OK);
+         pragma Assert (Norm_OK);
+      end if;
+
+      Resolve_Actuals (N, Nam);
+      Generate_Reference (Nam, Entry_Name);
+
+      if Ekind (Nam) = E_Entry
+        or else Ekind (Nam) = E_Entry_Family
+      then
+         Check_Potentially_Blocking_Operation (N);
+      end if;
+
+      --  Verify that a procedure call cannot masquerade as an entry
+      --  call where an entry call is expected.
+
+      if Ekind (Nam) = E_Procedure then
+
+         if Nkind (Parent (N)) = N_Entry_Call_Alternative
+           and then N = Entry_Call_Statement (Parent (N))
+         then
+            Error_Msg_N ("entry call required in select statement", N);
+
+         elsif Nkind (Parent (N)) = N_Triggering_Alternative
+           and then N = Triggering_Statement (Parent (N))
+         then
+            Error_Msg_N ("triggering statement cannot be procedure call", N);
+
+         elsif Ekind (Scope (Nam)) = E_Task_Type
+           and then not In_Open_Scopes (Scope (Nam))
+         then
+            Error_Msg_N ("Task has no entry with this name", Entry_Name);
+         end if;
+      end if;
+
+      --  After resolution, entry calls and protected procedure calls
+      --  are changed into entry calls, for expansion. The structure
+      --  of the node does not change, so it can safely be done in place.
+      --  Protected function calls must keep their structure because they
+      --  are subexpressions.
+
+      if Ekind (Nam) /= E_Function then
+
+         --  A protected operation that is not a function may modify the
+         --  corresponding object, and cannot apply to a constant.
+         --  If this is an internal call, the prefix is the type itself.
+
+         if Is_Protected_Type (Scope (Nam))
+           and then not Is_Variable (Obj)
+           and then (not Is_Entity_Name (Obj)
+                       or else not Is_Type (Entity (Obj)))
+         then
+            Error_Msg_N
+              ("prefix of protected procedure or entry call must be variable",
+               Entry_Name);
+         end if;
+
+         Actuals := Parameter_Associations (N);
+         First_Named := First_Named_Actual (N);
+
+         Rewrite (N,
+           Make_Entry_Call_Statement (Loc,
+             Name                   => Entry_Name,
+             Parameter_Associations => Actuals));
+
+         Set_First_Named_Actual (N, First_Named);
+         Set_Analyzed (N, True);
+
+      --  Protected functions can return on the secondary stack, in which
+      --  case we must trigger the transient scope mechanism
+
+      elsif Expander_Active
+        and then Requires_Transient_Scope (Etype (Nam))
+      then
+         Establish_Transient_Scope (N,
+           Sec_Stack => not Functions_Return_By_DSP_On_Target);
+      end if;
+
+   end Resolve_Entry_Call;
+
+   -------------------------
+   -- Resolve_Equality_Op --
+   -------------------------
+
+   --  Both arguments must have the same type, and the boolean context
+   --  does not participate in the resolution. The first pass verifies
+   --  that the interpretation is not ambiguous, and the type of the left
+   --  argument is correctly set, or is Any_Type in case of ambiguity.
+   --  If both arguments are strings or aggregates, allocators, or Null,
+   --  they are ambiguous even though they carry a single (universal) type.
+   --  Diagnose this case here.
+
+   procedure Resolve_Equality_Op (N : Node_Id; Typ : Entity_Id) is
+      L : constant Node_Id   := Left_Opnd (N);
+      R : constant Node_Id   := Right_Opnd (N);
+      T : Entity_Id := Find_Unique_Type (L, R);
+
+      function Find_Unique_Access_Type return Entity_Id;
+      --  In the case of allocators, make a last-ditch attempt to find a single
+      --  access type with the right designated type. This is semantically
+      --  dubious, and of no interest to any real code, but c48008a makes it
+      --  all worthwhile.
+
+      -----------------------------
+      -- Find_Unique_Access_Type --
+      -----------------------------
+
+      function Find_Unique_Access_Type return Entity_Id is
+         Acc : Entity_Id;
+         E   : Entity_Id;
+         S   : Entity_Id := Current_Scope;
+
+      begin
+         if Ekind (Etype (R)) =  E_Allocator_Type then
+            Acc := Designated_Type (Etype (R));
+
+         elsif Ekind (Etype (L)) =  E_Allocator_Type then
+            Acc := Designated_Type (Etype (L));
+
+         else
+            return Empty;
+         end if;
+
+         while S /= Standard_Standard loop
+            E := First_Entity (S);
+
+            while Present (E) loop
+
+               if Is_Type (E)
+                 and then Is_Access_Type (E)
+                 and then Ekind (E) /= E_Allocator_Type
+                 and then Designated_Type (E) = Base_Type (Acc)
+               then
+                  return E;
+               end if;
+
+               Next_Entity (E);
+            end loop;
+
+            S := Scope (S);
+         end loop;
+
+         return Empty;
+      end Find_Unique_Access_Type;
+
+   --  Start of processing for Resolve_Equality_Op
+
+   begin
+      Set_Etype (N, Base_Type (Typ));
+      Generate_Reference (T, N, ' ');
+
+      if T = Any_Fixed then
+         T := Unique_Fixed_Point_Type (L);
+      end if;
+
+      if T /= Any_Type then
+
+         if T = Any_String
+           or else T = Any_Composite
+           or else T = Any_Character
+         then
+
+            if T = Any_Character then
+               Ambiguous_Character (L);
+            else
+               Error_Msg_N ("ambiguous operands for equality", N);
+            end if;
+
+            Set_Etype (N, Any_Type);
+            return;
+
+         elsif T = Any_Access
+           or else Ekind (T) = E_Allocator_Type
+         then
+            T := Find_Unique_Access_Type;
+
+            if No (T) then
+               Error_Msg_N ("ambiguous operands for equality", N);
+               Set_Etype (N, Any_Type);
+               return;
+            end if;
+         end if;
+
+         if Comes_From_Source (N)
+           and then Has_Unchecked_Union (T)
+         then
+            Error_Msg_N
+              ("cannot compare Unchecked_Union values", N);
+         end if;
+
+         Resolve (L, T);
+         Resolve (R, T);
+         Check_Unset_Reference (L);
+         Check_Unset_Reference (R);
+         Generate_Operator_Reference (N);
+
+         --  If this is an inequality, it may be the implicit inequality
+         --  created for a user-defined operation, in which case the corres-
+         --  ponding equality operation is not intrinsic, and the operation
+         --  cannot be constant-folded. Else fold.
+
+         if Nkind (N) = N_Op_Eq
+           or else Comes_From_Source (Entity (N))
+           or else Ekind (Entity (N)) = E_Operator
+           or else Is_Intrinsic_Subprogram
+             (Corresponding_Equality (Entity (N)))
+         then
+            Eval_Relational_Op (N);
+         elsif Nkind (N) = N_Op_Ne
+           and then Is_Abstract (Entity (N))
+         then
+            Error_Msg_NE ("cannot call abstract subprogram &!", N, Entity (N));
+         end if;
+      end if;
+   end Resolve_Equality_Op;
+
+   ----------------------------------
+   -- Resolve_Explicit_Dereference --
+   ----------------------------------
+
+   procedure Resolve_Explicit_Dereference (N : Node_Id; Typ : Entity_Id) is
+      P  : constant Node_Id := Prefix (N);
+      I  : Interp_Index;
+      It : Interp;
+
+   begin
+      --  Now that we know the type, check that this is not a
+      --  dereference of an uncompleted type. Note that this
+      --  is not entirely correct, because dereferences of
+      --  private types are legal in default expressions.
+      --  This consideration also applies to similar checks
+      --  for allocators, qualified expressions, and type
+      --  conversions. ???
+
+      Check_Fully_Declared (Typ, N);
+
+      if Is_Overloaded (P) then
+
+         --  Use the context type to select the prefix that has the
+         --  correct designated type.
+
+         Get_First_Interp (P, I, It);
+         while Present (It.Typ) loop
+            exit when Is_Access_Type (It.Typ)
+              and then Covers (Typ, Designated_Type (It.Typ));
+
+            Get_Next_Interp (I, It);
+         end loop;
+
+         Resolve (P, It.Typ);
+         Set_Etype (N, Designated_Type (It.Typ));
+
+      else
+         Resolve (P, Etype (P));
+      end if;
+
+      if Is_Access_Type (Etype (P)) then
+         Apply_Access_Check (N);
+      end if;
+
+      --  If the designated type is a packed unconstrained array type,
+      --  and the explicit dereference is not in the context of an
+      --  attribute reference, then we must compute and set the actual
+      --  subtype, since it is needed by Gigi. The reason we exclude
+      --  the attribute case is that this is handled fine by Gigi, and
+      --  in fact we use such attributes to build the actual subtype.
+      --  We also exclude generated code (which builds actual subtypes
+      --  directly if they are needed).
+
+      if Is_Array_Type (Etype (N))
+        and then Is_Packed (Etype (N))
+        and then not Is_Constrained (Etype (N))
+        and then Nkind (Parent (N)) /= N_Attribute_Reference
+        and then Comes_From_Source (N)
+      then
+         Set_Etype (N, Get_Actual_Subtype (N));
+      end if;
+
+      --  Note: there is no Eval processing required for an explicit
+      --  deference, because the type is known to be an allocators, and
+      --  allocator expressions can never be static.
+
+   end Resolve_Explicit_Dereference;
+
+   -------------------------------
+   -- Resolve_Indexed_Component --
+   -------------------------------
+
+   procedure Resolve_Indexed_Component (N : Node_Id; Typ : Entity_Id) is
+      Name       : constant Node_Id := Prefix  (N);
+      Expr       : Node_Id;
+      Array_Type : Entity_Id := Empty; -- to prevent junk warning
+      Index      : Node_Id;
+
+   begin
+      if Is_Overloaded (Name) then
+
+         --  Use the context type to select the prefix that yields the
+         --  correct component type.
+
+         declare
+            I     : Interp_Index;
+            It    : Interp;
+            I1    : Interp_Index := 0;
+            P     : constant Node_Id := Prefix (N);
+            Found : Boolean := False;
+
+         begin
+            Get_First_Interp (P, I, It);
+
+            while Present (It.Typ) loop
+
+               if (Is_Array_Type (It.Typ)
+                     and then Covers (Typ, Component_Type (It.Typ)))
+                 or else (Is_Access_Type (It.Typ)
+                            and then Is_Array_Type (Designated_Type (It.Typ))
+                            and then Covers
+                              (Typ, Component_Type (Designated_Type (It.Typ))))
+               then
+                  if Found then
+                     It := Disambiguate (P, I1, I, Any_Type);
+
+                     if It = No_Interp then
+                        Error_Msg_N ("ambiguous prefix for indexing",  N);
+                        Set_Etype (N, Typ);
+                        return;
+
+                     else
+                        Found := True;
+                        Array_Type := It.Typ;
+                        I1 := I;
+                     end if;
+
+                  else
+                     Found := True;
+                     Array_Type := It.Typ;
+                     I1 := I;
+                  end if;
+               end if;
+
+               Get_Next_Interp (I, It);
+            end loop;
+         end;
+
+      else
+         Array_Type := Etype (Name);
+      end if;
+
+      Resolve (Name, Array_Type);
+      Array_Type := Get_Actual_Subtype_If_Available (Name);
+
+      --  If prefix is access type, dereference to get real array type.
+      --  Note: we do not apply an access check because the expander always
+      --  introduces an explicit dereference, and the check will happen there.
+
+      if Is_Access_Type (Array_Type) then
+         Array_Type := Designated_Type (Array_Type);
+      end if;
+
+      --  If name was overloaded, set component type correctly now.
+
+      Set_Etype (N, Component_Type (Array_Type));
+
+      Index := First_Index (Array_Type);
+      Expr  := First (Expressions (N));
+
+      --  The prefix may have resolved to a string literal, in which case
+      --  its etype has a special representation. This is only possible
+      --  currently if the prefix is a static concatenation, written in
+      --  functional notation.
+
+      if Ekind (Array_Type) = E_String_Literal_Subtype then
+         Resolve (Expr, Standard_Positive);
+
+      else
+         while Present (Index) and Present (Expr) loop
+            Resolve (Expr, Etype (Index));
+            Check_Unset_Reference (Expr);
+
+            if Is_Scalar_Type (Etype (Expr)) then
+               Apply_Scalar_Range_Check (Expr, Etype (Index));
+            else
+               Apply_Range_Check (Expr, Get_Actual_Subtype (Index));
+            end if;
+
+            Next_Index (Index);
+            Next (Expr);
+         end loop;
+      end if;
+
+      Eval_Indexed_Component (N);
+
+   end Resolve_Indexed_Component;
+
+   -----------------------------
+   -- Resolve_Integer_Literal --
+   -----------------------------
+
+   procedure Resolve_Integer_Literal (N : Node_Id; Typ : Entity_Id) is
+   begin
+      Set_Etype (N, Typ);
+      Eval_Integer_Literal (N);
+   end Resolve_Integer_Literal;
+
+   ---------------------------------
+   --  Resolve_Intrinsic_Operator --
+   ---------------------------------
+
+   procedure Resolve_Intrinsic_Operator  (N : Node_Id; Typ : Entity_Id) is
+      Op : Entity_Id;
+      Arg1 : Node_Id := Left_Opnd  (N);
+      Arg2 : Node_Id := Right_Opnd (N);
+
+   begin
+      Op := Entity (N);
+
+      while Scope (Op) /= Standard_Standard loop
+         Op := Homonym (Op);
+         pragma Assert (Present (Op));
+      end loop;
+
+      Set_Entity (N, Op);
+
+      if Typ /= Etype (Arg1) or else Typ = Etype (Arg2) then
+         Rewrite (Left_Opnd  (N), Convert_To (Typ, Arg1));
+         Rewrite (Right_Opnd (N), Convert_To (Typ, Arg2));
+
+         Analyze (Left_Opnd  (N));
+         Analyze (Right_Opnd (N));
+      end if;
+
+      Resolve_Arithmetic_Op (N, Typ);
+   end Resolve_Intrinsic_Operator;
+
+   ------------------------
+   -- Resolve_Logical_Op --
+   ------------------------
+
+   procedure Resolve_Logical_Op (N : Node_Id; Typ : Entity_Id) is
+      B_Typ : Entity_Id;
+
+   begin
+      --  Predefined operations on scalar types yield the base type. On
+      --  the other hand, logical operations on arrays yield the type of
+      --  the arguments (and the context).
+
+      if Is_Array_Type (Typ) then
+         B_Typ := Typ;
+      else
+         B_Typ := Base_Type (Typ);
+      end if;
+
+      --  The following test is required because the operands of the operation
+      --  may be literals, in which case the resulting type appears to be
+      --  compatible with a signed integer type, when in fact it is compatible
+      --  only with modular types. If the context itself is universal, the
+      --  operation is illegal.
+
+      if not Valid_Boolean_Arg (Typ) then
+         Error_Msg_N ("invalid context for logical operation", N);
+         Set_Etype (N, Any_Type);
+         return;
+
+      elsif Typ = Any_Modular then
+         Error_Msg_N
+           ("no modular type available in this context", N);
+         Set_Etype (N, Any_Type);
+         return;
+      end if;
+
+      Resolve (Left_Opnd (N), B_Typ);
+      Resolve (Right_Opnd (N), B_Typ);
+
+      Check_Unset_Reference (Left_Opnd  (N));
+      Check_Unset_Reference (Right_Opnd (N));
+
+      Set_Etype (N, B_Typ);
+      Generate_Operator_Reference (N);
+      Eval_Logical_Op (N);
+   end Resolve_Logical_Op;
+
+   ---------------------------
+   -- Resolve_Membership_Op --
+   ---------------------------
+
+   --  The context can only be a boolean type, and does not determine
+   --  the arguments. Arguments should be unambiguous, but the preference
+   --  rule for universal types applies.
+
+   procedure Resolve_Membership_Op (N : Node_Id; Typ : Entity_Id) is
+      L : constant Node_Id   := Left_Opnd (N);
+      R : constant Node_Id   := Right_Opnd (N);
+      T : Entity_Id;
+
+   begin
+      if L = Error or else R = Error then
+         return;
+      end if;
+
+      if not Is_Overloaded (R)
+        and then
+          (Etype (R) = Universal_Integer or else
+           Etype (R) = Universal_Real)
+        and then Is_Overloaded (L)
+      then
+         T := Etype (R);
+      else
+         T := Intersect_Types (L, R);
+      end if;
+
+      Resolve (L, T);
+      Check_Unset_Reference (L);
+
+      if Nkind (R) = N_Range
+        and then not Is_Scalar_Type (T)
+      then
+         Error_Msg_N ("scalar type required for range", R);
+      end if;
+
+      if Is_Entity_Name (R) then
+         Freeze_Expression (R);
+      else
+         Resolve (R, T);
+         Check_Unset_Reference (R);
+      end if;
+
+      Eval_Membership_Op (N);
+   end Resolve_Membership_Op;
+
+   ------------------
+   -- Resolve_Null --
+   ------------------
+
+   procedure Resolve_Null (N : Node_Id; Typ : Entity_Id) is
+   begin
+      --  For now allow circumvention of the restriction against
+      --  anonymous null access values via a debug switch to allow
+      --  for easier trasition.
+
+      if not Debug_Flag_J
+        and then Ekind (Typ) = E_Anonymous_Access_Type
+        and then Comes_From_Source (N)
+      then
+         --  In the common case of a call which uses an explicitly null
+         --  value for an access parameter, give specialized error msg
+
+         if Nkind (Parent (N)) = N_Procedure_Call_Statement
+              or else
+            Nkind (Parent (N)) = N_Function_Call
+         then
+            Error_Msg_N
+              ("null is not allowed as argument for an access parameter", N);
+
+         --  Standard message for all other cases (are there any?)
+
+         else
+            Error_Msg_N
+              ("null cannot be of an anonymous access type", N);
+         end if;
+      end if;
+
+      --  In a distributed context, null for a remote access to subprogram
+      --  may need to be replaced with a special record aggregate. In this
+      --  case, return after having done the transformation.
+
+      if (Ekind (Typ) = E_Record_Type
+           or else Is_Remote_Access_To_Subprogram_Type (Typ))
+        and then Remote_AST_Null_Value (N, Typ)
+      then
+         return;
+      end if;
+
+      --  The null literal takes its type from the context.
+
+      Set_Etype (N, Typ);
+   end Resolve_Null;
+
+   -----------------------
+   -- Resolve_Op_Concat --
+   -----------------------
+
+   procedure Resolve_Op_Concat (N : Node_Id; Typ : Entity_Id) is
+      Btyp : constant Entity_Id := Base_Type (Typ);
+      Op1  : constant Node_Id := Left_Opnd (N);
+      Op2  : constant Node_Id := Right_Opnd (N);
+
+      procedure Resolve_Concatenation_Arg (Arg : Node_Id; Is_Comp : Boolean);
+      --  Internal procedure to resolve one operand of concatenation operator.
+      --  The operand is either of the array type or of the component type.
+      --  If the operand is an aggregate, and the component type is composite,
+      --  this is ambiguous if component type has aggregates.
+
+      -------------------------------
+      -- Resolve_Concatenation_Arg --
+      -------------------------------
+
+      procedure Resolve_Concatenation_Arg (Arg : Node_Id; Is_Comp : Boolean) is
+      begin
+         if In_Instance then
+            if Is_Comp
+              or else (not Is_Overloaded (Arg)
+               and then Etype (Arg) /= Any_Composite
+               and then Covers (Component_Type (Typ), Etype (Arg)))
+            then
+               Resolve (Arg, Component_Type (Typ));
+            else
+               Resolve (Arg, Btyp);
+            end if;
+
+         elsif Has_Compatible_Type (Arg, Component_Type (Typ)) then
+
+            if Nkind (Arg) = N_Aggregate
+              and then Is_Composite_Type (Component_Type (Typ))
+            then
+               if Is_Private_Type (Component_Type (Typ)) then
+                  Resolve (Arg, Btyp);
+
+               else
+                  Error_Msg_N ("ambiguous aggregate must be qualified", Arg);
+                  Set_Etype (Arg, Any_Type);
+               end if;
+
+            else
+               if Is_Overloaded (Arg)
+                 and then Has_Compatible_Type (Arg, Typ)
+                 and then Etype (Arg) /= Any_Type
+               then
+                  Error_Msg_N ("ambiguous operand for concatenation!", Arg);
+
+                  declare
+                     I  : Interp_Index;
+                     It : Interp;
+
+                  begin
+                     Get_First_Interp (Arg, I, It);
+
+                     while Present (It.Nam) loop
+
+                        if Base_Type (Etype (It.Nam)) = Base_Type (Typ)
+                          or else Base_Type (Etype (It.Nam)) =
+                            Base_Type (Component_Type (Typ))
+                        then
+                           Error_Msg_Sloc := Sloc (It.Nam);
+                           Error_Msg_N ("\possible interpretation#", Arg);
+                        end if;
+
+                        Get_Next_Interp (I, It);
+                     end loop;
+                  end;
+               end if;
+
+               Resolve (Arg, Component_Type (Typ));
+
+               if Arg = Left_Opnd (N) then
+                  Set_Is_Component_Left_Opnd (N);
+               else
+                  Set_Is_Component_Right_Opnd (N);
+               end if;
+            end if;
+
+         else
+            Resolve (Arg, Btyp);
+         end if;
+
+         Check_Unset_Reference (Arg);
+      end Resolve_Concatenation_Arg;
+
+   --  Start of processing for Resolve_Op_Concat
+
+   begin
+      Set_Etype (N, Btyp);
+
+      if Is_Limited_Composite (Btyp) then
+         Error_Msg_N ("concatenation not available for limited array", N);
+      end if;
+
+      --  If the operands are themselves concatenations, resolve them as
+      --  such directly. This removes several layers of recursion and allows
+      --  GNAT to handle larger multiple concatenations.
+
+      if Nkind (Op1) = N_Op_Concat
+        and then not Is_Array_Type (Component_Type (Typ))
+        and then Entity (Op1) = Entity (N)
+      then
+         Resolve_Op_Concat (Op1, Typ);
+      else
+         Resolve_Concatenation_Arg
+           (Op1,  Is_Component_Left_Opnd  (N));
+      end if;
+
+      if Nkind (Op2) = N_Op_Concat
+        and then not Is_Array_Type (Component_Type (Typ))
+        and then Entity (Op2) = Entity (N)
+      then
+         Resolve_Op_Concat (Op2, Typ);
+      else
+         Resolve_Concatenation_Arg
+           (Op2, Is_Component_Right_Opnd  (N));
+      end if;
+
+      Generate_Operator_Reference (N);
+
+      if Is_String_Type (Typ) then
+         Eval_Concatenation (N);
+      end if;
+
+      --  If this is not a static concatenation, but the result is a
+      --  string type (and not an array of strings) insure that static
+      --  string operands have their subtypes properly constructed.
+
+      if Nkind (N) /= N_String_Literal
+        and then Is_Character_Type (Component_Type (Typ))
+      then
+         Set_String_Literal_Subtype (Op1, Typ);
+         Set_String_Literal_Subtype (Op2, Typ);
+      end if;
+   end Resolve_Op_Concat;
+
+   ----------------------
+   -- Resolve_Op_Expon --
+   ----------------------
+
+   procedure Resolve_Op_Expon (N : Node_Id; Typ : Entity_Id) is
+      B_Typ : constant Entity_Id := Base_Type (Typ);
+
+   begin
+      --  Catch attempts to do fixed-point exponentation with universal
+      --  operands, which is a case where the illegality is not caught
+      --  during normal operator analysis.
+
+      if Is_Fixed_Point_Type (Typ) and then Comes_From_Source (N) then
+         Error_Msg_N ("exponentiation not available for fixed point", N);
+         return;
+      end if;
+
+      if Etype (Left_Opnd (N)) = Universal_Integer
+        or else Etype (Left_Opnd (N)) = Universal_Real
+      then
+         Check_For_Visible_Operator (N, B_Typ);
+      end if;
+
+      --  We do the resolution using the base type, because intermediate values
+      --  in expressions always are of the base type, not a subtype of it.
+
+      Resolve (Left_Opnd (N), B_Typ);
+      Resolve (Right_Opnd (N), Standard_Integer);
+
+      Check_Unset_Reference (Left_Opnd  (N));
+      Check_Unset_Reference (Right_Opnd (N));
+
+      Set_Etype (N, B_Typ);
+      Generate_Operator_Reference (N);
+      Eval_Op_Expon (N);
+
+      --  Set overflow checking bit. Much cleverer code needed here eventually
+      --  and perhaps the Resolve routines should be separated for the various
+      --  arithmetic operations, since they will need different processing. ???
+
+      if Nkind (N) in N_Op then
+         if not Overflow_Checks_Suppressed (Etype (N)) then
+            Set_Do_Overflow_Check (N, True);
+         end if;
+      end if;
+
+   end Resolve_Op_Expon;
+
+   --------------------
+   -- Resolve_Op_Not --
+   --------------------
+
+   procedure Resolve_Op_Not (N : Node_Id; Typ : Entity_Id) is
+      B_Typ : Entity_Id;
+
+      function Parent_Is_Boolean return Boolean;
+      --  This function determines if the parent node is a boolean operator
+      --  or operation (comparison op, membership test, or short circuit form)
+      --  and the not in question is the left operand of this operation.
+      --  Note that if the not is in parens, then false is returned.
+
+      function Parent_Is_Boolean return Boolean is
+      begin
+         if Paren_Count (N) /= 0 then
+            return False;
+
+         else
+            case Nkind (Parent (N)) is
+               when N_Op_And   |
+                    N_Op_Eq    |
+                    N_Op_Ge    |
+                    N_Op_Gt    |
+                    N_Op_Le    |
+                    N_Op_Lt    |
+                    N_Op_Ne    |
+                    N_Op_Or    |
+                    N_Op_Xor   |
+                    N_In       |
+                    N_Not_In   |
+                    N_And_Then |
+                    N_Or_Else =>
+
+                  return Left_Opnd (Parent (N)) = N;
+
+               when others =>
+                  return False;
+            end case;
+         end if;
+      end Parent_Is_Boolean;
+
+   --  Start of processing for Resolve_Op_Not
+
+   begin
+      --  Predefined operations on scalar types yield the base type. On
+      --  the other hand, logical operations on arrays yield the type of
+      --  the arguments (and the context).
+
+      if Is_Array_Type (Typ) then
+         B_Typ := Typ;
+      else
+         B_Typ := Base_Type (Typ);
+      end if;
+
+      if not Valid_Boolean_Arg (Typ) then
+         Error_Msg_N ("invalid operand type for operator&", N);
+         Set_Etype (N, Any_Type);
+         return;
+
+      elsif (Typ = Universal_Integer
+        or else Typ = Any_Modular)
+      then
+         if Parent_Is_Boolean then
+            Error_Msg_N
+              ("operand of not must be enclosed in parentheses",
+               Right_Opnd (N));
+         else
+            Error_Msg_N
+              ("no modular type available in this context", N);
+         end if;
+
+         Set_Etype (N, Any_Type);
+         return;
+
+      else
+         if not Is_Boolean_Type (Typ)
+           and then Parent_Is_Boolean
+         then
+            Error_Msg_N ("?not expression should be parenthesized here", N);
+         end if;
+
+         Resolve (Right_Opnd (N), B_Typ);
+         Check_Unset_Reference (Right_Opnd (N));
+         Set_Etype (N, B_Typ);
+         Generate_Operator_Reference (N);
+         Eval_Op_Not (N);
+      end if;
+   end Resolve_Op_Not;
+
+   -----------------------------
+   -- Resolve_Operator_Symbol --
+   -----------------------------
+
+   --  Nothing to be done, all resolved already
+
+   procedure Resolve_Operator_Symbol (N : Node_Id; Typ : Entity_Id) is
+   begin
+      null;
+   end Resolve_Operator_Symbol;
+
+   ----------------------------------
+   -- Resolve_Qualified_Expression --
+   ----------------------------------
+
+   procedure Resolve_Qualified_Expression (N : Node_Id; Typ : Entity_Id) is
+      Target_Typ : constant Entity_Id := Entity (Subtype_Mark (N));
+      Expr       : constant Node_Id   := Expression (N);
+
+   begin
+      Resolve (Expr, Target_Typ);
+
+      --  A qualified expression requires an exact match of the type,
+      --  class-wide matching is not allowed.
+
+      if Is_Class_Wide_Type (Target_Typ)
+        and then Base_Type (Etype (Expr)) /= Base_Type (Target_Typ)
+      then
+         Wrong_Type (Expr, Target_Typ);
+      end if;
+
+      --  If the target type is unconstrained, then we reset the type of
+      --  the result from the type of the expression. For other cases, the
+      --  actual subtype of the expression is the target type.
+
+      if Is_Composite_Type (Target_Typ)
+        and then not Is_Constrained (Target_Typ)
+      then
+         Set_Etype (N, Etype (Expr));
+      end if;
+
+      Eval_Qualified_Expression (N);
+   end Resolve_Qualified_Expression;
+
+   -------------------
+   -- Resolve_Range --
+   -------------------
+
+   procedure Resolve_Range (N : Node_Id; Typ : Entity_Id) is
+      L : constant Node_Id := Low_Bound (N);
+      H : constant Node_Id := High_Bound (N);
+
+   begin
+      Set_Etype (N, Typ);
+      Resolve (L, Typ);
+      Resolve (H, Typ);
+
+      Check_Unset_Reference (L);
+      Check_Unset_Reference (H);
+
+      --  We have to check the bounds for being within the base range as
+      --  required for a non-static context. Normally this is automatic
+      --  and done as part of evaluating expressions, but the N_Range
+      --  node is an exception, since in GNAT we consider this node to
+      --  be a subexpression, even though in Ada it is not. The circuit
+      --  in Sem_Eval could check for this, but that would put the test
+      --  on the main evaluation path for expressions.
+
+      Check_Non_Static_Context (L);
+      Check_Non_Static_Context (H);
+
+   end Resolve_Range;
+
+   --------------------------
+   -- Resolve_Real_Literal --
+   --------------------------
+
+   procedure Resolve_Real_Literal (N : Node_Id; Typ : Entity_Id) is
+      Actual_Typ : constant Entity_Id := Etype (N);
+
+   begin
+      --  Special processing for fixed-point literals to make sure that the
+      --  value is an exact multiple of small where this is required. We
+      --  skip this for the universal real case, and also for generic types.
+
+      if Is_Fixed_Point_Type (Typ)
+        and then Typ /= Universal_Fixed
+        and then Typ /= Any_Fixed
+        and then not Is_Generic_Type (Typ)
+      then
+         declare
+            Val   : constant Ureal := Realval (N);
+            Cintr : constant Ureal := Val / Small_Value (Typ);
+            Cint  : constant Uint  := UR_Trunc (Cintr);
+            Den   : constant Uint  := Norm_Den (Cintr);
+            Stat  : Boolean;
+
+         begin
+            --  Case of literal is not an exact multiple of the Small
+
+            if Den /= 1 then
+
+               --  For a source program literal for a decimal fixed-point
+               --  type, this is statically illegal (RM 4.9(36)).
+
+               if Is_Decimal_Fixed_Point_Type (Typ)
+                 and then Actual_Typ = Universal_Real
+                 and then Comes_From_Source (N)
+               then
+                  Error_Msg_N ("value has extraneous low order digits", N);
+               end if;
+
+               --  Replace literal by a value that is the exact representation
+               --  of a value of the type, i.e. a multiple of the small value,
+               --  by truncation, since Machine_Rounds is false for all GNAT
+               --  fixed-point types (RM 4.9(38)).
+
+               Stat := Is_Static_Expression (N);
+               Rewrite (N,
+                 Make_Real_Literal (Sloc (N),
+                   Realval => Small_Value (Typ) * Cint));
+
+               Set_Is_Static_Expression (N, Stat);
+            end if;
+
+            --  In all cases, set the corresponding integer field
+
+            Set_Corresponding_Integer_Value (N, Cint);
+         end;
+      end if;
+
+      --  Now replace the actual type by the expected type as usual
+
+      Set_Etype (N, Typ);
+      Eval_Real_Literal (N);
+   end Resolve_Real_Literal;
+
+   -----------------------
+   -- Resolve_Reference --
+   -----------------------
+
+   procedure Resolve_Reference (N : Node_Id; Typ : Entity_Id) is
+      P : constant Node_Id := Prefix (N);
+
+   begin
+      --  Replace general access with specific type
+
+      if Ekind (Etype (N)) = E_Allocator_Type then
+         Set_Etype (N, Base_Type (Typ));
+      end if;
+
+      Resolve (P, Designated_Type (Etype (N)));
+
+      --  If we are taking the reference of a volatile entity, then treat
+      --  it as a potential modification of this entity. This is much too
+      --  conservative, but is neccessary because remove side effects can
+      --  result in transformations of normal assignments into reference
+      --  sequences that otherwise fail to notice the modification.
+
+      if Is_Entity_Name (P) and then Is_Volatile (Entity (P)) then
+         Note_Possible_Modification (P);
+      end if;
+   end Resolve_Reference;
+
+   --------------------------------
+   -- Resolve_Selected_Component --
+   --------------------------------
+
+   procedure Resolve_Selected_Component (N : Node_Id; Typ : Entity_Id) is
+      Comp  : Entity_Id;
+      Comp1 : Entity_Id        := Empty; -- prevent junk warning
+      P     : constant Node_Id := Prefix  (N);
+      S     : constant Node_Id := Selector_Name (N);
+      T     : Entity_Id        := Etype (P);
+      I     : Interp_Index;
+      I1    : Interp_Index := 0; -- prevent junk warning
+      It    : Interp;
+      It1   : Interp;
+      Found : Boolean;
+
+   begin
+      if Is_Overloaded (P) then
+
+         --  Use the context type to select the prefix that has a selector
+         --  of the correct name and type.
+
+         Found := False;
+         Get_First_Interp (P, I, It);
+
+         Search : while Present (It.Typ) loop
+            if Is_Access_Type (It.Typ) then
+               T := Designated_Type (It.Typ);
+            else
+               T := It.Typ;
+            end if;
+
+            if Is_Record_Type (T) then
+               Comp := First_Entity (T);
+
+               while Present (Comp) loop
+
+                  if Chars (Comp) = Chars (S)
+                    and then Covers (Etype (Comp), Typ)
+                  then
+                     if not Found then
+                        Found := True;
+                        I1  := I;
+                        It1 := It;
+                        Comp1 := Comp;
+
+                     else
+                        It := Disambiguate (P, I1, I, Any_Type);
+
+                        if It = No_Interp then
+                           Error_Msg_N
+                             ("ambiguous prefix for selected component",  N);
+                           Set_Etype (N, Typ);
+                           return;
+
+                        else
+                           It1 := It;
+
+                           if Scope (Comp1) /= It1.Typ then
+
+                              --  Resolution chooses the new interpretation.
+                              --  Find the component with the right name.
+
+                              Comp1 := First_Entity (It1.Typ);
+
+                              while Present (Comp1)
+                                and then Chars (Comp1) /= Chars (S)
+                              loop
+                                 Comp1 := Next_Entity (Comp1);
+                              end loop;
+                           end if;
+
+                           exit Search;
+                        end if;
+                     end if;
+                  end if;
+
+                  Comp := Next_Entity (Comp);
+               end loop;
+
+            end if;
+
+            Get_Next_Interp (I, It);
+
+         end loop Search;
+
+         Resolve (P, It1.Typ);
+         Set_Etype (N, Typ);
+         Set_Entity (S, Comp1);
+
+      else
+         --  Resolve prefix with its type.
+
+         Resolve (P, T);
+      end if;
+
+      --  Deal with access type case
+
+      if Is_Access_Type (Etype (P)) then
+         Apply_Access_Check (N);
+         T := Designated_Type (Etype (P));
+      else
+         T := Etype (P);
+      end if;
+
+      if Has_Discriminants (T)
+        and then Present (Original_Record_Component (Entity (S)))
+        and then Ekind (Original_Record_Component (Entity (S))) = E_Component
+        and then Present (Discriminant_Checking_Func
+                           (Original_Record_Component (Entity (S))))
+        and then not Discriminant_Checks_Suppressed (T)
+      then
+         Set_Do_Discriminant_Check (N);
+      end if;
+
+      if Ekind (Entity (S)) = E_Void then
+         Error_Msg_N ("premature use of component", S);
+      end if;
+
+      --  If the prefix is a record conversion, this may be a renamed
+      --  discriminant whose bounds differ from those of the original
+      --  one, so we must ensure that a range check is performed.
+
+      if Nkind (P) = N_Type_Conversion
+        and then Ekind (Entity (S)) = E_Discriminant
+      then
+         Set_Etype (N, Base_Type (Typ));
+      end if;
+
+      --  Note: No Eval processing is required, because the prefix is of a
+      --  record type, or protected type, and neither can possibly be static.
+
+   end Resolve_Selected_Component;
+
+   -------------------
+   -- Resolve_Shift --
+   -------------------
+
+   procedure Resolve_Shift (N : Node_Id; Typ : Entity_Id) is
+      B_Typ : constant Entity_Id := Base_Type (Typ);
+      L     : constant Node_Id   := Left_Opnd  (N);
+      R     : constant Node_Id   := Right_Opnd (N);
+
+   begin
+      --  We do the resolution using the base type, because intermediate values
+      --  in expressions always are of the base type, not a subtype of it.
+
+      Resolve (L, B_Typ);
+      Resolve (R, Standard_Natural);
+
+      Check_Unset_Reference (L);
+      Check_Unset_Reference (R);
+
+      Set_Etype (N, B_Typ);
+      Generate_Operator_Reference (N);
+      Eval_Shift (N);
+   end Resolve_Shift;
+
+   ---------------------------
+   -- Resolve_Short_Circuit --
+   ---------------------------
+
+   procedure Resolve_Short_Circuit (N : Node_Id; Typ : Entity_Id) is
+      B_Typ : constant Entity_Id := Base_Type (Typ);
+      L     : constant Node_Id   := Left_Opnd  (N);
+      R     : constant Node_Id   := Right_Opnd (N);
+
+   begin
+      Resolve (L, B_Typ);
+      Resolve (R, B_Typ);
+
+      Check_Unset_Reference (L);
+      Check_Unset_Reference (R);
+
+      Set_Etype (N, B_Typ);
+      Eval_Short_Circuit (N);
+   end Resolve_Short_Circuit;
+
+   -------------------
+   -- Resolve_Slice --
+   -------------------
+
+   procedure Resolve_Slice (N : Node_Id; Typ : Entity_Id) is
+      Name       : constant Node_Id := Prefix (N);
+      Drange     : constant Node_Id := Discrete_Range (N);
+      Array_Type : Entity_Id        := Empty;
+      Index      : Node_Id;
+
+   begin
+      if Is_Overloaded (Name) then
+
+         --  Use the context type to select the prefix that yields the
+         --  correct array type.
+
+         declare
+            I      : Interp_Index;
+            I1     : Interp_Index := 0;
+            It     : Interp;
+            P      : constant Node_Id := Prefix (N);
+            Found  : Boolean := False;
+
+         begin
+            Get_First_Interp (P, I,  It);
+
+            while Present (It.Typ) loop
+
+               if (Is_Array_Type (It.Typ)
+                    and then Covers (Typ,  It.Typ))
+                 or else (Is_Access_Type (It.Typ)
+                           and then Is_Array_Type (Designated_Type (It.Typ))
+                           and then Covers (Typ, Designated_Type (It.Typ)))
+               then
+                  if Found then
+                     It := Disambiguate (P, I1, I, Any_Type);
+
+                     if It = No_Interp then
+                        Error_Msg_N ("ambiguous prefix for slicing",  N);
+                        Set_Etype (N, Typ);
+                        return;
+                     else
+                        Found := True;
+                        Array_Type := It.Typ;
+                        I1 := I;
+                     end if;
+                  else
+                     Found := True;
+                     Array_Type := It.Typ;
+                     I1 := I;
+                  end if;
+               end if;
+
+               Get_Next_Interp (I, It);
+            end loop;
+         end;
+
+      else
+         Array_Type := Etype (Name);
+      end if;
+
+      Resolve (Name, Array_Type);
+
+      if Is_Access_Type (Array_Type) then
+         Apply_Access_Check (N);
+         Array_Type := Designated_Type (Array_Type);
+
+      elsif Is_Entity_Name (Name)
+        or else (Nkind (Name) = N_Function_Call
+                  and then not Is_Constrained (Etype (Name)))
+      then
+         Array_Type := Get_Actual_Subtype (Name);
+      end if;
+
+      --  If name was overloaded, set slice type correctly now
+
+      Set_Etype (N, Array_Type);
+
+      --  If the range is specified by a subtype mark, no resolution
+      --  is necessary.
+
+      if not Is_Entity_Name (Drange) then
+         Index := First_Index (Array_Type);
+         Resolve (Drange, Base_Type (Etype (Index)));
+
+         if Nkind (Drange) = N_Range then
+            Apply_Range_Check (Drange, Etype (Index));
+         end if;
+      end if;
+
+      Set_Slice_Subtype (N);
+      Eval_Slice (N);
+
+   end Resolve_Slice;
+
+   ----------------------------
+   -- Resolve_String_Literal --
+   ----------------------------
+
+   procedure Resolve_String_Literal (N : Node_Id; Typ : Entity_Id) is
+      C_Typ      : constant Entity_Id  := Component_Type (Typ);
+      R_Typ      : constant Entity_Id  := Root_Type (C_Typ);
+      Loc        : constant Source_Ptr := Sloc (N);
+      Str        : constant String_Id  := Strval (N);
+      Strlen     : constant Nat        := String_Length (Str);
+      Subtype_Id : Entity_Id;
+      Need_Check : Boolean;
+
+   begin
+      --  For a string appearing in a concatenation, defer creation of the
+      --  string_literal_subtype until the end of the resolution of the
+      --  concatenation, because the literal may be constant-folded away.
+      --  This is a useful optimization for long concatenation expressions.
+
+      --  If the string is an aggregate built for a single character  (which
+      --  happens in a non-static context) or a is null string to which special
+      --  checks may apply, we build the subtype. Wide strings must also get
+      --  a string subtype if they come from a one character aggregate. Strings
+      --  generated by attributes might be static, but it is often hard to
+      --  determine whether the enclosing context is static, so we generate
+      --  subtypes for them as well, thus losing some rarer optimizations ???
+      --  Same for strings that come from a static conversion.
+
+      Need_Check :=
+        (Strlen = 0 and then Typ /= Standard_String)
+          or else Nkind (Parent (N)) /= N_Op_Concat
+          or else (N /= Left_Opnd (Parent (N))
+                    and then N /= Right_Opnd (Parent (N)))
+          or else (Typ = Standard_Wide_String
+                    and then Nkind (Original_Node (N)) /= N_String_Literal);
+
+      --  If the resolving type is itself a string literal subtype, we
+      --  can just reuse it, since there is no point in creating another.
+
+      if Ekind (Typ) = E_String_Literal_Subtype then
+         Subtype_Id := Typ;
+
+      elsif Nkind (Parent (N)) = N_Op_Concat
+        and then not Need_Check
+        and then Nkind (Original_Node (N)) /= N_Character_Literal
+        and then Nkind (Original_Node (N)) /= N_Attribute_Reference
+        and then Nkind (Original_Node (N)) /= N_Qualified_Expression
+        and then Nkind (Original_Node (N)) /= N_Type_Conversion
+      then
+         Subtype_Id := Typ;
+
+      --  Otherwise we must create a string literal subtype. Note that the
+      --  whole idea of string literal subtypes is simply to avoid the need
+      --  for building a full fledged array subtype for each literal.
+      else
+         Set_String_Literal_Subtype (N, Typ);
+         Subtype_Id := Etype (N);
+      end if;
+
+      if Nkind (Parent (N)) /= N_Op_Concat
+        or else Need_Check
+      then
+         Set_Etype (N, Subtype_Id);
+         Eval_String_Literal (N);
+      end if;
+
+      if Is_Limited_Composite (Typ)
+        or else Is_Private_Composite (Typ)
+      then
+         Error_Msg_N ("string literal not available for private array", N);
+         Set_Etype (N, Any_Type);
+         return;
+      end if;
+
+      --  The validity of a null string has been checked in the
+      --  call to  Eval_String_Literal.
+
+      if Strlen = 0 then
+         return;
+
+      --  Always accept string literal with component type Any_Character,
+      --  which occurs in error situations and in comparisons of literals,
+      --  both of which should accept all literals.
+
+      elsif R_Typ = Any_Character then
+         return;
+
+      --  If the type is bit-packed, then we always tranform the string
+      --  literal into a full fledged aggregate.
+
+      elsif Is_Bit_Packed_Array (Typ) then
+         null;
+
+      --  Deal with cases of Wide_String and String
+
+      else
+         --  For Standard.Wide_String, or any other type whose component
+         --  type is Standard.Wide_Character, we know that all the
+         --  characters in the string must be acceptable, since the parser
+         --  accepted the characters as valid character literals.
+
+         if R_Typ = Standard_Wide_Character then
+            null;
+
+         --  For the case of Standard.String, or any other type whose
+         --  component type is Standard.Character, we must make sure that
+         --  there are no wide characters in the string, i.e. that it is
+         --  entirely composed of characters in range of type String.
+
+         --  If the string literal is the result of a static concatenation,
+         --  the test has already been performed on the components, and need
+         --  not be repeated.
+
+         elsif R_Typ = Standard_Character
+           and then Nkind (Original_Node (N)) /= N_Op_Concat
+         then
+            for J in 1 .. Strlen loop
+               if not In_Character_Range (Get_String_Char (Str, J)) then
+
+                  --  If we are out of range, post error. This is one of the
+                  --  very few places that we place the flag in the middle of
+                  --  a token, right under the offending wide character.
+
+                  Error_Msg
+                    ("literal out of range of type Character",
+                     Source_Ptr (Int (Loc) + J));
+                  return;
+               end if;
+            end loop;
+
+         --  If the root type is not a standard character, then we will convert
+         --  the string into an aggregate and will let the aggregate code do
+         --  the checking.
+
+         else
+            null;
+
+         end if;
+
+         --  See if the component type of the array corresponding to the
+         --  string has compile time known bounds. If yes we can directly
+         --  check whether the evaluation of the string will raise constraint
+         --  error. Otherwise we need to transform the string literal into
+         --  the corresponding character aggregate and let the aggregate
+         --  code do the checking.
+
+         if R_Typ = Standard_Wide_Character
+           or else R_Typ = Standard_Character
+         then
+            --  Check for the case of full range, where we are definitely OK
+
+            if Component_Type (Typ) = Base_Type (Component_Type (Typ)) then
+               return;
+            end if;
+
+            --  Here the range is not the complete base type range, so check
+
+            declare
+               Comp_Typ_Lo : constant Node_Id :=
+                               Type_Low_Bound (Component_Type (Typ));
+               Comp_Typ_Hi : constant Node_Id :=
+                               Type_High_Bound (Component_Type (Typ));
+
+               Char_Val : Uint;
+
+            begin
+               if Compile_Time_Known_Value (Comp_Typ_Lo)
+                 and then Compile_Time_Known_Value (Comp_Typ_Hi)
+               then
+                  for J in 1 .. Strlen loop
+                     Char_Val := UI_From_Int (Int (Get_String_Char (Str, J)));
+
+                     if Char_Val < Expr_Value (Comp_Typ_Lo)
+                       or else Char_Val > Expr_Value (Comp_Typ_Hi)
+                     then
+                        Apply_Compile_Time_Constraint_Error
+                          (N, "character out of range?",
+                           Loc => Source_Ptr (Int (Loc) + J));
+                     end if;
+                  end loop;
+
+                  return;
+               end if;
+            end;
+         end if;
+      end if;
+
+      --  If we got here we meed to transform the string literal into the
+      --  equivalent qualified positional array aggregate. This is rather
+      --  heavy artillery for this situation, but it is hard work to avoid.
+
+      declare
+         Lits : List_Id    := New_List;
+         P    : Source_Ptr := Loc + 1;
+         C    : Char_Code;
+
+      begin
+         --  Build the character literals, we give them source locations
+         --  that correspond to the string positions, which is a bit tricky
+         --  given the possible presence of wide character escape sequences.
+
+         for J in 1 .. Strlen loop
+            C := Get_String_Char (Str, J);
+            Set_Character_Literal_Name (C);
+
+            Append_To (Lits,
+              Make_Character_Literal (P, Name_Find, C));
+
+            if In_Character_Range (C) then
+               P := P + 1;
+
+            --  Should we have a call to Skip_Wide here ???
+            --  ???     else
+            --             Skip_Wide (P);
+
+            end if;
+         end loop;
+
+         Rewrite (N,
+           Make_Qualified_Expression (Loc,
+             Subtype_Mark => New_Reference_To (Typ, Loc),
+             Expression   =>
+               Make_Aggregate (Loc, Expressions => Lits)));
+
+         Analyze_And_Resolve (N, Typ);
+      end;
+   end Resolve_String_Literal;
+
+   -----------------------------
+   -- Resolve_Subprogram_Info --
+   -----------------------------
+
+   procedure Resolve_Subprogram_Info (N : Node_Id; Typ : Entity_Id) is
+   begin
+      Set_Etype (N, Typ);
+   end Resolve_Subprogram_Info;
+
+   -----------------------------
+   -- Resolve_Type_Conversion --
+   -----------------------------
+
+   procedure Resolve_Type_Conversion (N : Node_Id; Typ : Entity_Id) is
+      Target_Type : constant Entity_Id := Etype (N);
+      Conv_OK     : constant Boolean   := Conversion_OK (N);
+      Operand     : Node_Id;
+      Opnd_Type   : Entity_Id;
+      Rop         : Node_Id;
+
+   begin
+      Operand := Expression (N);
+
+      if not Conv_OK
+        and then not Valid_Conversion (N, Target_Type, Operand)
+      then
+         return;
+      end if;
+
+      if Etype (Operand) = Any_Fixed then
+
+         --  Mixed-mode operation involving a literal. Context must be a fixed
+         --  type which is applied to the literal subsequently.
+
+         if Is_Fixed_Point_Type (Typ) then
+            Set_Etype (Operand, Universal_Real);
+
+         elsif Is_Numeric_Type (Typ)
+           and then (Nkind (Operand) = N_Op_Multiply
+                      or else Nkind (Operand) = N_Op_Divide)
+           and then (Etype (Right_Opnd (Operand)) = Universal_Real
+                     or else Etype (Left_Opnd (Operand)) = Universal_Real)
+         then
+            if Unique_Fixed_Point_Type (N) = Any_Type then
+               return;    --  expression is ambiguous.
+            else
+               Set_Etype (Operand, Standard_Duration);
+            end if;
+
+            if Etype (Right_Opnd (Operand)) = Universal_Real then
+               Rop := New_Copy_Tree (Right_Opnd (Operand));
+            else
+               Rop := New_Copy_Tree (Left_Opnd (Operand));
+            end if;
+
+            Resolve (Rop, Standard_Long_Long_Float);
+
+            if Realval (Rop) /= Ureal_0
+              and then abs (Realval (Rop)) < Delta_Value (Standard_Duration)
+            then
+               Error_Msg_N ("universal real operand can only be interpreted?",
+                 Rop);
+               Error_Msg_N ("\as Duration, and will lose precision?", Rop);
+            end if;
+
+         else
+            Error_Msg_N ("invalid context for mixed mode operation", N);
+            Set_Etype (Operand, Any_Type);
+            return;
+         end if;
+      end if;
+
+      Opnd_Type := Etype (Operand);
+      Resolve (Operand, Opnd_Type);
+
+      --  Note: we do the Eval_Type_Conversion call before applying the
+      --  required checks for a subtype conversion. This is important,
+      --  since both are prepared under certain circumstances to change
+      --  the type conversion to a constraint error node, but in the case
+      --  of Eval_Type_Conversion this may reflect an illegality in the
+      --  static case, and we would miss the illegality (getting only a
+      --  warning message), if we applied the type conversion checks first.
+
+      Eval_Type_Conversion (N);
+
+      --  If after evaluation, we still have a type conversion, then we
+      --  may need to apply checks required for a subtype conversion.
+
+      --  Skip these type conversion checks if universal fixed operands
+      --  operands involved, since range checks are handled separately for
+      --  these cases (in the appropriate Expand routines in unit Exp_Fixd).
+
+      if Nkind (N) = N_Type_Conversion
+        and then not Is_Generic_Type (Root_Type (Target_Type))
+        and then Target_Type /= Universal_Fixed
+        and then Opnd_Type /= Universal_Fixed
+      then
+         Apply_Type_Conversion_Checks (N);
+      end if;
+
+      --  Issue warning for conversion of simple object to its own type
+
+      if Warn_On_Redundant_Constructs
+        and then Comes_From_Source (N)
+        and then Nkind (N) = N_Type_Conversion
+        and then Is_Entity_Name (Expression (N))
+        and then Etype (Entity (Expression (N))) = Target_Type
+      then
+         Error_Msg_NE
+           ("?useless conversion, & has this type",
+            N, Entity (Expression (N)));
+      end if;
+   end Resolve_Type_Conversion;
+
+   ----------------------
+   -- Resolve_Unary_Op --
+   ----------------------
+
+   procedure Resolve_Unary_Op (N : Node_Id; Typ : Entity_Id) is
+      B_Typ : Entity_Id := Base_Type (Typ);
+      R     : constant Node_Id := Right_Opnd (N);
+
+   begin
+      --  Generate warning for expressions like -5 mod 3
+
+      if Paren_Count (N) = 0
+        and then Nkind (N) = N_Op_Minus
+        and then Nkind (Right_Opnd (N)) = N_Op_Mod
+      then
+         Error_Msg_N
+           ("?unary minus expression should be parenthesized here", N);
+      end if;
+
+      if Etype (R) = Universal_Integer
+        or else Etype (R) = Universal_Real
+      then
+         Check_For_Visible_Operator (N, B_Typ);
+      end if;
+
+      Set_Etype (N, B_Typ);
+      Resolve (R, B_Typ);
+      Check_Unset_Reference (R);
+      Generate_Operator_Reference (N);
+      Eval_Unary_Op (N);
+
+      --  Set overflow checking bit. Much cleverer code needed here eventually
+      --  and perhaps the Resolve routines should be separated for the various
+      --  arithmetic operations, since they will need different processing ???
+
+      if Nkind (N) in N_Op then
+         if not Overflow_Checks_Suppressed (Etype (N)) then
+            Set_Do_Overflow_Check (N, True);
+         end if;
+      end if;
+
+   end Resolve_Unary_Op;
+
+   ----------------------------------
+   -- Resolve_Unchecked_Expression --
+   ----------------------------------
+
+   procedure Resolve_Unchecked_Expression
+     (N   : Node_Id;
+      Typ : Entity_Id)
+   is
+   begin
+      Resolve (Expression (N), Typ, Suppress => All_Checks);
+      Set_Etype (N, Typ);
+   end Resolve_Unchecked_Expression;
+
+   ---------------------------------------
+   -- Resolve_Unchecked_Type_Conversion --
+   ---------------------------------------
+
+   procedure Resolve_Unchecked_Type_Conversion
+     (N   : Node_Id;
+      Typ : Entity_Id)
+   is
+      Operand   : constant Node_Id   := Expression (N);
+      Opnd_Type : constant Entity_Id := Etype (Operand);
+
+   begin
+      --  Resolve operand using its own type.
+
+      Resolve (Operand, Opnd_Type);
+      Eval_Unchecked_Conversion (N);
+
+   end Resolve_Unchecked_Type_Conversion;
+
+   ------------------------------
+   -- Rewrite_Operator_As_Call --
+   ------------------------------
+
+   procedure Rewrite_Operator_As_Call (N : Node_Id; Nam : Entity_Id) is
+      Loc     :  Source_Ptr := Sloc (N);
+      Actuals :  List_Id := New_List;
+      New_N   : Node_Id;
+
+   begin
+      if Nkind (N) in  N_Binary_Op then
+         Append (Left_Opnd (N), Actuals);
+      end if;
+
+      Append (Right_Opnd (N), Actuals);
+
+      New_N :=
+        Make_Function_Call (Sloc => Loc,
+          Name => New_Occurrence_Of (Nam, Loc),
+          Parameter_Associations => Actuals);
+
+      Preserve_Comes_From_Source (New_N, N);
+      Preserve_Comes_From_Source (Name (New_N), N);
+      Rewrite (N, New_N);
+      Set_Etype (N, Etype (Nam));
+   end Rewrite_Operator_As_Call;
+
+   ------------------------------
+   -- Rewrite_Renamed_Operator --
+   ------------------------------
+
+   procedure Rewrite_Renamed_Operator (N : Node_Id; Op : Entity_Id) is
+      Nam       : constant Name_Id := Chars (Op);
+      Is_Binary : constant Boolean := Nkind (N) in N_Binary_Op;
+      Op_Node   : Node_Id;
+
+   begin
+      if Chars (N) /= Nam then
+
+         --  Rewrite the operator node using the real operator, not its
+         --  renaming.
+
+         Op_Node := New_Node (Operator_Kind (Nam, Is_Binary), Sloc (N));
+         Set_Chars      (Op_Node, Nam);
+         Set_Etype      (Op_Node, Etype (N));
+         Set_Entity     (Op_Node, Op);
+         Set_Right_Opnd (Op_Node, Right_Opnd (N));
+
+         Generate_Reference (Op, N);
+
+         if Is_Binary then
+            Set_Left_Opnd  (Op_Node, Left_Opnd  (N));
+         end if;
+
+         Rewrite (N, Op_Node);
+      end if;
+   end Rewrite_Renamed_Operator;
+
+   -----------------------
+   -- Set_Slice_Subtype --
+   -----------------------
+
+   --  Build an implicit subtype declaration to represent the type delivered
+   --  by the slice. This is an abbreviated version of an array subtype. We
+   --  define an index subtype for the slice,  using either the subtype name
+   --  or the discrete range of the slice. To be consistent with index usage
+   --  elsewhere, we create a list header to hold the single index. This list
+   --  is not otherwise attached to the syntax tree.
+
+   procedure Set_Slice_Subtype (N : Node_Id) is
+      Loc           : constant Source_Ptr := Sloc (N);
+      Index         : Node_Id;
+      Index_List    : List_Id := New_List;
+      Index_Subtype : Entity_Id;
+      Index_Type    : Entity_Id;
+      Slice_Subtype : Entity_Id;
+      Drange        : constant Node_Id := Discrete_Range (N);
+
+   begin
+      if Is_Entity_Name (Drange) then
+         Index_Subtype := Entity (Drange);
+
+      else
+         --  We force the evaluation of a range. This is definitely needed in
+         --  the renamed case, and seems safer to do unconditionally. Note in
+         --  any case that since we will create and insert an Itype referring
+         --  to this range, we must make sure any side effect removal actions
+         --  are inserted before the Itype definition.
+
+         if Nkind (Drange) = N_Range then
+            Force_Evaluation (Low_Bound (Drange));
+            Force_Evaluation (High_Bound (Drange));
+         end if;
+
+         Index_Type := Base_Type (Etype (Drange));
+
+         Index_Subtype := Create_Itype (Subtype_Kind (Ekind (Index_Type)), N);
+
+         Set_Scalar_Range (Index_Subtype, Drange);
+         Set_Etype        (Index_Subtype, Index_Type);
+         Set_Size_Info    (Index_Subtype, Index_Type);
+         Set_RM_Size      (Index_Subtype, RM_Size (Index_Type));
+      end if;
+
+      Slice_Subtype := Create_Itype (E_Array_Subtype, N);
+
+      Index := New_Occurrence_Of (Index_Subtype, Loc);
+      Set_Etype (Index, Index_Subtype);
+      Append (Index, Index_List);
+
+      Set_Component_Type (Slice_Subtype, Component_Type (Etype (N)));
+      Set_First_Index    (Slice_Subtype, Index);
+      Set_Etype          (Slice_Subtype, Base_Type (Etype (N)));
+      Set_Is_Constrained (Slice_Subtype, True);
+      Init_Size_Align    (Slice_Subtype);
+
+      Check_Compile_Time_Size (Slice_Subtype);
+
+      --  The Etype of the existing Slice node is reset to this slice
+      --  subtype. Its bounds are obtained from its first index.
+
+      Set_Etype (N, Slice_Subtype);
+
+      --  In the packed case, this must be immediately frozen
+
+      --  Couldn't we always freeze here??? and if we did, then the above
+      --  call to Check_Compile_Time_Size could be eliminated, which would
+      --  be nice, because then that routine could be made private to Freeze.
+
+      if Is_Packed (Slice_Subtype) and not In_Default_Expression then
+         Freeze_Itype (Slice_Subtype, N);
+      end if;
+
+   end Set_Slice_Subtype;
+
+   --------------------------------
+   -- Set_String_Literal_Subtype --
+   --------------------------------
+
+   procedure Set_String_Literal_Subtype (N : Node_Id; Typ : Entity_Id) is
+      Subtype_Id : Entity_Id;
+
+   begin
+      if Nkind (N) /= N_String_Literal then
+         return;
+
+      else
+         Subtype_Id := Create_Itype (E_String_Literal_Subtype, N);
+      end if;
+
+      Set_Component_Type           (Subtype_Id, Component_Type (Typ));
+      Set_String_Literal_Length    (Subtype_Id,
+        UI_From_Int (String_Length (Strval (N))));
+      Set_Etype                    (Subtype_Id, Base_Type (Typ));
+      Set_Is_Constrained           (Subtype_Id);
+
+      --  The low bound is set from the low bound of the corresponding
+      --  index type. Note that we do not store the high bound in the
+      --  string literal subtype, but it can be deduced if necssary
+      --  from the length and the low bound.
+
+      Set_String_Literal_Low_Bound
+        (Subtype_Id, Type_Low_Bound (Etype (First_Index (Typ))));
+
+      Set_Etype (N, Subtype_Id);
+   end Set_String_Literal_Subtype;
+
+   -----------------------------
+   -- Unique_Fixed_Point_Type --
+   -----------------------------
+
+   function Unique_Fixed_Point_Type (N : Node_Id) return Entity_Id is
+      T1   : Entity_Id := Empty;
+      T2   : Entity_Id;
+      Item : Node_Id;
+      Scop : Entity_Id;
+
+      procedure Fixed_Point_Error;
+      --  If true ambiguity, give details.
+
+      procedure Fixed_Point_Error is
+      begin
+         Error_Msg_N ("ambiguous universal_fixed_expression", N);
+         Error_Msg_NE ("\possible interpretation as}", N, T1);
+         Error_Msg_NE ("\possible interpretation as}", N, T2);
+      end Fixed_Point_Error;
+
+   begin
+      --  The operations on Duration are visible, so Duration is always a
+      --  possible interpretation.
+
+      T1 := Standard_Duration;
+
+      Scop := Current_Scope;
+
+      --  Look for fixed-point types in enclosing scopes.
+
+      while Scop /= Standard_Standard loop
+         T2 := First_Entity (Scop);
+
+         while Present (T2) loop
+            if Is_Fixed_Point_Type (T2)
+              and then Current_Entity (T2) = T2
+              and then Scope (Base_Type (T2)) = Scop
+            then
+               if Present (T1) then
+                  Fixed_Point_Error;
+                  return Any_Type;
+               else
+                  T1 := T2;
+               end if;
+            end if;
+
+            Next_Entity (T2);
+         end loop;
+
+         Scop := Scope (Scop);
+      end loop;
+
+      --  Look for visible fixed type declarations in the context.
+
+      Item := First (Context_Items (Cunit (Current_Sem_Unit)));
+
+      while Present (Item) loop
+
+         if Nkind (Item) = N_With_Clause then
+            Scop := Entity (Name (Item));
+            T2 := First_Entity (Scop);
+
+            while Present (T2) loop
+               if Is_Fixed_Point_Type (T2)
+                 and then Scope (Base_Type (T2)) = Scop
+                 and then (Is_Potentially_Use_Visible (T2)
+                             or else In_Use (T2))
+               then
+                  if Present (T1) then
+                     Fixed_Point_Error;
+                     return Any_Type;
+                  else
+                     T1 := T2;
+                  end if;
+               end if;
+
+               Next_Entity (T2);
+            end loop;
+         end if;
+
+         Next (Item);
+      end loop;
+
+      if Nkind (N) = N_Real_Literal then
+         Error_Msg_NE ("real literal interpreted as }?", N, T1);
+
+      else
+         Error_Msg_NE ("universal_fixed expression interpreted as }?", N, T1);
+      end if;
+
+      return T1;
+   end Unique_Fixed_Point_Type;
+
+   ----------------------
+   -- Valid_Conversion --
+   ----------------------
+
+   function Valid_Conversion
+     (N       : Node_Id;
+      Target  : Entity_Id;
+      Operand : Node_Id)
+      return    Boolean
+   is
+      Target_Type : Entity_Id := Base_Type (Target);
+      Opnd_Type   : Entity_Id := Etype (Operand);
+
+      function Conversion_Check
+        (Valid : Boolean;
+         Msg   : String)
+         return  Boolean;
+      --  Little routine to post Msg if Valid is False, returns Valid value
+
+      function Valid_Tagged_Conversion
+        (Target_Type : Entity_Id;
+         Opnd_Type   : Entity_Id)
+         return        Boolean;
+      --  Specifically test for validity of tagged conversions
+
+      ----------------------
+      -- Conversion_Check --
+      ----------------------
+
+      function Conversion_Check
+        (Valid : Boolean;
+         Msg   : String)
+         return  Boolean
+      is
+      begin
+         if not Valid then
+            Error_Msg_N (Msg, Operand);
+         end if;
+
+         return Valid;
+      end Conversion_Check;
+
+      -----------------------------
+      -- Valid_Tagged_Conversion --
+      -----------------------------
+
+      function Valid_Tagged_Conversion
+        (Target_Type : Entity_Id;
+         Opnd_Type   : Entity_Id)
+         return        Boolean
+      is
+      begin
+         --  Upward conversions are allowed (RM 4.6(22)).
+
+         if Covers (Target_Type, Opnd_Type)
+           or else Is_Ancestor (Target_Type, Opnd_Type)
+         then
+            return True;
+
+         --  Downward conversion are allowed if the operand is
+         --  is class-wide (RM 4.6(23)).
+
+         elsif Is_Class_Wide_Type (Opnd_Type)
+              and then Covers (Opnd_Type, Target_Type)
+         then
+            return True;
+
+         elsif Covers (Opnd_Type, Target_Type)
+           or else Is_Ancestor (Opnd_Type, Target_Type)
+         then
+            return
+              Conversion_Check (False,
+                "downward conversion of tagged objects not allowed");
+         else
+            Error_Msg_NE
+              ("invalid tagged conversion, not compatible with}",
+               N, First_Subtype (Opnd_Type));
+            return False;
+         end if;
+      end Valid_Tagged_Conversion;
+
+   --  Start of processing for Valid_Conversion
+
+   begin
+      Check_Parameterless_Call (Operand);
+
+      if Is_Overloaded (Operand) then
+         declare
+            I   : Interp_Index;
+            I1  : Interp_Index;
+            It  : Interp;
+            It1 : Interp;
+            N1  : Entity_Id;
+
+         begin
+            --  Remove procedure calls, which syntactically cannot appear
+            --  in this context, but which cannot be removed by type checking,
+            --  because the context does not impose a type.
+
+            Get_First_Interp (Operand, I, It);
+
+            while Present (It.Typ) loop
+
+               if It.Typ = Standard_Void_Type then
+                  Remove_Interp (I);
+               end if;
+
+               Get_Next_Interp (I, It);
+            end loop;
+
+            Get_First_Interp (Operand, I, It);
+            I1  := I;
+            It1 := It;
+
+            if No (It.Typ) then
+               Error_Msg_N ("illegal operand in conversion", Operand);
+               return False;
+            end if;
+
+            Get_Next_Interp (I, It);
+
+            if Present (It.Typ) then
+               N1  := It1.Nam;
+               It1 :=  Disambiguate (Operand, I1, I, Any_Type);
+
+               if It1 = No_Interp then
+                  Error_Msg_N ("ambiguous operand in conversion", Operand);
+
+                  Error_Msg_Sloc := Sloc (It.Nam);
+                  Error_Msg_N ("possible interpretation#!", Operand);
+
+                  Error_Msg_Sloc := Sloc (N1);
+                  Error_Msg_N ("possible interpretation#!", Operand);
+
+                  return False;
+               end if;
+            end if;
+
+            Set_Etype (Operand, It1.Typ);
+            Opnd_Type := It1.Typ;
+         end;
+      end if;
+
+      if Chars (Current_Scope) = Name_Unchecked_Conversion then
+
+         --  This check is dubious, what if there were a user defined
+         --  scope whose name was Unchecked_Conversion ???
+
+         return True;
+
+      elsif Is_Numeric_Type (Target_Type)  then
+         if Opnd_Type = Universal_Fixed then
+            return True;
+         else
+            return Conversion_Check (Is_Numeric_Type (Opnd_Type),
+                             "illegal operand for numeric conversion");
+         end if;
+
+      elsif Is_Array_Type (Target_Type) then
+         if not Is_Array_Type (Opnd_Type)
+           or else Opnd_Type = Any_Composite
+           or else Opnd_Type = Any_String
+         then
+            Error_Msg_N
+              ("illegal operand for array conversion", Operand);
+            return False;
+
+         elsif Number_Dimensions (Target_Type) /=
+           Number_Dimensions (Opnd_Type)
+         then
+            Error_Msg_N
+              ("incompatible number of dimensions for conversion", Operand);
+            return False;
+
+         else
+            declare
+               Target_Index      : Node_Id := First_Index (Target_Type);
+               Opnd_Index        : Node_Id := First_Index (Opnd_Type);
+
+               Target_Index_Type : Entity_Id;
+               Opnd_Index_Type   : Entity_Id;
+
+               Target_Comp_Type  : Entity_Id := Component_Type (Target_Type);
+               Opnd_Comp_Type    : Entity_Id := Component_Type (Opnd_Type);
+
+            begin
+               while Present (Target_Index) and then Present (Opnd_Index) loop
+                  Target_Index_Type := Etype (Target_Index);
+                  Opnd_Index_Type   := Etype (Opnd_Index);
+
+                  if not (Is_Integer_Type (Target_Index_Type)
+                          and then Is_Integer_Type (Opnd_Index_Type))
+                    and then (Root_Type (Target_Index_Type)
+                              /= Root_Type (Opnd_Index_Type))
+                  then
+                     Error_Msg_N
+                       ("incompatible index types for array conversion",
+                        Operand);
+                     return False;
+                  end if;
+
+                  Next_Index (Target_Index);
+                  Next_Index (Opnd_Index);
+               end loop;
+
+               if Base_Type (Target_Comp_Type) /=
+                 Base_Type (Opnd_Comp_Type)
+               then
+                  Error_Msg_N
+                    ("incompatible component types for array conversion",
+                     Operand);
+                  return False;
+
+               elsif
+                  Is_Constrained (Target_Comp_Type)
+                    /= Is_Constrained (Opnd_Comp_Type)
+                  or else not Subtypes_Statically_Match
+                                (Target_Comp_Type, Opnd_Comp_Type)
+               then
+                  Error_Msg_N
+                    ("component subtypes must statically match", Operand);
+                  return False;
+
+               end if;
+            end;
+         end if;
+
+         return True;
+
+      elsif (Ekind (Target_Type) = E_General_Access_Type
+        or else Ekind (Target_Type) = E_Anonymous_Access_Type)
+          and then
+            Conversion_Check
+              (Is_Access_Type (Opnd_Type)
+                 and then Ekind (Opnd_Type) /=
+                   E_Access_Subprogram_Type
+                 and then Ekind (Opnd_Type) /=
+                   E_Access_Protected_Subprogram_Type,
+               "must be an access-to-object type")
+      then
+         if Is_Access_Constant (Opnd_Type)
+           and then not Is_Access_Constant (Target_Type)
+         then
+            Error_Msg_N
+              ("access-to-constant operand type not allowed", Operand);
+            return False;
+         end if;
+
+         --  Check the static accessibility rule of 4.6(17). Note that
+         --  the check is not enforced when within an instance body, since
+         --  the RM requires such cases to be caught at run time.
+
+         if Ekind (Target_Type) /= E_Anonymous_Access_Type then
+            if Type_Access_Level (Opnd_Type)
+              > Type_Access_Level (Target_Type)
+            then
+               --  In an instance, this is a run-time check, but one we
+               --  know will fail, so generate an appropriate warning.
+               --  The raise will be generated by Expand_N_Type_Conversion.
+
+               if In_Instance_Body then
+                  Error_Msg_N
+                    ("?cannot convert local pointer to non-local access type",
+                     Operand);
+                  Error_Msg_N
+                    ("?Program_Error will be raised at run time", Operand);
+
+               else
+                  Error_Msg_N
+                    ("cannot convert local pointer to non-local access type",
+                     Operand);
+                  return False;
+               end if;
+
+            elsif Ekind (Opnd_Type) = E_Anonymous_Access_Type then
+
+               --  When the operand is a selected access discriminant
+               --  the check needs to be made against the level of the
+               --  object denoted by the prefix of the selected name.
+               --  (Object_Access_Level handles checking the prefix
+               --  of the operand for this case.)
+
+               if Nkind (Operand) = N_Selected_Component
+                 and then Object_Access_Level (Operand)
+                   > Type_Access_Level (Target_Type)
+               then
+                  --  In an instance, this is a run-time check, but one we
+                  --  know will fail, so generate an appropriate warning.
+                  --  The raise will be generated by Expand_N_Type_Conversion.
+
+                  if In_Instance_Body then
+                     Error_Msg_N
+                       ("?cannot convert access discriminant to non-local" &
+                        " access type", Operand);
+                     Error_Msg_N
+                       ("?Program_Error will be raised at run time", Operand);
+
+                  else
+                     Error_Msg_N
+                       ("cannot convert access discriminant to non-local" &
+                        " access type", Operand);
+                     return False;
+                  end if;
+               end if;
+
+               --  The case of a reference to an access discriminant
+               --  from within a type declaration (which will appear
+               --  as a discriminal) is always illegal because the
+               --  level of the discriminant is considered to be
+               --  deeper than any (namable) access type.
+
+               if Is_Entity_Name (Operand)
+                 and then (Ekind (Entity (Operand)) = E_In_Parameter
+                            or else Ekind (Entity (Operand)) = E_Constant)
+                 and then Present (Discriminal_Link (Entity (Operand)))
+               then
+                  Error_Msg_N
+                    ("discriminant has deeper accessibility level than target",
+                     Operand);
+                  return False;
+               end if;
+            end if;
+         end if;
+
+         declare
+            Target : constant Entity_Id := Designated_Type (Target_Type);
+            Opnd   : constant Entity_Id := Designated_Type (Opnd_Type);
+
+         begin
+            if Is_Tagged_Type (Target) then
+               return Valid_Tagged_Conversion (Target, Opnd);
+
+            else
+               if Base_Type (Target) /= Base_Type (Opnd) then
+                  Error_Msg_NE
+                    ("target designated type not compatible with }",
+                     N, Base_Type (Opnd));
+                  return False;
+
+               elsif not Subtypes_Statically_Match (Target, Opnd)
+                  and then (not Has_Discriminants (Target)
+                             or else Is_Constrained (Target))
+               then
+                  Error_Msg_NE
+                    ("target designated subtype not compatible with }",
+                     N, Opnd);
+                  return False;
+
+               else
+                  return True;
+               end if;
+            end if;
+         end;
+
+      elsif Ekind (Target_Type) = E_Access_Subprogram_Type
+        and then Conversion_Check
+                   (Ekind (Base_Type (Opnd_Type)) = E_Access_Subprogram_Type,
+                    "illegal operand for access subprogram conversion")
+      then
+         --  Check that the designated types are subtype conformant
+
+         if not Subtype_Conformant (Designated_Type (Opnd_Type),
+                                    Designated_Type (Target_Type))
+         then
+            Error_Msg_N
+              ("operand type is not subtype conformant with target type",
+               Operand);
+         end if;
+
+         --  Check the static accessibility rule of 4.6(20)
+
+         if Type_Access_Level (Opnd_Type) >
+            Type_Access_Level (Target_Type)
+         then
+            Error_Msg_N
+              ("operand type has deeper accessibility level than target",
+               Operand);
+
+         --  Check that if the operand type is declared in a generic body,
+         --  then the target type must be declared within that same body
+         --  (enforces last sentence of 4.6(20)).
+
+         elsif Present (Enclosing_Generic_Body (Opnd_Type)) then
+            declare
+               O_Gen : constant Node_Id :=
+                         Enclosing_Generic_Body (Opnd_Type);
+
+               T_Gen : Node_Id :=
+                         Enclosing_Generic_Body (Target_Type);
+
+            begin
+               while Present (T_Gen) and then T_Gen /= O_Gen loop
+                  T_Gen := Enclosing_Generic_Body (T_Gen);
+               end loop;
+
+               if T_Gen /= O_Gen then
+                  Error_Msg_N
+                    ("target type must be declared in same generic body"
+                     & " as operand type", N);
+               end if;
+            end;
+         end if;
+
+         return True;
+
+      elsif Is_Remote_Access_To_Subprogram_Type (Target_Type)
+        and then Is_Remote_Access_To_Subprogram_Type (Opnd_Type)
+      then
+         --  It is valid to convert from one RAS type to another provided
+         --  that their specification statically match.
+
+         Check_Subtype_Conformant
+           (New_Id  =>
+              Designated_Type (Corresponding_Remote_Type (Target_Type)),
+            Old_Id  =>
+              Designated_Type (Corresponding_Remote_Type (Opnd_Type)),
+            Err_Loc =>
+              N);
+         return True;
+
+      elsif Is_Tagged_Type (Target_Type) then
+         return Valid_Tagged_Conversion (Target_Type, Opnd_Type);
+
+      --  Types derived from the same root type are convertible.
+
+      elsif Root_Type (Target_Type) = Root_Type (Opnd_Type) then
+         return True;
+
+      --  In an instance, there may be inconsistent views of the same
+      --  type, or types derived from the same type.
+
+      elsif In_Instance
+        and then Underlying_Type (Target_Type) = Underlying_Type (Opnd_Type)
+      then
+         return True;
+
+      --  Special check for common access type error case
+
+      elsif Ekind (Target_Type) = E_Access_Type
+         and then Is_Access_Type (Opnd_Type)
+      then
+         Error_Msg_N ("target type must be general access type!", N);
+         Error_Msg_NE ("add ALL to }!", N, Target_Type);
+
+         return False;
+
+      else
+         Error_Msg_NE ("invalid conversion, not compatible with }",
+           N, Opnd_Type);
+
+         return False;
+      end if;
+   end Valid_Conversion;
+
+end Sem_Res;
diff --git a/gcc/ada/sem_res.ads b/gcc/ada/sem_res.ads
new file mode 100644
index 00000000000..5c926540c3b
--- /dev/null
+++ b/gcc/ada/sem_res.ads
@@ -0,0 +1,118 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              S E M _ R E S                               --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.19 $
+--                                                                          --
+--          Copyright (C) 1992-1999 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). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  Resolution processing for all subexpression nodes. Note that the separate
+--  package Sem_Aggr contains the actual resolution routines for aggregates,
+--  which are separated off since aggregate processing is complex.
+
+with Snames; use Snames;
+with Types;  use Types;
+
+package Sem_Res is
+
+   --  As described in Sem_Ch4, the type resolution proceeds in two phases.
+   --  The first phase is a bottom up pass that is achieved during the
+   --  recursive traversal performed by the Analyze procedures. This phase
+   --  determines unambiguous types, and collects sets of possible types
+   --  where the interpretation is potentially ambiguous.
+
+   --  On completing this bottom up pass, which corresponds to a call to
+   --  Analyze on a complete context, the Resolve routine is called which
+   --  performs a top down resolution with recursive calls to itself to
+   --  resolve operands.
+
+   --  Since in practice a lot of semantic analysis has to be postponed until
+   --  types are known (e.g. static folding, setting of suppress flags), the
+   --  Resolve routines also complete the semantic analyze, and also call the
+   --  expander for possibly expansion of the completely type resolved node.
+
+   procedure Resolve (N : Node_Id; Typ : Entity_Id);
+   procedure Resolve (N : Node_Id; Typ : Entity_Id; Suppress : Check_Id);
+   --  Top level type-checking procedure, called in a complete context. The
+   --  construct N, which is a subexpression, has already been analyzed, and
+   --  is required to be of type Typ given the analysis of the context (which
+   --  uses the information gathered on the bottom up phase in Analyze). The
+   --  resolve routines do various other processing, e.g. static evaluation.
+   --  If a Suppress argument is present, then the resolution is done with the
+   --  specified check suppressed (can be All_Checks to suppress all checks).
+
+   procedure Resolve_Discrete_Subtype_Indication
+     (N   : Node_Id;
+      Typ : Entity_Id);
+   --  Resolve subtype indications in choices (case statements and
+   --  aggregates) and in index constraints. Note that the resulting Etype
+   --  of the subtype indication node is set to the Etype of the contained
+   --  range (i.e. an Itype is not constructed for the actual subtype).
+
+   procedure Resolve_Entry (Entry_Name : Node_Id);
+   --  Find name of entry being called, and resolve prefix of name with its
+   --  own type. For now we assume that the prefix cannot be overloaded and
+   --  the name of the entry plays no role in the resolution.
+
+   procedure Analyze_And_Resolve (N : Node_Id);
+   procedure Analyze_And_Resolve (N : Node_Id; Typ : Entity_Id);
+   procedure Analyze_And_Resolve
+     (N        : Node_Id;
+      Typ      : Entity_Id;
+      Suppress : Check_Id);
+   procedure Analyze_And_Resolve
+     (N        : Node_Id;
+      Suppress : Check_Id);
+   --  These routines combine the effect of Analyze and Resolve. If a Suppress
+   --  argument is present, then the analysis is done with the specified check
+   --  suppressed (can be All_Checks to suppress all checks). These checks are
+   --  suppressed for both the analysis and resolution. If the type argument
+   --  is not present, then the Etype of the expression after the Analyze
+   --  call is used for the Resolve.
+
+   procedure Check_Parameterless_Call (N : Node_Id);
+   --  Several forms of names can denote calls to entities without para-
+   --  meters. The context determines whether the name denotes the entity
+   --  or a call to it. When it is a call, the node must be rebuilt
+   --  accordingly (deprocedured, in A68 terms) and renalyzed to obtain
+   --  possible interpretations.
+   --
+   --  The name may be that of an overloadable construct, or it can be an
+   --  explicit dereference of a prefix that denotes an access to subprogram.
+   --  In that case, we want to convert the name into a call only if the
+   --  context requires the return type of the subprogram.  Finally, a
+   --  parameterless protected subprogram appears as a selected component.
+   --
+   --  The parameter T is the Typ for the corresponding resolve call.
+
+   procedure Pre_Analyze_And_Resolve (N : Node_Id; T : Entity_Id);
+   --  Performs a pre-analysis of expression node N. During pre-analysis
+   --  N is analyzed and then resolved against type T, but no expansion
+   --  is carried out for N or its children. For more info on pre-analysis
+   --  read the spec of Sem.
+
+   procedure Pre_Analyze_And_Resolve (N : Node_Id);
+   --  Same, but use type of node because context does not impose a single
+   --  type.
+
+end Sem_Res;
diff --git a/gcc/ada/sem_smem.adb b/gcc/ada/sem_smem.adb
new file mode 100644
index 00000000000..5b0c29c73f6
--- /dev/null
+++ b/gcc/ada/sem_smem.adb
@@ -0,0 +1,150 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             S E M _ S M E M                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.5 $
+--                                                                          --
+--          Copyright (C) 1998-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 Atree;  use Atree;
+with Einfo;  use Einfo;
+with Errout; use Errout;
+with Namet;  use Namet;
+with Sinfo;  use Sinfo;
+with Snames; use Snames;
+
+package body Sem_Smem is
+
+   function Contains_Access_Type (T : Entity_Id) return Boolean;
+   --  This function determines if type T is an access type, or contains
+   --  a component (array, record, protected type cases) that contains
+   --  an access type (recursively defined in the appropriate manner).
+
+   ----------------------
+   -- Check_Shared_Var --
+   ----------------------
+
+   procedure Check_Shared_Var
+     (Id : Entity_Id;
+      T  : Entity_Id;
+      N  : Node_Id)
+   is
+   begin
+      --  We cannot tolerate aliased variables, because they might be
+      --  modified via an aliased pointer, and we could not detect that
+      --  this was happening (to update the corresponding shared memory
+      --  file), so we must disallow all use of Aliased
+
+      if Aliased_Present (N) then
+         Error_Msg_N
+           ("aliased variables " &
+            "not supported in Shared_Passive partitions",
+            N);
+
+      --  We can't support access types at all, since they are local
+      --  pointers that cannot in any simple way be transmitted to other
+      --  partitions.
+
+      elsif Is_Access_Type (T) then
+         Error_Msg_N
+           ("access type variables " &
+            "not supported in Shared_Passive partitions",
+            Id);
+
+      --  We cannot tolerate types that contain access types, same reasons
+
+      elsif Contains_Access_Type (T) then
+         Error_Msg_N
+           ("types containing access components " &
+            "not supported in Shared_Passive partitions",
+            Id);
+
+      --  Currently we do not support unconstrained record types, since we
+      --  use 'Write to write out values. This could probably be special
+      --  cased and handled in the future if necessary.
+
+      elsif Is_Record_Type (T)
+        and then not Is_Constrained (T)
+      then
+         Error_Msg_N
+           ("unconstrained variant records " &
+            "not supported in Shared_Passive partitions",
+            Id);
+      end if;
+   end Check_Shared_Var;
+
+   --------------------------
+   -- Contains_Access_Type --
+   --------------------------
+
+   function Contains_Access_Type (T : Entity_Id) return Boolean is
+      C : Entity_Id;
+
+   begin
+      if Is_Access_Type (T) then
+         return True;
+
+      elsif Is_Array_Type (T) then
+         return Contains_Access_Type (Component_Type (T));
+
+      elsif Is_Record_Type (T) then
+         if Has_Discriminants (T) then
+            C := First_Discriminant (T);
+            while Present (C) loop
+               if Comes_From_Source (C) then
+                  return True;
+               else
+                  C := Next_Discriminant (C);
+               end if;
+            end loop;
+         end if;
+
+         C := First_Component (T);
+         while Present (C) loop
+
+            --  For components, ignore internal components other than _Parent
+
+            if Comes_From_Source (T)
+              and then
+                (Chars (C) = Name_uParent
+                  or else
+                 not Is_Internal_Name (Chars (C)))
+              and then Contains_Access_Type (Etype (C))
+            then
+               return True;
+            else
+               C := Next_Component (C);
+            end if;
+         end loop;
+
+         return False;
+
+      elsif Is_Protected_Type (T) then
+         return Contains_Access_Type (Corresponding_Record_Type (T));
+
+      else
+         return False;
+      end if;
+   end Contains_Access_Type;
+
+end Sem_Smem;
diff --git a/gcc/ada/sem_smem.ads b/gcc/ada/sem_smem.ads
new file mode 100644
index 00000000000..a164659310e
--- /dev/null
+++ b/gcc/ada/sem_smem.ads
@@ -0,0 +1,43 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             S E M _ S M E M                              --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.2 $                              --
+--                                                                          --
+--           Copyright (C) 1998-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). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  This package contains routines involved in processing of shared memory
+--  variables, i.e. variables declared in shared passive partitions.
+
+with Types; use Types;
+package Sem_Smem is
+
+   procedure Check_Shared_Var
+     (Id : Entity_Id;
+      T  : Entity_Id;
+      N  : Node_Id);
+   --  This routine checks that the object declaration, N, for identifier,
+   --  Id, of type, T, is valid, i.e. that it does not violate restrictions
+   --  on the kind of variables we support in shared passive partitions.
+
+end Sem_Smem;
diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb
new file mode 100644
index 00000000000..9c335e6c4c6
--- /dev/null
+++ b/gcc/ada/sem_type.adb
@@ -0,0 +1,2028 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             S E M _ T Y P E                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.198 $
+--                                                                          --
+--          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 Debug;    use Debug;
+with Einfo;    use Einfo;
+with Errout;   use Errout;
+with Lib;      use Lib;
+with Opt;      use Opt;
+with Output;   use Output;
+with Sem;      use Sem;
+with Sem_Ch6;  use Sem_Ch6;
+with Sem_Ch8;  use Sem_Ch8;
+with Sem_Util; use Sem_Util;
+with Stand;    use Stand;
+with Sinfo;    use Sinfo;
+with Snames;   use Snames;
+with Uintp;    use Uintp;
+
+package body Sem_Type is
+
+   -------------------------------------
+   -- Handling of Overload Resolution --
+   -------------------------------------
+
+   --  Overload resolution uses two passes over the syntax tree of a complete
+   --  context. In the first, bottom-up pass, the types of actuals in calls
+   --  are used to resolve possibly overloaded subprogram and operator names.
+   --  In the second top-down pass, the type of the context (for example the
+   --  condition in a while statement) is used to resolve a possibly ambiguous
+   --  call, and the unique subprogram name in turn imposes a specific context
+   --  on each of its actuals.
+
+   --  Most expressions are in fact unambiguous, and the bottom-up pass is
+   --  sufficient  to resolve most everything. To simplify the common case,
+   --  names and expressions carry a flag Is_Overloaded to indicate whether
+   --  they have more than one interpretation. If the flag is off, then each
+   --  name has already a unique meaning and type, and the bottom-up pass is
+   --  sufficient (and much simpler).
+
+   --------------------------
+   -- Operator Overloading --
+   --------------------------
+
+   --  The visibility of operators is handled differently from that of
+   --  other entities. We do not introduce explicit versions of primitive
+   --  operators for each type definition. As a result, there is only one
+   --  entity corresponding to predefined addition on all numeric types, etc.
+   --  The back-end resolves predefined operators according to their type.
+   --  The visibility of primitive operations then reduces to the visibility
+   --  of the resulting type:  (a + b) is a legal interpretation of some
+   --  primitive operator + if the type of the result (which must also be
+   --  the type of a and b) is directly visible (i.e. either immediately
+   --  visible or use-visible.)
+
+   --  User-defined operators are treated like other functions, but the
+   --  visibility of these user-defined operations must be special-cased
+   --  to determine whether they hide or are hidden by predefined operators.
+   --  The form P."+" (x, y) requires additional handling.
+   --
+   --  Concatenation is treated more conventionally: for every one-dimensional
+   --  array type we introduce a explicit concatenation operator. This is
+   --  necessary to handle the case of (element & element => array) which
+   --  cannot be handled conveniently if there is no explicit instance of
+   --  resulting type of the operation.
+
+   -----------------------
+   -- Local Subprograms --
+   -----------------------
+
+   procedure All_Overloads;
+   pragma Warnings (Off, All_Overloads);
+   --  Debugging procedure: list full contents of Overloads table.
+
+   function Universal_Interpretation (Opnd : Node_Id) return Entity_Id;
+   --  Yields universal_Integer or Universal_Real if this is a candidate.
+
+   function Specific_Type (T1, T2 : Entity_Id) return Entity_Id;
+   --  If T1 and T2 are compatible, return  the one that is not
+   --  universal or is not a "class" type (any_character,  etc).
+
+   --------------------
+   -- Add_One_Interp --
+   --------------------
+
+   procedure Add_One_Interp
+     (N         : Node_Id;
+      E         : Entity_Id;
+      T         : Entity_Id;
+      Opnd_Type : Entity_Id := Empty)
+   is
+      Vis_Type : Entity_Id;
+
+      procedure Add_Entry (Name :  Entity_Id; Typ : Entity_Id);
+      --  Add one interpretation to node. Node is already known to be
+      --  overloaded. Add new interpretation if not hidden by previous
+      --  one, and remove previous one if hidden by new one.
+
+      function Is_Universal_Operation (Op : Entity_Id) return Boolean;
+      --  True if the entity is a predefined operator and the operands have
+      --  a universal Interpretation.
+
+      ---------------
+      -- Add_Entry --
+      ---------------
+
+      procedure Add_Entry (Name :  Entity_Id; Typ : Entity_Id) is
+         Index : Interp_Index;
+         It    : Interp;
+
+      begin
+         Get_First_Interp (N, Index, It);
+
+         while Present (It.Nam) loop
+
+            --  A user-defined subprogram hides another declared at an outer
+            --  level, or one that is use-visible. So return if previous
+            --  definition hides new one (which is either in an outer
+            --  scope, or use-visible). Note that for functions use-visible
+            --  is the same as potentially use-visible. If new one hides
+            --  previous one, replace entry in table of interpretations.
+            --  If this is a universal operation, retain the operator in case
+            --  preference rule applies.
+
+            if (((Ekind (Name) = E_Function or else Ekind (Name) = E_Procedure)
+                 and then Ekind (Name) = Ekind (It.Nam))
+                or else (Ekind (Name) = E_Operator
+              and then Ekind (It.Nam) = E_Function))
+
+              and then Is_Immediately_Visible (It.Nam)
+              and then Type_Conformant (Name, It.Nam)
+              and then Base_Type (It.Typ) = Base_Type (T)
+            then
+               if Is_Universal_Operation (Name) then
+                  exit;
+
+               --  If node is an operator symbol, we have no actuals with
+               --  which to check hiding, and this is done in full in the
+               --  caller (Analyze_Subprogram_Renaming) so we include the
+               --  predefined operator in any case.
+
+               elsif Nkind (N) = N_Operator_Symbol
+                 or else (Nkind (N) = N_Expanded_Name
+                            and then
+                          Nkind (Selector_Name (N)) = N_Operator_Symbol)
+               then
+                  exit;
+
+               elsif not In_Open_Scopes (Scope (Name))
+                 or else Scope_Depth (Scope (Name))
+                   <= Scope_Depth (Scope (It.Nam))
+               then
+                  --  If ambiguity within instance, and entity is not an
+                  --  implicit operation, save for later disambiguation.
+
+                  if Scope (Name) = Scope (It.Nam)
+                    and then not Is_Inherited_Operation (Name)
+                    and then In_Instance
+                  then
+                     exit;
+                  else
+                     return;
+                  end if;
+
+               else
+                  All_Interp.Table (Index).Nam := Name;
+                  return;
+               end if;
+
+            --  Avoid making duplicate entries in overloads
+
+            elsif Name = It.Nam
+              and then Base_Type (It.Typ) = Base_Type (T)
+            then
+               return;
+
+            --  Otherwise keep going
+
+            else
+               Get_Next_Interp (Index, It);
+            end if;
+
+         end loop;
+
+         --  On exit, enter new interpretation. The context, or a preference
+         --  rule, will resolve the ambiguity on the second pass.
+
+         All_Interp.Table (All_Interp.Last) := (Name, Typ);
+         All_Interp.Increment_Last;
+         All_Interp.Table (All_Interp.Last) := No_Interp;
+
+      end Add_Entry;
+
+      ----------------------------
+      -- Is_Universal_Operation --
+      ----------------------------
+
+      function Is_Universal_Operation (Op : Entity_Id) return Boolean is
+         Arg : Node_Id;
+
+      begin
+         if Ekind (Op) /= E_Operator then
+            return False;
+
+         elsif Nkind (N) in N_Binary_Op then
+            return Present (Universal_Interpretation (Left_Opnd (N)))
+              and then Present (Universal_Interpretation (Right_Opnd (N)));
+
+         elsif Nkind (N) in N_Unary_Op then
+            return Present (Universal_Interpretation (Right_Opnd (N)));
+
+         elsif Nkind (N) = N_Function_Call then
+            Arg := First_Actual (N);
+
+            while Present (Arg) loop
+
+               if No (Universal_Interpretation (Arg)) then
+                  return False;
+               end if;
+
+               Next_Actual (Arg);
+            end loop;
+
+            return True;
+
+         else
+            return False;
+         end if;
+      end Is_Universal_Operation;
+
+   --  Start of processing for Add_One_Interp
+
+   begin
+      --  If the interpretation is a predefined operator, verify that the
+      --  result type is visible, or that the entity has already been
+      --  resolved (case of an instantiation node that refers to a predefined
+      --  operation, or an internally generated operator node, or an operator
+      --  given as an expanded name). If the operator is a comparison or
+      --  equality, it is the type of the operand that matters to determine
+      --  whether the operator is visible. In an instance, the check is not
+      --  performed, given that the operator was visible in the generic.
+
+      if Ekind (E) = E_Operator then
+
+         if Present (Opnd_Type) then
+            Vis_Type := Opnd_Type;
+         else
+            Vis_Type := Base_Type (T);
+         end if;
+
+         if In_Open_Scopes (Scope (Vis_Type))
+           or else Is_Potentially_Use_Visible (Vis_Type)
+           or else In_Use (Vis_Type)
+           or else (In_Use (Scope (Vis_Type))
+                     and then not Is_Hidden (Vis_Type))
+           or else Nkind (N) = N_Expanded_Name
+           or else (Nkind (N) in N_Op and then E = Entity (N))
+           or else In_Instance
+         then
+            null;
+
+         --  If the node is given in functional notation and the prefix
+         --  is an expanded name, then the operator is visible if the
+         --  prefix is the scope of the result type as well.
+
+         elsif Nkind (N) = N_Function_Call
+           and then Nkind (Name (N)) = N_Expanded_Name
+           and then (Entity (Prefix (Name (N))) = Scope (Base_Type (T))
+                      or else Entity (Prefix (Name (N))) = Scope (Vis_Type))
+         then
+            null;
+
+         --  Save type for subsequent error message, in case no other
+         --  interpretation is found.
+
+         else
+            Candidate_Type := Vis_Type;
+            return;
+         end if;
+
+      --  In an instance, an abstract non-dispatching operation cannot
+      --  be a candidate interpretation, because it could not have been
+      --  one in the generic (it may be a spurious overloading in the
+      --  instance).
+
+      elsif In_Instance
+        and then Is_Abstract (E)
+        and then not Is_Dispatching_Operation (E)
+      then
+         return;
+      end if;
+
+      --  If this is the first interpretation of N, N has type Any_Type.
+      --  In that case place the new type on the node. If one interpretation
+      --  already exists, indicate that the node is overloaded, and store
+      --  both the previous and the new interpretation in All_Interp. If
+      --  this is a later interpretation, just add it to the set.
+
+      if Etype (N) = Any_Type then
+         if Is_Type (E) then
+            Set_Etype (N, T);
+
+         else
+            --  Record both the operator or subprogram name, and its type.
+
+            if Nkind (N) in N_Op or else Is_Entity_Name (N) then
+               Set_Entity (N, E);
+            end if;
+
+            Set_Etype (N, T);
+         end if;
+
+      --  Either there is no current interpretation in the table for any
+      --  node or the interpretation that is present is for a different
+      --  node. In both cases add a new interpretation to the table.
+
+      elsif Interp_Map.Last < 0
+        or else Interp_Map.Table (Interp_Map.Last).Node /= N
+      then
+         New_Interps (N);
+
+         if (Nkind (N) in N_Op or else Is_Entity_Name (N))
+           and then Present (Entity (N))
+         then
+            Add_Entry (Entity (N), Etype (N));
+
+         elsif (Nkind (N) = N_Function_Call
+                 or else Nkind (N) = N_Procedure_Call_Statement)
+           and then (Nkind (Name (N)) = N_Operator_Symbol
+                      or else Is_Entity_Name (Name (N)))
+         then
+            Add_Entry (Entity (Name (N)), Etype (N));
+
+         else
+            --  Overloaded prefix in indexed or selected component,
+            --  or call whose name is an expresion or another call.
+
+            Add_Entry (Etype (N), Etype (N));
+         end if;
+
+         Add_Entry (E, T);
+
+      else
+         Add_Entry (E, T);
+      end if;
+   end Add_One_Interp;
+
+   -------------------
+   -- All_Overloads --
+   -------------------
+
+   procedure All_Overloads is
+   begin
+      for J in All_Interp.First .. All_Interp.Last loop
+
+         if Present (All_Interp.Table (J).Nam) then
+            Write_Entity_Info (All_Interp.Table (J). Nam, " ");
+         else
+            Write_Str ("No Interp");
+         end if;
+
+         Write_Str ("=================");
+         Write_Eol;
+      end loop;
+   end All_Overloads;
+
+   ---------------------
+   -- Collect_Interps --
+   ---------------------
+
+   procedure Collect_Interps (N : Node_Id) is
+      Ent          : constant Entity_Id := Entity (N);
+      H            : Entity_Id;
+      First_Interp : Interp_Index;
+
+   begin
+      New_Interps (N);
+
+      --  Unconditionally add the entity that was initially matched
+
+      First_Interp := All_Interp.Last;
+      Add_One_Interp (N, Ent, Etype (N));
+
+      --  For expanded name, pick up all additional entities from the
+      --  same scope, since these are obviously also visible. Note that
+      --  these are not necessarily contiguous on the homonym chain.
+
+      if Nkind (N) = N_Expanded_Name then
+         H := Homonym (Ent);
+         while Present (H) loop
+            if Scope (H) = Scope (Entity (N)) then
+               Add_One_Interp (N, H, Etype (H));
+            end if;
+
+            H := Homonym (H);
+         end loop;
+
+      --  Case of direct name
+
+      else
+         --  First, search the homonym chain for directly visible entities
+
+         H := Current_Entity (Ent);
+         while Present (H) loop
+            exit when (not Is_Overloadable (H))
+              and then Is_Immediately_Visible (H);
+
+            if Is_Immediately_Visible (H)
+              and then H /= Ent
+            then
+               --  Only add interpretation if not hidden by an inner
+               --  immediately visible one.
+
+               for J in First_Interp .. All_Interp.Last - 1 loop
+
+                  --  Current homograph is not hidden. Add to overloads.
+
+                  if not Is_Immediately_Visible (All_Interp.Table (J).Nam) then
+                     exit;
+
+                  --  Homograph is hidden, unless it is a predefined operator.
+
+                  elsif Type_Conformant (H, All_Interp.Table (J).Nam) then
+
+                     --  A homograph in the same scope can occur within an
+                     --  instantiation, the resulting ambiguity has to be
+                     --  resolved later.
+
+                     if Scope (H) = Scope (Ent)
+                        and then In_Instance
+                        and then not Is_Inherited_Operation (H)
+                     then
+                        All_Interp.Table (All_Interp.Last) := (H, Etype (H));
+                        All_Interp.Increment_Last;
+                        All_Interp.Table (All_Interp.Last) := No_Interp;
+                        goto Next_Homograph;
+
+                     elsif Scope (H) /= Standard_Standard then
+                        goto Next_Homograph;
+                     end if;
+                  end if;
+               end loop;
+
+               --  On exit, we know that current homograph is not hidden.
+
+               Add_One_Interp (N, H, Etype (H));
+
+               if Debug_Flag_E then
+                  Write_Str ("Add overloaded Interpretation ");
+                  Write_Int (Int (H));
+                  Write_Eol;
+               end if;
+            end if;
+
+            <<Next_Homograph>>
+               H := Homonym (H);
+         end loop;
+
+         --  Scan list of homographs for use-visible entities only.
+
+         H := Current_Entity (Ent);
+
+         while Present (H) loop
+            if Is_Potentially_Use_Visible (H)
+              and then H /= Ent
+              and then Is_Overloadable (H)
+            then
+               for J in First_Interp .. All_Interp.Last - 1 loop
+
+                  if not Is_Immediately_Visible (All_Interp.Table (J).Nam) then
+                     exit;
+
+                  elsif Type_Conformant (H, All_Interp.Table (J).Nam) then
+                     goto Next_Use_Homograph;
+                  end if;
+               end loop;
+
+               Add_One_Interp (N, H, Etype (H));
+            end if;
+
+            <<Next_Use_Homograph>>
+               H := Homonym (H);
+         end loop;
+      end if;
+
+      if All_Interp.Last = First_Interp + 1 then
+
+         --  The original interpretation is in fact not overloaded.
+
+         Set_Is_Overloaded (N, False);
+      end if;
+   end Collect_Interps;
+
+   ------------
+   -- Covers --
+   ------------
+
+   function Covers (T1, T2 : Entity_Id) return Boolean is
+   begin
+      pragma Assert (Present (T1) and Present (T2));
+
+      --  Simplest case: same types are compatible, and types that have the
+      --  same base type and are not generic actuals are compatible. Generic
+      --  actuals  belong to their class but are not compatible with other
+      --  types of their class, and in particular with other generic actuals.
+      --  They are however compatible with their own subtypes, and itypes
+      --  with the same base are compatible as well. Similary, constrained
+      --  subtypes obtained from expressions of an unconstrained nominal type
+      --  are compatible with the base type (may lead to spurious ambiguities
+      --  in obscure cases ???)
+
+      --  Generic actuals require special treatment to avoid spurious ambi-
+      --  guities in an instance, when two formal types are instantiated with
+      --  the same actual, so that different subprograms end up with the same
+      --  signature in the instance.
+
+      if T1 = T2 then
+         return True;
+
+      elsif Base_Type (T1) = Base_Type (T2) then
+         if not Is_Generic_Actual_Type (T1) then
+            return True;
+         else
+            return (not Is_Generic_Actual_Type (T2)
+                     or else Is_Itype (T1)
+                     or else Is_Itype (T2)
+                     or else Is_Constr_Subt_For_U_Nominal (T1)
+                     or else Is_Constr_Subt_For_U_Nominal (T2)
+                     or else Scope (T1) /= Scope (T2));
+         end if;
+
+      --  Literals are compatible with types in  a given "class"
+
+      elsif (T2 = Universal_Integer and then Is_Integer_Type (T1))
+        or else (T2 = Universal_Real    and then Is_Real_Type (T1))
+        or else (T2 = Universal_Fixed   and then Is_Fixed_Point_Type (T1))
+        or else (T2 = Any_Fixed         and then Is_Fixed_Point_Type (T1))
+        or else (T2 = Any_String        and then Is_String_Type (T1))
+        or else (T2 = Any_Character     and then Is_Character_Type (T1))
+        or else (T2 = Any_Access        and then Is_Access_Type (T1))
+      then
+         return True;
+
+      --  The context may be class wide.
+
+      elsif Is_Class_Wide_Type (T1)
+        and then Is_Ancestor (Root_Type (T1), T2)
+      then
+         return True;
+
+      elsif Is_Class_Wide_Type (T1)
+        and then Is_Class_Wide_Type (T2)
+        and then Base_Type (Etype (T1)) = Base_Type (Etype (T2))
+      then
+         return True;
+
+      --  In a dispatching call the actual may be class-wide
+
+      elsif Is_Class_Wide_Type (T2)
+        and then Base_Type (Root_Type (T2)) = Base_Type (T1)
+      then
+         return True;
+
+      --  Some contexts require a class of types rather than a specific type
+
+      elsif (T1 = Any_Integer and then Is_Integer_Type (T2))
+        or else (T1 = Any_Boolean and then Is_Boolean_Type (T2))
+        or else (T1 = Any_Real and then Is_Real_Type (T2))
+        or else (T1 = Any_Fixed and then Is_Fixed_Point_Type (T2))
+        or else (T1 = Any_Discrete and then Is_Discrete_Type (T2))
+      then
+         return True;
+
+      --  An aggregate is compatible with an array or record type
+
+      elsif T2 = Any_Composite
+        and then Ekind (T1) in E_Array_Type .. E_Record_Subtype
+      then
+         return True;
+
+      --  If the expected type is an anonymous access, the designated
+      --  type must cover that of the expression.
+
+      elsif Ekind (T1) = E_Anonymous_Access_Type
+        and then Is_Access_Type (T2)
+        and then Covers (Designated_Type (T1), Designated_Type (T2))
+      then
+         return True;
+
+      --  An Access_To_Subprogram is compatible with itself, or with an
+      --  anonymous type created for an attribute reference Access.
+
+      elsif (Ekind (Base_Type (T1)) = E_Access_Subprogram_Type
+               or else
+             Ekind (Base_Type (T1)) = E_Access_Protected_Subprogram_Type)
+        and then Is_Access_Type (T2)
+        and then (not Comes_From_Source (T1)
+                   or else not Comes_From_Source (T2))
+        and then (Is_Overloadable (Designated_Type (T2))
+                    or else
+                  Ekind (Designated_Type (T2)) = E_Subprogram_Type)
+        and then
+          Type_Conformant (Designated_Type (T1), Designated_Type (T2))
+        and then
+          Mode_Conformant (Designated_Type (T1), Designated_Type (T2))
+      then
+         return True;
+
+      elsif Is_Record_Type (T1)
+        and then (Is_Remote_Call_Interface (T1)
+                   or else Is_Remote_Types (T1))
+        and then Present (Corresponding_Remote_Type (T1))
+      then
+         return Covers (Corresponding_Remote_Type (T1), T2);
+
+      elsif Ekind (T2) = E_Access_Attribute_Type
+        and then (Ekind (Base_Type (T1)) = E_General_Access_Type
+              or else Ekind (Base_Type (T1)) = E_Access_Type)
+        and then Covers (Designated_Type (T1), Designated_Type (T2))
+      then
+         --  If the target type is a RACW type while the source is an access
+         --  attribute type, we are building a RACW that may be exported.
+
+         if Is_Remote_Access_To_Class_Wide_Type (Base_Type (T1)) then
+            Set_Has_RACW (Current_Sem_Unit);
+         end if;
+
+         return True;
+
+      elsif Ekind (T2) = E_Allocator_Type
+        and then Is_Access_Type (T1)
+        and then Covers (Designated_Type (T1), Designated_Type (T2))
+      then
+         return True;
+
+      --  A boolean operation on integer literals is compatible with a
+      --  modular context.
+
+      elsif T2 = Any_Modular
+        and then Is_Modular_Integer_Type (T1)
+      then
+         return True;
+
+      --  The actual type may be the result of a previous error
+
+      elsif Base_Type (T2) = Any_Type then
+         return True;
+
+      --  A packed array type covers its corresponding non-packed type.
+      --  This is not legitimate Ada, but allows the omission of a number
+      --  of otherwise useless unchecked conversions, and since this can
+      --  only arise in (known correct) expanded code, no harm is done
+
+      elsif Is_Array_Type (T2)
+        and then Is_Packed (T2)
+        and then T1 = Packed_Array_Type (T2)
+      then
+         return True;
+
+      --  Similarly an array type covers its corresponding packed array type
+
+      elsif Is_Array_Type (T1)
+        and then Is_Packed (T1)
+        and then T2 = Packed_Array_Type (T1)
+      then
+         return True;
+
+      --  In an instance the proper view may not always be correct for
+      --  private types, but private and full view are compatible. This
+      --  removes spurious errors from nested instantiations that involve,
+      --  among other things, types derived from privated types.
+
+      elsif In_Instance
+        and then Is_Private_Type (T1)
+        and then ((Present (Full_View (T1))
+                    and then Covers (Full_View (T1), T2))
+          or else Base_Type (T1) = T2
+          or else Base_Type (T2) = T1)
+      then
+         return True;
+
+      --  In the expansion of inlined bodies, types are compatible if they
+      --  are structurally equivalent.
+
+      elsif In_Inlined_Body
+        and then (Underlying_Type (T1) = Underlying_Type (T2)
+                   or else (Is_Access_Type (T1)
+                              and then Is_Access_Type (T2)
+                              and then
+                                Designated_Type (T1) = Designated_Type (T2))
+                   or else (T1 = Any_Access
+                              and then Is_Access_Type (Underlying_Type (T2))))
+      then
+         return True;
+
+      --  Otherwise it doesn't cover!
+
+      else
+         return False;
+      end if;
+   end Covers;
+
+   ------------------
+   -- Disambiguate --
+   ------------------
+
+   function Disambiguate
+     (N      : Node_Id;
+      I1, I2 : Interp_Index;
+      Typ    : Entity_Id)
+      return   Interp
+   is
+      I           : Interp_Index;
+      It          : Interp;
+      It1, It2    : Interp;
+      Nam1, Nam2  : Entity_Id;
+      Predef_Subp : Entity_Id;
+      User_Subp   : Entity_Id;
+
+      function Matches (Actual, Formal : Node_Id) return Boolean;
+      --  Look for exact type match in an instance, to remove spurious
+      --  ambiguities when two formal types have the same actual.
+
+      function Standard_Operator return Boolean;
+
+      function Remove_Conversions return Interp;
+      --  Last chance for pathological cases involving comparisons on
+      --  literals, and user overloadings of the same operator. Such
+      --  pathologies have been removed from the ACVC, but still appear in
+      --  two DEC tests, with the following notable quote from Ben Brosgol:
+      --
+      --  [Note: I disclaim all credit/responsibility/blame for coming up with
+      --  this example;  Robert Dewar brought it to our attention, since it
+      --  is apparently found in the ACVC 1.5. I did not attempt to find
+      --  the reason in the Reference Manual that makes the example legal,
+      --  since I was too nauseated by it to want to pursue it further.]
+      --
+      --  Accordingly, this is not a fully recursive solution, but it handles
+      --  DEC tests c460vsa, c460vsb. It also handles ai00136a, which pushes
+      --  pathology in the other direction with calls whose multiple overloaded
+      --  actuals make them truly unresolvable.
+
+      -------------
+      -- Matches --
+      -------------
+
+      function Matches (Actual, Formal : Node_Id) return Boolean is
+         T1 : constant Entity_Id := Etype (Actual);
+         T2 : constant Entity_Id := Etype (Formal);
+
+      begin
+         return T1 = T2
+           or else
+             (Is_Numeric_Type (T2)
+               and then
+             (T1 = Universal_Real or else T1 = Universal_Integer));
+      end Matches;
+
+      ------------------------
+      -- Remove_Conversions --
+      ------------------------
+
+      function Remove_Conversions return Interp is
+         I    : Interp_Index;
+         It   : Interp;
+         It1  : Interp;
+         F1   : Entity_Id;
+         Act1 : Node_Id;
+         Act2 : Node_Id;
+
+      begin
+         It1   := No_Interp;
+         Get_First_Interp (N, I, It);
+
+         while Present (It.Typ) loop
+
+            if not Is_Overloadable (It.Nam) then
+               return No_Interp;
+            end if;
+
+            F1 := First_Formal (It.Nam);
+
+            if No (F1) then
+               return It1;
+
+            else
+               if Nkind (N) = N_Function_Call
+                 or else Nkind (N) = N_Procedure_Call_Statement
+               then
+                  Act1 := First_Actual (N);
+
+                  if Present (Act1) then
+                     Act2 := Next_Actual (Act1);
+                  else
+                     Act2 := Empty;
+                  end if;
+
+               elsif Nkind (N) in N_Unary_Op then
+                  Act1 := Right_Opnd (N);
+                  Act2 := Empty;
+
+               elsif Nkind (N) in N_Binary_Op then
+                  Act1 := Left_Opnd (N);
+                  Act2 := Right_Opnd (N);
+
+               else
+                  return It1;
+               end if;
+
+               if Nkind (Act1) in N_Op
+                 and then Is_Overloaded (Act1)
+                 and then (Nkind (Right_Opnd (Act1)) = N_Integer_Literal
+                            or else Nkind (Right_Opnd (Act1)) = N_Real_Literal)
+                 and then Has_Compatible_Type (Act1, Standard_Boolean)
+                 and then Etype (F1) = Standard_Boolean
+               then
+
+                  if It1 /= No_Interp then
+                     return No_Interp;
+
+                  elsif Present (Act2)
+                    and then Nkind (Act2) in N_Op
+                    and then Is_Overloaded (Act2)
+                    and then (Nkind (Right_Opnd (Act1)) = N_Integer_Literal
+                                or else
+                              Nkind (Right_Opnd (Act1)) = N_Real_Literal)
+                    and then Has_Compatible_Type (Act2, Standard_Boolean)
+                  then
+                     --  The preference rule on the first actual is not
+                     --  sufficient to disambiguate.
+
+                     goto Next_Interp;
+
+                  else
+                     It1 := It;
+                  end if;
+               end if;
+            end if;
+
+            <<Next_Interp>>
+               Get_Next_Interp (I, It);
+         end loop;
+
+         if Errors_Detected > 0 then
+
+            --  After some error, a formal may have Any_Type and yield
+            --  a spurious match. To avoid cascaded errors if possible,
+            --  check for such a formal in either candidate.
+
+            declare
+               Formal : Entity_Id;
+
+            begin
+               Formal := First_Formal (Nam1);
+               while Present (Formal) loop
+                  if Etype (Formal) = Any_Type then
+                     return Disambiguate.It2;
+                  end if;
+
+                  Next_Formal (Formal);
+               end loop;
+
+               Formal := First_Formal (Nam2);
+               while Present (Formal) loop
+                  if Etype (Formal) = Any_Type then
+                     return Disambiguate.It1;
+                  end if;
+
+                  Next_Formal (Formal);
+               end loop;
+            end;
+         end if;
+
+         return It1;
+      end Remove_Conversions;
+
+      -----------------------
+      -- Standard_Operator --
+      -----------------------
+
+      function Standard_Operator return Boolean is
+         Nam : Node_Id;
+
+      begin
+         if Nkind (N) in N_Op then
+            return True;
+
+         elsif Nkind (N) = N_Function_Call then
+            Nam := Name (N);
+
+            if Nkind (Nam) /= N_Expanded_Name then
+               return True;
+            else
+               return Entity (Prefix (Nam)) = Standard_Standard;
+            end if;
+         else
+            return False;
+         end if;
+      end Standard_Operator;
+
+   --  Start of processing for Disambiguate
+
+   begin
+      --  Recover the two legal interpretations.
+
+      Get_First_Interp (N, I, It);
+
+      while I /= I1 loop
+         Get_Next_Interp (I, It);
+      end loop;
+
+      It1  := It;
+      Nam1 := It.Nam;
+
+      while I /= I2 loop
+         Get_Next_Interp (I, It);
+      end loop;
+
+      It2  := It;
+      Nam2 := It.Nam;
+
+      --  If the context is universal, the predefined operator is preferred.
+      --  This includes bounds in numeric type declarations, and expressions
+      --  in type conversions. If no interpretation yields a universal type,
+      --  then we must check whether the user-defined entity hides the prede-
+      --  fined one.
+
+      if Chars (Nam1) in  Any_Operator_Name
+        and then Standard_Operator
+      then
+         if        Typ = Universal_Integer
+           or else Typ = Universal_Real
+           or else Typ = Any_Integer
+           or else Typ = Any_Discrete
+           or else Typ = Any_Real
+           or else Typ = Any_Type
+         then
+            --  Find an interpretation that yields the universal type, or else
+            --  a predefined operator that yields a predefined numeric type.
+
+            declare
+               Candidate : Interp := No_Interp;
+            begin
+               Get_First_Interp (N, I, It);
+
+               while Present (It.Typ) loop
+                  if (Covers (Typ, It.Typ)
+                       or else Typ = Any_Type)
+                    and then
+                     (It.Typ = Universal_Integer
+                       or else It.Typ = Universal_Real)
+                  then
+                     return It;
+
+                  elsif Covers (Typ, It.Typ)
+                    and then Scope (It.Typ) = Standard_Standard
+                    and then Scope (It.Nam) = Standard_Standard
+                    and then Is_Numeric_Type (It.Typ)
+                  then
+                     Candidate := It;
+                  end if;
+
+                  Get_Next_Interp (I, It);
+               end loop;
+
+               if Candidate /= No_Interp then
+                  return Candidate;
+               end if;
+            end;
+
+         elsif Chars (Nam1) /= Name_Op_Not
+           and then (Typ = Standard_Boolean
+             or else Typ = Any_Boolean)
+         then
+            --  Equality or comparison operation. Choose predefined operator
+            --  if arguments are universal. The node may be an operator, a
+            --  name, or a function call, so unpack arguments accordingly.
+
+            declare
+               Arg1, Arg2 : Node_Id;
+
+            begin
+               if Nkind (N) in N_Op then
+                  Arg1 := Left_Opnd  (N);
+                  Arg2 := Right_Opnd (N);
+
+               elsif Is_Entity_Name (N)
+                 or else Nkind (N) = N_Operator_Symbol
+               then
+                  Arg1 := First_Entity (Entity (N));
+                  Arg2 := Next_Entity (Arg1);
+
+               else
+                  Arg1 := First_Actual (N);
+                  Arg2 := Next_Actual (Arg1);
+               end if;
+
+               if Present (Arg2)
+                 and then Present (Universal_Interpretation (Arg1))
+                 and then Universal_Interpretation (Arg2) =
+                          Universal_Interpretation (Arg1)
+               then
+                  Get_First_Interp (N, I, It);
+
+                  while Scope (It.Nam) /= Standard_Standard loop
+                     Get_Next_Interp (I, It);
+                  end loop;
+
+                  return It;
+               end if;
+            end;
+         end if;
+      end if;
+
+      --  If no universal interpretation, check whether user-defined operator
+      --  hides predefined one, as well as other special cases. If the node
+      --  is a range, then one or both bounds are ambiguous. Each will have
+      --  to be disambiguated w.r.t. the context type. The type of the range
+      --  itself is imposed by the context, so we can return either legal
+      --  interpretation.
+
+      if Ekind (Nam1) = E_Operator then
+         Predef_Subp := Nam1;
+         User_Subp   := Nam2;
+
+      elsif Ekind (Nam2) = E_Operator then
+         Predef_Subp := Nam2;
+         User_Subp   := Nam1;
+
+      elsif Nkind (N) = N_Range then
+         return It1;
+
+      --  If two user defined-subprograms are visible, it is a true ambiguity,
+      --  unless one of them is an entry and the context is a conditional or
+      --  timed entry call, or unless we are within an instance and this is
+      --  results from two formals types with the same actual.
+
+      else
+         if Nkind (N) = N_Procedure_Call_Statement
+           and then Nkind (Parent (N)) = N_Entry_Call_Alternative
+           and then N = Entry_Call_Statement (Parent (N))
+         then
+            if Ekind (Nam2) = E_Entry then
+               return It2;
+            elsif Ekind (Nam1) = E_Entry then
+               return It1;
+            else
+               return No_Interp;
+            end if;
+
+         --  If the ambiguity occurs within an instance, it is due to several
+         --  formal types with the same actual. Look for an exact match
+         --  between the types of the formals of the overloadable entities,
+         --  and the actuals in the call, to recover the unambiguous match
+         --  in the original generic.
+
+         elsif In_Instance then
+            if (Nkind (N) = N_Function_Call
+              or else Nkind (N) = N_Procedure_Call_Statement)
+            then
+               declare
+                  Actual : Node_Id;
+                  Formal : Entity_Id;
+
+               begin
+                  Actual := First_Actual (N);
+                  Formal := First_Formal (Nam1);
+                  while Present (Actual) loop
+                     if Etype (Actual) /= Etype (Formal) then
+                        return It2;
+                     end if;
+
+                     Next_Actual (Actual);
+                     Next_Formal (Formal);
+                  end loop;
+
+                  return It1;
+               end;
+
+            elsif Nkind (N) in N_Binary_Op then
+
+               if Matches (Left_Opnd (N), First_Formal (Nam1))
+                 and then
+                   Matches (Right_Opnd (N), Next_Formal (First_Formal (Nam1)))
+               then
+                  return It1;
+               else
+                  return It2;
+               end if;
+
+            elsif Nkind (N) in  N_Unary_Op then
+
+               if Etype (Right_Opnd (N)) = Etype (First_Formal (Nam1)) then
+                  return It1;
+               else
+                  return It2;
+               end if;
+
+            else
+               return Remove_Conversions;
+            end if;
+         else
+            return Remove_Conversions;
+         end if;
+      end if;
+
+      --  an implicit concatenation operator on a string type cannot be
+      --  disambiguated from the predefined concatenation. This can only
+      --  happen with concatenation of string literals.
+
+      if Chars (User_Subp) = Name_Op_Concat
+        and then Ekind (User_Subp) = E_Operator
+        and then Is_String_Type (Etype (First_Formal (User_Subp)))
+      then
+         return No_Interp;
+
+      --  If the user-defined operator is in  an open scope, or in the scope
+      --  of the resulting type, or given by an expanded name that names its
+      --  scope, it hides the predefined operator for the type. Exponentiation
+      --  has to be special-cased because the implicit operator does not have
+      --  a symmetric signature, and may not be hidden by the explicit one.
+
+      elsif (Nkind (N) = N_Function_Call
+              and then Nkind (Name (N)) = N_Expanded_Name
+              and then (Chars (Predef_Subp) /= Name_Op_Expon
+                          or else Hides_Op (User_Subp, Predef_Subp))
+              and then Scope (User_Subp) = Entity (Prefix (Name (N))))
+        or else Hides_Op (User_Subp, Predef_Subp)
+      then
+         if It1.Nam = User_Subp then
+            return It1;
+         else
+            return It2;
+         end if;
+
+      --  Otherwise, the predefined operator has precedence, or if the
+      --  user-defined operation is directly visible we have a true ambiguity.
+      --  If this is a fixed-point multiplication and division in Ada83 mode,
+      --  exclude the universal_fixed operator, which often causes ambiguities
+      --  in legacy code.
+
+      else
+         if (In_Open_Scopes (Scope (User_Subp))
+           or else Is_Potentially_Use_Visible (User_Subp))
+           and then not In_Instance
+         then
+            if Is_Fixed_Point_Type (Typ)
+              and then (Chars (Nam1) = Name_Op_Multiply
+                         or else Chars (Nam1) = Name_Op_Divide)
+              and then Ada_83
+            then
+               if It2.Nam = Predef_Subp then
+                  return It1;
+
+               else
+                  return It2;
+               end if;
+            else
+               return No_Interp;
+            end if;
+
+         elsif It1.Nam = Predef_Subp then
+            return It1;
+
+         else
+            return It2;
+         end if;
+      end if;
+
+   end Disambiguate;
+
+   ---------------------
+   -- End_Interp_List --
+   ---------------------
+
+   procedure End_Interp_List is
+   begin
+      All_Interp.Table (All_Interp.Last) := No_Interp;
+      All_Interp.Increment_Last;
+   end End_Interp_List;
+
+   -------------------------
+   -- Entity_Matches_Spec --
+   -------------------------
+
+   function Entity_Matches_Spec (Old_S, New_S : Entity_Id) return Boolean is
+   begin
+      --  Simple case: same entity kinds, type conformance is required.
+      --  A parameterless function can also rename a literal.
+
+      if Ekind (Old_S) = Ekind (New_S)
+        or else (Ekind (New_S) = E_Function
+                  and then Ekind (Old_S) = E_Enumeration_Literal)
+      then
+         return Type_Conformant (New_S, Old_S);
+
+      elsif Ekind (New_S) = E_Function
+        and then Ekind (Old_S) = E_Operator
+      then
+         return Operator_Matches_Spec (Old_S, New_S);
+
+      elsif Ekind (New_S) = E_Procedure
+        and then Is_Entry (Old_S)
+      then
+         return Type_Conformant (New_S, Old_S);
+
+      else
+         return False;
+      end if;
+   end Entity_Matches_Spec;
+
+   ----------------------
+   -- Find_Unique_Type --
+   ----------------------
+
+   function Find_Unique_Type (L : Node_Id; R : Node_Id) return Entity_Id is
+      I  : Interp_Index;
+      It : Interp;
+      T  : Entity_Id := Etype (L);
+      TR : Entity_Id := Any_Type;
+
+   begin
+      if Is_Overloaded (R) then
+         Get_First_Interp (R, I, It);
+
+         while Present (It.Typ) loop
+            if Covers (T, It.Typ) or else Covers (It.Typ, T) then
+
+               --  If several interpretations are possible and L is universal,
+               --  apply preference rule.
+
+               if TR /= Any_Type then
+
+                  if (T = Universal_Integer or else T = Universal_Real)
+                    and then It.Typ = T
+                  then
+                     TR := It.Typ;
+                  end if;
+
+               else
+                  TR := It.Typ;
+               end if;
+            end if;
+
+            Get_Next_Interp (I, It);
+         end loop;
+
+         Set_Etype (R, TR);
+
+      --  In the non-overloaded case, the Etype of R is already set
+      --  correctly.
+
+      else
+         null;
+      end if;
+
+      --  If one of the operands is Universal_Fixed, the type of the
+      --  other operand provides the context.
+
+      if Etype (R) = Universal_Fixed then
+         return T;
+
+      elsif T = Universal_Fixed then
+         return Etype (R);
+
+      else
+         return Specific_Type (T, Etype (R));
+      end if;
+
+   end Find_Unique_Type;
+
+   ----------------------
+   -- Get_First_Interp --
+   ----------------------
+
+   procedure Get_First_Interp
+     (N  : Node_Id;
+      I  : out Interp_Index;
+      It : out Interp)
+   is
+      Int_Ind : Interp_Index;
+      O_N     : Node_Id;
+
+   begin
+      --  If a selected component is overloaded because the selector has
+      --  multiple interpretations, the node is a call to a protected
+      --  operation or an indirect call. Retrieve the interpretation from
+      --  the selector name. The selected component may be overloaded as well
+      --  if the prefix is overloaded. That case is unchanged.
+
+      if Nkind (N) = N_Selected_Component
+        and then Is_Overloaded (Selector_Name (N))
+      then
+         O_N := Selector_Name (N);
+      else
+         O_N := N;
+      end if;
+
+      for Index in 0 .. Interp_Map.Last loop
+         if Interp_Map.Table (Index).Node = O_N then
+            Int_Ind := Interp_Map.Table (Index).Index;
+            It := All_Interp.Table (Int_Ind);
+            I := Int_Ind;
+            return;
+         end if;
+      end loop;
+
+      --  Procedure should never be called if the node has no interpretations
+
+      raise Program_Error;
+   end Get_First_Interp;
+
+   ----------------------
+   --  Get_Next_Interp --
+   ----------------------
+
+   procedure Get_Next_Interp (I : in out Interp_Index; It : out Interp) is
+   begin
+      I  := I + 1;
+      It := All_Interp.Table (I);
+   end Get_Next_Interp;
+
+   -------------------------
+   -- Has_Compatible_Type --
+   -------------------------
+
+   function Has_Compatible_Type
+     (N    : Node_Id;
+      Typ  : Entity_Id)
+      return Boolean
+   is
+      I  : Interp_Index;
+      It : Interp;
+
+   begin
+      if N = Error then
+         return False;
+      end if;
+
+      if Nkind (N) = N_Subtype_Indication
+        or else not Is_Overloaded (N)
+      then
+         return Covers (Typ, Etype (N))
+           or else (not Is_Tagged_Type (Typ)
+                     and then Ekind (Typ) /= E_Anonymous_Access_Type
+                     and then Covers (Etype (N), Typ));
+
+      else
+         Get_First_Interp (N, I, It);
+
+         while Present (It.Typ) loop
+            if Covers (Typ, It.Typ)
+              or else (not Is_Tagged_Type (Typ)
+                        and then Ekind (Typ) /= E_Anonymous_Access_Type
+                        and then Covers (It.Typ, Typ))
+            then
+               return True;
+            end if;
+
+            Get_Next_Interp (I, It);
+         end loop;
+
+         return False;
+      end if;
+   end Has_Compatible_Type;
+
+   --------------
+   -- Hides_Op --
+   --------------
+
+   function Hides_Op (F : Entity_Id; Op : Entity_Id) return Boolean is
+      Btyp : constant Entity_Id := Base_Type (Etype (First_Formal (F)));
+
+   begin
+      return Operator_Matches_Spec (Op, F)
+        and then (In_Open_Scopes (Scope (F))
+                    or else Scope (F) = Scope (Btyp)
+                    or else (not In_Open_Scopes (Scope (Btyp))
+                              and then not In_Use (Btyp)
+                              and then not In_Use (Scope (Btyp))));
+   end Hides_Op;
+
+   ------------------------
+   -- Init_Interp_Tables --
+   ------------------------
+
+   procedure Init_Interp_Tables is
+   begin
+      All_Interp.Init;
+      Interp_Map.Init;
+   end Init_Interp_Tables;
+
+   ---------------------
+   -- Intersect_Types --
+   ---------------------
+
+   function Intersect_Types (L, R : Node_Id) return Entity_Id is
+      Index : Interp_Index;
+      It    : Interp;
+      Typ   : Entity_Id;
+
+      function Check_Right_Argument (T : Entity_Id) return Entity_Id;
+      --  Find interpretation of right arg that has type compatible with T
+
+      --------------------------
+      -- Check_Right_Argument --
+      --------------------------
+
+      function Check_Right_Argument (T : Entity_Id) return Entity_Id is
+         Index : Interp_Index;
+         It    : Interp;
+         T2    : Entity_Id;
+
+      begin
+         if not Is_Overloaded (R) then
+            return Specific_Type (T, Etype (R));
+
+         else
+            Get_First_Interp (R, Index, It);
+
+            loop
+               T2 := Specific_Type (T, It.Typ);
+
+               if T2 /= Any_Type then
+                  return T2;
+               end if;
+
+               Get_Next_Interp (Index, It);
+               exit when No (It.Typ);
+            end loop;
+
+            return Any_Type;
+         end if;
+      end Check_Right_Argument;
+
+   --  Start processing for Intersect_Types
+
+   begin
+      if Etype (L) = Any_Type or else Etype (R) = Any_Type then
+         return Any_Type;
+      end if;
+
+      if not Is_Overloaded (L) then
+         Typ := Check_Right_Argument (Etype (L));
+
+      else
+         Typ := Any_Type;
+         Get_First_Interp (L, Index, It);
+
+         while Present (It.Typ) loop
+            Typ := Check_Right_Argument (It.Typ);
+            exit when Typ /= Any_Type;
+            Get_Next_Interp (Index, It);
+         end loop;
+
+      end if;
+
+      --  If Typ is Any_Type, it means no compatible pair of types was found
+
+      if Typ = Any_Type then
+
+         if Nkind (Parent (L)) in N_Op then
+            Error_Msg_N ("incompatible types for operator", Parent (L));
+
+         elsif Nkind (Parent (L)) = N_Range then
+            Error_Msg_N ("incompatible types given in constraint", Parent (L));
+
+         else
+            Error_Msg_N ("incompatible types", Parent (L));
+         end if;
+      end if;
+
+      return Typ;
+   end Intersect_Types;
+
+   -----------------
+   -- Is_Ancestor --
+   -----------------
+
+   function Is_Ancestor (T1, T2 : Entity_Id) return Boolean is
+      Par : Entity_Id;
+
+   begin
+      if Base_Type (T1) = Base_Type (T2) then
+         return True;
+
+      elsif Is_Private_Type (T1)
+        and then Present (Full_View (T1))
+        and then Base_Type (T2) = Base_Type (Full_View (T1))
+      then
+         return True;
+
+      else
+         Par := Etype (T2);
+
+         loop
+            if Base_Type (T1) = Base_Type (Par)
+              or else (Is_Private_Type (T1)
+                        and then Present (Full_View (T1))
+                        and then Base_Type (Par) = Base_Type (Full_View (T1)))
+            then
+               return True;
+
+            elsif Is_Private_Type (Par)
+              and then Present (Full_View (Par))
+              and then Full_View (Par) = Base_Type (T1)
+            then
+               return True;
+
+            elsif Etype (Par) /= Par then
+               Par := Etype (Par);
+            else
+               return False;
+            end if;
+         end loop;
+      end if;
+   end Is_Ancestor;
+
+   -------------------
+   -- Is_Subtype_Of --
+   -------------------
+
+   function Is_Subtype_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean is
+      S : Entity_Id;
+
+   begin
+      S := Ancestor_Subtype (T1);
+      while Present (S) loop
+         if S = T2 then
+            return True;
+         else
+            S := Ancestor_Subtype (S);
+         end if;
+      end loop;
+
+      return False;
+   end Is_Subtype_Of;
+
+   -----------------
+   -- New_Interps --
+   -----------------
+
+   procedure New_Interps (N : Node_Id)  is
+   begin
+      Interp_Map.Increment_Last;
+      All_Interp.Increment_Last;
+      Interp_Map.Table (Interp_Map.Last) := (N, All_Interp.Last);
+      All_Interp.Table (All_Interp.Last) := No_Interp;
+      Set_Is_Overloaded (N, True);
+   end New_Interps;
+
+   ---------------------------
+   -- Operator_Matches_Spec --
+   ---------------------------
+
+   function Operator_Matches_Spec (Op, New_S : Entity_Id) return Boolean is
+      Op_Name : constant Name_Id   := Chars (Op);
+      T       : constant Entity_Id := Etype (New_S);
+      New_F   : Entity_Id;
+      Old_F   : Entity_Id;
+      Num     : Int;
+      T1      : Entity_Id;
+      T2      : Entity_Id;
+
+   begin
+      --  To verify that a predefined operator matches a given signature,
+      --  do a case analysis of the operator classes. Function can have one
+      --  or two formals and must have the proper result type.
+
+      New_F := First_Formal (New_S);
+      Old_F := First_Formal (Op);
+      Num := 0;
+
+      while Present (New_F) and then Present (Old_F) loop
+         Num := Num + 1;
+         Next_Formal (New_F);
+         Next_Formal (Old_F);
+      end loop;
+
+      --  Definite mismatch if different number of parameters
+
+      if Present (Old_F) or else Present (New_F) then
+         return False;
+
+      --  Unary operators
+
+      elsif Num = 1 then
+         T1 := Etype (First_Formal (New_S));
+
+         if Op_Name = Name_Op_Subtract
+           or else Op_Name = Name_Op_Add
+           or else Op_Name = Name_Op_Abs
+         then
+            return Base_Type (T1) = Base_Type (T)
+              and then Is_Numeric_Type (T);
+
+         elsif Op_Name = Name_Op_Not then
+            return Base_Type (T1) = Base_Type (T)
+              and then Valid_Boolean_Arg (Base_Type (T));
+
+         else
+            return False;
+         end if;
+
+      --  Binary operators
+
+      else
+         T1 := Etype (First_Formal (New_S));
+         T2 := Etype (Next_Formal (First_Formal (New_S)));
+
+         if Op_Name =  Name_Op_And or else Op_Name = Name_Op_Or
+           or else Op_Name = Name_Op_Xor
+         then
+            return Base_Type (T1) = Base_Type (T2)
+              and then Base_Type (T1) = Base_Type (T)
+              and then Valid_Boolean_Arg (Base_Type (T));
+
+         elsif Op_Name = Name_Op_Eq or else Op_Name = Name_Op_Ne then
+            return Base_Type (T1) = Base_Type (T2)
+              and then not Is_Limited_Type (T1)
+              and then Is_Boolean_Type (T);
+
+         elsif Op_Name = Name_Op_Lt or else Op_Name = Name_Op_Le
+           or else Op_Name = Name_Op_Gt or else Op_Name = Name_Op_Ge
+         then
+            return Base_Type (T1) = Base_Type (T2)
+              and then Valid_Comparison_Arg (T1)
+              and then Is_Boolean_Type (T);
+
+         elsif Op_Name = Name_Op_Add or else Op_Name = Name_Op_Subtract then
+            return Base_Type (T1) = Base_Type (T2)
+              and then Base_Type (T1) = Base_Type (T)
+              and then Is_Numeric_Type (T);
+
+         --  for division and multiplication, a user-defined function does
+         --  not match the predefined universal_fixed operation, except in
+         --  Ada83 mode.
+
+         elsif Op_Name = Name_Op_Divide then
+            return (Base_Type (T1) = Base_Type (T2)
+              and then Base_Type (T1) = Base_Type (T)
+              and then Is_Numeric_Type (T)
+              and then (not Is_Fixed_Point_Type (T)
+                         or else Ada_83))
+
+            --  Mixed_Mode operations on fixed-point types.
+
+              or else (Base_Type (T1) = Base_Type (T)
+                        and then Base_Type (T2) = Base_Type (Standard_Integer)
+                        and then Is_Fixed_Point_Type (T))
+
+            --  A user defined operator can also match (and hide) a mixed
+            --  operation on universal literals.
+
+              or else (Is_Integer_Type (T2)
+                        and then Is_Floating_Point_Type (T1)
+                        and then Base_Type (T1) = Base_Type (T));
+
+         elsif Op_Name = Name_Op_Multiply then
+            return (Base_Type (T1) = Base_Type (T2)
+              and then Base_Type (T1) = Base_Type (T)
+              and then Is_Numeric_Type (T)
+              and then (not Is_Fixed_Point_Type (T)
+                         or else Ada_83))
+
+            --  Mixed_Mode operations on fixed-point types.
+
+              or else (Base_Type (T1) = Base_Type (T)
+                        and then Base_Type (T2) = Base_Type (Standard_Integer)
+                        and then Is_Fixed_Point_Type (T))
+
+              or else (Base_Type (T2) = Base_Type (T)
+                        and then Base_Type (T1) = Base_Type (Standard_Integer)
+                        and then Is_Fixed_Point_Type (T))
+
+              or else (Is_Integer_Type (T2)
+                        and then Is_Floating_Point_Type (T1)
+                        and then Base_Type (T1) = Base_Type (T))
+
+              or else (Is_Integer_Type (T1)
+                        and then Is_Floating_Point_Type (T2)
+                        and then Base_Type (T2) = Base_Type (T));
+
+         elsif Op_Name = Name_Op_Mod or else Op_Name = Name_Op_Rem then
+            return Base_Type (T1) = Base_Type (T2)
+              and then Base_Type (T1) = Base_Type (T)
+              and then Is_Integer_Type (T);
+
+         elsif Op_Name = Name_Op_Expon then
+            return Base_Type (T1) = Base_Type (T)
+              and then Is_Numeric_Type (T)
+              and then Base_Type (T2) = Base_Type (Standard_Integer);
+
+         elsif Op_Name = Name_Op_Concat then
+            return Is_Array_Type (T)
+              and then (Base_Type (T) = Base_Type (Etype (Op)))
+              and then (Base_Type (T1) = Base_Type (T)
+                         or else
+                        Base_Type (T1) = Base_Type (Component_Type (T)))
+              and then (Base_Type (T2) = Base_Type (T)
+                         or else
+                        Base_Type (T2) = Base_Type (Component_Type (T)));
+
+         else
+            return False;
+         end if;
+      end if;
+   end Operator_Matches_Spec;
+
+   -------------------
+   -- Remove_Interp --
+   -------------------
+
+   procedure Remove_Interp (I : in out Interp_Index) is
+      II : Interp_Index;
+
+   begin
+      --  Find end of Interp list and copy downward to erase the discarded one
+
+      II := I + 1;
+
+      while Present (All_Interp.Table (II).Typ) loop
+         II := II + 1;
+      end loop;
+
+      for J in I + 1 .. II loop
+         All_Interp.Table (J - 1) := All_Interp.Table (J);
+      end loop;
+
+      --  Back up interp. index to insure that iterator will pick up next
+      --  available interpretation.
+
+      I := I - 1;
+   end Remove_Interp;
+
+   ------------------
+   -- Save_Interps --
+   ------------------
+
+   procedure Save_Interps (Old_N : Node_Id; New_N : Node_Id) is
+   begin
+      if Is_Overloaded (Old_N) then
+         for Index in 0 .. Interp_Map.Last loop
+            if Interp_Map.Table (Index).Node = Old_N then
+               Interp_Map.Table (Index).Node := New_N;
+               exit;
+            end if;
+         end loop;
+      end if;
+   end Save_Interps;
+
+   -------------------
+   -- Specific_Type --
+   -------------------
+
+   function Specific_Type (T1, T2 : Entity_Id) return Entity_Id is
+      B1 : constant Entity_Id := Base_Type (T1);
+      B2 : constant Entity_Id := Base_Type (T2);
+
+      function Is_Remote_Access (T : Entity_Id) return Boolean;
+      --  Check whether T is the equivalent type of a remote access type.
+      --  If distribution is enabled, T is a legal context for Null.
+
+      ----------------------
+      -- Is_Remote_Access --
+      ----------------------
+
+      function Is_Remote_Access (T : Entity_Id) return Boolean is
+      begin
+         return Is_Record_Type (T)
+           and then (Is_Remote_Call_Interface (T)
+                      or else Is_Remote_Types (T))
+           and then Present (Corresponding_Remote_Type (T))
+           and then Is_Access_Type (Corresponding_Remote_Type (T));
+      end Is_Remote_Access;
+
+   --  Start of processing for Specific_Type
+
+   begin
+      if (T1 = Any_Type or else T2 = Any_Type) then
+         return Any_Type;
+      end if;
+
+      if B1 = B2 then
+         return B1;
+
+      elsif (T1 = Universal_Integer  and then Is_Integer_Type (T2))
+        or else (T1 = Universal_Real and then Is_Real_Type (T2))
+        or else (T1 = Any_Fixed      and then Is_Fixed_Point_Type (T2))
+      then
+         return B2;
+
+      elsif (T2 = Universal_Integer  and then Is_Integer_Type (T1))
+        or else (T2 = Universal_Real and then Is_Real_Type (T1))
+        or else (T2 = Any_Fixed      and then Is_Fixed_Point_Type (T1))
+      then
+         return B1;
+
+      elsif (T2 = Any_String and then Is_String_Type (T1)) then
+         return B1;
+
+      elsif (T1 = Any_String and then Is_String_Type (T2)) then
+         return B2;
+
+      elsif (T2 = Any_Character and then Is_Character_Type (T1)) then
+         return B1;
+
+      elsif (T1 = Any_Character and then Is_Character_Type (T2)) then
+         return B2;
+
+      elsif (T1 = Any_Access
+        and then (Is_Access_Type (T2) or else Is_Remote_Access (T2)))
+      then
+         return T2;
+
+      elsif (T2 = Any_Access
+        and then (Is_Access_Type (T1) or else Is_Remote_Access (T1)))
+      then
+         return T1;
+
+      elsif (T2 = Any_Composite
+         and then Ekind (T1) in E_Array_Type .. E_Record_Subtype)
+      then
+         return T1;
+
+      elsif (T1 = Any_Composite
+         and then Ekind (T2) in E_Array_Type .. E_Record_Subtype)
+      then
+         return T2;
+
+      elsif (T1 = Any_Modular and then Is_Modular_Integer_Type (T2)) then
+         return T2;
+
+      elsif (T2 = Any_Modular and then Is_Modular_Integer_Type (T1)) then
+         return T1;
+
+      --  Special cases for equality operators (all other predefined
+      --  operators can never apply to tagged types)
+
+      elsif Is_Class_Wide_Type (T1)
+        and then Is_Ancestor (Root_Type (T1), T2)
+      then
+         return T1;
+
+      elsif Is_Class_Wide_Type (T2)
+        and then Is_Ancestor (Root_Type (T2), T1)
+      then
+         return T2;
+
+      elsif (Ekind (B1) = E_Access_Subprogram_Type
+               or else
+             Ekind (B1) = E_Access_Protected_Subprogram_Type)
+        and then Ekind (Designated_Type (B1)) /= E_Subprogram_Type
+        and then Is_Access_Type (T2)
+      then
+         return T2;
+
+      elsif (Ekind (B2) = E_Access_Subprogram_Type
+               or else
+             Ekind (B2) = E_Access_Protected_Subprogram_Type)
+        and then Ekind (Designated_Type (B2)) /= E_Subprogram_Type
+        and then Is_Access_Type (T1)
+      then
+         return T1;
+
+      elsif (Ekind (T1) = E_Allocator_Type
+              or else Ekind (T1) = E_Access_Attribute_Type
+              or else Ekind (T1) = E_Anonymous_Access_Type)
+        and then Is_Access_Type (T2)
+      then
+         return T2;
+
+      elsif (Ekind (T2) = E_Allocator_Type
+              or else Ekind (T2) = E_Access_Attribute_Type
+              or else Ekind (T2) = E_Anonymous_Access_Type)
+        and then Is_Access_Type (T1)
+      then
+         return T1;
+
+      --  If none of the above cases applies, types are not compatible.
+
+      else
+         return Any_Type;
+      end if;
+   end Specific_Type;
+
+   ------------------------------
+   -- Universal_Interpretation --
+   ------------------------------
+
+   function Universal_Interpretation (Opnd : Node_Id) return Entity_Id is
+      Index : Interp_Index;
+      It    : Interp;
+
+   begin
+      --  The argument may be a formal parameter of an operator or subprogram
+      --  with multiple interpretations, or else an expression for an actual.
+
+      if Nkind (Opnd) = N_Defining_Identifier
+        or else not Is_Overloaded (Opnd)
+      then
+         if Etype (Opnd) = Universal_Integer
+           or else Etype (Opnd) = Universal_Real
+         then
+            return Etype (Opnd);
+         else
+            return Empty;
+         end if;
+
+      else
+         Get_First_Interp (Opnd, Index, It);
+
+         while Present (It.Typ) loop
+
+            if It.Typ = Universal_Integer
+              or else It.Typ = Universal_Real
+            then
+               return It.Typ;
+            end if;
+
+            Get_Next_Interp (Index, It);
+         end loop;
+
+         return Empty;
+      end if;
+   end Universal_Interpretation;
+
+   -----------------------
+   -- Valid_Boolean_Arg --
+   -----------------------
+
+   --  In addition to booleans and arrays of booleans, we must include
+   --  aggregates as valid boolean arguments, because in the first pass
+   --  of resolution their components are not examined. If it turns out not
+   --  to be an aggregate of booleans, this will be diagnosed in Resolve.
+   --  Any_Composite must be checked for prior to the array type checks
+   --  because Any_Composite does not have any associated indexes.
+
+   function Valid_Boolean_Arg (T : Entity_Id) return Boolean is
+   begin
+      return Is_Boolean_Type (T)
+        or else T = Any_Composite
+        or else (Is_Array_Type (T)
+                  and then T /= Any_String
+                  and then Number_Dimensions (T) = 1
+                  and then Is_Boolean_Type (Component_Type (T))
+                  and then (not Is_Private_Composite (T)
+                             or else In_Instance)
+                  and then (not Is_Limited_Composite (T)
+                             or else In_Instance))
+        or else Is_Modular_Integer_Type (T)
+        or else T = Universal_Integer;
+   end Valid_Boolean_Arg;
+
+   --------------------------
+   -- Valid_Comparison_Arg --
+   --------------------------
+
+   function Valid_Comparison_Arg (T : Entity_Id) return Boolean is
+   begin
+      return Is_Discrete_Type (T)
+        or else Is_Real_Type (T)
+        or else (Is_Array_Type (T) and then Number_Dimensions (T) = 1
+                  and then Is_Discrete_Type (Component_Type (T))
+                  and then (not Is_Private_Composite (T)
+                             or else In_Instance)
+                  and then (not Is_Limited_Composite (T)
+                             or else In_Instance))
+        or else Is_String_Type (T);
+   end Valid_Comparison_Arg;
+
+   ---------------------
+   -- Write_Overloads --
+   ---------------------
+
+   procedure Write_Overloads (N : Node_Id) is
+      I   : Interp_Index;
+      It  : Interp;
+      Nam : Entity_Id;
+
+   begin
+      if not Is_Overloaded (N) then
+         Write_Str ("Non-overloaded entity ");
+         Write_Eol;
+         Write_Entity_Info (Entity (N), " ");
+
+      else
+         Get_First_Interp (N, I, It);
+         Write_Str ("Overloaded entity ");
+         Write_Eol;
+         Nam := It.Nam;
+
+         while Present (Nam) loop
+            Write_Entity_Info (Nam,  "      ");
+            Write_Str ("=================");
+            Write_Eol;
+            Get_Next_Interp (I, It);
+            Nam := It.Nam;
+         end loop;
+      end if;
+   end Write_Overloads;
+
+end Sem_Type;
diff --git a/gcc/ada/sem_type.ads b/gcc/ada/sem_type.ads
new file mode 100644
index 00000000000..5498e3827b8
--- /dev/null
+++ b/gcc/ada/sem_type.ads
@@ -0,0 +1,262 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             S E M _ T Y P E                              --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.26 $
+--                                                                          --
+--          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 unit contains the routines used to handle type determination,
+--  including the routine used to support overload resolution.
+
+with Alloc;
+with Table;
+with Types; use Types;
+
+package Sem_Type is
+
+   ---------------------------------------------
+   -- Data Structures for Overload Resolution --
+   ---------------------------------------------
+
+   --  To determine the unique meaning of an identifier, overload resolution
+   --  may have to be performed if the visibility rules alone identify more
+   --  than one possible entity as the denotation of a given identifier. When
+   --  the visibility rules find such a potential ambiguity, the set of
+   --  possible interpretations must be attached to the identifier, and
+   --  overload resolution must be performed over the innermost enclosing
+   --  complete context. At the end of the resolution,  either a single
+   --  interpretation is found for all identifiers in the context, or else a
+   --  type error (invalid type or ambiguous reference) must be signalled.
+
+   --  The set of interpretations of a given name is stored in a data structure
+   --  that is separate from the syntax tree, because it corresponds to
+   --  transient information.  The interpretations themselves are stored in
+   --  table All_Interp. A mapping from tree nodes to sets of interpretations
+   --  called Interp_Map, is maintained by the overload resolution routines.
+   --  Both these structures are initialized at the beginning of every complete
+   --  context.
+
+   --  Corresponding to the set of interpretation for a given overloadable
+   --  identifier, there is a set of possible types corresponding to the types
+   --  that the overloaded call may return. We keep a 1-to-1 correspondence
+   --  between interpretations and types: for user-defined subprograms the
+   --  type is the declared return type. For operators, the type is determined
+   --  by the type of the arguments. If the arguments themselves are
+   --  overloaded, we enter the operator name in the names table for each
+   --  possible result type. In most cases, arguments are not overloaded and
+   --  only one interpretation is present anyway.
+
+   type Interp is record
+      Nam : Entity_Id;
+      Typ : Entity_Id;
+   end record;
+
+   No_Interp : constant Interp := (Empty, Empty);
+
+   package All_Interp is new Table.Table (
+     Table_Component_Type => Interp,
+     Table_Index_Type     => Int,
+     Table_Low_Bound      => 0,
+     Table_Initial        => Alloc.All_Interp_Initial,
+     Table_Increment      => Alloc.All_Interp_Increment,
+     Table_Name           => "All_Interp");
+
+   --  The following data structures establish a mapping between nodes and
+   --  their interpretations. Eventually the Interp_Index corresponding to
+   --  the first interpretation of a node may be stored directly in the
+   --  corresponding node.
+
+   subtype Interp_Index is Int;
+
+   type Interp_Ref is record
+      Node  : Node_Id;
+      Index : Interp_Index;
+   end record;
+
+   package Interp_Map is new Table.Table (
+     Table_Component_Type => Interp_Ref,
+     Table_Index_Type     => Int,
+     Table_Low_Bound      => 0,
+     Table_Initial        => Alloc.Interp_Map_Initial,
+     Table_Increment      => Alloc.Interp_Map_Increment,
+     Table_Name           => "Interp_Map");
+
+   --  For now Interp_Map is searched sequentially
+
+   ----------------------
+   --  Error Reporting --
+   ----------------------
+
+   --  A common error is the use of an operator in infix notation on arguments
+   --  of a type that is not directly visible. Rather than diagnosing a type
+   --  mismatch, it is better to indicate that the type can be made use-visible
+   --  with the appropriate use clause. The global variable Candidate_Type is
+   --  set in Add_One_Interp whenever an interpretation might be legal for an
+   --  operator if the type were directly visible. This variable is used in
+   --  sem_ch4 when no legal interpretation is found.
+
+   Candidate_Type : Entity_Id;
+
+   -----------------
+   -- Subprograms --
+   -----------------
+
+   procedure Init_Interp_Tables;
+   --  Invoked by gnatf when processing multiple files.
+
+   procedure Collect_Interps (N : Node_Id);
+   --  Invoked when the name N has more than one visible interpretation.
+   --  This is the high level routine which accumulates the possible
+   --  interpretations of the node. The first meaning and type of N have
+   --  already been stored in N. If the name is an expanded name, the homonyms
+   --  are only those that belong to the same scope.
+
+   procedure New_Interps (N : Node_Id);
+   --  Initialize collection of interpretations for the given node, which is
+   --  either an overloaded entity, or an operation whose arguments have
+   --  multiple intepretations. Interpretations can be added to only one
+   --  node at a time.
+
+   procedure Add_One_Interp
+     (N         : Node_Id;
+      E         : Entity_Id;
+      T         : Entity_Id;
+      Opnd_Type : Entity_Id := Empty);
+   --  Add (E, T) to the list of interpretations of the node being resolved.
+   --  For calls and operators, i.e. for nodes that have a name field,
+   --  E is an overloadable entity, and T is its type. For constructs such
+   --  as indexed expressions, the caller sets E equal to T, because the
+   --  overloading comes from other fields, and the node itself has no name
+   --  to resolve. Add_One_Interp includes the semantic processing to deal
+   --  with adding entries that hide one another etc.
+
+   --  For operators, the legality of the operation depends on the visibility
+   --  of T and its scope. If the operator is an equality or comparison, T is
+   --  always Boolean, and we use Opnd_Type, which is a candidate type for one
+   --  of the operands of N, to check visibility.
+
+   procedure End_Interp_List;
+   --  End the list of interpretations of current node.
+
+   procedure Get_First_Interp
+     (N  : Node_Id;
+      I  : out Interp_Index;
+      It : out Interp);
+   --  Initialize iteration over set of interpretations for Node N. The first
+   --  interpretation is placed in It, and I is initialized for subsequent
+   --  calls to Get_Next_Interp.
+
+   procedure Get_Next_Interp (I : in out Interp_Index; It : out Interp);
+   --  Iteration step over set of interpretations. Using the value in I, which
+   --  was set by a previous call to Get_First_Interp or Get_Next_Interp, the
+   --  next interpretation is placed in It, and I is updated for the next call.
+   --  The end of the list of interpretations is signalled by It.Nam = Empty.
+
+   procedure Remove_Interp (I : in out Interp_Index);
+   --  Remove an interpretation that his hidden by another, or that does not
+   --  match the context. The value of I on input was set by a call to either
+   --  Get_First_Interp or Get_Next_Interp and references the interpretation
+   --  to be removed. The only allowed use of the exit value of I is as input
+   --  to a subsequent call to Get_Next_Interp, which yields the interpretation
+   --  following the removed one.
+
+   procedure Save_Interps (Old_N : Node_Id; New_N : Node_Id);
+   --  If an overloaded node is rewritten during semantic analysis, its
+   --  possible interpretations must be linked to the copy. This procedure
+   --  transfers the overload information from Old_N, the old node, to
+   --  New_N, its new copy. It has no effect in the non-overloaded case.
+
+   function Covers (T1, T2 : Entity_Id) return Boolean;
+   --  This is the basic type compatibility routine. T1 is the expexted
+   --  type, imposed by context, and T2 is the actual type. The processing
+   --  reflects both the definition of type coverage and the rules
+   --  for operand matching.
+
+   function Disambiguate
+     (N      : Node_Id;
+      I1, I2 : Interp_Index;
+      Typ    : Entity_Id)
+      return   Interp;
+   --  If more than one interpretation  of a name in a call is legal, apply
+   --  preference rules (universal types first) and operator visibility in
+   --  order to remove ambiguity. I1 and I2 are the first two interpretations
+   --  that are compatible with the context, but there may be others.
+
+   function Entity_Matches_Spec (Old_S,  New_S : Entity_Id) return Boolean;
+   --  To resolve subprogram renaming and default formal subprograms in generic
+   --  definitions. Old_S is a possible interpretation of the entity being
+   --  renamed, New_S has an explicit signature. If Old_S is a subprogram, as
+   --  opposed to an operator, type and mode conformance are required.
+
+   function Find_Unique_Type (L : Node_Id; R : Node_Id) return Entity_Id;
+   --  Used in second pass of resolution,  for equality and comparison nodes.
+   --  L is the left operand, whose type is known to be correct, and R is
+   --  the right operand,  which has one interpretation compatible with that
+   --  of L. Return the type intersection of the two.
+
+   function Has_Compatible_Type
+     (N    : Node_Id;
+      Typ  : Entity_Id)
+      return Boolean;
+   --  Verify that some interpretation of the node N has a type compatible
+   --  with Typ. If N is not overloaded, then its unique type must be
+   --  compatible with Typ. Otherwise iterate through the interpretations
+   --  of N looking for a compatible one.
+
+   function Hides_Op (F : Entity_Id; Op : Entity_Id) return Boolean;
+   --  A user-defined function hides a predefined operator if it is
+   --  matches the signature of the operator, and is declared in an
+   --  open scope, or in the scope of the result type.
+
+   function Intersect_Types (L, R : Node_Id) return Entity_Id;
+   --  Find the common interpretation to two analyzed nodes. If one of the
+   --  interpretations is universal, choose the non-universal one. If either
+   --  node is overloaded, find single common interpretation.
+
+   function Is_Subtype_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean;
+   --  Checks whether T1 is any subtype of T2 directly or indirectly. Applies
+   --  only to scalar subtypes ???
+
+   function Is_Ancestor (T1, T2 : Entity_Id) return Boolean;
+   --  T1 is a tagged type (not class-wide). Verify that it is one of the
+   --  ancestors of type T2 (which may or not be class-wide)
+
+   function Operator_Matches_Spec (Op,  New_S : Entity_Id) return Boolean;
+   --  Used to resolve subprograms renaming operators, and calls to user
+   --  defined operators. Determines whether a given operator Op, matches
+   --  a specification, New_S.
+
+   function Valid_Comparison_Arg (T : Entity_Id) return Boolean;
+   --  A valid argument to an ordering operator must be a discrete type, a
+   --  real type, or a one dimensional array with a discrete component type.
+
+   function Valid_Boolean_Arg (T : Entity_Id) return Boolean;
+   --  A valid argument of a boolean operator is either some boolean type,
+   --  or a one-dimensional array of boolean type.
+
+   procedure Write_Overloads (N : Node_Id);
+   --  Debugging procedure to output info on possibly overloaded entities
+   --  for specified node.
+
+end Sem_Type;
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
new file mode 100644
index 00000000000..c2474720fb3
--- /dev/null
+++ b/gcc/ada/sem_util.adb
@@ -0,0 +1,5205 @@
+-----------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             S E M _ U T I L                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.541 $
+--                                                                          --
+--          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 Debug;    use Debug;
+with Errout;   use Errout;
+with Elists;   use Elists;
+with Exp_Util; use Exp_Util;
+with Freeze;   use Freeze;
+with Lib;      use Lib;
+with Lib.Xref; use Lib.Xref;
+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 Scans;    use Scans;
+with Scn;      use Scn;
+with Sem;      use Sem;
+with Sem_Ch8;  use Sem_Ch8;
+with Sem_Eval; use Sem_Eval;
+with Sem_Res;  use Sem_Res;
+with Sem_Type; use Sem_Type;
+with Sinfo;    use Sinfo;
+with Sinput;   use Sinput;
+with Snames;   use Snames;
+with Stand;    use Stand;
+with Style;
+with Stringt;  use Stringt;
+with Targparm; use Targparm;
+with Tbuild;   use Tbuild;
+with Ttypes;   use Ttypes;
+
+package body Sem_Util is
+
+   -----------------------
+   -- Local Subprograms --
+   -----------------------
+
+   function Build_Component_Subtype
+     (C    : List_Id;
+      Loc  : Source_Ptr;
+      T    : Entity_Id)
+      return Node_Id;
+   --  This function builds the subtype for Build_Actual_Subtype_Of_Component
+   --  and Build_Discriminal_Subtype_Of_Component. C is a list of constraints,
+   --  Loc is the source location, T is the original subtype.
+
+   --------------------------------
+   -- Add_Access_Type_To_Process --
+   --------------------------------
+
+   procedure Add_Access_Type_To_Process (E : Entity_Id; A : Entity_Id)
+   is
+      L : Elist_Id;
+   begin
+      Ensure_Freeze_Node (E);
+      L := Access_Types_To_Process (Freeze_Node (E));
+
+      if No (L) then
+         L := New_Elmt_List;
+         Set_Access_Types_To_Process (Freeze_Node (E), L);
+      end if;
+
+      Append_Elmt (A, L);
+   end Add_Access_Type_To_Process;
+
+   -----------------------
+   -- Alignment_In_Bits --
+   -----------------------
+
+   function Alignment_In_Bits (E : Entity_Id) return Uint is
+   begin
+      return Alignment (E) * System_Storage_Unit;
+   end Alignment_In_Bits;
+
+   -----------------------------------------
+   -- Apply_Compile_Time_Constraint_Error --
+   -----------------------------------------
+
+   procedure Apply_Compile_Time_Constraint_Error
+     (N   : Node_Id;
+      Msg : String;
+      Ent : Entity_Id  := Empty;
+      Typ : Entity_Id  := Empty;
+      Loc : Source_Ptr := No_Location;
+      Rep : Boolean    := True)
+   is
+      Stat : constant Boolean := Is_Static_Expression (N);
+      Rtyp : Entity_Id;
+
+   begin
+      if No (Typ) then
+         Rtyp := Etype (N);
+      else
+         Rtyp := Typ;
+      end if;
+
+      if No (Compile_Time_Constraint_Error (N, Msg, Ent, Loc))
+        or else not Rep
+      then
+         return;
+      end if;
+
+      --  Now we replace the node by an N_Raise_Constraint_Error node
+      --  This does not need reanalyzing, so set it as analyzed now.
+
+      Rewrite (N, Make_Raise_Constraint_Error (Sloc (N)));
+      Set_Analyzed (N, True);
+      Set_Etype (N, Rtyp);
+      Set_Raises_Constraint_Error (N);
+
+      --  If the original expression was marked as static, the result is
+      --  still marked as static, but the Raises_Constraint_Error flag is
+      --  always set so that further static evaluation is not attempted.
+
+      if Stat then
+         Set_Is_Static_Expression (N);
+      end if;
+   end Apply_Compile_Time_Constraint_Error;
+
+   --------------------------
+   -- Build_Actual_Subtype --
+   --------------------------
+
+   function Build_Actual_Subtype
+     (T    : Entity_Id;
+      N    : Node_Or_Entity_Id)
+      return Node_Id
+   is
+      Obj : Node_Id;
+
+      Loc         : constant Source_Ptr := Sloc (N);
+      Constraints : List_Id;
+      Decl        : Node_Id;
+      Discr       : Entity_Id;
+      Hi          : Node_Id;
+      Lo          : Node_Id;
+      Subt        : Entity_Id;
+      Disc_Type   : Entity_Id;
+
+   begin
+      if Nkind (N) = N_Defining_Identifier then
+         Obj := New_Reference_To (N, Loc);
+      else
+         Obj := N;
+      end if;
+
+      if Is_Array_Type (T) then
+         Constraints := New_List;
+
+         for J in 1 .. Number_Dimensions (T) loop
+
+            --  Build an array subtype declaration with the nominal
+            --  subtype and the bounds of the actual. Add the declaration
+            --  in front of the local declarations for the subprogram,for
+            --  analysis before any reference to the formal in the body.
+
+            Lo :=
+              Make_Attribute_Reference (Loc,
+                Prefix         => Duplicate_Subexpr (Obj, Name_Req => True),
+                Attribute_Name => Name_First,
+                Expressions    => New_List (
+                  Make_Integer_Literal (Loc, J)));
+
+            Hi :=
+              Make_Attribute_Reference (Loc,
+                Prefix         => Duplicate_Subexpr (Obj, Name_Req => True),
+                Attribute_Name => Name_Last,
+                Expressions    => New_List (
+                  Make_Integer_Literal (Loc, J)));
+
+            Append (Make_Range (Loc, Lo, Hi), Constraints);
+         end loop;
+
+      --  If the type has unknown discriminants there is no constrained
+      --  subtype to build.
+
+      elsif Has_Unknown_Discriminants (T) then
+         return T;
+
+      else
+         Constraints := New_List;
+
+         if Is_Private_Type (T) and then No (Full_View (T)) then
+
+            --  Type is a generic derived type. Inherit discriminants from
+            --  Parent type.
+
+            Disc_Type := Etype (Base_Type (T));
+         else
+            Disc_Type := T;
+         end if;
+
+         Discr := First_Discriminant (Disc_Type);
+
+         while Present (Discr) loop
+            Append_To (Constraints,
+              Make_Selected_Component (Loc,
+                Prefix => Duplicate_Subexpr (Obj),
+                Selector_Name => New_Occurrence_Of (Discr, Loc)));
+            Next_Discriminant (Discr);
+         end loop;
+      end if;
+
+      Subt :=
+        Make_Defining_Identifier (Loc,
+          Chars => New_Internal_Name ('S'));
+      Set_Is_Internal (Subt);
+
+      Decl :=
+        Make_Subtype_Declaration (Loc,
+          Defining_Identifier => Subt,
+          Subtype_Indication =>
+            Make_Subtype_Indication (Loc,
+              Subtype_Mark => New_Reference_To (T,  Loc),
+              Constraint  =>
+                Make_Index_Or_Discriminant_Constraint (Loc,
+                  Constraints => Constraints)));
+
+      Mark_Rewrite_Insertion (Decl);
+      return Decl;
+   end Build_Actual_Subtype;
+
+   ---------------------------------------
+   -- Build_Actual_Subtype_Of_Component --
+   ---------------------------------------
+
+   function Build_Actual_Subtype_Of_Component
+     (T    : Entity_Id;
+      N    : Node_Id)
+      return Node_Id
+   is
+      Loc       : constant Source_Ptr := Sloc (N);
+      P         : constant Node_Id    := Prefix (N);
+      D         : Elmt_Id;
+      Id        : Node_Id;
+      Indx_Type : Entity_Id;
+
+      Deaccessed_T : Entity_Id;
+      --  This is either a copy of T, or if T is an access type, then it is
+      --  the directly designated type of this access type.
+
+      function Build_Actual_Array_Constraint return List_Id;
+      --  If one or more of the bounds of the component depends on
+      --  discriminants, build  actual constraint using the discriminants
+      --  of the prefix.
+
+      function Build_Actual_Record_Constraint return List_Id;
+      --  Similar to previous one, for discriminated components constrained
+      --  by the discriminant of the enclosing object.
+
+      -----------------------------------
+      -- Build_Actual_Array_Constraint --
+      -----------------------------------
+
+      function Build_Actual_Array_Constraint return List_Id is
+         Constraints : List_Id := New_List;
+         Indx        : Node_Id;
+         Hi          : Node_Id;
+         Lo          : Node_Id;
+         Old_Hi      : Node_Id;
+         Old_Lo      : Node_Id;
+
+      begin
+         Indx := First_Index (Deaccessed_T);
+         while Present (Indx) loop
+            Old_Lo := Type_Low_Bound  (Etype (Indx));
+            Old_Hi := Type_High_Bound (Etype (Indx));
+
+            if Denotes_Discriminant (Old_Lo) then
+               Lo :=
+                 Make_Selected_Component (Loc,
+                   Prefix => New_Copy_Tree (P),
+                   Selector_Name => New_Occurrence_Of (Entity (Old_Lo), Loc));
+
+            else
+               Lo := New_Copy_Tree (Old_Lo);
+
+               --  The new bound will be reanalyzed in the enclosing
+               --  declaration. For literal bounds that come from a type
+               --  declaration, the type of the context must be imposed, so
+               --  insure that analysis will take place. For non-universal
+               --  types this is not strictly necessary.
+
+               Set_Analyzed (Lo, False);
+            end if;
+
+            if Denotes_Discriminant (Old_Hi) then
+               Hi :=
+                 Make_Selected_Component (Loc,
+                   Prefix => New_Copy_Tree (P),
+                   Selector_Name => New_Occurrence_Of (Entity (Old_Hi), Loc));
+
+            else
+               Hi := New_Copy_Tree (Old_Hi);
+               Set_Analyzed (Hi, False);
+            end if;
+
+            Append (Make_Range (Loc, Lo, Hi), Constraints);
+            Next_Index (Indx);
+         end loop;
+
+         return Constraints;
+      end Build_Actual_Array_Constraint;
+
+      ------------------------------------
+      -- Build_Actual_Record_Constraint --
+      ------------------------------------
+
+      function Build_Actual_Record_Constraint return List_Id is
+         Constraints : List_Id := New_List;
+         D           : Elmt_Id;
+         D_Val       : Node_Id;
+
+      begin
+         D := First_Elmt (Discriminant_Constraint (Deaccessed_T));
+         while Present (D) loop
+
+            if Denotes_Discriminant (Node (D)) then
+               D_Val :=  Make_Selected_Component (Loc,
+                 Prefix => New_Copy_Tree (P),
+                Selector_Name => New_Occurrence_Of (Entity (Node (D)), Loc));
+
+            else
+               D_Val := New_Copy_Tree (Node (D));
+            end if;
+
+            Append (D_Val, Constraints);
+            Next_Elmt (D);
+         end loop;
+
+         return Constraints;
+      end Build_Actual_Record_Constraint;
+
+   --  Start of processing for Build_Actual_Subtype_Of_Component
+
+   begin
+      if Nkind (N) = N_Explicit_Dereference then
+         if Is_Composite_Type (T)
+           and then not Is_Constrained (T)
+           and then not (Is_Class_Wide_Type (T)
+                          and then Is_Constrained (Root_Type (T)))
+           and then not Has_Unknown_Discriminants (T)
+         then
+            --  If the type of the dereference is already constrained, it
+            --  is an actual subtype.
+
+            if Is_Array_Type (Etype (N))
+              and then Is_Constrained (Etype (N))
+            then
+               return Empty;
+            else
+               Remove_Side_Effects (P);
+               return Build_Actual_Subtype (T, N);
+            end if;
+         else
+            return Empty;
+         end if;
+      end if;
+
+      if Ekind (T) = E_Access_Subtype then
+         Deaccessed_T := Designated_Type (T);
+      else
+         Deaccessed_T := T;
+      end if;
+
+      if Ekind (Deaccessed_T) = E_Array_Subtype then
+
+         Id := First_Index (Deaccessed_T);
+         Indx_Type := Underlying_Type (Etype (Id));
+
+         while Present (Id) loop
+
+            if Denotes_Discriminant (Type_Low_Bound  (Indx_Type)) or else
+               Denotes_Discriminant (Type_High_Bound (Indx_Type))
+            then
+               Remove_Side_Effects (P);
+               return
+                 Build_Component_Subtype (
+                   Build_Actual_Array_Constraint, Loc, Base_Type (T));
+            end if;
+
+            Next_Index (Id);
+         end loop;
+
+      elsif Is_Composite_Type (Deaccessed_T)
+        and then Has_Discriminants (Deaccessed_T)
+        and then not Has_Unknown_Discriminants (Deaccessed_T)
+      then
+         D := First_Elmt (Discriminant_Constraint (Deaccessed_T));
+         while Present (D) loop
+
+            if Denotes_Discriminant (Node (D)) then
+               Remove_Side_Effects (P);
+               return
+                 Build_Component_Subtype (
+                   Build_Actual_Record_Constraint, Loc, Base_Type (T));
+            end if;
+
+            Next_Elmt (D);
+         end loop;
+      end if;
+
+      --  If none of the above, the actual and nominal subtypes are the same.
+
+      return Empty;
+
+   end Build_Actual_Subtype_Of_Component;
+
+   -----------------------------
+   -- Build_Component_Subtype --
+   -----------------------------
+
+   function Build_Component_Subtype
+     (C    : List_Id;
+      Loc  : Source_Ptr;
+      T    : Entity_Id)
+      return Node_Id
+   is
+      Subt : Entity_Id;
+      Decl : Node_Id;
+
+   begin
+      Subt :=
+        Make_Defining_Identifier (Loc,
+          Chars => New_Internal_Name ('S'));
+      Set_Is_Internal (Subt);
+
+      Decl :=
+        Make_Subtype_Declaration (Loc,
+          Defining_Identifier => Subt,
+          Subtype_Indication =>
+            Make_Subtype_Indication (Loc,
+              Subtype_Mark => New_Reference_To (Base_Type (T),  Loc),
+              Constraint  =>
+                Make_Index_Or_Discriminant_Constraint (Loc,
+                  Constraints => C)));
+
+      Mark_Rewrite_Insertion (Decl);
+      return Decl;
+   end Build_Component_Subtype;
+
+   --------------------------------------------
+   -- Build_Discriminal_Subtype_Of_Component --
+   --------------------------------------------
+
+   function Build_Discriminal_Subtype_Of_Component
+     (T    : Entity_Id)
+      return Node_Id
+   is
+      Loc : constant Source_Ptr := Sloc (T);
+      D   : Elmt_Id;
+      Id  : Node_Id;
+
+      function Build_Discriminal_Array_Constraint return List_Id;
+      --  If one or more of the bounds of the component depends on
+      --  discriminants, build  actual constraint using the discriminants
+      --  of the prefix.
+
+      function Build_Discriminal_Record_Constraint return List_Id;
+      --  Similar to previous one, for discriminated components constrained
+      --  by the discriminant of the enclosing object.
+
+      ----------------------------------------
+      -- Build_Discriminal_Array_Constraint --
+      ----------------------------------------
+
+      function Build_Discriminal_Array_Constraint return List_Id is
+         Constraints : List_Id := New_List;
+         Indx        : Node_Id;
+         Hi          : Node_Id;
+         Lo          : Node_Id;
+         Old_Hi      : Node_Id;
+         Old_Lo      : Node_Id;
+
+      begin
+         Indx := First_Index (T);
+         while Present (Indx) loop
+            Old_Lo := Type_Low_Bound  (Etype (Indx));
+            Old_Hi := Type_High_Bound (Etype (Indx));
+
+            if Denotes_Discriminant (Old_Lo) then
+               Lo := New_Occurrence_Of (Discriminal (Entity (Old_Lo)), Loc);
+
+            else
+               Lo := New_Copy_Tree (Old_Lo);
+            end if;
+
+            if Denotes_Discriminant (Old_Hi) then
+               Hi := New_Occurrence_Of (Discriminal (Entity (Old_Hi)), Loc);
+
+            else
+               Hi := New_Copy_Tree (Old_Hi);
+            end if;
+
+            Append (Make_Range (Loc, Lo, Hi), Constraints);
+            Next_Index (Indx);
+         end loop;
+
+         return Constraints;
+      end Build_Discriminal_Array_Constraint;
+
+      -----------------------------------------
+      -- Build_Discriminal_Record_Constraint --
+      -----------------------------------------
+
+      function Build_Discriminal_Record_Constraint return List_Id is
+         Constraints     : List_Id := New_List;
+         D     : Elmt_Id;
+         D_Val : Node_Id;
+
+      begin
+         D := First_Elmt (Discriminant_Constraint (T));
+         while Present (D) loop
+
+            if Denotes_Discriminant (Node (D)) then
+               D_Val :=
+                 New_Occurrence_Of (Discriminal (Entity (Node (D))), Loc);
+
+            else
+               D_Val := New_Copy_Tree (Node (D));
+            end if;
+
+            Append (D_Val, Constraints);
+            Next_Elmt (D);
+         end loop;
+
+         return Constraints;
+      end Build_Discriminal_Record_Constraint;
+
+   --  Start of processing for Build_Discriminal_Subtype_Of_Component
+
+   begin
+      if Ekind (T) = E_Array_Subtype then
+
+         Id := First_Index (T);
+
+         while Present (Id) loop
+
+            if Denotes_Discriminant (Type_Low_Bound  (Etype (Id))) or else
+               Denotes_Discriminant (Type_High_Bound (Etype (Id)))
+            then
+               return Build_Component_Subtype
+                 (Build_Discriminal_Array_Constraint, Loc, T);
+            end if;
+
+            Next_Index (Id);
+         end loop;
+
+      elsif Ekind (T) = E_Record_Subtype
+        and then Has_Discriminants (T)
+        and then not Has_Unknown_Discriminants (T)
+      then
+         D := First_Elmt (Discriminant_Constraint (T));
+         while Present (D) loop
+
+            if Denotes_Discriminant (Node (D)) then
+               return Build_Component_Subtype
+                 (Build_Discriminal_Record_Constraint, Loc, T);
+            end if;
+
+            Next_Elmt (D);
+         end loop;
+      end if;
+
+      --  If none of the above, the actual and nominal subtypes are the same.
+
+      return Empty;
+
+   end Build_Discriminal_Subtype_Of_Component;
+
+   ------------------------------
+   -- Build_Elaboration_Entity --
+   ------------------------------
+
+   procedure Build_Elaboration_Entity (N : Node_Id; Spec_Id : Entity_Id) is
+      Loc       : constant Source_Ptr       := Sloc (N);
+      Unum      : constant Unit_Number_Type := Get_Source_Unit (Loc);
+      Decl      : Node_Id;
+      P         : Natural;
+      Elab_Ent  : Entity_Id;
+
+   begin
+      --  Ignore if already constructed
+
+      if Present (Elaboration_Entity (Spec_Id)) then
+         return;
+      end if;
+
+      --  Construct name of elaboration entity as xxx_E, where xxx
+      --  is the unit name with dots replaced by double underscore.
+      --  We have to manually construct this name, since it will
+      --  be elaborated in the outer scope, and thus will not have
+      --  the unit name automatically prepended.
+
+      Get_Name_String (Unit_Name (Unum));
+
+      --  Replace the %s by _E
+
+      Name_Buffer (Name_Len - 1 .. Name_Len) := "_E";
+
+      --  Replace dots by double underscore
+
+      P := 2;
+      while P < Name_Len - 2 loop
+         if Name_Buffer (P) = '.' then
+            Name_Buffer (P + 2 .. Name_Len + 1) :=
+              Name_Buffer (P + 1 .. Name_Len);
+            Name_Len := Name_Len + 1;
+            Name_Buffer (P) := '_';
+            Name_Buffer (P + 1) := '_';
+            P := P + 3;
+         else
+            P := P + 1;
+         end if;
+      end loop;
+
+      --  Create elaboration flag
+
+      Elab_Ent :=
+        Make_Defining_Identifier (Loc, Chars => Name_Find);
+      Set_Elaboration_Entity (Spec_Id, Elab_Ent);
+
+      if No (Declarations (Aux_Decls_Node (N))) then
+         Set_Declarations (Aux_Decls_Node (N), New_List);
+      end if;
+
+      Decl :=
+         Make_Object_Declaration (Loc,
+           Defining_Identifier => Elab_Ent,
+           Object_Definition   =>
+             New_Occurrence_Of (Standard_Boolean, Loc),
+           Expression          =>
+             New_Occurrence_Of (Standard_False, Loc));
+
+      Append_To (Declarations (Aux_Decls_Node (N)), Decl);
+      Analyze (Decl);
+
+      --  Reset True_Constant indication, since we will indeed
+      --  assign a value to the variable in the binder main.
+
+      Set_Is_True_Constant (Elab_Ent, False);
+
+      --  We do not want any further qualification of the name (if we did
+      --  not do this, we would pick up the name of the generic package
+      --  in the case of a library level generic instantiation).
+
+      Set_Has_Qualified_Name       (Elab_Ent);
+      Set_Has_Fully_Qualified_Name (Elab_Ent);
+   end Build_Elaboration_Entity;
+
+   --------------------------
+   -- Check_Fully_Declared --
+   --------------------------
+
+   procedure Check_Fully_Declared (T : Entity_Id; N : Node_Id) is
+   begin
+      if Ekind (T) = E_Incomplete_Type then
+         Error_Msg_NE
+           ("premature usage of incomplete}", N, First_Subtype (T));
+
+      elsif Has_Private_Component (T)
+        and then not Is_Generic_Type (Root_Type (T))
+        and then not In_Default_Expression
+      then
+         Error_Msg_NE
+           ("premature usage of incomplete}", N, First_Subtype (T));
+      end if;
+   end Check_Fully_Declared;
+
+   ------------------------------------------
+   -- Check_Potentially_Blocking_Operation --
+   ------------------------------------------
+
+   procedure Check_Potentially_Blocking_Operation (N : Node_Id) is
+      S   : Entity_Id;
+      Loc : constant Source_Ptr := Sloc (N);
+
+   begin
+      --  N is one of the potentially blocking operations listed in
+      --  9.5.1 (8). When using the Ravenscar profile, raise Program_Error
+      --  before N if the context is a protected action. Otherwise, only issue
+      --  a warning, since some users are relying on blocking operations
+      --  inside protected objects.
+      --  Indirect blocking through a subprogram call
+      --  cannot be diagnosed statically without interprocedural analysis,
+      --  so we do not attempt to do it here.
+
+      S := Scope (Current_Scope);
+
+      while Present (S) and then S /= Standard_Standard loop
+         if Is_Protected_Type (S) then
+            if Restricted_Profile then
+               Insert_Before (N,
+                  Make_Raise_Statement (Loc,
+                   Name => New_Occurrence_Of (Standard_Program_Error, Loc)));
+               Error_Msg_N ("potentially blocking operation, " &
+                 " Program Error will be raised at run time?", N);
+
+            else
+               Error_Msg_N
+                 ("potentially blocking operation in protected operation?", N);
+            end if;
+
+            return;
+         end if;
+
+         S := Scope (S);
+      end loop;
+   end Check_Potentially_Blocking_Operation;
+
+   ---------------
+   -- Check_VMS --
+   ---------------
+
+   procedure Check_VMS (Construct : Node_Id) is
+   begin
+      if not OpenVMS_On_Target then
+         Error_Msg_N
+           ("this construct is allowed only in Open'V'M'S", Construct);
+      end if;
+   end Check_VMS;
+
+   ----------------------------------
+   -- Collect_Primitive_Operations --
+   ----------------------------------
+
+   function Collect_Primitive_Operations (T : Entity_Id) return Elist_Id is
+      B_Type         : constant Entity_Id := Base_Type (T);
+      B_Decl         : constant Node_Id   := Original_Node (Parent (B_Type));
+      B_Scope        : Entity_Id          := Scope (B_Type);
+      Op_List        : Elist_Id;
+      Formal         : Entity_Id;
+      Is_Prim        : Boolean;
+      Formal_Derived : Boolean := False;
+      Id             : Entity_Id;
+
+   begin
+      --  For tagged types, the primitive operations are collected as they
+      --  are declared, and held in an explicit list which is simply returned.
+
+      if Is_Tagged_Type (B_Type) then
+         return Primitive_Operations (B_Type);
+
+      --  An untagged generic type that is a derived type inherits the
+      --  primitive operations of its parent type. Other formal types only
+      --  have predefined operators, which are not explicitly represented.
+
+      elsif Is_Generic_Type (B_Type) then
+         if Nkind (B_Decl) = N_Formal_Type_Declaration
+           and then Nkind (Formal_Type_Definition (B_Decl))
+             = N_Formal_Derived_Type_Definition
+         then
+            Formal_Derived := True;
+         else
+            return New_Elmt_List;
+         end if;
+      end if;
+
+      Op_List := New_Elmt_List;
+
+      if B_Scope = Standard_Standard then
+         if B_Type = Standard_String then
+            Append_Elmt (Standard_Op_Concat, Op_List);
+
+         elsif B_Type = Standard_Wide_String then
+            Append_Elmt (Standard_Op_Concatw, Op_List);
+
+         else
+            null;
+         end if;
+
+      elsif (Is_Package (B_Scope)
+               and then Nkind (
+                 Parent (Declaration_Node (First_Subtype (T))))
+                   /=  N_Package_Body)
+
+        or else Is_Derived_Type (B_Type)
+      then
+         --  The primitive operations appear after the base type, except
+         --  if the derivation happens within the private part of B_Scope
+         --  and the type is a private type, in which case both the type
+         --  and some primitive operations may appear before the base
+         --  type, and the list of candidates starts after the type.
+
+         if In_Open_Scopes (B_Scope)
+           and then Scope (T) = B_Scope
+           and then In_Private_Part (B_Scope)
+         then
+            Id := Next_Entity (T);
+         else
+            Id := Next_Entity (B_Type);
+         end if;
+
+         while Present (Id) loop
+
+            --  Note that generic formal subprograms are not
+            --  considered to be primitive operations and thus
+            --  are never inherited.
+
+            if Is_Overloadable (Id)
+              and then Nkind (Parent (Parent (Id)))
+                         /= N_Formal_Subprogram_Declaration
+            then
+               Is_Prim := False;
+
+               if Base_Type (Etype (Id)) = B_Type then
+                  Is_Prim := True;
+               else
+                  Formal := First_Formal (Id);
+                  while Present (Formal) loop
+                     if Base_Type (Etype (Formal)) = B_Type then
+                        Is_Prim := True;
+                        exit;
+
+                     elsif Ekind (Etype (Formal)) = E_Anonymous_Access_Type
+                       and then Base_Type
+                         (Designated_Type (Etype (Formal))) = B_Type
+                     then
+                        Is_Prim := True;
+                        exit;
+                     end if;
+
+                     Next_Formal (Formal);
+                  end loop;
+               end if;
+
+               --  For a formal derived type, the only primitives are the
+               --  ones inherited from the parent type. Operations appearing
+               --  in the package declaration are not primitive for it.
+
+               if Is_Prim
+                 and then (not Formal_Derived
+                            or else Present (Alias (Id)))
+               then
+                  Append_Elmt (Id, Op_List);
+               end if;
+            end if;
+
+            Next_Entity (Id);
+
+            --  For a type declared in System, some of its operations
+            --  may appear in  the target-specific extension to System.
+
+            if No (Id)
+              and then Chars (B_Scope) = Name_System
+              and then Scope (B_Scope) = Standard_Standard
+              and then Present_System_Aux
+            then
+               B_Scope := System_Aux_Id;
+               Id := First_Entity (System_Aux_Id);
+            end if;
+
+         end loop;
+
+      end if;
+
+      return Op_List;
+   end Collect_Primitive_Operations;
+
+   -----------------------------------
+   -- Compile_Time_Constraint_Error --
+   -----------------------------------
+
+   function Compile_Time_Constraint_Error
+     (N    : Node_Id;
+      Msg  : String;
+      Ent  : Entity_Id  := Empty;
+      Loc  : Source_Ptr := No_Location)
+      return Node_Id
+   is
+      Msgc : String (1 .. Msg'Length + 2);
+      Msgl : Natural;
+      Warn : Boolean;
+      P    : Node_Id;
+      Msgs : Boolean;
+
+   begin
+      --  A static constraint error in an instance body is not a fatal error.
+      --  we choose to inhibit the message altogether, because there is no
+      --  obvious node (for now) on which to post it. On the other hand the
+      --  offending node must be replaced with a constraint_error in any case.
+
+      --  No messages are generated if we already posted an error on this node
+
+      if not Error_Posted (N) then
+
+         --  Make all such messages unconditional
+
+         Msgc (1 .. Msg'Length) := Msg;
+         Msgc (Msg'Length + 1) := '!';
+         Msgl := Msg'Length + 1;
+
+         --  Message is a warning, even in Ada 95 case
+
+         if Msg (Msg'Length) = '?' then
+            Warn := True;
+
+         --  In Ada 83, all messages are warnings. In the private part and
+         --  the body of an instance, constraint_checks are only warnings.
+
+         elsif Ada_83 and then Comes_From_Source (N) then
+
+            Msgl := Msgl + 1;
+            Msgc (Msgl) := '?';
+            Warn := True;
+
+         elsif In_Instance_Not_Visible then
+
+            Msgl := Msgl + 1;
+            Msgc (Msgl) := '?';
+            Warn := True;
+            Warn_On_Instance := True;
+
+         --  Otherwise we have a real error message (Ada 95 static case)
+
+         else
+            Warn := False;
+         end if;
+
+         --  Should we generate a warning? The answer is not quite yes. The
+         --  very annoying exception occurs in the case of a short circuit
+         --  operator where the left operand is static and decisive. Climb
+         --  parents to see if that is the case we have here.
+
+         Msgs := True;
+         P := N;
+
+         loop
+            P := Parent (P);
+
+            if (Nkind (P) = N_And_Then
+                and then Compile_Time_Known_Value (Left_Opnd (P))
+                and then Is_False (Expr_Value (Left_Opnd (P))))
+              or else (Nkind (P) = N_Or_Else
+                and then Compile_Time_Known_Value (Left_Opnd (P))
+                and then Is_True (Expr_Value (Left_Opnd (P))))
+            then
+               Msgs := False;
+               exit;
+
+            elsif Nkind (P) = N_Component_Association
+              and then Nkind (Parent (P)) = N_Aggregate
+            then
+               null;  --   Keep going.
+
+            else
+               exit when Nkind (P) not in N_Subexpr;
+            end if;
+         end loop;
+
+         if Msgs then
+            if Present (Ent) then
+               Error_Msg_NE (Msgc (1 .. Msgl), N, Ent);
+            else
+               Error_Msg_NE (Msgc (1 .. Msgl), N, Etype (N));
+            end if;
+
+            if Warn then
+               if Inside_Init_Proc then
+                  Error_Msg_NE
+                    ("\& will be raised for objects of this type!?",
+                     N, Standard_Constraint_Error);
+               else
+                  Error_Msg_NE
+                    ("\& will be raised at run time!?",
+                     N, Standard_Constraint_Error);
+               end if;
+            else
+               Error_Msg_NE
+                 ("\static expression raises&!",
+                  N, Standard_Constraint_Error);
+            end if;
+         end if;
+      end if;
+
+      return N;
+   end Compile_Time_Constraint_Error;
+
+   -----------------------
+   -- Conditional_Delay --
+   -----------------------
+
+   procedure Conditional_Delay (New_Ent, Old_Ent : Entity_Id) is
+   begin
+      if Has_Delayed_Freeze (Old_Ent) and then not Is_Frozen (Old_Ent) then
+         Set_Has_Delayed_Freeze (New_Ent);
+      end if;
+   end Conditional_Delay;
+
+   --------------------
+   -- Current_Entity --
+   --------------------
+
+   --  The currently visible definition for a given identifier is the
+   --  one most chained at the start of the visibility chain, i.e. the
+   --  one that is referenced by the Node_Id value of the name of the
+   --  given identifier.
+
+   function Current_Entity (N : Node_Id) return Entity_Id is
+   begin
+      return Get_Name_Entity_Id (Chars (N));
+   end Current_Entity;
+
+   -----------------------------
+   -- Current_Entity_In_Scope --
+   -----------------------------
+
+   function Current_Entity_In_Scope (N : Node_Id) return Entity_Id is
+      E  : Entity_Id;
+      CS : constant Entity_Id := Current_Scope;
+
+      Transient_Case : constant Boolean := Scope_Is_Transient;
+
+   begin
+      E := Get_Name_Entity_Id (Chars (N));
+
+      while Present (E)
+        and then Scope (E) /= CS
+        and then (not Transient_Case or else Scope (E) /= Scope (CS))
+      loop
+         E := Homonym (E);
+      end loop;
+
+      return E;
+   end Current_Entity_In_Scope;
+
+   -------------------
+   -- Current_Scope --
+   -------------------
+
+   function Current_Scope return Entity_Id is
+   begin
+      if Scope_Stack.Last = -1 then
+         return Standard_Standard;
+      else
+         declare
+            C : constant Entity_Id :=
+                  Scope_Stack.Table (Scope_Stack.Last).Entity;
+         begin
+            if Present (C) then
+               return C;
+            else
+               return Standard_Standard;
+            end if;
+         end;
+      end if;
+   end Current_Scope;
+
+   ------------------------
+   -- Current_Subprogram --
+   ------------------------
+
+   function Current_Subprogram return Entity_Id is
+      Scop : constant Entity_Id := Current_Scope;
+
+   begin
+      if Ekind (Scop) = E_Function
+           or else
+         Ekind (Scop) = E_Procedure
+           or else
+         Ekind (Scop) = E_Generic_Function
+           or else
+         Ekind (Scop) = E_Generic_Procedure
+      then
+         return Scop;
+
+      else
+         return Enclosing_Subprogram (Scop);
+      end if;
+   end Current_Subprogram;
+
+   ---------------------
+   -- Defining_Entity --
+   ---------------------
+
+   function Defining_Entity (N : Node_Id) return Entity_Id is
+      K : constant Node_Kind := Nkind (N);
+
+   begin
+      case K is
+         when
+           N_Subprogram_Declaration                 |
+           N_Abstract_Subprogram_Declaration        |
+           N_Subprogram_Body                        |
+           N_Package_Declaration                    |
+           N_Subprogram_Renaming_Declaration        |
+           N_Subprogram_Body_Stub                   |
+           N_Generic_Subprogram_Declaration         |
+           N_Generic_Package_Declaration            |
+           N_Formal_Subprogram_Declaration
+         =>
+            return Defining_Entity (Specification (N));
+
+         when
+           N_Component_Declaration                  |
+           N_Defining_Program_Unit_Name             |
+           N_Discriminant_Specification             |
+           N_Entry_Body                             |
+           N_Entry_Declaration                      |
+           N_Entry_Index_Specification              |
+           N_Exception_Declaration                  |
+           N_Exception_Renaming_Declaration         |
+           N_Formal_Object_Declaration              |
+           N_Formal_Package_Declaration             |
+           N_Formal_Type_Declaration                |
+           N_Full_Type_Declaration                  |
+           N_Implicit_Label_Declaration             |
+           N_Incomplete_Type_Declaration            |
+           N_Loop_Parameter_Specification           |
+           N_Number_Declaration                     |
+           N_Object_Declaration                     |
+           N_Object_Renaming_Declaration            |
+           N_Package_Body_Stub                      |
+           N_Parameter_Specification                |
+           N_Private_Extension_Declaration          |
+           N_Private_Type_Declaration               |
+           N_Protected_Body                         |
+           N_Protected_Body_Stub                    |
+           N_Protected_Type_Declaration             |
+           N_Single_Protected_Declaration           |
+           N_Single_Task_Declaration                |
+           N_Subtype_Declaration                    |
+           N_Task_Body                              |
+           N_Task_Body_Stub                         |
+           N_Task_Type_Declaration
+         =>
+            return Defining_Identifier (N);
+
+         when N_Subunit =>
+            return Defining_Entity (Proper_Body (N));
+
+         when
+           N_Function_Instantiation                 |
+           N_Function_Specification                 |
+           N_Generic_Function_Renaming_Declaration  |
+           N_Generic_Package_Renaming_Declaration   |
+           N_Generic_Procedure_Renaming_Declaration |
+           N_Package_Body                           |
+           N_Package_Instantiation                  |
+           N_Package_Renaming_Declaration           |
+           N_Package_Specification                  |
+           N_Procedure_Instantiation                |
+           N_Procedure_Specification
+         =>
+            declare
+               Nam : constant Node_Id := Defining_Unit_Name (N);
+
+            begin
+               if Nkind (Nam) in N_Entity then
+                  return Nam;
+               else
+                  return Defining_Identifier (Nam);
+               end if;
+            end;
+
+         when N_Block_Statement =>
+            return Entity (Identifier (N));
+
+         when others =>
+            raise Program_Error;
+
+      end case;
+   end Defining_Entity;
+
+   --------------------------
+   -- Denotes_Discriminant --
+   --------------------------
+
+   function Denotes_Discriminant (N : Node_Id) return Boolean is
+   begin
+      return Is_Entity_Name (N)
+        and then Present (Entity (N))
+        and then Ekind (Entity (N)) = E_Discriminant;
+   end Denotes_Discriminant;
+
+   -----------------------------
+   -- Depends_On_Discriminant --
+   -----------------------------
+
+   function Depends_On_Discriminant (N : Node_Id) return Boolean is
+      L : Node_Id;
+      H : Node_Id;
+
+   begin
+      Get_Index_Bounds (N, L, H);
+      return Denotes_Discriminant (L) or else Denotes_Discriminant (H);
+   end Depends_On_Discriminant;
+
+   -------------------------
+   -- Designate_Same_Unit --
+   -------------------------
+
+   function Designate_Same_Unit
+     (Name1 : Node_Id;
+      Name2 : Node_Id)
+      return  Boolean
+   is
+      K1 : Node_Kind := Nkind (Name1);
+      K2 : Node_Kind := Nkind (Name2);
+
+      function Prefix_Node (N : Node_Id) return Node_Id;
+      --  Returns the parent unit name node of a defining program unit name
+      --  or the prefix if N is a selected component or an expanded name.
+
+      function Select_Node (N : Node_Id) return Node_Id;
+      --  Returns the defining identifier node of a defining program unit
+      --  name or  the selector node if N is a selected component or an
+      --  expanded name.
+
+      function Prefix_Node (N : Node_Id) return Node_Id is
+      begin
+         if Nkind (N) = N_Defining_Program_Unit_Name then
+            return Name (N);
+
+         else
+            return Prefix (N);
+         end if;
+      end Prefix_Node;
+
+      function Select_Node (N : Node_Id) return Node_Id is
+      begin
+         if Nkind (N) = N_Defining_Program_Unit_Name then
+            return Defining_Identifier (N);
+
+         else
+            return Selector_Name (N);
+         end if;
+      end Select_Node;
+
+   --  Start of processing for Designate_Next_Unit
+
+   begin
+      if (K1 = N_Identifier or else
+          K1 = N_Defining_Identifier)
+        and then
+         (K2 = N_Identifier or else
+          K2 = N_Defining_Identifier)
+      then
+         return Chars (Name1) = Chars (Name2);
+
+      elsif
+         (K1 = N_Expanded_Name      or else
+          K1 = N_Selected_Component or else
+          K1 = N_Defining_Program_Unit_Name)
+        and then
+         (K2 = N_Expanded_Name      or else
+          K2 = N_Selected_Component or else
+          K2 = N_Defining_Program_Unit_Name)
+      then
+         return
+           (Chars (Select_Node (Name1)) = Chars (Select_Node (Name2)))
+             and then
+               Designate_Same_Unit (Prefix_Node (Name1), Prefix_Node (Name2));
+
+      else
+         return False;
+      end if;
+   end Designate_Same_Unit;
+
+   ----------------------------
+   -- Enclosing_Generic_Body --
+   ----------------------------
+
+   function Enclosing_Generic_Body
+     (E    : Entity_Id)
+      return Node_Id
+   is
+      P    : Node_Id;
+      Decl : Node_Id;
+      Spec : Node_Id;
+
+   begin
+      P := Parent (E);
+
+      while Present (P) loop
+         if Nkind (P) = N_Package_Body
+           or else Nkind (P) = N_Subprogram_Body
+         then
+            Spec := Corresponding_Spec (P);
+
+            if Present (Spec) then
+               Decl := Unit_Declaration_Node (Spec);
+
+               if Nkind (Decl) = N_Generic_Package_Declaration
+                 or else Nkind (Decl) = N_Generic_Subprogram_Declaration
+               then
+                  return P;
+               end if;
+            end if;
+         end if;
+
+         P := Parent (P);
+      end loop;
+
+      return Empty;
+   end Enclosing_Generic_Body;
+
+   -------------------------------
+   -- Enclosing_Lib_Unit_Entity --
+   -------------------------------
+
+   function Enclosing_Lib_Unit_Entity return Entity_Id is
+      Unit_Entity : Entity_Id := Current_Scope;
+
+   begin
+      --  Look for enclosing library unit entity by following scope links.
+      --  Equivalent to, but faster than indexing through the scope stack.
+
+      while (Present (Scope (Unit_Entity))
+        and then Scope (Unit_Entity) /= Standard_Standard)
+        and not Is_Child_Unit (Unit_Entity)
+      loop
+         Unit_Entity := Scope (Unit_Entity);
+      end loop;
+
+      return Unit_Entity;
+   end Enclosing_Lib_Unit_Entity;
+
+   -----------------------------
+   -- Enclosing_Lib_Unit_Node --
+   -----------------------------
+
+   function Enclosing_Lib_Unit_Node (N : Node_Id) return Node_Id is
+      Current_Node : Node_Id := N;
+
+   begin
+      while Present (Current_Node)
+        and then Nkind (Current_Node) /= N_Compilation_Unit
+      loop
+         Current_Node := Parent (Current_Node);
+      end loop;
+
+      if Nkind (Current_Node) /= N_Compilation_Unit then
+         return Empty;
+      end if;
+
+      return Current_Node;
+   end Enclosing_Lib_Unit_Node;
+
+   --------------------------
+   -- Enclosing_Subprogram --
+   --------------------------
+
+   function Enclosing_Subprogram (E : Entity_Id) return Entity_Id is
+      Dynamic_Scope : constant Entity_Id := Enclosing_Dynamic_Scope (E);
+
+   begin
+      if Dynamic_Scope = Standard_Standard then
+         return Empty;
+
+      elsif Ekind (Dynamic_Scope) = E_Subprogram_Body then
+         return Corresponding_Spec (Parent (Parent (Dynamic_Scope)));
+
+      elsif Ekind (Dynamic_Scope) = E_Block then
+         return Enclosing_Subprogram (Dynamic_Scope);
+
+      elsif Ekind (Dynamic_Scope) = E_Task_Type then
+         return Get_Task_Body_Procedure (Dynamic_Scope);
+
+      elsif Convention (Dynamic_Scope) = Convention_Protected then
+         return Protected_Body_Subprogram (Dynamic_Scope);
+
+      else
+         return Dynamic_Scope;
+      end if;
+   end Enclosing_Subprogram;
+
+   ------------------------
+   -- Ensure_Freeze_Node --
+   ------------------------
+
+   procedure Ensure_Freeze_Node (E : Entity_Id) is
+      FN : Node_Id;
+
+   begin
+      if No (Freeze_Node (E)) then
+         FN := Make_Freeze_Entity (Sloc (E));
+         Set_Has_Delayed_Freeze (E);
+         Set_Freeze_Node (E, FN);
+         Set_Access_Types_To_Process (FN, No_Elist);
+         Set_TSS_Elist (FN, No_Elist);
+         Set_Entity (FN, E);
+      end if;
+   end Ensure_Freeze_Node;
+
+   ----------------
+   -- Enter_Name --
+   ----------------
+
+   procedure Enter_Name (Def_Id : Node_Id) is
+      C : constant Entity_Id := Current_Entity (Def_Id);
+      E : constant Entity_Id := Current_Entity_In_Scope (Def_Id);
+      S : constant Entity_Id := Current_Scope;
+
+   begin
+      Generate_Definition (Def_Id);
+
+      --  Add new name to current scope declarations. Check for duplicate
+      --  declaration, which may or may not be a genuine error.
+
+      if Present (E) then
+
+         --  Case of previous entity entered because of a missing declaration
+         --  or else a bad subtype indication. Best is to use the new entity,
+         --  and make the previous one invisible.
+
+         if Etype (E) = Any_Type then
+            Set_Is_Immediately_Visible (E, False);
+
+         --  Case of renaming declaration constructed for package instances.
+         --  if there is an explicit declaration with the same identifier,
+         --  the renaming is not immediately visible any longer, but remains
+         --  visible through selected component notation.
+
+         elsif Nkind (Parent (E)) = N_Package_Renaming_Declaration
+           and then not Comes_From_Source (E)
+         then
+            Set_Is_Immediately_Visible (E, False);
+
+         --  The new entity may be the package renaming, which has the same
+         --  same name as a generic formal which has been seen already.
+
+         elsif Nkind (Parent (Def_Id)) = N_Package_Renaming_Declaration
+            and then not Comes_From_Source (Def_Id)
+         then
+            Set_Is_Immediately_Visible (E, False);
+
+         --  For a fat pointer corresponding to a remote access to subprogram,
+         --  we use the same identifier as the RAS type, so that the proper
+         --  name appears in the stub. This type is only retrieved through
+         --  the RAS type and never by visibility, and is not added to the
+         --  visibility list (see below).
+
+         elsif Nkind (Parent (Def_Id)) = N_Full_Type_Declaration
+           and then Present (Corresponding_Remote_Type (Def_Id))
+         then
+            null;
+
+         --  A controller component for a type extension overrides the
+         --  inherited component.
+
+         elsif Chars (E) = Name_uController then
+            null;
+
+         --  Case of an implicit operation or derived literal. The new entity
+         --  hides the implicit one,  which is removed from all visibility,
+         --  i.e. the entity list of its scope, and homonym chain of its name.
+
+         elsif (Is_Overloadable (E) and then Present (Alias (E)))
+           or else Is_Internal (E)
+           or else (Ekind (E) = E_Enumeration_Literal
+                     and then Is_Derived_Type (Etype (E)))
+         then
+            declare
+               Prev     : Entity_Id;
+               Prev_Vis : Entity_Id;
+
+            begin
+               --  If E is an implicit declaration, it cannot be the first
+               --  entity in the scope.
+
+               Prev := First_Entity (Current_Scope);
+
+               while Next_Entity (Prev) /= E loop
+                  Next_Entity (Prev);
+               end loop;
+
+               Set_Next_Entity (Prev, Next_Entity (E));
+
+               if No (Next_Entity (Prev)) then
+                  Set_Last_Entity (Current_Scope, Prev);
+               end if;
+
+               if E = Current_Entity (E) then
+                     Prev_Vis := Empty;
+               else
+                  Prev_Vis := Current_Entity (E);
+                  while Homonym (Prev_Vis) /= E loop
+                     Prev_Vis := Homonym (Prev_Vis);
+                  end loop;
+               end if;
+
+               if Present (Prev_Vis)  then
+
+                  --  Skip E in the visibility chain
+
+                  Set_Homonym (Prev_Vis, Homonym (E));
+
+               else
+                  Set_Name_Entity_Id (Chars (E), Homonym (E));
+               end if;
+            end;
+
+         --  This section of code could use a comment ???
+
+         elsif Present (Etype (E))
+           and then Is_Concurrent_Type (Etype (E))
+           and then E = Def_Id
+         then
+            return;
+
+         --  In the body or private part of an instance, a type extension
+         --  may introduce a component with the same name as that of an
+         --  actual. The legality rule is not enforced, but the semantics
+         --  of the full type with two components of the same name are not
+         --  clear at this point ???
+
+         elsif In_Instance_Not_Visible  then
+            null;
+
+         --  When compiling a package body, some child units may have become
+         --  visible. They cannot conflict with local entities that hide them.
+
+         elsif Is_Child_Unit (E)
+           and then In_Open_Scopes (Scope (E))
+           and then not Is_Immediately_Visible (E)
+         then
+            null;
+
+         --  Conversely, with front-end inlining we may compile the parent
+         --  body first, and a child unit subsequently. The context is now
+         --  the parent spec, and body entities are not visible.
+
+         elsif Is_Child_Unit (Def_Id)
+           and then Is_Package_Body_Entity (E)
+           and then not In_Package_Body (Current_Scope)
+         then
+            null;
+
+         --  Case of genuine duplicate declaration
+
+         else
+            Error_Msg_Sloc := Sloc (E);
+
+            --  If the previous declaration is an incomplete type declaration
+            --  this may be an attempt to complete it with a private type.
+            --  The following avoids confusing cascaded errors.
+
+            if Nkind (Parent (E)) = N_Incomplete_Type_Declaration
+              and then Nkind (Parent (Def_Id)) = N_Private_Type_Declaration
+            then
+               Error_Msg_N
+                 ("incomplete type cannot be completed" &
+                        " with a private declaration",
+                    Parent (Def_Id));
+               Set_Is_Immediately_Visible (E, False);
+               Set_Full_View (E, Def_Id);
+
+            elsif Ekind (E) = E_Discriminant
+              and then Present (Scope (Def_Id))
+              and then Scope (Def_Id) /= Current_Scope
+            then
+               --  An inherited component of a record conflicts with
+               --  a new discriminant. The discriminant is inserted first
+               --  in the scope, but the error should be posted on it, not
+               --  on the component.
+
+               Error_Msg_Sloc := Sloc (Def_Id);
+               Error_Msg_N ("& conflicts with declaration#", E);
+               return;
+
+            else
+               Error_Msg_N ("& conflicts with declaration#", Def_Id);
+
+               --  Avoid cascaded messages with duplicate components in
+               --  derived types.
+
+               if Ekind (E) = E_Component
+                 or else Ekind (E) = E_Discriminant
+               then
+                  return;
+               end if;
+            end if;
+
+            if Nkind (Parent (Parent (Def_Id)))
+                 = N_Generic_Subprogram_Declaration
+              and then Def_Id =
+                Defining_Entity (Specification (Parent (Parent (Def_Id))))
+            then
+               Error_Msg_N ("\generic units cannot be overloaded", Def_Id);
+            end if;
+
+            --  If entity is in standard, then we are in trouble, because
+            --  it means that we have a library package with a duplicated
+            --  name. That's hard to recover from, so abort!
+
+            if S = Standard_Standard then
+               raise Unrecoverable_Error;
+
+            --  Otherwise we continue with the declaration. Having two
+            --  identical declarations should not cause us too much trouble!
+
+            else
+               null;
+            end if;
+         end if;
+      end if;
+
+      --  If we fall through, declaration is OK , or OK enough to continue
+
+      --  If Def_Id is a discriminant or a record component we are in the
+      --  midst of inheriting components in a derived record definition.
+      --  Preserve their Ekind and Etype.
+
+      if Ekind (Def_Id) = E_Discriminant
+        or else Ekind (Def_Id) = E_Component
+      then
+         null;
+
+      --  If a type is already set, leave it alone (happens whey a type
+      --  declaration is reanalyzed following a call to the optimizer)
+
+      elsif Present (Etype (Def_Id)) then
+         null;
+
+      --  Otherwise, the kind E_Void insures that premature uses of the entity
+      --  will be detected. Any_Type insures that no cascaded errors will occur
+
+      else
+         Set_Ekind (Def_Id, E_Void);
+         Set_Etype (Def_Id, Any_Type);
+      end if;
+
+      --  Inherited discriminants and components in derived record types are
+      --  immediately visible. Itypes are not.
+
+      if Ekind (Def_Id) = E_Discriminant
+        or else Ekind (Def_Id) = E_Component
+        or else (No (Corresponding_Remote_Type (Def_Id))
+                 and then not Is_Itype (Def_Id))
+      then
+         Set_Is_Immediately_Visible (Def_Id);
+         Set_Current_Entity         (Def_Id);
+      end if;
+
+      Set_Homonym       (Def_Id, C);
+      Append_Entity     (Def_Id, S);
+      Set_Public_Status (Def_Id);
+
+      --  Warn if new entity hides an old one
+
+      if Warn_On_Hiding
+        and then Length_Of_Name (Chars (C)) /= 1
+        and then Present (C)
+        and then Comes_From_Source (C)
+        and then Comes_From_Source (Def_Id)
+        and then In_Extended_Main_Source_Unit (Def_Id)
+      then
+         Error_Msg_Sloc := Sloc (C);
+         Error_Msg_N ("declaration hides &#?", Def_Id);
+      end if;
+
+   end Enter_Name;
+
+   -------------------------------------
+   -- Find_Corresponding_Discriminant --
+   -------------------------------------
+
+   function Find_Corresponding_Discriminant
+     (Id   : Node_Id;
+      Typ  : Entity_Id)
+      return Entity_Id
+   is
+      Par_Disc : Entity_Id;
+      Old_Disc : Entity_Id;
+      New_Disc : Entity_Id;
+
+   begin
+      Par_Disc := Original_Record_Component (Original_Discriminant (Id));
+      Old_Disc := First_Discriminant (Scope (Par_Disc));
+
+      if Is_Class_Wide_Type (Typ) then
+         New_Disc := First_Discriminant (Root_Type (Typ));
+      else
+         New_Disc := First_Discriminant (Typ);
+      end if;
+
+      while Present (Old_Disc) and then Present (New_Disc) loop
+         if Old_Disc = Par_Disc  then
+            return New_Disc;
+         else
+            Next_Discriminant (Old_Disc);
+            Next_Discriminant (New_Disc);
+         end if;
+      end loop;
+
+      --  Should always find it
+
+      raise Program_Error;
+   end Find_Corresponding_Discriminant;
+
+   ------------------
+   -- First_Actual --
+   ------------------
+
+   function First_Actual (Node : Node_Id) return Node_Id is
+      N : Node_Id;
+
+   begin
+      if No (Parameter_Associations (Node)) then
+         return Empty;
+      end if;
+
+      N := First (Parameter_Associations (Node));
+
+      if Nkind (N) = N_Parameter_Association then
+         return First_Named_Actual (Node);
+      else
+         return N;
+      end if;
+   end First_Actual;
+
+   -------------------------
+   -- Full_Qualified_Name --
+   -------------------------
+
+   function Full_Qualified_Name (E : Entity_Id) return String_Id is
+
+      Res : String_Id;
+
+      function Internal_Full_Qualified_Name (E : Entity_Id) return String_Id;
+      --  Compute recursively the qualified name without NUL at the end.
+
+      function Internal_Full_Qualified_Name (E : Entity_Id) return String_Id is
+         Ent         : Entity_Id := E;
+         Parent_Name : String_Id := No_String;
+
+      begin
+         --  Deals properly with child units
+
+         if Nkind (Ent) = N_Defining_Program_Unit_Name then
+            Ent := Defining_Identifier (Ent);
+         end if;
+
+         --  Compute recursively the qualification. Only "Standard" has no
+         --  scope.
+
+         if Present (Scope (Scope (Ent))) then
+            Parent_Name := Internal_Full_Qualified_Name (Scope (Ent));
+         end if;
+
+         --  Every entity should have a name except some expanded blocks
+         --  don't bother about those.
+
+         if Chars (Ent) = No_Name then
+            return Parent_Name;
+         end if;
+
+         --  Add a period between Name and qualification
+
+         if Parent_Name /= No_String then
+            Start_String (Parent_Name);
+            Store_String_Char (Get_Char_Code ('.'));
+
+         else
+            Start_String;
+         end if;
+
+         --  Generates the entity name in upper case
+
+         Get_Name_String (Chars (Ent));
+         Set_All_Upper_Case;
+         Store_String_Chars (Name_Buffer (1 .. Name_Len));
+         return End_String;
+      end Internal_Full_Qualified_Name;
+
+   begin
+      Res := Internal_Full_Qualified_Name (E);
+      Store_String_Char (Get_Char_Code (ASCII.nul));
+      return End_String;
+   end Full_Qualified_Name;
+
+   -----------------------
+   -- Gather_Components --
+   -----------------------
+
+   procedure Gather_Components
+     (Typ           : Entity_Id;
+      Comp_List     : Node_Id;
+      Governed_By   : List_Id;
+      Into          : Elist_Id;
+      Report_Errors : out Boolean)
+   is
+      Assoc           : Node_Id;
+      Variant         : Node_Id;
+      Discrete_Choice : Node_Id;
+      Comp_Item       : Node_Id;
+
+      Discrim       : Entity_Id;
+      Discrim_Name  : Node_Id;
+      Discrim_Value : Node_Id;
+
+   begin
+      Report_Errors := False;
+
+      if No (Comp_List) or else Null_Present (Comp_List) then
+         return;
+
+      elsif Present (Component_Items (Comp_List)) then
+         Comp_Item := First (Component_Items (Comp_List));
+
+      else
+         Comp_Item := Empty;
+      end if;
+
+      while Present (Comp_Item) loop
+
+         --  Skip the tag of a tagged record, as well as all items
+         --  that are not user components (anonymous types, rep clauses,
+         --  Parent field, controller field).
+
+         if Nkind (Comp_Item) = N_Component_Declaration
+           and then Chars (Defining_Identifier (Comp_Item)) /= Name_uTag
+           and then Chars (Defining_Identifier (Comp_Item)) /= Name_uParent
+           and then Chars (Defining_Identifier (Comp_Item)) /= Name_uController
+         then
+            Append_Elmt (Defining_Identifier (Comp_Item), Into);
+         end if;
+
+         Next (Comp_Item);
+      end loop;
+
+      if No (Variant_Part (Comp_List)) then
+         return;
+      else
+         Discrim_Name := Name (Variant_Part (Comp_List));
+         Variant := First_Non_Pragma (Variants (Variant_Part (Comp_List)));
+      end if;
+
+      --  Look for the discriminant that governs this variant part.
+      --  The discriminant *must* be in the Governed_By List
+
+      Assoc := First (Governed_By);
+      Find_Constraint : loop
+         Discrim := First (Choices (Assoc));
+         exit Find_Constraint when Chars (Discrim_Name) = Chars (Discrim)
+           or else (Present (Corresponding_Discriminant (Entity (Discrim)))
+                      and then
+                    Chars (Corresponding_Discriminant (Entity (Discrim)))
+                         = Chars  (Discrim_Name))
+           or else Chars (Original_Record_Component (Entity (Discrim)))
+                         = Chars (Discrim_Name);
+
+         if No (Next (Assoc)) then
+            if not Is_Constrained (Typ)
+              and then Is_Derived_Type (Typ)
+              and then Present (Girder_Constraint (Typ))
+            then
+
+               --  If the type is a tagged type with inherited discriminants,
+               --  use the girder constraint on the parent in order to find
+               --  the values of discriminants that are otherwise hidden by an
+               --  explicit constraint. Renamed discriminants are handled in
+               --  the code above.
+
+               declare
+                  D : Entity_Id;
+                  C : Elmt_Id;
+
+               begin
+                  D := First_Discriminant (Etype (Typ));
+                  C := First_Elmt (Girder_Constraint (Typ));
+
+                  while Present (D)
+                    and then Present (C)
+                  loop
+                     if Chars (Discrim_Name) = Chars (D) then
+                        Assoc :=
+                          Make_Component_Association (Sloc (Typ),
+                            New_List
+                              (New_Occurrence_Of (D, Sloc (Typ))),
+                            Duplicate_Subexpr (Node (C)));
+                        exit Find_Constraint;
+                     end if;
+
+                     D := Next_Discriminant (D);
+                     Next_Elmt (C);
+                  end loop;
+               end;
+            end if;
+         end if;
+
+         if No (Next (Assoc)) then
+            Error_Msg_NE (" missing value for discriminant&",
+              First (Governed_By), Discrim_Name);
+            Report_Errors := True;
+            return;
+         end if;
+
+         Next (Assoc);
+      end loop Find_Constraint;
+
+      Discrim_Value := Expression (Assoc);
+
+      if not Is_OK_Static_Expression (Discrim_Value) then
+         Error_Msg_NE
+           ("value for discriminant & must be static", Discrim_Value, Discrim);
+         Report_Errors := True;
+         return;
+      end if;
+
+      Search_For_Discriminant_Value : declare
+         Low  : Node_Id;
+         High : Node_Id;
+
+         UI_High          : Uint;
+         UI_Low           : Uint;
+         UI_Discrim_Value : constant Uint := Expr_Value (Discrim_Value);
+
+      begin
+         Find_Discrete_Value : while Present (Variant) loop
+            Discrete_Choice := First (Discrete_Choices (Variant));
+            while Present (Discrete_Choice) loop
+
+               exit Find_Discrete_Value when
+                 Nkind (Discrete_Choice) = N_Others_Choice;
+
+               Get_Index_Bounds (Discrete_Choice, Low, High);
+
+               UI_Low  := Expr_Value (Low);
+               UI_High := Expr_Value (High);
+
+               exit Find_Discrete_Value when
+                 UI_Low <= UI_Discrim_Value
+                   and then
+                 UI_High >= UI_Discrim_Value;
+
+               Next (Discrete_Choice);
+            end loop;
+
+            Next_Non_Pragma (Variant);
+         end loop Find_Discrete_Value;
+      end Search_For_Discriminant_Value;
+
+      if No (Variant) then
+         Error_Msg_NE
+           ("value of discriminant & is out of range", Discrim_Value, Discrim);
+         Report_Errors := True;
+         return;
+      end  if;
+
+      --  If we have found the corresponding choice, recursively add its
+      --  components to the Into list.
+
+      Gather_Components (Empty,
+        Component_List (Variant), Governed_By, Into, Report_Errors);
+   end Gather_Components;
+
+   ------------------------
+   -- Get_Actual_Subtype --
+   ------------------------
+
+   function Get_Actual_Subtype (N : Node_Id) return Entity_Id is
+      Typ  : constant Entity_Id := Etype (N);
+      Utyp : Entity_Id := Underlying_Type (Typ);
+      Decl : Node_Id;
+      Atyp : Entity_Id;
+
+   begin
+      if not Present (Utyp) then
+         Utyp := Typ;
+      end if;
+
+      --  If what we have is an identifier that references a subprogram
+      --  formal, or a variable or constant object, then we get the actual
+      --  subtype from the referenced entity if one has been built.
+
+      if Nkind (N) = N_Identifier
+        and then
+          (Is_Formal (Entity (N))
+            or else Ekind (Entity (N)) = E_Constant
+            or else Ekind (Entity (N)) = E_Variable)
+        and then Present (Actual_Subtype (Entity (N)))
+      then
+         return Actual_Subtype (Entity (N));
+
+      --  Actual subtype of unchecked union is always itself. We never need
+      --  the "real" actual subtype. If we did, we couldn't get it anyway
+      --  because the discriminant is not available. The restrictions on
+      --  Unchecked_Union are designed to make sure that this is OK.
+
+      elsif Is_Unchecked_Union (Utyp) then
+         return Typ;
+
+      --  Here for the unconstrained case, we must find actual subtype
+      --  No actual subtype is available, so we must build it on the fly.
+
+      --  Checking the type, not the underlying type, for constrainedness
+      --  seems to be necessary. Maybe all the tests should be on the type???
+
+      elsif (not Is_Constrained (Typ))
+           and then (Is_Array_Type (Utyp)
+                      or else (Is_Record_Type (Utyp)
+                                and then Has_Discriminants (Utyp)))
+           and then not Has_Unknown_Discriminants (Utyp)
+           and then not (Ekind (Utyp) = E_String_Literal_Subtype)
+      then
+         --  Nothing to do if in default expression
+
+         if In_Default_Expression then
+            return Typ;
+
+         --  Else build the actual subtype
+
+         else
+            Decl := Build_Actual_Subtype (Typ, N);
+            Atyp := Defining_Identifier (Decl);
+
+            --  If Build_Actual_Subtype generated a new declaration then use it
+
+            if Atyp /= Typ then
+
+               --  The actual subtype is an Itype, so analyze the declaration,
+               --  but do not attach it to the tree, to get the type defined.
+
+               Set_Parent (Decl, N);
+               Set_Is_Itype (Atyp);
+               Analyze (Decl, Suppress => All_Checks);
+               Set_Associated_Node_For_Itype (Atyp, N);
+               Set_Has_Delayed_Freeze (Atyp, False);
+
+               --  We need to freeze the actual subtype immediately. This is
+               --  needed, because otherwise this Itype will not get frozen
+               --  at all, and it is always safe to freeze on creation because
+               --  any associated types must be frozen at this point.
+
+               Freeze_Itype (Atyp, N);
+               return Atyp;
+
+            --  Otherwise we did not build a declaration, so return original
+
+            else
+               return Typ;
+            end if;
+         end if;
+
+      --  For all remaining cases, the actual subtype is the same as
+      --  the nominal type.
+
+      else
+         return Typ;
+      end if;
+   end Get_Actual_Subtype;
+
+   -------------------------------------
+   -- Get_Actual_Subtype_If_Available --
+   -------------------------------------
+
+   function Get_Actual_Subtype_If_Available (N : Node_Id) return Entity_Id is
+      Typ  : constant Entity_Id := Etype (N);
+
+   begin
+      --  If what we have is an identifier that references a subprogram
+      --  formal, or a variable or constant object, then we get the actual
+      --  subtype from the referenced entity if one has been built.
+
+      if Nkind (N) = N_Identifier
+        and then
+          (Is_Formal (Entity (N))
+            or else Ekind (Entity (N)) = E_Constant
+            or else Ekind (Entity (N)) = E_Variable)
+        and then Present (Actual_Subtype (Entity (N)))
+      then
+         return Actual_Subtype (Entity (N));
+
+      --  Otherwise the Etype of N is returned unchanged
+
+      else
+         return Typ;
+      end if;
+   end Get_Actual_Subtype_If_Available;
+
+   -------------------------------
+   -- Get_Default_External_Name --
+   -------------------------------
+
+   function Get_Default_External_Name (E : Node_Or_Entity_Id) return Node_Id is
+   begin
+      Get_Decoded_Name_String (Chars (E));
+
+      if Opt.External_Name_Imp_Casing = Uppercase then
+         Set_Casing (All_Upper_Case);
+      else
+         Set_Casing (All_Lower_Case);
+      end if;
+
+      return
+        Make_String_Literal (Sloc (E),
+          Strval => String_From_Name_Buffer);
+
+   end Get_Default_External_Name;
+
+   ---------------------------
+   -- Get_Enum_Lit_From_Pos --
+   ---------------------------
+
+   function Get_Enum_Lit_From_Pos
+     (T    : Entity_Id;
+      Pos  : Uint;
+      Loc  : Source_Ptr)
+      return Node_Id
+   is
+      Lit : Node_Id;
+      P   : constant Nat := UI_To_Int (Pos);
+
+   begin
+      --  In the case where the literal is either of type Wide_Character
+      --  or Character or of a type derived from them, there needs to be
+      --  some special handling since there is no explicit chain of
+      --  literals to search. Instead, an N_Character_Literal node is
+      --  created with the appropriate Char_Code and Chars fields.
+
+      if Root_Type (T) = Standard_Character
+        or else Root_Type (T) = Standard_Wide_Character
+      then
+         Set_Character_Literal_Name (Char_Code (P));
+         return
+           Make_Character_Literal (Loc,
+             Chars => Name_Find,
+             Char_Literal_Value => Char_Code (P));
+
+      --  For all other cases, we have a complete table of literals, and
+      --  we simply iterate through the chain of literal until the one
+      --  with the desired position value is found.
+      --
+
+      else
+         Lit := First_Literal (Base_Type (T));
+         for J in 1 .. P loop
+            Next_Literal (Lit);
+         end loop;
+
+         return New_Occurrence_Of (Lit, Loc);
+      end if;
+   end Get_Enum_Lit_From_Pos;
+
+   ----------------------
+   -- Get_Index_Bounds --
+   ----------------------
+
+   procedure Get_Index_Bounds (N : Node_Id; L, H : out Node_Id) is
+      Kind : constant Node_Kind := Nkind (N);
+
+   begin
+      if Kind = N_Range then
+         L := Low_Bound (N);
+         H := High_Bound (N);
+
+      elsif Kind = N_Subtype_Indication then
+         L := Low_Bound  (Range_Expression (Constraint (N)));
+         H := High_Bound (Range_Expression (Constraint (N)));
+
+      elsif Is_Entity_Name (N) and then Is_Type (Entity (N)) then
+         if Error_Posted (Scalar_Range (Entity (N))) then
+            L := Error;
+            H := Error;
+
+         elsif Nkind (Scalar_Range (Entity (N))) = N_Subtype_Indication then
+            Get_Index_Bounds (Scalar_Range (Entity (N)), L, H);
+
+         else
+            L := Low_Bound  (Scalar_Range (Entity (N)));
+            H := High_Bound (Scalar_Range (Entity (N)));
+         end if;
+
+      else
+         --  N is an expression, indicating a range with one value.
+
+         L := N;
+         H := N;
+      end if;
+
+   end Get_Index_Bounds;
+
+   ------------------------
+   -- Get_Name_Entity_Id --
+   ------------------------
+
+   function Get_Name_Entity_Id (Id : Name_Id) return Entity_Id is
+   begin
+      return Entity_Id (Get_Name_Table_Info (Id));
+   end Get_Name_Entity_Id;
+
+   ---------------------------
+   -- Get_Referenced_Object --
+   ---------------------------
+
+   function Get_Referenced_Object (N : Node_Id) return Node_Id is
+      R   : Node_Id := N;
+
+   begin
+      while Is_Entity_Name (R)
+        and then Present (Renamed_Object (Entity (R)))
+      loop
+         R := Renamed_Object (Entity (R));
+      end loop;
+
+      return R;
+   end Get_Referenced_Object;
+
+   -------------------------
+   -- Get_Subprogram_Body --
+   -------------------------
+
+   function Get_Subprogram_Body (E : Entity_Id) return Node_Id is
+      Decl : Node_Id;
+
+   begin
+      Decl := Unit_Declaration_Node (E);
+
+      if Nkind (Decl) = N_Subprogram_Body then
+         return Decl;
+
+      else           --  Nkind (Decl) = N_Subprogram_Declaration
+
+         if Present (Corresponding_Body (Decl)) then
+            return Unit_Declaration_Node (Corresponding_Body (Decl));
+
+         else        --  imported subprogram.
+            return Empty;
+         end if;
+      end if;
+   end Get_Subprogram_Body;
+
+   -----------------------------
+   -- Get_Task_Body_Procedure --
+   -----------------------------
+
+   function Get_Task_Body_Procedure (E : Entity_Id) return Node_Id is
+   begin
+      return Task_Body_Procedure (Declaration_Node (Root_Type (E)));
+   end Get_Task_Body_Procedure;
+
+   --------------------
+   -- Has_Infinities --
+   --------------------
+
+   function Has_Infinities (E : Entity_Id) return Boolean is
+   begin
+      return
+        Is_Floating_Point_Type (E)
+          and then Nkind (Scalar_Range (E)) = N_Range
+          and then Includes_Infinities (Scalar_Range (E));
+   end Has_Infinities;
+
+   ---------------------------
+   -- Has_Private_Component --
+   ---------------------------
+
+   function Has_Private_Component (Type_Id : Entity_Id) return Boolean is
+      Btype     : Entity_Id := Base_Type (Type_Id);
+      Component : Entity_Id;
+
+   begin
+      if Error_Posted (Type_Id)
+        or else Error_Posted (Btype)
+      then
+         return False;
+      end if;
+
+      if Is_Class_Wide_Type (Btype) then
+         Btype := Root_Type (Btype);
+      end if;
+
+      if Is_Private_Type (Btype) then
+         declare
+            UT : constant Entity_Id := Underlying_Type (Btype);
+         begin
+            if No (UT) then
+
+               if No (Full_View (Btype)) then
+                  return not Is_Generic_Type (Btype)
+                    and then not Is_Generic_Type (Root_Type (Btype));
+
+               else
+                  return not Is_Generic_Type (Root_Type (Full_View (Btype)));
+               end if;
+
+            else
+               return not Is_Frozen (UT) and then Has_Private_Component (UT);
+            end if;
+         end;
+      elsif Is_Array_Type (Btype) then
+         return Has_Private_Component (Component_Type (Btype));
+
+      elsif Is_Record_Type (Btype) then
+
+         Component := First_Component (Btype);
+         while Present (Component) loop
+
+            if Has_Private_Component (Etype (Component)) then
+               return True;
+            end if;
+
+            Next_Component (Component);
+         end loop;
+
+         return False;
+
+      elsif Is_Protected_Type (Btype)
+        and then Present (Corresponding_Record_Type (Btype))
+      then
+         return Has_Private_Component (Corresponding_Record_Type (Btype));
+
+      else
+         return False;
+      end if;
+   end Has_Private_Component;
+
+   --------------------------
+   -- Has_Tagged_Component --
+   --------------------------
+
+   function Has_Tagged_Component (Typ : Entity_Id) return Boolean is
+      Comp : Entity_Id;
+
+   begin
+      if Is_Private_Type (Typ)
+        and then Present (Underlying_Type (Typ))
+      then
+         return Has_Tagged_Component (Underlying_Type (Typ));
+
+      elsif Is_Array_Type (Typ) then
+         return Has_Tagged_Component (Component_Type (Typ));
+
+      elsif Is_Tagged_Type (Typ) then
+         return True;
+
+      elsif Is_Record_Type (Typ) then
+         Comp := First_Component (Typ);
+
+         while Present (Comp) loop
+            if Has_Tagged_Component (Etype (Comp)) then
+               return True;
+            end if;
+
+            Comp := Next_Component (Typ);
+         end loop;
+
+         return False;
+
+      else
+         return False;
+      end if;
+   end Has_Tagged_Component;
+
+   -----------------
+   -- In_Instance --
+   -----------------
+
+   function In_Instance return Boolean is
+      S : Entity_Id := Current_Scope;
+
+   begin
+      while Present (S)
+        and then S /= Standard_Standard
+      loop
+         if (Ekind (S) = E_Function
+              or else Ekind (S) = E_Package
+              or else Ekind (S) = E_Procedure)
+           and then Is_Generic_Instance (S)
+         then
+            return True;
+         end if;
+
+         S := Scope (S);
+      end loop;
+
+      return False;
+   end In_Instance;
+
+   ----------------------
+   -- In_Instance_Body --
+   ----------------------
+
+   function In_Instance_Body return Boolean is
+      S : Entity_Id := Current_Scope;
+
+   begin
+      while Present (S)
+        and then S /= Standard_Standard
+      loop
+         if (Ekind (S) = E_Function
+              or else Ekind (S) = E_Procedure)
+           and then Is_Generic_Instance (S)
+         then
+            return True;
+
+         elsif Ekind (S) = E_Package
+           and then In_Package_Body (S)
+           and then Is_Generic_Instance (S)
+         then
+            return True;
+         end if;
+
+         S := Scope (S);
+      end loop;
+
+      return False;
+   end In_Instance_Body;
+
+   -----------------------------
+   -- In_Instance_Not_Visible --
+   -----------------------------
+
+   function In_Instance_Not_Visible return Boolean is
+      S : Entity_Id := Current_Scope;
+
+   begin
+      while Present (S)
+        and then S /= Standard_Standard
+      loop
+         if (Ekind (S) = E_Function
+              or else Ekind (S) = E_Procedure)
+           and then Is_Generic_Instance (S)
+         then
+            return True;
+
+         elsif Ekind (S) = E_Package
+           and then (In_Package_Body (S) or else In_Private_Part (S))
+           and then Is_Generic_Instance (S)
+         then
+            return True;
+         end if;
+
+         S := Scope (S);
+      end loop;
+
+      return False;
+   end In_Instance_Not_Visible;
+
+   ------------------------------
+   -- In_Instance_Visible_Part --
+   ------------------------------
+
+   function In_Instance_Visible_Part return Boolean is
+      S : Entity_Id := Current_Scope;
+
+   begin
+      while Present (S)
+        and then S /= Standard_Standard
+      loop
+         if Ekind (S) = E_Package
+           and then Is_Generic_Instance (S)
+           and then not In_Package_Body (S)
+           and then not In_Private_Part (S)
+         then
+            return True;
+         end if;
+
+         S := Scope (S);
+      end loop;
+
+      return False;
+   end In_Instance_Visible_Part;
+
+   --------------------------------------
+   -- In_Subprogram_Or_Concurrent_Unit --
+   --------------------------------------
+
+   function In_Subprogram_Or_Concurrent_Unit return Boolean is
+      E : Entity_Id;
+      K : Entity_Kind;
+
+   begin
+      --  Use scope chain to check successively outer scopes
+
+      E := Current_Scope;
+      loop
+         K := Ekind (E);
+
+         if K in Subprogram_Kind
+           or else K in Concurrent_Kind
+           or else K = E_Generic_Procedure
+           or else K = E_Generic_Function
+         then
+            return True;
+
+         elsif E = Standard_Standard then
+            return False;
+         end if;
+
+         E := Scope (E);
+      end loop;
+
+   end In_Subprogram_Or_Concurrent_Unit;
+
+   ---------------------
+   -- In_Visible_Part --
+   ---------------------
+
+   function In_Visible_Part (Scope_Id : Entity_Id) return Boolean is
+   begin
+      return
+        Is_Package (Scope_Id)
+          and then In_Open_Scopes (Scope_Id)
+          and then not In_Package_Body (Scope_Id)
+          and then not In_Private_Part (Scope_Id);
+   end In_Visible_Part;
+
+   -------------------
+   -- Is_AAMP_Float --
+   -------------------
+
+   function Is_AAMP_Float (E : Entity_Id) return Boolean is
+   begin
+      pragma Assert (Is_Type (E));
+
+      return AAMP_On_Target
+         and then Is_Floating_Point_Type (E)
+         and then E = Base_Type (E);
+   end Is_AAMP_Float;
+
+   -------------------------
+   -- Is_Actual_Parameter --
+   -------------------------
+
+   function Is_Actual_Parameter (N : Node_Id) return Boolean is
+      PK : constant Node_Kind := Nkind (Parent (N));
+
+   begin
+      case PK is
+         when N_Parameter_Association =>
+            return N = Explicit_Actual_Parameter (Parent (N));
+
+         when N_Function_Call | N_Procedure_Call_Statement =>
+            return Is_List_Member (N)
+              and then
+                List_Containing (N) = Parameter_Associations (Parent (N));
+
+         when others =>
+            return False;
+      end case;
+   end Is_Actual_Parameter;
+
+   ---------------------
+   -- Is_Aliased_View --
+   ---------------------
+
+   function Is_Aliased_View (Obj : Node_Id) return Boolean is
+      E : Entity_Id;
+
+   begin
+      if Is_Entity_Name (Obj) then
+
+         --  Shouldn't we check that we really have an object here?
+         --  If we do, then a-caldel.adb blows up mysteriously ???
+
+         E := Entity (Obj);
+
+         return Is_Aliased (E)
+           or else (Present (Renamed_Object (E))
+                     and then Is_Aliased_View (Renamed_Object (E)))
+
+           or else ((Is_Formal (E)
+                      or else Ekind (E) = E_Generic_In_Out_Parameter
+                      or else Ekind (E) = E_Generic_In_Parameter)
+                    and then Is_Tagged_Type (Etype (E)))
+
+           or else ((Ekind (E) = E_Task_Type or else
+                     Ekind (E) = E_Protected_Type)
+                    and then In_Open_Scopes (E))
+
+            --  Current instance of type
+
+           or else (Is_Type (E) and then E = Current_Scope)
+           or else (Is_Incomplete_Or_Private_Type (E)
+                     and then Full_View (E) = Current_Scope);
+
+      elsif Nkind (Obj) = N_Selected_Component then
+         return Is_Aliased (Entity (Selector_Name (Obj)));
+
+      elsif Nkind (Obj) = N_Indexed_Component then
+         return Has_Aliased_Components (Etype (Prefix (Obj)))
+           or else
+             (Is_Access_Type (Etype (Prefix (Obj)))
+               and then
+              Has_Aliased_Components
+                (Designated_Type (Etype (Prefix (Obj)))));
+
+      elsif Nkind (Obj) = N_Unchecked_Type_Conversion
+        or else Nkind (Obj) = N_Type_Conversion
+      then
+         return Is_Tagged_Type (Etype (Obj))
+           or else Is_Aliased_View (Expression (Obj));
+
+      elsif Nkind (Obj) = N_Explicit_Dereference then
+         return Nkind (Original_Node (Obj)) /= N_Function_Call;
+
+      else
+         return False;
+      end if;
+   end Is_Aliased_View;
+
+   ----------------------
+   -- Is_Atomic_Object --
+   ----------------------
+
+   function Is_Atomic_Object (N : Node_Id) return Boolean is
+
+      function Object_Has_Atomic_Components (N : Node_Id) return Boolean;
+      --  Determines if given object has atomic components
+
+      function Is_Atomic_Prefix (N : Node_Id) return Boolean;
+      --  If prefix is an implicit dereference, examine designated type.
+
+      function Is_Atomic_Prefix (N : Node_Id) return Boolean is
+      begin
+         if Is_Access_Type (Etype (N)) then
+            return
+              Has_Atomic_Components (Designated_Type (Etype (N)));
+         else
+            return Object_Has_Atomic_Components (N);
+         end if;
+      end Is_Atomic_Prefix;
+
+      function Object_Has_Atomic_Components (N : Node_Id) return Boolean is
+      begin
+         if Has_Atomic_Components (Etype (N))
+           or else Is_Atomic (Etype (N))
+         then
+            return True;
+
+         elsif Is_Entity_Name (N)
+           and then (Has_Atomic_Components (Entity (N))
+                      or else Is_Atomic (Entity (N)))
+         then
+            return True;
+
+         elsif Nkind (N) = N_Indexed_Component
+           or else Nkind (N) = N_Selected_Component
+         then
+            return Is_Atomic_Prefix (Prefix (N));
+
+         else
+            return False;
+         end if;
+      end Object_Has_Atomic_Components;
+
+   --  Start of processing for Is_Atomic_Object
+
+   begin
+      if Is_Atomic (Etype (N))
+        or else (Is_Entity_Name (N) and then Is_Atomic (Entity (N)))
+      then
+         return True;
+
+      elsif Nkind (N) = N_Indexed_Component
+        or else Nkind (N) = N_Selected_Component
+      then
+         return Is_Atomic_Prefix (Prefix (N));
+
+      else
+         return False;
+      end if;
+   end Is_Atomic_Object;
+
+   ----------------------------------------------
+   -- Is_Dependent_Component_Of_Mutable_Object --
+   ----------------------------------------------
+
+   function Is_Dependent_Component_Of_Mutable_Object
+     (Object : Node_Id)
+      return   Boolean
+   is
+      P           : Node_Id;
+      Prefix_Type : Entity_Id;
+      P_Aliased   : Boolean := False;
+      Comp        : Entity_Id;
+
+      function Has_Dependent_Constraint (Comp : Entity_Id) return Boolean;
+      --  Returns True if and only if Comp has a constrained subtype
+      --  that depends on a discriminant.
+
+      function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean;
+      --  Returns True if and only if Comp is declared within a variant part.
+
+      ------------------------------
+      -- Has_Dependent_Constraint --
+      ------------------------------
+
+      function Has_Dependent_Constraint (Comp : Entity_Id) return Boolean is
+         Comp_Decl  : constant Node_Id   := Parent (Comp);
+         Subt_Indic : constant Node_Id   := Subtype_Indication (Comp_Decl);
+         Constr     : Node_Id;
+         Assn       : Node_Id;
+
+      begin
+         if Nkind (Subt_Indic) = N_Subtype_Indication then
+            Constr := Constraint (Subt_Indic);
+
+            if Nkind (Constr) = N_Index_Or_Discriminant_Constraint then
+               Assn := First (Constraints (Constr));
+               while Present (Assn) loop
+                  case Nkind (Assn) is
+                     when N_Subtype_Indication |
+                          N_Range              |
+                          N_Identifier
+                     =>
+                        if Depends_On_Discriminant (Assn) then
+                           return True;
+                        end if;
+
+                     when N_Discriminant_Association =>
+                        if Depends_On_Discriminant (Expression (Assn)) then
+                           return True;
+                        end if;
+
+                     when others =>
+                        null;
+
+                  end case;
+
+                  Next (Assn);
+               end loop;
+            end if;
+         end if;
+
+         return False;
+      end Has_Dependent_Constraint;
+
+      --------------------------------
+      -- Is_Declared_Within_Variant --
+      --------------------------------
+
+      function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean is
+         Comp_Decl : constant Node_Id   := Parent (Comp);
+         Comp_List : constant Node_Id   := Parent (Comp_Decl);
+
+      begin
+         return Nkind (Parent (Comp_List)) = N_Variant;
+      end Is_Declared_Within_Variant;
+
+   --  Start of processing for Is_Dependent_Component_Of_Mutable_Object
+
+   begin
+      if Is_Variable (Object) then
+
+         if Nkind (Object) = N_Selected_Component then
+            P := Prefix (Object);
+            Prefix_Type := Etype (P);
+
+            if Is_Entity_Name (P) then
+
+               if Ekind (Entity (P)) = E_Generic_In_Out_Parameter then
+                  Prefix_Type := Base_Type (Prefix_Type);
+               end if;
+
+               if Is_Aliased (Entity (P)) then
+                  P_Aliased := True;
+               end if;
+
+            else
+               --  Check for prefix being an aliased component ???
+               null;
+            end if;
+
+            if Is_Access_Type (Prefix_Type)
+              or else Nkind (P) = N_Explicit_Dereference
+            then
+               return False;
+            end if;
+
+            Comp :=
+              Original_Record_Component (Entity (Selector_Name (Object)));
+
+            if not Is_Constrained (Prefix_Type)
+              and then not Is_Indefinite_Subtype (Prefix_Type)
+              and then (Is_Declared_Within_Variant (Comp)
+                          or else Has_Dependent_Constraint (Comp))
+              and then not P_Aliased
+            then
+               return True;
+
+            else
+               return
+                 Is_Dependent_Component_Of_Mutable_Object (Prefix (Object));
+
+            end if;
+
+         elsif Nkind (Object) = N_Indexed_Component
+           or else Nkind (Object) = N_Slice
+         then
+            return Is_Dependent_Component_Of_Mutable_Object (Prefix (Object));
+         end if;
+      end if;
+
+      return False;
+   end Is_Dependent_Component_Of_Mutable_Object;
+
+   --------------
+   -- Is_False --
+   --------------
+
+   function Is_False (U : Uint) return Boolean is
+   begin
+      return (U = 0);
+   end Is_False;
+
+   ---------------------------
+   -- Is_Fixed_Model_Number --
+   ---------------------------
+
+   function Is_Fixed_Model_Number (U : Ureal; T : Entity_Id) return Boolean is
+      S : constant Ureal := Small_Value (T);
+      M : Urealp.Save_Mark;
+      R : Boolean;
+
+   begin
+      M := Urealp.Mark;
+      R := (U = UR_Trunc (U / S) * S);
+      Urealp.Release (M);
+      return R;
+   end Is_Fixed_Model_Number;
+
+   -------------------------------
+   -- Is_Fully_Initialized_Type --
+   -------------------------------
+
+   function Is_Fully_Initialized_Type (Typ : Entity_Id) return Boolean is
+   begin
+      if Is_Scalar_Type (Typ) then
+         return False;
+
+      elsif Is_Access_Type (Typ) then
+         return True;
+
+      elsif Is_Array_Type (Typ) then
+         if Is_Fully_Initialized_Type (Component_Type (Typ)) then
+            return True;
+         end if;
+
+         --  An interesting case, if we have a constrained type one of whose
+         --  bounds is known to be null, then there are no elements to be
+         --  initialized, so all the elements are initialized!
+
+         if Is_Constrained (Typ) then
+            declare
+               Indx     : Node_Id;
+               Indx_Typ : Entity_Id;
+               Lbd, Hbd : Node_Id;
+
+            begin
+               Indx := First_Index (Typ);
+               while Present (Indx) loop
+
+                  if Etype (Indx) = Any_Type then
+                     return False;
+
+                  --  If index is a range, use directly.
+
+                  elsif Nkind (Indx) = N_Range then
+                     Lbd := Low_Bound  (Indx);
+                     Hbd := High_Bound (Indx);
+
+                  else
+                     Indx_Typ := Etype (Indx);
+
+                     if Is_Private_Type (Indx_Typ)  then
+                        Indx_Typ := Full_View (Indx_Typ);
+                     end if;
+
+                     if No (Indx_Typ) then
+                        return False;
+                     else
+                        Lbd := Type_Low_Bound  (Indx_Typ);
+                        Hbd := Type_High_Bound (Indx_Typ);
+                     end if;
+                  end if;
+
+                  if Compile_Time_Known_Value (Lbd)
+                    and then Compile_Time_Known_Value (Hbd)
+                  then
+                     if Expr_Value (Hbd) < Expr_Value (Lbd) then
+                        return True;
+                     end if;
+                  end if;
+
+                  Next_Index (Indx);
+               end loop;
+            end;
+         end if;
+
+         return False;
+
+      elsif Is_Record_Type (Typ) then
+         declare
+            Ent : Entity_Id;
+
+         begin
+            Ent := First_Entity (Typ);
+
+            while Present (Ent) loop
+               if Ekind (Ent) = E_Component
+                 and then (No (Parent (Ent))
+                             or else No (Expression (Parent (Ent))))
+                 and then not Is_Fully_Initialized_Type (Etype (Ent))
+               then
+                  return False;
+               end if;
+
+               Next_Entity (Ent);
+            end loop;
+         end;
+
+         return True;
+
+      elsif Is_Concurrent_Type (Typ) then
+         return True;
+
+      elsif Is_Private_Type (Typ) then
+         declare
+            U : constant Entity_Id := Underlying_Type (Typ);
+
+         begin
+            if No (U) then
+               return False;
+            else
+               return Is_Fully_Initialized_Type (U);
+            end if;
+         end;
+
+      else
+         return False;
+      end if;
+   end Is_Fully_Initialized_Type;
+
+   ----------------------------
+   -- Is_Inherited_Operation --
+   ----------------------------
+
+   function Is_Inherited_Operation (E : Entity_Id) return Boolean is
+      Kind : constant Node_Kind := Nkind (Parent (E));
+
+   begin
+      pragma Assert (Is_Overloadable (E));
+      return Kind = N_Full_Type_Declaration
+        or else Kind = N_Private_Extension_Declaration
+        or else Kind = N_Subtype_Declaration
+        or else (Ekind (E) = E_Enumeration_Literal
+                  and then Is_Derived_Type (Etype (E)));
+   end Is_Inherited_Operation;
+
+   -----------------------------
+   -- Is_Library_Level_Entity --
+   -----------------------------
+
+   function Is_Library_Level_Entity (E : Entity_Id) return Boolean is
+   begin
+      return Enclosing_Dynamic_Scope (E) = Standard_Standard;
+   end Is_Library_Level_Entity;
+
+   ---------------------------------
+   -- Is_Local_Variable_Reference --
+   ---------------------------------
+
+   function Is_Local_Variable_Reference (Expr : Node_Id) return Boolean is
+   begin
+      if not Is_Entity_Name (Expr) then
+         return False;
+
+      else
+         declare
+            Ent : constant Entity_Id := Entity (Expr);
+            Sub : constant Entity_Id := Enclosing_Subprogram (Ent);
+
+         begin
+            if Ekind (Ent) /= E_Variable
+                 and then
+               Ekind (Ent) /= E_In_Out_Parameter
+            then
+               return False;
+
+            else
+               return Present (Sub) and then Sub = Current_Subprogram;
+            end if;
+         end;
+      end if;
+   end Is_Local_Variable_Reference;
+
+   -------------------------
+   -- Is_Object_Reference --
+   -------------------------
+
+   function Is_Object_Reference (N : Node_Id) return Boolean is
+   begin
+      if Is_Entity_Name (N) then
+         return Is_Object (Entity (N));
+
+      else
+         case Nkind (N) is
+            when N_Indexed_Component | N_Slice =>
+               return True;
+
+            --  In Ada95, a function call is a constant object.
+
+            when N_Function_Call =>
+               return True;
+
+            when N_Selected_Component =>
+               return Is_Object_Reference (Selector_Name (N));
+
+            when N_Explicit_Dereference =>
+               return True;
+
+            --  An unchecked type conversion is considered to be an object if
+            --  the operand is an object (this construction arises only as a
+            --  result of expansion activities).
+
+            when N_Unchecked_Type_Conversion =>
+               return True;
+
+            when others =>
+               return False;
+         end case;
+      end if;
+   end Is_Object_Reference;
+
+   -----------------------------------
+   -- Is_OK_Variable_For_Out_Formal --
+   -----------------------------------
+
+   function Is_OK_Variable_For_Out_Formal (AV : Node_Id) return Boolean is
+   begin
+      Note_Possible_Modification (AV);
+
+      --  We must reject parenthesized variable names. The check for
+      --  Comes_From_Source is present because there are currently
+      --  cases where the compiler violates this rule (e.g. passing
+      --  a task object to its controlled Initialize routine).
+
+      if Paren_Count (AV) > 0 and then Comes_From_Source (AV) then
+         return False;
+
+      --  A variable is always allowed
+
+      elsif Is_Variable (AV) then
+         return True;
+
+      --  Unchecked conversions are allowed only if they come from the
+      --  generated code, which sometimes uses unchecked conversions for
+      --  out parameters in cases where code generation is unaffected.
+      --  We tell source unchecked conversions by seeing if they are
+      --  rewrites of an original UC function call, or of an explicit
+      --  conversion of a function call.
+
+      elsif Nkind (AV) = N_Unchecked_Type_Conversion then
+         if Nkind (Original_Node (AV)) = N_Function_Call then
+            return False;
+
+         elsif Comes_From_Source (AV)
+           and then Nkind (Original_Node (Expression (AV))) = N_Function_Call
+         then
+            return False;
+
+         else
+            return True;
+         end if;
+
+      --  Normal type conversions are allowed if argument is a variable
+
+      elsif Nkind (AV) = N_Type_Conversion then
+         if Is_Variable (Expression (AV))
+           and then Paren_Count (Expression (AV)) = 0
+         then
+            Note_Possible_Modification (Expression (AV));
+            return True;
+
+         --  We also allow a non-parenthesized expression that raises
+         --  constraint error if it rewrites what used to be a variable
+
+         elsif Raises_Constraint_Error (Expression (AV))
+            and then Paren_Count (Expression (AV)) = 0
+            and then Is_Variable (Original_Node (Expression (AV)))
+         then
+            return True;
+
+         --  Type conversion of something other than a variable
+
+         else
+            return False;
+         end if;
+
+      --  If this node is rewritten, then test the original form, if that is
+      --  OK, then we consider the rewritten node OK (for example, if the
+      --  original node is a conversion, then Is_Variable will not be true
+      --  but we still want to allow the conversion if it converts a variable.
+
+      elsif Original_Node (AV) /= AV then
+         return Is_OK_Variable_For_Out_Formal (Original_Node (AV));
+
+      --  All other non-variables are rejected
+
+      else
+         return False;
+      end if;
+   end Is_OK_Variable_For_Out_Formal;
+
+   -----------------------------
+   -- Is_RCI_Pkg_Spec_Or_Body --
+   -----------------------------
+
+   function Is_RCI_Pkg_Spec_Or_Body (Cunit : Node_Id) return Boolean is
+
+      function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean;
+      --  Return True if the unit of Cunit is an RCI package declaration
+
+      ---------------------------
+      -- Is_RCI_Pkg_Decl_Cunit --
+      ---------------------------
+
+      function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean is
+         The_Unit : constant Node_Id := Unit (Cunit);
+
+      begin
+         if Nkind (The_Unit) /= N_Package_Declaration then
+            return False;
+         end if;
+         return Is_Remote_Call_Interface (Defining_Entity (The_Unit));
+      end Is_RCI_Pkg_Decl_Cunit;
+
+   --  Start of processing for Is_RCI_Pkg_Spec_Or_Body
+
+   begin
+      return Is_RCI_Pkg_Decl_Cunit (Cunit)
+        or else
+         (Nkind (Unit (Cunit)) = N_Package_Body
+           and then Is_RCI_Pkg_Decl_Cunit (Library_Unit (Cunit)));
+   end Is_RCI_Pkg_Spec_Or_Body;
+
+   -----------------------------------------
+   -- Is_Remote_Access_To_Class_Wide_Type --
+   -----------------------------------------
+
+   function Is_Remote_Access_To_Class_Wide_Type
+     (E    : Entity_Id)
+      return Boolean
+   is
+      D : Entity_Id;
+
+      function Comes_From_Limited_Private_Type_Declaration
+        (E    : Entity_Id)
+         return Boolean;
+      --  Check if the original declaration is a limited private one and
+      --  if all the derivations have been using private extensions.
+
+      -------------------------------------------------
+      -- Comes_From_Limited_Private_Type_Declaration --
+      -------------------------------------------------
+
+      function Comes_From_Limited_Private_Type_Declaration (E : in Entity_Id)
+        return Boolean
+      is
+         N : constant Node_Id := Declaration_Node (E);
+      begin
+         if Nkind (N) = N_Private_Type_Declaration
+           and then Limited_Present (N)
+         then
+            return True;
+         end if;
+
+         if Nkind (N) = N_Private_Extension_Declaration then
+            return Comes_From_Limited_Private_Type_Declaration (Etype (E));
+         end if;
+
+         return False;
+      end Comes_From_Limited_Private_Type_Declaration;
+
+   --  Start of processing for Is_Remote_Access_To_Class_Wide_Type
+
+   begin
+      if not (Is_Remote_Call_Interface (E)
+               or else Is_Remote_Types (E))
+        or else Ekind (E) /= E_General_Access_Type
+      then
+         return False;
+      end if;
+
+      D := Designated_Type (E);
+
+      if Ekind (D) /= E_Class_Wide_Type then
+         return False;
+      end if;
+
+      return Comes_From_Limited_Private_Type_Declaration
+               (Defining_Identifier (Parent (D)));
+   end Is_Remote_Access_To_Class_Wide_Type;
+
+   -----------------------------------------
+   -- Is_Remote_Access_To_Subprogram_Type --
+   -----------------------------------------
+
+   function Is_Remote_Access_To_Subprogram_Type
+     (E    : Entity_Id)
+      return Boolean
+   is
+   begin
+      return (Ekind (E) = E_Access_Subprogram_Type
+                or else (Ekind (E) = E_Record_Type
+                           and then Present (Corresponding_Remote_Type (E))))
+        and then (Is_Remote_Call_Interface (E)
+                   or else Is_Remote_Types (E));
+   end Is_Remote_Access_To_Subprogram_Type;
+
+   --------------------
+   -- Is_Remote_Call --
+   --------------------
+
+   function Is_Remote_Call (N : Node_Id) return Boolean is
+   begin
+      if Nkind (N) /= N_Procedure_Call_Statement
+        and then Nkind (N) /= N_Function_Call
+      then
+         --  An entry call cannot be remote
+
+         return False;
+
+      elsif Nkind (Name (N)) in N_Has_Entity
+        and then Is_Remote_Call_Interface (Entity (Name (N)))
+      then
+         --  A subprogram declared in the spec of a RCI package is remote
+
+         return True;
+
+      elsif Nkind (Name (N)) = N_Explicit_Dereference
+        and then Is_Remote_Access_To_Subprogram_Type
+          (Etype (Prefix (Name (N))))
+      then
+         --  The dereference of a RAS is a remote call
+
+         return True;
+
+      elsif Present (Controlling_Argument (N))
+        and then Is_Remote_Access_To_Class_Wide_Type
+          (Etype (Controlling_Argument (N)))
+      then
+         --  Any primitive operation call with a controlling argument of
+         --  a RACW type is a remote call.
+
+         return True;
+      end if;
+
+      --  All other calls are local calls
+
+      return False;
+   end Is_Remote_Call;
+
+   ----------------------
+   -- Is_Selector_Name --
+   ----------------------
+
+   function Is_Selector_Name (N : Node_Id) return Boolean is
+
+   begin
+      if not Is_List_Member (N) then
+         declare
+            P : constant Node_Id   := Parent (N);
+            K : constant Node_Kind := Nkind (P);
+
+         begin
+            return
+              (K = N_Expanded_Name          or else
+               K = N_Generic_Association    or else
+               K = N_Parameter_Association  or else
+               K = N_Selected_Component)
+              and then Selector_Name (P) = N;
+         end;
+
+      else
+         declare
+            L : constant List_Id := List_Containing (N);
+            P : constant Node_Id := Parent (L);
+
+         begin
+            return (Nkind (P) = N_Discriminant_Association
+                     and then Selector_Names (P) = L)
+              or else
+                   (Nkind (P) = N_Component_Association
+                     and then Choices (P) = L);
+         end;
+      end if;
+   end Is_Selector_Name;
+
+   ------------------
+   -- Is_Statement --
+   ------------------
+
+   function Is_Statement (N : Node_Id) return Boolean is
+   begin
+      return
+        Nkind (N) in N_Statement_Other_Than_Procedure_Call
+          or else Nkind (N) = N_Procedure_Call_Statement;
+   end Is_Statement;
+
+   -----------------
+   -- Is_Transfer --
+   -----------------
+
+   function Is_Transfer (N : Node_Id) return Boolean is
+      Kind : constant Node_Kind := Nkind (N);
+
+   begin
+      if Kind = N_Return_Statement
+           or else
+         Kind = N_Goto_Statement
+           or else
+         Kind = N_Raise_Statement
+           or else
+         Kind = N_Requeue_Statement
+      then
+         return True;
+
+      elsif (Kind = N_Exit_Statement or else Kind in N_Raise_xxx_Error)
+        and then No (Condition (N))
+      then
+         return True;
+
+      elsif Kind = N_Procedure_Call_Statement
+        and then Is_Entity_Name (Name (N))
+        and then Present (Entity (Name (N)))
+        and then No_Return (Entity (Name (N)))
+      then
+         return True;
+
+      elsif Nkind (Original_Node (N)) = N_Raise_Statement then
+         return True;
+
+      else
+         return False;
+      end if;
+   end Is_Transfer;
+
+   -------------
+   -- Is_True --
+   -------------
+
+   function Is_True (U : Uint) return Boolean is
+   begin
+      return (U /= 0);
+   end Is_True;
+
+   -----------------
+   -- Is_Variable --
+   -----------------
+
+   function Is_Variable (N : Node_Id) return Boolean is
+
+      Orig_Node : constant Node_Id := Original_Node (N);
+      --  We do the test on the original node, since this is basically a
+      --  test of syntactic categories, so it must not be disturbed by
+      --  whatever rewriting might have occurred. For example, an aggregate,
+      --  which is certainly NOT a variable, could be turned into a variable
+      --  by expansion.
+
+      function In_Protected_Function (E : Entity_Id) return Boolean;
+      --  Within a protected function, the private components of the
+      --  enclosing protected type are constants. A function nested within
+      --  a (protected) procedure is not itself protected.
+
+      function Is_Variable_Prefix (P : Node_Id) return Boolean;
+      --  Prefixes can involve implicit dereferences, in which case we
+      --  must test for the case of a reference of a constant access
+      --  type, which can never be a variable.
+
+      function In_Protected_Function (E : Entity_Id) return Boolean is
+         Prot : constant Entity_Id := Scope (E);
+         S    : Entity_Id;
+
+      begin
+         if not Is_Protected_Type (Prot) then
+            return False;
+         else
+            S := Current_Scope;
+
+            while Present (S) and then S /= Prot loop
+
+               if Ekind (S) = E_Function
+                 and then Scope (S) = Prot
+               then
+                  return True;
+               end if;
+
+               S := Scope (S);
+            end loop;
+
+            return False;
+         end if;
+      end In_Protected_Function;
+
+      function Is_Variable_Prefix (P : Node_Id) return Boolean is
+      begin
+         if Is_Access_Type (Etype (P)) then
+            return not Is_Access_Constant (Root_Type (Etype (P)));
+         else
+            return Is_Variable (P);
+         end if;
+      end Is_Variable_Prefix;
+
+   --  Start of processing for Is_Variable
+
+   begin
+      --  Definitely OK if Assignment_OK is set. Since this is something that
+      --  only gets set for expanded nodes, the test is on N, not Orig_Node.
+
+      if Nkind (N) in N_Subexpr and then Assignment_OK (N) then
+         return True;
+
+      --  Normally we go to the original node, but there is one exception
+      --  where we use the rewritten node, namely when it is an explicit
+      --  dereference. The generated code may rewrite a prefix which is an
+      --  access type with an explicit dereference. The dereference is a
+      --  variable, even though the original node may not be (since it could
+      --  be a constant of the access type).
+
+      elsif Nkind (N) = N_Explicit_Dereference
+        and then Nkind (Orig_Node) /= N_Explicit_Dereference
+        and then Is_Access_Type (Etype (Orig_Node))
+      then
+         return Is_Variable_Prefix (Original_Node (Prefix (N)));
+
+      --  All remaining checks use the original node
+
+      elsif Is_Entity_Name (Orig_Node) then
+         declare
+            E : constant Entity_Id := Entity (Orig_Node);
+            K : constant Entity_Kind := Ekind (E);
+
+         begin
+            return (K = E_Variable
+                      and then Nkind (Parent (E)) /= N_Exception_Handler)
+              or else  (K = E_Component
+                          and then not In_Protected_Function (E))
+              or else  K = E_Out_Parameter
+              or else  K = E_In_Out_Parameter
+              or else  K = E_Generic_In_Out_Parameter
+
+               --  Current instance of type:
+
+              or else (Is_Type (E) and then In_Open_Scopes (E))
+              or else (Is_Incomplete_Or_Private_Type (E)
+                        and then In_Open_Scopes (Full_View (E)));
+         end;
+
+      else
+         case Nkind (Orig_Node) is
+            when N_Indexed_Component | N_Slice =>
+               return Is_Variable_Prefix (Prefix (Orig_Node));
+
+            when N_Selected_Component =>
+               return Is_Variable_Prefix (Prefix (Orig_Node))
+                 and then Is_Variable (Selector_Name (Orig_Node));
+
+            --  For an explicit dereference, we must check whether the type
+            --  is ACCESS CONSTANT, since if it is, then it is not a variable.
+
+            when N_Explicit_Dereference =>
+               return Is_Access_Type (Etype (Prefix (Orig_Node)))
+                 and then not
+                   Is_Access_Constant (Root_Type (Etype (Prefix (Orig_Node))));
+
+            --  The type conversion is the case where we do not deal with the
+            --  context dependent special case of an actual parameter. Thus
+            --  the type conversion is only considered a variable for the
+            --  purposes of this routine if the target type is tagged. However,
+            --  a type conversion is considered to be a variable if it does not
+            --  come from source (this deals for example with the conversions
+            --  of expressions to their actual subtypes).
+
+            when N_Type_Conversion =>
+               return Is_Variable (Expression (Orig_Node))
+                 and then
+                   (not Comes_From_Source (Orig_Node)
+                      or else
+                        (Is_Tagged_Type (Etype (Subtype_Mark (Orig_Node)))
+                          and then
+                         Is_Tagged_Type (Etype (Expression (Orig_Node)))));
+
+            --  GNAT allows an unchecked type conversion as a variable. This
+            --  only affects the generation of internal expanded code, since
+            --  calls to instantiations of Unchecked_Conversion are never
+            --  considered variables (since they are function calls).
+            --  This is also true for expression actions.
+
+            when N_Unchecked_Type_Conversion =>
+               return Is_Variable (Expression (Orig_Node));
+
+            when others =>
+               return False;
+         end case;
+      end if;
+   end Is_Variable;
+
+   ------------------------
+   -- Is_Volatile_Object --
+   ------------------------
+
+   function Is_Volatile_Object (N : Node_Id) return Boolean is
+
+      function Object_Has_Volatile_Components (N : Node_Id) return Boolean;
+      --  Determines if given object has volatile components
+
+      function Is_Volatile_Prefix (N : Node_Id) return Boolean;
+      --  If prefix is an implicit dereference, examine designated type.
+
+      function Is_Volatile_Prefix (N : Node_Id) return Boolean is
+      begin
+         if Is_Access_Type (Etype (N)) then
+            return Has_Volatile_Components (Designated_Type (Etype (N)));
+         else
+            return Object_Has_Volatile_Components (N);
+         end if;
+      end Is_Volatile_Prefix;
+
+      function Object_Has_Volatile_Components (N : Node_Id) return Boolean is
+      begin
+         if Is_Volatile (Etype (N))
+           or else Has_Volatile_Components (Etype (N))
+         then
+            return True;
+
+         elsif Is_Entity_Name (N)
+           and then (Has_Volatile_Components (Entity (N))
+                      or else Is_Volatile (Entity (N)))
+         then
+            return True;
+
+         elsif Nkind (N) = N_Indexed_Component
+           or else Nkind (N) = N_Selected_Component
+         then
+            return Is_Volatile_Prefix (Prefix (N));
+
+         else
+            return False;
+         end if;
+      end Object_Has_Volatile_Components;
+
+   --  Start of processing for Is_Volatile_Object
+
+   begin
+      if Is_Volatile (Etype (N))
+        or else (Is_Entity_Name (N) and then Is_Volatile (Entity (N)))
+      then
+         return True;
+
+      elsif Nkind (N) = N_Indexed_Component
+        or else Nkind (N) = N_Selected_Component
+      then
+         return Is_Volatile_Prefix (Prefix (N));
+
+      else
+         return False;
+      end if;
+   end Is_Volatile_Object;
+
+   --------------------------
+   -- Kill_Size_Check_Code --
+   --------------------------
+
+   procedure Kill_Size_Check_Code (E : Entity_Id) is
+   begin
+      if (Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
+        and then Present (Size_Check_Code (E))
+      then
+         Remove (Size_Check_Code (E));
+         Set_Size_Check_Code (E, Empty);
+      end if;
+   end Kill_Size_Check_Code;
+
+   -------------------------
+   -- New_External_Entity --
+   -------------------------
+
+   function New_External_Entity
+     (Kind         : Entity_Kind;
+      Scope_Id     : Entity_Id;
+      Sloc_Value   : Source_Ptr;
+      Related_Id   : Entity_Id;
+      Suffix       : Character;
+      Suffix_Index : Nat := 0;
+      Prefix       : Character := ' ')
+      return         Entity_Id
+   is
+      N : constant Entity_Id :=
+            Make_Defining_Identifier (Sloc_Value,
+              New_External_Name
+                (Chars (Related_Id), Suffix, Suffix_Index, Prefix));
+
+   begin
+      Set_Ekind          (N, Kind);
+      Set_Is_Internal    (N, True);
+      Append_Entity      (N, Scope_Id);
+      Set_Public_Status  (N);
+
+      if Kind in Type_Kind then
+         Init_Size_Align (N);
+      end if;
+
+      return N;
+   end New_External_Entity;
+
+   -------------------------
+   -- New_Internal_Entity --
+   -------------------------
+
+   function New_Internal_Entity
+     (Kind       : Entity_Kind;
+      Scope_Id   : Entity_Id;
+      Sloc_Value : Source_Ptr;
+      Id_Char    : Character)
+      return       Entity_Id
+   is
+      N : constant Entity_Id :=
+            Make_Defining_Identifier (Sloc_Value, New_Internal_Name (Id_Char));
+
+   begin
+      Set_Ekind          (N, Kind);
+      Set_Is_Internal    (N, True);
+      Append_Entity      (N, Scope_Id);
+
+      if Kind in Type_Kind then
+         Init_Size_Align (N);
+      end if;
+
+      return N;
+   end New_Internal_Entity;
+
+   -----------------
+   -- Next_Actual --
+   -----------------
+
+   function Next_Actual (Actual_Id : Node_Id) return Node_Id is
+      N  : Node_Id;
+
+   begin
+      --  If we are pointing at a positional parameter, it is a member of
+      --  a node list (the list of parameters), and the next parameter
+      --  is the next node on the list, unless we hit a parameter
+      --  association, in which case we shift to using the chain whose
+      --  head is the First_Named_Actual in the parent, and then is
+      --  threaded using the Next_Named_Actual of the Parameter_Association.
+      --  All this fiddling is because the original node list is in the
+      --  textual call order, and what we need is the declaration order.
+
+      if Is_List_Member (Actual_Id) then
+         N := Next (Actual_Id);
+
+         if Nkind (N) = N_Parameter_Association then
+            return First_Named_Actual (Parent (Actual_Id));
+         else
+            return N;
+         end if;
+
+      else
+         return Next_Named_Actual (Parent (Actual_Id));
+      end if;
+   end Next_Actual;
+
+   procedure Next_Actual (Actual_Id : in out Node_Id) is
+   begin
+      Actual_Id := Next_Actual (Actual_Id);
+   end Next_Actual;
+
+   -----------------------
+   -- Normalize_Actuals --
+   -----------------------
+
+   --  Chain actuals according to formals of subprogram. If there are
+   --  no named associations, the chain is simply the list of Parameter
+   --  Associations, since the order is the same as the declaration order.
+   --  If there are named associations, then the First_Named_Actual field
+   --  in the N_Procedure_Call_Statement node or N_Function_Call node
+   --  points to the Parameter_Association node for the parameter that
+   --  comes first in declaration order. The remaining named parameters
+   --  are then chained in declaration order using Next_Named_Actual.
+
+   --  This routine also verifies that the number of actuals is compatible
+   --  with the number and default values of formals, but performs no type
+   --  checking (type checking is done by the caller).
+
+   --  If the matching succeeds, Success is set to True, and the caller
+   --  proceeds with type-checking. If the match is unsuccessful, then
+   --  Success is set to False, and the caller attempts a different
+   --  interpretation, if there is one.
+
+   --  If the flag Report is on, the call is not overloaded, and a failure
+   --  to match can be reported here, rather than in the caller.
+
+   procedure Normalize_Actuals
+     (N       : Node_Id;
+      S       : Entity_Id;
+      Report  : Boolean;
+      Success : out Boolean)
+   is
+      Actuals     : constant List_Id := Parameter_Associations (N);
+      Actual      : Node_Id   := Empty;
+      Formal      : Entity_Id;
+      Last        : Node_Id := Empty;
+      First_Named : Node_Id := Empty;
+      Found       : Boolean;
+
+      Formals_To_Match : Integer := 0;
+      Actuals_To_Match : Integer := 0;
+
+      procedure Chain (A : Node_Id);
+      --  Add named actual at the proper place in the list, using the
+      --  Next_Named_Actual link.
+
+      function Reporting return Boolean;
+      --  Determines if an error is to be reported. To report an error, we
+      --  need Report to be True, and also we do not report errors caused
+      --  by calls to Init_Proc's that occur within other Init_Proc's. Such
+      --  errors must always be cascaded errors, since if all the types are
+      --  declared correctly, the compiler will certainly build decent calls!
+
+      procedure Chain (A : Node_Id) is
+      begin
+         if No (Last) then
+
+            --  Call node points to first actual in list.
+
+            Set_First_Named_Actual (N, Explicit_Actual_Parameter (A));
+
+         else
+            Set_Next_Named_Actual (Last, Explicit_Actual_Parameter (A));
+         end if;
+
+         Last := A;
+         Set_Next_Named_Actual (Last, Empty);
+      end Chain;
+
+      function Reporting return Boolean is
+      begin
+         if not Report then
+            return False;
+
+         elsif not Within_Init_Proc then
+            return True;
+
+         elsif Chars (Entity (Name (N))) = Name_uInit_Proc then
+            return False;
+
+         else
+            return True;
+         end if;
+      end Reporting;
+
+   --  Start of processing for Normalize_Actuals
+
+   begin
+      if Is_Access_Type (S) then
+
+         --  The name in the call is a function call that returns an access
+         --  to subprogram. The designated type has the list of formals.
+
+         Formal := First_Formal (Designated_Type (S));
+      else
+         Formal := First_Formal (S);
+      end if;
+
+      while Present (Formal) loop
+         Formals_To_Match := Formals_To_Match + 1;
+         Next_Formal (Formal);
+      end loop;
+
+      --  Find if there is a named association, and verify that no positional
+      --  associations appear after named ones.
+
+      if Present (Actuals) then
+         Actual := First (Actuals);
+      end if;
+
+      while Present (Actual)
+        and then Nkind (Actual) /= N_Parameter_Association
+      loop
+         Actuals_To_Match := Actuals_To_Match + 1;
+         Next (Actual);
+      end loop;
+
+      if No (Actual) and Actuals_To_Match = Formals_To_Match then
+
+         --  Most common case: positional notation, no defaults
+
+         Success := True;
+         return;
+
+      elsif Actuals_To_Match > Formals_To_Match then
+
+         --  Too many actuals: will not work.
+
+         if Reporting then
+            Error_Msg_N ("too many arguments in call", N);
+         end if;
+
+         Success := False;
+         return;
+      end if;
+
+      First_Named := Actual;
+
+      while Present (Actual) loop
+         if Nkind (Actual) /= N_Parameter_Association then
+            Error_Msg_N
+              ("positional parameters not allowed after named ones", Actual);
+            Success := False;
+            return;
+
+         else
+            Actuals_To_Match := Actuals_To_Match + 1;
+         end if;
+
+         Next (Actual);
+      end loop;
+
+      if Present (Actuals) then
+         Actual := First (Actuals);
+      end if;
+
+      Formal := First_Formal (S);
+
+      while Present (Formal) loop
+
+         --  Match the formals in order. If the corresponding actual
+         --  is positional,  nothing to do. Else scan the list of named
+         --  actuals to find the one with the right name.
+
+         if Present (Actual)
+           and then Nkind (Actual) /= N_Parameter_Association
+         then
+            Next (Actual);
+            Actuals_To_Match := Actuals_To_Match - 1;
+            Formals_To_Match := Formals_To_Match - 1;
+
+         else
+            --  For named parameters, search the list of actuals to find
+            --  one that matches the next formal name.
+
+            Actual := First_Named;
+            Found  := False;
+
+            while Present (Actual) loop
+               if Chars (Selector_Name (Actual)) = Chars (Formal) then
+                  Found := True;
+                  Chain (Actual);
+                  Actuals_To_Match := Actuals_To_Match - 1;
+                  Formals_To_Match := Formals_To_Match - 1;
+                  exit;
+               end if;
+
+               Next (Actual);
+            end loop;
+
+            if not Found then
+               if Ekind (Formal) /= E_In_Parameter
+                 or else No (Default_Value (Formal))
+               then
+                  if Reporting then
+                     if Comes_From_Source (S)
+                       and then Is_Overloadable (S)
+                     then
+                        Error_Msg_Name_1 := Chars (S);
+                        Error_Msg_Sloc := Sloc (S);
+                        Error_Msg_NE
+                          ("missing argument for parameter & " &
+                             "in call to % declared #", N, Formal);
+                     else
+                        Error_Msg_NE
+                          ("missing argument for parameter &", N, Formal);
+                     end if;
+                  end if;
+
+                  Success := False;
+                  return;
+
+               else
+                  Formals_To_Match := Formals_To_Match - 1;
+               end if;
+            end if;
+         end if;
+
+         Next_Formal (Formal);
+      end loop;
+
+      if  Formals_To_Match = 0 and then Actuals_To_Match = 0 then
+         Success := True;
+         return;
+
+      else
+         if Reporting then
+
+            --  Find some superfluous named actual that did not get
+            --  attached to the list of associations.
+
+            Actual := First (Actuals);
+
+            while Present (Actual) loop
+
+               if Nkind (Actual) = N_Parameter_Association
+                 and then Actual /= Last
+                 and then No (Next_Named_Actual (Actual))
+               then
+                  Error_Msg_N ("Unmatched actual in call",  Actual);
+                  exit;
+               end if;
+
+               Next (Actual);
+            end loop;
+         end if;
+
+         Success := False;
+         return;
+      end if;
+   end Normalize_Actuals;
+
+   --------------------------------
+   -- Note_Possible_Modification --
+   --------------------------------
+
+   procedure Note_Possible_Modification (N : Node_Id) is
+      Ent : Entity_Id;
+      Exp : Node_Id;
+
+      procedure Set_Ref (E : Entity_Id; N : Node_Id);
+      --  Internal routine to note modification on entity E by node N
+
+      procedure Set_Ref (E : Entity_Id; N : Node_Id) is
+      begin
+         Set_Not_Source_Assigned (E, False);
+         Set_Is_True_Constant (E, False);
+         Generate_Reference (E, N, 'm');
+      end Set_Ref;
+
+   --  Start of processing for Note_Possible_Modification
+
+   begin
+      --  Loop to find referenced entity, if there is one
+
+      Exp := N;
+      loop
+         --  Test for node rewritten as dereference (e.g. accept parameter)
+
+         if Nkind (Exp) = N_Explicit_Dereference
+           and then Is_Entity_Name (Original_Node (Exp))
+         then
+            Set_Ref (Entity (Original_Node (Exp)), Original_Node (Exp));
+            return;
+
+         elsif Is_Entity_Name (Exp) then
+            Ent := Entity (Exp);
+
+            if (Ekind (Ent) = E_Variable or else Ekind (Ent) = E_Constant)
+              and then Present (Renamed_Object (Ent))
+            then
+               Exp := Renamed_Object (Ent);
+
+            else
+               Set_Ref (Ent, Exp);
+               return;
+            end if;
+
+         elsif     Nkind (Exp) = N_Type_Conversion
+           or else Nkind (Exp) = N_Unchecked_Type_Conversion
+         then
+            Exp := Expression (Exp);
+
+         elsif     Nkind (Exp) = N_Slice
+           or else Nkind (Exp) = N_Indexed_Component
+           or else Nkind (Exp) = N_Selected_Component
+         then
+            Exp := Prefix (Exp);
+
+         else
+            return;
+         end if;
+      end loop;
+   end Note_Possible_Modification;
+
+   -------------------------
+   -- Object_Access_Level --
+   -------------------------
+
+   function Object_Access_Level (Obj : Node_Id) return Uint is
+      E : Entity_Id;
+
+   --  Returns the static accessibility level of the view denoted
+   --  by Obj.  Note that the value returned is the result of a
+   --  call to Scope_Depth.  Only scope depths associated with
+   --  dynamic scopes can actually be returned.  Since only
+   --  relative levels matter for accessibility checking, the fact
+   --  that the distance between successive levels of accessibility
+   --  is not always one is immaterial (invariant: if level(E2) is
+   --  deeper than level(E1), then Scope_Depth(E1) < Scope_Depth(E2)).
+
+   begin
+      if Is_Entity_Name (Obj) then
+         E := Entity (Obj);
+
+         --  If E is a type then it denotes a current instance.
+         --  For this case we add one to the normal accessibility
+         --  level of the type to ensure that current instances
+         --  are treated as always being deeper than than the level
+         --  of any visible named access type (see 3.10.2(21)).
+
+         if Is_Type (E) then
+            return Type_Access_Level (E) +  1;
+
+         elsif Present (Renamed_Object (E)) then
+            return Object_Access_Level (Renamed_Object (E));
+
+         --  Similarly, if E is a component of the current instance of a
+         --  protected type, any instance of it is assumed to be at a deeper
+         --  level than the type. For a protected object (whose type is an
+         --  anonymous protected type) its components are at the same level
+         --  as the type itself.
+
+         elsif not Is_Overloadable (E)
+           and then Ekind (Scope (E)) = E_Protected_Type
+           and then Comes_From_Source (Scope (E))
+         then
+            return Type_Access_Level (Scope (E)) + 1;
+
+         else
+            return Scope_Depth (Enclosing_Dynamic_Scope (E));
+         end if;
+
+      elsif Nkind (Obj) = N_Selected_Component then
+         if Is_Access_Type (Etype (Prefix (Obj))) then
+            return Type_Access_Level (Etype (Prefix (Obj)));
+         else
+            return Object_Access_Level (Prefix (Obj));
+         end if;
+
+      elsif Nkind (Obj) = N_Indexed_Component then
+         if Is_Access_Type (Etype (Prefix (Obj))) then
+            return Type_Access_Level (Etype (Prefix (Obj)));
+         else
+            return Object_Access_Level (Prefix (Obj));
+         end if;
+
+      elsif Nkind (Obj) = N_Explicit_Dereference then
+
+         --  If the prefix is a selected access discriminant then
+         --  we make a recursive call on the prefix, which will
+         --  in turn check the level of the prefix object of
+         --  the selected discriminant.
+
+         if Nkind (Prefix (Obj)) = N_Selected_Component
+           and then Ekind (Etype (Prefix (Obj))) = E_Anonymous_Access_Type
+           and then
+             Ekind (Entity (Selector_Name (Prefix (Obj)))) = E_Discriminant
+         then
+            return Object_Access_Level (Prefix (Obj));
+         else
+            return Type_Access_Level (Etype (Prefix (Obj)));
+         end if;
+
+      elsif Nkind (Obj) = N_Type_Conversion then
+         return Object_Access_Level (Expression (Obj));
+
+      --  Function results are objects, so we get either the access level
+      --  of the function or, in the case of an indirect call, the level of
+      --  of the access-to-subprogram type.
+
+      elsif Nkind (Obj) = N_Function_Call then
+         if Is_Entity_Name (Name (Obj)) then
+            return Subprogram_Access_Level (Entity (Name (Obj)));
+         else
+            return Type_Access_Level (Etype (Prefix (Name (Obj))));
+         end if;
+
+      --  For convenience we handle qualified expressions, even though
+      --  they aren't technically object names.
+
+      elsif Nkind (Obj) = N_Qualified_Expression then
+         return Object_Access_Level (Expression (Obj));
+
+      --  Otherwise return the scope level of Standard.
+      --  (If there are cases that fall through
+      --  to this point they will be treated as
+      --  having global accessibility for now. ???)
+
+      else
+         return Scope_Depth (Standard_Standard);
+      end if;
+   end Object_Access_Level;
+
+   -----------------------
+   -- Private_Component --
+   -----------------------
+
+   function Private_Component (Type_Id : Entity_Id) return Entity_Id is
+      Ancestor  : constant Entity_Id := Base_Type (Type_Id);
+
+      function Trace_Components
+        (T     : Entity_Id;
+         Check : Boolean)
+         return  Entity_Id;
+      --  Recursive function that does the work, and checks against circular
+      --  definition for each subcomponent type.
+
+      ----------------------
+      -- Trace_Components --
+      ----------------------
+
+      function Trace_Components
+         (T     : Entity_Id;
+          Check : Boolean) return Entity_Id
+       is
+         Btype     : constant Entity_Id := Base_Type (T);
+         Component : Entity_Id;
+         P         : Entity_Id;
+         Candidate : Entity_Id := Empty;
+
+      begin
+         if Check and then Btype = Ancestor then
+            Error_Msg_N ("circular type definition", Type_Id);
+            return Any_Type;
+         end if;
+
+         if Is_Private_Type (Btype)
+           and then not Is_Generic_Type (Btype)
+         then
+            return Btype;
+
+         elsif Is_Array_Type (Btype) then
+            return Trace_Components (Component_Type (Btype), True);
+
+         elsif Is_Record_Type (Btype) then
+            Component := First_Entity (Btype);
+            while Present (Component) loop
+
+               --  skip anonymous types generated by constrained components.
+
+               if not Is_Type (Component) then
+                  P := Trace_Components (Etype (Component), True);
+
+                  if Present (P) then
+                     if P = Any_Type then
+                        return P;
+                     else
+                        Candidate := P;
+                     end if;
+                  end if;
+               end if;
+
+               Next_Entity (Component);
+            end loop;
+
+            return Candidate;
+
+         else
+            return Empty;
+         end if;
+      end Trace_Components;
+
+   --  Start of processing for Private_Component
+
+   begin
+      return Trace_Components (Type_Id, False);
+   end Private_Component;
+
+   -----------------------
+   -- Process_End_Label --
+   -----------------------
+
+   procedure Process_End_Label (N : Node_Id; Typ  : Character) is
+      Loc  : Source_Ptr;
+      Nam  : Node_Id;
+      Ctyp : Entity_Id;
+
+      Label_Ref : Boolean;
+      --  Set True if reference to end label itself is required
+
+      Endl : Node_Id;
+      --  Gets set to the operator symbol or identifier that references
+      --  the entity Ent. For the child unit case, this is the identifier
+      --  from the designator. For other cases, this is simply Endl.
+
+      Ent : Entity_Id;
+      --  This is the entity for the construct to which the End_Label applies
+
+      procedure Generate_Parent_Ref (N : Node_Id);
+      --  N is an identifier node that appears as a parent unit reference
+      --  in the case where Ent is a child unit. This procedure generates
+      --  an appropriate cross-reference entry.
+
+      procedure Generate_Parent_Ref (N : Node_Id) is
+         Parent_Ent : Entity_Id;
+
+      begin
+         --  Search up scope stack. The reason we do this is that normal
+         --  visibility analysis would not work for two reasons. First in
+         --  some subunit cases, the entry for the parent unit may not be
+         --  visible, and in any case there can be a local entity that
+         --  hides the scope entity.
+
+         Parent_Ent := Current_Scope;
+         while Present (Parent_Ent) loop
+            if Chars (Parent_Ent) = Chars (N) then
+
+               --  Generate the reference. We do NOT consider this as a
+               --  reference for unreferenced symbol purposes, but we do
+               --  force a cross-reference even if the end line does not
+               --  come from source (the caller already generated the
+               --  appropriate Typ for this situation).
+
+               Generate_Reference
+                 (Parent_Ent, N, 'r', Set_Ref => False, Force => True);
+               Style.Check_Identifier (N, Parent_Ent);
+               return;
+            end if;
+
+            Parent_Ent := Scope (Parent_Ent);
+         end loop;
+
+         --  Fall through means entity was not found -- that's odd, but
+         --  the appropriate thing is simply to ignore and not generate
+         --  any cross-reference for this entry.
+
+         return;
+      end Generate_Parent_Ref;
+
+   --  Start of processing for Process_End_Label
+
+   begin
+      --  If no node, ignore. This happens in some error situations,
+      --  and also for some internally generated structures where no
+      --  end label references are required in any case.
+
+      if No (N) then
+         return;
+      end if;
+
+      --  Nothing to do if no End_Label, happens for internally generated
+      --  constructs where we don't want an end label reference anyway.
+
+      Endl := End_Label (N);
+
+      if No (Endl) then
+         return;
+      end if;
+
+      --  Reference node is not in extended main source unit
+
+      if not In_Extended_Main_Source_Unit (N) then
+
+         --  Generally we do not collect references except for the
+         --  extended main source unit. The one exception is the 'e'
+         --  entry for a package spec, where it is useful for a client
+         --  to have the ending information to define scopes.
+
+         if Typ /= 'e' then
+            return;
+
+         else
+            Label_Ref := False;
+
+            --  For this case, we can ignore any parent references,
+            --  but we need the package name itself for the 'e' entry.
+
+            if Nkind (Endl) = N_Designator then
+               Endl := Identifier (Endl);
+            end if;
+         end if;
+
+      --  Reference is in extended main source unit
+
+      else
+         Label_Ref := True;
+
+         --  For designator, generate references for the parent entries
+
+         if Nkind (Endl) = N_Designator then
+
+            --  Generate references for the prefix if the END line comes
+            --  from source (otherwise we do not need these references)
+
+            if Comes_From_Source (Endl) then
+               Nam := Name (Endl);
+               while Nkind (Nam) = N_Selected_Component loop
+                  Generate_Parent_Ref (Selector_Name (Nam));
+                  Nam := Prefix (Nam);
+               end loop;
+
+               Generate_Parent_Ref (Nam);
+            end if;
+
+            Endl := Identifier (Endl);
+         end if;
+      end if;
+
+      --  Locate the entity to which the end label applies. Most of the
+      --  time this is simply the current scope containing the construct.
+
+      Ent := Current_Scope;
+
+      if Chars (Ent) = Chars (Endl) then
+         null;
+
+      --  But in the case of single tasks and single protected objects,
+      --  the current scope is the anonymous task or protected type and
+      --  what we want is the object. There is no direct link so what we
+      --  do is search ahead in the entity chain for the object with the
+      --  matching type and name. In practice it is almost certain to be
+      --  the very next entity on the chain, so this is not inefficient.
+
+      else
+         Ctyp := Etype (Ent);
+         loop
+            Next_Entity (Ent);
+
+            --  If we don't find the entry we are looking for, that's
+            --  odd, perhaps results from some error condition? Anyway
+            --  the appropriate thing is just to abandon the attempt.
+
+            if No (Ent) then
+               return;
+
+            --  Exit if we find the entity we are looking for
+
+            elsif Etype (Ent) = Ctyp
+              and then Chars (Ent) = Chars (Endl)
+            then
+               exit;
+            end if;
+         end loop;
+      end if;
+
+      --  If label was really there, then generate a normal reference
+      --  and then adjust the location in the end label to point past
+      --  the name (which should almost always be the semicolon).
+
+      Loc := Sloc (Endl);
+
+      if Comes_From_Source (Endl) then
+
+         --  If a label reference is required, then do the style check
+         --  and generate a normal cross-reference entry for the label
+
+         if Label_Ref then
+            Style.Check_Identifier (Endl, Ent);
+            Generate_Reference (Ent, Endl, 'r', Set_Ref => False);
+         end if;
+
+         --  Set the location to point past the label (normally this will
+         --  mean the semicolon immediately following the label). This is
+         --  done for the sake of the 'e' or 't' entry generated below.
+
+         Get_Decoded_Name_String (Chars (Endl));
+         Set_Sloc (Endl, Sloc (Endl) + Source_Ptr (Name_Len));
+      end if;
+
+      --  Now generate the e/t reference
+
+      Generate_Reference (Ent, Endl, Typ, Set_Ref => False, Force => True);
+
+      --  Restore Sloc, in case modified above, since we have an identifier
+      --  and the normal Sloc should be left set in the tree.
+
+      Set_Sloc (Endl, Loc);
+   end Process_End_Label;
+
+   ------------------
+   -- Real_Convert --
+   ------------------
+
+   --  We do the conversion to get the value of the real string by using
+   --  the scanner, see Sinput for details on use of the internal source
+   --  buffer for scanning internal strings.
+
+   function Real_Convert (S : String) return Node_Id is
+      Save_Src : constant Source_Buffer_Ptr := Source;
+      Negative : Boolean;
+
+   begin
+      Source := Internal_Source_Ptr;
+      Scan_Ptr := 1;
+
+      for J in S'Range loop
+         Source (Source_Ptr (J)) := S (J);
+      end loop;
+
+      Source (S'Length + 1) := EOF;
+
+      if Source (Scan_Ptr) = '-' then
+         Negative := True;
+         Scan_Ptr := Scan_Ptr + 1;
+      else
+         Negative := False;
+      end if;
+
+      Scan;
+
+      if Negative then
+         Set_Realval (Token_Node, UR_Negate (Realval (Token_Node)));
+      end if;
+
+      Source := Save_Src;
+      return Token_Node;
+   end Real_Convert;
+
+   ------------------------------
+   -- Requires_Transient_Scope --
+   ------------------------------
+
+   --  A transient scope is required when variable-sized temporaries are
+   --  allocated in the primary or secondary stack, or when finalization
+   --  actions must be generated before the next instruction
+
+   function Requires_Transient_Scope (Id : Entity_Id) return Boolean is
+      Typ : constant Entity_Id := Underlying_Type (Id);
+
+   begin
+      --  This is a private type which is not completed yet. This can only
+      --  happen in a default expression (of a formal parameter or of a
+      --  record component). Do not expand transient scope in this case
+
+      if No (Typ) then
+         return False;
+
+      elsif Typ = Standard_Void_Type then
+         return False;
+
+      --  The back-end has trouble allocating variable-size temporaries so
+      --  we generate them in the front-end and need a transient scope to
+      --  reclaim them properly
+
+      elsif not Size_Known_At_Compile_Time (Typ) then
+         return True;
+
+      --  Unconstrained discriminated records always require a variable
+      --  length temporary, since the length may depend on the variant.
+
+      elsif Is_Record_Type (Typ)
+        and then Has_Discriminants (Typ)
+        and then not Is_Constrained (Typ)
+      then
+         return True;
+
+      --  Functions returning tagged types may dispatch on result so their
+      --  returned value is allocated on the secondary stack. Controlled
+      --  type temporaries need finalization.
+
+      elsif Is_Tagged_Type (Typ)
+        or else Has_Controlled_Component (Typ)
+      then
+         return True;
+
+      --  Unconstrained array types are returned on the secondary stack
+
+      elsif Is_Array_Type (Typ) then
+         return not Is_Constrained (Typ);
+      end if;
+
+      return False;
+   end Requires_Transient_Scope;
+
+   --------------------------
+   -- Reset_Analyzed_Flags --
+   --------------------------
+
+   procedure Reset_Analyzed_Flags (N : Node_Id) is
+
+      function Clear_Analyzed
+        (N    : Node_Id)
+         return Traverse_Result;
+      --  Function used to reset Analyzed flags in tree. Note that we do
+      --  not reset Analyzed flags in entities, since there is no need to
+      --  renalalyze entities, and indeed, it is wrong to do so, since it
+      --  can result in generating auxiliary stuff more than once.
+
+      function Clear_Analyzed
+        (N    : Node_Id)
+         return Traverse_Result
+      is
+      begin
+         if not Has_Extension (N) then
+            Set_Analyzed (N, False);
+         end if;
+
+         return OK;
+      end Clear_Analyzed;
+
+      function Reset_Analyzed is
+        new Traverse_Func (Clear_Analyzed);
+
+      Discard : Traverse_Result;
+
+   --  Start of processing for Reset_Analyzed_Flags
+
+   begin
+      Discard := Reset_Analyzed (N);
+   end Reset_Analyzed_Flags;
+
+   ---------------
+   -- Same_Name --
+   ---------------
+
+   function Same_Name (N1, N2 : Node_Id) return Boolean is
+      K1 : constant Node_Kind := Nkind (N1);
+      K2 : constant Node_Kind := Nkind (N2);
+
+   begin
+      if (K1 = N_Identifier or else K1 = N_Defining_Identifier)
+        and then (K2 = N_Identifier or else K2 = N_Defining_Identifier)
+      then
+         return Chars (N1) = Chars (N2);
+
+      elsif (K1 = N_Selected_Component or else K1 = N_Expanded_Name)
+        and then (K2 = N_Selected_Component or else K2 = N_Expanded_Name)
+      then
+         return Same_Name (Selector_Name (N1), Selector_Name (N2))
+           and then Same_Name (Prefix (N1), Prefix (N2));
+
+      else
+         return False;
+      end if;
+   end Same_Name;
+
+   ---------------
+   -- Same_Type --
+   ---------------
+
+   function Same_Type (T1, T2 : Entity_Id) return Boolean is
+   begin
+      if T1 = T2 then
+         return True;
+
+      elsif not Is_Constrained (T1)
+        and then not Is_Constrained (T2)
+        and then Base_Type (T1) = Base_Type (T2)
+      then
+         return True;
+
+      --  For now don't bother with case of identical constraints, to be
+      --  fiddled with later on perhaps (this is only used for optimization
+      --  purposes, so it is not critical to do a best possible job)
+
+      else
+         return False;
+      end if;
+   end Same_Type;
+
+   ------------------------
+   -- Scope_Is_Transient --
+   ------------------------
+
+   function Scope_Is_Transient  return Boolean is
+   begin
+      return Scope_Stack.Table (Scope_Stack.Last).Is_Transient;
+   end Scope_Is_Transient;
+
+   ------------------
+   -- Scope_Within --
+   ------------------
+
+   function Scope_Within (Scope1, Scope2 : Entity_Id) return Boolean is
+      Scop : Entity_Id;
+
+   begin
+      Scop := Scope1;
+      while Scop /= Standard_Standard loop
+         Scop := Scope (Scop);
+
+         if Scop = Scope2 then
+            return True;
+         end if;
+      end loop;
+
+      return False;
+   end Scope_Within;
+
+   --------------------------
+   -- Scope_Within_Or_Same --
+   --------------------------
+
+   function Scope_Within_Or_Same (Scope1, Scope2 : Entity_Id) return Boolean is
+      Scop : Entity_Id;
+
+   begin
+      Scop := Scope1;
+      while Scop /= Standard_Standard loop
+         if Scop = Scope2 then
+            return True;
+         else
+            Scop := Scope (Scop);
+         end if;
+      end loop;
+
+      return False;
+   end Scope_Within_Or_Same;
+
+   ------------------------
+   -- Set_Current_Entity --
+   ------------------------
+
+   --  The given entity is to be set as the currently visible definition
+   --  of its associated name (i.e. the Node_Id associated with its name).
+   --  All we have to do is to get the name from the identifier, and
+   --  then set the associated Node_Id to point to the given entity.
+
+   procedure Set_Current_Entity (E : Entity_Id) is
+   begin
+      Set_Name_Entity_Id (Chars (E), E);
+   end Set_Current_Entity;
+
+   ---------------------------------
+   -- Set_Entity_With_Style_Check --
+   ---------------------------------
+
+   procedure Set_Entity_With_Style_Check (N : Node_Id; Val : Entity_Id) is
+      Val_Actual : Entity_Id;
+      Nod        : Node_Id;
+
+   begin
+      Set_Entity (N, Val);
+
+      if Style_Check
+        and then not Suppress_Style_Checks (Val)
+        and then not In_Instance
+      then
+         if Nkind (N) = N_Identifier then
+            Nod := N;
+
+         elsif Nkind (N) = N_Expanded_Name then
+            Nod := Selector_Name (N);
+
+         else
+            return;
+         end if;
+
+         Val_Actual := Val;
+
+         --  A special situation arises for derived operations, where we want
+         --  to do the check against the parent (since the Sloc of the derived
+         --  operation points to the derived type declaration itself).
+
+         while not Comes_From_Source (Val_Actual)
+           and then Nkind (Val_Actual) in N_Entity
+           and then (Ekind (Val_Actual) = E_Enumeration_Literal
+                      or else Ekind (Val_Actual) = E_Function
+                      or else Ekind (Val_Actual) = E_Generic_Function
+                      or else Ekind (Val_Actual) = E_Procedure
+                      or else Ekind (Val_Actual) = E_Generic_Procedure)
+           and then Present (Alias (Val_Actual))
+         loop
+            Val_Actual := Alias (Val_Actual);
+         end loop;
+
+         --  Renaming declarations for generic actuals do not come from source,
+         --  and have a different name from that of the entity they rename, so
+         --  there is no style check to perform here.
+
+         if Chars (Nod) = Chars (Val_Actual) then
+            Style.Check_Identifier (Nod, Val_Actual);
+         end if;
+
+      end if;
+
+      Set_Entity (N, Val);
+   end Set_Entity_With_Style_Check;
+
+   ------------------------
+   -- Set_Name_Entity_Id --
+   ------------------------
+
+   procedure Set_Name_Entity_Id (Id : Name_Id; Val : Entity_Id) is
+   begin
+      Set_Name_Table_Info (Id, Int (Val));
+   end Set_Name_Entity_Id;
+
+   ---------------------
+   -- Set_Next_Actual --
+   ---------------------
+
+   procedure Set_Next_Actual (Ass1_Id : Node_Id; Ass2_Id : Node_Id) is
+   begin
+      if Nkind (Parent (Ass1_Id)) = N_Parameter_Association then
+         Set_First_Named_Actual (Parent (Ass1_Id), Ass2_Id);
+      end if;
+   end Set_Next_Actual;
+
+   -----------------------
+   -- Set_Public_Status --
+   -----------------------
+
+   procedure Set_Public_Status (Id : Entity_Id) is
+      S : constant Entity_Id := Current_Scope;
+
+   begin
+      if S = Standard_Standard
+        or else (Is_Public (S)
+                  and then (Ekind (S) = E_Package
+                             or else Is_Record_Type (S)
+                             or else Ekind (S) = E_Void))
+      then
+         Set_Is_Public (Id);
+
+      --  The bounds of an entry family declaration can generate object
+      --  declarations that are visible to the back-end, e.g. in the
+      --  the declaration of a composite type that contains tasks.
+
+      elsif Is_Public (S)
+        and then Is_Concurrent_Type (S)
+        and then not Has_Completion (S)
+        and then Nkind (Parent (Id)) = N_Object_Declaration
+      then
+         Set_Is_Public (Id);
+      end if;
+   end Set_Public_Status;
+
+   ----------------------------
+   -- Set_Scope_Is_Transient --
+   ----------------------------
+
+   procedure Set_Scope_Is_Transient (V : Boolean := True) is
+   begin
+      Scope_Stack.Table (Scope_Stack.Last).Is_Transient := V;
+   end Set_Scope_Is_Transient;
+
+   -------------------
+   -- Set_Size_Info --
+   -------------------
+
+   procedure Set_Size_Info (T1, T2 : Entity_Id) is
+   begin
+      --  We copy Esize, but not RM_Size, since in general RM_Size is
+      --  subtype specific and does not get inherited by all subtypes.
+
+      Set_Esize                     (T1, Esize                     (T2));
+      Set_Has_Biased_Representation (T1, Has_Biased_Representation (T2));
+
+      if Is_Discrete_Or_Fixed_Point_Type (T1)
+           and then
+         Is_Discrete_Or_Fixed_Point_Type (T2)
+      then
+         Set_Is_Unsigned_Type       (T1, Is_Unsigned_Type          (T2));
+      end if;
+
+      Set_Alignment                 (T1, Alignment                 (T2));
+   end Set_Size_Info;
+
+   --------------------
+   -- Static_Integer --
+   --------------------
+
+   function Static_Integer (N : Node_Id) return Uint is
+   begin
+      Analyze_And_Resolve (N, Any_Integer);
+
+      if N = Error
+        or else Error_Posted (N)
+        or else Etype (N) = Any_Type
+      then
+         return No_Uint;
+      end if;
+
+      if Is_Static_Expression (N) then
+         if not Raises_Constraint_Error (N) then
+            return Expr_Value (N);
+         else
+            return No_Uint;
+         end if;
+
+      elsif Etype (N) = Any_Type then
+         return No_Uint;
+
+      else
+         Error_Msg_N ("static integer expression required here", N);
+         return No_Uint;
+      end if;
+   end Static_Integer;
+
+   --------------------------
+   -- Statically_Different --
+   --------------------------
+
+   function Statically_Different (E1, E2 : Node_Id) return Boolean is
+      R1 : constant Node_Id := Get_Referenced_Object (E1);
+      R2 : constant Node_Id := Get_Referenced_Object (E2);
+
+   begin
+      return     Is_Entity_Name (R1)
+        and then Is_Entity_Name (R2)
+        and then Entity (R1) /= Entity (R2)
+        and then not Is_Formal (Entity (R1))
+        and then not Is_Formal (Entity (R2));
+   end Statically_Different;
+
+   -----------------------------
+   -- Subprogram_Access_Level --
+   -----------------------------
+
+   function Subprogram_Access_Level (Subp : Entity_Id) return Uint is
+   begin
+      if Present (Alias (Subp)) then
+         return Subprogram_Access_Level (Alias (Subp));
+      else
+         return Scope_Depth (Enclosing_Dynamic_Scope (Subp));
+      end if;
+   end Subprogram_Access_Level;
+
+   -----------------
+   -- Trace_Scope --
+   -----------------
+
+   procedure Trace_Scope (N : Node_Id; E : Entity_Id; Msg : String) is
+   begin
+      if Debug_Flag_W then
+         for J in 0 .. Scope_Stack.Last loop
+            Write_Str ("  ");
+         end loop;
+
+         Write_Str (Msg);
+         Write_Name (Chars (E));
+         Write_Str ("   line ");
+         Write_Int (Int (Get_Logical_Line_Number (Sloc (N))));
+         Write_Eol;
+      end if;
+   end Trace_Scope;
+
+   -----------------------
+   -- Transfer_Entities --
+   -----------------------
+
+   procedure Transfer_Entities (From : Entity_Id; To : Entity_Id) is
+      Ent      : Entity_Id := First_Entity (From);
+
+   begin
+      if No (Ent) then
+         return;
+      end if;
+
+      if (Last_Entity (To)) = Empty then
+         Set_First_Entity (To, Ent);
+      else
+         Set_Next_Entity (Last_Entity (To), Ent);
+      end if;
+
+      Set_Last_Entity (To, Last_Entity (From));
+
+      while Present (Ent) loop
+         Set_Scope (Ent, To);
+
+         if not Is_Public (Ent) then
+            Set_Public_Status (Ent);
+
+            if Is_Public (Ent)
+              and then Ekind (Ent) = E_Record_Subtype
+
+            then
+               --  The components of the propagated Itype must be public
+               --  as well.
+
+               declare
+                  Comp : Entity_Id;
+
+               begin
+                  Comp := First_Entity (Ent);
+
+                  while Present (Comp) loop
+                     Set_Is_Public (Comp);
+                     Next_Entity (Comp);
+                  end loop;
+               end;
+            end if;
+         end if;
+
+         Next_Entity (Ent);
+      end loop;
+
+      Set_First_Entity (From, Empty);
+      Set_Last_Entity (From, Empty);
+   end Transfer_Entities;
+
+   -----------------------
+   -- Type_Access_Level --
+   -----------------------
+
+   function Type_Access_Level (Typ : Entity_Id) return Uint is
+      Btyp : Entity_Id := Base_Type (Typ);
+
+   begin
+      --  If the type is an anonymous access type we treat it as being
+      --  declared at the library level to ensure that names such as
+      --  X.all'access don't fail static accessibility checks.
+
+      if Ekind (Btyp) in Access_Kind then
+         if Ekind (Btyp) = E_Anonymous_Access_Type then
+            return Scope_Depth (Standard_Standard);
+         end if;
+
+         Btyp := Root_Type (Btyp);
+      end if;
+
+      return Scope_Depth (Enclosing_Dynamic_Scope (Btyp));
+   end Type_Access_Level;
+
+   --------------------------
+   -- Unit_Declaration_Node --
+   --------------------------
+
+   function Unit_Declaration_Node (Unit_Id : Entity_Id) return Node_Id is
+      N : Node_Id := Parent (Unit_Id);
+
+   begin
+      --  Predefined operators do not have a full function declaration.
+
+      if Ekind (Unit_Id) = E_Operator then
+         return N;
+      end if;
+
+      while Nkind (N) /= N_Abstract_Subprogram_Declaration
+        and then Nkind (N) /= N_Formal_Package_Declaration
+        and then Nkind (N) /= N_Formal_Subprogram_Declaration
+        and then Nkind (N) /= N_Function_Instantiation
+        and then Nkind (N) /= N_Generic_Package_Declaration
+        and then Nkind (N) /= N_Generic_Subprogram_Declaration
+        and then Nkind (N) /= N_Package_Declaration
+        and then Nkind (N) /= N_Package_Body
+        and then Nkind (N) /= N_Package_Instantiation
+        and then Nkind (N) /= N_Package_Renaming_Declaration
+        and then Nkind (N) /= N_Procedure_Instantiation
+        and then Nkind (N) /= N_Subprogram_Declaration
+        and then Nkind (N) /= N_Subprogram_Body
+        and then Nkind (N) /= N_Subprogram_Body_Stub
+        and then Nkind (N) /= N_Subprogram_Renaming_Declaration
+        and then Nkind (N) /= N_Task_Body
+        and then Nkind (N) /= N_Task_Type_Declaration
+        and then Nkind (N) not in N_Generic_Renaming_Declaration
+      loop
+         N := Parent (N);
+         pragma Assert (Present (N));
+      end loop;
+
+      return N;
+   end Unit_Declaration_Node;
+
+   ----------------------
+   -- Within_Init_Proc --
+   ----------------------
+
+   function Within_Init_Proc return Boolean is
+      S : Entity_Id;
+
+   begin
+      S := Current_Scope;
+      while not Is_Overloadable (S) loop
+         if S = Standard_Standard then
+            return False;
+         else
+            S := Scope (S);
+         end if;
+      end loop;
+
+      return Chars (S) = Name_uInit_Proc;
+   end Within_Init_Proc;
+
+   ----------------
+   -- Wrong_Type --
+   ----------------
+
+   procedure Wrong_Type (Expr : Node_Id; Expected_Type : Entity_Id) is
+      Found_Type : constant Entity_Id := First_Subtype (Etype (Expr));
+      Expec_Type : constant Entity_Id := First_Subtype (Expected_Type);
+
+      function Has_One_Matching_Field return Boolean;
+      --  Determines whether Expec_Type is a record type with a single
+      --  component or discriminant whose type matches the found type or
+      --  is a one dimensional array whose component type matches the
+      --  found type.
+
+      function Has_One_Matching_Field return Boolean is
+         E : Entity_Id;
+
+      begin
+         if Is_Array_Type (Expec_Type)
+           and then Number_Dimensions (Expec_Type) = 1
+           and then
+             Covers (Etype (Component_Type (Expec_Type)), Found_Type)
+         then
+            return True;
+
+         elsif not Is_Record_Type (Expec_Type) then
+            return False;
+
+         else
+            E := First_Entity (Expec_Type);
+
+            loop
+               if No (E) then
+                  return False;
+
+               elsif (Ekind (E) /= E_Discriminant
+                       and then Ekind (E) /= E_Component)
+                 or else (Chars (E) = Name_uTag
+                           or else Chars (E) = Name_uParent)
+               then
+                  Next_Entity (E);
+
+               else
+                  exit;
+               end if;
+            end loop;
+
+            if not Covers (Etype (E), Found_Type) then
+               return False;
+
+            elsif Present (Next_Entity (E)) then
+               return False;
+
+            else
+               return True;
+            end if;
+         end if;
+      end Has_One_Matching_Field;
+
+   --  Start of processing for Wrong_Type
+
+   begin
+      --  Don't output message if either type is Any_Type, or if a message
+      --  has already been posted for this node. We need to do the latter
+      --  check explicitly (it is ordinarily done in Errout), because we
+      --  are using ! to force the output of the error messages.
+
+      if Expec_Type = Any_Type
+        or else Found_Type = Any_Type
+        or else Error_Posted (Expr)
+      then
+         return;
+
+      --  In  an instance, there is an ongoing problem with completion of
+      --  type derived from private types. Their structure is what Gigi
+      --  expects, but the  Etype is the parent type rather than the
+      --  derived private type itself. Do not flag error in this case. The
+      --  private completion is an entity without a parent, like an Itype.
+      --  Similarly, full and partial views may be incorrect in the instance.
+      --  There is no simple way to insure that it is consistent ???
+
+      elsif In_Instance then
+
+         if Etype (Etype (Expr)) = Etype (Expected_Type)
+           and then No (Parent (Expected_Type))
+         then
+            return;
+         end if;
+      end if;
+
+      --  An interesting special check. If the expression is parenthesized
+      --  and its type corresponds to the type of the sole component of the
+      --  expected record type, or to the component type of the expected one
+      --  dimensional array type, then assume we have a bad aggregate attempt.
+
+      if Nkind (Expr) in N_Subexpr
+        and then Paren_Count (Expr) /= 0
+        and then Has_One_Matching_Field
+      then
+         Error_Msg_N ("positional aggregate cannot have one component", Expr);
+
+      --  Another special check, if we are looking for a pool-specific access
+      --  type and we found an E_Access_Attribute_Type, then we have the case
+      --  of an Access attribute being used in a context which needs a pool-
+      --  specific type, which is never allowed. The one extra check we make
+      --  is that the expected designated type covers the Found_Type.
+
+      elsif Is_Access_Type (Expec_Type)
+        and then Ekind (Found_Type) = E_Access_Attribute_Type
+        and then Ekind (Base_Type (Expec_Type)) /= E_General_Access_Type
+        and then Ekind (Base_Type (Expec_Type)) /= E_Anonymous_Access_Type
+        and then Covers
+          (Designated_Type (Expec_Type), Designated_Type (Found_Type))
+      then
+         Error_Msg_N ("result must be general access type!", Expr);
+         Error_Msg_NE ("add ALL to }!", Expr, Expec_Type);
+
+      --  If the expected type is an anonymous access type, as for access
+      --  parameters and discriminants, the error is on the designated types.
+
+      elsif Ekind (Expec_Type) = E_Anonymous_Access_Type then
+         if Comes_From_Source (Expec_Type) then
+            Error_Msg_NE ("expected}!", Expr, Expec_Type);
+         else
+            Error_Msg_NE
+              ("expected an access type with designated}",
+                 Expr, Designated_Type (Expec_Type));
+         end if;
+
+         if Is_Access_Type (Found_Type)
+           and then not Comes_From_Source (Found_Type)
+         then
+            Error_Msg_NE
+              ("found an access type with designated}!",
+                Expr, Designated_Type (Found_Type));
+         else
+            if From_With_Type (Found_Type) then
+               Error_Msg_NE ("found incomplete}!", Expr, Found_Type);
+               Error_Msg_NE
+                 ("\possibly missing with_clause on&", Expr,
+                   Scope (Found_Type));
+            else
+               Error_Msg_NE ("found}!", Expr, Found_Type);
+            end if;
+         end if;
+
+      --  Normal case of one type found, some other type expected
+
+      else
+         --  If the names of the two types are the same, see if some
+         --  number of levels of qualification will help. Don't try
+         --  more than three levels, and if we get to standard, it's
+         --  no use (and probably represents an error in the compiler)
+         --  Also do not bother with internal scope names.
+
+         declare
+            Expec_Scope : Entity_Id;
+            Found_Scope : Entity_Id;
+
+         begin
+            Expec_Scope := Expec_Type;
+            Found_Scope := Found_Type;
+
+            for Levels in Int range 0 .. 3 loop
+               if Chars (Expec_Scope) /= Chars (Found_Scope) then
+                  Error_Msg_Qual_Level := Levels;
+                  exit;
+               end if;
+
+               Expec_Scope := Scope (Expec_Scope);
+               Found_Scope := Scope (Found_Scope);
+
+               exit when Expec_Scope = Standard_Standard
+                           or else
+                         Found_Scope = Standard_Standard
+                           or else
+                         not Comes_From_Source (Expec_Scope)
+                           or else
+                         not Comes_From_Source (Found_Scope);
+            end loop;
+         end;
+
+         Error_Msg_NE ("expected}!", Expr, Expec_Type);
+
+         if Is_Entity_Name (Expr)
+           and then Is_Package (Entity (Expr))
+         then
+            Error_Msg_N ("found package name!", Expr);
+
+         elsif Is_Entity_Name (Expr)
+           and then
+             (Ekind (Entity (Expr)) = E_Procedure
+                or else
+              Ekind (Entity (Expr)) = E_Generic_Procedure)
+         then
+            Error_Msg_N ("found procedure name instead of function!", Expr);
+
+         --  catch common error: a prefix or infix operator which is not
+         --  directly visible because the type isn't.
+
+         elsif Nkind (Expr) in N_Op
+            and then Is_Overloaded (Expr)
+            and then not Is_Immediately_Visible (Expec_Type)
+            and then not Is_Potentially_Use_Visible (Expec_Type)
+            and then not In_Use (Expec_Type)
+            and then Has_Compatible_Type (Right_Opnd (Expr), Expec_Type)
+         then
+            Error_Msg_N (
+              "operator of the type is not directly visible!", Expr);
+
+         else
+            Error_Msg_NE ("found}!", Expr, Found_Type);
+         end if;
+
+         Error_Msg_Qual_Level := 0;
+      end if;
+   end Wrong_Type;
+
+end Sem_Util;
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
new file mode 100644
index 00000000000..2d493944d41
--- /dev/null
+++ b/gcc/ada/sem_util.ads
@@ -0,0 +1,698 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             S E M _ U T I L                              --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.225 $
+--                                                                          --
+--          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). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  Package containing utility procedures used throughout the semantics
+
+with Einfo;  use Einfo;
+with Types;  use Types;
+with Uintp;  use Uintp;
+with Urealp; use Urealp;
+
+package Sem_Util is
+
+   procedure Add_Access_Type_To_Process (E : Entity_Id; A : Entity_Id);
+   --  Add A to the list of access types to process when expanding the
+   --  freeze node of E.
+
+   function Alignment_In_Bits (E : Entity_Id) return Uint;
+   --  If the alignment of the type or object E is currently known to the
+   --  compiler, then this function returns the alignment value in bits.
+   --  Otherwise Uint_0 is returned, indicating that the alignment of the
+   --  entity is not yet known to the compiler.
+
+   procedure Apply_Compile_Time_Constraint_Error
+     (N   : Node_Id;
+      Msg : String;
+      Ent : Entity_Id  := Empty;
+      Typ : Entity_Id  := Empty;
+      Loc : Source_Ptr := No_Location;
+      Rep : Boolean    := True);
+   --  N is a subexpression which will raise constraint error when evaluated
+   --  at runtime. Msg is a message that explains the reason for raising the
+   --  exception. The last character is ? if the message is always a
+   --  warning, even in Ada 95, and is not a ? if the message represents an
+   --  illegality (because of violation of static expression rules) in Ada 95
+   --  (but not in Ada 83). Typically this routine posts all messages at
+   --  the Sloc of node N. However, if Loc /= No_Location, Loc is the Sloc
+   --  used to output the message. After posting the appropriate message,
+   --  and if the flag Rep is set, this routine replaces the expression
+   --  with an N_Raise_Constraint_Error node. This node is then marked as
+   --  being static if the original node is static, but sets the flag
+   --  Raises_Constraint_Error, preventing further evaluation.
+   --  The error message may contain a } or & insertion character.
+   --  This normally references Etype (N), unless the Ent argument is given
+   --  explicitly, in which case it is used instead. The type of the raise
+   --  node that is built is normally Etype (N), but if the Typ parameter
+   --  is present, this is used instead.
+
+   function Build_Actual_Subtype
+     (T    : Entity_Id;
+      N    : Node_Or_Entity_Id)
+      return Node_Id;
+   --  Build an anonymous subtype for an entity or expression, using the
+   --  bounds of the entity or the discriminants of the enclosing record.
+   --  T is the type for which the actual subtype is required, and N is either
+   --  a defining identifier, or any subexpression.
+
+   function Build_Actual_Subtype_Of_Component
+     (T    : Entity_Id;
+      N    : Node_Id)
+      return Node_Id;
+   --  Determine whether a selected component has a type that depends on
+   --  discriminants, and build actual subtype for it if so.
+
+   function Build_Discriminal_Subtype_Of_Component
+     (T    : Entity_Id)
+      return Node_Id;
+   --  Determine whether a record component has a type that depends on
+   --  discriminants, and build actual subtype for it if so.
+
+   procedure Build_Elaboration_Entity (N : Node_Id; Spec_Id : Entity_Id);
+   --  Given a compilation unit node N, allocate an elaboration boolean for
+   --  the compilation unit, and install it in the Elaboration_Entity field
+   --  of Spec_Id, the entity for the compilation unit.
+
+   procedure Check_Fully_Declared (T : Entity_Id; N : Node_Id);
+   --  Verify that the full declaration of type T has been seen. If not,
+   --  place error message on node N. Used in  object declarations, type
+   --  conversions, qualified expressions.
+
+   procedure Check_Potentially_Blocking_Operation (N : Node_Id);
+   --  N is one of the statement forms that is a potentially blocking
+   --  operation. If it appears within a protected action, emit warning
+   --  and raise Program_Error.
+
+   procedure Check_VMS (Construct : Node_Id);
+   --  Check that this the target is OpenVMS, and if so, return with
+   --  no effect, otherwise post an error noting this can only be used
+   --  with OpenVMS ports. The argument is the construct in question
+   --  and is used to post the error message.
+
+   function Collect_Primitive_Operations (T : Entity_Id) return Elist_Id;
+   --  Called upon type derivation and extension. We scan the declarative
+   --  part in  which the type appears, and collect subprograms that have
+   --  one subsidiary subtype of the type. These subprograms can only
+   --  appear after the type itself.
+
+   function Compile_Time_Constraint_Error
+     (N    : Node_Id;
+      Msg  : String;
+      Ent  : Entity_Id  := Empty;
+      Loc  : Source_Ptr := No_Location)
+      return Node_Id;
+   --  Subsidiary to Apply_Compile_Time_Constraint_Error and Checks routines.
+   --  Does not modify any nodes, but generates a warning (or error) message.
+   --  For convenience, the function always returns its first argument.
+
+   procedure Conditional_Delay (New_Ent, Old_Ent : Entity_Id);
+   --  Sets the Has_Delayed_Freeze flag of New if the Delayed_Freeze flag
+   --  of Old is set and Old has no yet been Frozen (i.e. Is_Frozen is false);
+
+   function Current_Entity (N : Node_Id) return Entity_Id;
+   --  Find the currently visible definition for a given identifier, that is to
+   --  say the first entry in the visibility chain for the Chars of N.
+
+   function Current_Entity_In_Scope (N : Node_Id) return Entity_Id;
+   --  Find whether there is a previous definition for identifier N in the
+   --  current scope. Because declarations for a scope are not necessarily
+   --  contiguous (e.g. for packages) the first entry on the visibility chain
+   --  for N is not necessarily in the current scope.
+
+   function Current_Scope return Entity_Id;
+   --  Get entity representing current scope
+
+   function Current_Subprogram return Entity_Id;
+   --  Returns current enclosing subprogram. If Current_Scope is a subprogram,
+   --  then that is what is returned, otherwise the Enclosing_Subprogram of
+   --  the Current_Scope is returned. The returned value is Empty if this
+   --  is called from a library package which is not within any subprogram.
+
+   function Defining_Entity (N : Node_Id) return Entity_Id;
+   --  Given a declaration N, returns the associated defining entity. If
+   --  the declaration has a specification, the entity is obtained from
+   --  the specification. If the declaration has a defining unit name,
+   --  then the defining entity is obtained from the defining unit name
+   --  ignoring any child unit prefixes.
+
+   function Denotes_Discriminant (N : Node_Id) return Boolean;
+   --  Returns True if node N is an N_Identifier node for a discriminant.
+   --  Returns False for any other kind of node, or for an N_Identifier
+   --  node that does not denote a discriminant.
+
+   function Depends_On_Discriminant (N : Node_Id) return Boolean;
+   --  Returns True if N denotes a discriminant or if N is a range, a subtype
+   --  indication or a scalar subtype where one of the bounds is a
+   --  discriminant.
+
+   function Designate_Same_Unit
+     (Name1 : Node_Id;
+      Name2 : Node_Id)
+      return  Boolean;
+   --  Return true if Name1 and Name2 designate the same unit name;
+   --  each of these names is supposed to be a selected component name,
+   --  an expanded name, a defining program unit name or an identifier
+
+   function Enclosing_Generic_Body
+     (E    : Entity_Id)
+      return Node_Id;
+   --  Returns the Node_Id associated with the innermost enclosing
+   --  generic body, if any. If none, then returns Empty.
+
+   function Enclosing_Lib_Unit_Entity return Entity_Id;
+   --  Returns the entity of enclosing N_Compilation_Unit Node which is the
+   --  root of the current scope (which must not be Standard_Standard, and
+   --  the caller is responsible for ensuring this condition).
+
+   function Enclosing_Lib_Unit_Node (N : Node_Id) return Node_Id;
+   --  Returns the enclosing N_Compilation_Unit Node that is the root
+   --  of a subtree containing N.
+
+   function Enclosing_Subprogram (E : Entity_Id) return Entity_Id;
+   --  Utility function to return the Ada entity of the subprogram enclosing
+   --  the entity E, if any. Returns Empty if no enclosing subprogram.
+
+   procedure Ensure_Freeze_Node (E : Entity_Id);
+   --  Make sure a freeze node is allocated for entity E. If necessary,
+   --  build and initialize a new freeze node and set Has_Delayed_Freeze
+   --  true for entity E.
+
+   procedure Enter_Name (Def_Id : Node_Id);
+   --  Insert new name in symbol table of current scope with check for
+   --  duplications (error message is issued if a conflict is found)
+   --  Note: Enter_Name is not used for overloadable entities, instead
+   --  these are entered using Sem_Ch6.Enter_Overloadable_Entity.
+
+   function Find_Corresponding_Discriminant
+     (Id   : Node_Id;
+      Typ  : Entity_Id)
+      return Entity_Id;
+   --  Because discriminants may have different names in a generic unit
+   --  and in an instance, they are resolved positionally when possible.
+   --  A reference to a discriminant carries the discriminant that it
+   --  denotes when analyzed. Subsequent uses of this id on a different
+   --  type denote the discriminant at the same position in this new type.
+
+   function First_Actual (Node : Node_Id) return Node_Id;
+   --  Node is an N_Function_Call or N_Procedure_Call_Statement node. The
+   --  result returned is the first actual parameter in declaration order
+   --  (not the order of parameters as they appeared in the source, which
+   --  can be quite different as a result of the use of named parameters).
+   --  Empty is returned for a call with no parameters. The procedure for
+   --  iterating through the actuals in declaration order is to use this
+   --  function to find the first actual, and then use Next_Actual to obtain
+   --  the next actual in declaration order. Note that the value returned
+   --  is always the expression (not the N_Parameter_Association nodes
+   --  even if named association is used).
+
+   function Full_Qualified_Name (E : Entity_Id) return String_Id;
+   --  Generates the string literal corresponding to the E's full qualified
+   --  name in upper case. An ASCII.NUL is appended as the last character
+
+   procedure Gather_Components
+     (Typ           : Entity_Id;
+      Comp_List     : Node_Id;
+      Governed_By   : List_Id;
+      Into          : Elist_Id;
+      Report_Errors : out Boolean);
+   --  The purpose of this procedure is to gather the valid components
+   --  in a record type according to the values of its discriminants, in order
+   --  to validate the components of a record aggregate.
+   --
+   --    Typ is the type of the aggregate when its constrained discriminants
+   --      need to be collected, otherwise it is Empty.
+   --
+   --    Comp_List is an N_Component_List node.
+   --
+   --    Governed_By is a list of N_Component_Association nodes,
+   --     where each choice list contains the name of a discriminant and
+   --     the expression field gives its value. The values of the
+   --     discriminants governing the (possibly nested) variant parts in
+   --     Comp_List are found in this Component_Association List.
+   --
+   --    Into is the list where the valid components are appended.
+   --     Note that Into need not be an Empty list. If it's not, components
+   --     are attached to its tail.
+   --
+   --    Report_Errors is set to True if the values of the discriminants
+   --     are non-static.
+
+   --  This procedure is also used when building a record subtype. If the
+   --  discriminant constraint of the subtype is static, the components of the
+   --  subtype are only those of the variants selected by the values of the
+   --  discriminants. Otherwise all components of the parent must be included
+   --  in the subtype for semantic analysis.
+
+   function Get_Actual_Subtype (N : Node_Id) return Entity_Id;
+   --  Given a node for an expression, obtain the actual subtype of the
+   --  expression. In the case of a parameter where the formal is an
+   --  unconstrained array or discriminated type, this will be the
+   --  previously constructed subtype of the actual. Note that this is
+   --  not quite the "Actual Subtype" of the RM, since it is always
+   --  a constrained type, i.e. it is the subtype of the value of the
+   --  actual. The actual subtype is also returned in other cases where
+   --  it has already been constructed for an object. Otherwise the
+   --  expression type is returned unchanged, except for the case of an
+   --  unconstrained array type, where an actual subtype is created, using
+   --  Insert_Actions if necessary to insert any associated actions.
+
+   function Get_Actual_Subtype_If_Available (N : Node_Id) return Entity_Id;
+   --  This is like Get_Actual_Subtype, except that it never constructs an
+   --  actual subtype. If an actual subtype is already available, i.e. the
+   --  Actual_Subtype field of the corresponding entity is set, then it is
+   --  returned. Otherwise the Etype of the node is returned.
+
+   function Get_Default_External_Name (E : Node_Or_Entity_Id) return Node_Id;
+   --  This is used to construct the string literal node representing a
+   --  default external name, i.e. one that is constructed from the name
+   --  of an entity, or (in the case of extended DEC import/export pragmas,
+   --  an identifier provided as the external name. Letters in the name are
+   --  according to the setting of Opt.External_Name_Default_Casing.
+
+   procedure Get_Index_Bounds (N : Node_Id; L, H : out Node_Id);
+   --  This procedure assigns to L and H respectively the values of the
+   --  low and high bounds of node N, which must be a range, subtype
+   --  indication, or the name of a scalar subtype. The result in L, H
+   --  may be set to Error if there was an earlier error in the range.
+
+   function Get_Enum_Lit_From_Pos
+     (T    : Entity_Id;
+      Pos  : Uint;
+      Loc  : Source_Ptr)
+      return Entity_Id;
+   --  This function obtains the E_Enumeration_Literal entity for the
+   --  specified value from the enumneration type or subtype T. The
+   --  second argument is the Pos value, which is assumed to be in range.
+   --  The third argument supplies a source location for constructed
+   --  nodes returned by this function.
+
+   function Get_Name_Entity_Id (Id : Name_Id) return Entity_Id;
+   --  An entity value is associated with each name in the name table. The
+   --  Get_Name_Entity_Id function fetches the Entity_Id of this entity,
+   --  which is the innermost visible entity with the given name. See the
+   --  body of Sem_Ch8 for further details on handling of entity visibility.
+
+   function Get_Referenced_Object (N : Node_Id) return Node_Id;
+   --  Given a node, return the renamed object if the node represents
+   --  a renamed object, otherwise return the node unchanged. The node
+   --  may represent an arbitrary expression.
+
+   function Get_Subprogram_Body (E : Entity_Id) return Node_Id;
+   --  Given the entity for a subprogram (E_Function or E_Procedure),
+   --  return the corresponding N_Subprogram_Body node. If the corresponding
+   --  body of the declaration is missing (as for an imported subprogram)
+   --  return Empty.
+
+   function Get_Task_Body_Procedure (E : Entity_Id) return Node_Id;
+   pragma Inline (Get_Task_Body_Procedure);
+   --  Given an entity for a task type or subtype, retrieves the
+   --  Task_Body_Procedure field from the corresponding task type
+   --  declaration.
+
+   function Has_Infinities (E : Entity_Id) return Boolean;
+   --  Determines if the range of the floating-point type E includes
+   --  infinities. Returns False if E is not a floating-point type.
+
+   function Has_Private_Component (Type_Id : Entity_Id) return Boolean;
+   --  Check if a type has a (sub)component of a private type that has not
+   --  yet received a full declaration.
+
+   function Has_Tagged_Component (Typ : Entity_Id) return Boolean;
+   --  Typ must be a composite type (array or record). This function is used
+   --  to check if '=' has to be expanded into a bunch component comparaisons.
+
+   function In_Instance return Boolean;
+   --  Returns True if the current scope is within a generic instance.
+
+   function In_Instance_Body return Boolean;
+   --  Returns True if current scope is within the body of an instance, where
+   --  several semantic checks (e.g. accessibility checks) are relaxed.
+
+   function In_Instance_Not_Visible return Boolean;
+   --  Returns True if current scope is with the private part or the body of
+   --  an instance. Other semantic checks are suppressed in this context.
+
+   function In_Instance_Visible_Part return Boolean;
+   --  Returns True if current scope is within the visible part of a package
+   --  instance, where several additional semantic checks apply.
+
+   function In_Subprogram_Or_Concurrent_Unit return Boolean;
+   --  Determines if the current scope is within a subprogram compilation
+   --  unit (inside a subprogram declaration, subprogram body, or generic
+   --  subprogram declaration) or within a task or protected body. The test
+   --  is for appearing anywhere within such a construct (that is it does not
+   --  need to be directly within).
+
+   function In_Visible_Part (Scope_Id : Entity_Id) return Boolean;
+   --  Determine whether a declaration occurs within the visible part of a
+   --  package specification. The package must be on the scope stack, and the
+   --  corresponding private part must not.
+
+   function Is_AAMP_Float (E : Entity_Id) return Boolean;
+   --  Defined for all type entities. Returns True only for the base type
+   --  of float types with AAMP format. The particular format is determined
+   --  by the Digits_Value value which is 6 for the 32-bit floating point type,
+   --  or 9 for the 48-bit type. This is not an attribute function (like
+   --  VAX_Float) in order to not use up an extra flag and to prevent
+   --  the dependency of Einfo on Targparm which would be required for a
+   --  synthesized attribute.
+
+   function Is_Dependent_Component_Of_Mutable_Object
+     (Object : Node_Id)
+      return   Boolean;
+   --  Returns True if Object is the name of a subcomponent that
+   --  depends on discriminants of a variable whose nominal subtype
+   --  is unconstrained and not indefinite, and the variable is
+   --  not aliased.  Otherwise returns False.  The nodes passed
+   --  to this function are assumed to denote objects.
+
+   function Is_Actual_Parameter (N : Node_Id) return Boolean;
+   --  Determines if N is an actual parameter in a subprogram call.
+
+   function Is_Aliased_View (Obj : Node_Id) return Boolean;
+   --  Determine if Obj is an aliased view, i.e. the name of an
+   --  object to which 'Access or 'Unchecked_Access can apply.
+
+   function Is_Atomic_Object (N : Node_Id) return Boolean;
+   --  Determines if the given node denotes an atomic object in the sense
+   --  of the legality checks described in RM C.6(12).
+
+   function Is_False (U : Uint) return Boolean;
+   --  The argument is a Uint value which is the Boolean'Pos value of a
+   --  Boolean operand (i.e. is either 0 for False, or 1 for True). This
+   --  function simply tests if it is False (i.e. zero)
+
+   function Is_Fixed_Model_Number (U : Ureal; T : Entity_Id) return Boolean;
+   --  Returns True iff the number U is a model number of the fixed-
+   --  point type T, i.e. if it is an exact multiple of Small.
+
+   function Is_Fully_Initialized_Type (Typ : Entity_Id) return Boolean;
+   --  Typ is a type entity. This function returns true if this type is
+   --  fully initialized, meaning that an object of the type is fully
+   --  initialized. Note that initialization resulting from the use of
+   --  pragma Normalized_Scalars does not count.
+
+   function Is_Inherited_Operation (E : Entity_Id) return Boolean;
+   --  E is a subprogram. Return True is E is an implicit operation inherited
+   --  by a derived type declarations.
+
+   function Is_Library_Level_Entity (E : Entity_Id) return Boolean;
+   --  A library-level declaration is one that is accessible from Standard,
+   --  i.e. a library unit or an entity declared in a library package.
+
+   function Is_Local_Variable_Reference (Expr : Node_Id) return Boolean;
+   --  Determines whether Expr is a refeference to a variable or IN OUT
+   --  mode parameter of the current enclosing subprogram.
+
+   function Is_Object_Reference (N : Node_Id) return Boolean;
+   --  Determines if the tree referenced by N represents an object. Both
+   --  variable and constant objects return True (compare Is_Variable).
+
+   function Is_OK_Variable_For_Out_Formal (AV : Node_Id) return Boolean;
+   --  Used to test if AV is an acceptable formal for an OUT or IN OUT
+   --  formal. Note that the Is_Variable function is not quite the right
+   --  test because this is a case in which conversions whose expression
+   --  is a variable (in the Is_Variable sense) with a non-tagged type
+   --  target are considered view conversions and hence variables.
+
+   function Is_RCI_Pkg_Spec_Or_Body (Cunit : Node_Id) return Boolean;
+   --  Return True if a compilation unit is the specification or the
+   --  body of a remote call interface package.
+
+   function Is_Remote_Access_To_Class_Wide_Type (E : Entity_Id) return Boolean;
+   --  Return True if E is a remote access-to-class-wide-limited_private type
+
+   function Is_Remote_Access_To_Subprogram_Type (E : Entity_Id) return Boolean;
+   --  Return True if E is a remote access to subprogram type.
+
+   function Is_Remote_Call (N : Node_Id) return Boolean;
+   --  Return True if N denotes a potentially remote call
+
+   function Is_Selector_Name (N : Node_Id) return Boolean;
+   --  Given an N_Identifier node N, determines if it is a Selector_Name.
+   --  As described in Sinfo, Selector_Names are special because they
+   --  represent use of the N_Identifier node for a true identifer, when
+   --  normally such nodes represent a direct name.
+
+   function Is_Statement (N : Node_Id) return Boolean;
+   --  Check if the node N is a statement node. Note that this includes
+   --  the case of procedure call statements (unlike the direct use of
+   --  the N_Statement_Other_Than_Procedure_Call subtype from Sinfo)
+
+   function Is_Transfer (N : Node_Id) return Boolean;
+   --  Returns True if the node N is a statement which is known to cause
+   --  an unconditional transfer of control at runtime, i.e. the following
+   --  statement definitely will not be executed.
+
+   function Is_True (U : Uint) return Boolean;
+   --  The argument is a Uint value which is the Boolean'Pos value of a
+   --  Boolean operand (i.e. is either 0 for False, or 1 for True). This
+   --  function simply tests if it is True (i.e. non-zero)
+
+   function Is_Variable (N : Node_Id) return Boolean;
+   --  Determines if the tree referenced by N represents a variable, i.e.
+   --  can appear on the left side of an assignment. There is one situation,
+   --  namely formal parameters, in which non-tagged type conversions are
+   --  also considered variables, but Is_Variable returns False for such
+   --  cases, since it has no knowledge of the context. Note that this is
+   --  the point at which Assignment_OK is checked, and True is returned
+   --  for any tree thus marked.
+
+   function Is_Volatile_Object (N : Node_Id) return Boolean;
+   --  Determines if the given node denotes an volatile object in the sense
+   --  of the legality checks described in RM C.6(12).
+
+   procedure Kill_Size_Check_Code (E : Entity_Id);
+   --  Called when an address clause or pragma Import is applied to an
+   --  entity. If the entity is a variable or a constant, and size check
+   --  code is present, this size check code is killed, since the object
+   --  will not be allocated by the program.
+
+   function New_External_Entity
+     (Kind         : Entity_Kind;
+      Scope_Id     : Entity_Id;
+      Sloc_Value   : Source_Ptr;
+      Related_Id   : Entity_Id;
+      Suffix       : Character;
+      Suffix_Index : Nat := 0;
+      Prefix       : Character := ' ')
+      return         Entity_Id;
+   --  This function creates an N_Defining_Identifier node for an internal
+   --  created entity, such as an implicit type or subtype, or a record
+   --  initialization procedure. The entity name is constructed with a call
+   --  to New_External_Name (Related_Id, Suffix, Suffix_Index, Prefix), so
+   --  that the generated name may be referenced as a public entry, and the
+   --  Is_Public flag is set if needed (using Set_Public_Status). If the
+   --  entity is for a type or subtype, the size/align fields are initialized
+   --  to unknown (Uint_0).
+
+   function New_Internal_Entity
+     (Kind       : Entity_Kind;
+      Scope_Id   : Entity_Id;
+      Sloc_Value : Source_Ptr;
+      Id_Char    : Character)
+      return       Entity_Id;
+   --  This function is similar to New_External_Entity, except that the
+   --  name is constructed by New_Internal_Name (Id_Char). This is used
+   --  when the resulting entity does not have to be referenced as a
+   --  public entity (and in this case Is_Public is not set).
+
+   procedure Next_Actual (Actual_Id : in out Node_Id);
+   pragma Inline (Next_Actual);
+   --  Next_Actual (N) is equivalent to N := Next_Actual (N)
+
+   function Next_Actual (Actual_Id : Node_Id) return Node_Id;
+   --  Find next actual parameter in declaration order. As described for
+   --  First_Actual, this is the next actual in the declaration order, not
+   --  the call order, so this does not correspond to simply taking the
+   --  next entry of the Parameter_Associations list. The argument is an
+   --  actual previously returned by a call to First_Actual or Next_Actual.
+   --  Note tha the result produced is always an expression, not a parameter
+   --  assciation node, even if named notation was used.
+
+   procedure Normalize_Actuals
+     (N       : Node_Id;
+      S       : Entity_Id;
+      Report  : Boolean;
+      Success : out Boolean);
+   --  Reorders lists of actuals according to names of formals, value returned
+   --  in Success indicates sucess of reordering. For more details, see body.
+   --  Errors are reported only if Report is set to True.
+
+   procedure Note_Possible_Modification (N : Node_Id);
+   --  This routine is called if the sub-expression N maybe the target of
+   --  an assignment (e.g. it is the left side of an assignment, used as
+   --  an out parameters, or used as prefixes of access attributes). It
+   --  sets May_Be_Modified in the associated entity if there is one,
+   --  taking into account the rule that in the case of renamed objects,
+   --  it is the flag in the renamed object that must be set.
+
+   function Object_Access_Level (Obj : Node_Id) return Uint;
+   --  Return the accessibility level of the view of the object Obj.
+   --  For convenience, qualified expressions applied to object names
+   --  are also allowed as actuals for this function.
+
+   function Private_Component (Type_Id : Entity_Id) return Entity_Id;
+   --  Returns some private component (if any) of the given Type_Id.
+   --  Used to enforce the rules on visibility of operations on composite
+   --  types, that depend on the full view of the component type. For a
+   --  record type there may be several such components, we just return
+   --  the first one.
+
+   procedure Process_End_Label (N : Node_Id; Typ : Character);
+   --  N is a node whose End_Label is to be processed, generating all
+   --  appropriate cross-reference entries, and performing style checks
+   --  for any identifier references in the end label. Typ is either
+   --  'e' or 't indicating the type of the cross-reference entity
+   --  (e for spec, t for body, see Lib.Xref spec for details).
+
+   function Real_Convert (S : String) return Node_Id;
+   --  S is a possibly signed syntactically valid real literal. The result
+   --  returned is an N_Real_Literal node representing the literal value.
+
+   function Requires_Transient_Scope (Id : Entity_Id) return Boolean;
+   --  E is a type entity. The result is True when temporaries of this
+   --  type need to be wrapped in a transient scope to be reclaimed
+   --  properly when a secondary stack is in use. Examples of types
+   --  requiring such wrapping are controlled types and variable-sized
+   --  types including unconstrained arrays
+
+   procedure Reset_Analyzed_Flags (N : Node_Id);
+   --  Reset the Analyzed flags in all nodes of the tree whose root is N
+
+   function Same_Name (N1, N2 : Node_Id) return Boolean;
+   --  Determine if two (possibly expanded) names are the same name
+
+   function Same_Type (T1, T2 : Entity_Id) return Boolean;
+   --  Determines if T1 and T2 represent exactly the same type. Two types
+   --  are the same if they are identical, or if one is an unconstrained
+   --  subtype of the other, or they are both common subtypes of the same
+   --  type with identical contraints. The result returned is conservative.
+   --  It is True if the types are known to be the same, but a result of
+   --  False is indecisive (e.g. the compiler may not be able to tell that
+   --  two constraints are identical).
+
+   function Scope_Within_Or_Same (Scope1, Scope2 : Entity_Id) return Boolean;
+   --  Determines if the entity Scope1 is the same as Scope2, or if it is
+   --  inside it, where both entities represent scopes. Note that scopes
+   --  are only partially ordered, so Scope_Within_Or_Same (A,B) and
+   --  Scope_Within_Or_Same (B,A) can both be False for a given pair A,B.
+
+   function Scope_Within (Scope1, Scope2 : Entity_Id) return Boolean;
+   --  Like Scope_Within_Or_Same, except that this function returns
+   --  False in the case where Scope1 and Scope2 are the same scope.
+
+   procedure Set_Current_Entity (E : Entity_Id);
+   --  Establish the entity E as the currently visible definition of its
+   --  associated name (i.e. the Node_Id associated with its name)
+
+   procedure Set_Entity_With_Style_Check (N : Node_Id; Val : Entity_Id);
+   --  This procedure has the same calling sequence as Set_Entity, but
+   --  if Style_Check is set, then it calls a style checking routine which
+   --  can check identifier spelling style.
+
+   procedure Set_Name_Entity_Id (Id : Name_Id; Val : Entity_Id);
+   --  Sets the Entity_Id value associated with the given name, which is the
+   --  Id of the innermost visible entity with the given name. See the body
+   --  of package Sem_Ch8 for further details on the handling of visibility.
+
+   procedure Set_Next_Actual (Ass1_Id : Node_Id; Ass2_Id : Node_Id);
+   --  The arguments may be parameter associations, whose descendants
+   --  are the optional formal name and the actual parameter. Positional
+   --  parameters are already members of a list, and do not need to be
+   --  chained separately. See also First_Actual and Next_Actual.
+
+   procedure Set_Public_Status (Id : Entity_Id);
+   --  If an entity (visible or otherwise) is defined in a library
+   --  package, or a package that is itself public, then this subprogram
+   --  labels the entity public as well.
+
+   procedure Set_Scope_Is_Transient (V : Boolean := True);
+   --  Set the flag Is_Transient of the current scope
+
+   procedure Set_Size_Info (T1, T2 : Entity_Id);
+   --  Copies the Esize field and Has_Biased_Representation flag from
+   --  (sub)type entity T2 to (sub)type entity T1. Also copies the
+   --  Is_Unsigned_Type flag in the fixed-point and discrete cases,
+   --  and also copies the alignment value from T2 to T1. It does NOT
+   --  copy the RM_Size field, which must be separately set if this
+   --  is required to be copied also.
+
+   function Scope_Is_Transient  return Boolean;
+   --  True if the current scope is transient.
+
+   function Static_Integer (N : Node_Id) return Uint;
+   --  This function analyzes the given expression node and then resolves it
+   --  as any integer type. If the result is static, then the value of the
+   --  universal expression is returned, otherwise an error message is output
+   --  and a value of No_Uint is returned.
+
+   function Statically_Different (E1, E2 : Node_Id) return Boolean;
+   --  Return True if it can be statically determined that the Expressions
+   --  E1 and E2 refer to different objects
+
+   function Subprogram_Access_Level (Subp : Entity_Id) return Uint;
+   --  Return the accessibility level of the view denoted by Subp.
+
+   procedure Trace_Scope (N : Node_Id; E : Entity_Id; Msg : String);
+   --  Print debugging information on entry to each unit being analyzed.
+
+   procedure Transfer_Entities (From : Entity_Id; To : Entity_Id);
+   --  Move a list of entities from one scope to another, and recompute
+   --  Is_Public based upon the new scope.
+
+   function Type_Access_Level (Typ : Entity_Id) return Uint;
+   --  Return the accessibility level of Typ.
+
+   function Unit_Declaration_Node (Unit_Id : Entity_Id) return Node_Id;
+   --  Unit_Id is the simple name of a program unit, this function returns
+   --  the corresponding xxx_Declaration node for the entity. Also applies
+   --  to the body entities for subprograms in tasks, in which case it
+   --  returns the subprogram or task body node for it. The unit may be
+   --  a child unit with any number of ancestors.
+
+   function Within_Init_Proc return Boolean;
+   --  Determines if Current_Scope is within an Init_Proc
+
+   procedure Wrong_Type (Expr : Node_Id; Expected_Type : Entity_Id);
+   --  Output error message for incorrectly typed expression. Expr is the
+   --  node for the incorrectly typed construct (Etype (Expr) is the type
+   --  found), and Expected_Type is the entity for the expected type. Note
+   --  that Expr does not have to be a subexpression, anything with an
+   --  Etype field may be used.
+
+private
+   pragma Inline (Current_Entity);
+   pragma Inline (Get_Name_Entity_Id);
+   pragma Inline (Is_False);
+   pragma Inline (Is_Statement);
+   pragma Inline (Is_True);
+   pragma Inline (Set_Current_Entity);
+   pragma Inline (Set_Name_Entity_Id);
+   pragma Inline (Set_Size_Info);
+
+end Sem_Util;
diff --git a/gcc/ada/sem_vfpt.adb b/gcc/ada/sem_vfpt.adb
new file mode 100644
index 00000000000..d4b76d4eeef
--- /dev/null
+++ b/gcc/ada/sem_vfpt.adb
@@ -0,0 +1,168 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             S E M _ V F P T                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.10 $
+--                                                                          --
+--          Copyright (C) 1997-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 CStand;   use CStand;
+with Einfo;    use Einfo;
+with Opt;      use Opt;
+with Stand;    use Stand;
+with Targparm; use Targparm;
+with Ttypef;   use Ttypef;
+with Uintp;    use Uintp;
+
+pragma Elaborate_All (Uintp);
+
+package body Sem_VFpt is
+
+   T_Digits : constant Uint := UI_From_Int (IEEEL_Digits);
+   --  Digits for IEEE formats
+
+   -----------------
+   -- Set_D_Float --
+   -----------------
+
+   procedure Set_D_Float (E : Entity_Id) is
+   begin
+      Init_Size         (Base_Type (E), 64);
+      Init_Alignment    (Base_Type (E));
+      Init_Digits_Value (Base_Type (E), VAXDF_Digits);
+      Set_Vax_Float     (Base_Type (E), True);
+      Set_Float_Bounds  (Base_Type (E));
+
+      Init_Size         (E, 64);
+      Init_Alignment    (E);
+      Init_Digits_Value (E, VAXDF_Digits);
+      Set_Scalar_Range  (E, Scalar_Range (Base_Type (E)));
+   end Set_D_Float;
+
+   -----------------
+   -- Set_F_Float --
+   -----------------
+
+   procedure Set_F_Float (E : Entity_Id) is
+   begin
+      Init_Size         (Base_Type (E), 32);
+      Init_Alignment    (Base_Type (E));
+      Init_Digits_Value (Base_Type (E), VAXFF_Digits);
+      Set_Vax_Float     (Base_Type (E), True);
+      Set_Float_Bounds  (Base_Type (E));
+
+      Init_Size         (E, 32);
+      Init_Alignment    (E);
+      Init_Digits_Value (E, VAXFF_Digits);
+      Set_Scalar_Range  (E, Scalar_Range (Base_Type (E)));
+   end Set_F_Float;
+
+   -----------------
+   -- Set_G_Float --
+   -----------------
+
+   procedure Set_G_Float (E : Entity_Id) is
+   begin
+      Init_Size         (Base_Type (E), 64);
+      Init_Alignment    (Base_Type (E));
+      Init_Digits_Value (Base_Type (E), VAXGF_Digits);
+      Set_Vax_Float     (Base_Type (E), True);
+      Set_Float_Bounds  (Base_Type (E));
+
+      Init_Size         (E, 64);
+      Init_Alignment    (E);
+      Init_Digits_Value (E, VAXGF_Digits);
+      Set_Scalar_Range  (E, Scalar_Range (Base_Type (E)));
+   end Set_G_Float;
+
+   -------------------
+   -- Set_IEEE_Long --
+   -------------------
+
+   procedure Set_IEEE_Long (E : Entity_Id) is
+   begin
+      Init_Size         (Base_Type (E), 64);
+      Init_Alignment    (Base_Type (E));
+      Init_Digits_Value (Base_Type (E), IEEEL_Digits);
+      Set_Vax_Float     (Base_Type (E), False);
+      Set_Float_Bounds  (Base_Type (E));
+
+      Init_Size         (E, 64);
+      Init_Alignment    (E);
+      Init_Digits_Value (E, IEEEL_Digits);
+      Set_Scalar_Range  (E, Scalar_Range (Base_Type (E)));
+   end Set_IEEE_Long;
+
+   --------------------
+   -- Set_IEEE_Short --
+   --------------------
+
+   procedure Set_IEEE_Short (E : Entity_Id) is
+   begin
+      Init_Size         (Base_Type (E), 32);
+      Init_Alignment    (Base_Type (E));
+      Init_Digits_Value (Base_Type (E), IEEES_Digits);
+      Set_Vax_Float     (Base_Type (E), False);
+      Set_Float_Bounds  (Base_Type (E));
+
+      Init_Size         (E, 32);
+      Init_Alignment    (E);
+      Init_Digits_Value (E, IEEES_Digits);
+      Set_Scalar_Range  (E, Scalar_Range (Base_Type (E)));
+   end Set_IEEE_Short;
+
+   ------------------------------
+   -- Set_Standard_Fpt_Formats --
+   ------------------------------
+
+   procedure Set_Standard_Fpt_Formats is
+   begin
+      --  IEEE case
+
+      if Opt.Float_Format = 'I' then
+         Set_IEEE_Short (Standard_Float);
+         Set_IEEE_Long  (Standard_Long_Float);
+         Set_IEEE_Long  (Standard_Long_Long_Float);
+
+      --  Vax float case
+
+      else
+         Set_F_Float (Standard_Float);
+
+         if Opt.Float_Format_Long = 'D' then
+            Set_D_Float (Standard_Long_Float);
+         else
+            Set_G_Float (Standard_Long_Float);
+         end if;
+
+         --  Note: Long_Long_Float gets set only in the real VMS case,
+         --  because this gives better results for testing out the use
+         --  of VAX float on non-VMS environments with the -gnatdm switch.
+
+         if OpenVMS_On_Target then
+            Set_G_Float (Standard_Long_Long_Float);
+         end if;
+      end if;
+   end Set_Standard_Fpt_Formats;
+
+end Sem_VFpt;
diff --git a/gcc/ada/sem_vfpt.ads b/gcc/ada/sem_vfpt.ads
new file mode 100644
index 00000000000..ed27175b0b3
--- /dev/null
+++ b/gcc/ada/sem_vfpt.ads
@@ -0,0 +1,58 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             S E M _ V F P T                              --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.1 $                              --
+--                                                                          --
+--             Copyright (C) 1997 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 contains specialized routines for handling the Alpha
+--  floating point formats. It is used only in Alpha implementations.
+--  Note that this means that the caller can assume that we are on an
+--  Alpha implementation, and that Vax floating-point formats are valid.
+
+with Types; use Types;
+
+package Sem_VFpt is
+
+   procedure Set_D_Float (E : Entity_Id);
+   --  Sets the given floating-point entity to have Vax D_Float format
+
+   procedure Set_F_Float (E : Entity_Id);
+   --  Sets the given floating-point entity to have Vax F_Float format
+
+   procedure Set_G_Float (E : Entity_Id);
+   --  Sets the given floating-point entity to have Vax G_Float format
+
+   procedure Set_IEEE_Short (E : Entity_Id);
+   --  Sets the given floating-point entity to have IEEE Short format
+
+   procedure Set_IEEE_Long (E : Entity_Id);
+   --  Sets the given floating-point entity to have IEEE Long format
+
+   procedure Set_Standard_Fpt_Formats;
+   --  This procedure sets the appropriate formats for the standard
+   --  floating-point types in Standard, based on the setting of
+   --  the flags Opt.Float_Format and Opt.Float_Format_Long
+
+end Sem_VFpt;
diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb
new file mode 100644
index 00000000000..f3133d2006d
--- /dev/null
+++ b/gcc/ada/sem_warn.adb
@@ -0,0 +1,1062 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             S E M _ W A R N                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.24 $
+--                                                                          --
+--          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.                                                      --
+--                                                                          --
+-- 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;
+with Atree;    use Atree;
+with Einfo;    use Einfo;
+with Errout;   use Errout;
+with Fname;    use Fname;
+with Lib;      use Lib;
+with Nlists;   use Nlists;
+with Opt;      use Opt;
+with Sem;      use Sem;
+with Sem_Util; use Sem_Util;
+with Sinfo;    use Sinfo;
+with Sinput;   use Sinput;
+with Snames;   use Snames;
+with Stand;    use Stand;
+with Table;
+
+package body Sem_Warn is
+
+   --  The following table collects Id's of entities that are potentially
+   --  unreferenced. See Check_Unset_Reference for further details.
+
+   package Unreferenced_Entities is new Table.Table (
+     Table_Component_Type => Entity_Id,
+     Table_Index_Type     => Nat,
+     Table_Low_Bound      => 1,
+     Table_Initial        => Alloc.Unreferenced_Entities_Initial,
+     Table_Increment      => Alloc.Unreferenced_Entities_Increment,
+     Table_Name           => "Unreferenced_Entities");
+
+   --  One entry is made in the following table for each branch of
+   --  a conditional, e.g. an if-then-elsif-else-endif structure
+   --  creates three entries in this table.
+
+   type Branch_Entry is record
+      Sloc : Source_Ptr;
+      --  Location for warnings associated with this branch
+
+      Defs : Elist_Id;
+      --  List of entities defined for the first time in this branch. On
+      --  exit from a conditional structure, any entity that is in the
+      --  list of all branches is removed (and the entity flagged as
+      --  defined by the conditional as a whole). Thus after processing
+      --  a conditional, Defs contains a list of entities defined in this
+      --  branch for the first time, but not defined at all in some other
+      --  branch of the same conditional. A value of No_Elist is used to
+      --  represent the initial empty list.
+
+      Next : Nat;
+      --  Index of next branch for this conditional, zero = last branch
+   end record;
+
+   package Branch_Table is new Table.Table (
+     Table_Component_Type => Branch_Entry,
+     Table_Index_Type     => Nat,
+     Table_Low_Bound      => 1,
+     Table_Initial        => Alloc.Branches_Initial,
+     Table_Increment      => Alloc.Branches_Increment,
+     Table_Name           => "Branches");
+
+   --  The following table is used to represent conditionals, there is
+   --  one entry in this table for each conditional structure.
+
+   type Conditional_Entry is record
+      If_Stmt : Boolean;
+      --  True for IF statement, False for CASE statement
+
+      First_Branch : Nat;
+      --  Index in Branch table of first branch, zero = none yet
+
+      Current_Branch : Nat;
+      --  Index in Branch table of current branch, zero = none yet
+   end record;
+
+   package Conditional_Table is new Table.Table (
+     Table_Component_Type => Conditional_Entry,
+     Table_Index_Type     => Nat,
+     Table_Low_Bound      => 1,
+     Table_Initial        => Alloc.Conditionals_Initial,
+     Table_Increment      => Alloc.Conditionals_Increment,
+     Table_Name           => "Conditionals");
+
+   --  The following table is a stack that keeps track of the current
+   --  conditional. The Last entry is the top of the stack. An Empty
+   --  entry represents the start of a compilation unit. Non-zero
+   --  entries in the stack are indexes into the conditional table.
+
+   package Conditional_Stack is new Table.Table (
+     Table_Component_Type => Nat,
+     Table_Index_Type     => Nat,
+     Table_Low_Bound      => 1,
+     Table_Initial        => Alloc.Conditional_Stack_Initial,
+     Table_Increment      => Alloc.Conditional_Stack_Increment,
+     Table_Name           => "Conditional_Stack");
+
+   Current_Entity_List : Elist_Id := No_Elist;
+   --  This is a copy of the Defs list of the current branch of the current
+   --  conditional. It could be accessed by taking the top element of the
+   --  Conditional_Stack, and going to te Current_Branch entry of this
+   --  conditional, but we keep it precomputed for rapid access.
+
+   ----------------------
+   -- Check_References --
+   ----------------------
+
+   procedure Check_References (E : Entity_Id; Anod : Node_Id := Empty) is
+      E1 : Entity_Id;
+      UR : Node_Id;
+      PU : Node_Id;
+
+      procedure Output_Reference_Error (M : String);
+      --  Used to output an error message. Deals with posting the error on
+      --  the body formal in the accept case.
+
+      function Publicly_Referenceable (Ent : Entity_Id) return Boolean;
+      --  This is true if the entity in question is potentially referenceable
+      --  from another unit. This is true for entities in packages that are
+      --  at the library level, or for entities in tasks or protected objects
+      --  that are themselves publicly visible.
+
+      ----------------------------
+      -- Output_Reference_Error --
+      ----------------------------
+
+      procedure Output_Reference_Error (M : String) is
+      begin
+         --  Other than accept case, post error on defining identifier
+
+         if No (Anod) then
+            Error_Msg_N (M, E1);
+
+         --  Accept case, find body formal to post the message
+
+         else
+            declare
+               Parm  : Node_Id;
+               Enod  : Node_Id;
+               Defid : Entity_Id;
+
+            begin
+               Enod := Anod;
+
+               if Present (Parameter_Specifications (Anod)) then
+                  Parm := First (Parameter_Specifications (Anod));
+
+                  while Present (Parm) loop
+                     Defid := Defining_Identifier (Parm);
+
+                     if Chars (E1) = Chars (Defid) then
+                        Enod := Defid;
+                        exit;
+                     end if;
+
+                     Next (Parm);
+                  end loop;
+               end if;
+
+               Error_Msg_NE (M, Enod, E1);
+            end;
+         end if;
+      end Output_Reference_Error;
+
+      ----------------------------
+      -- Publicly_Referenceable --
+      ----------------------------
+
+      function Publicly_Referenceable (Ent : Entity_Id) return Boolean is
+         S : Entity_Id;
+
+      begin
+         --  Any entity in a generic package is considered to be publicly
+         --  referenceable, since it could be referenced in an instantiation
+
+         if Ekind (E) = E_Generic_Package then
+            return True;
+         end if;
+
+         --  Otherwise look up the scope stack
+
+         S := Scope (Ent);
+         loop
+            if Is_Package (S) then
+               return Is_Library_Level_Entity (S);
+
+            elsif Ekind (S) = E_Task_Type
+              or else Ekind (S) = E_Protected_Type
+              or else Ekind (S) = E_Entry
+            then
+               S := Scope (S);
+
+            else
+               return False;
+            end if;
+         end loop;
+      end Publicly_Referenceable;
+
+   --  Start of processing for Check_References
+
+   begin
+      --  No messages if warnings are suppressed, or if we have detected
+      --  any real errors so far (this last check avoids junk messages
+      --  resulting from errors, e.g. a subunit that is not loaded).
+
+      --  We also skip the messages if any subunits were not loaded (see
+      --  comment in Sem_Ch10 to understand how this is set, and why it is
+      --  necessary to suppress the warnings in this case).
+
+      if Warning_Mode = Suppress
+        or else Errors_Detected /= 0
+        or else Unloaded_Subunits
+      then
+         return;
+      end if;
+
+      --  Otherwise loop through entities, looking for suspicious stuff
+
+      E1 := First_Entity (E);
+      while Present (E1) loop
+
+         --  We only look at source entities with warning flag off
+
+         if Comes_From_Source (E1) and then not Warnings_Off (E1) then
+
+            --  We are interested in variables and out parameters, but we
+            --  exclude protected types, too complicated to worry about.
+
+            if Ekind (E1) = E_Variable
+                 or else
+               (Ekind (E1) = E_Out_Parameter
+                  and then not Is_Protected_Type (Current_Scope))
+            then
+               --  Post warning if this object not assigned. Note that we
+               --  do not consider the implicit initialization of an access
+               --  type to be the assignment of a value for this purpose.
+               --  If the entity is an out parameter of the current subprogram
+               --  body, check the warning status of the parameter in the spec.
+
+               if Ekind (E1) = E_Out_Parameter
+                 and then Present (Spec_Entity (E1))
+                 and then Warnings_Off (Spec_Entity (E1))
+               then
+                  null;
+
+               elsif Not_Source_Assigned (E1) then
+                  Output_Reference_Error ("& is never assigned a value?");
+
+                  --  Deal with special case where this variable is hidden
+                  --  by a loop variable
+
+                  if Ekind (E1) = E_Variable
+                    and then Present (Hiding_Loop_Variable (E1))
+                  then
+                     Error_Msg_Sloc := Sloc (E1);
+                     Error_Msg_N
+                       ("declaration hides &#?",
+                        Hiding_Loop_Variable (E1));
+                     Error_Msg_N
+                       ("for loop implicitly declares loop variable?",
+                        Hiding_Loop_Variable (E1));
+                  end if;
+
+                  goto Continue;
+               end if;
+
+               --  Check for unset reference, note that we exclude access
+               --  types from this check, since access types do always have
+               --  a null value, and that seems legitimate in this case.
+
+               UR := Unset_Reference (E1);
+               if Present (UR) then
+
+                  --  For access types, the only time we complain is when
+                  --  we have a dereference (of a null value)
+
+                  if Is_Access_Type (Etype (E1)) then
+                     PU := Parent (UR);
+
+                     if (Nkind (PU) = N_Selected_Component
+                           or else
+                         Nkind (PU) = N_Explicit_Dereference
+                           or else
+                         Nkind (PU) = N_Indexed_Component)
+                       and then
+                         Prefix (PU) = UR
+                     then
+                        Error_Msg_N ("& may be null?", UR);
+                        goto Continue;
+                     end if;
+
+                  --  For other than access type, go back to original node
+                  --  to deal with case where original unset reference
+                  --  has been rewritten during expansion.
+
+                  else
+                     UR := Original_Node (UR);
+
+                     --  In some cases, the original node may be a type
+                     --  conversion or qualification, and in this case
+                     --  we want the object entity inside.
+
+                     while Nkind (UR) = N_Type_Conversion
+                       or else Nkind (UR) = N_Qualified_Expression
+                     loop
+                        UR := Expression (UR);
+                     end loop;
+
+                     Error_Msg_N
+                       ("& may be referenced before it has a value?", UR);
+                     goto Continue;
+                  end if;
+               end if;
+            end if;
+
+            --  Then check for unreferenced variables
+
+            if Check_Unreferenced
+
+               --  Check entity is flagged as not referenced and that
+               --  warnings are not suppressed for this entity
+
+               and then not Referenced (E1)
+               and then not Warnings_Off (E1)
+
+               --  Warnings are placed on objects, types, subprograms,
+               --  labels, and enumeration literals.
+
+               and then (Is_Object (E1)
+                           or else
+                         Is_Type (E1)
+                           or else
+                         Ekind (E1) = E_Label
+                           or else
+                         Ekind (E1) = E_Named_Integer
+                           or else
+                         Ekind (E1) = E_Named_Real
+                           or else
+                         Is_Overloadable (E1))
+
+               --  We only place warnings for the main unit
+
+               and then In_Extended_Main_Source_Unit (E1)
+
+               --  Exclude instantiations, since there is no reason why
+               --  every entity in an instantiation should be referenced.
+
+               and then Instantiation_Location (Sloc (E1)) = No_Location
+
+               --  Exclude formal parameters from bodies (in the case
+               --  where there is a separate spec, it is the spec formals
+               --  that are of interest).
+
+               and then (not Is_Formal (E1)
+                           or else
+                         Ekind (Scope (E1)) /= E_Subprogram_Body)
+
+               --  Consider private type referenced if full view is
+               --  referenced.
+
+               and then not (Is_Private_Type (E1)
+                               and then
+                             Referenced (Full_View (E1)))
+
+               --  Don't worry about full view, only about private type
+
+               and then not Has_Private_Declaration (E1)
+
+               --  Eliminate dispatching operations from consideration, we
+               --  cannot tell if these are referenced or not in any easy
+               --  manner (note this also catches Adjust/Finalize/Initialize)
+
+               and then not Is_Dispatching_Operation (E1)
+
+               --  Check entity that can be publicly referenced (we do not
+               --  give messages for such entities, since there could be
+               --  other units, not involved in this compilation, that
+               --  contain relevant references.
+
+               and then not Publicly_Referenceable (E1)
+
+               --  Class wide types are marked as source entities, but
+               --  they are not really source entities, and are always
+               --  created, so we do not care if they are not referenced.
+
+               and then Ekind (E1) /= E_Class_Wide_Type
+
+               --  Objects other than parameters of task types are allowed
+               --  to be non-referenced, since they start up tasks!
+
+               and then ((Ekind (E1) /= E_Variable
+                             and then Ekind (E1) /= E_Constant
+                             and then Ekind (E1) /= E_Component)
+                           or else not Is_Task_Type (Etype (E1)))
+            then
+               --  Suppress warnings in internal units if not in -gnatg
+               --  mode (these would be junk warnings for an applications
+               --  program, since they refer to problems in internal units)
+
+               if GNAT_Mode
+                 or else not
+                   Is_Internal_File_Name
+                     (Unit_File_Name (Get_Source_Unit (E1)))
+               then
+                  --  We do not immediately flag the error. This is because
+                  --  we have not expanded generic bodies yet, and they may
+                  --  have the missing reference. So instead we park the
+                  --  entity on a list, for later processing. However, for
+                  --  the accept case, post the error right here, since we
+                  --  have the information now in this case.
+
+                  if Present (Anod) then
+                     Output_Reference_Error ("& is not referenced?");
+
+                  else
+                     Unreferenced_Entities.Increment_Last;
+                     Unreferenced_Entities.Table
+                       (Unreferenced_Entities.Last) := E1;
+                  end if;
+               end if;
+            end if;
+         end if;
+
+         --  Recurse into nested package or block
+
+         <<Continue>>
+            if (Ekind (E1) = E_Package
+                  and then Nkind (Parent (E1)) = N_Package_Specification)
+              or else Ekind (E1) = E_Block
+            then
+               Check_References (E1);
+            end if;
+
+            Next_Entity (E1);
+      end loop;
+   end Check_References;
+
+   ---------------------------
+   -- Check_Unset_Reference --
+   ---------------------------
+
+   procedure Check_Unset_Reference (N : Node_Id) is
+   begin
+      --  Nothing to do if warnings suppressed
+
+      if Warning_Mode = Suppress then
+         return;
+      end if;
+
+      --  Otherwise see what kind of node we have. If the entity already
+      --  has an unset reference, it is not necessarily the earliest in
+      --  the text, because resolution of the prefix of selected components
+      --  is completed before the resolution of the selected component itself.
+      --  as a result, given  (R /= null and then R.X > 0), the occurrences
+      --  of R are examined in right-to-left order. If there is already an
+      --  unset reference, we check whether N is earlier before proceeding.
+
+      case Nkind (N) is
+
+         when N_Identifier | N_Expanded_Name =>
+            declare
+               E  : constant Entity_Id := Entity (N);
+
+            begin
+               if (Ekind (E) = E_Variable
+                    or else Ekind (E) = E_Out_Parameter)
+                 and then Not_Source_Assigned (E)
+                 and then (No (Unset_Reference (E))
+                             or else Earlier_In_Extended_Unit
+                               (Sloc (N),  Sloc (Unset_Reference (E))))
+                 and then not Warnings_Off (E)
+               then
+                  --  Here we have a potential unset reference. But before we
+                  --  get worried about it, we have to make sure that the
+                  --  entity declaration is in the same procedure as the
+                  --  reference, since if they are in separate procedures,
+                  --  then we have no idea about sequential execution.
+
+                  --  The tests in the loop below catch all such cases, but
+                  --  do allow the reference to appear in a loop, block, or
+                  --  package spec that is nested within the declaring scope.
+                  --  As always, it is possible to construct cases where the
+                  --  warning is wrong, that is why it is a warning!
+
+                  --  If the entity is an out_parameter, it is ok to read its
+                  --  its discriminants (that was true in Ada83) so suppress
+                  --  the message in that case as well.
+
+                  if Ekind (E) = E_Out_Parameter
+                    and then Nkind (Parent (N)) = N_Selected_Component
+                    and then Ekind (Entity (Selector_Name (Parent (N))))
+                      = E_Discriminant
+                  then
+                     return;
+                  end if;
+
+                  declare
+                     SR : Entity_Id;
+                     SE : constant Entity_Id := Scope (E);
+
+                  begin
+                     SR := Current_Scope;
+                     while SR /= SE loop
+                        if SR = Standard_Standard
+                          or else Is_Subprogram (SR)
+                          or else Is_Concurrent_Body (SR)
+                          or else Is_Concurrent_Type (SR)
+                        then
+                           return;
+                        end if;
+
+                        SR := Scope (SR);
+                     end loop;
+
+                     if Nkind (N) = N_Identifier then
+                        Set_Unset_Reference (E, N);
+                     else
+                        Set_Unset_Reference (E, Selector_Name (N));
+                     end if;
+                  end;
+               end if;
+            end;
+
+         when N_Indexed_Component | N_Selected_Component | N_Slice =>
+            Check_Unset_Reference (Prefix (N));
+            return;
+
+         when N_Type_Conversion | N_Qualified_Expression =>
+            Check_Unset_Reference (Expression (N));
+
+         when others =>
+            null;
+
+      end case;
+   end Check_Unset_Reference;
+
+   ------------------------
+   -- Check_Unused_Withs --
+   ------------------------
+
+   procedure Check_Unused_Withs (Spec_Unit : Unit_Number_Type := No_Unit) is
+      Cnode : Node_Id;
+      Item  : Node_Id;
+      Lunit : Node_Id;
+      Ent   : Entity_Id;
+
+      Munite : constant Entity_Id := Cunit_Entity (Main_Unit);
+      --  This is needed for checking the special renaming case
+
+      procedure Check_One_Unit (Unit : Unit_Number_Type);
+      --  Subsidiary procedure, performs checks for specified unit
+
+      --------------------
+      -- Check_One_Unit --
+      --------------------
+
+      procedure Check_One_Unit (Unit : Unit_Number_Type) is
+         Is_Visible_Renaming : Boolean := False;
+         Pack                : Entity_Id;
+
+         function Find_Package_Renaming
+           (P : Entity_Id;
+            L : Entity_Id) return Entity_Id;
+         --  The only reference to a context unit may be in a renaming
+         --  declaration. If this renaming declares a visible entity, do
+         --  not warn that the context clause could be moved to the body,
+         --  because the renaming may be intented to re-export the unit.
+
+         ---------------------------
+         -- Find_Package_Renaming --
+         ---------------------------
+
+         function Find_Package_Renaming
+           (P : Entity_Id;
+            L : Entity_Id) return Entity_Id
+         is
+            E1 : Entity_Id;
+            R  : Entity_Id;
+
+         begin
+            Is_Visible_Renaming := False;
+            E1 := First_Entity (P);
+
+            while Present (E1) loop
+               if Ekind (E1) = E_Package
+                  and then Renamed_Object (E1) = L
+               then
+                  Is_Visible_Renaming := not Is_Hidden (E1);
+                  return E1;
+
+               elsif Ekind (E1) = E_Package
+                 and then No (Renamed_Object (E1))
+                 and then not Is_Generic_Instance (E1)
+               then
+                  R := Find_Package_Renaming (E1, L);
+
+                  if Present (R) then
+                     Is_Visible_Renaming := not Is_Hidden (R);
+                     return R;
+                  end if;
+               end if;
+
+               Next_Entity (E1);
+            end loop;
+
+            return Empty;
+         end Find_Package_Renaming;
+
+      --  Start of processing for Check_One_Unit
+
+      begin
+         Cnode := Cunit (Unit);
+
+         --  Only do check in units that are part of the extended main
+         --  unit. This is actually a necessary restriction, because in
+         --  the case of subprogram acting as its own specification,
+         --  there can be with's in subunits that we will not see.
+
+         if not In_Extended_Main_Source_Unit (Cnode) then
+            return;
+         end if;
+
+         --  Loop through context items in this unit
+
+         Item := First (Context_Items (Cnode));
+         while Present (Item) loop
+
+            if Nkind (Item) = N_With_Clause
+               and then not Implicit_With (Item)
+               and then In_Extended_Main_Source_Unit (Item)
+            then
+               Lunit := Entity (Name (Item));
+
+               --  Check if this unit is referenced
+
+               if not Referenced (Lunit) then
+
+                  --  Suppress warnings in internal units if not in -gnatg
+                  --  mode (these would be junk warnings for an applications
+                  --  program, since they refer to problems in internal units)
+
+                  if GNAT_Mode
+                    or else not Is_Internal_File_Name (Unit_File_Name (Unit))
+                  then
+                     --  Here we definitely have a non-referenced unit. If
+                     --  it is the special call for a spec unit, then just
+                     --  set the flag to be read later.
+
+                     if Unit = Spec_Unit then
+                        Set_Unreferenced_In_Spec (Item);
+
+                     --  Otherwise simple unreferenced message
+
+                     else
+                        Error_Msg_N
+                          ("unit& is not referenced?", Name (Item));
+                     end if;
+                  end if;
+
+               --  If main unit is a renaming of this unit, then we consider
+               --  the with to be OK (obviously it is needed in this case!)
+
+               elsif Present (Renamed_Entity (Munite))
+                  and then Renamed_Entity (Munite) = Lunit
+               then
+                  null;
+
+               --  If this unit is referenced, and it is a package, we
+               --  do another test, to see if any of the entities in the
+               --  package are referenced. If none of the entities are
+               --  referenced, we still post a warning. This occurs if
+               --  the only use of the package is in a use clause, or
+               --  in a package renaming declaration.
+
+               elsif Ekind (Lunit) = E_Package then
+
+                  --  If Is_Instantiated is set, it means that the package
+                  --  is implicitly instantiated (this is the case of a
+                  --  parent instance or an actual for a generic package
+                  --  formal), and this counts as a reference.
+
+                  if Is_Instantiated (Lunit) then
+                     null;
+
+                  --  If no entities in package, and there is a pragma
+                  --  Elaborate_Body present, then assume that this with
+                  --  is done for purposes of this elaboration.
+
+                  elsif No (First_Entity (Lunit))
+                    and then Has_Pragma_Elaborate_Body (Lunit)
+                  then
+                     null;
+
+                  --  Otherwise see if any entities have been referenced
+
+                  else
+                     Ent  := First_Entity (Lunit);
+
+                     loop
+                        --  No more entities, and we did not find one
+                        --  that was referenced. Means we have a definite
+                        --  case of a with none of whose entities was
+                        --  referenced.
+
+                        if No (Ent) then
+
+                           --  If in spec, just set the flag
+
+                           if Unit = Spec_Unit then
+                              Set_No_Entities_Ref_In_Spec (Item);
+
+                           --  Else give the warning
+
+                           else
+                              Error_Msg_N
+                                ("no entities of & are referenced?",
+                                 Name (Item));
+
+                              --  Look for renamings of this package, and
+                              --  flag them as well. If the original package
+                              --  has warnings off, we suppress the warning
+                              --  on the renaming as well.
+
+                              Pack := Find_Package_Renaming (Munite, Lunit);
+
+                              if Present (Pack)
+                                and then not Warnings_Off (Lunit)
+                              then
+                                 Error_Msg_NE
+                                   ("no entities of & are referenced?",
+                                     Unit_Declaration_Node (Pack),
+                                       Pack);
+                              end if;
+                           end if;
+
+                           exit;
+
+                        --  Case of next entity is referenced
+
+                        elsif Referenced (Ent) then
+
+                           --  This means that the with is indeed fine, in
+                           --  that it is definitely needed somewhere, and
+                           --  we can quite worrying about this one.
+
+                           --  Except for one little detail, if either of
+                           --  the flags was set during spec processing,
+                           --  this is where we complain that the with
+                           --  could be moved from the spec. If the spec
+                           --  contains a visible renaming of the package,
+                           --  inhibit warning to move with_clause to body.
+
+                           if Ekind (Munite) = E_Package_Body then
+                              Pack :=
+                                Find_Package_Renaming
+                                  (Spec_Entity (Munite), Lunit);
+                           end if;
+
+                           if Unreferenced_In_Spec (Item) then
+                              Error_Msg_N
+                                ("unit& is not referenced in spec?",
+                                 Name (Item));
+
+                           elsif No_Entities_Ref_In_Spec (Item) then
+                              Error_Msg_N
+                                ("no entities of & are referenced in spec?",
+                                 Name (Item));
+
+                           else
+                              exit;
+                           end if;
+
+                           if not Is_Visible_Renaming then
+                              Error_Msg_N
+                                ("\with clause might be moved to body?",
+                                 Name (Item));
+                           end if;
+
+                           exit;
+
+                        --  Move to next entity to continue search
+
+                        else
+                           Next_Entity (Ent);
+                        end if;
+                     end loop;
+                  end if;
+
+               --  For a generic package, the only interesting kind of
+               --  reference is an instantiation, since entities cannot
+               --  be referenced directly.
+
+               elsif Is_Generic_Unit (Lunit) then
+
+                  --  Unit was never instantiated, set flag for case of spec
+                  --  call, or give warning for normal call.
+
+                  if not Is_Instantiated (Lunit) then
+                     if Unit = Spec_Unit then
+                        Set_Unreferenced_In_Spec (Item);
+                     else
+                        Error_Msg_N
+                          ("unit& is never instantiated?", Name (Item));
+                     end if;
+
+                  --  If unit was indeed instantiated, make sure that
+                  --  flag is not set showing it was uninstantiated in
+                  --  the spec, and if so, give warning.
+
+                  elsif Unreferenced_In_Spec (Item) then
+                     Error_Msg_N
+                       ("unit& is not instantiated in spec?", Name (Item));
+                     Error_Msg_N
+                       ("\with clause can be moved to body?", Name (Item));
+                  end if;
+               end if;
+            end if;
+
+            Next (Item);
+         end loop;
+
+      end Check_One_Unit;
+
+   --  Start of processing for Check_Unused_Withs
+
+   begin
+      if not Opt.Check_Withs
+        or else Operating_Mode = Check_Syntax
+      then
+         return;
+      end if;
+
+      --  Flag any unused with clauses, but skip this step if we are
+      --  compiling a subunit on its own, since we do not have enough
+      --  information to determine whether with's are used. We will get
+      --  the relevant warnings when we compile the parent. This is the
+      --  normal style of GNAT compilation in any case.
+
+      if Nkind (Unit (Cunit (Main_Unit))) = N_Subunit then
+         return;
+      end if;
+
+      --  Process specified units
+
+      if Spec_Unit = No_Unit then
+
+         --  For main call, check all units
+
+         for Unit in Main_Unit .. Last_Unit loop
+            Check_One_Unit (Unit);
+         end loop;
+
+      else
+         --  For call for spec, check only the spec
+
+         Check_One_Unit (Spec_Unit);
+      end if;
+   end Check_Unused_Withs;
+
+   ---------------------
+   -- End_Conditional --
+   ---------------------
+
+   procedure End_Conditional is
+   begin
+      null;
+   end End_Conditional;
+
+   --------------
+   -- End_Unit --
+   --------------
+
+   procedure End_Unit is
+   begin
+      null;
+   end End_Unit;
+
+   ----------------------------------
+   -- Output_Unreferenced_Messages --
+   ----------------------------------
+
+   procedure Output_Unreferenced_Messages is
+      E : Entity_Id;
+
+   begin
+      for J in Unreferenced_Entities.First ..
+               Unreferenced_Entities.Last
+      loop
+         E := Unreferenced_Entities.Table (J);
+
+         if not Referenced (E) and then not Warnings_Off (E) then
+
+            case Ekind (E) is
+               when E_Variable =>
+                  if Present (Renamed_Object (E))
+                    and then Comes_From_Source (Renamed_Object (E))
+                  then
+                     Error_Msg_N ("renamed variable & is not referenced?", E);
+                  else
+                     Error_Msg_N ("variable & is not referenced?", E);
+                  end if;
+
+               when E_Constant =>
+                  if Present (Renamed_Object (E)) then
+                     Error_Msg_N ("renamed constant & is not referenced?", E);
+                  else
+                     Error_Msg_N ("constant & is not referenced?", E);
+                  end if;
+
+               when E_In_Parameter     |
+                    E_Out_Parameter    |
+                    E_In_Out_Parameter =>
+
+                  --  Do not emit message for formals of a renaming, because
+                  --  they are never referenced explicitly.
+
+                  if Nkind (Original_Node (Unit_Declaration_Node (Scope (E))))
+                    /= N_Subprogram_Renaming_Declaration
+                  then
+                     Error_Msg_N ("formal parameter & is not referenced?", E);
+                  end if;
+
+               when E_Named_Integer    |
+                    E_Named_Real       =>
+                  Error_Msg_N ("named number & is not referenced?", E);
+
+               when E_Enumeration_Literal =>
+                  Error_Msg_N ("literal & is not referenced?", E);
+
+               when E_Function         =>
+                  Error_Msg_N ("function & is not referenced?", E);
+
+               when E_Procedure         =>
+                  Error_Msg_N ("procedure & is not referenced?", E);
+
+               when Type_Kind          =>
+                  Error_Msg_N ("type & is not referenced?", E);
+
+               when others =>
+                  Error_Msg_N ("& is not referenced?", E);
+            end case;
+
+            Set_Warnings_Off (E);
+         end if;
+      end loop;
+   end Output_Unreferenced_Messages;
+
+   ------------------
+   -- Start_Branch --
+   ------------------
+
+   procedure Start_Branch (Loc : Source_Ptr) is
+   begin
+      null;
+   end Start_Branch;
+
+   -----------------------
+   -- Start_Conditional --
+   -----------------------
+
+   procedure Start_Conditional (If_Stmt : Boolean) is
+   begin
+      null;
+   end Start_Conditional;
+
+   ----------------
+   -- Start_Unit --
+   ----------------
+
+   procedure Start_Unit is
+   begin
+      null;
+   end Start_Unit;
+
+   -----------------------------
+   -- Warn_On_Known_Condition --
+   -----------------------------
+
+   procedure Warn_On_Known_Condition (C : Node_Id) is
+      P : Node_Id;
+
+   begin
+      if Constant_Condition_Warnings
+        and then Nkind (C) = N_Identifier
+        and then
+          (Entity (C) = Standard_False or else Entity (C) = Standard_True)
+        and then Comes_From_Source (Original_Node (C))
+        and then not In_Instance
+      then
+         --  See if this is in a statement or a declaration
+
+         P := Parent (C);
+         loop
+            --  If tree is not attached, do not issue warning (this is very
+            --  peculiar, and probably arises from some other error condition)
+
+            if No (P) then
+               return;
+
+            --  If we are in a declaration, then no warning, since in practice
+            --  conditionals in declarations are used for intended tests which
+            --  may be known at compile time, e.g. things like
+
+            --    x : constant Integer := 2 + (Word'Size = 32);
+
+            --  And a warning is annoying in such cases
+
+            elsif Nkind (P) in N_Declaration
+                    or else
+                  Nkind (P) in N_Later_Decl_Item
+            then
+               return;
+
+            --  Don't warn in assert pragma, since presumably tests in such
+            --  a context are very definitely intended, and might well be
+            --  known at compile time. Note that we have to test the original
+            --  node, since assert pragmas get rewritten at analysis time.
+
+            elsif Nkind (Original_Node (P)) = N_Pragma
+              and then Chars (Original_Node (P)) = Name_Assert
+            then
+               return;
+            end if;
+
+            exit when Is_Statement (P);
+            P := Parent (P);
+         end loop;
+
+         if Entity (C) = Standard_True then
+            Error_Msg_N ("condition is always True?", C);
+         else
+            Error_Msg_N ("condition is always False?", C);
+         end if;
+      end if;
+   end Warn_On_Known_Condition;
+
+end Sem_Warn;
diff --git a/gcc/ada/sem_warn.ads b/gcc/ada/sem_warn.ads
new file mode 100644
index 00000000000..0c5d75956a0
--- /dev/null
+++ b/gcc/ada/sem_warn.ads
@@ -0,0 +1,161 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             S E M _ W A R N                              --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.3 $
+--                                                                          --
+--          Copyright (C) 1999-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). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  This package contains the routines used to deal with issuing warnings
+--  about uses of uninitialized variables and unused with's. It also has
+--  some unrelated routines related to the generation of warnings.
+
+with Types; use Types;
+
+package Sem_Warn is
+
+   ------------------------------------------
+   -- Routines to Handle Unused References --
+   ------------------------------------------
+
+   procedure Check_References (E : Entity_Id; Anod : Node_Id := Empty);
+   --  Called at the end of processing a declarative region. The entity E
+   --  is the entity for the scope. All entities declared in the region,
+   --  as indicated by First_Entity and the entity chain, are checked to
+   --  see if they are variables for which warnings need to be posted for
+   --  either no assignments, or a use before an assignment or no references
+   --  at all. The Anod node is present for the case of an accept statement,
+   --  and references the accept statement. This is used to place the warning
+   --  messages in the right place.
+
+   procedure Check_Unset_Reference (N : Node_Id);
+   --  N is the node for an expression which occurs in a reference position,
+   --  e.g. as the right side of an assignment. This procedure checks to see
+   --  if the node is a reference to a variable entity where the entity has
+   --  Not_Assigned set. If so, the Unset_Reference field is set if it is not
+   --  the first occurrence. No warning is posted, instead warnings will be
+   --  posted later by Check_References. The reason we do things that
+   --  way is that if there are no assignments anywhere, we prefer to flag
+   --  the entity, rather than a reference to it. Note that for the purposes
+   --  of this routine, a type conversion or qualified expression whose
+   --  expression is an entity is also processed. The reason that we do not
+   --  process these at the point of occurrence is that both these constructs
+   --  can occur in non-reference positions (e.g. as out parameters).
+
+   procedure Check_Unused_Withs (Spec_Unit : Unit_Number_Type := No_Unit);
+   --  This routine performs two kinds of checks. It checks that all with'ed
+   --  units are referenced, and that at least one entity of each with'ed
+   --  unit is referenced (the latter check catches units that are only
+   --  referenced in a use or package renaming statement). Appropriate
+   --  warning messages are generated if either of these situations is
+   --  detected.
+   --
+   --  A special case arises when a package body or a subprogram body with
+   --  a separate spec is being compiled. In this case, a with may appear
+   --  on the spec, but be needed only by the body. This still generates
+   --  a warning, but the text is different (the with is not redundant,
+   --  it is misplaced).
+   --
+   --  This special case is implemented by making an initial call to this
+   --  procedure with Spec_Unit set to the unit number of the separate spec.
+   --  This call does not generate any warning messages, but instead may
+   --  result in flags being set in the N_With_Clause node that record that
+   --  there was no use in the spec.
+   --
+   --  The main call (made after all units have been analyzed, with Spec_Unit
+   --  set to the default value of No_Unit) generates the required warnings
+   --  using the flags set by the initial call where appropriate to specialize
+   --  the text of the warning messages.
+
+   ----------------------------------------
+   -- Routines to Deal with Conditionals --
+   ----------------------------------------
+
+   --  These routines provide the necessary interfacing information to
+   --  correctly handle references in conditional structures (if/then/end-if,
+   --  or case/when/end-case). The issue here is that if a variable is only
+   --  set in some but not all branches of a conditional, then it is not
+   --  considered as being set by the conditional as a whole.
+
+   procedure Start_Unit;
+   --  Mark start of new unit to be analyzed, deals with fact that a call to
+   --  Rtsfind may cause new unit to be analyzed in middle of conditional.
+
+   procedure End_Unit;
+   --  Mark end of unit corresponding to previous call to Start_Unit
+
+   procedure Start_Conditional (If_Stmt : Boolean);
+   --  Mark start of a new conditional structure (an if-elsif-else-endif
+   --  or a case-when-end-case structure). If_Stmt is True for the IF
+   --  statement case, and False for the CASE statement case.
+
+   procedure Start_Branch (Loc : Source_Ptr);
+   --  Start processing of one branch of conditional previously marked by
+   --  a call to Start_Conditional (i.e. start of then/elsif/else statements
+   --  or set of statements after a when condition). The Loc value is the
+   --  source pointer to be used in warning messages concerning variables
+   --  not properly initialized in this branch. A branch is terminated by
+   --  either another Start_Branch or End_Conditional call.
+
+   procedure End_Conditional;
+   --  Terminate conditional started by previous Start_Conditional statement.
+
+   ---------------------
+   -- Output Routines --
+   ---------------------
+
+   procedure Output_Unreferenced_Messages;
+   --  Warnings about unreferenced entities are collected till the end of
+   --  the compilation process (see Check_Unset_Reference for further
+   --  details). This procedure outputs waiting warnings, if any.
+
+   ----------------------------
+   -- Other Warning Routines --
+   ----------------------------
+
+   procedure Warn_On_Known_Condition (C : Node_Id);
+   --  C is a node for a boolean expression resluting from a relational
+   --  or membership operation. If the expression has a compile time known
+   --  value, then a warning is output if all the following conditions hold:
+   --
+   --    1. Original expression comes from source. We don't want to generate
+   --       warnings for internally generated conditionals.
+   --
+   --    2. As noted above, the expression is a relational or membership
+   --       test, we don't want to generate warnings for boolean variables
+   --       since this is typical of conditional compilation in Ada.
+   --
+   --    3. The expression appears in a statement, rather than a declaration.
+   --       In practice, most occurrences in declarations are legitimate
+   --       conditionalizations, but occurrences in statements are often
+   --       errors for which the warning is useful.
+   --
+   --    4. The expression does not occur within an instantiation. A non-
+   --       static expression in a generic may become constant because of
+   --       the attributes of the actuals, and we do not want to warn on
+   --       these legitimate constant foldings.
+   --
+   --  If all these conditions are met, the warning is issued noting that
+   --  the result of the test is always false or always true as appropriate.
+
+end Sem_Warn;
diff --git a/gcc/ada/sequenio.ads b/gcc/ada/sequenio.ads
new file mode 100644
index 00000000000..e191a5a1d40
--- /dev/null
+++ b/gcc/ada/sequenio.ads
@@ -0,0 +1,21 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT RUNTIME COMPONENTS                          --
+--                                                                          --
+--                        S E Q U E N T I A L  _ I O                        --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.8 $                              --
+--                                                                          --
+-- This specification is adapted from the Ada Reference Manual for use with --
+-- GNAT.  In accordance with the copyright of that document, you can freely --
+-- copy and modify this specification,  provided that if you redistribute a --
+-- modified version,  any changes that you have made are clearly indicated. --
+--                                                                          --
+------------------------------------------------------------------------------
+
+pragma Ada_95;
+with Ada.Sequential_IO;
+
+generic package Sequential_IO renames Ada.Sequential_IO;
diff --git a/gcc/ada/sfn_scan.adb b/gcc/ada/sfn_scan.adb
new file mode 100644
index 00000000000..57bc534f582
--- /dev/null
+++ b/gcc/ada/sfn_scan.adb
@@ -0,0 +1,659 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             S F N _ S C A N                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.6 $
+--                                                                          --
+--          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.                                                      --
+--                                                                          --
+-- 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 Ada.Exceptions; use Ada.Exceptions;
+
+package body SFN_Scan is
+
+   use ASCII;
+   --  Allow easy access to control character definitions
+
+   type String_Ptr is access String;
+
+   S : String_Ptr;
+   --  Points to the gnat.adc input file
+
+   P : Natural;
+   --  Subscript of next character to process in S
+
+   Line_Num : Natural;
+   --  Current line number
+
+   Start_Of_Line : Natural;
+   --  Subscript of first character at start of current line
+
+   ----------------------
+   -- Local Procedures --
+   ----------------------
+
+   function Acquire_String (B : Natural; E : Natural) return String;
+   --  This function takes a string scanned out by Scan_String, strips
+   --  the enclosing quote characters and any internal doubled quote
+   --  characters, and returns the result as a String. The arguments
+   --  B and E are as returned from a call to Scan_String. The lower
+   --  bound of the string returned is always 1.
+
+   function Acquire_Unit_Name return String;
+   --  Skips white space, and then scans and returns a unit name. The
+   --  unit name is cased exactly as it appears in the source file.
+   --  The terminating character must be white space, or a comma or
+   --  a right parenthesis or end of file.
+
+   function At_EOF return Boolean;
+   pragma Inline (At_EOF);
+   --  Returns True if at end of file, False if not. Note that this
+   --  function does NOT skip white space, so P is always unchanged.
+
+   procedure Check_Not_At_EOF;
+   pragma Inline (Check_Not_At_EOF);
+   --  Skips past white space if any, and then raises Error if at
+   --  end of file. Otherwise returns with P skipped past whitespace.
+
+   function Check_File_Type return Character;
+   --  Skips white space if any, and then looks for any of the tokens
+   --  Spec_File_Name, Body_File_Name, or Subunit_File_Name. If one
+   --  of these is found then the value returned is 's', 'b' or 'u'
+   --  respectively, and P is bumped past the token. If none of
+   --  these tokens is found, then P is unchanged (except for
+   --  possible skip of white space), and a space is returned.
+
+   function Check_Token (T : String) return Boolean;
+   --  Skips white space if any, and then checks if the string at the
+   --  current location matches the given string T, and the character
+   --  immediately following is non-alphabetic, non-numeric. If so,
+   --  P is stepped past the token, and True is returned. If not,
+   --  P is unchanged (except for possibly skipping past whitespace),
+   --  and False is returned. S may contain only lower-case letters
+   --  ('a' .. 'z').
+
+   procedure Error (Err : String);
+   --  Called if an error is detected. Raises Syntax_Error_In_GNAT_ADC
+   --  with a message of the form gnat.adc:line:col: xxx, where xxx is
+   --  the string Err passed as a parameter.
+
+   procedure Require_Token (T : String);
+   --  Skips white space if any, and then requires the given string
+   --  to be present. If it is, the P is stepped past it, otherwise
+   --  Error is raised, since this is a syntax error. Require_Token
+   --  is used only for sequences of special characters, so there
+   --  is no issue of terminators, or casing of letters.
+
+   procedure Scan_String (B : out Natural; E : out Natural);
+   --  Skips white space if any, then requires that a double quote
+   --  or percent be present (start of string). Raises error if
+   --  neither of these two characters is found. Otherwise scans
+   --  out the string, and returns with P pointing past the
+   --  closing quote and S (B .. E) contains the characters of the
+   --  string (including the enclosing quotes, with internal quotes
+   --  still doubled). Raises Error if the string is malformed.
+
+   procedure Skip_WS;
+   --  Skips P past any white space characters (end of line
+   --  characters, spaces, comments, horizontal tab characters).
+
+   --------------------
+   -- Acquire_String --
+   --------------------
+
+   function Acquire_String (B : Natural; E : Natural) return String is
+      Str : String (1 .. E - B - 1);
+      Q   : constant Character := S (B);
+      J   : Natural;
+      Ptr : Natural;
+
+   begin
+      Ptr := B + 1;
+      J := 0;
+      while Ptr < E loop
+         J := J + 1;
+         Str (J) := S (Ptr);
+
+         if S (Ptr) = Q and then S (Ptr + 1) = Q then
+            Ptr := Ptr + 2;
+         else
+            Ptr := Ptr + 1;
+         end if;
+      end loop;
+
+      return Str (1 .. J);
+   end Acquire_String;
+
+   -----------------------
+   -- Acquire_Unit_Name --
+   -----------------------
+
+   function Acquire_Unit_Name return String is
+      B : Natural;
+
+   begin
+      Check_Not_At_EOF;
+      B := P;
+
+      while not At_EOF loop
+         exit when S (P) not in '0' .. '9'
+           and then S (P) /= '.'
+           and then S (P) /= '_'
+           and then not (S (P) = '[' and then S (P + 1) = '"')
+           and then not (S (P) = '"' and then S (P - 1) = '[')
+           and then not (S (P) = '"' and then S (P + 1) = ']')
+           and then not (S (P) = ']' and then S (P - 1) = '"')
+           and then S (P) < 'A';
+         P := P + 1;
+      end loop;
+
+      if P = B then
+         Error ("null unit name");
+      end if;
+
+      return S (B .. P - 1);
+   end Acquire_Unit_Name;
+
+   ------------
+   -- At_EOF --
+   ------------
+
+   function At_EOF return Boolean is
+   begin
+      return P > S'Last;
+   end At_EOF;
+
+   ---------------------
+   -- Check_File_Type --
+   ---------------------
+
+   function Check_File_Type return Character is
+   begin
+      if Check_Token ("spec_file_name") then
+         return 's';
+      elsif Check_Token ("body_file_name") then
+         return 'b';
+      elsif Check_Token ("subunit_file_name") then
+         return 'u';
+      else
+         return ' ';
+      end if;
+   end Check_File_Type;
+
+   ----------------------
+   -- Check_Not_At_EOF --
+   ----------------------
+
+   procedure Check_Not_At_EOF is
+   begin
+      Skip_WS;
+
+      if At_EOF then
+         Error ("unexpected end of file");
+      end if;
+
+      return;
+   end Check_Not_At_EOF;
+
+   -----------------
+   -- Check_Token --
+   -----------------
+
+   function Check_Token (T : String) return Boolean is
+      Save_P : Natural;
+      C : Character;
+
+   begin
+      Skip_WS;
+      Save_P := P;
+
+      for K in T'Range loop
+         if At_EOF then
+            P := Save_P;
+            return False;
+         end if;
+
+         C := S (P);
+
+         if C in 'A' .. 'Z' then
+            C := Character'Val (Character'Pos (C) +
+                                 (Character'Pos ('a') - Character'Pos ('A')));
+         end if;
+
+         if C /= T (K) then
+            P := Save_P;
+            return False;
+         end if;
+
+         P := P + 1;
+      end loop;
+
+      if At_EOF then
+         return True;
+      end if;
+
+      C := S (P);
+
+      if C in '0' .. '9'
+        or else C in 'a' .. 'z'
+        or else C in 'A' .. 'Z'
+        or else C > Character'Val (127)
+      then
+         P := Save_P;
+         return False;
+
+      else
+         return True;
+      end if;
+   end Check_Token;
+
+   -----------
+   -- Error --
+   -----------
+
+   procedure Error (Err : String) is
+      C : Natural := 0;
+      --  Column number
+
+      M : String (1 .. 80);
+      --  Buffer used to build resulting error msg
+
+      LM : Natural := 0;
+      --  Pointer to last set location in M
+
+      procedure Add_Nat (N : Natural);
+      --  Add chars of integer to error msg buffer
+
+      procedure Add_Nat (N : Natural) is
+      begin
+         if N > 9 then
+            Add_Nat (N / 10);
+         end if;
+
+         LM := LM + 1;
+         M (LM) := Character'Val (N mod 10 + Character'Pos ('0'));
+      end Add_Nat;
+
+   --  Start of processing for Error
+
+   begin
+      M (1 .. 9) := "gnat.adc:";
+      LM := 9;
+      Add_Nat (Line_Num);
+      LM := LM + 1;
+      M (LM) := ':';
+
+      --  Determine column number
+
+      for X in Start_Of_Line .. P loop
+         C := C + 1;
+
+         if S (X) = HT then
+            C := (C + 7) / 8 * 8;
+         end if;
+      end loop;
+
+      Add_Nat (C);
+      M (LM + 1) := ':';
+      LM := LM + 1;
+      M (LM + 1) := ' ';
+      LM := LM + 1;
+
+      M (LM + 1 .. LM + Err'Length) := Err;
+      LM := LM + Err'Length;
+
+      Raise_Exception (Syntax_Error_In_GNAT_ADC'Identity, M (1 .. LM));
+   end Error;
+
+   -------------------
+   -- Require_Token --
+   -------------------
+
+   procedure Require_Token (T : String) is
+      SaveP : Natural;
+
+   begin
+      Skip_WS;
+      SaveP := P;
+
+      for J in T'Range loop
+
+         if At_EOF or else S (P) /= T (J) then
+            declare
+               S : String (1 .. T'Length + 10);
+
+            begin
+               S (1 .. 9) := "missing """;
+               S (10 .. T'Length + 9) := T;
+               S (T'Length + 10) := '"';
+               P := SaveP;
+               Error (S);
+            end;
+
+         else
+            P := P + 1;
+         end if;
+      end loop;
+   end Require_Token;
+
+   ----------------------
+   -- Scan_SFN_Pragmas --
+   ----------------------
+
+   procedure Scan_SFN_Pragmas
+     (Source   : String;
+      SFN_Ptr  : Set_File_Name_Ptr;
+      SFNP_Ptr : Set_File_Name_Pattern_Ptr)
+   is
+      B, E : Natural;
+      Typ  : Character;
+      Cas  : Character;
+
+   begin
+      Line_Num := 1;
+      S := Source'Unrestricted_Access;
+      P := Source'First;
+      Start_Of_Line := P;
+
+      --  Loop through pragmas in file
+
+      Main_Scan_Loop : loop
+         Skip_WS;
+         exit Main_Scan_Loop when At_EOF;
+
+         --  Error if something other than pragma
+
+         if not Check_Token ("pragma") then
+            Error ("non pragma encountered");
+         end if;
+
+         --  Source_File_Name pragma case
+
+         if Check_Token ("source_file_name") then
+            Require_Token ("(");
+
+            Typ := Check_File_Type;
+
+            --  First format, with unit name first
+
+            if Typ = ' ' then
+               if Check_Token ("unit_name") then
+                  Require_Token ("=>");
+               end if;
+
+               declare
+                  U : constant String := Acquire_Unit_Name;
+
+               begin
+                  Require_Token (",");
+                  Typ := Check_File_Type;
+
+                  if Typ /= 's' and then Typ /= 'b' then
+                     Error ("bad pragma");
+                  end if;
+
+                  Require_Token ("=>");
+                  Scan_String (B, E);
+
+                  declare
+                     F : constant String := Acquire_String (B, E);
+
+                  begin
+                     Require_Token (")");
+                     Require_Token (";");
+                     SFN_Ptr.all (Typ, U, F);
+                  end;
+               end;
+
+            --  Second format with pattern string
+
+            else
+               Require_Token ("=>");
+               Scan_String (B, E);
+
+               declare
+                  Pat : constant String := Acquire_String (B, E);
+                  Nas : Natural := 0;
+
+               begin
+                  --  Check exactly one asterisk
+
+                  for J in Pat'Range loop
+                     if Pat (J) = '*' then
+                        Nas := Nas + 1;
+                     end if;
+                  end loop;
+
+                  if Nas /= 1 then
+                     Error ("** not allowed");
+                  end if;
+
+                  B := 0;
+                  E := 0;
+                  Cas := ' ';
+
+                  --  Loop to scan out Casing or Dot_Replacement parameters
+
+                  loop
+                     Check_Not_At_EOF;
+                     exit when S (P) = ')';
+                     Require_Token (",");
+
+                     if Check_Token ("casing") then
+                        Require_Token ("=>");
+
+                        if Cas /= ' ' then
+                           Error ("duplicate casing argument");
+                        elsif Check_Token ("lowercase") then
+                           Cas := 'l';
+                        elsif Check_Token ("uppercase") then
+                           Cas := 'u';
+                        elsif Check_Token ("mixedcase") then
+                           Cas := 'm';
+                        else
+                           Error ("invalid casing argument");
+                        end if;
+
+                     elsif Check_Token ("dot_replacement") then
+                        Require_Token ("=>");
+
+                        if E /= 0 then
+                           Error ("duplicate dot_replacement");
+                        else
+                           Scan_String (B, E);
+                        end if;
+
+                     else
+                        Error ("invalid argument");
+                     end if;
+                  end loop;
+
+                  Require_Token (")");
+                  Require_Token (";");
+
+                  if Cas = ' ' then
+                     Cas := 'l';
+                  end if;
+
+                  if E = 0 then
+                     SFNP_Ptr.all (Pat, Typ, ".", Cas);
+
+                  else
+                     declare
+                        Dot : constant String := Acquire_String (B, E);
+
+                     begin
+                        SFNP_Ptr.all (Pat, Typ, Dot, Cas);
+                     end;
+                  end if;
+               end;
+            end if;
+
+         --  Some other pragma, scan to semicolon at end of pragma
+
+         else
+            Skip_Loop : loop
+               exit Main_Scan_Loop when At_EOF;
+               exit Skip_Loop when S (P) = ';';
+
+               if S (P) = '"' or else S (P) = '%' then
+                  Scan_String (B, E);
+               else
+                  P := P + 1;
+               end if;
+            end loop Skip_Loop;
+
+            --  We successfuly skipped to semicolon, so skip past it
+
+            P := P + 1;
+         end if;
+      end loop Main_Scan_Loop;
+
+   exception
+      when others =>
+         Cursor := P - S'First + 1;
+         raise;
+   end Scan_SFN_Pragmas;
+
+   -----------------
+   -- Scan_String --
+   -----------------
+
+   procedure Scan_String (B : out Natural; E : out Natural) is
+      Q : Character;
+
+   begin
+      Check_Not_At_EOF;
+
+      if S (P) = '"' then
+         Q := '"';
+      elsif S (P) = '%' then
+         Q := '%';
+      else
+         Error ("bad string");
+         Q := '"';
+      end if;
+
+      --  Scan out the string, B points to first char
+
+      B := P;
+      P := P + 1;
+
+      loop
+         if At_EOF or else S (P) = LF or else S (P) = CR then
+            Error ("missing string quote");
+
+         elsif S (P) = HT then
+            Error ("tab character in string");
+
+         elsif S (P) /= Q then
+            P := P + 1;
+
+         --  We have a quote
+
+         else
+            P := P + 1;
+
+            --  Check for doubled quote
+
+            if not At_EOF and then S (P) = Q then
+               P := P + 1;
+
+            --  Otherwise this is the terminating quote
+
+            else
+               E := P - 1;
+               return;
+            end if;
+         end if;
+      end loop;
+   end Scan_String;
+
+   -------------
+   -- Skip_WS --
+   -------------
+
+   procedure Skip_WS is
+   begin
+      WS_Scan : while not At_EOF loop
+         case S (P) is
+
+            --  End of physical line
+
+            when CR | LF =>
+               Line_Num := Line_Num + 1;
+               P := P + 1;
+
+               while not At_EOF
+                 and then (S (P) = CR or else S (P) = LF)
+               loop
+                  Line_Num := Line_Num + 1;
+                  P := P + 1;
+               end loop;
+
+               Start_Of_Line := P;
+
+            --  All other cases of white space characters
+
+            when ' ' | FF | VT | HT =>
+               P := P + 1;
+
+            --  Comment
+
+            when '-' =>
+               P := P + 1;
+
+               if At_EOF then
+                  Error ("bad comment");
+
+               elsif S (P) = '-' then
+                  P := P + 1;
+
+                  while not At_EOF loop
+                     case S (P) is
+                        when CR | LF | FF | VT =>
+                           exit;
+                        when others =>
+                           P := P + 1;
+                     end case;
+                  end loop;
+
+               else
+                  P := P - 1;
+                  exit WS_Scan;
+               end if;
+
+            when others =>
+               exit WS_Scan;
+
+         end case;
+      end loop WS_Scan;
+   end Skip_WS;
+
+end SFN_Scan;
diff --git a/gcc/ada/sfn_scan.ads b/gcc/ada/sfn_scan.ads
new file mode 100644
index 00000000000..ed84fc6686d
--- /dev/null
+++ b/gcc/ada/sfn_scan.ads
@@ -0,0 +1,94 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             S F N _ S C A N                              --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.2 $
+--                                                                          --
+--          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). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  This package provides a stand alone capability for scanning a gnat.adc
+--  file for Source_File_Name pragmas. This is for use in tools other than
+--  the compiler, which want to scan source file name pragmas without the
+--  overhead of the full compiler scanner and parser.
+
+--  Note that neither the package spec, nor the package body, of this
+--  unit contains any with statements at all. This is a compeltely
+--  independent package, suitable for incorporation into tools that do
+--  not access any other units in the GNAT compiler or tools sources.
+
+--  This package is NOT task safe, so multiple tasks that may call the
+--  Scan_SFN_Pragmas procedure at the same time are responsibible for
+--  avoiding such multiple calls by appropriate synchronization.
+
+package SFN_Scan is
+
+   --  The call to SFN_Scan passes pointers to two procedures that are
+   --  used to store the results of scanning any Source_File_Name pragmas
+   --  that are encountered. The following access types define the form
+   --  of these procedures:
+
+   type Set_File_Name_Ptr is access
+     procedure (Typ : Character; U : String; F : String);
+   --  The procedure with this profile is called when a Source_File_Name
+   --  pragma of the form having a unit name parameter. Typ is 'b' for
+   --  a body file name, and 's' for a spec file name. U is a string that
+   --  contains the unit name, exactly as it appeared in the source file,
+   --  and F is the file taken from the second parameter.
+
+   type Set_File_Name_Pattern_Ptr is access
+     procedure (Pat : String; Typ : Character; Dot : String; Cas : Character);
+   --  This is called to process a Source_File_Name pragma whose first
+   --  argument is a file pattern. Pat is this pattern string, which
+   --  contains an asterisk to correspond to the unit. Typ is one of
+   --  ('b'/'s'/'u') for body/spec/subunit, Dot is the separator string
+   --  for child/subunit names (default is "."), and Cas is one of
+   --  ('l'/'u'/'m') indicating the required case for the file name.
+   --  The default setting for Cas is 'l' if no parameter is present.
+
+   Cursor : Natural;
+   --  Used to record the cursor value if a syntax error is found
+
+   Syntax_Error_In_GNAT_ADC : exception;
+   --  Exception raised if a syntax error is found
+
+   procedure Scan_SFN_Pragmas
+     (Source   : String;
+      SFN_Ptr  : Set_File_Name_Ptr;
+      SFNP_Ptr : Set_File_Name_Pattern_Ptr);
+   --  This is the procedure called to scan a gnat.adc file. The Source
+   --  parameter points to the full text of the file, with normal line end
+   --  characters, in the format normally read by the compiler. The two
+   --  parameters SFN_Ptr and SFNP_Ptr point to procedures that will be
+   --  called to register Source_File_Name pragmas as they are found.
+   --
+   --  If a syntax error is found, then Syntax_Error_In_GNAT_ADC is raised,
+   --  and the location SFN_Scan.Cursor contains the approximate index of
+   --  the error in the source string.
+   --
+   --  The scan assumes that it is dealing with a valid gnat.adc file,
+   --  that includes only pragmas and comments. It does not do a full
+   --  syntax correctness scan by any means, but if it does find anything
+   --  that it can tell is wrong it will immediately raise the exception
+   --  to indicate the aproximate location of the error
+
+end SFN_Scan;
diff --git a/gcc/ada/sinfo-cn.adb b/gcc/ada/sinfo-cn.adb
new file mode 100644
index 00000000000..33e6da641b1
--- /dev/null
+++ b/gcc/ada/sinfo-cn.adb
@@ -0,0 +1,114 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             S I N F O . C N                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.7 $
+--                                                                          --
+--          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 child package of Sinfo contains some routines that permit in place
+--  alteration of existing tree nodes by changing the value in the Nkind
+--  field. Since Nkind functions logically in a manner similart to a variant
+--  record discriminant part, such alterations cannot be permitted in a
+--  general manner, but in some specific cases, the fields of related nodes
+--  have been deliberately layed out in a manner that permits such alteration.
+--  that determin
+
+with Atree; use Atree;
+
+package body Sinfo.CN is
+
+   use Atree.Unchecked_Access;
+   --  This package is one of the few packages which is allowed to make direct
+   --  references to tree nodes (since it is in the business of providing a
+   --  higher level of tree access which other clients are expected to use and
+   --  which implements checks).
+
+   ------------------------------------------------------------
+   -- Change_Character_Literal_To_Defining_Character_Literal --
+   ------------------------------------------------------------
+
+   procedure Change_Character_Literal_To_Defining_Character_Literal
+     (N : in out Node_Id)
+   is
+   begin
+      Set_Nkind (N, N_Defining_Character_Literal);
+      N := Extend_Node (N);
+   end Change_Character_Literal_To_Defining_Character_Literal;
+
+   ------------------------------------
+   -- Change_Conversion_To_Unchecked --
+   ------------------------------------
+
+   procedure Change_Conversion_To_Unchecked (N : Node_Id) is
+   begin
+      Set_Do_Overflow_Check (N, False);
+      Set_Do_Tag_Check (N, False);
+      Set_Do_Length_Check (N, False);
+      Set_Nkind (N, N_Unchecked_Type_Conversion);
+   end Change_Conversion_To_Unchecked;
+
+   ----------------------------------------------
+   -- Change_Identifier_To_Defining_Identifier --
+   ----------------------------------------------
+
+   procedure Change_Identifier_To_Defining_Identifier (N : in out Node_Id) is
+   begin
+      Set_Nkind (N, N_Defining_Identifier);
+      N := Extend_Node (N);
+   end Change_Identifier_To_Defining_Identifier;
+
+   --------------------------------------------------------
+   -- Change_Operator_Symbol_To_Defining_Operator_Symbol --
+   --------------------------------------------------------
+
+   procedure Change_Operator_Symbol_To_Defining_Operator_Symbol
+     (N : in out Node_Id)
+   is
+   begin
+      Set_Nkind (N, N_Defining_Operator_Symbol);
+      Set_Node2 (N, Empty); -- Clear unused Str2 field
+      N := Extend_Node (N);
+   end Change_Operator_Symbol_To_Defining_Operator_Symbol;
+
+   ----------------------------------------------
+   -- Change_Operator_Symbol_To_String_Literal --
+   ----------------------------------------------
+
+   procedure Change_Operator_Symbol_To_String_Literal (N : Node_Id) is
+   begin
+      Set_Nkind (N, N_String_Literal);
+      Set_Node1 (N, Empty); -- clear Name1 field
+   end Change_Operator_Symbol_To_String_Literal;
+
+   ------------------------------------------------
+   -- Change_Selected_Component_To_Expanded_Name --
+   ------------------------------------------------
+
+   procedure Change_Selected_Component_To_Expanded_Name (N : Node_Id) is
+   begin
+      Set_Nkind (N, N_Expanded_Name);
+      Set_Chars (N, Chars (Selector_Name (N)));
+   end Change_Selected_Component_To_Expanded_Name;
+
+end Sinfo.CN;
diff --git a/gcc/ada/sinfo-cn.ads b/gcc/ada/sinfo-cn.ads
new file mode 100644
index 00000000000..03dcae3d630
--- /dev/null
+++ b/gcc/ada/sinfo-cn.ads
@@ -0,0 +1,71 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             S I N F O . C N                              --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.9 $
+--                                                                          --
+--          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 child package of Sinfo contains some routines that permit in place
+--  alteration of existing tree nodes by changing the value in the Nkind
+--  field. Since Nkind functions logically in a manner similar to a variant
+--  record discriminant part, such alterations cannot be permitted in a
+--  general manner, but in some specific cases, the fields of related nodes
+--  have been deliberately laid out in a manner that permits such alteration.
+
+package Sinfo.CN is
+
+   procedure Change_Identifier_To_Defining_Identifier (N : in out Node_Id);
+   --  N must refer to a node of type N_Identifier. This node is modified to
+   --  be of type N_Defining_Identifier. The scanner always returns identifiers
+   --  as N_Identifier. The parser then uses this routine to change the node
+   --  to be a defining identifier where the context demands it. This routine
+   --  also allocates the necessary extension node. Note that this procedure
+   --  may (but is not required to) change the Id of the node in question.
+
+   procedure Change_Character_Literal_To_Defining_Character_Literal
+     (N : in out Node_Id);
+   --  Similar processing for a character literal
+
+   procedure Change_Operator_Symbol_To_Defining_Operator_Symbol
+     (N : in out Node_Id);
+   --  Similar processing for an operator symbol
+
+   procedure Change_Conversion_To_Unchecked (N : Node_Id);
+   --  Change checked conversion node to unchecked conversion node, clearing
+   --  irrelevant check flags (other fields in the two nodes are identical)
+
+   procedure Change_Operator_Symbol_To_String_Literal (N : Node_Id);
+   --  The scanner returns any string that looks like an operator symbol as
+   --  a N_Operator_Symbol node. The parser then uses this procedure to change
+   --  the node to a normal N_String_Literal node if the context is not one
+   --  in which an operator symbol is required. There are some cases where the
+   --  parser cannot tell, in which case this transformation happens later on.
+
+   procedure Change_Selected_Component_To_Expanded_Name (N : Node_Id);
+   --  The parser always generates Selected_Component nodes. The semantics
+   --  modifies these to Expanded_Name nodes where appropriate. Note that
+   --  on return the Chars field is set to a copy of the contents of the
+   --  Chars field of the Selector_Name field.
+
+end Sinfo.CN;
diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb
new file mode 100644
index 00000000000..fb96678b814
--- /dev/null
+++ b/gcc/ada/sinfo.adb
@@ -0,0 +1,4798 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                                S I N F O                                 --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.314 $
+--                                                                          --
+--          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 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). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+pragma Style_Checks (All_Checks);
+--  No subprogram ordering check, due to logical grouping
+
+with Atree; use Atree;
+
+package body Sinfo is
+
+   use Atree.Unchecked_Access;
+   --  This package is one of the few packages which is allowed to make direct
+   --  references to tree nodes (since it is in the business of providing a
+   --  higher level of tree access which other clients are expected to use and
+   --  which implements checks).
+
+   use Atree_Private_Part;
+   --  The only reason that we ask for direct access to the private part of
+   --  the tree package is so that we can directly reference the Nkind field
+   --  of nodes table entries. We do this since it helps the efficiency of
+   --  the Sinfo debugging checks considerably (note that when we are checking
+   --  Nkind values, we don't need to check for a valid node reference, because
+   --  we will check that anyway when we reference the field).
+
+   NT : Nodes.Table_Ptr renames Nodes.Table;
+   --  A short hand abbreviation, useful for the debugging checks
+
+   ----------------------------
+   -- Field Access Functions --
+   ----------------------------
+
+   function ABE_Is_Certain
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Formal_Package_Declaration
+        or else NT (N).Nkind = N_Function_Call
+        or else NT (N).Nkind = N_Function_Instantiation
+        or else NT (N).Nkind = N_Package_Instantiation
+        or else NT (N).Nkind = N_Procedure_Call_Statement
+        or else NT (N).Nkind = N_Procedure_Instantiation);
+      return Flag18 (N);
+   end ABE_Is_Certain;
+
+   function Abort_Present
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Requeue_Statement);
+      return Flag15 (N);
+   end Abort_Present;
+
+   function Abortable_Part
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Asynchronous_Select);
+      return Node2 (N);
+   end Abortable_Part;
+
+   function Abstract_Present
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Derived_Type_Definition
+        or else NT (N).Nkind = N_Formal_Derived_Type_Definition
+        or else NT (N).Nkind = N_Formal_Private_Type_Definition
+        or else NT (N).Nkind = N_Private_Extension_Declaration
+        or else NT (N).Nkind = N_Private_Type_Declaration
+        or else NT (N).Nkind = N_Record_Definition);
+      return Flag4 (N);
+   end Abstract_Present;
+
+   function Accept_Handler_Records
+      (N : Node_Id) return List_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Accept_Alternative);
+      return List5 (N);
+   end Accept_Handler_Records;
+
+   function Accept_Statement
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Accept_Alternative);
+      return Node2 (N);
+   end Accept_Statement;
+
+   function Access_Types_To_Process
+      (N : Node_Id) return Elist_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Freeze_Entity);
+      return Elist2 (N);
+   end Access_Types_To_Process;
+
+   function Actions
+      (N : Node_Id) return List_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_And_Then
+        or else NT (N).Nkind = N_Compilation_Unit_Aux
+        or else NT (N).Nkind = N_Freeze_Entity
+        or else NT (N).Nkind = N_Or_Else);
+      return List1 (N);
+   end Actions;
+
+   function Activation_Chain_Entity
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Block_Statement
+        or else NT (N).Nkind = N_Entry_Body
+        or else NT (N).Nkind = N_Generic_Package_Declaration
+        or else NT (N).Nkind = N_Package_Declaration
+        or else NT (N).Nkind = N_Subprogram_Body
+        or else NT (N).Nkind = N_Task_Body);
+      return Node3 (N);
+   end Activation_Chain_Entity;
+
+   function Acts_As_Spec
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Compilation_Unit
+        or else NT (N).Nkind = N_Subprogram_Body);
+      return Flag4 (N);
+   end Acts_As_Spec;
+
+   function Aggregate_Bounds
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Aggregate);
+      return Node3 (N);
+   end Aggregate_Bounds;
+
+   function Aliased_Present
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Component_Declaration
+        or else NT (N).Nkind = N_Constrained_Array_Definition
+        or else NT (N).Nkind = N_Object_Declaration
+        or else NT (N).Nkind = N_Unconstrained_Array_Definition);
+      return Flag4 (N);
+   end Aliased_Present;
+
+   function All_Others
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Others_Choice);
+      return Flag11 (N);
+   end All_Others;
+
+   function All_Present
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Access_To_Object_Definition);
+      return Flag15 (N);
+   end All_Present;
+
+   function Alternatives
+      (N : Node_Id) return List_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Case_Statement);
+      return List4 (N);
+   end Alternatives;
+
+   function Ancestor_Part
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Extension_Aggregate);
+      return Node3 (N);
+   end Ancestor_Part;
+
+   function Array_Aggregate
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Enumeration_Representation_Clause);
+      return Node3 (N);
+   end Array_Aggregate;
+
+   function Assignment_OK
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Object_Declaration
+          or else NT (N).Nkind in N_Subexpr);
+      return Flag15 (N);
+   end Assignment_OK;
+
+   function At_End_Proc
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Handled_Sequence_Of_Statements);
+      return Node1 (N);
+   end At_End_Proc;
+
+   function Attribute_Name
+      (N : Node_Id) return Name_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Attribute_Reference);
+      return Name2 (N);
+   end Attribute_Name;
+
+   function Aux_Decls_Node
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Compilation_Unit);
+      return Node5 (N);
+   end Aux_Decls_Node;
+
+   function Backwards_OK
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Assignment_Statement);
+      return Flag6 (N);
+   end Backwards_OK;
+
+   function Bad_Is_Detected
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Subprogram_Body);
+      return Flag15 (N);
+   end Bad_Is_Detected;
+
+   function Body_Required
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Compilation_Unit);
+      return Flag13 (N);
+   end Body_Required;
+
+   function Body_To_Inline
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Subprogram_Declaration);
+      return Node3 (N);
+   end Body_To_Inline;
+
+   function Box_Present
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Formal_Package_Declaration
+        or else NT (N).Nkind = N_Formal_Subprogram_Declaration);
+      return Flag15 (N);
+   end Box_Present;
+
+   function By_Ref
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Return_Statement);
+      return Flag5 (N);
+   end By_Ref;
+
+   function Char_Literal_Value
+      (N : Node_Id) return Char_Code is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Character_Literal);
+      return Char_Code2 (N);
+   end Char_Literal_Value;
+
+   function Chars
+      (N : Node_Id) return Name_Id is
+   begin
+      pragma Assert (False
+          or else NT (N).Nkind in N_Has_Chars);
+      return Name1 (N);
+   end Chars;
+
+   function Choice_Parameter
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Exception_Handler);
+      return Node2 (N);
+   end Choice_Parameter;
+
+   function Choices
+      (N : Node_Id) return List_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Component_Association);
+      return List1 (N);
+   end Choices;
+
+   function Compile_Time_Known_Aggregate
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Aggregate);
+      return Flag18 (N);
+   end Compile_Time_Known_Aggregate;
+
+   function Component_Associations
+      (N : Node_Id) return List_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Aggregate
+        or else NT (N).Nkind = N_Extension_Aggregate);
+      return List2 (N);
+   end Component_Associations;
+
+   function Component_Clauses
+      (N : Node_Id) return List_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Record_Representation_Clause);
+      return List3 (N);
+   end Component_Clauses;
+
+   function Component_Items
+      (N : Node_Id) return List_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Component_List);
+      return List3 (N);
+   end Component_Items;
+
+   function Component_List
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Record_Definition
+        or else NT (N).Nkind = N_Variant);
+      return Node1 (N);
+   end Component_List;
+
+   function Component_Name
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Component_Clause);
+      return Node1 (N);
+   end Component_Name;
+
+   function Condition
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Accept_Alternative
+        or else NT (N).Nkind = N_Delay_Alternative
+        or else NT (N).Nkind = N_Elsif_Part
+        or else NT (N).Nkind = N_Entry_Body_Formal_Part
+        or else NT (N).Nkind = N_Exit_Statement
+        or else NT (N).Nkind = N_If_Statement
+        or else NT (N).Nkind = N_Iteration_Scheme
+        or else NT (N).Nkind = N_Raise_Constraint_Error
+        or else NT (N).Nkind = N_Raise_Program_Error
+        or else NT (N).Nkind = N_Raise_Storage_Error
+        or else NT (N).Nkind = N_Terminate_Alternative);
+      return Node1 (N);
+   end Condition;
+
+   function Condition_Actions
+      (N : Node_Id) return List_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Elsif_Part
+        or else NT (N).Nkind = N_Iteration_Scheme);
+      return List3 (N);
+   end Condition_Actions;
+
+   function Constant_Present
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Access_To_Object_Definition
+        or else NT (N).Nkind = N_Object_Declaration);
+      return Flag17 (N);
+   end Constant_Present;
+
+   function Constraint
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Subtype_Indication);
+      return Node3 (N);
+   end Constraint;
+
+   function Constraints
+      (N : Node_Id) return List_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Index_Or_Discriminant_Constraint);
+      return List1 (N);
+   end Constraints;
+
+   function Context_Installed
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_With_Clause);
+      return Flag13 (N);
+   end Context_Installed;
+
+   function Context_Items
+      (N : Node_Id) return List_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Compilation_Unit);
+      return List1 (N);
+   end Context_Items;
+
+   function Controlling_Argument
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Function_Call
+        or else NT (N).Nkind = N_Procedure_Call_Statement);
+      return Node1 (N);
+   end Controlling_Argument;
+
+   function Conversion_OK
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Type_Conversion);
+      return Flag14 (N);
+   end Conversion_OK;
+
+   function Corresponding_Body
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Generic_Package_Declaration
+        or else NT (N).Nkind = N_Generic_Subprogram_Declaration
+        or else NT (N).Nkind = N_Package_Body_Stub
+        or else NT (N).Nkind = N_Package_Declaration
+        or else NT (N).Nkind = N_Protected_Body_Stub
+        or else NT (N).Nkind = N_Protected_Type_Declaration
+        or else NT (N).Nkind = N_Subprogram_Body_Stub
+        or else NT (N).Nkind = N_Subprogram_Declaration
+        or else NT (N).Nkind = N_Task_Body_Stub
+        or else NT (N).Nkind = N_Task_Type_Declaration);
+      return Node5 (N);
+   end Corresponding_Body;
+
+   function Corresponding_Generic_Association
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Object_Declaration
+        or else NT (N).Nkind = N_Object_Renaming_Declaration);
+      return Node5 (N);
+   end Corresponding_Generic_Association;
+
+   function Corresponding_Integer_Value
+      (N : Node_Id) return Uint is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Real_Literal);
+      return Uint4 (N);
+   end Corresponding_Integer_Value;
+
+   function Corresponding_Spec
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Package_Body
+        or else NT (N).Nkind = N_Protected_Body
+        or else NT (N).Nkind = N_Subprogram_Body
+        or else NT (N).Nkind = N_Subprogram_Renaming_Declaration
+        or else NT (N).Nkind = N_Task_Body
+        or else NT (N).Nkind = N_With_Clause);
+      return Node5 (N);
+   end Corresponding_Spec;
+
+   function Corresponding_Stub
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Subunit);
+      return Node3 (N);
+   end Corresponding_Stub;
+
+   function Dcheck_Function
+      (N : Node_Id) return Entity_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Variant);
+      return Node5 (N);
+   end Dcheck_Function;
+
+   function Debug_Statement
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Pragma);
+      return Node3 (N);
+   end Debug_Statement;
+
+   function Declarations
+      (N : Node_Id) return List_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Accept_Statement
+        or else NT (N).Nkind = N_Block_Statement
+        or else NT (N).Nkind = N_Compilation_Unit_Aux
+        or else NT (N).Nkind = N_Entry_Body
+        or else NT (N).Nkind = N_Package_Body
+        or else NT (N).Nkind = N_Protected_Body
+        or else NT (N).Nkind = N_Subprogram_Body
+        or else NT (N).Nkind = N_Task_Body);
+      return List2 (N);
+   end Declarations;
+
+   function Default_Expression
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Parameter_Specification);
+      return Node5 (N);
+   end Default_Expression;
+
+   function Default_Name
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Formal_Subprogram_Declaration);
+      return Node2 (N);
+   end Default_Name;
+
+   function Defining_Identifier
+      (N : Node_Id) return Entity_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Component_Declaration
+        or else NT (N).Nkind = N_Defining_Program_Unit_Name
+        or else NT (N).Nkind = N_Discriminant_Specification
+        or else NT (N).Nkind = N_Entry_Body
+        or else NT (N).Nkind = N_Entry_Declaration
+        or else NT (N).Nkind = N_Entry_Index_Specification
+        or else NT (N).Nkind = N_Exception_Declaration
+        or else NT (N).Nkind = N_Exception_Renaming_Declaration
+        or else NT (N).Nkind = N_Formal_Object_Declaration
+        or else NT (N).Nkind = N_Formal_Package_Declaration
+        or else NT (N).Nkind = N_Formal_Type_Declaration
+        or else NT (N).Nkind = N_Full_Type_Declaration
+        or else NT (N).Nkind = N_Implicit_Label_Declaration
+        or else NT (N).Nkind = N_Incomplete_Type_Declaration
+        or else NT (N).Nkind = N_Loop_Parameter_Specification
+        or else NT (N).Nkind = N_Number_Declaration
+        or else NT (N).Nkind = N_Object_Declaration
+        or else NT (N).Nkind = N_Object_Renaming_Declaration
+        or else NT (N).Nkind = N_Package_Body_Stub
+        or else NT (N).Nkind = N_Parameter_Specification
+        or else NT (N).Nkind = N_Private_Extension_Declaration
+        or else NT (N).Nkind = N_Private_Type_Declaration
+        or else NT (N).Nkind = N_Protected_Body
+        or else NT (N).Nkind = N_Protected_Body_Stub
+        or else NT (N).Nkind = N_Protected_Type_Declaration
+        or else NT (N).Nkind = N_Single_Protected_Declaration
+        or else NT (N).Nkind = N_Single_Task_Declaration
+        or else NT (N).Nkind = N_Subtype_Declaration
+        or else NT (N).Nkind = N_Task_Body
+        or else NT (N).Nkind = N_Task_Body_Stub
+        or else NT (N).Nkind = N_Task_Type_Declaration);
+      return Node1 (N);
+   end Defining_Identifier;
+
+   function Defining_Unit_Name
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Function_Instantiation
+        or else NT (N).Nkind = N_Function_Specification
+        or else NT (N).Nkind = N_Generic_Function_Renaming_Declaration
+        or else NT (N).Nkind = N_Generic_Package_Renaming_Declaration
+        or else NT (N).Nkind = N_Generic_Procedure_Renaming_Declaration
+        or else NT (N).Nkind = N_Package_Body
+        or else NT (N).Nkind = N_Package_Instantiation
+        or else NT (N).Nkind = N_Package_Renaming_Declaration
+        or else NT (N).Nkind = N_Package_Specification
+        or else NT (N).Nkind = N_Procedure_Instantiation
+        or else NT (N).Nkind = N_Procedure_Specification);
+      return Node1 (N);
+   end Defining_Unit_Name;
+
+   function Delay_Alternative
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Timed_Entry_Call);
+      return Node4 (N);
+   end Delay_Alternative;
+
+   function Delay_Finalize_Attach
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Object_Declaration);
+      return Flag14 (N);
+   end Delay_Finalize_Attach;
+
+   function Delay_Statement
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Delay_Alternative);
+      return Node2 (N);
+   end Delay_Statement;
+
+   function Delta_Expression
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Decimal_Fixed_Point_Definition
+        or else NT (N).Nkind = N_Delta_Constraint
+        or else NT (N).Nkind = N_Ordinary_Fixed_Point_Definition);
+      return Node3 (N);
+   end Delta_Expression;
+
+   function Digits_Expression
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Decimal_Fixed_Point_Definition
+        or else NT (N).Nkind = N_Digits_Constraint
+        or else NT (N).Nkind = N_Floating_Point_Definition);
+      return Node2 (N);
+   end Digits_Expression;
+
+   function Discr_Check_Funcs_Built
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Full_Type_Declaration);
+      return Flag11 (N);
+   end Discr_Check_Funcs_Built;
+
+   function Discrete_Choices
+      (N : Node_Id) return List_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Case_Statement_Alternative
+        or else NT (N).Nkind = N_Variant);
+      return List4 (N);
+   end Discrete_Choices;
+
+   function Discrete_Range
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Slice);
+      return Node4 (N);
+   end Discrete_Range;
+
+   function Discrete_Subtype_Definition
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Entry_Declaration
+        or else NT (N).Nkind = N_Entry_Index_Specification
+        or else NT (N).Nkind = N_Loop_Parameter_Specification);
+      return Node4 (N);
+   end Discrete_Subtype_Definition;
+
+   function Discrete_Subtype_Definitions
+      (N : Node_Id) return List_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Constrained_Array_Definition);
+      return List2 (N);
+   end Discrete_Subtype_Definitions;
+
+   function Discriminant_Specifications
+      (N : Node_Id) return List_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Formal_Type_Declaration
+        or else NT (N).Nkind = N_Full_Type_Declaration
+        or else NT (N).Nkind = N_Incomplete_Type_Declaration
+        or else NT (N).Nkind = N_Private_Extension_Declaration
+        or else NT (N).Nkind = N_Private_Type_Declaration
+        or else NT (N).Nkind = N_Protected_Type_Declaration
+        or else NT (N).Nkind = N_Task_Type_Declaration);
+      return List4 (N);
+   end Discriminant_Specifications;
+
+   function Discriminant_Type
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Discriminant_Specification);
+      return Node5 (N);
+   end Discriminant_Type;
+
+   function Do_Access_Check
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Attribute_Reference
+        or else NT (N).Nkind = N_Explicit_Dereference
+        or else NT (N).Nkind = N_Indexed_Component
+        or else NT (N).Nkind = N_Selected_Component
+        or else NT (N).Nkind = N_Slice);
+      return Flag11 (N);
+   end Do_Access_Check;
+
+   function Do_Accessibility_Check
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Parameter_Specification);
+      return Flag13 (N);
+   end Do_Accessibility_Check;
+
+   function Do_Discriminant_Check
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Selected_Component);
+      return Flag13 (N);
+   end Do_Discriminant_Check;
+
+   function Do_Division_Check
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Op_Divide
+        or else NT (N).Nkind = N_Op_Mod
+        or else NT (N).Nkind = N_Op_Rem);
+      return Flag13 (N);
+   end Do_Division_Check;
+
+   function Do_Length_Check
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Assignment_Statement
+        or else NT (N).Nkind = N_Op_And
+        or else NT (N).Nkind = N_Op_Or
+        or else NT (N).Nkind = N_Op_Xor
+        or else NT (N).Nkind = N_Type_Conversion);
+      return Flag4 (N);
+   end Do_Length_Check;
+
+   function Do_Overflow_Check
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+          or else NT (N).Nkind in N_Op
+        or else NT (N).Nkind = N_Attribute_Reference
+        or else NT (N).Nkind = N_Type_Conversion);
+      return Flag17 (N);
+   end Do_Overflow_Check;
+
+   function Do_Range_Check
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+          or else NT (N).Nkind in N_Subexpr);
+      return Flag9 (N);
+   end Do_Range_Check;
+
+   function Do_Storage_Check
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Allocator
+        or else NT (N).Nkind = N_Subprogram_Body);
+      return Flag17 (N);
+   end Do_Storage_Check;
+
+   function Do_Tag_Check
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Assignment_Statement
+        or else NT (N).Nkind = N_Function_Call
+        or else NT (N).Nkind = N_Procedure_Call_Statement
+        or else NT (N).Nkind = N_Return_Statement
+        or else NT (N).Nkind = N_Type_Conversion);
+      return Flag13 (N);
+   end Do_Tag_Check;
+
+   function Elaborate_All_Present
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_With_Clause);
+      return Flag15 (N);
+   end Elaborate_All_Present;
+
+   function Elaborate_Present
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_With_Clause);
+      return Flag4 (N);
+   end Elaborate_Present;
+
+   function Elaboration_Boolean
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Function_Specification
+        or else NT (N).Nkind = N_Procedure_Specification);
+      return Node2 (N);
+   end Elaboration_Boolean;
+
+   function Else_Actions
+      (N : Node_Id) return List_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Conditional_Expression);
+      return List3 (N);
+   end Else_Actions;
+
+   function Else_Statements
+      (N : Node_Id) return List_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Conditional_Entry_Call
+        or else NT (N).Nkind = N_If_Statement
+        or else NT (N).Nkind = N_Selective_Accept);
+      return List4 (N);
+   end Else_Statements;
+
+   function Elsif_Parts
+      (N : Node_Id) return List_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_If_Statement);
+      return List3 (N);
+   end Elsif_Parts;
+
+   function Enclosing_Variant
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Variant);
+      return Node2 (N);
+   end Enclosing_Variant;
+
+   function End_Label
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Handled_Sequence_Of_Statements
+        or else NT (N).Nkind = N_Loop_Statement
+        or else NT (N).Nkind = N_Package_Specification
+        or else NT (N).Nkind = N_Protected_Body
+        or else NT (N).Nkind = N_Protected_Definition
+        or else NT (N).Nkind = N_Record_Definition
+        or else NT (N).Nkind = N_Task_Definition);
+      return Node4 (N);
+   end End_Label;
+
+   function End_Span
+      (N : Node_Id) return Uint is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Case_Statement
+        or else NT (N).Nkind = N_If_Statement);
+      return Uint5 (N);
+   end End_Span;
+
+   function Entity
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+          or else NT (N).Nkind in N_Has_Entity
+        or else NT (N).Nkind = N_Freeze_Entity);
+      return Node4 (N);
+   end Entity;
+
+   function Entry_Body_Formal_Part
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Entry_Body);
+      return Node5 (N);
+   end Entry_Body_Formal_Part;
+
+   function Entry_Call_Alternative
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Conditional_Entry_Call
+        or else NT (N).Nkind = N_Timed_Entry_Call);
+      return Node1 (N);
+   end Entry_Call_Alternative;
+
+   function Entry_Call_Statement
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Entry_Call_Alternative);
+      return Node1 (N);
+   end Entry_Call_Statement;
+
+   function Entry_Direct_Name
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Accept_Statement);
+      return Node1 (N);
+   end Entry_Direct_Name;
+
+   function Entry_Index
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Accept_Statement);
+      return Node5 (N);
+   end Entry_Index;
+
+   function Entry_Index_Specification
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Entry_Body_Formal_Part);
+      return Node4 (N);
+   end Entry_Index_Specification;
+
+   function Etype
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+         or else NT (N).Nkind in N_Has_Etype);
+      return Node5 (N);
+   end Etype;
+
+   function Exception_Choices
+      (N : Node_Id) return List_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Exception_Handler);
+      return List4 (N);
+   end Exception_Choices;
+
+   function Exception_Handlers
+      (N : Node_Id) return List_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Handled_Sequence_Of_Statements);
+      return List5 (N);
+   end Exception_Handlers;
+
+   function Exception_Junk
+     (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Goto_Statement
+        or else NT (N).Nkind = N_Label
+        or else NT (N).Nkind = N_Object_Declaration
+        or else NT (N).Nkind = N_Subtype_Declaration);
+      return Flag11 (N);
+   end Exception_Junk;
+
+   function Expansion_Delayed
+     (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Aggregate
+        or else NT (N).Nkind = N_Extension_Aggregate);
+      return Flag11 (N);
+   end Expansion_Delayed;
+
+   function Explicit_Actual_Parameter
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Parameter_Association);
+      return Node3 (N);
+   end Explicit_Actual_Parameter;
+
+   function Explicit_Generic_Actual_Parameter
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Generic_Association);
+      return Node1 (N);
+   end Explicit_Generic_Actual_Parameter;
+
+   function Expression
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Allocator
+        or else NT (N).Nkind = N_Assignment_Statement
+        or else NT (N).Nkind = N_At_Clause
+        or else NT (N).Nkind = N_Attribute_Definition_Clause
+        or else NT (N).Nkind = N_Case_Statement
+        or else NT (N).Nkind = N_Code_Statement
+        or else NT (N).Nkind = N_Component_Association
+        or else NT (N).Nkind = N_Component_Declaration
+        or else NT (N).Nkind = N_Delay_Relative_Statement
+        or else NT (N).Nkind = N_Delay_Until_Statement
+        or else NT (N).Nkind = N_Discriminant_Association
+        or else NT (N).Nkind = N_Discriminant_Specification
+        or else NT (N).Nkind = N_Exception_Declaration
+        or else NT (N).Nkind = N_Formal_Object_Declaration
+        or else NT (N).Nkind = N_Free_Statement
+        or else NT (N).Nkind = N_Mod_Clause
+        or else NT (N).Nkind = N_Modular_Type_Definition
+        or else NT (N).Nkind = N_Number_Declaration
+        or else NT (N).Nkind = N_Object_Declaration
+        or else NT (N).Nkind = N_Parameter_Specification
+        or else NT (N).Nkind = N_Pragma_Argument_Association
+        or else NT (N).Nkind = N_Qualified_Expression
+        or else NT (N).Nkind = N_Return_Statement
+        or else NT (N).Nkind = N_Type_Conversion
+        or else NT (N).Nkind = N_Unchecked_Expression
+        or else NT (N).Nkind = N_Unchecked_Type_Conversion);
+      return Node3 (N);
+   end Expression;
+
+   function Expressions
+      (N : Node_Id) return List_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Aggregate
+        or else NT (N).Nkind = N_Attribute_Reference
+        or else NT (N).Nkind = N_Conditional_Expression
+        or else NT (N).Nkind = N_Extension_Aggregate
+        or else NT (N).Nkind = N_Indexed_Component);
+      return List1 (N);
+   end Expressions;
+
+   function First_Bit
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Component_Clause);
+      return Node3 (N);
+   end First_Bit;
+
+   function First_Inlined_Subprogram
+      (N : Node_Id) return Entity_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Compilation_Unit);
+      return Node3 (N);
+   end First_Inlined_Subprogram;
+
+   function First_Name
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_With_Clause);
+      return Flag5 (N);
+   end First_Name;
+
+   function First_Named_Actual
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Entry_Call_Statement
+        or else NT (N).Nkind = N_Function_Call
+        or else NT (N).Nkind = N_Procedure_Call_Statement);
+      return Node4 (N);
+   end First_Named_Actual;
+
+   function First_Real_Statement
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Handled_Sequence_Of_Statements);
+      return Node2 (N);
+   end First_Real_Statement;
+
+   function First_Subtype_Link
+      (N : Node_Id) return Entity_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Freeze_Entity);
+      return Node5 (N);
+   end First_Subtype_Link;
+
+   function Float_Truncate
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Type_Conversion);
+      return Flag11 (N);
+   end Float_Truncate;
+
+   function Formal_Type_Definition
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Formal_Type_Declaration);
+      return Node3 (N);
+   end Formal_Type_Definition;
+
+   function Forwards_OK
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Assignment_Statement);
+      return Flag5 (N);
+   end Forwards_OK;
+
+   function From_At_Mod
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Attribute_Definition_Clause);
+      return Flag4 (N);
+   end From_At_Mod;
+
+   function Generic_Associations
+      (N : Node_Id) return List_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Formal_Package_Declaration
+        or else NT (N).Nkind = N_Function_Instantiation
+        or else NT (N).Nkind = N_Package_Instantiation
+        or else NT (N).Nkind = N_Procedure_Instantiation);
+      return List3 (N);
+   end Generic_Associations;
+
+   function Generic_Formal_Declarations
+      (N : Node_Id) return List_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Generic_Package_Declaration
+        or else NT (N).Nkind = N_Generic_Subprogram_Declaration);
+      return List2 (N);
+   end Generic_Formal_Declarations;
+
+   function Generic_Parent
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Function_Specification
+        or else NT (N).Nkind = N_Package_Specification
+        or else NT (N).Nkind = N_Procedure_Specification);
+      return Node5 (N);
+   end Generic_Parent;
+
+   function Generic_Parent_Type
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Subtype_Declaration);
+      return Node4 (N);
+   end Generic_Parent_Type;
+
+   function Handled_Statement_Sequence
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Accept_Statement
+        or else NT (N).Nkind = N_Block_Statement
+        or else NT (N).Nkind = N_Entry_Body
+        or else NT (N).Nkind = N_Package_Body
+        or else NT (N).Nkind = N_Subprogram_Body
+        or else NT (N).Nkind = N_Task_Body);
+      return Node4 (N);
+   end Handled_Statement_Sequence;
+
+   function Handler_List_Entry
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Object_Declaration);
+      return Node2 (N);
+   end Handler_List_Entry;
+
+   function Has_Created_Identifier
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Block_Statement
+        or else NT (N).Nkind = N_Loop_Statement);
+      return Flag15 (N);
+   end Has_Created_Identifier;
+
+   function Has_Dynamic_Length_Check
+      (N : Node_Id) return Boolean is
+   begin
+      return Flag10 (N);
+   end Has_Dynamic_Length_Check;
+
+   function Has_Dynamic_Range_Check
+      (N : Node_Id) return Boolean is
+   begin
+      return Flag12 (N);
+   end Has_Dynamic_Range_Check;
+
+   function Has_No_Elaboration_Code
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Compilation_Unit);
+      return Flag17 (N);
+   end Has_No_Elaboration_Code;
+
+   function Has_Priority_Pragma
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Protected_Definition
+        or else NT (N).Nkind = N_Subprogram_Body
+        or else NT (N).Nkind = N_Task_Definition);
+      return Flag6 (N);
+   end Has_Priority_Pragma;
+
+   function Has_Private_View
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+         or else NT (N).Nkind in N_Op
+       or else NT (N).Nkind = N_Character_Literal
+       or else NT (N).Nkind = N_Expanded_Name
+       or else NT (N).Nkind = N_Identifier
+       or else NT (N).Nkind = N_Operator_Symbol);
+      return Flag11 (N);
+   end Has_Private_View;
+
+   function Has_Storage_Size_Pragma
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Task_Definition);
+      return Flag5 (N);
+   end Has_Storage_Size_Pragma;
+
+   function Has_Task_Info_Pragma
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Task_Definition);
+      return Flag7 (N);
+   end Has_Task_Info_Pragma;
+
+   function Has_Task_Name_Pragma
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Task_Definition);
+      return Flag8 (N);
+   end Has_Task_Name_Pragma;
+
+   function Has_Wide_Character
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_String_Literal);
+      return Flag11 (N);
+   end Has_Wide_Character;
+
+   function Hidden_By_Use_Clause
+     (N : Node_Id) return Elist_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Use_Package_Clause
+        or else NT (N).Nkind = N_Use_Type_Clause);
+      return Elist4 (N);
+   end Hidden_By_Use_Clause;
+
+   function High_Bound
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Range
+        or else NT (N).Nkind = N_Real_Range_Specification
+        or else NT (N).Nkind = N_Signed_Integer_Type_Definition);
+      return Node2 (N);
+   end High_Bound;
+
+   function Identifier
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_At_Clause
+        or else NT (N).Nkind = N_Block_Statement
+        or else NT (N).Nkind = N_Designator
+        or else NT (N).Nkind = N_Enumeration_Representation_Clause
+        or else NT (N).Nkind = N_Label
+        or else NT (N).Nkind = N_Loop_Statement
+        or else NT (N).Nkind = N_Record_Representation_Clause
+        or else NT (N).Nkind = N_Subprogram_Info);
+      return Node1 (N);
+   end Identifier;
+
+   function Implicit_With
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_With_Clause);
+      return Flag17 (N);
+   end Implicit_With;
+
+   function In_Present
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Formal_Object_Declaration
+        or else NT (N).Nkind = N_Parameter_Specification);
+      return Flag15 (N);
+   end In_Present;
+
+   function Includes_Infinities
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Range);
+      return Flag11 (N);
+   end Includes_Infinities;
+
+   function Instance_Spec
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Formal_Package_Declaration
+        or else NT (N).Nkind = N_Function_Instantiation
+        or else NT (N).Nkind = N_Package_Instantiation
+        or else NT (N).Nkind = N_Procedure_Instantiation);
+      return Node5 (N);
+   end Instance_Spec;
+
+   function Intval
+      (N : Node_Id) return Uint is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Integer_Literal);
+      return Uint3 (N);
+   end Intval;
+
+   function Is_Asynchronous_Call_Block
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Block_Statement);
+      return Flag7 (N);
+   end Is_Asynchronous_Call_Block;
+
+   function Is_Component_Left_Opnd
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Op_Concat);
+      return Flag13 (N);
+   end Is_Component_Left_Opnd;
+
+   function Is_Component_Right_Opnd
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Op_Concat);
+      return Flag14 (N);
+   end Is_Component_Right_Opnd;
+
+   function Is_Controlling_Actual
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+          or else NT (N).Nkind in N_Subexpr);
+      return Flag16 (N);
+   end Is_Controlling_Actual;
+
+   function Is_Machine_Number
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Real_Literal);
+      return Flag11 (N);
+   end Is_Machine_Number;
+
+   function Is_Overloaded
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+          or else NT (N).Nkind in N_Subexpr);
+      return Flag5 (N);
+   end Is_Overloaded;
+
+   function Is_Power_Of_2_For_Shift
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Op_Expon);
+      return Flag13 (N);
+   end Is_Power_Of_2_For_Shift;
+
+   function Is_Protected_Subprogram_Body
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Subprogram_Body);
+      return Flag7 (N);
+   end Is_Protected_Subprogram_Body;
+
+   function Is_Static_Expression
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+          or else NT (N).Nkind in N_Subexpr);
+      return Flag6 (N);
+   end Is_Static_Expression;
+
+   function Is_Subprogram_Descriptor
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Object_Declaration);
+      return Flag16 (N);
+   end Is_Subprogram_Descriptor;
+
+   function Is_Task_Allocation_Block
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Block_Statement);
+      return Flag6 (N);
+   end Is_Task_Allocation_Block;
+
+   function Is_Task_Master
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Block_Statement
+        or else NT (N).Nkind = N_Subprogram_Body
+        or else NT (N).Nkind = N_Task_Body);
+      return Flag5 (N);
+   end Is_Task_Master;
+
+   function Iteration_Scheme
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Loop_Statement);
+      return Node2 (N);
+   end Iteration_Scheme;
+
+   function Itype
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+      or else NT (N).Nkind = N_Itype_Reference);
+      return Node1 (N);
+   end Itype;
+
+   function Kill_Range_Check
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Unchecked_Type_Conversion);
+      return Flag11 (N);
+   end Kill_Range_Check;
+
+   function Label_Construct
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Implicit_Label_Declaration);
+      return Node2 (N);
+   end Label_Construct;
+
+   function Last_Bit
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Component_Clause);
+      return Node4 (N);
+   end Last_Bit;
+
+   function Last_Name
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_With_Clause);
+      return Flag6 (N);
+   end Last_Name;
+
+   function Left_Opnd
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_And_Then
+        or else NT (N).Nkind = N_In
+        or else NT (N).Nkind = N_Not_In
+        or else NT (N).Nkind = N_Or_Else
+          or else NT (N).Nkind in N_Binary_Op);
+      return Node2 (N);
+   end Left_Opnd;
+
+   function Library_Unit
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Compilation_Unit
+        or else NT (N).Nkind = N_Package_Body_Stub
+        or else NT (N).Nkind = N_Protected_Body_Stub
+        or else NT (N).Nkind = N_Subprogram_Body_Stub
+        or else NT (N).Nkind = N_Task_Body_Stub
+        or else NT (N).Nkind = N_With_Clause);
+      return Node4 (N);
+   end Library_Unit;
+
+   function Limited_Present
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Formal_Private_Type_Definition
+        or else NT (N).Nkind = N_Private_Type_Declaration
+        or else NT (N).Nkind = N_Record_Definition);
+      return Flag17 (N);
+   end Limited_Present;
+
+   function Literals
+      (N : Node_Id) return List_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Enumeration_Type_Definition);
+      return List1 (N);
+   end Literals;
+
+   function Loop_Actions
+      (N : Node_Id) return List_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Component_Association);
+      return List2 (N);
+   end Loop_Actions;
+
+   function Loop_Parameter_Specification
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Iteration_Scheme);
+      return Node4 (N);
+   end Loop_Parameter_Specification;
+
+   function Low_Bound
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Range
+        or else NT (N).Nkind = N_Real_Range_Specification
+        or else NT (N).Nkind = N_Signed_Integer_Type_Definition);
+      return Node1 (N);
+   end Low_Bound;
+
+   function Mod_Clause
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Record_Representation_Clause);
+      return Node2 (N);
+   end Mod_Clause;
+
+   function More_Ids
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Component_Declaration
+        or else NT (N).Nkind = N_Discriminant_Specification
+        or else NT (N).Nkind = N_Exception_Declaration
+        or else NT (N).Nkind = N_Formal_Object_Declaration
+        or else NT (N).Nkind = N_Number_Declaration
+        or else NT (N).Nkind = N_Object_Declaration
+        or else NT (N).Nkind = N_Parameter_Specification);
+      return Flag5 (N);
+   end More_Ids;
+
+   function Must_Not_Freeze
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Subtype_Indication
+          or else NT (N).Nkind in N_Subexpr);
+      return Flag8 (N);
+   end Must_Not_Freeze;
+
+   function Name
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Assignment_Statement
+        or else NT (N).Nkind = N_Attribute_Definition_Clause
+        or else NT (N).Nkind = N_Defining_Program_Unit_Name
+        or else NT (N).Nkind = N_Designator
+        or else NT (N).Nkind = N_Entry_Call_Statement
+        or else NT (N).Nkind = N_Exception_Renaming_Declaration
+        or else NT (N).Nkind = N_Exit_Statement
+        or else NT (N).Nkind = N_Formal_Package_Declaration
+        or else NT (N).Nkind = N_Function_Call
+        or else NT (N).Nkind = N_Function_Instantiation
+        or else NT (N).Nkind = N_Generic_Function_Renaming_Declaration
+        or else NT (N).Nkind = N_Generic_Package_Renaming_Declaration
+        or else NT (N).Nkind = N_Generic_Procedure_Renaming_Declaration
+        or else NT (N).Nkind = N_Goto_Statement
+        or else NT (N).Nkind = N_Object_Renaming_Declaration
+        or else NT (N).Nkind = N_Package_Instantiation
+        or else NT (N).Nkind = N_Package_Renaming_Declaration
+        or else NT (N).Nkind = N_Procedure_Call_Statement
+        or else NT (N).Nkind = N_Procedure_Instantiation
+        or else NT (N).Nkind = N_Raise_Statement
+        or else NT (N).Nkind = N_Requeue_Statement
+        or else NT (N).Nkind = N_Subprogram_Renaming_Declaration
+        or else NT (N).Nkind = N_Subunit
+        or else NT (N).Nkind = N_Variant_Part
+        or else NT (N).Nkind = N_With_Clause
+        or else NT (N).Nkind = N_With_Type_Clause);
+      return Node2 (N);
+   end Name;
+
+   function Names
+      (N : Node_Id) return List_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Abort_Statement
+        or else NT (N).Nkind = N_Use_Package_Clause);
+      return List2 (N);
+   end Names;
+
+   function Next_Entity
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Defining_Character_Literal
+        or else NT (N).Nkind = N_Defining_Identifier
+        or else NT (N).Nkind = N_Defining_Operator_Symbol);
+      return Node2 (N);
+   end Next_Entity;
+
+   function Next_Named_Actual
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Parameter_Association);
+      return Node4 (N);
+   end Next_Named_Actual;
+
+   function Next_Rep_Item
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Attribute_Definition_Clause
+        or else NT (N).Nkind = N_Enumeration_Representation_Clause
+        or else NT (N).Nkind = N_Pragma
+        or else NT (N).Nkind = N_Record_Representation_Clause);
+      return Node4 (N);
+   end Next_Rep_Item;
+
+   function Next_Use_Clause
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Use_Package_Clause
+        or else NT (N).Nkind = N_Use_Type_Clause);
+      return Node3 (N);
+   end Next_Use_Clause;
+
+   function No_Ctrl_Actions
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Assignment_Statement);
+      return Flag7 (N);
+   end No_Ctrl_Actions;
+
+   function No_Entities_Ref_In_Spec
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_With_Clause);
+      return Flag8 (N);
+   end No_Entities_Ref_In_Spec;
+
+   function No_Initialization
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Allocator
+        or else NT (N).Nkind = N_Object_Declaration);
+      return Flag13 (N);
+   end No_Initialization;
+
+   function Null_Present
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Component_List
+        or else NT (N).Nkind = N_Record_Definition);
+      return Flag13 (N);
+   end Null_Present;
+
+   function Null_Record_Present
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Aggregate
+        or else NT (N).Nkind = N_Extension_Aggregate);
+      return Flag17 (N);
+   end Null_Record_Present;
+
+   function Object_Definition
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Object_Declaration);
+      return Node4 (N);
+   end Object_Definition;
+
+   function OK_For_Stream
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Attribute_Reference);
+      return Flag4 (N);
+   end OK_For_Stream;
+
+   function Original_Discriminant
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Identifier);
+      return Node2 (N);
+   end Original_Discriminant;
+
+   function Others_Discrete_Choices
+      (N : Node_Id) return List_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Others_Choice);
+      return List1 (N);
+   end Others_Discrete_Choices;
+
+   function Out_Present
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Formal_Object_Declaration
+        or else NT (N).Nkind = N_Parameter_Specification);
+      return Flag17 (N);
+   end Out_Present;
+
+   function Parameter_Associations
+      (N : Node_Id) return List_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Entry_Call_Statement
+        or else NT (N).Nkind = N_Function_Call
+        or else NT (N).Nkind = N_Procedure_Call_Statement);
+      return List3 (N);
+   end Parameter_Associations;
+
+   function Parameter_List_Truncated
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Function_Call
+        or else NT (N).Nkind = N_Procedure_Call_Statement);
+      return Flag17 (N);
+   end Parameter_List_Truncated;
+
+   function Parameter_Specifications
+      (N : Node_Id) return List_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Accept_Statement
+        or else NT (N).Nkind = N_Access_Function_Definition
+        or else NT (N).Nkind = N_Access_Procedure_Definition
+        or else NT (N).Nkind = N_Entry_Body_Formal_Part
+        or else NT (N).Nkind = N_Entry_Declaration
+        or else NT (N).Nkind = N_Function_Specification
+        or else NT (N).Nkind = N_Procedure_Specification);
+      return List3 (N);
+   end Parameter_Specifications;
+
+   function Parameter_Type
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Parameter_Specification);
+      return Node2 (N);
+   end Parameter_Type;
+
+   function Parent_Spec
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Function_Instantiation
+        or else NT (N).Nkind = N_Generic_Function_Renaming_Declaration
+        or else NT (N).Nkind = N_Generic_Package_Declaration
+        or else NT (N).Nkind = N_Generic_Package_Renaming_Declaration
+        or else NT (N).Nkind = N_Generic_Procedure_Renaming_Declaration
+        or else NT (N).Nkind = N_Generic_Subprogram_Declaration
+        or else NT (N).Nkind = N_Package_Declaration
+        or else NT (N).Nkind = N_Package_Instantiation
+        or else NT (N).Nkind = N_Package_Renaming_Declaration
+        or else NT (N).Nkind = N_Procedure_Instantiation
+        or else NT (N).Nkind = N_Subprogram_Declaration
+        or else NT (N).Nkind = N_Subprogram_Renaming_Declaration);
+      return Node4 (N);
+   end Parent_Spec;
+
+   function Position
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Component_Clause);
+      return Node2 (N);
+   end Position;
+
+   function Pragma_Argument_Associations
+      (N : Node_Id) return List_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Pragma);
+      return List2 (N);
+   end Pragma_Argument_Associations;
+
+   function Pragmas_After
+      (N : Node_Id) return List_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Compilation_Unit_Aux
+        or else NT (N).Nkind = N_Terminate_Alternative);
+      return List5 (N);
+   end Pragmas_After;
+
+   function Pragmas_Before
+      (N : Node_Id) return List_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Accept_Alternative
+        or else NT (N).Nkind = N_Delay_Alternative
+        or else NT (N).Nkind = N_Entry_Call_Alternative
+        or else NT (N).Nkind = N_Mod_Clause
+        or else NT (N).Nkind = N_Terminate_Alternative
+        or else NT (N).Nkind = N_Triggering_Alternative);
+      return List4 (N);
+   end Pragmas_Before;
+
+   function Prefix
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Attribute_Reference
+        or else NT (N).Nkind = N_Expanded_Name
+        or else NT (N).Nkind = N_Explicit_Dereference
+        or else NT (N).Nkind = N_Indexed_Component
+        or else NT (N).Nkind = N_Reference
+        or else NT (N).Nkind = N_Selected_Component
+        or else NT (N).Nkind = N_Slice);
+      return Node3 (N);
+   end Prefix;
+
+   function Present_Expr
+      (N : Node_Id) return Uint is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Variant);
+      return Uint3 (N);
+   end Present_Expr;
+
+   function Prev_Ids
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Component_Declaration
+        or else NT (N).Nkind = N_Discriminant_Specification
+        or else NT (N).Nkind = N_Exception_Declaration
+        or else NT (N).Nkind = N_Formal_Object_Declaration
+        or else NT (N).Nkind = N_Number_Declaration
+        or else NT (N).Nkind = N_Object_Declaration
+        or else NT (N).Nkind = N_Parameter_Specification);
+      return Flag6 (N);
+   end Prev_Ids;
+
+   function Print_In_Hex
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Integer_Literal);
+      return Flag13 (N);
+   end Print_In_Hex;
+
+   function Private_Declarations
+      (N : Node_Id) return List_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Package_Specification
+        or else NT (N).Nkind = N_Protected_Definition
+        or else NT (N).Nkind = N_Task_Definition);
+      return List3 (N);
+   end Private_Declarations;
+
+   function Private_Present
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Compilation_Unit
+        or else NT (N).Nkind = N_Formal_Derived_Type_Definition);
+      return Flag15 (N);
+   end Private_Present;
+
+   function Procedure_To_Call
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Allocator
+        or else NT (N).Nkind = N_Free_Statement
+        or else NT (N).Nkind = N_Return_Statement);
+      return Node4 (N);
+   end Procedure_To_Call;
+
+   function Proper_Body
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Subunit);
+      return Node1 (N);
+   end Proper_Body;
+
+   function Protected_Definition
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Protected_Type_Declaration
+        or else NT (N).Nkind = N_Single_Protected_Declaration);
+      return Node3 (N);
+   end Protected_Definition;
+
+   function Protected_Present
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Access_Function_Definition
+        or else NT (N).Nkind = N_Access_Procedure_Definition);
+      return Flag15 (N);
+   end Protected_Present;
+
+   function Raises_Constraint_Error
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+          or else NT (N).Nkind in N_Subexpr);
+      return Flag7 (N);
+   end Raises_Constraint_Error;
+
+   function Range_Constraint
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Delta_Constraint
+        or else NT (N).Nkind = N_Digits_Constraint);
+      return Node4 (N);
+   end Range_Constraint;
+
+   function Range_Expression
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Range_Constraint);
+      return Node4 (N);
+   end Range_Expression;
+
+   function Real_Range_Specification
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Decimal_Fixed_Point_Definition
+        or else NT (N).Nkind = N_Floating_Point_Definition
+        or else NT (N).Nkind = N_Ordinary_Fixed_Point_Definition);
+      return Node4 (N);
+   end Real_Range_Specification;
+
+   function Realval
+      (N : Node_Id) return Ureal is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Real_Literal);
+      return Ureal3 (N);
+   end Realval;
+
+   function Record_Extension_Part
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Derived_Type_Definition);
+      return Node3 (N);
+   end Record_Extension_Part;
+
+   function Redundant_Use
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Attribute_Reference
+        or else NT (N).Nkind = N_Expanded_Name
+        or else NT (N).Nkind = N_Identifier);
+      return Flag13 (N);
+   end Redundant_Use;
+
+   function Return_Type
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Return_Statement);
+      return Node2 (N);
+   end Return_Type;
+
+   function Reverse_Present
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Loop_Parameter_Specification);
+      return Flag15 (N);
+   end Reverse_Present;
+
+   function Right_Opnd
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+          or else NT (N).Nkind in N_Op
+        or else NT (N).Nkind = N_And_Then
+        or else NT (N).Nkind = N_In
+        or else NT (N).Nkind = N_Not_In
+        or else NT (N).Nkind = N_Or_Else);
+      return Node3 (N);
+   end Right_Opnd;
+
+   function Rounded_Result
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Op_Divide
+        or else NT (N).Nkind = N_Op_Multiply
+        or else NT (N).Nkind = N_Type_Conversion);
+      return Flag18 (N);
+   end Rounded_Result;
+
+   function Scope
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Defining_Character_Literal
+        or else NT (N).Nkind = N_Defining_Identifier
+        or else NT (N).Nkind = N_Defining_Operator_Symbol);
+      return Node3 (N);
+   end Scope;
+
+   function Select_Alternatives
+      (N : Node_Id) return List_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Selective_Accept);
+      return List1 (N);
+   end Select_Alternatives;
+
+   function Selector_Name
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Expanded_Name
+        or else NT (N).Nkind = N_Generic_Association
+        or else NT (N).Nkind = N_Parameter_Association
+        or else NT (N).Nkind = N_Selected_Component);
+      return Node2 (N);
+   end Selector_Name;
+
+   function Selector_Names
+      (N : Node_Id) return List_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Discriminant_Association);
+      return List1 (N);
+   end Selector_Names;
+
+   function Shift_Count_OK
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Op_Rotate_Left
+        or else NT (N).Nkind = N_Op_Rotate_Right
+        or else NT (N).Nkind = N_Op_Shift_Left
+        or else NT (N).Nkind = N_Op_Shift_Right
+        or else NT (N).Nkind = N_Op_Shift_Right_Arithmetic);
+      return Flag4 (N);
+   end Shift_Count_OK;
+
+   function Source_Type
+      (N : Node_Id) return Entity_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Validate_Unchecked_Conversion);
+      return Node1 (N);
+   end Source_Type;
+
+   function Specification
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Abstract_Subprogram_Declaration
+        or else NT (N).Nkind = N_Formal_Subprogram_Declaration
+        or else NT (N).Nkind = N_Generic_Package_Declaration
+        or else NT (N).Nkind = N_Generic_Subprogram_Declaration
+        or else NT (N).Nkind = N_Package_Declaration
+        or else NT (N).Nkind = N_Subprogram_Body
+        or else NT (N).Nkind = N_Subprogram_Body_Stub
+        or else NT (N).Nkind = N_Subprogram_Declaration
+        or else NT (N).Nkind = N_Subprogram_Renaming_Declaration);
+      return Node1 (N);
+   end Specification;
+
+   function Statements
+      (N : Node_Id) return List_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Abortable_Part
+        or else NT (N).Nkind = N_Accept_Alternative
+        or else NT (N).Nkind = N_Case_Statement_Alternative
+        or else NT (N).Nkind = N_Delay_Alternative
+        or else NT (N).Nkind = N_Entry_Call_Alternative
+        or else NT (N).Nkind = N_Exception_Handler
+        or else NT (N).Nkind = N_Handled_Sequence_Of_Statements
+        or else NT (N).Nkind = N_Loop_Statement
+        or else NT (N).Nkind = N_Triggering_Alternative);
+      return List3 (N);
+   end Statements;
+
+   function Static_Processing_OK
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Aggregate);
+      return Flag4 (N);
+   end Static_Processing_OK;
+
+   function Storage_Pool
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Allocator
+        or else NT (N).Nkind = N_Free_Statement
+        or else NT (N).Nkind = N_Return_Statement);
+      return Node1 (N);
+   end Storage_Pool;
+
+   function Strval
+      (N : Node_Id) return String_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Operator_Symbol
+        or else NT (N).Nkind = N_String_Literal);
+      return Str3 (N);
+   end Strval;
+
+   function Subtype_Indication
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Access_To_Object_Definition
+        or else NT (N).Nkind = N_Component_Declaration
+        or else NT (N).Nkind = N_Constrained_Array_Definition
+        or else NT (N).Nkind = N_Derived_Type_Definition
+        or else NT (N).Nkind = N_Private_Extension_Declaration
+        or else NT (N).Nkind = N_Subtype_Declaration
+        or else NT (N).Nkind = N_Unconstrained_Array_Definition);
+      return Node5 (N);
+   end Subtype_Indication;
+
+   function Subtype_Mark
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Access_Definition
+        or else NT (N).Nkind = N_Access_Function_Definition
+        or else NT (N).Nkind = N_Formal_Derived_Type_Definition
+        or else NT (N).Nkind = N_Formal_Object_Declaration
+        or else NT (N).Nkind = N_Function_Specification
+        or else NT (N).Nkind = N_Object_Renaming_Declaration
+        or else NT (N).Nkind = N_Qualified_Expression
+        or else NT (N).Nkind = N_Subtype_Indication
+        or else NT (N).Nkind = N_Type_Conversion
+        or else NT (N).Nkind = N_Unchecked_Type_Conversion);
+      return Node4 (N);
+   end Subtype_Mark;
+
+   function Subtype_Marks
+      (N : Node_Id) return List_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Unconstrained_Array_Definition
+        or else NT (N).Nkind = N_Use_Type_Clause);
+      return List2 (N);
+   end Subtype_Marks;
+
+   function Tagged_Present
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Formal_Private_Type_Definition
+        or else NT (N).Nkind = N_Private_Type_Declaration
+        or else NT (N).Nkind = N_Record_Definition
+        or else NT (N).Nkind = N_With_Type_Clause);
+      return Flag15 (N);
+   end Tagged_Present;
+
+   function Target_Type
+      (N : Node_Id) return Entity_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Validate_Unchecked_Conversion);
+      return Node2 (N);
+   end Target_Type;
+
+   function Task_Body_Procedure
+      (N : Node_Id) return Entity_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Task_Type_Declaration);
+      return Node2 (N);
+   end Task_Body_Procedure;
+
+   function Task_Definition
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Single_Task_Declaration
+        or else NT (N).Nkind = N_Task_Type_Declaration);
+      return Node3 (N);
+   end Task_Definition;
+
+   function Then_Actions
+      (N : Node_Id) return List_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Conditional_Expression);
+      return List2 (N);
+   end Then_Actions;
+
+   function Then_Statements
+      (N : Node_Id) return List_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Elsif_Part
+        or else NT (N).Nkind = N_If_Statement);
+      return List2 (N);
+   end Then_Statements;
+
+   function Treat_Fixed_As_Integer
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Op_Divide
+        or else NT (N).Nkind = N_Op_Mod
+        or else NT (N).Nkind = N_Op_Multiply
+        or else NT (N).Nkind = N_Op_Rem);
+      return Flag14 (N);
+   end Treat_Fixed_As_Integer;
+
+   function Triggering_Alternative
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Asynchronous_Select);
+      return Node1 (N);
+   end Triggering_Alternative;
+
+   function Triggering_Statement
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Triggering_Alternative);
+      return Node1 (N);
+   end Triggering_Statement;
+
+   function TSS_Elist
+      (N : Node_Id) return Elist_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Freeze_Entity);
+      return Elist3 (N);
+   end TSS_Elist;
+
+   function Type_Definition
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Full_Type_Declaration);
+      return Node3 (N);
+   end Type_Definition;
+
+   function Unit
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Compilation_Unit);
+      return Node2 (N);
+   end Unit;
+
+   function Unknown_Discriminants_Present
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Formal_Type_Declaration
+        or else NT (N).Nkind = N_Incomplete_Type_Declaration
+        or else NT (N).Nkind = N_Private_Extension_Declaration
+        or else NT (N).Nkind = N_Private_Type_Declaration);
+      return Flag13 (N);
+   end Unknown_Discriminants_Present;
+
+   function Unreferenced_In_Spec
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_With_Clause);
+      return Flag7 (N);
+   end Unreferenced_In_Spec;
+
+   function Variant_Part
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Component_List);
+      return Node4 (N);
+   end Variant_Part;
+
+   function Variants
+      (N : Node_Id) return List_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Variant_Part);
+      return List1 (N);
+   end Variants;
+
+   function Visible_Declarations
+      (N : Node_Id) return List_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Package_Specification
+        or else NT (N).Nkind = N_Protected_Definition
+        or else NT (N).Nkind = N_Task_Definition);
+      return List2 (N);
+   end Visible_Declarations;
+
+   function Was_Originally_Stub
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Package_Body
+        or else NT (N).Nkind = N_Protected_Body
+        or else NT (N).Nkind = N_Subprogram_Body
+        or else NT (N).Nkind = N_Task_Body);
+      return Flag13 (N);
+   end Was_Originally_Stub;
+
+   function Zero_Cost_Handling
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Exception_Handler
+        or else NT (N).Nkind = N_Handled_Sequence_Of_Statements);
+      return Flag5 (N);
+   end Zero_Cost_Handling;
+
+   --------------------------
+   -- Field Set Procedures --
+   --------------------------
+
+   procedure Set_ABE_Is_Certain
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Formal_Package_Declaration
+        or else NT (N).Nkind = N_Function_Call
+        or else NT (N).Nkind = N_Function_Instantiation
+        or else NT (N).Nkind = N_Package_Instantiation
+        or else NT (N).Nkind = N_Procedure_Call_Statement
+        or else NT (N).Nkind = N_Procedure_Instantiation);
+      Set_Flag18 (N, Val);
+   end Set_ABE_Is_Certain;
+
+   procedure Set_Abort_Present
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Requeue_Statement);
+      Set_Flag15 (N, Val);
+   end Set_Abort_Present;
+
+   procedure Set_Abortable_Part
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Asynchronous_Select);
+      Set_Node2_With_Parent (N, Val);
+   end Set_Abortable_Part;
+
+   procedure Set_Abstract_Present
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Derived_Type_Definition
+        or else NT (N).Nkind = N_Formal_Derived_Type_Definition
+        or else NT (N).Nkind = N_Formal_Private_Type_Definition
+        or else NT (N).Nkind = N_Private_Extension_Declaration
+        or else NT (N).Nkind = N_Private_Type_Declaration
+        or else NT (N).Nkind = N_Record_Definition);
+      Set_Flag4 (N, Val);
+   end Set_Abstract_Present;
+
+   procedure Set_Accept_Handler_Records
+      (N : Node_Id; Val : List_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Accept_Alternative);
+      Set_List5 (N, Val); -- semantic field, no parent set
+   end Set_Accept_Handler_Records;
+
+   procedure Set_Accept_Statement
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Accept_Alternative);
+      Set_Node2_With_Parent (N, Val);
+   end Set_Accept_Statement;
+
+   procedure Set_Access_Types_To_Process
+      (N : Node_Id; Val : Elist_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Freeze_Entity);
+      Set_Elist2 (N, Val); -- semantic field, no parent set
+   end Set_Access_Types_To_Process;
+
+   procedure Set_Actions
+      (N : Node_Id; Val : List_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_And_Then
+        or else NT (N).Nkind = N_Compilation_Unit_Aux
+        or else NT (N).Nkind = N_Freeze_Entity
+        or else NT (N).Nkind = N_Or_Else);
+      Set_List1_With_Parent (N, Val);
+   end Set_Actions;
+
+   procedure Set_Activation_Chain_Entity
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Block_Statement
+        or else NT (N).Nkind = N_Entry_Body
+        or else NT (N).Nkind = N_Generic_Package_Declaration
+        or else NT (N).Nkind = N_Package_Declaration
+        or else NT (N).Nkind = N_Subprogram_Body
+        or else NT (N).Nkind = N_Task_Body);
+      Set_Node3 (N, Val); -- semantic field, no parent set
+   end Set_Activation_Chain_Entity;
+
+   procedure Set_Acts_As_Spec
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Compilation_Unit
+        or else NT (N).Nkind = N_Subprogram_Body);
+      Set_Flag4 (N, Val);
+   end Set_Acts_As_Spec;
+
+   procedure Set_Aggregate_Bounds
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Aggregate);
+      Set_Node3 (N, Val); -- semantic field, no parent set
+   end Set_Aggregate_Bounds;
+
+   procedure Set_Aliased_Present
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Component_Declaration
+        or else NT (N).Nkind = N_Constrained_Array_Definition
+        or else NT (N).Nkind = N_Object_Declaration
+        or else NT (N).Nkind = N_Unconstrained_Array_Definition);
+      Set_Flag4 (N, Val);
+   end Set_Aliased_Present;
+
+   procedure Set_All_Others
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Others_Choice);
+      Set_Flag11 (N, Val);
+   end Set_All_Others;
+
+   procedure Set_All_Present
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Access_To_Object_Definition);
+      Set_Flag15 (N, Val);
+   end Set_All_Present;
+
+   procedure Set_Alternatives
+      (N : Node_Id; Val : List_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Case_Statement);
+      Set_List4_With_Parent (N, Val);
+   end Set_Alternatives;
+
+   procedure Set_Ancestor_Part
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Extension_Aggregate);
+      Set_Node3_With_Parent (N, Val);
+   end Set_Ancestor_Part;
+
+   procedure Set_Array_Aggregate
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Enumeration_Representation_Clause);
+      Set_Node3_With_Parent (N, Val);
+   end Set_Array_Aggregate;
+
+   procedure Set_Assignment_OK
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Object_Declaration
+          or else NT (N).Nkind in N_Subexpr);
+      Set_Flag15 (N, Val);
+   end Set_Assignment_OK;
+
+   procedure Set_At_End_Proc
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Handled_Sequence_Of_Statements);
+      Set_Node1 (N, Val);
+   end Set_At_End_Proc;
+
+   procedure Set_Attribute_Name
+      (N : Node_Id; Val : Name_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Attribute_Reference);
+      Set_Name2 (N, Val);
+   end Set_Attribute_Name;
+
+   procedure Set_Aux_Decls_Node
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Compilation_Unit);
+      Set_Node5_With_Parent (N, Val);
+   end Set_Aux_Decls_Node;
+
+   procedure Set_Backwards_OK
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Assignment_Statement);
+      Set_Flag6 (N, Val);
+   end Set_Backwards_OK;
+
+   procedure Set_Bad_Is_Detected
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Subprogram_Body);
+      Set_Flag15 (N, Val);
+   end Set_Bad_Is_Detected;
+
+   procedure Set_Body_Required
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Compilation_Unit);
+      Set_Flag13 (N, Val);
+   end Set_Body_Required;
+
+   procedure Set_Body_To_Inline
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Subprogram_Declaration);
+      Set_Node3 (N, Val);
+   end Set_Body_To_Inline;
+
+   procedure Set_Box_Present
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Formal_Package_Declaration
+        or else NT (N).Nkind = N_Formal_Subprogram_Declaration);
+      Set_Flag15 (N, Val);
+   end Set_Box_Present;
+
+   procedure Set_By_Ref
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Return_Statement);
+      Set_Flag5 (N, Val);
+   end Set_By_Ref;
+
+   procedure Set_Char_Literal_Value
+      (N : Node_Id; Val : Char_Code) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Character_Literal);
+      Set_Char_Code2 (N, Val);
+   end Set_Char_Literal_Value;
+
+   procedure Set_Chars
+      (N : Node_Id; Val : Name_Id) is
+   begin
+      pragma Assert (False
+          or else NT (N).Nkind in N_Has_Chars);
+      Set_Name1 (N, Val);
+   end Set_Chars;
+
+   procedure Set_Choice_Parameter
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Exception_Handler);
+      Set_Node2_With_Parent (N, Val);
+   end Set_Choice_Parameter;
+
+   procedure Set_Choices
+      (N : Node_Id; Val : List_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Component_Association);
+      Set_List1_With_Parent (N, Val);
+   end Set_Choices;
+
+   procedure Set_Compile_Time_Known_Aggregate
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Aggregate);
+      Set_Flag18 (N, Val);
+   end Set_Compile_Time_Known_Aggregate;
+
+   procedure Set_Component_Associations
+      (N : Node_Id; Val : List_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Aggregate
+        or else NT (N).Nkind = N_Extension_Aggregate);
+      Set_List2_With_Parent (N, Val);
+   end Set_Component_Associations;
+
+   procedure Set_Component_Clauses
+      (N : Node_Id; Val : List_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Record_Representation_Clause);
+      Set_List3_With_Parent (N, Val);
+   end Set_Component_Clauses;
+
+   procedure Set_Component_Items
+      (N : Node_Id; Val : List_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Component_List);
+      Set_List3_With_Parent (N, Val);
+   end Set_Component_Items;
+
+   procedure Set_Component_List
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Record_Definition
+        or else NT (N).Nkind = N_Variant);
+      Set_Node1_With_Parent (N, Val);
+   end Set_Component_List;
+
+   procedure Set_Component_Name
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Component_Clause);
+      Set_Node1_With_Parent (N, Val);
+   end Set_Component_Name;
+
+   procedure Set_Condition
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Accept_Alternative
+        or else NT (N).Nkind = N_Delay_Alternative
+        or else NT (N).Nkind = N_Elsif_Part
+        or else NT (N).Nkind = N_Entry_Body_Formal_Part
+        or else NT (N).Nkind = N_Exit_Statement
+        or else NT (N).Nkind = N_If_Statement
+        or else NT (N).Nkind = N_Iteration_Scheme
+        or else NT (N).Nkind = N_Raise_Constraint_Error
+        or else NT (N).Nkind = N_Raise_Program_Error
+        or else NT (N).Nkind = N_Raise_Storage_Error
+        or else NT (N).Nkind = N_Terminate_Alternative);
+      Set_Node1_With_Parent (N, Val);
+   end Set_Condition;
+
+   procedure Set_Condition_Actions
+      (N : Node_Id; Val : List_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Elsif_Part
+        or else NT (N).Nkind = N_Iteration_Scheme);
+      Set_List3 (N, Val); -- semantic field, no parent set
+   end Set_Condition_Actions;
+
+   procedure Set_Constant_Present
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Access_To_Object_Definition
+        or else NT (N).Nkind = N_Object_Declaration);
+      Set_Flag17 (N, Val);
+   end Set_Constant_Present;
+
+   procedure Set_Constraint
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Subtype_Indication);
+      Set_Node3_With_Parent (N, Val);
+   end Set_Constraint;
+
+   procedure Set_Constraints
+      (N : Node_Id; Val : List_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Index_Or_Discriminant_Constraint);
+      Set_List1_With_Parent (N, Val);
+   end Set_Constraints;
+
+   procedure Set_Context_Installed
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_With_Clause);
+      Set_Flag13 (N, Val);
+   end Set_Context_Installed;
+
+   procedure Set_Context_Items
+      (N : Node_Id; Val : List_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Compilation_Unit);
+      Set_List1_With_Parent (N, Val);
+   end Set_Context_Items;
+
+   procedure Set_Controlling_Argument
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Function_Call
+        or else NT (N).Nkind = N_Procedure_Call_Statement);
+      Set_Node1 (N, Val); -- semantic field, no parent set
+   end Set_Controlling_Argument;
+
+   procedure Set_Conversion_OK
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Type_Conversion);
+      Set_Flag14 (N, Val);
+   end Set_Conversion_OK;
+
+   procedure Set_Corresponding_Body
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Generic_Package_Declaration
+        or else NT (N).Nkind = N_Generic_Subprogram_Declaration
+        or else NT (N).Nkind = N_Package_Body_Stub
+        or else NT (N).Nkind = N_Package_Declaration
+        or else NT (N).Nkind = N_Protected_Body_Stub
+        or else NT (N).Nkind = N_Protected_Type_Declaration
+        or else NT (N).Nkind = N_Subprogram_Body_Stub
+        or else NT (N).Nkind = N_Subprogram_Declaration
+        or else NT (N).Nkind = N_Task_Body_Stub
+        or else NT (N).Nkind = N_Task_Type_Declaration);
+      Set_Node5 (N, Val); -- semantic field, no parent set
+   end Set_Corresponding_Body;
+
+   procedure Set_Corresponding_Generic_Association
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Object_Declaration
+        or else NT (N).Nkind = N_Object_Renaming_Declaration);
+      Set_Node5 (N, Val); -- semantic field, no parent set
+   end Set_Corresponding_Generic_Association;
+   procedure Set_Corresponding_Integer_Value
+      (N : Node_Id; Val : Uint) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Real_Literal);
+      Set_Uint4 (N, Val); -- semantic field, no parent set
+   end Set_Corresponding_Integer_Value;
+
+   procedure Set_Corresponding_Spec
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Package_Body
+        or else NT (N).Nkind = N_Protected_Body
+        or else NT (N).Nkind = N_Subprogram_Body
+        or else NT (N).Nkind = N_Subprogram_Renaming_Declaration
+        or else NT (N).Nkind = N_Task_Body
+        or else NT (N).Nkind = N_With_Clause);
+      Set_Node5 (N, Val); -- semantic field, no parent set
+   end Set_Corresponding_Spec;
+
+   procedure Set_Corresponding_Stub
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Subunit);
+      Set_Node3 (N, Val);
+   end Set_Corresponding_Stub;
+
+   procedure Set_Dcheck_Function
+      (N : Node_Id; Val : Entity_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Variant);
+      Set_Node5 (N, Val); -- semantic field, no parent set
+   end Set_Dcheck_Function;
+
+   procedure Set_Debug_Statement
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Pragma);
+      Set_Node3_With_Parent (N, Val);
+   end Set_Debug_Statement;
+
+   procedure Set_Declarations
+      (N : Node_Id; Val : List_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Accept_Statement
+        or else NT (N).Nkind = N_Block_Statement
+        or else NT (N).Nkind = N_Compilation_Unit_Aux
+        or else NT (N).Nkind = N_Entry_Body
+        or else NT (N).Nkind = N_Package_Body
+        or else NT (N).Nkind = N_Protected_Body
+        or else NT (N).Nkind = N_Subprogram_Body
+        or else NT (N).Nkind = N_Task_Body);
+      Set_List2_With_Parent (N, Val);
+   end Set_Declarations;
+
+   procedure Set_Default_Expression
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Parameter_Specification);
+      Set_Node5 (N, Val); -- semantic field, no parent set
+   end Set_Default_Expression;
+
+   procedure Set_Default_Name
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Formal_Subprogram_Declaration);
+      Set_Node2_With_Parent (N, Val);
+   end Set_Default_Name;
+
+   procedure Set_Defining_Identifier
+      (N : Node_Id; Val : Entity_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Component_Declaration
+        or else NT (N).Nkind = N_Defining_Program_Unit_Name
+        or else NT (N).Nkind = N_Discriminant_Specification
+        or else NT (N).Nkind = N_Entry_Body
+        or else NT (N).Nkind = N_Entry_Declaration
+        or else NT (N).Nkind = N_Entry_Index_Specification
+        or else NT (N).Nkind = N_Exception_Declaration
+        or else NT (N).Nkind = N_Exception_Renaming_Declaration
+        or else NT (N).Nkind = N_Formal_Object_Declaration
+        or else NT (N).Nkind = N_Formal_Package_Declaration
+        or else NT (N).Nkind = N_Formal_Type_Declaration
+        or else NT (N).Nkind = N_Full_Type_Declaration
+        or else NT (N).Nkind = N_Implicit_Label_Declaration
+        or else NT (N).Nkind = N_Incomplete_Type_Declaration
+        or else NT (N).Nkind = N_Loop_Parameter_Specification
+        or else NT (N).Nkind = N_Number_Declaration
+        or else NT (N).Nkind = N_Object_Declaration
+        or else NT (N).Nkind = N_Object_Renaming_Declaration
+        or else NT (N).Nkind = N_Package_Body_Stub
+        or else NT (N).Nkind = N_Parameter_Specification
+        or else NT (N).Nkind = N_Private_Extension_Declaration
+        or else NT (N).Nkind = N_Private_Type_Declaration
+        or else NT (N).Nkind = N_Protected_Body
+        or else NT (N).Nkind = N_Protected_Body_Stub
+        or else NT (N).Nkind = N_Protected_Type_Declaration
+        or else NT (N).Nkind = N_Single_Protected_Declaration
+        or else NT (N).Nkind = N_Single_Task_Declaration
+        or else NT (N).Nkind = N_Subtype_Declaration
+        or else NT (N).Nkind = N_Task_Body
+        or else NT (N).Nkind = N_Task_Body_Stub
+        or else NT (N).Nkind = N_Task_Type_Declaration);
+      Set_Node1_With_Parent (N, Val);
+   end Set_Defining_Identifier;
+
+   procedure Set_Defining_Unit_Name
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Function_Instantiation
+        or else NT (N).Nkind = N_Function_Specification
+        or else NT (N).Nkind = N_Generic_Function_Renaming_Declaration
+        or else NT (N).Nkind = N_Generic_Package_Renaming_Declaration
+        or else NT (N).Nkind = N_Generic_Procedure_Renaming_Declaration
+        or else NT (N).Nkind = N_Package_Body
+        or else NT (N).Nkind = N_Package_Instantiation
+        or else NT (N).Nkind = N_Package_Renaming_Declaration
+        or else NT (N).Nkind = N_Package_Specification
+        or else NT (N).Nkind = N_Procedure_Instantiation
+        or else NT (N).Nkind = N_Procedure_Specification);
+      Set_Node1_With_Parent (N, Val);
+   end Set_Defining_Unit_Name;
+
+   procedure Set_Delay_Alternative
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Timed_Entry_Call);
+      Set_Node4_With_Parent (N, Val);
+   end Set_Delay_Alternative;
+
+   procedure Set_Delay_Finalize_Attach
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Object_Declaration);
+      Set_Flag14 (N, Val);
+   end Set_Delay_Finalize_Attach;
+
+   procedure Set_Delay_Statement
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Delay_Alternative);
+      Set_Node2_With_Parent (N, Val);
+   end Set_Delay_Statement;
+
+   procedure Set_Delta_Expression
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Decimal_Fixed_Point_Definition
+        or else NT (N).Nkind = N_Delta_Constraint
+        or else NT (N).Nkind = N_Ordinary_Fixed_Point_Definition);
+      Set_Node3_With_Parent (N, Val);
+   end Set_Delta_Expression;
+
+   procedure Set_Digits_Expression
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Decimal_Fixed_Point_Definition
+        or else NT (N).Nkind = N_Digits_Constraint
+        or else NT (N).Nkind = N_Floating_Point_Definition);
+      Set_Node2_With_Parent (N, Val);
+   end Set_Digits_Expression;
+
+   procedure Set_Discr_Check_Funcs_Built
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Full_Type_Declaration);
+      Set_Flag11 (N, Val);
+   end Set_Discr_Check_Funcs_Built;
+
+   procedure Set_Discrete_Choices
+      (N : Node_Id; Val : List_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Case_Statement_Alternative
+        or else NT (N).Nkind = N_Variant);
+      Set_List4_With_Parent (N, Val);
+   end Set_Discrete_Choices;
+
+   procedure Set_Discrete_Range
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Slice);
+      Set_Node4_With_Parent (N, Val);
+   end Set_Discrete_Range;
+
+   procedure Set_Discrete_Subtype_Definition
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Entry_Declaration
+        or else NT (N).Nkind = N_Entry_Index_Specification
+        or else NT (N).Nkind = N_Loop_Parameter_Specification);
+      Set_Node4_With_Parent (N, Val);
+   end Set_Discrete_Subtype_Definition;
+
+   procedure Set_Discrete_Subtype_Definitions
+      (N : Node_Id; Val : List_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Constrained_Array_Definition);
+      Set_List2_With_Parent (N, Val);
+   end Set_Discrete_Subtype_Definitions;
+
+   procedure Set_Discriminant_Specifications
+      (N : Node_Id; Val : List_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Formal_Type_Declaration
+        or else NT (N).Nkind = N_Full_Type_Declaration
+        or else NT (N).Nkind = N_Incomplete_Type_Declaration
+        or else NT (N).Nkind = N_Private_Extension_Declaration
+        or else NT (N).Nkind = N_Private_Type_Declaration
+        or else NT (N).Nkind = N_Protected_Type_Declaration
+        or else NT (N).Nkind = N_Task_Type_Declaration);
+      Set_List4_With_Parent (N, Val);
+   end Set_Discriminant_Specifications;
+
+   procedure Set_Discriminant_Type
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Discriminant_Specification);
+      Set_Node5_With_Parent (N, Val);
+   end Set_Discriminant_Type;
+
+   procedure Set_Do_Access_Check
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Attribute_Reference
+        or else NT (N).Nkind = N_Explicit_Dereference
+        or else NT (N).Nkind = N_Indexed_Component
+        or else NT (N).Nkind = N_Selected_Component
+        or else NT (N).Nkind = N_Slice);
+      Set_Flag11 (N, Val);
+   end Set_Do_Access_Check;
+
+   procedure Set_Do_Accessibility_Check
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Parameter_Specification);
+      Set_Flag13 (N, Val);
+   end Set_Do_Accessibility_Check;
+
+   procedure Set_Do_Discriminant_Check
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Selected_Component);
+      Set_Flag13 (N, Val);
+   end Set_Do_Discriminant_Check;
+
+   procedure Set_Do_Division_Check
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Op_Divide
+        or else NT (N).Nkind = N_Op_Mod
+        or else NT (N).Nkind = N_Op_Rem);
+      Set_Flag13 (N, Val);
+   end Set_Do_Division_Check;
+
+   procedure Set_Do_Length_Check
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Assignment_Statement
+        or else NT (N).Nkind = N_Op_And
+        or else NT (N).Nkind = N_Op_Or
+        or else NT (N).Nkind = N_Op_Xor
+        or else NT (N).Nkind = N_Type_Conversion);
+      Set_Flag4 (N, Val);
+   end Set_Do_Length_Check;
+
+   procedure Set_Do_Overflow_Check
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+          or else NT (N).Nkind in N_Op
+        or else NT (N).Nkind = N_Attribute_Reference
+        or else NT (N).Nkind = N_Type_Conversion);
+      Set_Flag17 (N, Val);
+   end Set_Do_Overflow_Check;
+
+   procedure Set_Do_Range_Check
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+          or else NT (N).Nkind in N_Subexpr);
+      Set_Flag9 (N, Val);
+   end Set_Do_Range_Check;
+
+   procedure Set_Do_Storage_Check
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Allocator
+        or else NT (N).Nkind = N_Subprogram_Body);
+      Set_Flag17 (N, Val);
+   end Set_Do_Storage_Check;
+
+   procedure Set_Do_Tag_Check
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Assignment_Statement
+        or else NT (N).Nkind = N_Function_Call
+        or else NT (N).Nkind = N_Procedure_Call_Statement
+        or else NT (N).Nkind = N_Return_Statement
+        or else NT (N).Nkind = N_Type_Conversion);
+      Set_Flag13 (N, Val);
+   end Set_Do_Tag_Check;
+
+   procedure Set_Elaborate_All_Present
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_With_Clause);
+      Set_Flag15 (N, Val);
+   end Set_Elaborate_All_Present;
+
+   procedure Set_Elaborate_Present
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_With_Clause);
+      Set_Flag4 (N, Val);
+   end Set_Elaborate_Present;
+
+   procedure Set_Elaboration_Boolean
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Function_Specification
+        or else NT (N).Nkind = N_Procedure_Specification);
+      Set_Node2 (N, Val);
+   end Set_Elaboration_Boolean;
+
+   procedure Set_Else_Actions
+      (N : Node_Id; Val : List_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Conditional_Expression);
+      Set_List3 (N, Val); -- semantic field, no parent set
+   end Set_Else_Actions;
+
+   procedure Set_Else_Statements
+      (N : Node_Id; Val : List_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Conditional_Entry_Call
+        or else NT (N).Nkind = N_If_Statement
+        or else NT (N).Nkind = N_Selective_Accept);
+      Set_List4_With_Parent (N, Val);
+   end Set_Else_Statements;
+
+   procedure Set_Elsif_Parts
+      (N : Node_Id; Val : List_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_If_Statement);
+      Set_List3_With_Parent (N, Val);
+   end Set_Elsif_Parts;
+
+   procedure Set_Enclosing_Variant
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Variant);
+      Set_Node2 (N, Val); -- semantic field, no parent set
+   end Set_Enclosing_Variant;
+
+   procedure Set_End_Label
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Handled_Sequence_Of_Statements
+        or else NT (N).Nkind = N_Loop_Statement
+        or else NT (N).Nkind = N_Package_Specification
+        or else NT (N).Nkind = N_Protected_Body
+        or else NT (N).Nkind = N_Protected_Definition
+        or else NT (N).Nkind = N_Record_Definition
+        or else NT (N).Nkind = N_Task_Definition);
+      Set_Node4_With_Parent (N, Val);
+   end Set_End_Label;
+
+   procedure Set_End_Span
+      (N : Node_Id; Val : Uint) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Case_Statement
+        or else NT (N).Nkind = N_If_Statement);
+      Set_Uint5 (N, Val);
+   end Set_End_Span;
+
+   procedure Set_Entity
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+          or else NT (N).Nkind in N_Has_Entity
+        or else NT (N).Nkind = N_Freeze_Entity);
+      Set_Node4 (N, Val); -- semantic field, no parent set
+   end Set_Entity;
+
+   procedure Set_Entry_Body_Formal_Part
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Entry_Body);
+      Set_Node5_With_Parent (N, Val);
+   end Set_Entry_Body_Formal_Part;
+
+   procedure Set_Entry_Call_Alternative
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Conditional_Entry_Call
+        or else NT (N).Nkind = N_Timed_Entry_Call);
+      Set_Node1_With_Parent (N, Val);
+   end Set_Entry_Call_Alternative;
+
+   procedure Set_Entry_Call_Statement
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Entry_Call_Alternative);
+      Set_Node1_With_Parent (N, Val);
+   end Set_Entry_Call_Statement;
+
+   procedure Set_Entry_Direct_Name
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Accept_Statement);
+      Set_Node1_With_Parent (N, Val);
+   end Set_Entry_Direct_Name;
+
+   procedure Set_Entry_Index
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Accept_Statement);
+      Set_Node5_With_Parent (N, Val);
+   end Set_Entry_Index;
+
+   procedure Set_Entry_Index_Specification
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Entry_Body_Formal_Part);
+      Set_Node4_With_Parent (N, Val);
+   end Set_Entry_Index_Specification;
+
+   procedure Set_Etype
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+          or else NT (N).Nkind in N_Has_Etype);
+      Set_Node5 (N, Val); -- semantic field, no parent set
+   end Set_Etype;
+
+   procedure Set_Exception_Choices
+      (N : Node_Id; Val : List_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Exception_Handler);
+      Set_List4_With_Parent (N, Val);
+   end Set_Exception_Choices;
+
+   procedure Set_Exception_Handlers
+      (N : Node_Id; Val : List_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Handled_Sequence_Of_Statements);
+      Set_List5_With_Parent (N, Val);
+   end Set_Exception_Handlers;
+
+   procedure Set_Exception_Junk
+     (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Goto_Statement
+        or else NT (N).Nkind = N_Label
+        or else NT (N).Nkind = N_Object_Declaration
+        or else NT (N).Nkind = N_Subtype_Declaration);
+      Set_Flag11 (N, Val);
+   end Set_Exception_Junk;
+
+   procedure Set_Expansion_Delayed
+     (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Aggregate
+        or else NT (N).Nkind = N_Extension_Aggregate);
+      Set_Flag11 (N, Val);
+   end Set_Expansion_Delayed;
+
+   procedure Set_Explicit_Actual_Parameter
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Parameter_Association);
+      Set_Node3_With_Parent (N, Val);
+   end Set_Explicit_Actual_Parameter;
+
+   procedure Set_Explicit_Generic_Actual_Parameter
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Generic_Association);
+      Set_Node1_With_Parent (N, Val);
+   end Set_Explicit_Generic_Actual_Parameter;
+
+   procedure Set_Expression
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Allocator
+        or else NT (N).Nkind = N_Assignment_Statement
+        or else NT (N).Nkind = N_At_Clause
+        or else NT (N).Nkind = N_Attribute_Definition_Clause
+        or else NT (N).Nkind = N_Case_Statement
+        or else NT (N).Nkind = N_Code_Statement
+        or else NT (N).Nkind = N_Component_Association
+        or else NT (N).Nkind = N_Component_Declaration
+        or else NT (N).Nkind = N_Delay_Relative_Statement
+        or else NT (N).Nkind = N_Delay_Until_Statement
+        or else NT (N).Nkind = N_Discriminant_Association
+        or else NT (N).Nkind = N_Discriminant_Specification
+        or else NT (N).Nkind = N_Exception_Declaration
+        or else NT (N).Nkind = N_Formal_Object_Declaration
+        or else NT (N).Nkind = N_Free_Statement
+        or else NT (N).Nkind = N_Mod_Clause
+        or else NT (N).Nkind = N_Modular_Type_Definition
+        or else NT (N).Nkind = N_Number_Declaration
+        or else NT (N).Nkind = N_Object_Declaration
+        or else NT (N).Nkind = N_Parameter_Specification
+        or else NT (N).Nkind = N_Pragma_Argument_Association
+        or else NT (N).Nkind = N_Qualified_Expression
+        or else NT (N).Nkind = N_Return_Statement
+        or else NT (N).Nkind = N_Type_Conversion
+        or else NT (N).Nkind = N_Unchecked_Expression
+        or else NT (N).Nkind = N_Unchecked_Type_Conversion);
+      Set_Node3_With_Parent (N, Val);
+   end Set_Expression;
+
+   procedure Set_Expressions
+      (N : Node_Id; Val : List_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Aggregate
+        or else NT (N).Nkind = N_Attribute_Reference
+        or else NT (N).Nkind = N_Conditional_Expression
+        or else NT (N).Nkind = N_Extension_Aggregate
+        or else NT (N).Nkind = N_Indexed_Component);
+      Set_List1_With_Parent (N, Val);
+   end Set_Expressions;
+
+   procedure Set_First_Bit
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Component_Clause);
+      Set_Node3_With_Parent (N, Val);
+   end Set_First_Bit;
+
+   procedure Set_First_Inlined_Subprogram
+      (N : Node_Id; Val : Entity_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Compilation_Unit);
+      Set_Node3 (N, Val);  -- semantic field, no parent set
+   end Set_First_Inlined_Subprogram;
+
+   procedure Set_First_Name
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_With_Clause);
+      Set_Flag5 (N, Val);
+   end Set_First_Name;
+
+   procedure Set_First_Named_Actual
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Entry_Call_Statement
+        or else NT (N).Nkind = N_Function_Call
+        or else NT (N).Nkind = N_Procedure_Call_Statement);
+      Set_Node4 (N, Val); -- semantic field, no parent set
+   end Set_First_Named_Actual;
+
+   procedure Set_First_Real_Statement
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Handled_Sequence_Of_Statements);
+      Set_Node2 (N, Val); -- semantic field, no parent set
+   end Set_First_Real_Statement;
+
+   procedure Set_First_Subtype_Link
+      (N : Node_Id; Val : Entity_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Freeze_Entity);
+      Set_Node5 (N, Val); -- semantic field, no parent set
+   end Set_First_Subtype_Link;
+
+   procedure Set_Float_Truncate
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Type_Conversion);
+      Set_Flag11 (N, Val);
+   end Set_Float_Truncate;
+
+   procedure Set_Formal_Type_Definition
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Formal_Type_Declaration);
+      Set_Node3_With_Parent (N, Val);
+   end Set_Formal_Type_Definition;
+
+   procedure Set_Forwards_OK
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Assignment_Statement);
+      Set_Flag5 (N, Val);
+   end Set_Forwards_OK;
+
+   procedure Set_From_At_Mod
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Attribute_Definition_Clause);
+      Set_Flag4 (N, Val);
+   end Set_From_At_Mod;
+
+   procedure Set_Generic_Associations
+      (N : Node_Id; Val : List_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Formal_Package_Declaration
+        or else NT (N).Nkind = N_Function_Instantiation
+        or else NT (N).Nkind = N_Package_Instantiation
+        or else NT (N).Nkind = N_Procedure_Instantiation);
+      Set_List3_With_Parent (N, Val);
+   end Set_Generic_Associations;
+
+   procedure Set_Generic_Formal_Declarations
+      (N : Node_Id; Val : List_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Generic_Package_Declaration
+        or else NT (N).Nkind = N_Generic_Subprogram_Declaration);
+      Set_List2_With_Parent (N, Val);
+   end Set_Generic_Formal_Declarations;
+
+   procedure Set_Generic_Parent
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Function_Specification
+        or else NT (N).Nkind = N_Package_Specification
+        or else NT (N).Nkind = N_Procedure_Specification);
+      Set_Node5 (N, Val);
+   end Set_Generic_Parent;
+
+   procedure Set_Generic_Parent_Type
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Subtype_Declaration);
+      Set_Node4 (N, Val);
+   end Set_Generic_Parent_Type;
+
+   procedure Set_Handled_Statement_Sequence
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Accept_Statement
+        or else NT (N).Nkind = N_Block_Statement
+        or else NT (N).Nkind = N_Entry_Body
+        or else NT (N).Nkind = N_Package_Body
+        or else NT (N).Nkind = N_Subprogram_Body
+        or else NT (N).Nkind = N_Task_Body);
+      Set_Node4_With_Parent (N, Val);
+   end Set_Handled_Statement_Sequence;
+
+   procedure Set_Handler_List_Entry
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Object_Declaration);
+      Set_Node2 (N, Val);
+   end Set_Handler_List_Entry;
+
+   procedure Set_Has_Created_Identifier
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Block_Statement
+        or else NT (N).Nkind = N_Loop_Statement);
+      Set_Flag15 (N, Val);
+   end Set_Has_Created_Identifier;
+
+   procedure Set_Has_Dynamic_Length_Check
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      Set_Flag10 (N, Val);
+   end Set_Has_Dynamic_Length_Check;
+
+   procedure Set_Has_Dynamic_Range_Check
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      Set_Flag12 (N, Val);
+   end Set_Has_Dynamic_Range_Check;
+
+   procedure Set_Has_No_Elaboration_Code
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Compilation_Unit);
+      Set_Flag17 (N, Val);
+   end Set_Has_No_Elaboration_Code;
+
+   procedure Set_Has_Priority_Pragma
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Protected_Definition
+        or else NT (N).Nkind = N_Subprogram_Body
+        or else NT (N).Nkind = N_Task_Definition);
+      Set_Flag6 (N, Val);
+   end Set_Has_Priority_Pragma;
+
+   procedure Set_Has_Private_View
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+         or else NT (N).Nkind in N_Op
+       or else NT (N).Nkind = N_Character_Literal
+       or else NT (N).Nkind = N_Expanded_Name
+       or else NT (N).Nkind = N_Identifier
+       or else NT (N).Nkind = N_Operator_Symbol);
+      Set_Flag11 (N, Val);
+   end Set_Has_Private_View;
+
+   procedure Set_Has_Storage_Size_Pragma
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Task_Definition);
+      Set_Flag5 (N, Val);
+   end Set_Has_Storage_Size_Pragma;
+
+   procedure Set_Has_Task_Info_Pragma
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Task_Definition);
+      Set_Flag7 (N, Val);
+   end Set_Has_Task_Info_Pragma;
+
+   procedure Set_Has_Task_Name_Pragma
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Task_Definition);
+      Set_Flag8 (N, Val);
+   end Set_Has_Task_Name_Pragma;
+
+   procedure Set_Has_Wide_Character
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_String_Literal);
+      Set_Flag11 (N, Val);
+   end Set_Has_Wide_Character;
+
+   procedure Set_Hidden_By_Use_Clause
+     (N : Node_Id; Val : Elist_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Use_Package_Clause
+        or else NT (N).Nkind = N_Use_Type_Clause);
+      Set_Elist4 (N, Val);
+   end Set_Hidden_By_Use_Clause;
+
+   procedure Set_High_Bound
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Range
+        or else NT (N).Nkind = N_Real_Range_Specification
+        or else NT (N).Nkind = N_Signed_Integer_Type_Definition);
+      Set_Node2_With_Parent (N, Val);
+   end Set_High_Bound;
+
+   procedure Set_Identifier
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_At_Clause
+        or else NT (N).Nkind = N_Block_Statement
+        or else NT (N).Nkind = N_Designator
+        or else NT (N).Nkind = N_Enumeration_Representation_Clause
+        or else NT (N).Nkind = N_Label
+        or else NT (N).Nkind = N_Loop_Statement
+        or else NT (N).Nkind = N_Record_Representation_Clause
+        or else NT (N).Nkind = N_Subprogram_Info);
+      Set_Node1_With_Parent (N, Val);
+   end Set_Identifier;
+
+   procedure Set_Implicit_With
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_With_Clause);
+      Set_Flag17 (N, Val);
+   end Set_Implicit_With;
+
+   procedure Set_In_Present
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Formal_Object_Declaration
+        or else NT (N).Nkind = N_Parameter_Specification);
+      Set_Flag15 (N, Val);
+   end Set_In_Present;
+
+   procedure Set_Includes_Infinities
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Range);
+      Set_Flag11 (N, Val);
+   end Set_Includes_Infinities;
+
+   procedure Set_Instance_Spec
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Formal_Package_Declaration
+        or else NT (N).Nkind = N_Function_Instantiation
+        or else NT (N).Nkind = N_Package_Instantiation
+        or else NT (N).Nkind = N_Procedure_Instantiation);
+      Set_Node5 (N, Val); -- semantic field, no Parent set
+   end Set_Instance_Spec;
+
+   procedure Set_Intval
+      (N : Node_Id; Val : Uint) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Integer_Literal);
+      Set_Uint3 (N, Val);
+   end Set_Intval;
+
+   procedure Set_Is_Asynchronous_Call_Block
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Block_Statement);
+      Set_Flag7 (N, Val);
+   end Set_Is_Asynchronous_Call_Block;
+
+   procedure Set_Is_Component_Left_Opnd
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Op_Concat);
+      Set_Flag13 (N, Val);
+   end Set_Is_Component_Left_Opnd;
+
+   procedure Set_Is_Component_Right_Opnd
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Op_Concat);
+      Set_Flag14 (N, Val);
+   end Set_Is_Component_Right_Opnd;
+
+   procedure Set_Is_Controlling_Actual
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+          or else NT (N).Nkind in N_Subexpr);
+      Set_Flag16 (N, Val);
+   end Set_Is_Controlling_Actual;
+
+   procedure Set_Is_Machine_Number
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Real_Literal);
+      Set_Flag11 (N, Val);
+   end Set_Is_Machine_Number;
+
+   procedure Set_Is_Overloaded
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+          or else NT (N).Nkind in N_Subexpr);
+      Set_Flag5 (N, Val);
+   end Set_Is_Overloaded;
+
+   procedure Set_Is_Power_Of_2_For_Shift
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Op_Expon);
+      Set_Flag13 (N, Val);
+   end Set_Is_Power_Of_2_For_Shift;
+
+   procedure Set_Is_Protected_Subprogram_Body
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Subprogram_Body);
+      Set_Flag7 (N, Val);
+   end Set_Is_Protected_Subprogram_Body;
+
+   procedure Set_Is_Static_Expression
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+          or else NT (N).Nkind in N_Subexpr);
+      Set_Flag6 (N, Val);
+   end Set_Is_Static_Expression;
+
+   procedure Set_Is_Subprogram_Descriptor
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Object_Declaration);
+      Set_Flag16 (N, Val);
+   end Set_Is_Subprogram_Descriptor;
+
+   procedure Set_Is_Task_Allocation_Block
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Block_Statement);
+      Set_Flag6 (N, Val);
+   end Set_Is_Task_Allocation_Block;
+
+   procedure Set_Is_Task_Master
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Block_Statement
+        or else NT (N).Nkind = N_Subprogram_Body
+        or else NT (N).Nkind = N_Task_Body);
+      Set_Flag5 (N, Val);
+   end Set_Is_Task_Master;
+
+   procedure Set_Iteration_Scheme
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Loop_Statement);
+      Set_Node2_With_Parent (N, Val);
+   end Set_Iteration_Scheme;
+
+   procedure Set_Itype
+      (N : Node_Id; Val : Entity_Id) is
+   begin
+      pragma Assert (False
+      or else NT (N).Nkind = N_Itype_Reference);
+      Set_Node1 (N, Val); -- no parent, semantic field
+   end Set_Itype;
+
+   procedure Set_Kill_Range_Check
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Unchecked_Type_Conversion);
+      Set_Flag11 (N, Val);
+   end Set_Kill_Range_Check;
+
+   procedure Set_Label_Construct
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Implicit_Label_Declaration);
+      Set_Node2 (N, Val); -- semantic field, no parent set
+   end Set_Label_Construct;
+
+   procedure Set_Last_Bit
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Component_Clause);
+      Set_Node4_With_Parent (N, Val);
+   end Set_Last_Bit;
+
+   procedure Set_Last_Name
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_With_Clause);
+      Set_Flag6 (N, Val);
+   end Set_Last_Name;
+
+   procedure Set_Left_Opnd
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_And_Then
+        or else NT (N).Nkind = N_In
+        or else NT (N).Nkind = N_Not_In
+        or else NT (N).Nkind = N_Or_Else
+          or else NT (N).Nkind in N_Binary_Op);
+      Set_Node2_With_Parent (N, Val);
+   end Set_Left_Opnd;
+
+   procedure Set_Library_Unit
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Compilation_Unit
+        or else NT (N).Nkind = N_Package_Body_Stub
+        or else NT (N).Nkind = N_Protected_Body_Stub
+        or else NT (N).Nkind = N_Subprogram_Body_Stub
+        or else NT (N).Nkind = N_Task_Body_Stub
+        or else NT (N).Nkind = N_With_Clause);
+      Set_Node4 (N, Val); -- semantic field, no parent set
+   end Set_Library_Unit;
+
+   procedure Set_Limited_Present
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Formal_Private_Type_Definition
+        or else NT (N).Nkind = N_Private_Type_Declaration
+        or else NT (N).Nkind = N_Record_Definition);
+      Set_Flag17 (N, Val);
+   end Set_Limited_Present;
+
+   procedure Set_Literals
+      (N : Node_Id; Val : List_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Enumeration_Type_Definition);
+      Set_List1_With_Parent (N, Val);
+   end Set_Literals;
+
+   procedure Set_Loop_Actions
+      (N : Node_Id; Val : List_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Component_Association);
+      Set_List2 (N, Val); -- semantic field, no parent set
+   end Set_Loop_Actions;
+
+   procedure Set_Loop_Parameter_Specification
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Iteration_Scheme);
+      Set_Node4_With_Parent (N, Val);
+   end Set_Loop_Parameter_Specification;
+
+   procedure Set_Low_Bound
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Range
+        or else NT (N).Nkind = N_Real_Range_Specification
+        or else NT (N).Nkind = N_Signed_Integer_Type_Definition);
+      Set_Node1_With_Parent (N, Val);
+   end Set_Low_Bound;
+
+   procedure Set_Mod_Clause
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Record_Representation_Clause);
+      Set_Node2_With_Parent (N, Val);
+   end Set_Mod_Clause;
+
+   procedure Set_More_Ids
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Component_Declaration
+        or else NT (N).Nkind = N_Discriminant_Specification
+        or else NT (N).Nkind = N_Exception_Declaration
+        or else NT (N).Nkind = N_Formal_Object_Declaration
+        or else NT (N).Nkind = N_Number_Declaration
+        or else NT (N).Nkind = N_Object_Declaration
+        or else NT (N).Nkind = N_Parameter_Specification);
+      Set_Flag5 (N, Val);
+   end Set_More_Ids;
+
+   procedure Set_Must_Not_Freeze
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Subtype_Indication
+          or else NT (N).Nkind in N_Subexpr);
+      Set_Flag8 (N, Val);
+   end Set_Must_Not_Freeze;
+
+   procedure Set_Name
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Assignment_Statement
+        or else NT (N).Nkind = N_Attribute_Definition_Clause
+        or else NT (N).Nkind = N_Defining_Program_Unit_Name
+        or else NT (N).Nkind = N_Designator
+        or else NT (N).Nkind = N_Entry_Call_Statement
+        or else NT (N).Nkind = N_Exception_Renaming_Declaration
+        or else NT (N).Nkind = N_Exit_Statement
+        or else NT (N).Nkind = N_Formal_Package_Declaration
+        or else NT (N).Nkind = N_Function_Call
+        or else NT (N).Nkind = N_Function_Instantiation
+        or else NT (N).Nkind = N_Generic_Function_Renaming_Declaration
+        or else NT (N).Nkind = N_Generic_Package_Renaming_Declaration
+        or else NT (N).Nkind = N_Generic_Procedure_Renaming_Declaration
+        or else NT (N).Nkind = N_Goto_Statement
+        or else NT (N).Nkind = N_Object_Renaming_Declaration
+        or else NT (N).Nkind = N_Package_Instantiation
+        or else NT (N).Nkind = N_Package_Renaming_Declaration
+        or else NT (N).Nkind = N_Procedure_Call_Statement
+        or else NT (N).Nkind = N_Procedure_Instantiation
+        or else NT (N).Nkind = N_Raise_Statement
+        or else NT (N).Nkind = N_Requeue_Statement
+        or else NT (N).Nkind = N_Subprogram_Renaming_Declaration
+        or else NT (N).Nkind = N_Subunit
+        or else NT (N).Nkind = N_Variant_Part
+        or else NT (N).Nkind = N_With_Clause
+        or else NT (N).Nkind = N_With_Type_Clause);
+      Set_Node2_With_Parent (N, Val);
+   end Set_Name;
+
+   procedure Set_Names
+      (N : Node_Id; Val : List_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Abort_Statement
+        or else NT (N).Nkind = N_Use_Package_Clause);
+      Set_List2_With_Parent (N, Val);
+   end Set_Names;
+
+   procedure Set_Next_Entity
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Defining_Character_Literal
+        or else NT (N).Nkind = N_Defining_Identifier
+        or else NT (N).Nkind = N_Defining_Operator_Symbol);
+      Set_Node2 (N, Val); -- semantic field, no parent set
+   end Set_Next_Entity;
+
+   procedure Set_Next_Named_Actual
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Parameter_Association);
+      Set_Node4 (N, Val); -- semantic field, no parent set
+   end Set_Next_Named_Actual;
+
+   procedure Set_Next_Rep_Item
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Attribute_Definition_Clause
+        or else NT (N).Nkind = N_Enumeration_Representation_Clause
+        or else NT (N).Nkind = N_Pragma
+        or else NT (N).Nkind = N_Record_Representation_Clause);
+      Set_Node4 (N, Val); -- semantic field, no parent set
+   end Set_Next_Rep_Item;
+
+   procedure Set_Next_Use_Clause
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Use_Package_Clause
+        or else NT (N).Nkind = N_Use_Type_Clause);
+      Set_Node3 (N, Val); -- semantic field, no parent set
+   end Set_Next_Use_Clause;
+
+   procedure Set_No_Ctrl_Actions
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Assignment_Statement);
+      Set_Flag7 (N, Val);
+   end Set_No_Ctrl_Actions;
+
+   procedure Set_No_Entities_Ref_In_Spec
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_With_Clause);
+      Set_Flag8 (N, Val);
+   end Set_No_Entities_Ref_In_Spec;
+
+   procedure Set_No_Initialization
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Allocator
+        or else NT (N).Nkind = N_Object_Declaration);
+      Set_Flag13 (N, Val);
+   end Set_No_Initialization;
+
+   procedure Set_Null_Present
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Component_List
+        or else NT (N).Nkind = N_Record_Definition);
+      Set_Flag13 (N, Val);
+   end Set_Null_Present;
+
+   procedure Set_Null_Record_Present
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Aggregate
+        or else NT (N).Nkind = N_Extension_Aggregate);
+      Set_Flag17 (N, Val);
+   end Set_Null_Record_Present;
+
+   procedure Set_Object_Definition
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Object_Declaration);
+      Set_Node4_With_Parent (N, Val);
+   end Set_Object_Definition;
+
+   procedure Set_OK_For_Stream
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Attribute_Reference);
+      Set_Flag4 (N, Val);
+   end Set_OK_For_Stream;
+
+   procedure Set_Original_Discriminant
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Identifier);
+      Set_Node2 (N, Val); -- semantic field, no parent set
+   end Set_Original_Discriminant;
+
+   procedure Set_Others_Discrete_Choices
+      (N : Node_Id; Val : List_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Others_Choice);
+      Set_List1_With_Parent (N, Val);
+   end Set_Others_Discrete_Choices;
+
+   procedure Set_Out_Present
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Formal_Object_Declaration
+        or else NT (N).Nkind = N_Parameter_Specification);
+      Set_Flag17 (N, Val);
+   end Set_Out_Present;
+
+   procedure Set_Parameter_Associations
+      (N : Node_Id; Val : List_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Entry_Call_Statement
+        or else NT (N).Nkind = N_Function_Call
+        or else NT (N).Nkind = N_Procedure_Call_Statement);
+      Set_List3_With_Parent (N, Val);
+   end Set_Parameter_Associations;
+
+   procedure Set_Parameter_List_Truncated
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Function_Call
+        or else NT (N).Nkind = N_Procedure_Call_Statement);
+      Set_Flag17 (N, Val);
+   end Set_Parameter_List_Truncated;
+
+   procedure Set_Parameter_Specifications
+      (N : Node_Id; Val : List_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Accept_Statement
+        or else NT (N).Nkind = N_Access_Function_Definition
+        or else NT (N).Nkind = N_Access_Procedure_Definition
+        or else NT (N).Nkind = N_Entry_Body_Formal_Part
+        or else NT (N).Nkind = N_Entry_Declaration
+        or else NT (N).Nkind = N_Function_Specification
+        or else NT (N).Nkind = N_Procedure_Specification);
+      Set_List3_With_Parent (N, Val);
+   end Set_Parameter_Specifications;
+
+   procedure Set_Parameter_Type
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Parameter_Specification);
+      Set_Node2_With_Parent (N, Val);
+   end Set_Parameter_Type;
+
+   procedure Set_Parent_Spec
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Function_Instantiation
+        or else NT (N).Nkind = N_Generic_Function_Renaming_Declaration
+        or else NT (N).Nkind = N_Generic_Package_Declaration
+        or else NT (N).Nkind = N_Generic_Package_Renaming_Declaration
+        or else NT (N).Nkind = N_Generic_Procedure_Renaming_Declaration
+        or else NT (N).Nkind = N_Generic_Subprogram_Declaration
+        or else NT (N).Nkind = N_Package_Declaration
+        or else NT (N).Nkind = N_Package_Instantiation
+        or else NT (N).Nkind = N_Package_Renaming_Declaration
+        or else NT (N).Nkind = N_Procedure_Instantiation
+        or else NT (N).Nkind = N_Subprogram_Declaration
+        or else NT (N).Nkind = N_Subprogram_Renaming_Declaration);
+      Set_Node4 (N, Val); -- semantic field, no parent set
+   end Set_Parent_Spec;
+
+   procedure Set_Position
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Component_Clause);
+      Set_Node2_With_Parent (N, Val);
+   end Set_Position;
+
+   procedure Set_Pragma_Argument_Associations
+      (N : Node_Id; Val : List_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Pragma);
+      Set_List2_With_Parent (N, Val);
+   end Set_Pragma_Argument_Associations;
+
+   procedure Set_Pragmas_After
+      (N : Node_Id; Val : List_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Compilation_Unit_Aux
+        or else NT (N).Nkind = N_Terminate_Alternative);
+      Set_List5_With_Parent (N, Val);
+   end Set_Pragmas_After;
+
+   procedure Set_Pragmas_Before
+      (N : Node_Id; Val : List_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Accept_Alternative
+        or else NT (N).Nkind = N_Delay_Alternative
+        or else NT (N).Nkind = N_Entry_Call_Alternative
+        or else NT (N).Nkind = N_Mod_Clause
+        or else NT (N).Nkind = N_Terminate_Alternative
+        or else NT (N).Nkind = N_Triggering_Alternative);
+      Set_List4_With_Parent (N, Val);
+   end Set_Pragmas_Before;
+
+   procedure Set_Prefix
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Attribute_Reference
+        or else NT (N).Nkind = N_Expanded_Name
+        or else NT (N).Nkind = N_Explicit_Dereference
+        or else NT (N).Nkind = N_Indexed_Component
+        or else NT (N).Nkind = N_Reference
+        or else NT (N).Nkind = N_Selected_Component
+        or else NT (N).Nkind = N_Slice);
+      Set_Node3_With_Parent (N, Val);
+   end Set_Prefix;
+
+   procedure Set_Present_Expr
+      (N : Node_Id; Val : Uint) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Variant);
+      Set_Uint3 (N, Val);
+   end Set_Present_Expr;
+
+   procedure Set_Prev_Ids
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Component_Declaration
+        or else NT (N).Nkind = N_Discriminant_Specification
+        or else NT (N).Nkind = N_Exception_Declaration
+        or else NT (N).Nkind = N_Formal_Object_Declaration
+        or else NT (N).Nkind = N_Number_Declaration
+        or else NT (N).Nkind = N_Object_Declaration
+        or else NT (N).Nkind = N_Parameter_Specification);
+      Set_Flag6 (N, Val);
+   end Set_Prev_Ids;
+
+   procedure Set_Print_In_Hex
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Integer_Literal);
+      Set_Flag13 (N, Val);
+   end Set_Print_In_Hex;
+
+   procedure Set_Private_Declarations
+      (N : Node_Id; Val : List_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Package_Specification
+        or else NT (N).Nkind = N_Protected_Definition
+        or else NT (N).Nkind = N_Task_Definition);
+      Set_List3_With_Parent (N, Val);
+   end Set_Private_Declarations;
+
+   procedure Set_Private_Present
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Compilation_Unit
+        or else NT (N).Nkind = N_Formal_Derived_Type_Definition);
+      Set_Flag15 (N, Val);
+   end Set_Private_Present;
+
+   procedure Set_Procedure_To_Call
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Allocator
+        or else NT (N).Nkind = N_Free_Statement
+        or else NT (N).Nkind = N_Return_Statement);
+      Set_Node4 (N, Val); -- semantic field, no parent set
+   end Set_Procedure_To_Call;
+
+   procedure Set_Proper_Body
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Subunit);
+      Set_Node1_With_Parent (N, Val);
+   end Set_Proper_Body;
+
+   procedure Set_Protected_Definition
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Protected_Type_Declaration
+        or else NT (N).Nkind = N_Single_Protected_Declaration);
+      Set_Node3_With_Parent (N, Val);
+   end Set_Protected_Definition;
+
+   procedure Set_Protected_Present
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Access_Function_Definition
+        or else NT (N).Nkind = N_Access_Procedure_Definition);
+      Set_Flag15 (N, Val);
+   end Set_Protected_Present;
+
+   procedure Set_Raises_Constraint_Error
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+          or else NT (N).Nkind in N_Subexpr);
+      Set_Flag7 (N, Val);
+   end Set_Raises_Constraint_Error;
+
+   procedure Set_Range_Constraint
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Delta_Constraint
+        or else NT (N).Nkind = N_Digits_Constraint);
+      Set_Node4_With_Parent (N, Val);
+   end Set_Range_Constraint;
+
+   procedure Set_Range_Expression
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Range_Constraint);
+      Set_Node4_With_Parent (N, Val);
+   end Set_Range_Expression;
+
+   procedure Set_Real_Range_Specification
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Decimal_Fixed_Point_Definition
+        or else NT (N).Nkind = N_Floating_Point_Definition
+        or else NT (N).Nkind = N_Ordinary_Fixed_Point_Definition);
+      Set_Node4_With_Parent (N, Val);
+   end Set_Real_Range_Specification;
+
+   procedure Set_Realval
+     (N : Node_Id; Val : Ureal) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Real_Literal);
+      Set_Ureal3 (N, Val);
+   end Set_Realval;
+
+   procedure Set_Record_Extension_Part
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Derived_Type_Definition);
+      Set_Node3_With_Parent (N, Val);
+   end Set_Record_Extension_Part;
+
+   procedure Set_Redundant_Use
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Attribute_Reference
+        or else NT (N).Nkind = N_Expanded_Name
+        or else NT (N).Nkind = N_Identifier);
+      Set_Flag13 (N, Val);
+   end Set_Redundant_Use;
+
+   procedure Set_Return_Type
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Return_Statement);
+      Set_Node2 (N, Val); -- semantic field, no parent set
+   end Set_Return_Type;
+
+   procedure Set_Reverse_Present
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Loop_Parameter_Specification);
+      Set_Flag15 (N, Val);
+   end Set_Reverse_Present;
+
+   procedure Set_Right_Opnd
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+          or else NT (N).Nkind in N_Op
+        or else NT (N).Nkind = N_And_Then
+        or else NT (N).Nkind = N_In
+        or else NT (N).Nkind = N_Not_In
+        or else NT (N).Nkind = N_Or_Else);
+      Set_Node3_With_Parent (N, Val);
+   end Set_Right_Opnd;
+
+   procedure Set_Rounded_Result
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Op_Divide
+        or else NT (N).Nkind = N_Op_Multiply
+        or else NT (N).Nkind = N_Type_Conversion);
+      Set_Flag18 (N, Val);
+   end Set_Rounded_Result;
+
+   procedure Set_Scope
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Defining_Character_Literal
+        or else NT (N).Nkind = N_Defining_Identifier
+        or else NT (N).Nkind = N_Defining_Operator_Symbol);
+      Set_Node3 (N, Val); -- semantic field, no parent set
+   end Set_Scope;
+
+   procedure Set_Select_Alternatives
+      (N : Node_Id; Val : List_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Selective_Accept);
+      Set_List1_With_Parent (N, Val);
+   end Set_Select_Alternatives;
+
+   procedure Set_Selector_Name
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Expanded_Name
+        or else NT (N).Nkind = N_Generic_Association
+        or else NT (N).Nkind = N_Parameter_Association
+        or else NT (N).Nkind = N_Selected_Component);
+      Set_Node2_With_Parent (N, Val);
+   end Set_Selector_Name;
+
+   procedure Set_Selector_Names
+      (N : Node_Id; Val : List_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Discriminant_Association);
+      Set_List1_With_Parent (N, Val);
+   end Set_Selector_Names;
+
+   procedure Set_Shift_Count_OK
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Op_Rotate_Left
+        or else NT (N).Nkind = N_Op_Rotate_Right
+        or else NT (N).Nkind = N_Op_Shift_Left
+        or else NT (N).Nkind = N_Op_Shift_Right
+        or else NT (N).Nkind = N_Op_Shift_Right_Arithmetic);
+      Set_Flag4 (N, Val);
+   end Set_Shift_Count_OK;
+
+   procedure Set_Source_Type
+      (N : Node_Id; Val : Entity_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Validate_Unchecked_Conversion);
+      Set_Node1 (N, Val); -- semantic field, no parent set
+   end Set_Source_Type;
+
+   procedure Set_Specification
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Abstract_Subprogram_Declaration
+        or else NT (N).Nkind = N_Formal_Subprogram_Declaration
+        or else NT (N).Nkind = N_Generic_Package_Declaration
+        or else NT (N).Nkind = N_Generic_Subprogram_Declaration
+        or else NT (N).Nkind = N_Package_Declaration
+        or else NT (N).Nkind = N_Subprogram_Body
+        or else NT (N).Nkind = N_Subprogram_Body_Stub
+        or else NT (N).Nkind = N_Subprogram_Declaration
+        or else NT (N).Nkind = N_Subprogram_Renaming_Declaration);
+      Set_Node1_With_Parent (N, Val);
+   end Set_Specification;
+
+   procedure Set_Statements
+      (N : Node_Id; Val : List_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Abortable_Part
+        or else NT (N).Nkind = N_Accept_Alternative
+        or else NT (N).Nkind = N_Case_Statement_Alternative
+        or else NT (N).Nkind = N_Delay_Alternative
+        or else NT (N).Nkind = N_Entry_Call_Alternative
+        or else NT (N).Nkind = N_Exception_Handler
+        or else NT (N).Nkind = N_Handled_Sequence_Of_Statements
+        or else NT (N).Nkind = N_Loop_Statement
+        or else NT (N).Nkind = N_Triggering_Alternative);
+      Set_List3_With_Parent (N, Val);
+   end Set_Statements;
+
+   procedure Set_Static_Processing_OK
+      (N : Node_Id; Val : Boolean) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Aggregate);
+      Set_Flag4 (N, Val);
+   end Set_Static_Processing_OK;
+
+   procedure Set_Storage_Pool
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Allocator
+        or else NT (N).Nkind = N_Free_Statement
+        or else NT (N).Nkind = N_Return_Statement);
+      Set_Node1 (N, Val); -- semantic field, no parent set
+   end Set_Storage_Pool;
+
+   procedure Set_Strval
+      (N : Node_Id; Val : String_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Operator_Symbol
+        or else NT (N).Nkind = N_String_Literal);
+      Set_Str3 (N, Val);
+   end Set_Strval;
+
+   procedure Set_Subtype_Indication
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Access_To_Object_Definition
+        or else NT (N).Nkind = N_Component_Declaration
+        or else NT (N).Nkind = N_Constrained_Array_Definition
+        or else NT (N).Nkind = N_Derived_Type_Definition
+        or else NT (N).Nkind = N_Private_Extension_Declaration
+        or else NT (N).Nkind = N_Subtype_Declaration
+        or else NT (N).Nkind = N_Unconstrained_Array_Definition);
+      Set_Node5_With_Parent (N, Val);
+   end Set_Subtype_Indication;
+
+   procedure Set_Subtype_Mark
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Access_Definition
+        or else NT (N).Nkind = N_Access_Function_Definition
+        or else NT (N).Nkind = N_Formal_Derived_Type_Definition
+        or else NT (N).Nkind = N_Formal_Object_Declaration
+        or else NT (N).Nkind = N_Function_Specification
+        or else NT (N).Nkind = N_Object_Renaming_Declaration
+        or else NT (N).Nkind = N_Qualified_Expression
+        or else NT (N).Nkind = N_Subtype_Indication
+        or else NT (N).Nkind = N_Type_Conversion
+        or else NT (N).Nkind = N_Unchecked_Type_Conversion);
+      Set_Node4_With_Parent (N, Val);
+   end Set_Subtype_Mark;
+
+   procedure Set_Subtype_Marks
+      (N : Node_Id; Val : List_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Unconstrained_Array_Definition
+        or else NT (N).Nkind = N_Use_Type_Clause);
+      Set_List2_With_Parent (N, Val);
+   end Set_Subtype_Marks;
+
+   procedure Set_Tagged_Present
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Formal_Private_Type_Definition
+        or else NT (N).Nkind = N_Private_Type_Declaration
+        or else NT (N).Nkind = N_Record_Definition
+        or else NT (N).Nkind = N_With_Type_Clause);
+      Set_Flag15 (N, Val);
+   end Set_Tagged_Present;
+
+   procedure Set_Target_Type
+      (N : Node_Id; Val : Entity_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Validate_Unchecked_Conversion);
+      Set_Node2 (N, Val); -- semantic field, no parent set
+   end Set_Target_Type;
+
+   procedure Set_Task_Body_Procedure
+      (N : Node_Id; Val : Entity_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Task_Type_Declaration);
+      Set_Node2 (N, Val); -- semantic field, no parent set
+   end Set_Task_Body_Procedure;
+
+   procedure Set_Task_Definition
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Single_Task_Declaration
+        or else NT (N).Nkind = N_Task_Type_Declaration);
+      Set_Node3_With_Parent (N, Val);
+   end Set_Task_Definition;
+
+   procedure Set_Then_Actions
+      (N : Node_Id; Val : List_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Conditional_Expression);
+      Set_List2 (N, Val); -- semantic field, no parent set
+   end Set_Then_Actions;
+
+   procedure Set_Then_Statements
+      (N : Node_Id; Val : List_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Elsif_Part
+        or else NT (N).Nkind = N_If_Statement);
+      Set_List2_With_Parent (N, Val);
+   end Set_Then_Statements;
+
+   procedure Set_Treat_Fixed_As_Integer
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Op_Divide
+        or else NT (N).Nkind = N_Op_Mod
+        or else NT (N).Nkind = N_Op_Multiply
+        or else NT (N).Nkind = N_Op_Rem);
+      Set_Flag14 (N, Val);
+   end Set_Treat_Fixed_As_Integer;
+
+   procedure Set_Triggering_Alternative
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Asynchronous_Select);
+      Set_Node1_With_Parent (N, Val);
+   end Set_Triggering_Alternative;
+
+   procedure Set_Triggering_Statement
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Triggering_Alternative);
+      Set_Node1_With_Parent (N, Val);
+   end Set_Triggering_Statement;
+
+   procedure Set_TSS_Elist
+      (N : Node_Id; Val : Elist_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Freeze_Entity);
+      Set_Elist3 (N, Val); -- semantic field, no parent set
+   end Set_TSS_Elist;
+
+   procedure Set_Type_Definition
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Full_Type_Declaration);
+      Set_Node3_With_Parent (N, Val);
+   end Set_Type_Definition;
+
+   procedure Set_Unit
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Compilation_Unit);
+      Set_Node2_With_Parent (N, Val);
+   end Set_Unit;
+
+   procedure Set_Unknown_Discriminants_Present
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Formal_Type_Declaration
+        or else NT (N).Nkind = N_Incomplete_Type_Declaration
+        or else NT (N).Nkind = N_Private_Extension_Declaration
+        or else NT (N).Nkind = N_Private_Type_Declaration);
+      Set_Flag13 (N, Val);
+   end Set_Unknown_Discriminants_Present;
+
+   procedure Set_Unreferenced_In_Spec
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_With_Clause);
+      Set_Flag7 (N, Val);
+   end Set_Unreferenced_In_Spec;
+
+   procedure Set_Variant_Part
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Component_List);
+      Set_Node4_With_Parent (N, Val);
+   end Set_Variant_Part;
+
+   procedure Set_Variants
+      (N : Node_Id; Val : List_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Variant_Part);
+      Set_List1_With_Parent (N, Val);
+   end Set_Variants;
+
+   procedure Set_Visible_Declarations
+      (N : Node_Id; Val : List_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Package_Specification
+        or else NT (N).Nkind = N_Protected_Definition
+        or else NT (N).Nkind = N_Task_Definition);
+      Set_List2_With_Parent (N, Val);
+   end Set_Visible_Declarations;
+
+   procedure Set_Was_Originally_Stub
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Package_Body
+        or else NT (N).Nkind = N_Protected_Body
+        or else NT (N).Nkind = N_Subprogram_Body
+        or else NT (N).Nkind = N_Task_Body);
+      Set_Flag13 (N, Val);
+   end Set_Was_Originally_Stub;
+
+   procedure Set_Zero_Cost_Handling
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Exception_Handler
+        or else NT (N).Nkind = N_Handled_Sequence_Of_Statements);
+      Set_Flag5 (N, Val);
+   end Set_Zero_Cost_Handling;
+
+   -------------------------
+   -- Iterator Procedures --
+   -------------------------
+
+   procedure Next_Entity       (N : in out Node_Id) is
+   begin
+      N := Next_Entity (N);
+   end Next_Entity;
+
+   procedure Next_Named_Actual (N : in out Node_Id) is
+   begin
+      N := Next_Named_Actual (N);
+   end Next_Named_Actual;
+
+   procedure Next_Rep_Item     (N : in out Node_Id) is
+   begin
+      N := Next_Rep_Item (N);
+   end Next_Rep_Item;
+
+   procedure Next_Use_Clause   (N : in out Node_Id) is
+   begin
+      N := Next_Use_Clause (N);
+   end Next_Use_Clause;
+
+   ------------------
+   -- End_Location --
+   ------------------
+
+   function End_Location (N : Node_Id) return Source_Ptr is
+      L : constant Uint := End_Span (N);
+
+   begin
+      if L = No_Uint then
+         return No_Location;
+      else
+         return Source_Ptr (Int (Sloc (N)) + UI_To_Int (L));
+      end if;
+   end End_Location;
+
+   ----------------------
+   -- Set_End_Location --
+   ----------------------
+
+   procedure Set_End_Location (N : Node_Id; S : Source_Ptr) is
+   begin
+      Set_End_Span (N,
+        UI_From_Int (Int (S) - Int (Sloc (N))));
+   end Set_End_Location;
+
+end Sinfo;
diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads
new file mode 100644
index 00000000000..335f9fa379c
--- /dev/null
+++ b/gcc/ada/sinfo.ads
@@ -0,0 +1,8684 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                                S I N F O                                 --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.430 $
+--                                                                          --
+--          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 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 defines the structure of the abstract syntax tree. The Tree
+--  package provides a basic tree structure. Sinfo describes how this
+--  structure is used to represent the syntax of an Ada program.
+
+--  Note: the grammar used here is taken from Version 5.95 of the RM, dated
+--  November 1994. The grammar in the RM is followed very closely in the tree
+--  design, and is repeated as part of this source file.
+
+--  The tree contains not only the full syntactic representation of the
+--  program, but also the results of semantic analysis. In particular, the
+--  nodes for defining identifiers, defining character literals and defining
+--  operator symbols, collectively referred to as entities, represent what
+--  would normally be regarded as the symbol table information. In addition
+--  a number of the tree nodes contain semantic information.
+
+--  WARNING: There is a C version of this package. Any changes to this
+--  source file must be properly reflected in this C header file sinfo.h
+--  which is created automatically from sinfo.ads using xsinfo.spt.
+
+with Types;  use Types;
+with Uintp;  use Uintp;
+with Urealp; use Urealp;
+
+package Sinfo is
+
+   ---------------------------------
+   -- Making Changes to This File --
+   ---------------------------------
+
+   --  If changes are made to this file, a number of related steps must be
+   --  carried out to ensure consistency. First, if a field access function
+   --  is added, it appears in seven places:
+
+   --    The documentation associated with the node
+   --    The spec of the access function in sinfo.ads
+   --    The body of the access function in sinfo.adb
+   --    The pragma Inline at the end of sinfo.ads for the access function
+   --    The spec of the set procedure in sinfo.ads
+   --    The body of the set procedure in sinfo.adb
+   --    The pragma Inline at the end of sinfo.ads for the set procedure
+
+   --  The field chosen must be consistent in all places, and, for a node
+   --  that is a subexpression, must not overlap any of the standard
+   --  expression fields. In the body, the calls to the Dcheck_Node debug
+   --  procedure will need cross-references adding in alphabetical order.
+
+   --  In addition, if any of the standard expression fields is changed, then
+   --  the utiliy program which creates the Treeprs spec (in file treeprs.ads)
+   --  must be updated appropriately, since it special cases expression fields.
+
+   --  If a new tree node is added, then the following changes are made
+
+   --    Add it to the documentation in the appropriate place
+   --    Add its fields to this documentation section
+   --    Define it in the appropriate classification in Node_Kind
+   --    In the body (sinfo), add entries to the Dcheck calls for all
+   --     its fields (except standard expression fields) to include
+   --     the new node in the debug cross-reference list
+   --    Add an appropriate section to the case statement in sprint.adb
+   --    Add an appropriate section to the case statement in sem.adb
+   --    Add an appropraite section to the case statement in exp_util.adb
+   --     (Insert_Actions procedure)
+   --    For a subexpression, add an appropriate sections to the case
+   --     statement in sem_eval.adb
+   --    For a subexpression, add an appropriate sections to the case
+   --     statement in sem_res.adb
+
+   --  Finally, four utility programs must be run:
+
+   --    Run CSinfo to check that you have made the changes consistently.
+   --     It checks most of the rules given above, with clear error messages.
+   --     This utility reads sinfo.ads and sinfo.adb and generates a report
+   --     to standard output.
+
+   --    Run XSinfo to create a-sinfo.h, the corresponding C header. This
+   --     utility reads sinfo.ads and generates a-sinfo.h. Note that it
+   --     does not need to read sinfo.adb, since the contents of the body
+   --     are algorithmically determinable from the spec.
+
+   --    Run XTreeprs to create treeprs.ads, an updated version of
+   --     the module that is used to drive the tree print routine. This
+   --     utility reads (but does not modify) treeprs.adt, the template
+   --     that provides the basic structure of the file, and then fills
+   --     in the data from the comments in sinfo.ads.
+
+   --    Run XNmake to create nmake.ads and nmake.adb, the package body
+   --     and spec of the Nmake package which contains functions for
+   --     constructing nodes.
+
+   --  Note: sometime we could write a utility that actually generated the
+   --  body of sinfo from the spec instead of simply checking it, since, as
+   --  noted above, the contents of the body can be determined from the spec.
+
+   --------------------------------
+   -- Implicit Nodes in the Tree --
+   --------------------------------
+
+   --  Generally the structure of the tree very closely follows the grammar
+   --  as defined in the RM. However, certain nodes are omitted to save
+   --  space and simplify semantic processing. Two general classes of such
+   --  omitted nodes are as follows:
+
+   --   If the only possibilities for a non-terminal are one or more other
+   --   non terminals (i.e. the rule is a "skinny" rule), then usually the
+   --   corresponding node is omitted from the tree, and the target construct
+   --   appears directly. For example, a real type definition is either a
+   --   floating point definition or a fixed point definition. No explicit
+   --   node appears for real type definition. Instead either the floating
+   --   point definition or fixed point definition appears directly.
+
+   --   If a non-terminal corresponds to a list of some other non-terminal
+   --   (possibly with separating punctuation), then usually it is omitted
+   --   from the tree, and a list of components appears instead. For
+   --   example, sequence of statements does not appear explicitly in the
+   --   tree. Instead a list of statements appears directly.
+
+   --  Some additional cases of omitted nodes occur and are documented
+   --  individually. In particular, many nodes are omitted in the tree
+   --  generated for an expression.
+
+   -------------------------------------------
+   -- Handling of Defining Identifier Lists --
+   -------------------------------------------
+
+   --  In several declarative forms in the syntax, lists of defining
+   --  identifiers appear (object declarations, component declarations,
+   --  number declarations etc.)
+
+   --  The semantics of such statements are equivalent to a series of
+   --  identical declarations of single defining identifiers (except that
+   --  conformance checks require the same grouping of identifiers in the
+   --  parameter case).
+
+   --  To simplify semantic processing, the parser breaks down such multiple
+   --  declaration cases into sequences of single declarations, duplicating
+   --  type and initialization information as required. The flags More_Ids
+   --  and Prev_Ids are used to record the original form of the source in
+   --  the case where the original source used a list of names, More_Ids
+   --  being set on all but the last name and Prev_Ids being set on all
+   --  but the first name. These flags are used to reconstruct the original
+   --  source (e.g. in the Sprint package), and also are included in the
+   --  conformance checks, but otherwise have no semantic significance.
+
+   --  Note: the reason that we use More_Ids and Prev_Ids rather than
+   --  First_Name and Last_Name flags is so that the flags are off in the
+   --  normal one identifier case, which minimizes tree print output.
+
+   -----------------------
+   -- Use of Node Lists --
+   -----------------------
+
+   --  With a few exceptions, if a construction of the form {non-terminal}
+   --  appears in the tree, lists are used in the corresponding tree node
+   --  (see package Nlists for handling of node lists). In this case a field
+   --  of the parent node points to a list of nodes for the non-terminal. The
+   --  field name for such fields has a plural name which always ends in "s".
+   --  For example, a case statement has a field Alternatives pointing to a
+   --  list of case statement alternative nodes.
+
+   --  Only fields pointing to lists have names ending in "s", so generally
+   --  the structure is strongly typed, fields not ending in s point to
+   --  single nodes, and fields ending in s point to lists.
+
+   --  The following example shows how a traversal of a list is written. We
+   --  suppose here that Stmt points to a N_Case_Statement node which has
+   --  a list field called Alternatives:
+
+   --   Alt := First (Alternatives (Stmt));
+   --   while Present (Alt) loop
+   --      ..
+   --      -- processing for case statement alternative Alt
+   --      ..
+   --      Alt := Next (Alt);
+   --   end loop;
+
+   --  The Present function tests for Empty, which in this case signals the
+   --  end of the list. First returns Empty immediately if the list is empty.
+   --  Present is defined in Atree, First and Next are defined in Nlists.
+
+   --  The exceptions to this rule occur with {DEFINING_IDENTIFIERS} in all
+   --  contexts, which is handled as described in the previous section, and
+   --  with {,library_unit_NAME} in the N_With_Clause mode, which is handled
+   --  using the First_Name and Last_Name flags, as further detailed in the
+   --  description of the N_With_Clause node.
+
+   -------------
+   -- Pragmas --
+   -------------
+
+   --  Pragmas can appear in many different context, but are not included
+   --  in the grammar. Still they must appear in the tree, so they can be
+   --  properly processed.
+
+   --  Two approaches are used. In some cases, an extra field is defined
+   --  in an appropriate node that contains a list of pragmas appearing
+   --  in the expected context. For example pragmas can appear before an
+   --  Accept_Alternative in a Selective_Accept_Statement, and these pragmas
+   --  appear in the Pragmas_Before field of the N_Accept_Alternative node.
+
+   --  The other approach is to simply allow pragmas to appear in syntactic
+   --  lists where the grammar (of course) does not include the possibility.
+   --  For example, the Variants field of an N_Variant_Part node points to
+   --  a list that can contain both N_Pragma and N_Variant nodes.
+
+   --  To make processing easier in the latter case, the Nlists package
+   --  provides a set of routines (First_Non_Pragma, Last_Non_Pragma,
+   --  Next_Non_Pragma, Prev_Non_Pragma) that allow such lists to be
+   --  handled ignoring all pragmas.
+
+   --  In the case of the variants list, we can either write:
+
+   --      Variant := First (Variants (N));
+   --      while Present (Variant) loop
+   --         ...
+   --         Alt := Next (Alt);
+   --      end loop;
+
+   --  or
+
+   --      Variant := First_Non_Pragma (Variants (N));
+   --      while Present (Variant) loop
+   --         ...
+   --         Alt := Next_Non_Pragma (Alt);
+   --      end loop;
+
+   --  In the first form of the loop, Variant can either be an N_Pragma or
+   --  an N_Variant node. In the second form, Variant can only be N_Variant
+   --  since all pragmas are skipped.
+
+   ---------------------
+   -- Optional Fields --
+   ---------------------
+
+   --  Fields which correspond to a section of the syntax enclosed in square
+   --  brackets are generally omitted (and the corresponding field set to
+   --  Empty for a node, or No_List for a list). The documentation of such
+   --  fields notes these cases. One exception to this rule occurs in the
+   --  case of possibly empty statement sequences (such as the sequence of
+   --  statements in an entry call alternative). Such cases appear in the
+   --  syntax rules as [SEQUENCE_OF_STATEMENTS] and the fields corresponding
+   --  to such optional statement sequences always contain an empty list (not
+   --  No_List) if no statements are present.
+
+   --  Note: the utility program that constructs the body and spec of the
+   --  Nmake package relies on the format of the comments to determine if
+   --  a field should have a default value in the corresponding make routine.
+   --  The rule is that if the first line of the description of the field
+   --  contains the string "(set to xxx if", then a default value of xxx is
+   --  provided for this field in the corresponding Make_yyy routine.
+
+   -----------------------------------
+   -- Note on Body/Spec Terminology --
+   -----------------------------------
+
+   --  In informal discussions about Ada, it is customary to refer to package
+   --  and subprogram specs and bodies. However, this is not technically
+   --  correct, what is normally referred to as a spec or specification is in
+   --  fact a package declaration or subprogram declaration. We are careful
+   --  in GNAT to use the correct terminology and in particular, the full
+   --  word specification is never used as an incorrect substitute for
+   --  declaration. The structure and terminology used in the tree also
+   --  reflects the grammar and thus uses declaration and specification in
+   --  the technically correct manner.
+
+   --  However, there are contexts in which the informal terminology is
+   --  useful. We have the word "body" to refer to the Interp_Etype declared by
+   --  the declaration of a unit body, and in some contexts we need a
+   --  similar term to refer to the entity declared by the package or
+   --  subprogram declaration, and simply using declaration can be confusing
+   --  since the body also has a declaration.
+
+   --  An example of such a context is the link between the package body
+   --  and its declaration. With_Declaration is confusing, since
+   --  the package body itself is a declaration.
+
+   --  To deal with this problem, we reserve the informal term Spec, i.e.
+   --  the popular abbreviation used in this context, to refer to the entity
+   --  declared by the package or subprogram declaration. So in the above
+   --  example case, the field in the body is called With_Spec.
+
+   --  Another important context for the use of the word Spec is in error
+   --  messages, where a hyper-correct use of declaration would be confusing
+   --  to a typical Ada programmer, and even for an expert programmer can
+   --  cause confusion since the body has a declaration as well.
+
+   --  So, to summarize:
+
+   --     Declaration    always refers to the syntactic entity that is called
+   --                    a declaration. In particular, subprogram declaration
+   --                    and package declaration are used to describe the
+   --                    syntactic entity that includes the semicolon.
+
+   --     Specification  always refers to the syntactic entity that is called
+   --                    a specification. In particular, the terms procedure
+   --                    specification, function specification, package
+   --                    specification, subprogram specification always refer
+   --                    to the syntactic entity that has no semicolon.
+
+   --     Spec           is an informal term, used to refer to the entity
+   --                    that is declared by a task declaration, protected
+   --                    declaration, generic declaration, subprogram
+   --                    declaration or package declaration.
+
+   --  This convention is followed throughout the GNAT documentation
+   --  both internal and external, and in all error message text.
+
+   ------------------------
+   -- Internal Use Nodes --
+   ------------------------
+
+   --  These are Node_Kind settings used in the internal implementation
+   --  which are not logically part of the specification.
+
+   --  N_Unused_At_Start
+   --  Completely unused entry at the start of the enumeration type. This
+   --  is inserted so that no legitimate value is zero, which helps to get
+   --  better debugging behavior, since zero is a likely uninitialized value).
+
+   --  N_Unused_At_End
+   --  Completely unused entry at the end of the enumeration type. This is
+   --  handy so that arrays with Node_Kind as the index type have an extra
+   --  entry at the end (see for example the use of the Pchar_Pos_Array in
+   --  Treepr, where the extra entry provides the limit value when dealing
+   --  with the last used entry in the array).
+
+   -----------------------------------------
+   -- Note on the settings of Sloc fields --
+   -----------------------------------------
+
+   --  The Sloc field of nodes that come from the source is set by the
+   --  parser. For internal nodes, and nodes generated during expansion
+   --  the Sloc is usually set in the call to the constructor for the node.
+   --  In general the Sloc value chosen for an internal node is the Sloc of
+   --  the source node whose processing is responsible for the expansion. For
+   --  example, the Sloc of an inherited primitive operation is the Sloc of
+   --  the corresponding derived type declaration.
+
+   --  For the nodes of a generic instantiation, the Sloc value is encoded
+   --  to represent both the original Sloc in the generic unit, and the Sloc
+   --  of the instantiation itself. See Sinput.ads for details.
+
+   --  Subprogram instances create two callable entities: one is the visible
+   --  subprogram instance, and the other is an anonymous subprogram nested
+   --  within a wrapper package that contains the renamings for the actuals.
+   --  Both of these entities have the Sloc of the defining entity in the
+   --  instantiation node. This simplifies some ASIS queries.
+
+   -----------------------
+   -- Field Definitions --
+   -----------------------
+
+   --  In the following node definitions, all fields, both syntactic and
+   --  semantic, are documented. The one exception is in the case of entities
+   --  (defining indentifiers, character literals and operator symbols),
+   --  where the usage of the fields depends on the entity kind. Entity
+   --  fields are fully documented in the separate package Einfo.
+
+   --  In the node definitions, three common sets of fields are abbreviated
+   --  to save both space in the documentation, and also space in the string
+   --  (defined in Tree_Print_Strings) used to print trees. The following
+   --  abbreviations are used:
+
+   --  Note: the utility program that creates the Treeprs spec (in the file
+   --  treeprs.ads) knows about the special fields here, so it must be
+   --  modified if any change is made to these fields.
+
+   --    "plus fields for binary operator"
+   --       Chars                    (Name1)      Name_Id for the operator
+   --       Left_Opnd                (Node2)      left operand expression
+   --       Right_Opnd               (Node3)      right operand expression
+   --       Entity                   (Node4-Sem)  defining entity for operator
+   --       Do_Overflow_Check        (Flag17-Sem) set if overflow check needed
+   --       Has_Private_View         (Flag11-Sem) set in generic units.
+
+   --    "plus fields for unary operator"
+   --       Chars                    (Name1)      Name_Id for the operator
+   --       Right_Opnd               (Node3)      right operand expression
+   --       Entity                   (Node4-Sem)  defining entity for operator
+   --       Do_Overflow_Check        (Flag17-Sem) set if overflow check needed
+   --       Has_Private_View         (Flag11-Sem) set in generic units.
+
+   --    "plus fields for expression"
+   --       Paren_Count                           number of parentheses levels
+   --       Etype                    (Node5-Sem)  type of the expression
+   --       Is_Overloaded            (Flag5-Sem)  >1 type interpretation exists
+   --       Is_Static_Expression     (Flag6-Sem)  set for static expression
+   --       Raises_Constraint_Error  (Flag7-Sem)  evaluation raises CE
+   --       Must_Not_Freeze          (Flag8-Sem)  set if must not freeze
+   --       Do_Range_Check           (Flag9-Sem)  set if a range check needed
+   --       Assignment_OK            (Flag15-Sem) set if modification is OK
+   --       Is_Controlling_Actual    (Flag16-Sem) set for controlling argument
+
+   --  Note: see under (EXPRESSION) for further details on the use of
+   --  the Paren_Count field to record the number of parentheses levels.
+
+   --  Node_Kind is the type used in the Nkind field to indicate the node
+   --  kind. The actual definition of this type is given later (the reason
+   --  for this is that we want the descriptions ordered by logical chapter
+   --  in the RM, but the type definition is reordered to facilitate the
+   --  definition of some subtype ranges. The individual descriptions of
+   --  the nodes show how the various fields are used in each node kind,
+   --  as well as providing logical names for the fields. Functions and
+   --  procedures are provided for accessing and setting these fields
+   --  using these logical names.
+
+   -----------------------
+   -- Gigi Restrictions --
+   -----------------------
+
+   --  The tree passed to Gigi is more restricted than the general tree form.
+   --  For example, as a result of expansion, most of the tasking nodes can
+   --  never appear. For each node to which either a complete or partial
+   --  restriction applies, a note entitled "Gigi restriction" appears which
+   --  documents the restriction.
+
+   --  Note that most of these restrictions apply only to trees generated when
+   --  code is being generated, since they involved expander actions that
+   --  destroy the tree.
+
+   ------------------------
+   -- Common Flag Fields --
+   ------------------------
+
+   --  The following flag fields appear in all nodes
+
+   --  Analyzed
+   --    This flag is used to indicate that a node (and all its children
+   --    have been analyzed. It is used to avoid reanalysis of a node that
+   --    has already been analyzed, both for efficiency and functional
+   --    correctness reasons.
+
+   --  Error_Posted
+   --    This flag is used to avoid multiple error messages being posted
+   --    on or referring to the same node. This flag is set if an error
+   --    message refers to a node or is posted on its source location,
+   --    and has the effect of inhibiting further messages involving
+   --    this same node.
+
+   --  Comes_From_Source
+   --    This flag is on for any nodes built by the scanner or parser from
+   --    the source program, and off for any nodes built by the analyzer or
+   --    expander. It indicates that a node comes from the original source.
+   --    This flag is defined in Atree.
+
+   --  Has_Dynamic_Length_Check and Has_Dynamic_Range_Check also appear on
+   --  all nodes. They are fully described in the next section.
+
+   ------------------------------------
+   -- Description of Semantic Fields --
+   ------------------------------------
+
+   --  The meaning of the syntactic fields is generally clear from their
+   --  names without any further description, since the names are chosen
+   --  to correspond very closely to the syntax in the reference manual.
+   --  This section describes the usage of the semantic fields, which are
+   --  used to contain additional information determined during semantic
+   --  analysis.
+
+   --  ABE_Is_Certain (Flag18-Sem)
+   --    This flag is set in an instantiation node or a call node is
+   --    determined to be sure to raise an ABE. This is used to trigger
+   --    special handling of such cases, particularly in the instantiation
+   --    case where we avoid instantiating the body if this flag is set.
+   --    This flag is also present in an N_Formal_Package_Declaration_Node
+   --    since formal package declarations are treated like instantiations,
+   --    but it is always set to False in this context.
+
+   --  Accept_Handler_Records (List5-Sem)
+   --    This field is present only in an N_Accept_Alternative node. It is
+   --    used to temporarily hold the exception handler records from an
+   --    accept statement in a selective accept. These exception handlers
+   --    will eventually be placed in the Handler_Records list of the
+   --    procedure built for this accept (see Expand_N_Selective_Accept
+   --    procedure in Exp_Ch9 for further details).
+
+   --  Access_Types_To_Process (Elist2-Sem)
+   --    Present in N_Freeze_Entity nodes for Incomplete or private types.
+   --    Contains the list of access types which may require specific
+   --    treatment when the nature of the type completion is completely
+   --    known. An example of such treatement is the generation of the
+   --    associated_final_chain.
+
+   --  Actions (List1-Sem)
+   --    This field contains a sequence of actions that are associated
+   --    with the node holding the field. See the individual node types
+   --    for details of how this field is used, as well as the description
+   --    of the specific use for a particular node type.
+
+   --  Activation_Chain_Entity (Node3-Sem)
+   --    This is used in tree nodes representing task activators (blocks,
+   --    subprogram bodies, package declarations, and task bodies). It is
+   --    initially Empty, and then gets set to point to the entity for the
+   --    declared Activation_Chain variable when the first task is declared.
+   --    When tasks are declared in the corresponding declarative region
+   --    this entity is located by name (its name is always _Chain) and
+   --    the declared tasks are added to the chain.
+
+   --  Acts_As_Spec (Flag4-Sem)
+   --    A flag set in the N_Subprogram_Body node for a subprogram body
+   --    which is acting as its own spec. This flag also appears in the
+   --    compilation unit node at the library level for such a subprogram
+   --    (see further description in spec of Lib package).
+
+   --  Aggregate_Bounds (Node3-Sem)
+   --    Present in array N_Aggregate nodes. If the aggregate contains
+   --    component associations this field points to an N_Range node whose
+   --    bounds give the lowest and highest discrete choice values. If the
+   --    named aggregate contains a dynamic or null choice this field is
+   --    empty. If the aggregate contains positional elements this field
+   --    points to an N_Integer_Literal node giving the number of positional
+   --    elements. Note that if the aggregate contains positional elements
+   --    and an other choice the N_Integer_Literal only accounts for the
+   --    number of positional elements.
+
+   --  All_Others (Flag11-Sem)
+   --    Present in an N_Others_Choice node. This flag is set in the case
+   --    of an others exception where all exceptions, even those that are
+   --    not normally handled (in particular the tasking abort signal) by
+   --    others. This is used for translation of the at end handler into
+   --    a normal exception handler.
+
+   --  Assignment_OK (Flag15-Sem)
+   --    This flag is set in a subexpression node for an object, indicating
+   --    that the associated object can be modified, even if this would not
+   --    normally be permissible (either by direct assignment, or by being
+   --    passed as an out or in-out parameter). This is used by the expander
+   --    for a number of purposes, including initialzation of constants and
+   --    limited type objects (such as tasks), setting discriminant fields,
+   --    setting tag values, etc. N_Object_Declaration nodes also have this
+   --    flag defined. Here it is used to indicate that an initialization
+   --    expression is valid, even where it would normally not be allowed
+   --    (e.g. where the type involved is limited).
+
+   --  At_End_Proc (Node1)
+   --    This field is present in an N_Handled_Sequence_Of_Statements node.
+   --    It contains an identifier reference for the cleanup procedure to
+   --    be called. See description of this node for further details.
+
+   --  Backwards_OK (Flag6-Sem)
+   --    A flag present in the N_Assignment_Statement node. It is used only
+   --    if the type being assigned is an array type, and is set if analysis
+   --    determines that it is definitely safe to do the copy backwards, i.e.
+   --    starting at the highest addressed element. Note that if neither of
+   --    the flags Forwards_OK or Backwards_OK is set, it means that the
+   --    front end could not determine that either direction is definitely
+   --    safe, and a runtime check is required.
+
+   --  Body_To_Inline (Node3-Sem)
+   --    present in subprogram declarations. Denotes analyzed but unexpanded
+   --    body of subprogram, to be used when inlining calls. Present when the
+   --    subprogram has an Inline pragma and inlining is enabled. If the
+   --    declaration is completed by a renaming_as_body, and the renamed en-
+   --    tity is a subprogram, the Body_To_Inline is the name of that entity,
+   --    which is used directly in later calls to the original subprogram.
+
+   --  Body_Required (Flag13-Sem)
+   --    A flag that appears in the N_Compilation_Unit node indicating that
+   --    the corresponding unit requires a body. For the package case, this
+   --    indicates that a completion is required. In Ada 95, if the flag
+   --    is not set for the package case, then a body may not be present.
+   --    In Ada 83, if the flag is not set for the package case, then a
+   --    body is optional. For a subprogram declaration, the flag is set
+   --    except in the case where a pragma Import or Interface applies,
+   --    in which case no body is permitted (in Ada 83 or Ada 95).
+
+   --  By_Ref (Flag5-Sem)
+   --    A flag present in the N_Return_Statement_Node. It is set when the
+   --    returned expression is already allocated on the secondary stack
+   --    and thus the result is passed by reference rather than copied
+   --    another time.
+
+   --  Compile_Time_Known_Aggregate (Flag18-Sem)
+   --    Present in N_Aggregate nodes. Set for aggregates which can be
+   --    fully evaluated at compile time without raising constraint error.
+   --    Such aggregates can be passed as is to Gigi without any expansion.
+   --    See Sem_Aggr for the specific conditions under which an aggregate
+   --    has this flag set. See also the flag Static_Processing_OK.
+
+   --  Condition_Actions (List3-Sem)
+   --    This field appears in else-if nodes and in the iteration scheme
+   --    node for while loops. This field is only used during semantic
+   --    processing to temporarily hold actions inserted into the tree.
+   --    In the tree passed to gigi, the condition actions field is always
+   --    set to No_List. For details on how this field is used, see the
+   --    routine Insert_Actions in package Exp_Util, and also the expansion
+   --    routines for the relevant nodes.
+
+   --  Controlling_Argument (Node1-Sem)
+   --    This field is set in procedure and function call nodes if the call
+   --    is a dispatching call (it is Empty for a non-dispatching call).
+   --    It indicates the source of the controlling tag for the call. For
+   --    Procedure calls, the Controlling_Argument is one of the actuals.
+   --    For a function that has a dispatching result, it is an entity in
+   --    the context of the call that can provide a tag, or else it is the
+   --    tag of the root type of the class.
+
+   --  Conversion_OK (Flag14-Sem)
+   --    A flag set on type conversion nodes to indicate that the conversion
+   --    is to be considered as being valid, even though it is the case that
+   --    the conversion is not valid Ada. This is used for the Enum_Rep,
+   --    Fixed_Value and Integer_Value attributes, for internal conversions
+   --    done for fixed-point operations, and for certain conversions for
+   --    calls to initialization procedures. If Conversion_OK is set, then
+   --    Etype must be set (the analyzer assumes that Etype has been set).
+   --    For the case of fixed-point operands, it also indicates that the
+   --    conversion is to be a direct conversion of the underlying integer
+   --    result, with no regard to the small operand.
+
+   --  Corresponding_Body (Node5-Sem)
+   --    This field is set in subprogram declarations, where it is needed
+   --    if a pragma Inline is present and the subprogram is called, in
+   --    generic declarations if the generic is instantiated, and also in
+   --    package declarations that contain inlined subprograms that are
+   --    called, or generic declarations that are instantiated. It points
+   --    to the defining entity for the corresponding body.
+
+   --  Corresponding_Generic_Association (Node5-Sem)
+   --    This field is defined for object declarations and object renaming
+   --    declarations. It is set for the declarations within an instance that
+   --    map generic formals to their actuals.  If set, the field points to
+   --    a generic_association which is the original parent of the expression
+   --    or name appearing in the declaration. This simplifies ASIS queries.
+
+   --  Corresponding_Integer_Value (Uint4-Sem)
+   --    This field is set in real literals of fixed-point types (it is not
+   --    used for floating-point types). It contains the integer value used
+   --    to represent the fixed-point value. It is also set on the universal
+   --    real literals used to represent bounds of fixed-point base types
+   --    and their first named subtypes.
+
+   --  Corresponding_Spec (Node5-Sem)
+   --    This field is set in subprogram, package, task, and protected body
+   --    nodes, where it points to the defining entity in the corresponding
+   --    spec. The attribute is also set in N_With_Clause nodes, where
+   --    it points to the defining entity for the with'ed spec, and in
+   --    a subprogram renaming declaration when it is a Renaming_As_Body.
+   --    The field is Empty if there is no corresponding spec, as in the
+   --    case of a subprogram body that serves as its own spec.
+
+   --  Corresponding_Stub (Node3-Sem)
+   --    This field is present in an N_Subunit node. It holds the node in
+   --    the parent unit that is the stub declaration for the subunit. it is
+   --    set when analysis of the stub forces loading of the proper body. If
+   --    expansion of the proper body creates new declarative nodes, they are
+   --    inserted at the point of the corresponding_stub.
+
+   --  Dcheck_Function (Node5-Sem)
+   --    This field is present in an N_Variant node, It references the entity
+   --    for the discriminant checking function for the variant.
+
+   --  Debug_Statement (Node3)
+   --    This field is present in an N_Pragma node. It is used only for
+   --    a Debug pragma or pragma Assert with a second parameter. The
+   --    parameter is of the form of an expression, as required by the
+   --    pragma syntax, but is actually a procedure call. To simplify
+   --    semantic processing, the parser creates a copy of the argument
+   --    rearranged into a procedure call statement and places it in the
+   --    Debug_Statement field. Note that this field is considered a
+   --    syntactic field, since it is created by the parser.
+
+   --  Default_Expression (Node5-Sem)
+   --    This field is Empty if there is no default expression. If there
+   --    is a simple default expression (one with no side effects), then
+   --    this field simply contains a copy of the Expression field (both
+   --    point to the tree for the default expression). Default_Expression
+   --    is used for conformance checking.
+
+   --  Delay_Finalize_Attach (Flag14-Sem)
+   --    This flag is present in an N_Object_Declaration node. If it is set,
+   --    then in the case of a controlled type being declared and initialized,
+   --    the normal code for attaching the result to the appropriate local
+   --    finalization list is suppressed. This is used for functions that
+   --    return controlled types without using the secondary stack, where
+   --    it is the caller who must do the attachment.
+
+   --  Discr_Check_Funcs_Built (Flag11-Sem)
+   --    This flag is present in N_Full_Type_Declaration nodes. It is set when
+   --    discriminant checking functions are constructed. The purpose is to
+   --    avoid attempting to set these functions more than once.
+
+   --  Do_Access_Check (Flag11-Sem)
+   --    This flag is set on nodes with a Prefix field that can be an object
+   --    of an access type. If the flag is set, it indicates that a check is
+   --    required to ensure that the value of the referenced object is not
+   --    null. The actual check (which may be explicit or implicit by means
+   --    of some trap), is generated by Gigi (all the front end does is to
+   --    set this flag to request the trap).
+
+   --  Do_Accessibility_Check (Flag13-Sem)
+   --    This flag is set on N_Parameter_Specification nodes to indicate
+   --    that an accessibility check is required for the parameter. It is
+   --    not yet decided who takes care of this check (TBD ???).
+
+   --  Do_Discriminant_Check (Flag13-Sem)
+   --    This flag is set on N_Selected_Component nodes to indicate that a
+   --    discriminant check is required using the discriminant check routine
+   --    associated with the selector. The actual check is dealt with by
+   --    Gigi (all the front end does is to set the flag).
+
+   --  Do_Division_Check (Flag13-Sem)
+   --    This flag is set on a division operator (/ mod rem) to indicate
+   --    that a zero divide check is required. The actual check is dealt
+   --    with by the backend (all the front end does is to set the flag).
+
+   --  Do_Length_Check (Flag4-Sem)
+   --    This flag is set in an N_Assignment_Statement, N_Op_And, N_Op_Or,
+   --    N_Op_Xor, or N_Type_Conversion node to indicate that a length check
+   --    is required. It is not determined who deals with this flag (???).
+
+   --  Do_Overflow_Check (Flag17-Sem)
+   --    This flag is set on an operator where an overflow check is required
+   --    on the operation. The actual check is dealt with by the backend
+   --    (all the front end does is to set the flag). The other cases where
+   --    this flag is used is on a Type_Conversion node and for attribute
+   --    reference nodes. For a type conversion, it means that the conversion
+   --    is from one base type to another, and the value may not fit in the
+   --    target base type. See also the description of Do_Range_Check for
+   --    this case. The only attribute references which use this flag are
+   --    Pred and Succ, where it means that the result should be checked
+   --    for going outside the base range.
+
+   --  Do_Range_Check (Flag9-Sem)
+   --    This flag is set on an expression which appears in a context where
+   --    a range check is required. The target type is clear from the
+   --    context. The contexts in which this flag can appear are limited to
+   --    the following.
+
+   --      Right side of an assignment. In this case the target type is
+   --      taken from the left side of the assignment, which is referenced
+   --      by the Name of the N_Assignment_Statement node.
+
+   --      Subscript expressions in an indexed component. In this case the
+   --      target type is determined from the type of the array, which is
+   --      referenced by the Prefix of the N_Indexed_Component node.
+
+   --      Argument expression for a parameter, appearing either directly
+   --      in the Parameter_Associations list of a call or as the Expression
+   --      of an N_Parameter_Association node that appears in this list. In
+   --      either case, the check is against the type of the formal. Note
+   --      that the flag is relevant only in IN and IN OUT parameters, and
+   --      will be ignored for OUT parameters, where no check is required
+   --      in the call, and if a check is required on the return, it is
+   --      generated explicitly with a type conversion.
+
+   --      Initialization expression for the initial value in an object
+   --      declaration. In this case the Do_Range_Check flag is set on
+   --      the initialization expression, and the check is against the
+   --      range of the type of the object being declared.
+
+   --      The expression of a type conversion. In this case the range check
+   --      is against the target type of the conversion. See also the use of
+   --      Do_Overflow_Check on a type conversion. The distinction is that
+   --      the ovrflow check protects against a value that is outside the
+   --      range of the target base type, whereas a range check checks that
+   --      the resulting value (which is a value of the base type of the
+   --      target type), satisfies the range constraint of the target type.
+
+   --    Note: when a range check is required in contexts other than those
+   --    listed above (e.g. in a return statement), an additional type
+   --    conversion node is introduced to represent the required check.
+
+   --  Do_Storage_Check (Flag17-Sem)
+   --    This flag is set in an N_Allocator node to indicate that a storage
+   --    check is required for the allocation, or in an N_Subprogram_Body
+   --    node to indicate that a stack check is required in the subprogram
+   --    prolog. The N_Allocator case is handled by the routine that expands
+   --    the call to the runtime routine. The N_Subprogram_Body case is
+   --    handled by the backend, and all the semantics does is set the flag.
+
+   --  Do_Tag_Check (Flag13-Sem)
+   --    This flag is set on an N_Assignment_Statement, N_Function_Call,
+   --    N_Procedure_Call_Statement, N_Type_Conversion or N_Return_Statememt
+   --    node to indicate that the tag check can be suppressed. It is not
+   --    yet decided how this flag is used (TBD ???).
+
+   --  Elaborate_Present (Flag4-Sem)
+   --    This flag is set in the N_With_Clause node to indicate that a
+   --    pragma Elaborate pragma appears for the with'ed units.
+
+   --  Elaborate_All_Present (Flag15-Sem)
+   --    This flag is set in the N_With_Clause node to indicate that a
+   --    pragma Elaborate_All pragma appears for the with'ed units.
+
+   --  Elaboration_Boolean (Node2-Sem)
+   --    This field is present in function and procedure specification
+   --    nodes. If set, it points to the entity for a Boolean flag that
+   --    must be tested for certain calls to check for access before
+   --    elaboration. See body of Sem_Elab for further details. This
+   --    field is Empty if no elaboration boolean is required.
+
+   --  Else_Actions (List3-Sem)
+   --    This field is present in conditional expression nodes. During code
+   --    expansion we use the Insert_Actions procedure (in Exp_Util) to insert
+   --    actions at an appropriate place in the tree to get elaborated at the
+   --    right time. For conditional expressions, we have to be sure that the
+   --    actions for the Else branch are only elaborated if the condition is
+   --    False. The Else_Actions field is used as a temporary parking place
+   --    for these actions. The final tree is always rewritten to eliminate
+   --    the need for this field, so in the tree passed to Gigi, this field
+   --    is always set to No_List.
+
+   --  Enclosing_Variant (Node2-Sem)
+   --    This field is present in the N_Variant node and identifies the
+   --    Node_Id corresponding to the immediately enclosing variant when
+   --    the variant is nested, and N_Empty otherwise. Set during semantic
+   --    processing of the variant part of a record type.
+
+   --  Entity (Node4-Sem)
+   --    Appears in all direct names (identifier, character literal,
+   --    operator symbol), as well as expanded names, and attributes that
+   --    denote entities, such as 'Class. Points to the entity for the
+   --    corresponding defining occurrence. Set after name resolution.
+   --    In the case of identifiers in a WITH list, the corresponding
+   --    defining occurrence is in a separately compiled file, and this
+   --    pointer must be set using the library Load procedure. Note that
+   --    during name resolution, the value in Entity may be temporarily
+   --    incorrect (e.g. during overload resolution, Entity is
+   --    initially set to the first possible correct interpretation, and
+   --    then later modified if necessary to contain the correct value
+   --    after resolution).
+
+   --  Etype (Node5-Sem)
+   --    Appears in all expression nodes, all direct names, and all
+   --    entities. Points to the entity for the related type. Set after
+   --    type resolution. Normally this is the actual subtype of the
+   --    expression. However, in certain contexts such as the right side
+   --    of an assignment, subscripts, arguments to calls, returned value
+   --    in a function, initial value etc. it is the desired target type.
+   --    In the event that this is different from the actual type, the
+   --    Do_Range_Check flag will be set if a range check is required.
+   --    Note: if the Is_Overloaded flag is set, then Etype points to
+   --    an essentially arbitrary choice from the possible set of types.
+
+   --  Exception_Junk (Flag11-Sem)
+   --    This flag is set in a various nodes appearing in a statement
+   --    sequence to indicate that the corresponding node is an artifact
+   --    of the generated code for exception handling, and should be
+   --    ignored when analyzing the control flow of the relevant sequence
+   --    of statements (e.g. to check that it does not end with a bad
+   --    return statement).
+
+   --  Expansion_Delayed (Flag11-Sem)
+   --    Set on aggregates and extension aggregates that need a top-down
+   --    rather than bottom up expansion. Typically aggregate expansion
+   --    happens bottom up. For nested aggregates the expansion is delayed
+   --    until the enclosing aggregate itself is expanded, e.g. in the context
+   --    of a declaration. To delay it we set this flag. This is done to
+   --    avoid creating a temporary for each level of a nested aggregates,
+   --    and also to prevent the premature generation of constraint checks.
+   --    This is also a requirement if we want to generate the proper
+   --    attachment to the internal finalization lists (for record with
+   --    controlled components). Top down expansion of aggregates is also
+   --    used for in-place array aggregate assignment or initialization.
+   --    When the full context is known, the target of the assignment or
+   --    initialization is used to generate the left-hand side of individual
+   --    assignment to each sub-component.
+
+   --  First_Inlined_Subprogram (Node3-Sem)
+   --    Present in the N_Compilation_Unit node for the main program. Points
+   --    to a chain of entities for subprograms that are to be inlined. The
+   --    Next_Inlined_Subprogram field of these entities is used as a link
+   --    pointer with Empty marking the end of the list. This field is Empty
+   --    if there are no inlined subprograms or inlining is not active.
+
+   --  First_Named_Actual (Node4-Sem)
+   --    Present in procedure call statement and function call nodes, and
+   --    also in Intrinsic nodes. Set during semantic analysis to point to
+   --    the first named parameter where parameters are ordered by declaration
+   --    order (as opposed to the actual order in the call which may be
+   --    different due to named associations). Note: this field points to the
+   --    explicit actual parameter itself, not the N_Parameter_Association
+   --    node (its parent).
+
+   --  First_Real_Statement (Node2-Sem)
+   --    Present in N_Handled_Sequence_Of_Statements node. Normally set to
+   --    Empty. Used only when declarations are moved into the statement
+   --    part of a construct as a result of wrapping an AT END handler that
+   --    is required to cover the declarations. In this case, this field is
+   --    used to remember the location in the statements list of the first
+   --    real statement, i.e. the statement that used to be first in the
+   --    statement list before the declarations were prepended.
+
+   --  First_Subtype_Link (Node5-Sem)
+   --    Present in N_Freeze_Entity node for an anonymous base type that
+   --    is implicitly created by the declaration of a first subtype. It
+   --    points to the entity for the first subtype.
+
+   --  Float_Truncate (Flag11-Sem)
+   --    A flag present in type conversion nodes. This is used for float
+   --    to integer conversions where truncation is required rather than
+   --    rounding. Note that Gigi does not handle type conversions from real
+   --    to integer with rounding (see Expand_N_Type_Conversion).
+
+   --  Forwards_OK (Flag5-Sem)
+   --    A flag present in the N_Assignment_Statement node. It is used only
+   --    if the type being assigned is an array type, and is set if analysis
+   --    determines that it is definitely safe to do the copy forwards, i.e.
+   --    starting at the lowest addressed element. Note that if neither of
+   --    the flags Forwards_OK or Backwards_OK is set, it means that the
+   --    front end could not determine that either direction is definitely
+   --    safe, and a runtime check is required.
+
+   --  From_At_Mod (Flag4-Sem)
+   --    This flag is set on the attribute definition clause node that is
+   --    generated by a transformation of an at mod phrase in a record
+   --    representation clause. This is used to give slightly different
+   --    (Ada 83 compatible) semantics to such a clause, namely it is
+   --    used to specify a minimum acceptable alignment for the base type
+   --    and all subtypes. In Ada 95 terms, the actual alignment of the
+   --    base type and all subtypes must be a multiple of the given value,
+   --    and the representation clause is considered to be type specific
+   --    instead of subtype specific.
+
+   --  Generic_Parent (Node5-Sem)
+   --    Generic_parent is defined on declaration nodes that are instances.
+   --    The value of Generic_Parent is the generic entity from which the
+   --    instance is obtained. Generic_Parent is also defined for the renaming
+   --    declarations and object declarations created for the actuals in an
+   --    instantiation. The generic parent of such a declaration is the
+   --    corresponding generic association in the Instantiation node.
+
+   --  Generic_Parent_Type (Node4-Sem)
+   --    Generic_Parent_Type is defined on Subtype_Declaration nodes for
+   --    the actuals of formal private and derived types. Within the instance,
+   --    the operations on the actual are those inherited from the parent.
+   --    For a formal private type, the parent type is the generic type
+   --    itself. The Generic_Parent_Type is also used in an instance to
+   --    determine whether a private operation overrides an inherited one.
+
+   --  Handler_List_Entry (Node2-Sem)
+   --    This field is present in N_Object_Declaration nodes. It is set only
+   --    for the Handler_Record entry generated for an exception in zero cost
+   --    exception handling mode. It references the corresponding item in the
+   --    handler list, and is used to delete this entry if the corresponding
+   --    handler is deleted during optimization. For further details on why
+   --    this is required, see Exp_Ch11.Remove_Handler_Entries.
+
+   --  Has_Dynamic_Length_Check (Flag10-Sem)
+   --    This flag is present on all nodes. It is set to indicate that one
+   --    of the routines in unit Checks has generated a length check action
+   --    which has been inserted at the flagged node. This is used to avoid
+   --    the generation of duplicate checks.
+
+   --  Has_Dynamic_Range_Check (Flag12-Sem)
+   --    This flag is present on all nodes. It is set to indicate that one
+   --    of the routines in unit Checks has generated a range check action
+   --    which has been inserted at the flagged node. This is used to avoid
+   --    the generation of duplicate checks.
+
+   --  Has_No_Elaboration_Code (Flag17-Sem)
+   --    A flag that appears in the N_Compilation_Unit node to indicate
+   --    whether or not elaboration code is present for this unit. It is
+   --    initially set true for subprogram specs and bodies and for all
+   --    generic units and false for non-generic package specs and bodies.
+   --    Gigi may set the flag in the non-generic package case if it
+   --    determines that no elaboration code is generated. Note that this
+   --    flag is not related to the Is_Preelaborated status, there can be
+   --    preelaborated packages that generate elaboration code, and non-
+   --    preelaborated packages which do not generate elaboration code.
+
+   --  Has_Priority_Pragma (Flag6-Sem)
+   --    A flag present in N_Subprogram_Body, N_Task_Definition and
+   --    N_Protected_Definition nodes to flag the presence of either
+   --    a Priority or Interrupt_Priority pragma in the declaration
+   --    sequence (public or private in the task and protected cases)
+
+   --  Has_Private_View (Flag11-Sem)
+   --    A flag present in generic nodes that have an entity, to indicate
+   --    that the node has a private type. Used to exchange private
+   --    and full declarations if the visibility at instantiation is
+   --    different from the visibility at generic definition.
+
+   --  Has_Storage_Size_Pragma (Flag5-Sem)
+   --    A flag present in an N_Task_Definition node to flag the presence
+   --    of a Storage_Size pragma
+
+   --  Has_Task_Info_Pragma (Flag7-Sem)
+   --    A flag present in an N_Task_Definition node to flag the presence
+   --    of a Task_Info pragma. Used to detect duplicate pragmas.
+
+   --  Has_Task_Name_Pragma (Flag8-Sem)
+   --    A flag present in N_Task_Definition nodes to flag the presence
+   --    of a Task_Name pragma in the declaration sequence for the task.
+
+   --  Has_Wide_Character (Flag11-Sem)
+   --    Present in string literals, set if any wide character (i.e. a
+   --    character code outside the Character range) appears in the string.
+
+   --  Hidden_By_Use_Clause (Elist4-Sem)
+   --     An entity list present in use clauses that appear within
+   --     instantiations. For the resolution of local entities, entities
+   --     introduced by these use clauses have priority over global ones,
+   --     and outer entities must be explicitly hidden/restored on exit.
+
+   --  Implicit_With (Flag17-Sem)
+   --    This flag is set in the N_With_Clause node that is implicitly
+   --    generated for runtime units that are loaded by the expander, and
+   --    also for package System, if it is loaded implicitly by a use of
+   --    the 'Address or 'Tag attribute
+
+   --  Includes_Infinities (Flag11-Sem)
+   --    This flag is present in N_Range nodes. It is set for the range
+   --    of unconstrained float types defined in Standard, which include
+   --    not only the given range of values, but also legtitimately can
+   --    include infinite values. This flag is false for any float type
+   --    for which an explicit range is given by the programmer, even if
+   --    that range is identical to the range for float.
+
+   --  Instance_Spec (Node5-Sem)
+   --    This field is present in generic instantiation nodes, and also in
+   --    formal package declaration nodes (formal package declarations are
+   --    treated in a manner very similar to package instantiations). It
+   --    points to the node for the spec of the instance, inserted as part
+   --    of the semantic processing for instantiations in Sem_Ch12.
+
+   --  Is_Asynchronous_Call_Block (Flag7-Sem)
+   --    A flag set in a Block_Statement node to indicate that it is the
+   --    expansion of an asynchronous entry call. Such a block needs a
+   --    cleanup handler to assure that the call is cancelled.
+
+   --  Is_Component_Left_Opnd  (Flag13-Sem)
+   --  Is_Component_Right_Opnd (Flag14-Sem)
+   --    Present in concatenation nodes, to indicate that the corresponding
+   --    operand is of the component type of the result. Used in resolving
+   --    concatenation nodes in instances.
+
+   --  Is_Controlling_Actual (Flag16-Sem)
+   --    This flag is set on in an expression that is a controlling argument
+   --    in a dispatching call. It is off in all other cases. See Sem_Disp
+   --    for details of its use.
+
+   --  Is_Machine_Number (Flag11-Sem)
+   --    This flag is set in an N_Real_Literal node to indicate that the
+   --    value is a machine number. This avoids some unnecessary cases
+   --    of converting real literals to machine numbers.
+
+   --  Is_Power_Of_2_For_Shift (Flag13-Sem)
+   --    A flag present only in N_Op_Expon nodes. It is set when the
+   --    exponentiation is of the forma 2 ** N, where the type of N is
+   --    an unsigned integral subtype whose size does not exceed the size
+   --    of Standard_Integer (i.e. a type that can be safely converted to
+   --    Natural), and the exponentiation appears as the right operand of
+   --    an integer multiplication or an integer division where the dividend
+   --    is unsigned. It is also required that overflow checking is off for
+   --    both the exponentiation and the multiply/divide node. If this set
+   --    of conditions holds, and the flag is set, then the division or
+   --    multiplication can be (and is) converted to a shift.
+
+   --  Is_Overloaded (Flag5-Sem)
+   --    A flag present in all expression nodes. Used temporarily during
+   --    overloading determination. The setting of this flag is not
+   --    relevant once overloading analysis is complete.
+
+   --  Is_Protected_Subprogram_Body (Flag7-Sem)
+   --    A flag set in a Subprogram_Body block to indicate that it is the
+   --    implemenation of a protected subprogram. Such a body needs a
+   --    cleanup handler to make sure that the associated protected object
+   --    is unlocked when the subprogram completes.
+
+   --  Is_Static_Expression (Flag6-Sem)
+   --    Indicates that an expression is a static expression (RM 4.9). See
+   --    spec of package Sem_Eval for full details on the use of this flag.
+
+   --  Is_Subprogram_Descriptor (Flag16-Sem)
+   --    Present in N_Object_Declaration, and set only for the object
+   --    declaration generated for a subprogram descriptor in fast exception
+   --    mode. See Exp_Ch11 for details of use.
+
+   --  Is_Task_Allocation_Block (Flag6-Sem)
+   --    A flag set in a Block_Statement node to indicate that it is the
+   --    expansion of a task allocator, or the allocator of an object
+   --    containing tasks. Such a block requires a cleanup handler to call
+   --    Expunge_Unactivted_Tasks to complete any tasks that have been
+   --    allocated but not activated when the allocator completes abnormally.
+
+   --  Is_Task_Master (Flag5-Sem)
+   --    A flag set in a Subprogram_Body, Block_Statement or Task_Body node
+   --    to indicate that the construct is a task master (i.e. has declared
+   --    tasks or declares an access to a task type).
+
+   --  Itype (Node1-Sem)
+   --    Used in N_Itype_Reference node to reference an itype for which it
+   --    is important to ensure that it is defined. See description of this
+   --    node for further details.
+
+   --  Kill_Range_Check (Flag11-Sem)
+   --    Used in an N_Unchecked_Type_Conversion node to indicate that the
+   --    result should not be subjected to range checks. This is used for
+   --    the implementation of Normalize_Scalars.
+
+   --  Label_Construct (Node2-Sem)
+   --    Used in an N_Implicit_Label_Declaration node. Refers to an N_Label,
+   --    N_Block_Statement or N_Loop_Statement node to which the label
+   --    declaration applies. This is not currently used in the compiler
+   --    itself, but it is useful in the implementation of ASIS queries.
+
+   --  Library_Unit (Node4-Sem)
+   --    In a stub node, the Library_Unit field points to the compilation unit
+   --    node of the corresponding subunit.
+   --
+   --    In a with clause node, the Library_Unit field points to the spec
+   --    of the with'ed unit.
+   --
+   --    In a compilation unit node, the use of this field depends on
+   --    the unit type:
+   --
+   --     For a subprogram body, the Library_Unit field points to the
+   --     compilation unit node of the corresponding spec, unless
+   --     Acts_As_Spec is set, in which case it points to itself.
+   --
+   --     For a package body, the Library_Unit field points to the
+   --     compilation unit node of the corresponding spec.
+   --
+   --     For a subprogram spec to which pragma Inline applies, the
+   --     Library_Unit field points to the compilation unit node of
+   --     the corresponding body, if inlining is active.
+   --
+   --     For a generic declaration, the Library_Unit field points
+   --     to the compilation unit node of the corresponding generic body.
+   --
+   --     For a subunit, the Library_Unit field points to the compilation
+   --     unit node of the parent body.
+   --
+   --    Note that this field is not used to hold the parent pointer for a
+   --    child unit (which might in any case need to use it for some other
+   --    purpose as described above). Instead for a child unit, implicit
+   --    with's are generated for all parents.
+
+   --  Loop_Actions (List2-Sem)
+   --    A list present in Component_Association nodes in array aggregates.
+   --    Used to collect actions that must be executed within the loop because
+   --    they may need to be evaluated anew each time through.
+
+   --  Must_Not_Freeze (Flag8-Sem)
+   --    A flag present in all expression nodes. Normally expressions cause
+   --    freezing as described in the RM. If this flag is set, then this
+   --    is inhibited. This is used by the analyzer and expander to label
+   --    nodes that are created by semantic analysis or expansion and which
+   --    must not cause freezing even though they normally would. This flag
+   --    is also present in an N_Subtype_Indication node, since we also use
+   --    these in calls to Freeze_Expression.
+
+   --  Next_Entity (Node2-Sem)
+   --    Present in defining identifiers, defining character literals and
+   --    defining operator symbols (i.e. in all entities). The entities of
+   --    a scope are chained, and this field is used as the forward pointer
+   --    for this list. See Einfo for further details.
+
+   --  Next_Named_Actual (Node4-Sem)
+   --    Present in parameter association node. Set during semantic
+   --    analysis to point to the next named parameter, where parameters
+   --    are ordered by declaration order (as opposed to the actual order
+   --    in the call, which may be different due to named associations).
+   --    Not that this field points to the explicit actual parameter itself,
+   --    not to the N_Parameter_Association node (its parent).
+
+   --  Next_Rep_Item (Node4-Sem)
+   --    Present in pragma nodes and attribute definition nodes. Used to
+   --    link representation items that apply to an entity. See description
+   --    of First_Rep_Item field in Einfo for full details.
+
+   --  Next_Use_Clause (Node3-Sem)
+   --    While use clauses are active during semantic processing, they
+   --    are chained from the scope stack entry, using Next_Use_Clause
+   --    as a link pointer, with Empty marking the end of the list. The
+   --    head pointer is in the scope stack entry (First_Use_Clause). At
+   --    the end of semantic processing (i.e. when Gigi sees the tree,
+   --    the contents of this field is undefined and should not be read).
+
+   --  No_Ctrl_Actions (Flag7-Sem)
+   --    Present in N_Assignment_Statement to indicate that no finalize nor
+   --    nor adjust should take place on this assignment eventhough the rhs
+   --    is controlled. This is used in init_procs and aggregate expansions
+   --    where the generated assignments are more initialisations than real
+   --    assignments.
+
+   --  No_Entities_Ref_In_Spec (Flag8-Sem)
+   --    Present in N_With_Clause nodes. Set if the with clause is on the
+   --    package or subprogram spec where the main unit is the corresponding
+   --    body, and no entities of the with'ed unit are referenced by the spec
+   --    (an entity may still be referenced in the body, so this flag is used
+   --    to generate the proper message (see Sem_Util.Check_Unused_Withs for
+   --    full details)
+
+   --  No_Initialization (Flag13-Sem)
+   --    Present in N_Object_Declaration & N_Allocator to indicate
+   --    that the object must not be initialized (by Initialize or a
+   --    call to _init_proc). This is needed for controlled aggregates.
+   --    When the Object declaration has an expression, this flag means
+   --    that this expression should not be taken into account (needed
+   --    for in place initialization with aggregates)
+
+   --  OK_For_Stream (Flag4-Sem)
+   --    Present in N_Attribute_Definition clauses for stream attributes. If
+   --    set, indicates that the attribute is permitted even though the type
+   --    involved is a limited type. In the case of a protected type, the
+   --    result is to stream all components (including discriminants) in
+   --    lexical order. For other limited types, the effect is simply to
+   --    use the corresponding stream routine for the full type. This flag
+   --    is used for internally generated code, where the streaming of these
+   --    types is required, even though not normally allowed by the language.
+
+   --  Original_Discriminant (Node2-Sem)
+   --    Present in identifiers. Used in references to discriminants that
+   --    appear in generic units. Because the names of the discriminants
+   --    may be different in  an instance, we use this field to recover the
+   --    position of the discriminant in the original type, and replace it
+   --    with the discriminant at the same position in the instantiated type.
+
+   --  Others_Discrete_Choices (List1-Sem)
+   --    When a case statement or variant is analyzed, the semantic checks
+   --    determine the actual list of choices that correspond to an others
+   --    choice. This list is materialized for later use by the expander
+   --    and the Others_Discrete_Choices field of an N_Others_Choice node
+   --    points to this materialized list of choices, which is in standard
+   --    format for a list of discrete choices, except that of course it
+   --    cannot contain an N_Others_Choice entry.
+
+   --  Parameter_List_Truncated (Flag17-Sem)
+   --    Present in N_Function_Call and N_Procedure_Call_Statement nodes.
+   --    Set (for OpenVMS ports of GNAT only) if the parameter list is
+   --    truncated as a result of a First_Optional_Parameter specification
+   --    in an Import_Function, Import_Procedure, or Import_Valued_Procedure
+   --    pragma. The truncation is done by the expander by removing trailing
+   --    parameters from the argument list, in accordance with the set of
+   --    rules allowing such parameter removal. In particular, parameters
+   --    can be removed working from the end of the parameter list backwards
+   --    up to and including the entry designated by First_Optional_Parameter
+   --    in the Import pragma. Parameters can be removed if they are implicit
+   --    and the default value is a known-at-compile-time value, including
+   --    the use of the Null_Parameter attribute, or if explicit parameter
+   --    values are present that match the corresponding defaults.
+
+   --  Parent_Spec (Node4-Sem)
+   --    For a library unit that is a child unit spec (package or subprogram
+   --    declaration, generic declaration or instantiation, or library level
+   --    rename, this field points to the compilation unit node for the parent
+   --    package specification. This field is Empty for library bodies (the
+   --    parent spec in this case can be found from the corresponding spec).
+
+   --  Present_Expr (Uint3-Sem)
+   --    Present in an N_Variant node. This has a meaningful value only after
+   --    Gigi has back annotated the tree with representation information.
+   --    At this point, it contains a reference to a gcc expression that
+   --    depends on the values of one or more discriminants. Give a set of
+   --    discriminant values, this expression evaluates to False (zero) if
+   --    variant is not present, and True (non-zero) if it is present. See
+   --    unit Repinfo for further details on gigi back annotation. This
+   --    field is used during ASIS processing (data decomposition annex)
+   --    to determine if a field is present or not.
+
+   --  Print_In_Hex (Flag13-Sem)
+   --    Set on an N_Integer_Literal node to indicate that the value should
+   --    be printed in hexadecimal in the sprint listing. Has no effect on
+   --    legality or semantics of program, only on the displayed output.
+   --    This is used to clarify output from the packed array cases.
+
+   --  Procedure_To_Call (Node4-Sem)
+   --    Present in N_Allocator. N_Free_Statement, and N_Return_Statement
+   --    nodes. References the entity for the declaration of the procedure
+   --    to be called to accomplish the required operation (i.e. for the
+   --    Allocate procedure in the case of N_Allocator and N_Return_Statement
+   --    (for allocating the return value), and for the Deallocate procedure
+   --    in the case of N_Free_Statement.
+
+   --  Raises_Constraint_Error (Flag7-Sem)
+   --    Set on an expression whose evaluation will definitely fail a
+   --    constraint error check. In the case of static expressions, this
+   --    flag must be set accurately (and if it is set, the expression is
+   --    typically illegal unless it appears as a non-elaborated branch of
+   --    a short-circuit form). For a non-static expression, this flag may
+   --    be set whenever an expression (e.g. an aggregate) is known to raise
+   --    constraint error. If set, the expression definitely will raise CE
+   --    if elaborated at runtime. If not set, the expression may or may
+   --    not raise CE. In other words, on static expressions, the flag is
+   --    set accurately, on non-static expressions it is set conservatively.
+
+   --  Redundant_Use (Flag13-Sem)
+   --    A flag present in nodes that can appear as an operand in a use
+   --    clause or use type clause (identifiers, expanded names, attribute
+   --    references). Set to indicate that a use is redundant (and therefore
+   --    need not be undone on scope exit).
+
+   --  Return_Type (Node2-Sem)
+   --    Present in N_Return_Statement node. For a procedure, this is set
+   --    to Standard_Void_Type. For a function it references the entity
+   --    for the returned type.
+
+   --  Rounded_Result (Flag18-Sem)
+   --    Present in N_Type_Conversion, N_Op_Divide and N_Op_Multiply nodes.
+   --    Used in the fixed-point cases to indicate that the result must be
+   --    rounded as a result of the use of the 'Round attribute. Also used
+   --    for integer N_Op_Divide nodes to indicate that the result should
+   --    be rounded to the nearest integer (breaking ties away from zero),
+   --    rather than truncated towards zero as usual. These rounded integer
+   --    operations are the result of expansion of rounded fixed-point
+   --    divide, conersion and multiplication operations.
+
+   --  Scope (Node3-Sem)
+   --    Present in defining identifiers, defining character literals and
+   --    defining operator symbols (i.e. in all entities). The entities of
+   --    a scope all use this field to reference the corresponding scope
+   --    entity. See Einfo for further details.
+
+   --  Shift_Count_OK (Flag4-Sem)
+   --    A flag present in shift nodes to indicate that the shift count is
+   --    known to be in range, i.e. is in the range from zero to word length
+   --    minus one. If this flag is not set, then the shift count may be
+   --    outside this range, i.e. larger than the word length, and the code
+   --    must ensure that such shift counts give the appropriate result.
+
+   --  Source_Type (Node1-Sem)
+   --    Used in an N_Validate_Unchecked_Conversion node to point to the
+   --    source type entity for the unchecked conversion instantiation
+   --    which gigi must do size validation for.
+
+   --  Static_Processing_OK (Flag4-Sem)
+   --    Present in N_Aggregate nodes. When the Compile_Time_Known_Aggregate
+   --    flag is set, the full value of the aggregate can be determined at
+   --    compile time and the aggregate can be passed as is to the back-end.
+   --    In this event it is irrelevant whether this flag is set or not.
+   --    However, if the Compile_Time_Known_Aggregate flag is not set but
+   --    Static_Processing_OK is set, the aggregate can (but need not) be
+   --    converted into a compile time known aggregate by the expander.
+   --    See Sem_Aggr for the specific conditions under which an aggregate
+   --    has its Static_Processing_OK flag set.
+
+   --  Storage_Pool (Node1-Sem)
+   --    Present in N_Allocator, N_Free_Statement and N_Return_Statement
+   --    nodes. References the entity for the storage pool to be used for
+   --    the allocate or free call or for the allocation of the returned
+   --    value from a function. Empty indicates that the global default
+   --    default pool is to be used. Note that in the case of a return
+   --    statement, this field is set only if the function returns a
+   --    value of a type whose size is not known at compile time on the
+   --    secondary stack. It is never set on targets for which the target
+   --    parameter Targparm.Functions_Return_By_DSP_On_Target is True.
+
+   --  Target_Type (Node2-Sem)
+   --    Used in an N_Validate_Unchecked_Conversion node to point to the
+   --    target type entity for the unchecked conversion instantiation
+   --    which gigi must do size validation for.
+
+   --  Task_Body_Procedure (Node2-Sem)
+   --    Present in task type declaration nodes. Points to the entity for
+   --    the task body procedure (as further described in Exp_Ch9, task
+   --    bodies are expanded into procedures). A convenient function to
+   --    retrieve this field is Sem_Util.Get_Task_Body_Procedure.
+
+   --  Then_Actions (List3-Sem)
+   --    This field is present in conditional expression nodes. During code
+   --    expansion we use the Insert_Actions procedure (in Exp_Util) to insert
+   --    actions at an appropriate place in the tree to get elaborated at the
+   --    right time. For conditional expressions, we have to be sure that the
+   --    actions for the Then branch are only elaborated if the condition is
+   --    True. The Then_Actions field is used as a temporary parking place
+   --    for these actions. The final tree is always rewritten to eliminate
+   --    the need for this field, so in the tree passed to Gigi, this field
+   --    is always set to No_List.
+
+   --  Treat_Fixed_As_Integer (Flag14-Sem)
+   --    This flag appears in operator nodes for divide, multiply, mod and
+   --    rem on fixed-point operands. It indicates that the operands are
+   --    to be treated as integer values, ignoring small values. This flag
+   --    is only set as a result of expansion of fixed-point operations.
+   --    Typically a fixed-point multplication in the source generates
+   --    subsidiary multiplication and division operations that work with
+   --    the underlying integer values and have this flag set. Note that
+   --    this flag is not needed on other arithmetic operations (add, neg,
+   --    subtract etc) since in these cases it is always the case that fixed
+   --    is treated as integer. The Etype field MUST be set if this flag
+   --    is set. The analyzer knows to leave such nodes alone, and whoever
+   --    makes them must set the correct Etype value.
+
+   --  TSS_Elist (Elist3-Sem)
+   --    Present in N_Freeze_Entity nodes. Holds an element list containing
+   --    entries for each TSS (type support subprogram) associated with the
+   --    frozen type. The elements of the list are the entities for the
+   --    subprograms (see package Exp_TSS for further details). Set to
+   --    No_Elist if there are no type support subprograms for the type
+   --    or if the freeze node is not for a type.
+
+   --  Unreferenced_In_Spec (Flag7-Sem)
+   --    Present in N_With_Clause nodes. Set if the with clause is on the
+   --    package or subprogram spec where the main unit is the corresponding
+   --    body, and is not referenced by the spec (it may still be referenced
+   --    by the body, so this flag is used to generate the proper message
+   --    (see Sem_Util.Check_Unused_Withs for details)
+
+   --  Was_Originally_Stub (Flag13-Sem)
+   --    This flag is set in the node for a proper body that replaces a
+   --    stub. During the analysis procedure, stubs in some situations
+   --    get rewritten by the corresponding bodies, and we set this flag
+   --    to remember that this happened. Note that it is not good enough
+   --    to rely on the use of Original_Tree here because of the case of
+   --    nested instantiations where the substituted node can be copied.
+
+   --  Zero_Cost_Handling (Flag5-Sem)
+   --    This flag is set in all handled sequence of statement and exception
+   --    handler nodes if eceptions are to be handled using the zero-cost
+   --    mechanism (see Ada.Exceptions and System.Exceptions in files
+   --    a-except.ads/adb and s-except.ads for full details). What gigi
+   --    needs to do for such a handler is simply to put the code in the
+   --    handler somewhere. The front end has generated all necessary labels.
+
+   --------------------------------------------------
+   -- Note on Use of End_Label and End_Span Fields --
+   --------------------------------------------------
+
+   --  Several constructs have end lines:
+
+   --    Loop Statement             end loop [loop_IDENTIFIER];
+   --    Package Specification      end [[PARENT_UNIT_NAME .] IDENTIFIER]
+   --    Task Definition            end [task_IDENTIFIER]
+   --    Protected Definition       end [protected_IDENTIFIER]
+   --    Protected Body             end [protected_IDENTIFIER]
+
+   --    Block Statement            end [block_IDENTIFIER];
+   --    Subprogram Body            end [DESIGNATOR];
+   --    Package Body               end [[PARENT_UNIT_NAME .] IDENTIFIER];
+   --    Task Body                  end [task_IDENTIFIER];
+   --    Accept Statement           end [entry_IDENTIFIER]];
+   --    Entry Body                 end [entry_IDENTIFIER];
+
+   --    If Statement               end if;
+   --    Case Statement             end case;
+
+   --    Record Definition          end record;
+
+   --  The End_Label and End_Span fields are used to mark the locations
+   --  of these lines, and also keep track of the label in the case where
+   --  a label is present.
+
+   --  For the first group above, the End_Label field of the corresponding
+   --  node is used to point to the label identifier. In the case where
+   --  there is no label in the source, the parser supplies a dummy
+   --  identifier (with Comes_From_Source set to False), and the Sloc
+   --  of this dummy identifier marks the location of the token following
+   --  the END token.
+
+   --  For the second group, the use of End_Label is similar, but the
+   --  End_Label is found in the N_Handled_Sequence_Of_Statements node.
+   --  This is done simply because in some cases there is no room in
+   --  the parent node.
+
+   --  For the third group, there is never any label, and instead of
+   --  using End_Label, we use the End_Span field which gives the
+   --  location of the token following END, relative to the starting
+   --  Sloc of the construct, i.e. add Sloc (Node) + End_Span (Node)
+   --  to get the Sloc of the IF or CASE following the End_Label.
+
+   --  The record definition case is handled specially, we treat it
+   --  as though it required an optional label which is never present,
+   --  and so the parser always builds a dummy identifier with Comes
+   --  From Source set False. The reason we do this, rather than using
+   --  End_Span in this case, is that we want to generate a cross-ref
+   --  entry for the end of a record, since it represents a scope for
+   --  name declaration purposes.
+
+   --  Note: the reason we store the difference as a Uint, instead of
+   --  storing the Source_Ptr value directly, is that Source_Ptr values
+   --  cannot be distinguished from other types of values, and we count
+   --  on all general use fields being self describing. To make things
+   --  easier for clients, note that we provide function End_Location,
+   --  and procedure Set_End_Location to allow access to the logical
+   --  value (which is the Source_Ptr value for the end token).
+
+   ---------------------
+   -- Syntactic Nodes --
+   ---------------------
+
+      ---------------------
+      -- 2.3  Identifier --
+      ---------------------
+
+      --  IDENTIFIER ::= IDENTIFIER_LETTER {[UNDERLINE] LETTER_OR_DIGIT}
+      --  LETTER_OR_DIGIT ::= IDENTIFIER_LETTER | DIGIT
+
+      --  An IDENTIFIER shall not be a reserved word
+
+      --  In the Ada grammar identifiers are the bottom level tokens which
+      --  have very few semantics. Actual program identifiers are direct
+      --  names. If we were being 100% honest with the grammar, then we would
+      --  have a node called N_Direct_Name which would point to an identifier.
+      --  However, that's too many extra nodes, so we just use the N_Identifier
+      --  node directly as a direct name, and it contains the expression fields
+      --  and Entity field that correspond to its use as a direct name. In
+      --  those few cases where identifiers appear in contexts where they are
+      --  not direct names (pragmas, pragma argument associations, attribute
+      --  references and attribute definition clauses), the Chars field of the
+      --  node contains the Name_Id for the identifier name.
+
+      --  Note: in GNAT, a reserved word can be treated as an identifier
+      --  in two cases. First, an incorrect use of a reserved word as an
+      --  identifier is diagnosed and then treated as a normal identifier.
+      --  Second, an attribute designator of the form of a reserved word
+      --  (access, delta, digits, range) is treated as an identifier.
+
+      --  Note: The set of letters that is permitted in an identifier depends
+      --  on the character set in use. See package Csets for full details.
+
+      --  N_Identifier
+      --  Sloc points to identifier
+      --  Chars (Name1) contains the Name_Id for the identifier
+      --  Entity (Node4-Sem)
+      --  Original_Discriminant (Node2-Sem)
+      --  Redundant_Use (Flag13-Sem)
+      --  Has_Private_View (Flag11-Sem) (set in generic units)
+      --  plus fields for expression
+
+      --------------------------
+      -- 2.4  Numeric Literal --
+      --------------------------
+
+      --  NUMERIC_LITERAL ::= DECIMAL_LITERAL | BASED_LITERAL
+
+      ----------------------------
+      -- 2.4.1  Decimal Literal --
+      ----------------------------
+
+      --  DECIMAL_LITERAL ::= NUMERAL [.NUMERAL] [EXPONENT]
+
+      --  NUMERAL ::= DIGIT {[UNDERLINE] DIGIT}
+
+      --  EXPONENT ::= E [+] NUMERAL | E - NUMERAL
+
+      --  Decimal literals appear in the tree as either integer literal nodes
+      --  or real literal nodes, depending on whether a period is present.
+
+      --  Note: literal nodes appear as a result of direct use of literals
+      --  in the source program, and also as the result of evaluating
+      --  expressions at compile time. In the latter case, it is possible
+      --  to construct real literals that have no syntactic representation
+      --  using the standard literal format. Such literals are listed by
+      --  Sprint using the notation [numerator / denominator].
+
+      --  N_Integer_Literal
+      --  Sloc points to literal
+      --  Intval (Uint3) contains integer value of literal
+      --  plus fields for expression
+      --  Print_In_Hex (Flag13-Sem)
+
+      --  N_Real_Literal
+      --  Sloc points to literal
+      --  Realval (Ureal3) contains real value of literal
+      --  Corresponding_Integer_Value (Uint4-Sem)
+      --  Is_Machine_Number (Flag11-Sem)
+      --  plus fields for expression
+
+      --------------------------
+      -- 2.4.2  Based Literal --
+      --------------------------
+
+      --  BASED_LITERAL ::=
+      --   BASE # BASED_NUMERAL [.BASED_NUMERAL] # [EXPONENT]
+
+      --  BASE ::= NUMERAL
+
+      --  BASED_NUMERAL ::=
+      --    EXTENDED_DIGIT {[UNDERLINE] EXTENDED_DIGIT}
+
+      --  EXTENDED_DIGIT ::= DIGIT | A | B | C | D | E | F
+
+      --  Based literals appear in the tree as either integer literal nodes
+      --  or real literal nodes, depending on whether a period is present.
+
+      ----------------------------
+      -- 2.5  Character Literal --
+      ----------------------------
+
+      --  CHARACTER_LITERAL ::= ' GRAPHIC_CHARACTER '
+
+      --  N_Character_Literal
+      --  Sloc points to literal
+      --  Chars (Name1) contains the Name_Id for the identifier
+      --  Char_Literal_Value (Char_Code2) contains the literal value
+      --  Entity (Node4-Sem)
+      --  Has_Private_View (Flag11-Sem) set in generic units.
+      --  plus fields for expression
+
+      --  Note: the Entity field will be missing (and set to Empty) for
+      --  character literals whose type is Standard.Wide_Character or
+      --  Standard.Character or a type derived from one of these two.
+      --  In this case the character literal stands for its own coding.
+      --  The reason we take this irregular short cut is to avoid the
+      --  need to build lots of junk defining character literal nodes.
+
+      -------------------------
+      -- 2.6  String Literal --
+      -------------------------
+
+      --  STRING LITERAL ::= "{STRING_ELEMENT}"
+
+      --  A STRING_ELEMENT is either a pair of quotation marks ("), or a
+      --  single GRAPHIC_CHARACTER other than a quotation mark.
+
+      --  N_String_Literal
+      --  Sloc points to literal
+      --  Strval (Str3) contains Id of string value
+      --  Has_Wide_Character (Flag11-Sem)
+      --  plus fields for expression
+
+      ------------------
+      -- 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.
+
+      --  Comments are skipped by the scanner and do not appear in the tree.
+      --  It is possible to reconstruct the position of comments with respect
+      --  to the elements of the tree by using the source position (Sloc)
+      --  pointers that appear in every tree node.
+
+      -----------------
+      -- 2.8  Pragma --
+      -----------------
+
+      --  PRAGMA ::= pragma IDENTIFIER
+      --    [(PRAGMA_ARGUMENT_ASSOCIATION {, PRAGMA_ARGUMENT_ASSOCIATION})];
+
+      --  Note that a pragma may appear in the tree anywhere a declaration
+      --  or a statement may appear, as well as in some other situations
+      --  which are explicitly documented.
+
+      --  N_Pragma
+      --  Sloc points to PRAGMA
+      --  Chars (Name1) identifier name from pragma identifier
+      --  Pragma_Argument_Associations (List2) (set to No_List if none)
+      --  Debug_Statement (Node3) (set to Empty if not Debug, Assert)
+      --  Next_Rep_Item (Node4-Sem)
+
+      --------------------------------------
+      -- 2.8  Pragma Argument Association --
+      --------------------------------------
+
+      --  PRAGMA_ARGUMENT_ASSOCIATION ::=
+      --    [pragma_argument_IDENTIFIER =>] NAME
+      --  | [pragma_argument_IDENTIFIER =>] EXPRESSION
+
+      --  N_Pragma_Argument_Association
+      --  Sloc points to first token in association
+      --  Chars (Name1) (set to No_Name if no pragma argument identifier)
+      --  Expression (Node3)
+
+      ------------------------
+      -- 2.9  Reserved Word --
+      ------------------------
+
+      --  Reserved words are parsed by the scanner, and returned as the
+      --  corresponding token types (e.g. PACKAGE is returned as Tok_Package)
+
+      ----------------------------
+      -- 3.1  Basic Declaration --
+      ----------------------------
+
+      --  BASIC_DECLARATION ::=
+      --    TYPE_DECLARATION          | SUBTYPE_DECLARATION
+      --  | OBJECT_DECLARATION        | NUMBER_DECLARATION
+      --  | SUBPROGRAM_DECLARATION    | ABSTRACT_SUBPROGRAM_DECLARATION
+      --  | PACKAGE_DECLARATION       | RENAMING_DECLARATION
+      --  | EXCEPTION_DECLARATION     | GENERIC_DECLARATION
+      --  | GENERIC_INSTANTIATION
+
+      --  Basic declaration also includes IMPLICIT_LABEL_DECLARATION
+      --  see further description in section on semantic nodes.
+
+      --  Also, in the tree that is constructed, a pragma may appear
+      --  anywhere that a declaration may appear.
+
+      ------------------------------
+      -- 3.1  Defining Identifier --
+      ------------------------------
+
+      --  DEFINING_IDENTIFIER ::= IDENTIFIER
+
+      --  A defining identifier is an entity, which has additional fields
+      --  depending on the setting of the Ekind field. These additional
+      --  fields are defined (and access subprograms declared) in package
+      --  Einfo.
+
+      --  Note: N_Defining_Identifier is an extended node whose fields are
+      --  deliberate layed out to match the layout of fields in an ordinary
+      --  N_Identifier node allowing for easy alteration of an identifier
+      --  node into a defining identifier node. For details, see procedure
+      --  Sinfo.CN.Change_Identifier_To_Defining_Identifier.
+
+      --  N_Defining_Identifier
+      --  Sloc points to identifier
+      --  Chars (Name1) contains the Name_Id for the identifier
+      --  Next_Entity (Node2-Sem)
+      --  Scope (Node3-Sem)
+      --  Etype (Node5-Sem)
+
+      -----------------------------
+      -- 3.2.1  Type Declaration --
+      -----------------------------
+
+      --  TYPE_DECLARATION ::=
+      --    FULL_TYPE_DECLARATION
+      --  | INCOMPLETE_TYPE_DECLARATION
+      --  | PRIVATE_TYPE_DECLARATION
+      --  | PRIVATE_EXTENSION_DECLARATION
+
+      ----------------------------------
+      -- 3.2.1  Full Type Declaration --
+      ----------------------------------
+
+      --  FULL_TYPE_DECLARATION ::=
+      --    type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART]
+      --      is TYPE_DEFINITION;
+      --  | TASK_TYPE_DECLARATION
+      --  | PROTECTED_TYPE_DECLARATION
+
+      --  The full type declaration node is used only for the first case. The
+      --  second case (concurrent type declaration), is represented directly
+      --  by a task type declaration or a protected type declaration.
+
+      --  N_Full_Type_Declaration
+      --  Sloc points to TYPE
+      --  Defining_Identifier (Node1)
+      --  Discriminant_Specifications (List4) (set to No_List if none)
+      --  Type_Definition (Node3)
+      --  Discr_Check_Funcs_Built (Flag11-Sem)
+
+      ----------------------------
+      -- 3.2.1  Type Definition --
+      ----------------------------
+
+      --  TYPE_DEFINITION ::=
+      --    ENUMERATION_TYPE_DEFINITION  | INTEGER_TYPE_DEFINITION
+      --  | REAL_TYPE_DEFINITION         | ARRAY_TYPE_DEFINITION
+      --  | RECORD_TYPE_DEFINITION       | ACCESS_TYPE_DEFINITION
+      --  | DERIVED_TYPE_DEFINITION
+
+      --------------------------------
+      -- 3.2.2  Subtype Declaration --
+      --------------------------------
+
+      --  SUBTYPE_DECLARATION ::=
+      --    subtype DEFINING_IDENTIFIER is SUBTYPE_INDICATION;
+
+      --  The subtype indication field is set to Empty for subtypes
+      --  declared in package Standard (Positive, Natural).
+
+      --  N_Subtype_Declaration
+      --  Sloc points to SUBTYPE
+      --  Defining_Identifier (Node1)
+      --  Subtype_Indication (Node5)
+      --  Generic_Parent_Type (Node4-Sem) (set for an actual derived type).
+      --  Exception_Junk (Flag11-Sem)
+
+      -------------------------------
+      -- 3.2.2  Subtype Indication --
+      -------------------------------
+
+      --  SUBTYPE_INDICATION ::= SUBTYPE_MARK [CONSTRAINT]
+
+      --  Note: if no constraint is present, the subtype indication appears
+      --  directly in the tree as a subtype mark. The N_Subtype_Indication
+      --  node is used only if a constraint is present.
+
+      --  Note: the reason that this node has expression fields is that a
+      --  subtype indication can appear as an operand of a membership test.
+
+      --  N_Subtype_Indication
+      --  Sloc points to first token of subtype mark
+      --  Subtype_Mark (Node4)
+      --  Constraint (Node3)
+      --  Etype (Node5-Sem)
+      --  Must_Not_Freeze (Flag8-Sem)
+
+      --  Note: Etype is a copy of the Etype field of the Subtype_Mark. The
+      --  reason for this redundancy is so that in a list of array index types,
+      --  the Etype can be uniformly accessed to determine the subscript type.
+      --  This means that no Itype is constructed for the actual subtype that
+      --  is created by the subtype indication. If such an Itype is required,
+      --  it is constructed in the context in which the indication appears.
+
+      -------------------------
+      -- 3.2.2  Subtype Mark --
+      -------------------------
+
+      --  SUBTYPE_MARK ::= subtype_NAME
+
+      -----------------------
+      -- 3.2.2  Constraint --
+      -----------------------
+
+      --  CONSTRAINT ::= SCALAR_CONSTRAINT | COMPOSITE_CONSTRAINT
+
+      ------------------------------
+      -- 3.2.2  Scalar Constraint --
+      ------------------------------
+
+      --  SCALAR_CONSTRAINT ::=
+      --    RANGE_CONSTRAINT | DIGITS_CONSTRAINT | DELTA_CONSTRAINT
+
+      ---------------------------------
+      -- 3.2.2  Composite Constraint --
+      ---------------------------------
+
+      --  COMPOSITE_CONSTRAINT ::=
+      --    INDEX_CONSTRAINT | DISCRIMINANT_CONSTRAINT
+
+      -------------------------------
+      -- 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
+
+      --  Note: aliased is not permitted in Ada 83 mode
+
+      --  The N_Object_Declaration node is only for the first two cases.
+      --  Single task declaration is handled by P_Task (9.1)
+      --  Single protected declaration is handled by P_protected (9.5)
+
+      --  Although the syntax allows multiple identifiers in the list, the
+      --  semantics is as though successive declarations were given with
+      --  identical type definition and expression components. To simplify
+      --  semantic processing, the parser represents a multiple declaration
+      --  case as a sequence of single declarations, using the More_Ids and
+      --  Prev_Ids flags to preserve the original source form as described
+      --  in the section on "Handling of Defining Identifier Lists".
+
+      --  Note: if a range check is required for the initialization
+      --  expression then the Do_Range_Check flag is set in the Expression,
+      --  with the check being done against the type given by the object
+      --  definition, which is also the Etype of the defining identifier.
+
+      --  Note: the contents of the Expression field must be ignored (i.e.
+      --  treated as though it were Empty) if No_Initialization is set True.
+
+      --  N_Object_Declaration
+      --  Sloc points to first identifier
+      --  Defining_Identifier (Node1)
+      --  Aliased_Present (Flag4) set if ALIASED appears
+      --  Constant_Present (Flag17) set if CONSTANT appears
+      --  Object_Definition (Node4) subtype indication/array type definition
+      --  Expression (Node3) (set to Empty if not present)
+      --  Handler_List_Entry (Node2-Sem)
+      --  Corresponding_Generic_Association (Node5-Sem)
+      --  More_Ids (Flag5) (set to False if no more identifiers in list)
+      --  Prev_Ids (Flag6) (set to False if no previous identifiers in list)
+      --  No_Initialization (Flag13-Sem)
+      --  Assignment_OK (Flag15-Sem)
+      --  Exception_Junk (Flag11-Sem)
+      --  Delay_Finalize_Attach (Flag14-Sem)
+      --  Is_Subprogram_Descriptor (Flag16-Sem)
+
+      -------------------------------------
+      -- 3.3.1  Defining Identifier List --
+      -------------------------------------
+
+      --  DEFINING_IDENTIFIER_LIST ::=
+      --    DEFINING_IDENTIFIER {, DEFINING_IDENTIFIER}
+
+      -------------------------------
+      -- 3.3.2  Number Declaration --
+      -------------------------------
+
+      --  NUMBER_DECLARATION ::=
+      --    DEFINING_IDENTIFIER_LIST : constant := static_EXPRESSION;
+
+      --  Although the syntax allows multiple identifiers in the list, the
+      --  semantics is as though successive declarations were given with
+      --  identical expressions. To simplify semantic processing, the parser
+      --  represents a multiple declaration case as a sequence of single
+      --  declarations, using the More_Ids and Prev_Ids flags to preserve
+      --  the original source form as described in the section on "Handling
+      --  of Defining Identifier Lists".
+
+      --  N_Number_Declaration
+      --  Sloc points to first identifier
+      --  Defining_Identifier (Node1)
+      --  Expression (Node3)
+      --  More_Ids (Flag5) (set to False if no more identifiers in list)
+      --  Prev_Ids (Flag6) (set to False if no previous identifiers in list)
+
+      ----------------------------------
+      -- 3.4  Derived Type Definition --
+      ----------------------------------
+
+      --  DERIVED_TYPE_DEFINITION ::=
+      --    [abstract] new parent_SUBTYPE_INDICATION [RECORD_EXTENSION_PART]
+
+      --  Note: ABSTRACT, record extension part not permitted in Ada 83 mode
+
+      --  Note: a record extension part is required if ABSTRACT is present
+
+      --  N_Derived_Type_Definition
+      --  Sloc points to NEW
+      --  Abstract_Present (Flag4)
+      --  Subtype_Indication (Node5)
+      --  Record_Extension_Part (Node3) (set to Empty if not present)
+
+      ---------------------------
+      -- 3.5  Range Constraint --
+      ---------------------------
+
+      --  RANGE_CONSTRAINT ::= range RANGE
+
+      --  N_Range_Constraint
+      --  Sloc points to RANGE
+      --  Range_Expression (Node4)
+
+      ----------------
+      -- 3.5  Range --
+      ----------------
+
+      --  RANGE ::=
+      --    RANGE_ATTRIBUTE_REFERENCE
+      --  | SIMPLE_EXPRESSION .. SIMPLE_EXPRESSION
+
+      --  Note: the case of a range given as a range attribute reference
+      --  appears directly in the tree as an attribute reference.
+
+      --  Note: the field name for a reference to a range is Range_Expression
+      --  rather than Range, because range is a reserved keyword in Ada!
+
+      --  Note: the reason that this node has expression fields is that a
+      --  range can appear as an operand of a membership test. The Etype
+      --  field is the type of the range (we do NOT construct an implicit
+      --  subtype to represent the range exactly).
+
+      --  N_Range
+      --  Sloc points to ..
+      --  Low_Bound (Node1)
+      --  High_Bound (Node2)
+      --  Includes_Infinities (Flag11)
+      --  plus fields for expression
+
+      --  Note: if the range appears in a context, such as a subtype
+      --  declaration, where range checks are required on one or both of
+      --  the expression fields, then type conversion nodes are inserted
+      --  to represent the required checks.
+
+      ----------------------------------------
+      -- 3.5.1  Enumeration Type Definition --
+      ----------------------------------------
+
+      --  ENUMERATION_TYPE_DEFINITION ::=
+      --    (ENUMERATION_LITERAL_SPECIFICATION
+      --      {, ENUMERATION_LITERAL_SPECIFICATION})
+
+      --  Note: the Literals field in the node described below is null for
+      --  the case of the standard types CHARACTER and WIDE_CHARACTER, for
+      --  which special processing handles these types as special cases.
+
+      --  N_Enumeration_Type_Definition
+      --  Sloc points to left parenthesis
+      --  Literals (List1) (Empty for CHARACTER or WIDE_CHARACTER)
+
+      ----------------------------------------------
+      -- 3.5.1  Enumeration Literal Specification --
+      ----------------------------------------------
+
+      --  ENUMERATION_LITERAL_SPECIFICATION ::=
+      --    DEFINING_IDENTIFIER | DEFINING_CHARACTER_LITERAL
+
+      ---------------------------------------
+      -- 3.5.1  Defining Character Literal --
+      ---------------------------------------
+
+      --  DEFINING_CHARACTER_LITERAL ::= CHARACTER_LITERAL
+
+      --  A defining character literal is an entity, which has additional
+      --  fields depending on the setting of the Ekind field. These
+      --  additional fields are defined (and access subprograms declared)
+      --  in package Einfo.
+
+      --  Note: N_Defining_Character_Literal is an extended node whose fields
+      --  are deliberate layed out to match the layout of fields in an ordinary
+      --  N_Character_Literal node allowing for easy alteration of a character
+      --  literal node into a defining character literal node. For details, see
+      --  Sinfo.CN.Change_Character_Literal_To_Defining_Character_Literal.
+
+      --  N_Defining_Character_Literal
+      --  Sloc points to literal
+      --  Chars (Name1) contains the Name_Id for the identifier
+      --  Next_Entity (Node2-Sem)
+      --  Scope (Node3-Sem)
+      --  Etype (Node5-Sem)
+
+      ------------------------------------
+      -- 3.5.4  Integer Type Definition --
+      ------------------------------------
+
+      --  Note: there is an error in this rule in the latest version of the
+      --  grammar, so we have retained the old rule pending clarification.
+
+      --  INTEGER_TYPE_DEFINITION ::=
+      --    SIGNED_INTEGER_TYPE_DEFINITION
+      --    MODULAR_TYPE_DEFINITION
+
+      -------------------------------------------
+      -- 3.5.4  Signed Integer Type Definition --
+      -------------------------------------------
+
+      --  SIGNED_INTEGER_TYPE_DEFINITION ::=
+      --    range static_SIMPLE_EXPRESSION .. static_SIMPLE_EXPRESSION
+
+      --  Note: the Low_Bound and High_Bound fields are set to Empty for
+      --  integer types defined in package Standard.
+
+      --  N_Signed_Integer_Type_Definition
+      --  Sloc points to RANGE
+      --  Low_Bound (Node1)
+      --  High_Bound (Node2)
+
+      -----------------------------------------
+      -- 3.5.4  Unsigned Range Specification --
+      -----------------------------------------
+
+      --  MODULAR_TYPE_DEFINITION ::= mod static_EXPRESSION
+
+      --  N_Modular_Type_Definition
+      --  Sloc points to MOD
+      --  Expression (Node3)
+
+      ---------------------------------
+      -- 3.5.6  Real Type Definition --
+      ---------------------------------
+
+      --  REAL_TYPE_DEFINITION ::=
+      --    FLOATING_POINT_DEFINITION | FIXED_POINT_DEFINITION
+
+      --------------------------------------
+      -- 3.5.7  Floating Point Definition --
+      --------------------------------------
+
+      --  FLOATING_POINT_DEFINITION ::=
+      --    digits static_SIMPLE_EXPRESSION [REAL_RANGE_SPECIFICATION]
+
+      --  Note: The Digits_Expression and Real_Range_Specifications fields
+      --  are set to Empty for floating-point types declared in Standard.
+
+      --  N_Floating_Point_Definition
+      --  Sloc points to DIGITS
+      --  Digits_Expression (Node2)
+      --  Real_Range_Specification (Node4) (set to Empty if not present)
+
+      -------------------------------------
+      -- 3.5.7  Real Range Specification --
+      -------------------------------------
+
+      --  REAL_RANGE_SPECIFICATION ::=
+      --    range static_SIMPLE_EXPRESSION .. static_SIMPLE_EXPRESSION
+
+      --  N_Real_Range_Specification
+      --  Sloc points to RANGE
+      --  Low_Bound (Node1)
+      --  High_Bound (Node2)
+
+      -----------------------------------
+      -- 3.5.9  Fixed Point Definition --
+      -----------------------------------
+
+      --  FIXED_POINT_DEFINITION ::=
+      --    ORDINARY_FIXED_POINT_DEFINITION | DECIMAL_FIXED_POINT_DEFINITION
+
+      --------------------------------------------
+      -- 3.5.9  Ordinary Fixed Point Definition --
+      --------------------------------------------
+
+      --  ORDINARY_FIXED_POINT_DEFINITION ::=
+      --    delta static_EXPRESSION REAL_RANGE_SPECIFICATION
+
+      --  Note: In Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION
+
+      --  Note: the Delta_Expression and Real_Range_Specification fields
+      --  are set to Empty for fixed point types declared in Standard.
+
+      --  N_Ordinary_Fixed_Point_Definition
+      --  Sloc points to DELTA
+      --  Delta_Expression (Node3)
+      --  Real_Range_Specification (Node4)
+
+      -------------------------------------------
+      -- 3.5.9  Decimal Fixed Point Definition --
+      -------------------------------------------
+
+      --  DECIMAL_FIXED_POINT_DEFINITION ::=
+      --    delta static_EXPRESSION
+      --      digits static_EXPRESSION [REAL_RANGE_SPECIFICATION]
+
+      --  Note: decimal types are not permitted in Ada 83 mode
+
+      --  N_Decimal_Fixed_Point_Definition
+      --  Sloc points to DELTA
+      --  Delta_Expression (Node3)
+      --  Digits_Expression (Node2)
+      --  Real_Range_Specification (Node4) (set to Empty if not present)
+
+      ------------------------------
+      -- 3.5.9  Digits Constraint --
+      ------------------------------
+
+      --  DIGITS_CONSTRAINT ::=
+      --    digits static_EXPRESSION [RANGE_CONSTRAINT]
+
+      --  Note: in Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION
+      --  Note: in Ada 95, reduced accuracy subtypes are obsolescent
+
+      --  N_Digits_Constraint
+      --  Sloc points to DIGITS
+      --  Digits_Expression (Node2)
+      --  Range_Constraint (Node4) (set to Empty if not present)
+
+      --------------------------------
+      -- 3.6  Array Type Definition --
+      --------------------------------
+
+      --  ARRAY_TYPE_DEFINITION ::=
+      --    UNCONSTRAINED_ARRAY_DEFINITION | CONSTRAINED_ARRAY_DEFINITION
+
+      -----------------------------------------
+      -- 3.6  Unconstrained Array Definition --
+      -----------------------------------------
+
+      --  UNCONSTRAINED_ARRAY_DEFINITION ::=
+      --    array (INDEX_SUBTYPE_DEFINITION {, INDEX_SUBTYPE_DEFINITION}) of
+      --      COMPONENT_DEFINITION
+
+      --  Note: dimensionality of array is indicated by number of entries in
+      --  the Subtype_Marks list, which has one entry for each dimension.
+
+      --  N_Unconstrained_Array_Definition
+      --  Sloc points to ARRAY
+      --  Subtype_Marks (List2)
+      --  Aliased_Present (Flag4) from component definition
+      --  Subtype_Indication (Node5) from component definition
+
+      -----------------------------------
+      -- 3.6  Index Subtype Definition --
+      -----------------------------------
+
+      --  INDEX_SUBTYPE_DEFINITION ::= SUBTYPE_MARK range <>
+
+      --  There is no explicit node in the tree for an index subtype
+      --  definition since the N_Unconstrained_Array_Definition node
+      --  incorporates the type marks which appear in this context.
+
+      ---------------------------------------
+      -- 3.6  Constrained Array Definition --
+      ---------------------------------------
+
+      --  CONSTRAINED_ARRAY_DEFINITION ::=
+      --    array (DISCRETE_SUBTYPE_DEFINITION
+      --      {, DISCRETE_SUBTYPE_DEFINITION})
+      --        of COMPONENT_DEFINITION
+
+      --  Note: dimensionality of array is indicated by number of entries
+      --  in the Discrete_Subtype_Definitions list, which has one entry
+      --  for each dimension.
+
+      --  N_Constrained_Array_Definition
+      --  Sloc points to ARRAY
+      --  Discrete_Subtype_Definitions (List2)
+      --  Aliased_Present (Flag4) from component definition
+      --  Subtype_Indication (Node5) from component definition
+
+      --------------------------------------
+      -- 3.6  Discrete Subtype Definition --
+      --------------------------------------
+
+      --  DISCRETE_SUBTYPE_DEFINITION ::=
+      --    discrete_SUBTYPE_INDICATION | RANGE
+
+      -------------------------------
+      -- 3.6  Component Definition --
+      -------------------------------
+
+      --  COMPONENT_DEFINITION ::= [aliased] SUBTYPE_INDICATION
+
+      --  There is no explicit node in the tree for a component definition.
+      --  Instead the subtype indication appears directly, and the ALIASED
+      --  indication (Aliased_Present flag) is in the parent node.
+
+      --  Note: although the syntax does not permit a component definition to
+      --  be an anonymous array (and the parser will diagnose such an attempt
+      --  with an appropriate message), it is possible for anonymous arrays
+      --  to appear as component definitions. The semantics and back end handle
+      --  this case properly, and the expander in fact generates such cases.
+
+      -----------------------------
+      -- 3.6.1  Index Constraint --
+      -----------------------------
+
+      --  INDEX_CONSTRAINT ::= (DISCRETE_RANGE {, DISCRETE_RANGE})
+
+      --  It is not in general possible to distinguish between discriminant
+      --  constraints and index constraints at parse time, since a simple
+      --  name could be either the subtype mark of a discrete range, or an
+      --  expression in a discriminant association with no name. Either
+      --  entry appears simply as the name, and the semantic parse must
+      --  distinguish between the two cases. Thus we use a common tree
+      --  node format for both of these constraint types.
+
+      --  See Discriminant_Constraint for format of node
+
+      ---------------------------
+      -- 3.6.1  Discrete Range --
+      ---------------------------
+
+      --  DISCRETE_RANGE ::= discrete_SUBTYPE_INDICATION | RANGE
+
+      ----------------------------
+      -- 3.7  Discriminant Part --
+      ----------------------------
+
+      --  DISCRIMINANT_PART ::=
+      --    UNKNOWN_DISCRIMINANT_PART | KNOWN_DISCRIMINANT_PART
+
+      ------------------------------------
+      -- 3.7  Unknown Discriminant Part --
+      ------------------------------------
+
+      --  UNKNOWN_DISCRIMINANT_PART ::= (<>)
+
+      --  Note: unknown discriminant parts are not permitted in Ada 83 mode
+
+      --  There is no explicit node in the tree for an unknown discriminant
+      --  part. Instead the Unknown_Discriminants_Present flag is set in the
+      --  parent node.
+
+      ----------------------------------
+      -- 3.7  Known Discriminant Part --
+      ----------------------------------
+
+      --  KNOWN_DISCRIMINANT_PART ::=
+      --    (DISCRIMINANT_SPECIFICATION {; DISCRIMINANT_SPECIFICATION})
+
+      -------------------------------------
+      -- 3.7  Discriminant Specification --
+      -------------------------------------
+
+      --  DISCRIMINANT_SPECIFICATION ::=
+      --    DEFINING_IDENTIFIER_LIST : SUBTYPE_MARK
+      --      [:= DEFAULT_EXPRESSION]
+      --  | DEFINING_IDENTIFIER_LIST : ACCESS_DEFINITION
+      --      [:= DEFAULT_EXPRESSION]
+
+      --  Although the syntax allows multiple identifiers in the list, the
+      --  semantics is as though successive specifications were given with
+      --  identical type definition and expression components. To simplify
+      --  semantic processing, the parser represents a multiple declaration
+      --  case as a sequence of single specifications, using the More_Ids and
+      --  Prev_Ids flags to preserve the original source form as described
+      --  in the section on "Handling of Defining Identifier Lists".
+
+      --  N_Discriminant_Specification
+      --  Sloc points to first identifier
+      --  Defining_Identifier (Node1)
+      --  Discriminant_Type (Node5) subtype mark or
+      --    access parameter definition
+      --  Expression (Node3) (set to Empty if no default expression)
+      --  More_Ids (Flag5) (set to False if no more identifiers in list)
+      --  Prev_Ids (Flag6) (set to False if no previous identifiers in list)
+
+      -----------------------------
+      -- 3.7  Default Expression --
+      -----------------------------
+
+      --  DEFAULT_EXPRESSION ::= EXPRESSION
+
+      ------------------------------------
+      -- 3.7.1  Discriminant Constraint --
+      ------------------------------------
+
+      --  DISCRIMINANT_CONSTRAINT ::=
+      --    (DISCRIMINANT_ASSOCIATION {, DISCRIMINANT_ASSOCIATION})
+
+      --  It is not in general possible to distinguish between discriminant
+      --  constraints and index constraints at parse time, since a simple
+      --  name could be either the subtype mark of a discrete range, or an
+      --  expression in a discriminant association with no name. Either
+      --  entry appears simply as the name, and the semantic parse must
+      --  distinguish between the two cases. Thus we use a common tree
+      --  node format for both of these constraint types.
+
+      --  N_Index_Or_Discriminant_Constraint
+      --  Sloc points to left paren
+      --  Constraints (List1) points to list of discrete ranges or
+      --    discriminant associations
+
+      -------------------------------------
+      -- 3.7.1  Discriminant Association --
+      -------------------------------------
+
+      --  DISCRIMINANT_ASSOCIATION ::=
+      --    [discriminant_SELECTOR_NAME
+      --      {| discriminant_SELECTOR_NAME} =>] EXPRESSION
+
+      --  Note: a discriminant association that has no selector name list
+      --  appears directly as an expression in the tree.
+
+      --  N_Discriminant_Association
+      --  Sloc points to first token of discriminant association
+      --  Selector_Names (List1) (always non-empty, since if no selector
+      --   names are present, this node is not used, see comment above)
+      --  Expression (Node3)
+
+      ---------------------------------
+      -- 3.8  Record Type Definition --
+      ---------------------------------
+
+      --  RECORD_TYPE_DEFINITION ::=
+      --    [[abstract] tagged] [limited] RECORD_DEFINITION
+
+      --  Note: ABSTRACT, TAGGED, LIMITED are not permitted in Ada 83 mode
+
+      --  There is no explicit node in the tree for a record type definition.
+      --  Instead the flags for Tagged_Present and Limited_Present appear in
+      --  the N_Record_Definition node for a record definition appearing in
+      --  the context of a record type definition.
+
+      ----------------------------
+      -- 3.8  Record Definition --
+      ----------------------------
+
+      --  RECORD_DEFINITION ::=
+      --    record
+      --      COMPONENT_LIST
+      --    end record
+      --  | null record
+
+      --  Note: the Abstract_Present, Tagged_Present and Limited_Present
+      --  flags appear only for a record definition appearing in a record
+      --  type definition.
+
+      --  Note: the NULL RECORD case is not permitted in Ada 83
+
+      --  N_Record_Definition
+      --  Sloc points to RECORD or NULL
+      --  End_Label (Node4) (set to Empty if internally generated record)
+      --  Abstract_Present (Flag4)
+      --  Tagged_Present (Flag15)
+      --  Limited_Present (Flag17)
+      --  Component_List (Node1) empty in null record case
+      --  Null_Present (Flag13) set in null record case
+
+      -------------------------
+      -- 3.8  Component List --
+      -------------------------
+
+      --  COMPONENT_LIST ::=
+      --    COMPONENT_ITEM {COMPONENT_ITEM}
+      --  | {COMPONENT_ITEM} VARIANT_PART
+      --  | null;
+
+      --  N_Component_List
+      --  Sloc points to first token of component list
+      --  Component_Items (List3)
+      --  Variant_Part (Node4) (set to Empty if no variant part)
+      --  Null_Present (Flag13)
+
+      -------------------------
+      -- 3.8  Component Item --
+      -------------------------
+
+      --  COMPONENT_ITEM ::= COMPONENT_DECLARATION | REPRESENTATION_CLAUSE
+
+      --  Note: A component item can also be a pragma, and in the tree
+      --  that is obtained after semantic processing, a component item
+      --  can be an N_Null node resulting from a non-recognized pragma.
+
+      --------------------------------
+      -- 3.8  Component Declaration --
+      --------------------------------
+
+      --  COMPONENT_DECLARATION ::=
+      --    DEFINING_IDENTIFIER_LIST : COMPONENT_DEFINITION
+      --      [:= DEFAULT_EXPRESSION]
+
+      --  Note: although the syntax does not permit a component definition to
+      --  be an anonymous array (and the parser will diagnose such an attempt
+      --  with an appropriate message), it is possible for anonymous arrays
+      --  to appear as component definitions. The semantics and back end handle
+      --  this case properly, and the expander in fact generates such cases.
+
+      --  Although the syntax allows multiple identifiers in the list, the
+      --  semantics is as though successive declarations were given with the
+      --  same component definition and expression components. To simplify
+      --  semantic processing, the parser represents a multiple declaration
+      --  case as a sequence of single declarations, using the More_Ids and
+      --  Prev_Ids flags to preserve the original source form as described
+      --  in the section on "Handling of Defining Identifier Lists".
+
+      --  N_Component_Declaration
+      --  Sloc points to first identifier
+      --  Defining_Identifier (Node1)
+      --  Aliased_Present (Flag4) from component definition
+      --  Subtype_Indication (Node5) from component definition
+      --  Expression (Node3) (set to Empty if no default expression)
+      --  More_Ids (Flag5) (set to False if no more identifiers in list)
+      --  Prev_Ids (Flag6) (set to False if no previous identifiers in list)
+
+      -------------------------
+      -- 3.8.1  Variant Part --
+      -------------------------
+
+      --  VARIANT_PART ::=
+      --    case discriminant_DIRECT_NAME is
+      --      VARIANT
+      --      {VARIANT}
+      --    end case;
+
+      --  Note: the variants list can contain pragmas as well as variants.
+      --  In a properly formed program there is at least one variant.
+
+      --  N_Variant_Part
+      --  Sloc points to CASE
+      --  Name (Node2)
+      --  Variants (List1)
+
+      --------------------
+      -- 3.8.1  Variant --
+      --------------------
+
+      --  VARIANT ::=
+      --    when DISCRETE_CHOICE_LIST =>
+      --      COMPONENT_LIST
+
+      --  N_Variant
+      --  Sloc points to WHEN
+      --  Discrete_Choices (List4)
+      --  Component_List (Node1)
+      --  Enclosing_Variant (Node2-Sem)
+      --  Present_Expr (Uint3-Sem)
+      --  Dcheck_Function (Node5-Sem)
+
+      ---------------------------------
+      -- 3.8.1  Discrete Choice List --
+      ---------------------------------
+
+      --  DISCRETE_CHOICE_LIST ::= DISCRETE_CHOICE {| DISCRETE_CHOICE}
+
+      ----------------------------
+      -- 3.8.1  Discrete Choice --
+      ----------------------------
+
+      --  DISCRETE_CHOICE ::= EXPRESSION | DISCRETE_RANGE | others
+
+      --  Note: in Ada 83 mode, the expression must be a simple expression
+
+      --  The only choice that appears explicitly is the OTHERS choice, as
+      --  defined here. Other cases of discrete choice (expression and
+      --  discrete range) appear directly. This production is also used
+      --  for the OTHERS possibility of an exception choice.
+
+      --  Note: in accordance with the syntax, the parser does not check that
+      --  OTHERS appears at the end on its own in a choice list context. This
+      --  is a semantic check.
+
+      --  N_Others_Choice
+      --  Sloc points to OTHERS
+      --  Others_Discrete_Choices (List1-Sem)
+      --  All_Others (Flag11-Sem)
+
+      ----------------------------------
+      -- 3.9.1  Record Extension Part --
+      ----------------------------------
+
+      --  RECORD_EXTENSION_PART ::= with RECORD_DEFINITION
+
+      --  Note: record extension parts are not permitted in Ada 83 mode
+
+      ----------------------------------
+      -- 3.10  Access Type Definition --
+      ----------------------------------
+
+      --  ACCESS_TYPE_DEFINITION ::=
+      --    ACCESS_TO_OBJECT_DEFINITION
+      --  | ACCESS_TO_SUBPROGRAM_DEFINITION
+
+      ---------------------------------------
+      -- 3.10  Access To Object Definition --
+      ---------------------------------------
+
+      --  ACCESS_TO_OBJECT_DEFINITION ::=
+      --    access [GENERAL_ACCESS_MODIFIER] SUBTYPE_INDICATION
+
+      --  N_Access_To_Object_Definition
+      --  Sloc points to ACCESS
+      --  All_Present (Flag15)
+      --  Subtype_Indication (Node5)
+      --  Constant_Present (Flag17)
+
+      -----------------------------------
+      -- 3.10  General Access Modifier --
+      -----------------------------------
+
+      --  GENERAL_ACCESS_MODIFIER ::= all | constant
+
+      --  Note: general access modifiers are not permitted in Ada 83 mode
+
+      --  There is no explicit node in the tree for general access modifier.
+      --  Instead the All_Present or Constant_Present flags are set in the
+      --  parent node.
+
+      -------------------------------------------
+      -- 3.10  Access To Subprogram Definition --
+      -------------------------------------------
+
+      --  ACCESS_TO_SUBPROGRAM_DEFINITION
+      --    access [protected] procedure PARAMETER_PROFILE
+      --  | access [protected] function PARAMETER_AND_RESULT_PROFILE
+
+      --  Note: access to subprograms are not permitted in Ada 83 mode
+
+      --  N_Access_Function_Definition
+      --  Sloc points to ACCESS
+      --  Protected_Present (Flag15)
+      --  Parameter_Specifications (List3) (set to No_List if no formal part)
+      --  Subtype_Mark (Node4) result subtype
+
+      --  N_Access_Procedure_Definition
+      --  Sloc points to ACCESS
+      --  Protected_Present (Flag15)
+      --  Parameter_Specifications (List3) (set to No_List if no formal part)
+
+      -----------------------------
+      -- 3.10  Access Definition --
+      -----------------------------
+
+      --  ACCESS_DEFINITION ::= access SUBTYPE_MARK
+
+      --  N_Access_Definition
+      --  Sloc points to ACCESS
+      --  Subtype_Mark (Node4)
+
+      -----------------------------------------
+      -- 3.10.1  Incomplete Type Declaration --
+      -----------------------------------------
+
+      --  INCOMPLETE_TYPE_DECLARATION ::=
+      --    type DEFINING_IDENTIFIER [DISCRIMINANT_PART];
+
+      --  N_Incomplete_Type_Declaration
+      --  Sloc points to TYPE
+      --  Defining_Identifier (Node1)
+      --  Discriminant_Specifications (List4) (set to No_List if no
+      --   discriminant part, or if the discriminant part is an
+      --   unknown discriminant part)
+      --  Unknown_Discriminants_Present (Flag13) set if (<>) discriminant
+
+      ----------------------------
+      -- 3.11  Declarative Part --
+      ----------------------------
+
+      --  DECLARATIVE_PART ::= {DECLARATIVE_ITEM}
+
+      --  Note: although the parser enforces the syntactic requirement that
+      --  a declarative part can contain only declarations, the semantic
+      --  processing may add statements to the list of actions in a
+      --  declarative part, so the code generator should be prepared
+      --  to accept a statement in this position.
+
+      ----------------------------
+      -- 3.11  Declarative Item --
+      ----------------------------
+
+      --  DECLARATIVE_ITEM ::= BASIC_DECLARATIVE_ITEM | BODY
+
+      ----------------------------------
+      -- 3.11  Basic Declarative Item --
+      ----------------------------------
+
+      --  BASIC_DECLARATIVE_ITEM ::=
+      --    BASIC_DECLARATION | REPRESENTATION_CLAUSE | USE_CLAUSE
+
+      ----------------
+      -- 3.11  Body --
+      ----------------
+
+      --  BODY ::= PROPER_BODY | BODY_STUB
+
+      -----------------------
+      -- 3.11  Proper Body --
+      -----------------------
+
+      --  PROPER_BODY ::=
+      --    SUBPROGRAM_BODY | PACKAGE_BODY | TASK_BODY | PROTECTED_BODY
+
+      ---------------
+      -- 4.1  Name --
+      ---------------
+
+      --  NAME ::=
+      --    DIRECT_NAME        | EXPLICIT_DEREFERENCE
+      --  | INDEXED_COMPONENT  | SLICE
+      --  | SELECTED_COMPONENT | ATTRIBUTE_REFERENCE
+      --  | TYPE_CONVERSION    | FUNCTION_CALL
+      --  | CHARACTER_LITERAL
+
+      ----------------------
+      -- 4.1  Direct Name --
+      ----------------------
+
+      --  DIRECT_NAME ::= IDENTIFIER | OPERATOR_SYMBOL
+
+      -----------------
+      -- 4.1  Prefix --
+      -----------------
+
+      --  PREFIX ::= NAME | IMPLICIT_DEREFERENCE
+
+      -------------------------------
+      -- 4.1  Explicit Dereference --
+      -------------------------------
+
+      --  EXPLICIT_DEREFERENCE ::= NAME . all
+
+      --  N_Explicit_Dereference
+      --  Sloc points to ALL
+      --  Prefix (Node3)
+      --  Do_Access_Check (Flag11-Sem)
+      --  plus fields for expression
+
+      -------------------------------
+      -- 4.1  Implicit Dereference --
+      -------------------------------
+
+      --  IMPLICIT_DEREFERENCE ::= NAME
+
+      ------------------------------
+      -- 4.1.1  Indexed Component --
+      ------------------------------
+
+      --  INDEXED_COMPONENT ::= PREFIX (EXPRESSION {, EXPRESSION})
+
+      --  Note: the parser may generate this node in some situations where it
+      --  should be a function call. The semantic  pass must correct this
+      --  misidentification (which is inevitable at the parser level).
+
+      --  N_Indexed_Component
+      --  Sloc contains a copy of the Sloc value of the Prefix
+      --  Prefix (Node3)
+      --  Expressions (List1)
+      --  Do_Access_Check (Flag11-Sem)
+      --  plus fields for expression
+
+      --  Note: if any of the subscripts requires a range check, then the
+      --  Do_Range_Check flag is set on the corresponding expression, with
+      --  the index type being determined from the type of the Prefix, which
+      --  references the array being indexed.
+
+      --  Note: in a fully analyzed and expanded indexed component node, and
+      --  hence in any such node that gigi sees, if the prefix is an access
+      --  type, then an explicit dereference operation has been inserted.
+
+      ------------------
+      -- 4.1.2  Slice --
+      ------------------
+
+      --  SLICE ::= PREFIX (DISCRETE_RANGE)
+
+      --  Note: an implicit subtype is created to describe the resulting
+      --  type, so that the bounds of this type are the bounds of the slice.
+
+      --  N_Slice
+      --  Sloc points to first token of prefix
+      --  Prefix (Node3)
+      --  Discrete_Range (Node4)
+      --  Do_Access_Check (Flag11-Sem)
+      --  plus fields for expression
+
+      -------------------------------
+      -- 4.1.3  Selected Component --
+      -------------------------------
+
+      --  SELECTED_COMPONENT ::= PREFIX . SELECTOR_NAME
+
+      --  Note: selected components that are semantically expanded names get
+      --  changed during semantic processing into the separate N_Expanded_Name
+      --  node. See description of this node in the section on semantic nodes.
+
+      --  N_Selected_Component
+      --  Sloc points to period
+      --  Prefix (Node3)
+      --  Selector_Name (Node2)
+      --  Do_Access_Check (Flag11-Sem)
+      --  Do_Discriminant_Check (Flag13-Sem)
+      --  plus fields for expression
+
+      --------------------------
+      -- 4.1.3  Selector Name --
+      --------------------------
+
+      --  SELECTOR_NAME ::= IDENTIFIER | CHARACTER_LITERAL | OPERATOR_SYMBOL
+
+      --------------------------------
+      -- 4.1.4  Attribute Reference --
+      --------------------------------
+
+      --  ATTRIBUTE_REFERENCE ::= PREFIX ' ATTRIBUTE_DESIGNATOR
+
+      --  Note: the syntax is quite ambiguous at this point. Consider:
+
+      --    A'Length (X)  X is part of the attribute designator
+      --    A'Pos (X)     X is an explicit actual parameter of function A'Pos
+      --    A'Class (X)   X is the expression of a type conversion
+
+      --  It would be possible for the parser to distinguish these cases
+      --  by looking at the attribute identifier. However, that would mean
+      --  more work in introducing new implementation defined attributes,
+      --  and also it would mean that special processing for attributes
+      --  would be scattered around, instead of being centralized in the
+      --  semantic routine that handles an N_Attribute_Reference node.
+      --  Consequently, the parser in all the above cases stores the
+      --  expression (X in these examples) as a single element list in
+      --  in the Expressions field of the N_Attribute_Reference node.
+
+      --  Similarly, for attributes like Max which take two arguments,
+      --  we store the two arguments as a two element list in the
+      --  Expressions field. Of course it is clear at parse time that
+      --  this case is really a function call with an attribute as the
+      --  prefix, but it turns out to be convenient to handle the two
+      --  argument case in a similar manner to the one argument case,
+      --  and indeed in general the parser will accept any number of
+      --  expressions in this position and store them as a list in the
+      --  attribute reference node. This allows for future addition of
+      --  attributes that take more than two arguments.
+
+      --  Note: named associates are not permitted in function calls where
+      --  the function is an attribute (see RM 6.4(3)) so it is legitimate
+      --  to skip the normal subprogram argument processing.
+
+      --  Note: for the attributes whose designators are technically keywords,
+      --  i.e. digits, access, delta, range, the Attribute_Name field contains
+      --  the corresponding name, even though no identifier is involved.
+
+      --  The flag OK_For_Stream is used in generated code to indicate that
+      --  a stream attribute is permissible for a limited type, and results
+      --  in the use of the stream attribute for the underlying full type,
+      --  or in the case of a protected type, the components (including any
+      --  disriminants) are merely streamed in order.
+
+      --  See Exp_Attr for a complete description of which attributes are
+      --  passed onto Gigi, and which are handled entirely by the front end.
+
+      --  Gigi restriction: For the Pos attribute, the prefix cannot be
+      --  a non-standard enumeration type or a nonzero/zero semantics
+      --  boolean type, so the value is simply the stored representation.
+
+      --  N_Attribute_Reference
+      --  Sloc points to apostrophe
+      --  Prefix (Node3)
+      --  Attribute_Name (Name2) identifier name from attribute designator
+      --  Expressions (List1) (set to No_List if no associated expressions)
+      --  Entity (Node4-Sem) used if the attribute yields a type
+      --  Do_Access_Check (Flag11-Sem)
+      --  Do_Overflow_Check (Flag17-Sem)
+      --  Redundant_Use (Flag13-Sem)
+      --  OK_For_Stream (Flag4-Sem)
+      --  plus fields for expression
+
+      ---------------------------------
+      -- 4.1.4  Attribute Designator --
+      ---------------------------------
+
+      --  ATTRIBUTE_DESIGNATOR ::=
+      --    IDENTIFIER [(static_EXPRESSION)]
+      --  | access | delta | digits
+
+      --  There is no explicit node in the tree for an attribute designator.
+      --  Instead the Attribute_Name and Expressions fields of the parent
+      --  node (N_Attribute_Reference node) hold the information.
+
+      --  Note: if ACCESS, DELTA or DIGITS appears in an attribute
+      --  designator, then they are treated as identifiers internally
+      --  rather than the keywords of the same name.
+
+      --------------------------------------
+      -- 4.1.4  Range Attribute Reference --
+      --------------------------------------
+
+      --  RANGE_ATTRIBUTE_REFERENCE ::= PREFIX ' RANGE_ATTRIBUTE_DESIGNATOR
+
+      --  A range attribute reference is represented in the tree using the
+      --  normal N_Attribute_Reference node.
+
+      ---------------------------------------
+      -- 4.1.4  Range Attribute Designator --
+      ---------------------------------------
+
+      --  RANGE_ATTRIBUTE_DESIGNATOR ::= Range [(static_EXPRESSION)]
+
+      --  A range attribute designator is represented in the tree using the
+      --  normal N_Attribute_Reference node.
+
+      --------------------
+      -- 4.3  Aggregate --
+      --------------------
+
+      --  AGGREGATE ::=
+      --    RECORD_AGGREGATE | EXTENSION_AGGREGATE | ARRAY_AGGREGATE
+
+      -----------------------------
+      -- 4.3.1  Record Aggregate --
+      -----------------------------
+
+      --  RECORD_AGGREGATE ::= (RECORD_COMPONENT_ASSOCIATION_LIST)
+
+      --  N_Aggregate
+      --  Sloc points to left parenthesis
+      --  Expressions (List1) (set to No_List if none or null record case)
+      --  Component_Associations (List2) (set to No_List if none)
+      --  Null_Record_Present (Flag17)
+      --  Aggregate_Bounds (Node3-Sem)
+      --  Static_Processing_OK (Flag4-Sem)
+      --  Compile_Time_Known_Aggregate (Flag18-Sem)
+      --  Expansion_Delayed (Flag11-Sem)
+      --  plus fields for expression
+
+      --  Note: this structure is used for both record and array aggregates
+      --  since the two cases are not separable by the parser. The parser
+      --  makes no attempt to enforce consistency here, so it is up to the
+      --  semantic phase to make sure that the aggregate is consistent (i.e.
+      --  that it is not a "half-and-half" case that mixes record and array
+      --  syntax. In particular, for a record aggregate, the expressions
+      --  field will be set if there are positional associations.
+
+      --  Note: gigi/gcc can handle array aggregates correctly providing that
+      --  they are entirely positional, and the array subtype involved has a
+      --  known at compile time length and is not bit packed, or a convention
+      --  Fortran array with more than one dimension. If these conditions
+      --  are not met, then the front end must translate the aggregate into
+      --  an appropriate set  of assignments into a temporary.
+
+      --  Note: for the record aggregate case, gigi/gcc can handle all cases
+      --  of record aggregates, including those for packed, and rep-claused
+      --  records, and also variant records, providing that there are no
+      --  variable length fields whose size is not known at runtime, and
+      --  providing that the aggregate is presented in fully named form.
+
+      ----------------------------------------------
+      -- 4.3.1  Record Component Association List --
+      ----------------------------------------------
+
+      --  RECORD_COMPONENT_ASSOCIATION_LIST ::=
+      --     RECORD_COMPONENT_ASSOCIATION {, RECORD_COMPONENT_ASSOCIATION}
+      --   | null record
+
+      --  There is no explicit node in the tree for a record component
+      --  association list. Instead the Null_Record_Present flag is set in
+      --  the parent node for the NULL RECORD case.
+
+      ------------------------------------------------------
+      -- 4.3.1  Record Component Association (also 4.3.3) --
+      ------------------------------------------------------
+
+      --  RECORD_COMPONENT_ASSOCIATION ::=
+      --    [COMPONENT_CHOICE_LIST =>] EXPRESSION
+
+      --  N_Component_Association
+      --  Sloc points to first selector name
+      --  Choices (List1)
+      --  Loop_Actions (List2-Sem)
+      --  Expression (Node3)
+
+      --  Note: this structure is used for both record component associations
+      --  and array component associations, since the two cases aren't always
+      --  separable by the parser. The choices list may represent either a
+      --  list of selector names in the record aggregate case, or a list of
+      --  discrete choices in the array aggregate case or an N_Others_Choice
+      --  node (which appears as a singleton list).
+
+      ------------------------------------
+      --  4.3.1  Commponent Choice List --
+      ------------------------------------
+
+      --  COMPONENT_CHOICE_LIST ::=
+      --    component_SELECTOR_NAME {| component_SELECTOR_NAME}
+      --  | others
+
+      --  The entries of a component choice list appear in the Choices list
+      --  of the associated N_Component_Association, as either selector
+      --  names, or as an N_Others_Choice node.
+
+      --------------------------------
+      -- 4.3.2  Extension Aggregate --
+      --------------------------------
+
+      --  EXTENSION_AGGREGATE ::=
+      --    (ANCESTOR_PART with RECORD_COMPONENT_ASSOCIATION_LIST)
+
+      --  Note: extension aggregates are not permitted in Ada 83 mode
+
+      --  N_Extension_Aggregate
+      --  Sloc points to left parenthesis
+      --  Ancestor_Part (Node3)
+      --  Expressions (List1) (set to No_List if none or null record case)
+      --  Component_Associations (List2) (set to No_List if none)
+      --  Null_Record_Present (Flag17)
+      --  Expansion_Delayed (Flag11-Sem)
+      --  plus fields for expression
+
+      --------------------------
+      -- 4.3.2  Ancestor Part --
+      --------------------------
+
+      --  ANCESTOR_PART ::= EXPRESSION | SUBTYPE_MARK
+
+      ----------------------------
+      -- 4.3.3  Array Aggregate --
+      ----------------------------
+
+      --  ARRAY_AGGREGATE ::=
+      --    POSITIONAL_ARRAY_AGGREGATE | NAMED_ARRAY_AGGREGATE
+
+      ---------------------------------------
+      -- 4.3.3  Positional Array Aggregate --
+      ---------------------------------------
+
+      --  POSITIONAL_ARRAY_AGGREGATE ::=
+      --    (EXPRESSION, EXPRESSION {, EXPRESSION})
+      --  | (EXPRESSION {, EXPRESSION}, others => EXPRESSION)
+
+      --  See Record_Aggregate (4.3.1) for node structure
+
+      ----------------------------------
+      -- 4.3.3  Named Array Aggregate --
+      ----------------------------------
+
+      --  NAMED_ARRAY_AGGREGATE ::=
+      --  | (ARRAY_COMPONENT_ASSOCIATION {, ARRAY_COMPONENT_ASSOCIATION})
+
+      --  See Record_Aggregate (4.3.1) for node structure
+
+      ----------------------------------------
+      -- 4.3.3  Array Component Association --
+      ----------------------------------------
+
+      --  ARRAY_COMPONENT_ASSOCIATION ::=
+      --    DISCRETE_CHOICE_LIST => EXPRESSION
+
+      --  See Record_Component_Association (4.3.1) for node structure
+
+      --------------------------------------------------
+      -- 4.4  Expression/Relation/Term/Factor/Primary --
+      --------------------------------------------------
+
+      --  EXPRESSION ::=
+      --    RELATION {and RELATION} | RELATION {and then RELATION}
+      --  | RELATION {or RELATION}  | RELATION {or else RELATION}
+      --  | RELATION {xor RELATION}
+
+      --  RELATION ::=
+      --    SIMPLE_EXPRESSION [RELATIONAL_OPERATOR SIMPLE_EXPRESSION]
+      --  | SIMPLE_EXPRESSION [not] in RANGE
+      --  | SIMPLE_EXPRESSION [not] in SUBTYPE_MARK
+
+      --  SIMPLE_EXPRESSION ::=
+      --    [UNARY_ADDING_OPERATOR] TERM {BINARY_ADDING_OPERATOR TERM}
+
+      --  TERM ::= FACTOR {MULTIPLYING_OPERATOR FACTOR}
+
+      --  FACTOR ::= PRIMARY [** PRIMARY] | abs PRIMARY | not PRIMARY
+
+      --  No nodes are generated for any of these constructs. Instead, the
+      --  node for the operator appears directly. When we refer to an
+      --  expression in this description, we mean any of the possible
+      --  consistuent components of an expression (e.g. identifier is
+      --  an example of an expression).
+
+      ------------------
+      -- 4.4  Primary --
+      ------------------
+
+      --  PRIMARY ::=
+      --    NUMERIC_LITERAL  | null
+      --  | STRING_LITERAL   | AGGREGATE
+      --  | NAME             | QUALIFIED_EXPRESSION
+      --  | ALLOCATOR        | (EXPRESSION)
+
+      --  Usually there is no explicit node in the tree for primary. Instead
+      --  the constituent (e.g. AGGREGATE) appears directly. There are two
+      --  exceptions. First, there is an explicit node for a null primary.
+
+      --  N_Null
+      --  Sloc points to NULL
+      --  plus fields for expression
+
+      --  Second, the case of (EXPRESSION) is handled specially. Ada requires
+      --  that the parser keep track of which subexpressions are enclosed
+      --  in parentheses, and how many levels of parentheses are used. This
+      --  information is required for optimization purposes, and also for
+      --  some semantic checks (e.g. (((1))) in a procedure spec does not
+      --  conform with ((((1)))) in the body).
+
+      --  The parentheses are recorded by keeping a Paren_Count field in every
+      --  subexpression node (it is actually present in all nodes, but only
+      --  used in subexpression nodes). This count records the number of
+      --  levels of parentheses. If the number of levels in the source exceeds
+      --  the maximum accomodated by this count, then the count is simply left
+      --  at the maximum value. This means that there are some pathalogical
+      --  cases of failure to detect conformance failures (e.g. an expression
+      --  with 500 levels of parens will conform with one with 501 levels),
+      --  but we do not need to lose sleep over this.
+
+      --  Historical note: in versions of GNAT prior to 1.75, there was a node
+      --  type N_Parenthesized_Expression used to accurately record unlimited
+      --  numbers of levels of parentheses. However, it turned out to be a
+      --  real nuisance to have to take into account the possible presence of
+      --  this node during semantic analysis, since basically parentheses have
+      --  zero relevance to semantic analysis.
+
+      --  Note: the level of parentheses always present in things like
+      --  aggregates does not count, only the parentheses in the primary
+      --  (EXPRESSION) affect the setting of the Paren_Count field.
+
+      --  2nd Note: the contents of the Expression field must be ignored (i.e.
+      --  treated as though it were Empty) if No_Initialization is set True.
+
+      --------------------------------------
+      -- 4.5  Short Circuit Control Forms --
+      --------------------------------------
+
+      --  EXPRESSION ::=
+      --    RELATION {and then RELATION} | RELATION {or else RELATION}
+
+      --  Gigi restriction: For both these control forms, the operand and
+      --  result types are always Standard.Boolean. The expander inserts the
+      --  required conversion operations where needed to ensure this is the
+      --  case.
+
+      --  N_And_Then
+      --  Sloc points to AND of AND THEN
+      --  Left_Opnd (Node2)
+      --  Right_Opnd (Node3)
+      --  Actions (List1-Sem)
+      --  plus fields for expression
+
+      --  N_Or_Else
+      --  Sloc points to OR of OR ELSE
+      --  Left_Opnd (Node2)
+      --  Right_Opnd (Node3)
+      --  Actions (List1-Sem)
+      --  plus fields for expression
+
+      --  Note: The Actions field is used to hold actions associated with
+      --  the right hand operand. These have to be treated specially since
+      --  they are not unconditionally executed. See Insert_Actions for a
+      --  more detailed description of how these actions are handled.
+
+      ---------------------------
+      -- 4.5  Membership Tests --
+      ---------------------------
+
+      --  RELATION ::=
+      --    SIMPLE_EXPRESSION [not] in RANGE
+      --  | SIMPLE_EXPRESSION [not] in SUBTYPE_MARK
+
+      --  Note: although the grammar above allows only a range or a
+      --  subtype mark, the parser in fact will accept any simple
+      --  expression in place of a subtype mark. This means that the
+      --  semantic analyzer must be prepared to deal with, and diagnose
+      --  a simple expression other than a name for the right operand.
+      --  This simplifies error recovery in the parser.
+
+      --  N_In
+      --  Sloc points to IN
+      --  Left_Opnd (Node2)
+      --  Right_Opnd (Node3)
+      --  plus fields for expression
+
+      --  N_Not_In
+      --  Sloc points to NOT of NOT IN
+      --  Left_Opnd (Node2)
+      --  Right_Opnd (Node3)
+      --  plus fields for expression
+
+      --------------------
+      -- 4.5  Operators --
+      --------------------
+
+      --  LOGICAL_OPERATOR             ::=  and | or  | xor
+
+      --  RELATIONAL_OPERATOR          ::=  =   | /=  | <   | <= | > | >=
+
+      --  BINARY_ADDING_OPERATOR       ::=  +   |  -  | &
+
+      --  UNARY_ADDING_OPERATOR        ::=  +   |  -
+
+      --  MULTIPLYING_OPERATOR         ::=  *   |  /  | mod | rem
+
+      --  HIGHEST_PRECEDENCE_OPERATOR  ::=  **  | abs | not
+
+      --  Sprint syntax if Treat_Fixed_As_Integer is set:
+
+      --     x #* y
+      --     x #/ y
+      --     x #mod y
+      --     x #rem y
+
+      --  Gigi restriction: For * / mod rem with fixed-point operands, Gigi
+      --  will only be given nodes with the Treat_Fixed_As_Integer flag set.
+      --  All handling of smalls for multiplication and division is handled
+      --  by the front end (mod and rem result only from expansion). Gigi
+      --  thus never needs to worry about small values (for other operators
+      --  operating on fixed-point, e.g. addition, the small value does not
+      --  have any semantic effect anyway, these are always integer operations.
+
+      --  Gigi restriction: For all operators taking Boolean operands, the
+      --  type is always Standard.Boolean. The expander inserts the required
+      --  conversion operations where needed to ensure this is the case.
+
+      --  N_Op_And
+      --  Sloc points to AND
+      --  Do_Length_Check (Flag4-Sem)
+      --  plus fields for binary operator
+      --  plus fields for expression
+
+      --  N_Op_Or
+      --  Sloc points to OR
+      --  Do_Length_Check (Flag4-Sem)
+      --  plus fields for binary operator
+      --  plus fields for expression
+
+      --  N_Op_Xor
+      --  Sloc points to XOR
+      --  Do_Length_Check (Flag4-Sem)
+      --  plus fields for binary operator
+      --  plus fields for expression
+
+      --  N_Op_Eq
+      --  Sloc points to =
+      --  plus fields for binary operator
+      --  plus fields for expression
+
+      --  N_Op_Ne
+      --  Sloc points to /=
+      --  plus fields for binary operator
+      --  plus fields for expression
+
+      --  N_Op_Lt
+      --  Sloc points to <
+      --  plus fields for binary operator
+      --  plus fields for expression
+
+      --  N_Op_Le
+      --  Sloc points to <=
+      --  plus fields for binary operator
+      --  plus fields for expression
+
+      --  N_Op_Gt
+      --  Sloc points to >
+      --  plus fields for binary operator
+      --  plus fields for expression
+
+      --  N_Op_Ge
+      --  Sloc points to >=
+      --  plus fields for binary operator
+      --  plus fields for expression
+
+      --  N_Op_Add
+      --  Sloc points to + (binary)
+      --  plus fields for binary operator
+      --  plus fields for expression
+
+      --  N_Op_Subtract
+      --  Sloc points to - (binary)
+      --  plus fields for binary operator
+      --  plus fields for expression
+
+      --  N_Op_Concat
+      --  Sloc points to &
+      --  Is_Component_Left_Opnd (Flag13-Sem)
+      --  Is_Component_Right_Opnd (Flag14-Sem)
+      --  plus fields for binary operator
+      --  plus fields for expression
+
+      --  N_Op_Multiply
+      --  Sloc points to *
+      --  Treat_Fixed_As_Integer (Flag14-Sem)
+      --  Rounded_Result (Flag18-Sem)
+      --  plus fields for binary operator
+      --  plus fields for expression
+
+      --  N_Op_Divide
+      --  Sloc points to /
+      --  Treat_Fixed_As_Integer (Flag14-Sem)
+      --  Do_Division_Check (Flag13-Sem)
+      --  Rounded_Result (Flag18-Sem)
+      --  plus fields for binary operator
+      --  plus fields for expression
+
+      --  N_Op_Mod
+      --  Sloc points to MOD
+      --  Treat_Fixed_As_Integer (Flag14-Sem)
+      --  Do_Division_Check (Flag13-Sem)
+      --  plus fields for binary operator
+      --  plus fields for expression
+
+      --  N_Op_Rem
+      --  Sloc points to REM
+      --  Treat_Fixed_As_Integer (Flag14-Sem)
+      --  Do_Division_Check (Flag13-Sem)
+      --  plus fields for binary operator
+      --  plus fields for expression
+
+      --  N_Op_Expon
+      --  Is_Power_Of_2_For_Shift (Flag13-Sem)
+      --  Sloc points to **
+      --  plus fields for binary operator
+      --  plus fields for expression
+
+      --  N_Op_Plus
+      --  Sloc points to + (unary)
+      --  plus fields for unary operator
+      --  plus fields for expression
+
+      --  N_Op_Minus
+      --  Sloc points to - (unary)
+      --  plus fields for unary operator
+      --  plus fields for expression
+
+      --  N_Op_Abs
+      --  Sloc points to ABS
+      --  plus fields for unary operator
+      --  plus fields for expression
+
+      --  N_Op_Not
+      --  Sloc points to NOT
+      --  plus fields for unary operator
+      --  plus fields for expression
+
+      --  See also shift operators in section B.2
+
+      --  Note on fixed-point operations passed to Gigi: For adding operators,
+      --  the semantics is to treat these simply as integer operations, with
+      --  the small values being ignored (the bounds are already stored in
+      --  units of small, so that constraint checking works as usual). For the
+      --  case of multiply/divide/rem/mod operations, Gigi will only see fixed
+      --  point operands if the Treat_Fixed_As_Integer flag is set and will
+      --  thus treat these nodes in identical manner, ignoring small values.
+
+      --------------------------
+      -- 4.6  Type Conversion --
+      --------------------------
+
+      --  TYPE_CONVERSION ::=
+      --    SUBTYPE_MARK (EXPRESSION) | SUBTYPE_MARK (NAME)
+
+      --  In the (NAME) case, the name is stored as the expression
+
+      --  Note: the parser never generates a type conversion node, since it
+      --  looks like an indexed component which is generated by preference.
+      --  The semantic pass must correct this misidentification.
+
+      --  Gigi handles conversions that involve no change in the root type,
+      --  and also all conversions from integer to floating-point types.
+      --  Conversions from floating-point to integer are only handled in
+      --  the case where Float_Truncate flag set. Other conversions from
+      --  floating-point to integer (involving rounding) and all conversions
+      --  involving fixed-point types are handled by the expander.
+
+      --  Sprint syntax if Float_Truncate set: X^(Y)
+      --  Sprint syntax if Conversion_OK set X?(Y)
+      --  Sprint syntax if both flags set X?^(Y)
+
+      --  Note: If either the operand or result type is fixed-point, Gigi will
+      --  only see a type conversion node with Conversion_OK set. The front end
+      --  takes care of all handling of small's for fixed-point conversions.
+
+      --  N_Type_Conversion
+      --  Sloc points to first token of subtype mark
+      --  Subtype_Mark (Node4)
+      --  Expression (Node3)
+      --  Do_Overflow_Check (Flag17-Sem)
+      --  Do_Tag_Check (Flag13-Sem)
+      --  Do_Length_Check (Flag4-Sem)
+      --  Float_Truncate (Flag11-Sem)
+      --  Rounded_Result (Flag18-Sem)
+      --  Conversion_OK (Flag14-Sem)
+      --  plus fields for expression
+
+      --  Note: if a range check is required, then the Do_Range_Check flag
+      --  is set in the Expression with the check being done against the
+      --  target type range (after the base type conversion, if any).
+
+      -------------------------------
+      -- 4.7  Qualified Expression --
+      -------------------------------
+
+      --  QUALIFIED_EXPRESSION ::=
+      --    SUBTYPE_MARK ' (EXPRESSION) | SUBTYPE_MARK ' AGGREGATE
+
+      --  Note: the parentheses in the (EXPRESSION) case are deemed to enclose
+      --  the expression, so the Expression field of this node always points
+      --  to a parenthesized expression in this case (i.e. Paren_Count will
+      --  always be non-zero for the referenced expression if it is not an
+      --  aggregate).
+
+      --  N_Qualified_Expression
+      --  Sloc points to apostrophe
+      --  Subtype_Mark (Node4)
+      --  Expression (Node3) expression or aggregate
+      --  plus fields for expression
+
+      --------------------
+      -- 4.8  Allocator --
+      --------------------
+
+      --  ALLOCATOR ::=
+      --    new SUBTYPE_INDICATION | new QUALIFIED_EXPRESSION
+
+      --  Sprint syntax (when storage pool present)
+      --    new xxx (storage_pool = pool)
+
+      --  N_Allocator
+      --  Sloc points to NEW
+      --  Expression (Node3) subtype indication or qualified expression
+      --  Storage_Pool (Node1-Sem)
+      --  Procedure_To_Call (Node4-Sem)
+      --  No_Initialization (Flag13-Sem)
+      --  Do_Storage_Check (Flag17-Sem)
+      --  plus fields for expression
+
+      ---------------------------------
+      -- 5.1  Sequence Of Statements --
+      ---------------------------------
+
+      --  SEQUENCE_OF_STATEMENTS ::= STATEMENT {STATEMENT}
+
+      --  Note: Although the parser will not accept a declaration as a
+      --  statement, the semantic analyzer may insert declarations (e.g.
+      --  declarations of implicit types needed for execution of other
+      --  statements) into a sequence of statements, so the code genmerator
+      --  should be prepared to accept a declaration where a statement is
+      --  expected. Note also that pragmas can appear as statements.
+
+      --------------------
+      -- 5.1  Statement --
+      --------------------
+
+      --  STATEMENT ::=
+      --    {LABEL} SIMPLE_STATEMENT | {LABEL} COMPOUND_STATEMENT
+
+      --  There is no explicit node in the tree for a statement. Instead, the
+      --  individual statement appears directly. Labels are treated  as a
+      --  kind of statement, i.e. they are linked into a statement list at
+      --  the point they appear, so the labeled statement appears following
+      --  the label or labels in the statement list.
+
+      ---------------------------
+      -- 5.1  Simple 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
+
+      -----------------------------
+      -- 5.1  Compound Statement --
+      -----------------------------
+
+      --  COMPOUND_STATEMENT ::=
+      --    IF_STATEMENT         | CASE_STATEMENT
+      --  | LOOP_STATEMENT       | BLOCK_STATEMENT
+      --  | ACCEPT_STATEMENT     | SELECT_STATEMENT
+
+      -------------------------
+      -- 5.1  Null Statement --
+      -------------------------
+
+      --  NULL_STATEMENT ::= null;
+
+      --  N_Null_Statement
+      --  Sloc points to NULL
+
+      ----------------
+      -- 5.1  Label --
+      ----------------
+
+      --  LABEL ::= <<label_STATEMENT_IDENTIFIER>>
+
+      --  Note that the occurrence of a label is not a defining identifier,
+      --  but rather a referencing occurrence. The defining occurrence is
+      --  in the implicit label declaration which occurs in the innermost
+      --  enclosing block.
+
+      --  N_Label
+      --  Sloc points to <<
+      --  Identifier (Node1) direct name of statement identifier
+      --  Exception_Junk (Flag11-Sem)
+
+      -------------------------------
+      -- 5.1  Statement Identifier --
+      -------------------------------
+
+      --  STATEMENT_INDENTIFIER ::= DIRECT_NAME
+
+      --  The IDENTIFIER of a STATEMENT_IDENTIFIER shall be an identifier
+      --  (not an OPERATOR_SYMBOL)
+
+      -------------------------------
+      -- 5.2  Assignment Statement --
+      -------------------------------
+
+      --  ASSIGNMENT_STATEMENT ::=
+      --    variable_NAME := EXPRESSION;
+
+      --  N_Assignment_Statement
+      --  Sloc points to :=
+      --  Name (Node2)
+      --  Expression (Node3)
+      --  Do_Tag_Check (Flag13-Sem)
+      --  Do_Length_Check (Flag4-Sem)
+      --  Forwards_OK (Flag5-Sem)
+      --  Backwards_OK (Flag6-Sem)
+      --  No_Ctrl_Actions (Flag7-Sem)
+
+      --  Note: if a range check is required, then the Do_Range_Check flag
+      --  is set in the Expression (right hand side), with the check being
+      --  done against the type of the Name (left hand side).
+
+      -----------------------
+      -- 5.3  If Statement --
+      -----------------------
+
+      --  IF_STATEMENT ::=
+      --    if CONDITION then
+      --      SEQUENCE_OF_STATEMENTS
+      --    {elsif CONDITION then
+      --      SEQUENCE_OF_STATEMENTS}
+      --    [else
+      --      SEQUENCE_OF_STATEMENTS]
+      --    end if;
+
+      --  Gigi restriction: This expander ensures that the type of the
+      --  Condition fields is always Standard.Boolean, even if the type
+      --  in the source is some non-standard boolean type.
+
+      --  N_If_Statement
+      --  Sloc points to IF
+      --  Condition (Node1)
+      --  Then_Statements (List2)
+      --  Elsif_Parts (List3) (set to No_List if none present)
+      --  Else_Statements (List4) (set to No_List if no else part present)
+      --  End_Span (Uint5) (set to No_Uint if expander generated)
+
+      --  N_Elsif_Part
+      --  Sloc points to ELSIF
+      --  Condition (Node1)
+      --  Then_Statements (List2)
+      --  Condition_Actions (List3-Sem)
+
+      --------------------
+      -- 5.3  Condition --
+      --------------------
+
+      --  CONDITION ::= boolean_EXPRESSION
+
+      -------------------------
+      -- 5.4  Case Statement --
+      -------------------------
+
+      --  CASE_STATEMENT ::=
+      --    case EXPRESSION is
+      --      CASE_STATEMENT_ALTERNATIVE
+      --      {CASE_STATEMENT_ALTERNATIVE}
+      --    end case;
+
+      --  Note: the Alternatives can contain pragmas. These only occur at
+      --  the start of the list, since any pragmas occurring after the first
+      --  alternative are absorbed into the corresponding statement sequence.
+
+      --  N_Case_Statement
+      --  Sloc points to CASE
+      --  Expression (Node3)
+      --  Alternatives (List4)
+      --  End_Span (Uint5) (set to No_Uint if expander generated)
+
+      -------------------------------------
+      -- 5.4  Case Statement Alternative --
+      -------------------------------------
+
+      --  CASE_STATEMENT_ALTERNATIVE ::=
+      --    when DISCRETE_CHOICE_LIST =>
+      --      SEQUENCE_OF_STATEMENTS
+
+      --  N_Case_Statement_Alternative
+      --  Sloc points to WHEN
+      --  Discrete_Choices (List4)
+      --  Statements (List3)
+
+      -------------------------
+      -- 5.5  Loop Statement --
+      -------------------------
+
+      --  LOOP_STATEMENT ::=
+      --    [loop_STATEMENT_IDENTIFIER :]
+      --      [ITERATION_SCHEME] loop
+      --        SEQUENCE_OF_STATEMENTS
+      --      end loop [loop_IDENTIFIER];
+
+      --  Note: The occurrence of a loop label is not a defining identifier
+      --  but rather a referencing occurrence. The defining occurrence is in
+      --  the implicit label declaration which occurs in the innermost
+      --  enclosing block.
+
+      --  Note: there is always a loop statement identifier present in
+      --  the tree, even if none was given in the source. In the case where
+      --  no loop identifier is given in the source, the parser creates
+      --  a name of the form _Loop_n, where n is a decimal integer (the
+      --  two underlines ensure that the loop names created in this manner
+      --  do not conflict with any user defined identifiers), and the flag
+      --  Has_Created_Identifier is set to True. The only exception to the
+      --  rule that all loop statement nodes have identifiers occurs for
+      --  loops constructed by the expander, and the semantic analyzer will
+      --  create and supply dummy loop identifiers in these cases.
+
+      --  N_Loop_Statement
+      --  Sloc points to LOOP
+      --  Identifier (Node1) loop identifier (set to Empty if no identifier)
+      --  Iteration_Scheme (Node2) (set to Empty if no iteration scheme)
+      --  Statements (List3)
+      --  End_Label (Node4)
+      --  Has_Created_Identifier (Flag15)
+
+      --------------------------
+      -- 5.5 Iteration Scheme --
+      --------------------------
+
+      --  ITERATION_SCHEME ::=
+      --    while CONDITION | for LOOP_PARAMETER_SPECIFICATION
+
+      --  Gigi restriction: This expander ensures that the type of the
+      --  Condition field is always Standard.Boolean, even if the type
+      --  in the source is some non-standard boolean type.
+
+      --  N_Iteration_Scheme
+      --  Sloc points to WHILE or FOR
+      --  Condition (Node1) (set to Empty if FOR case)
+      --  Condition_Actions (List3-Sem)
+      --  Loop_Parameter_Specification (Node4) (set to Empty if WHILE case)
+
+      ---------------------------------------
+      -- 5.5  Loop parameter specification --
+      ---------------------------------------
+
+      --  LOOP_PARAMETER_SPECIFICATION ::=
+      --    DEFINING_IDENTIFIER in [reverse] DISCRETE_SUBTYPE_DEFINITION
+
+      --  N_Loop_Parameter_Specification
+      --  Sloc points to first identifier
+      --  Defining_Identifier (Node1)
+      --  Reverse_Present (Flag15)
+      --  Discrete_Subtype_Definition (Node4)
+
+      --------------------------
+      -- 5.6  Block Statement --
+      --------------------------
+
+      --  BLOCK_STATEMENT ::=
+      --    [block_STATEMENT_IDENTIFIER:]
+      --      [declare
+      --        DECLARATIVE_PART]
+      --      begin
+      --        HANDLED_SEQUENCE_OF_STATEMENTS
+      --      end [block_IDENTIFIER];
+
+      --  Note that the occurrence of a block identifier is not a defining
+      --  identifier, but rather a referencing occurrence. The defining
+      --  occurrence is in the implicit label declaration which occurs in
+      --  the innermost enclosing block.
+
+      --  Note: there is always a block statement identifier present in
+      --  the tree, even if none was given in the source. In the case where
+      --  no block identifier is given in the source, the parser creates
+      --  a name of the form _Block_n, where n is a decimal integer (the
+      --  two underlines ensure that the block names created in this manner
+      --  do not conflict with any user defined identifiers), and the flag
+      --  Has_Created_Identifier is set to True. The only exception to the
+      --  rule that all loop statement nodes have identifiers occurs for
+      --  blocks constructed by the expander, and the semantic analyzer
+      --  creates and supplies dummy names for the blocks).
+
+      --  N_Block_Statement
+      --  Sloc points to DECLARE or BEGIN
+      --  Identifier (Node1) block direct name (set to Empty if not present)
+      --  Declarations (List2) (set to No_List if no DECLARE part)
+      --  Handled_Statement_Sequence (Node4)
+      --  Is_Task_Master (Flag5-Sem)
+      --  Activation_Chain_Entity (Node3-Sem)
+      --  Has_Created_Identifier (Flag15)
+      --  Is_Task_Allocation_Block (Flag6)
+      --  Is_Asynchronous_Call_Block (Flag7)
+
+      -------------------------
+      -- 5.7  Exit Statement --
+      -------------------------
+
+      --  EXIT_STATEMENT ::= exit [loop_NAME] [when CONDITION];
+
+      --  Gigi restriction: This expander ensures that the type of the
+      --  Condition field is always Standard.Boolean, even if the type
+      --  in the source is some non-standard boolean type.
+
+      --  N_Exit_Statement
+      --  Sloc points to EXIT
+      --  Name (Node2) (set to Empty if no loop name present)
+      --  Condition (Node1) (set to Empty if no when part present)
+
+      -------------------------
+      -- 5.9  Goto Statement --
+      -------------------------
+
+      --  GOTO_STATEMENT ::= goto label_NAME;
+
+      --  N_Goto_Statement
+      --  Sloc points to GOTO
+      --  Name (Node2)
+      --  Exception_Junk (Flag11-Sem)
+
+      ---------------------------------
+      -- 6.1  Subprogram Declaration --
+      ---------------------------------
+
+      --  SUBPROGRAM_DECLARATION ::= SUBPROGRAM_SPECIFICATION;
+
+      --  N_Subprogram_Declaration
+      --  Sloc points to FUNCTION or PROCEDURE
+      --  Specification (Node1)
+      --  Body_To_Inline (Node3-Sem)
+      --  Corresponding_Body (Node5-Sem)
+      --  Parent_Spec (Node4-Sem)
+
+      ------------------------------------------
+      -- 6.1  Abstract Subprogram Declaration --
+      ------------------------------------------
+
+      --  ABSTRACT_SUBPROGRAM_DECLARATION ::=
+      --    SUBPROGRAM_SPECIFICATION is abstract;
+
+      --  N_Abstract_Subprogram_Declaration
+      --  Sloc points to ABSTRACT
+      --  Specification (Node1)
+
+      -----------------------------------
+      -- 6.1  Subprogram Specification --
+      -----------------------------------
+
+      --  SUBPROGRAM_SPECIFICATION ::=
+      --    procedure DEFINING_PROGRAM_UNIT_NAME PARAMETER_PROFILE
+      --  | function DEFINING_DESIGNATOR PARAMETER_AND_RESULT_PROFILE
+
+      --  Note: there are no separate nodes for the profiles, instead the
+      --  information appears directly in the following nodes.
+
+      --  N_Function_Specification
+      --  Sloc points to FUNCTION
+      --  Defining_Unit_Name (Node1) (the designator)
+      --  Elaboration_Boolean (Node2-Sem)
+      --  Parameter_Specifications (List3) (set to No_List if no formal part)
+      --  Subtype_Mark (Node4) for return type
+      --  Generic_Parent (Node5-Sem)
+
+      --  N_Procedure_Specification
+      --  Sloc points to PROCEDURE
+      --  Defining_Unit_Name (Node1)
+      --  Elaboration_Boolean (Node2-Sem)
+      --  Parameter_Specifications (List3) (set to No_List if no formal part)
+      --  Generic_Parent (Node5-Sem)
+
+      ---------------------
+      -- 6.1  Designator --
+      ---------------------
+
+      --  DESIGNATOR ::=
+      --    [PARENT_UNIT_NAME .] IDENTIFIER | OPERATOR_SYMBOL
+
+      --  Designators that are simply identifiers or operator symbols appear
+      --  directly in the tree in this form. The following node is used only
+      --  in the case where the designator has a parent unit name component.
+
+      --  N_Designator
+      --  Sloc points to period
+      --  Name (Node2) holds the parent unit name. Note that this is always
+      --   non-Empty, since this node is only used for the case where a
+      --   parent library unit package name is present.
+      --  Identifier (Node1)
+
+      --  Note that the identifier can also be an operator symbol here.
+
+      ------------------------------
+      -- 6.1  Defining Designator --
+      ------------------------------
+
+      --  DEFINING_DESIGNATOR ::=
+      --    DEFINING_PROGRAM_UNIT_NAME | DEFINING_OPERATOR_SYMBOL
+
+      -------------------------------------
+      -- 6.1  Defining Program Unit Name --
+      -------------------------------------
+
+      --  DEFINING_PROGRAM_UNIT_NAME ::=
+      --    [PARENT_UNIT_NAME .] DEFINING_IDENTIFIER
+
+      --  The parent unit name is present only in the case of a child unit
+      --  name (permissible only for Ada 95 for a library level unit, i.e.
+      --  a unit at scope level one). If no such name is present, the defining
+      --  program unit name is represented simply as the defining identifier.
+      --  In the child unit case, the following node is used to represent the
+      --  child unit name.
+
+      --  N_Defining_Program_Unit_Name
+      --  Sloc points to period
+      --  Name (Node2) holds the parent unit name. Note that this is always
+      --   non-Empty, since this node is only used for the case where a
+      --   parent unit name is present.
+      --  Defining_Identifier (Node1)
+
+      --------------------------
+      -- 6.1  Operator Symbol --
+      --------------------------
+
+      --  OPERATOR_SYMBOL ::= STRING_LITERAL
+
+      --  Note: the fields of the N_Operator_Symbol node are laid out to
+      --  match the corresponding fields of an N_Character_Literal node. This
+      --  allows easy conversion of the operator symbol node into a character
+      --  literal node in the case where a string constant of the form of an
+      --  operator symbol is scanned out as such, but turns out semantically
+      --  to be a string literal that is not an operator. For details see
+      --  Sinfo.CN.Change_Operator_Symbol_To_String_Literal.
+
+      --  N_Operator_Symbol
+      --  Sloc points to literal
+      --  Chars (Name1) contains the Name_Id for the operator symbol
+      --  Strval (Str3) Id of string value. This is used if the operator
+      --   symbol turns out to be a normal string after all.
+      --  Entity (Node4-Sem)
+      --  Has_Private_View (Flag11-Sem) set in generic units.
+      --  Etype (Node5-Sem)
+
+      --  Note: the Strval field may be set to No_String for generated
+      --  operator symbols that are known not to be string literals
+      --  semantically.
+
+      -----------------------------------
+      -- 6.1  Defining Operator Symbol --
+      -----------------------------------
+
+      --  DEFINING_OPERATOR_SYMBOL ::= OPERATOR_SYMBOL
+
+      --  A defining operator symbol is an entity, which has additional
+      --  fields depending on the setting of the Ekind field. These
+      --  additional fields are defined (and access subprograms declared)
+      --  in package Einfo.
+
+      --  Note: N_Defining_Operator_Symbol is an extended node whose fields
+      --  are deliberately layed out to match the layout of fields in an
+      --  ordinary N_Operator_Symbol node allowing for easy alteration of
+      --  an operator symbol node into a defining operator symbol node.
+      --  See Sinfo.CN.Change_Operator_Symbol_To_Defining_Operator_Symbol
+      --  for further details.
+
+      --  N_Defining_Operator_Symbol
+      --  Sloc points to literal
+      --  Chars (Name1) contains the Name_Id for the operator symbol
+      --  Next_Entity (Node2-Sem)
+      --  Scope (Node3-Sem)
+      --  Etype (Node5-Sem)
+
+      ----------------------------
+      -- 6.1  Parameter Profile --
+      ----------------------------
+
+      --  PARAMETER_PROFILE ::= [FORMAL_PART]
+
+      ---------------------------------------
+      -- 6.1  Parameter and Result Profile --
+      ---------------------------------------
+
+      --  PARAMETER_AND_RESULT_PROFILE ::= [FORMAL_PART] return SUBTYPE_MARK
+
+      --  There is no explicit node in the tree for a parameter and result
+      --  profile. Instead the information appears directly in the parent.
+
+      ----------------------
+      -- 6.1  Formal part --
+      ----------------------
+
+      --  FORMAL_PART ::=
+      --    (PARAMETER_SPECIFICATION {; PARAMETER_SPECIFICATION})
+
+      ----------------------------------
+      -- 6.1  Parameter specification --
+      ----------------------------------
+
+      --  PARAMETER_SPECIFICATION ::=
+      --    DEFINING_IDENTIFIER_LIST : MODE SUBTYPE_MARK
+      --      [:= DEFAULT_EXPRESSION]
+      --  | DEFINING_IDENTIFIER_LIST : ACCESS_DEFINITION
+      --      [:= DEFAULT_EXPRESSION]
+
+      --  Although the syntax allows multiple identifiers in the list, the
+      --  semantics is as though successive specifications were given with
+      --  identical type definition and expression components. To simplify
+      --  semantic processing, the parser represents a multiple declaration
+      --  case as a sequence of single Specifications, using the More_Ids and
+      --  Prev_Ids flags to preserve the original source form as described
+      --  in the section on "Handling of Defining Identifier Lists".
+
+      --  N_Parameter_Specification
+      --  Sloc points to first identifier
+      --  Defining_Identifier (Node1)
+      --  In_Present (Flag15)
+      --  Out_Present (Flag17)
+      --  Parameter_Type (Node2) subtype mark or access definition
+      --  Expression (Node3) (set to Empty if no default expression present)
+      --  Do_Accessibility_Check (Flag13-Sem)
+      --  More_Ids (Flag5) (set to False if no more identifiers in list)
+      --  Prev_Ids (Flag6) (set to False if no previous identifiers in list)
+      --  Default_Expression (Node5-Sem)
+
+      ---------------
+      -- 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.
+
+      --------------------------
+      -- 6.3  Subprogram Body --
+      --------------------------
+
+      --  SUBPROGRAM_BODY ::=
+      --    SUBPROGRAM_SPECIFICATION is
+      --      DECLARATIVE_PART
+      --    begin
+      --      HANDLED_SEQUENCE_OF_STATEMENTS
+      --    end [DESIGNATOR];
+
+      --  N_Subprogram_Body
+      --  Sloc points to FUNCTION or PROCEDURE
+      --  Specification (Node1)
+      --  Declarations (List2)
+      --  Handled_Statement_Sequence (Node4)
+      --  Activation_Chain_Entity (Node3-Sem)
+      --  Corresponding_Spec (Node5-Sem)
+      --  Acts_As_Spec (Flag4-Sem)
+      --  Bad_Is_Detected (Flag15) used only by parser
+      --  Do_Storage_Check (Flag17-Sem)
+      --  Has_Priority_Pragma (Flag6-Sem)
+      --  Is_Protected_Subprogram_Body (Flag7-Sem)
+      --  Is_Task_Master (Flag5-Sem)
+      --  Was_Originally_Stub (Flag13-Sem)
+
+      -----------------------------------
+      -- 6.4  Procedure Call Statement --
+      -----------------------------------
+
+      --  PROCEDURE_CALL_STATEMENT ::=
+      --    procedure_NAME; | procedure_PREFIX ACTUAL_PARAMETER_PART;
+
+      --  Note: the reason that a procedure call has expression fields is
+      --  that it semantically resembles an expression, e.g. overloading is
+      --  allowed and a type is concocted for semantic processing purposes.
+      --  Certain of these fields, such as Parens are not relevant, but it
+      --  is easier to just supply all of them together!
+
+      --  N_Procedure_Call_Statement
+      --  Sloc points to first token of name or prefix
+      --  Name (Node2) stores name or prefix
+      --  Parameter_Associations (List3) (set to No_List if no
+      --   actual parameter part)
+      --  First_Named_Actual (Node4-Sem)
+      --  Controlling_Argument (Node1-Sem) (set to Empty if not dispatching)
+      --  Do_Tag_Check (Flag13-Sem)
+      --  Parameter_List_Truncated (Flag17-Sem)
+      --  ABE_Is_Certain (Flag18-Sem)
+      --  plus fields for expression
+
+      --  If any IN parameter requires a range check, then the corresponding
+      --  argument expression has the Do_Range_Check flag set, and the range
+      --  check is done against the formal type. Note that this argument
+      --  expression may appear directly in the Parameter_Associations list,
+      --  or may be a descendent of an N_Parameter_Association node that
+      --  appears in this list.
+
+      ------------------------
+      -- 6.4  Function Call --
+      ------------------------
+
+      --  FUNCTION_CALL ::=
+      --    function_NAME | function_PREFIX ACTUAL_PARAMETER_PART
+
+      --  Note: the parser may generate an indexed component node or simply
+      --  a name node instead of a function call node. The semantic pass must
+      --  correct this misidentification.
+
+      --  N_Function_Call
+      --  Sloc points to first token of name or prefix
+      --  Name (Node2) stores name or prefix
+      --  Parameter_Associations (List3) (set to No_List if no
+      --   actual parameter part)
+      --  First_Named_Actual (Node4-Sem)
+      --  Controlling_Argument (Node1-Sem) (set to Empty if not dispatching)
+      --  Do_Tag_Check (Flag13-Sem)
+      --  Parameter_List_Truncated (Flag17-Sem)
+      --  ABE_Is_Certain (Flag18-Sem)
+      --  plus fields for expression
+
+      --------------------------------
+      -- 6.4  Actual Parameter Part --
+      --------------------------------
+
+      --  ACTUAL_PARAMETER_PART ::=
+      --    (PARAMETER_ASSOCIATION {,PARAMETER_ASSOCIATION})
+
+      --------------------------------
+      -- 6.4  Parameter Association --
+      --------------------------------
+
+      --  PARAMETER_ASSOCIATION ::=
+      --    [formal_parameter_SELECTOR_NAME =>] EXPLICIT_ACTUAL_PARAMETER
+
+      --  Note: the N_Parameter_Association node is built only if a formal
+      --  parameter selector name is present, otherwise the parameter
+      --  association appears in the tree simply as the node for the
+      --  explicit actual parameter.
+
+      --  N_Parameter_Association
+      --  Sloc points to formal parameter
+      --  Selector_Name (Node2) (always non-Empty, since this node is
+      --   only used if a formal parameter selector name is present)
+      --  Explicit_Actual_Parameter (Node3)
+      --  Next_Named_Actual (Node4-Sem)
+
+      ---------------------------
+      -- 6.4  Actual Parameter --
+      ---------------------------
+
+      --  EXPLICIT_ACTUAL_PARAMETER ::= EXPRESSION | variable_NAME
+
+      ---------------------------
+      -- 6.5  Return Statement --
+      ---------------------------
+
+      --  RETURN_STATEMENT ::= return [EXPRESSION];
+
+      --  N_Return_Statement
+      --  Sloc points to RETURN
+      --  Expression (Node3) (set to Empty if no expression present)
+      --  Storage_Pool (Node1-Sem)
+      --  Procedure_To_Call (Node4-Sem)
+      --  Do_Tag_Check (Flag13-Sem)
+      --  Return_Type (Node2-Sem)
+      --  By_Ref (Flag5-Sem)
+
+      --  Note: if a range check is required, then Do_Range_Check is set
+      --  on the Expression. The range check is against Return_Type.
+
+      ------------------------------
+      -- 7.1  Package Declaration --
+      ------------------------------
+
+      --  PACKAGE_DECLARATION ::= PACKAGE_SPECIFICATION;
+
+      --  Note: the activation chain entity for a package spec is used for
+      --  all tasks declared in the package spec, or in the package body.
+
+      --  N_Package_Declaration
+      --  Sloc points to PACKAGE
+      --  Specification (Node1)
+      --  Corresponding_Body (Node5-Sem)
+      --  Parent_Spec (Node4-Sem)
+      --  Activation_Chain_Entity (Node3-Sem)
+
+      --------------------------------
+      -- 7.1  Package Specification --
+      --------------------------------
+
+      --  PACKAGE_SPECIFICATION ::=
+      --    package DEFINING_PROGRAM_UNIT_NAME is
+      --      {BASIC_DECLARATIVE_ITEM}
+      --    [private
+      --      {BASIC_DECLARATIVE_ITEM}]
+      --    end [[PARENT_UNIT_NAME .] IDENTIFIER]
+
+      --  N_Package_Specification
+      --  Sloc points to PACKAGE
+      --  Defining_Unit_Name (Node1)
+      --  Visible_Declarations (List2)
+      --  Private_Declarations (List3) (set to No_List if no private
+      --   part present)
+      --  End_Label (Node4)
+      --  Generic_Parent (Node5-Sem)
+
+      -----------------------
+      -- 7.1  Package Body --
+      -----------------------
+
+      --  PACKAGE_BODY ::=
+      --    package body DEFINING_PROGRAM_UNIT_NAME is
+      --      DECLARATIVE_PART
+      --    [begin
+      --      HANDLED_SEQUENCE_OF_STATEMENTS]
+      --    end [[PARENT_UNIT_NAME .] IDENTIFIER];
+
+      --  N_Package_Body
+      --  Sloc points to PACKAGE
+      --  Defining_Unit_Name (Node1)
+      --  Declarations (List2)
+      --  Handled_Statement_Sequence (Node4) (set to Empty if no HSS present)
+      --  Corresponding_Spec (Node5-Sem)
+      --  Was_Originally_Stub (Flag13-Sem)
+
+      --  Note: if a source level package does not contain a handled sequence
+      --  of statements, then the parser supplies a dummy one with a null
+      --  sequence of statements. Comes_From_Source will be False in this
+      --  constructed sequence. The reason we need this is for the End_Label
+      --  field in the HSS.
+
+      -----------------------------------
+      -- 7.4  Private Type Declaration --
+      -----------------------------------
+
+      --  PRIVATE_TYPE_DECLARATION ::=
+      --    type DEFINING_IDENTIFIER [DISCRIMINANT_PART]
+      --      is [[abstract] tagged] [limited] private;
+
+      --  Note: TAGGED is not permitted in Ada 83 mode
+
+      --  N_Private_Type_Declaration
+      --  Sloc points to TYPE
+      --  Defining_Identifier (Node1)
+      --  Discriminant_Specifications (List4) (set to No_List if no
+      --   discriminant part)
+      --  Unknown_Discriminants_Present (Flag13) set if (<>) discriminant
+      --  Abstract_Present (Flag4)
+      --  Tagged_Present (Flag15)
+      --  Limited_Present (Flag17)
+
+      ----------------------------------------
+      -- 7.4  Private Extension Declaration --
+      ----------------------------------------
+
+      --  PRIVATE_EXTENSION_DECLARATION ::=
+      --    type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is
+      --      [abstract] new ancestor_SUBTYPE_INDICATION with private;
+
+      --  Note: private extension declarations are not allowed in Ada 83 mode
+
+      --  N_Private_Extension_Declaration
+      --  Sloc points to TYPE
+      --  Defining_Identifier (Node1)
+      --  Discriminant_Specifications (List4) (set to No_List if no
+      --   discriminant part)
+      --  Unknown_Discriminants_Present (Flag13) set if (<>) discriminant
+      --  Abstract_Present (Flag4)
+      --  Subtype_Indication (Node5)
+
+      ---------------------
+      -- 8.4  Use Clause --
+      ---------------------
+
+      --  USE_CLAUSE ::= USE_PACKAGE_CLAUSE | USE_TYPE_CLAUSE
+
+      -----------------------------
+      -- 8.4  Use Package Clause --
+      -----------------------------
+
+      --  USE_PACKAGE_CLAUSE ::= use package_NAME {, package_NAME};
+
+      --  N_Use_Package_Clause
+      --  Sloc points to USE
+      --  Names (List2)
+      --  Next_Use_Clause (Node3-Sem)
+      --  Hidden_By_Use_Clause (Elist4-Sem)
+
+      --------------------------
+      -- 8.4  Use Type Clause --
+      --------------------------
+
+      --  USE_TYPE_CLAUSE ::= use type SUBTYPE_MARK {, SUBTYPE_MARK};
+
+      --  Note: use type clause is not permitted in Ada 83 mode
+
+      --  N_Use_Type_Clause
+      --  Sloc points to USE
+      --  Subtype_Marks (List2)
+      --  Next_Use_Clause (Node3-Sem)
+      --  Hidden_By_Use_Clause (Elist4-Sem)
+
+      -------------------------------
+      -- 8.5  Renaming Declaration --
+      -------------------------------
+
+      --  RENAMING_DECLARATION ::=
+      --    OBJECT_RENAMING_DECLARATION
+      --  | EXCEPTION_RENAMING_DECLARATION
+      --  | PACKAGE_RENAMING_DECLARATION
+      --  | SUBPROGRAM_RENAMING_DECLARATION
+      --  | GENERIC_RENAMING_DECLARATION
+
+      --------------------------------------
+      -- 8.5  Object Renaming Declaration --
+      --------------------------------------
+
+      --  OBJECT_RENAMING_DECLARATION ::=
+      --    DEFINING_IDENTIFIER : SUBTYPE_MARK renames object_NAME;
+
+      --  N_Object_Renaming_Declaration
+      --  Sloc points to first identifier
+      --  Defining_Identifier (Node1)
+      --  Subtype_Mark (Node4)
+      --  Name (Node2)
+      --  Corresponding_Generic_Association (Node5-Sem)
+
+      -----------------------------------------
+      -- 8.5  Exception Renaming Declaration --
+      -----------------------------------------
+
+      --  EXCEPTION_RENAMING_DECLARATION ::=
+      --    DEFINING_IDENTIFIER : exception renames exception_NAME;
+
+      --  N_Exception_Renaming_Declaration
+      --  Sloc points to first identifier
+      --  Defining_Identifier (Node1)
+      --  Name (Node2)
+
+      ---------------------------------------
+      -- 8.5  Package Renaming Declaration --
+      ---------------------------------------
+
+      --  PACKAGE_RENAMING_DECLARATION ::=
+      --    package DEFINING_PROGRAM_UNIT_NAME renames package_NAME;
+
+      --  N_Package_Renaming_Declaration
+      --  Sloc points to PACKAGE
+      --  Defining_Unit_Name (Node1)
+      --  Name (Node2)
+      --  Parent_Spec (Node4-Sem)
+
+      ------------------------------------------
+      -- 8.5  Subprogram Renaming Declaration --
+      ------------------------------------------
+
+      --  SUBPROGRAM_RENAMING_DECLARATION ::=
+      --    SUBPROGRAM_SPECIFICATION renames callable_entity_NAME;
+
+      --  N_Subprogram_Renaming_Declaration
+      --  Sloc points to RENAMES
+      --  Specification (Node1)
+      --  Name (Node2)
+      --  Parent_Spec (Node4-Sem)
+      --  Corresponding_Spec (Node5-Sem)
+
+      -----------------------------------------
+      -- 8.5.5  Generic Renaming Declaration --
+      -----------------------------------------
+
+      --  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
+
+      --  N_Generic_Package_Renaming_Declaration
+      --  Sloc points to GENERIC
+      --  Defining_Unit_Name (Node1)
+      --  Name (Node2)
+      --  Parent_Spec (Node4-Sem)
+
+      --  N_Generic_Procedure_Renaming_Declaration
+      --  Sloc points to GENERIC
+      --  Defining_Unit_Name (Node1)
+      --  Name (Node2)
+      --  Parent_Spec (Node4-Sem)
+
+      --  N_Generic_Function_Renaming_Declaration
+      --  Sloc points to GENERIC
+      --  Defining_Unit_Name (Node1)
+      --  Name (Node2)
+      --  Parent_Spec (Node4-Sem)
+
+      --------------------------------
+      -- 9.1  Task Type Declaration --
+      --------------------------------
+
+      --  TASK_TYPE_DECLARATION ::=
+      --    task type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART]
+      --      [is TASK_DEFINITITION];
+
+      --  N_Task_Type_Declaration
+      --  Sloc points to TASK
+      --  Defining_Identifier (Node1)
+      --  Task_Body_Procedure (Node2-Sem)
+      --  Discriminant_Specifications (List4) (set to No_List if no
+      --   discriminant part)
+      --  Task_Definition (Node3) (set to Empty if not present)
+      --  Corresponding_Body (Node5-Sem)
+
+      ----------------------------------
+      -- 9.1  Single Task Declaration --
+      ----------------------------------
+
+      --  SINGLE_TASK_DECLARATION ::=
+      --    task DEFINING_IDENTIFIER [is TASK_DEFINITION];
+
+      --  N_Single_Task_Declaration
+      --  Sloc points to TASK
+      --  Defining_Identifier (Node1)
+      --  Task_Definition (Node3) (set to Empty if not present)
+
+      --------------------------
+      -- 9.1  Task Definition --
+      --------------------------
+
+      --  TASK_DEFINITION ::=
+      --      {TASK_ITEM}
+      --    [private
+      --      {TASK_ITEM}]
+      --    end [task_IDENTIFIER]
+
+      --  Note: as a result of semantic analysis, the list of task items can
+      --  include implicit type declarations resulting from entry families.
+
+      --  N_Task_Definition
+      --  Sloc points to first token of task definition
+      --  Visible_Declarations (List2)
+      --  Private_Declarations (List3) (set to No_List if no private part)
+      --  End_Label (Node4)
+      --  Has_Priority_Pragma (Flag6-Sem)
+      --  Has_Storage_Size_Pragma (Flag5-Sem)
+      --  Has_Task_Info_Pragma (Flag7-Sem)
+      --  Has_Task_Name_Pragma (Flag8-Sem)
+
+      --------------------
+      -- 9.1  Task Item --
+      --------------------
+
+      --  TASK_ITEM ::= ENTRY_DECLARATION | REPRESENTATION_CLAUSE
+
+      --------------------
+      -- 9.1  Task Body --
+      --------------------
+
+      --  TASK_BODY ::=
+      --    task body task_DEFINING_IDENTIFIER is
+      --      DECLARATIVE_PART
+      --    begin
+      --      HANDLED_SEQUENCE_OF_STATEMENTS
+      --    end [task_IDENTIFIER];
+
+      --  Gigi restriction: This node never appears.
+
+      --  N_Task_Body
+      --  Sloc points to TASK
+      --  Defining_Identifier (Node1)
+      --  Declarations (List2)
+      --  Handled_Statement_Sequence (Node4)
+      --  Is_Task_Master (Flag5-Sem)
+      --  Activation_Chain_Entity (Node3-Sem)
+      --  Corresponding_Spec (Node5-Sem)
+      --  Was_Originally_Stub (Flag13-Sem)
+
+      -------------------------------------
+      -- 9.4  Protected Type Declaration --
+      -------------------------------------
+
+      --  PROTECTED_TYPE_DECLARATION ::=
+      --    protected type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART]
+      --      is PROTECTED_DEFINITION;
+
+      --  Note: protected type declarations are not permitted in Ada 83 mode
+
+      --  N_Protected_Type_Declaration
+      --  Sloc points to PROTECTED
+      --  Defining_Identifier (Node1)
+      --  Discriminant_Specifications (List4) (set to No_List if no
+      --   discriminant part)
+      --  Protected_Definition (Node3)
+      --  Corresponding_Body (Node5-Sem)
+
+      ---------------------------------------
+      -- 9.4  Single Protected Declaration --
+      ---------------------------------------
+
+      --  SINGLE_PROTECTED_DECLARATION ::=
+      --    protected DEFINING_IDENTIFIER is PROTECTED_DEFINITION;
+
+      --  Note: single protected declarations are not allowed in Ada 83 mode
+
+      --  N_Single_Protected_Declaration
+      --  Sloc points to PROTECTED
+      --  Defining_Identifier (Node1)
+      --  Protected_Definition (Node3)
+
+      -------------------------------
+      -- 9.4  Protected Definition --
+      -------------------------------
+
+      --  PROTECTED_DEFINITION ::=
+      --      {PROTECTED_OPERATION_DECLARATION}
+      --    [private
+      --      {PROTECTED_ELEMENT_DECLARATION}]
+      --    end [protected_IDENTIFIER]
+
+      --  N_Protected_Definition
+      --  Sloc points to first token of protected definition
+      --  Visible_Declarations (List2)
+      --  Private_Declarations (List3) (set to No_List if no private part)
+      --  End_Label (Node4)
+      --  Has_Priority_Pragma (Flag6-Sem)
+
+      ------------------------------------------
+      -- 9.4  Protected Operation Declaration --
+      ------------------------------------------
+
+      --  PROTECTED_OPERATION_DECLARATION ::=
+      --    SUBPROGRAM_DECLARATION
+      --  | ENTRY_DECLARATION
+      --  | REPRESENTATION_CLAUSE
+
+      ----------------------------------------
+      -- 9.4  Protected Element Declaration --
+      ----------------------------------------
+
+      --  PROTECTED_ELEMENT_DECLARATION ::=
+      --    PROTECTED_OPERATION_DECLARATION | COMPONENT_DECLARATION
+
+      -------------------------
+      -- 9.4  Protected Body --
+      -------------------------
+
+      --  PROTECTED_BODY ::=
+      --    protected body DEFINING_IDENTIFIER is
+      --      {PROTECTED_OPERATION_ITEM}
+      --    end [protected_IDENTIFIER];
+
+      --  Note: protected bodies are not allowed in Ada 83 mode
+
+      --  Gigi restriction: This node never appears.
+
+      --  N_Protected_Body
+      --  Sloc points to PROTECTED
+      --  Defining_Identifier (Node1)
+      --  Declarations (List2) protected operation items (and pragmas)
+      --  End_Label (Node4)
+      --  Corresponding_Spec (Node5-Sem)
+      --  Was_Originally_Stub (Flag13-Sem)
+
+      -----------------------------------
+      -- 9.4  Protected Operation Item --
+      -----------------------------------
+
+      --  PROTECTED_OPERATION_ITEM ::=
+      --    SUBPROGRAM_DECLARATION
+      --  | SUBPROGRAM_BODY
+      --  | ENTRY_BODY
+      --  | REPRESENTATION_CLAUSE
+
+      ------------------------------
+      -- 9.5.2  Entry Declaration --
+      ------------------------------
+
+      --  ENTRY_DECLARATION ::=
+      --    entry DEFINING_IDENTIFIER
+      --      [(DISCRETE_SUBTYPE_DEFINITION)] PARAMETER_PROFILE;
+
+      --  N_Entry_Declaration
+      --  Sloc points to ENTRY
+      --  Defining_Identifier (Node1)
+      --  Discrete_Subtype_Definition (Node4) (set to Empty if not present)
+      --  Parameter_Specifications (List3) (set to No_List if no formal part)
+
+      -----------------------------
+      -- 9.5.2  Accept statement --
+      -----------------------------
+
+      --  ACCEPT_STATEMENT ::=
+      --    accept entry_DIRECT_NAME
+      --      [(ENTRY_INDEX)] PARAMETER_PROFILE [do
+      --        HANDLED_SEQUENCE_OF_STATEMENTS
+      --    end [entry_IDENTIFIER]];
+
+      --  Gigi restriction: This node never appears.
+
+      --  Note: there are no explicit declarations allowed in an accept
+      --  statement. However, the implicit declarations for any statement
+      --  identifiers (labels and block/loop identifiers) are declarations
+      --  that belong logically to the accept statement, and that is why
+      --  there is a Declarations field in this node.
+
+      --  N_Accept_Statement
+      --  Sloc points to ACCEPT
+      --  Entry_Direct_Name (Node1)
+      --  Entry_Index (Node5) (set to Empty if not present)
+      --  Parameter_Specifications (List3) (set to No_List if no formal part)
+      --  Handled_Statement_Sequence (Node4)
+      --  Declarations (List2) (set to No_List if no declarations)
+
+      ------------------------
+      -- 9.5.2  Entry Index --
+      ------------------------
+
+      --  ENTRY_INDEX ::= EXPRESSION
+
+      -----------------------
+      -- 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];
+
+      --  ENTRY_BARRIER ::= when CONDITION
+
+      --  Note: we store the CONDITION of the ENTRY_BARRIER in the node for
+      --  the ENTRY_BODY_FORMAL_PART to avoid the N_Entry_Body node getting
+      --  too full (it would otherwise have too many fields)
+
+      --  Gigi restriction: This node never appears.
+
+      --  N_Entry_Body
+      --  Sloc points to ENTRY
+      --  Defining_Identifier (Node1)
+      --  Entry_Body_Formal_Part (Node5)
+      --  Declarations (List2)
+      --  Handled_Statement_Sequence (Node4)
+      --  Activation_Chain_Entity (Node3-Sem)
+
+      -----------------------------------
+      -- 9.5.2  Entry Body Formal Part --
+      -----------------------------------
+
+      --  ENTRY_BODY_FORMAL_PART ::=
+      --    [(ENTRY_INDEX_SPECIFICATION)] PARAMETER_PROFILE
+
+      --  Note that an entry body formal part node is present even if it is
+      --  empty. This reflects the grammar, in which it is the components of
+      --  the entry body formal part that are optional, not the entry body
+      --  formal part itself. Also this means that the barrier condition
+      --  always has somewhere to be stored.
+
+      --  Gigi restriction: This node never appears.
+
+      --  N_Entry_Body_Formal_Part
+      --  Sloc points to first token
+      --  Entry_Index_Specification (Node4) (set to Empty if not present)
+      --  Parameter_Specifications (List3) (set to No_List if no formal part)
+      --  Condition (Node1) from entry barrier of entry body
+
+      --------------------------
+      -- 9.5.2  Entry Barrier --
+      --------------------------
+
+      --  ENTRY_BARRIER ::= when CONDITION
+
+      --------------------------------------
+      -- 9.5.2  Entry Index Specification --
+      --------------------------------------
+
+      --  ENTRY_INDEX_SPECIFICATION ::=
+      --    for DEFINING_IDENTIFIER in DISCRETE_SUBTYPE_DEFINITION
+
+      --  Gigi restriction: This node never appears.
+
+      --  N_Entry_Index_Specification
+      --  Sloc points to FOR
+      --  Defining_Identifier (Node1)
+      --  Discrete_Subtype_Definition (Node4)
+
+      ---------------------------------
+      -- 9.5.3  Entry Call Statement --
+      ---------------------------------
+
+      --  ENTRY_CALL_STATEMENT ::= entry_NAME [ACTUAL_PARAMETER_PART];
+
+      --  The parser may generate a procedure call for this construct. The
+      --  semantic pass must correct this misidentification where needed.
+
+      --  Gigi restriction: This node never appears.
+
+      --  N_Entry_Call_Statement
+      --  Sloc points to first token of name
+      --  Name (Node2)
+      --  Parameter_Associations (List3) (set to No_List if no
+      --   actual parameter part)
+      --  First_Named_Actual (Node4-Sem)
+
+      ------------------------------
+      -- 9.5.4  Requeue Statement --
+      ------------------------------
+
+      --  REQUEUE_STATEMENT ::= requeue entry_NAME [with abort];
+
+      --  Note: requeue statements are not permitted in Ada 83 mode
+
+      --  Gigi restriction: This node never appears.
+
+      --  N_Requeue_Statement
+      --  Sloc points to REQUEUE
+      --  Name (Node2)
+      --  Abort_Present (Flag15)
+
+      --------------------------
+      -- 9.6  Delay Statement --
+      --------------------------
+
+      --  DELAY_STATEMENT ::=
+      --    DELAY_UNTIL_STATEMENT
+      --  | DELAY_RELATIVE_STATEMENT
+
+      --------------------------------
+      -- 9.6  Delay Until Statement --
+      --------------------------------
+
+      --  DELAY_UNTIL_STATEMENT ::= delay until delay_EXPRESSION;
+
+      --  Note: delay until statements are not permitted in Ada 83 mode
+
+      --  Gigi restriction: This node never appears.
+
+      --  N_Delay_Until_Statement
+      --  Sloc points to DELAY
+      --  Expression (Node3)
+
+      -----------------------------------
+      -- 9.6  Delay Relative Statement --
+      -----------------------------------
+
+      --  DELAY_RELATIVE_STATEMENT ::= delay delay_EXPRESSION;
+
+      --  Gigi restriction: This node never appears.
+
+      --  N_Delay_Relative_Statement
+      --  Sloc points to DELAY
+      --  Expression (Node3)
+
+      ---------------------------
+      -- 9.7  Select Statement --
+      ---------------------------
+
+      --  SELECT_STATEMENT ::=
+      --    SELECTIVE_ACCEPT
+      --  | TIMED_ENTRY_CALL
+      --  | CONDITIONAL_ENTRY_CALL
+      --  | ASYNCHRONOUS_SELECT
+
+      -----------------------------
+      -- 9.7.1  Selective Accept --
+      -----------------------------
+
+      --  SELECTIVE_ACCEPT ::=
+      --    select
+      --      [GUARD]
+      --        SELECT_ALTERNATIVE
+      --    {or
+      --      [GUARD]
+      --        SELECT_ALTERNATIVE}
+      --    [else
+      --      SEQUENCE_OF_STATEMENTS]
+      --    end select;
+
+      --  Gigi restriction: This node never appears.
+
+      --  Note: the guard expression, if present, appears in the node for
+      --  the select alternative.
+
+      --  N_Selective_Accept
+      --  Sloc points to SELECT
+      --  Select_Alternatives (List1)
+      --  Else_Statements (List4) (set to No_List if no else part)
+
+      ------------------
+      -- 9.7.1  Guard --
+      ------------------
+
+      --  GUARD ::= when CONDITION =>
+
+      --  As noted above, the CONDITION that is part of a GUARD is included
+      --  in the node for the select alernative for convenience.
+
+      -------------------------------
+      -- 9.7.1  Select Alternative --
+      -------------------------------
+
+      --  SELECT_ALTERNATIVE ::=
+      --    ACCEPT_ALTERNATIVE
+      --  | DELAY_ALTERNATIVE
+      --  | TERMINATE_ALTERNATIVE
+
+      -------------------------------
+      -- 9.7.1  Accept Alternative --
+      -------------------------------
+
+      --  ACCEPT_ALTERNATIVE ::=
+      --    ACCEPT_STATEMENT [SEQUENCE_OF_STATEMENTS]
+
+      --  Gigi restriction: This node never appears.
+
+      --  N_Accept_Alternative
+      --  Sloc points to ACCEPT
+      --  Accept_Statement (Node2)
+      --  Condition (Node1) from the guard (set to Empty if no guard present)
+      --  Statements (List3) (set to Empty_List if no statements)
+      --  Pragmas_Before (List4) pragmas before alt (set to No_List if none)
+      --  Accept_Handler_Records (List5-Sem)
+
+      ------------------------------
+      -- 9.7.1  Delay Alternative --
+      ------------------------------
+
+      --  DELAY_ALTERNATIVE ::=
+      --    DELAY_STATEMENT [SEQUENCE_OF_STATEMENTS]
+
+      --  Gigi restriction: This node never appears.
+
+      --  N_Delay_Alternative
+      --  Sloc points to DELAY
+      --  Delay_Statement (Node2)
+      --  Condition (Node1) from the guard (set to Empty if no guard present)
+      --  Statements (List3) (set to Empty_List if no statements)
+      --  Pragmas_Before (List4) pragmas before alt (set to No_List if none)
+
+      ----------------------------------
+      -- 9.7.1  Terminate Alternative --
+      ----------------------------------
+
+      --  TERMINATE_ALTERNATIVE ::= terminate;
+
+      --  Gigi restriction: This node never appears.
+
+      --  N_Terminate_Alternative
+      --  Sloc points to TERMINATE
+      --  Condition (Node1) from the guard (set to Empty if no guard present)
+      --  Pragmas_Before (List4) pragmas before alt (set to No_List if none)
+      --  Pragmas_After (List5) pragmas after alt (set to No_List if none)
+
+      -----------------------------
+      -- 9.7.2  Timed Entry Call --
+      -----------------------------
+
+      --  TIMED_ENTRY_CALL ::=
+      --    select
+      --      ENTRY_CALL_ALTERNATIVE
+      --    or
+      --      DELAY_ALTERNATIVE
+      --    end select;
+
+      --  Gigi restriction: This node never appears.
+
+      --  N_Timed_Entry_Call
+      --  Sloc points to SELECT
+      --  Entry_Call_Alternative (Node1)
+      --  Delay_Alternative (Node4)
+
+      -----------------------------------
+      -- 9.7.2  Entry Call Alternative --
+      -----------------------------------
+
+      --  ENTRY_CALL_ALTERNATIVE ::=
+      --    ENTRY_CALL_STATEMENT [SEQUENCE_OF_STATEMENTS]
+
+      --  Gigi restriction: This node never appears.
+
+      --  N_Entry_Call_Alternative
+      --  Sloc points to first token of entry call statement
+      --  Entry_Call_Statement (Node1)
+      --  Statements (List3) (set to Empty_List if no statements)
+      --  Pragmas_Before (List4) pragmas before alt (set to No_List if none)
+
+      -----------------------------------
+      -- 9.7.3  Conditional Entry Call --
+      -----------------------------------
+
+      --  CONDITIONAL_ENTRY_CALL ::=
+      --    select
+      --      ENTRY_CALL_ALTERNATIVE
+      --    else
+      --      SEQUENCE_OF_STATEMENTS
+      --    end select;
+
+      --  Gigi restriction: This node never appears.
+
+      --  N_Conditional_Entry_Call
+      --  Sloc points to SELECT
+      --  Entry_Call_Alternative (Node1)
+      --  Else_Statements (List4)
+
+      --------------------------------
+      -- 9.7.4  Asynchronous Select --
+      --------------------------------
+
+      --  ASYNCHRONOUS_SELECT ::=
+      --    select
+      --      TRIGGERING_ALTERNATIVE
+      --    then abort
+      --      ABORTABLE_PART
+      --    end select;
+
+      --  Note: asynchronous select is not permitted in Ada 83 mode
+
+      --  Gigi restriction: This node never appears.
+
+      --  N_Asynchronous_Select
+      --  Sloc points to SELECT
+      --  Triggering_Alternative (Node1)
+      --  Abortable_Part (Node2)
+
+      -----------------------------------
+      -- 9.7.4  Triggering Alternative --
+      -----------------------------------
+
+      --  TRIGGERING_ALTERNATIVE ::=
+      --    TRIGGERING_STATEMENT [SEQUENCE_OF_STATEMENTS]
+
+      --  Gigi restriction: This node never appears.
+
+      --  N_Triggering_Alternative
+      --  Sloc points to first token of triggering statement
+      --  Triggering_Statement (Node1)
+      --  Statements (List3) (set to Empty_List if no statements)
+      --  Pragmas_Before (List4) pragmas before alt (set to No_List if none)
+
+      ---------------------------------
+      -- 9.7.4  Triggering Statement --
+      ---------------------------------
+
+      --  TRIGGERING_STATEMENT ::= ENTRY_CALL_STATEMENT | DELAY_STATEMENT
+
+      ---------------------------
+      -- 9.7.4  Abortable Part --
+      ---------------------------
+
+      --  ABORTABLE_PART ::= SEQUENCE_OF_STATEMENTS
+
+      --  Gigi restriction: This node never appears.
+
+      --  N_Abortable_Part
+      --  Sloc points to ABORT
+      --  Statements (List3)
+
+      --------------------------
+      -- 9.8  Abort Statement --
+      --------------------------
+
+      --  ABORT_STATEMENT ::= abort task_NAME {, task_NAME};
+
+      --  Gigi restriction: This node never appears.
+
+      --  N_Abort_Statement
+      --  Sloc points to ABORT
+      --  Names (List2)
+
+      -------------------------
+      -- 10.1.1  Compilation --
+      -------------------------
+
+      --  COMPILATION ::= {COMPILATION_UNIT}
+
+      --  There is no explicit node in the tree for a compilation, since in
+      --  general the compiler is processing only a single compilation unit
+      --  at a time. It is possible to parse multiple units in syntax check
+      --  only mode, but they the trees are discarded in any case.
+
+      ------------------------------
+      -- 10.1.1  Compilation Unit --
+      ------------------------------
+
+      --  COMPILATION_UNIT ::=
+      --    CONTEXT_CLAUSE LIBRARY_ITEM
+      --  | CONTEXT_CLAUSE SUBUNIT
+
+      --  The N_Compilation_Unit node itself respresents the above syntax.
+      --  However, there are two additional items not reflected in the above
+      --  syntax. First we have the global declarations that are added by the
+      --  code generator. These are outer level declarations (so they cannot
+      --  be represented as being inside the units). An example is the wrapper
+      --  subprograms that are created to do ABE checking. As always a list of
+      --  declarations can contain actions as well (i.e. statements), and such
+      --  statements are executed as part of the elaboration of the unit. Note
+      --  that all such declarations are elaborated before the library unit.
+
+      --  Similarly, certain actions need to be elaborated at the completion
+      --  of elaboration of the library unit (notably the statement that sets
+      --  the Boolean flag indicating that elaboration is complete).
+
+      --  The third item not reflected in the syntax is pragmas that appear
+      --  after the compilation unit. As always pragmas are a problem since
+      --  they are not part of the formal syntax, but can be stuck into the
+      --  source following a set of ad hoc rules, and we have to find an ad
+      --  hoc way of sticking them into the tree. For pragmas that appear
+      --  before the library unit, we just consider them to be part of the
+      --  context clause, and pragmas can appear in the Context_Items list
+      --  of the compilation unit. However, pragmas can also appear after
+      --  the library item.
+
+      --  To deal with all these problems, we create an auxiliary node for
+      --  a compilation unit, referenced from the N_Compilation_Unit node
+      --  that contains these three items.
+
+      --  N_Compilation_Unit
+      --  Sloc points to first token of defining unit name
+      --  Library_Unit (Node4-Sem) corresponding/parent spec/body
+      --  Context_Items (List1) context items and pragmas preceding unit
+      --  Private_Present (Flag15) set if library unit has private keyword
+      --  Unit (Node2) library item or subunit
+      --  Aux_Decls_Node (Node5) points to the N_Compilation_Unit_Aux node
+      --  Has_No_Elaboration_Code (Flag17-Sem)
+      --  Body_Required (Flag13-Sem) set for spec if body is required
+      --  Acts_As_Spec (Flag4-Sem) flag for subprogram body with no spec
+      --  First_Inlined_Subprogram (Node3-Sem)
+
+      --  N_Compilation_Unit_Aux
+      --  Sloc is a copy of the Sloc from the N_Compilation_Unit node
+      --  Declarations (List2) (set to No_List if no global declarations)
+      --  Actions (List1) (set to No_List if no actions)
+      --  Pragmas_After (List5) pragmas after unit (set to No_List if none)
+
+      --------------------------
+      -- 10.1.1  Library Item --
+      --------------------------
+
+      --  LIBRARY_ITEM ::=
+      --    [private] LIBRARY_UNIT_DECLARATION
+      --  | LIBRARY_UNIT_BODY
+      --  | [private] LIBRARY_UNIT_RENAMING_DECLARATION
+
+      --  Note: PRIVATE is not allowed in Ada 83 mode
+
+      --  There is no explicit node in the tree for library item, instead
+      --  the declaration or body, and the flag for private if present,
+      --  appear in the N_Compilation_Unit clause.
+
+      ----------------------------------------
+      -- 10.1.1  Library Unit Declararation --
+      ----------------------------------------
+
+      --  LIBRARY_UNIT_DECLARATION ::=
+      --    SUBPROGRAM_DECLARATION | PACKAGE_DECLARATION
+      --  | GENERIC_DECLARATION    | GENERIC_INSTANTIATION
+
+      -------------------------------------------------
+      -- 10.1.1  Library Unit Renaming Declararation --
+      -------------------------------------------------
+
+      --  LIBRARY_UNIT_RENAMING_DECLARATION ::=
+      --    PACKAGE_RENAMING_DECLARATION
+      --  | GENERIC_RENAMING_DECLARATION
+      --  | SUBPROGRAM_RENAMING_DECLARATION
+
+      -------------------------------
+      -- 10.1.1  Library unit body --
+      -------------------------------
+
+      --  LIBRARY_UNIT_BODY ::= SUBPROGRAM_BODY | PACKAGE_BODY
+
+      ------------------------------
+      -- 10.1.1  Parent Unit Name --
+      ------------------------------
+
+      --  PARENT_UNIT_NAME ::= NAME
+
+      ----------------------------
+      -- 10.1.2  Context clause --
+      ----------------------------
+
+      --  CONTEXT_CLAUSE ::= {CONTEXT_ITEM}
+
+      --  The context clause can include pragmas, and any pragmas that appear
+      --  before the context clause proper (i.e. all configuration pragmas,
+      --  also appear at the front of this list).
+
+      --------------------------
+      -- 10.1.2  Context_Item --
+      --------------------------
+
+      --  CONTEXT_ITEM ::= WITH_CLAUSE | USE_CLAUSE  | WITH_TYPE_CLAUSE
+
+      -------------------------
+      -- 10.1.2  With clause --
+      -------------------------
+
+      --  WITH_CLAUSE ::=
+      --    with library_unit_NAME {,library_unit_NAME};
+
+      --  A separate With clause is built for each name, so that we have
+      --  a Corresponding_Spec field for each with'ed spec. The flags
+      --  First_Name and Last_Name are used to reconstruct the exact
+      --  source form. When a list of names appears in one with clause,
+      --  the first name in the list has First_Name set, and the last
+      --  has Last_Name set. If the with clause has only one name, then
+      --  both of the flags First_Name and Last_Name are set in this name.
+
+      --  Note: in the case of implicit with's that are installed by the
+      --  Rtsfind routine, Implicit_With is set, and the Sloc is typically
+      --  set to Standard_Location, but it is incorrect to test the Sloc
+      --  to find out if a with clause is implicit, test the flag instead.
+
+      --  N_With_Clause
+      --  Sloc points to first token of library unit name
+      --  Name (Node2)
+      --  Library_Unit (Node4-Sem)
+      --  Corresponding_Spec (Node5-Sem)
+      --  First_Name (Flag5) (set to True if first name or only one name)
+      --  Last_Name (Flag6) (set to True if last name or only one name)
+      --  Context_Installed (Flag13-Sem)
+      --  Elaborate_Present (Flag4-Sem)
+      --  Elaborate_All_Present (Flag15-Sem)
+      --  Implicit_With (Flag17-Sem)
+      --  Unreferenced_In_Spec (Flag7-Sem)
+      --  No_Entities_Ref_In_Spec (Flag8-Sem)
+
+      ----------------------
+      -- With_Type clause --
+      ----------------------
+
+      --  This is a GNAT extension, used to implement mutually recursive
+      --  types declared in different packages.
+
+      --  WITH_TYPE_CLAUSE ::=
+      --    with type type_NAME is access | with type type_NAME is tagged
+
+      --  N_With_Type_Clause
+      --  Sloc points to first token of type name
+      --  Name (Node2)
+      --  Tagged_Present (Flag15)
+
+      ---------------------
+      -- 10.2  Body stub --
+      ---------------------
+
+      --  BODY_STUB ::=
+      --    SUBPROGRAM_BODY_STUB
+      --  | PACKAGE_BODY_STUB
+      --  | TASK_BODY_STUB
+      --  | PROTECTED_BODY_STUB
+
+      ----------------------------------
+      -- 10.1.3  Subprogram Body Stub --
+      ----------------------------------
+
+      --  SUBPROGRAM_BODY_STUB ::=
+      --    SUBPROGRAM_SPECIFICATION is separate;
+
+      --  N_Subprogram_Body_Stub
+      --  Sloc points to FUNCTION or PROCEDURE
+      --  Specification (Node1)
+      --  Library_Unit (Node4-Sem) points to the subunit
+      --  Corresponding_Body (Node5-Sem)
+
+      -------------------------------
+      -- 10.1.3  Package Body Stub --
+      -------------------------------
+
+      --  PACKAGE_BODY_STUB ::=
+      --    package body DEFINING_IDENTIFIER is separate;
+
+      --  N_Package_Body_Stub
+      --  Sloc points to PACKAGE
+      --  Defining_Identifier (Node1)
+      --  Library_Unit (Node4-Sem) points to the subunit
+      --  Corresponding_Body (Node5-Sem)
+
+      ----------------------------
+      -- 10.1.3  Task Body Stub --
+      ----------------------------
+
+      --  TASK_BODY_STUB ::=
+      --    task body DEFINING_IDENTIFIER is separate;
+
+      --  N_Task_Body_Stub
+      --  Sloc points to TASK
+      --  Defining_Identifier (Node1)
+      --  Library_Unit (Node4-Sem) points to the subunit
+      --  Corresponding_Body (Node5-Sem)
+
+      ---------------------------------
+      -- 10.1.3  Protected Body Stub --
+      ---------------------------------
+
+      --  PROTECTED_BODY_STUB ::=
+      --    protected body DEFINING_IDENTIFIER is separate;
+
+      --  Note: protected body stubs are not allowed in Ada 83 mode
+
+      --  N_Protected_Body_Stub
+      --  Sloc points to PROTECTED
+      --  Defining_Identifier (Node1)
+      --  Library_Unit (Node4-Sem) points to the subunit
+      --  Corresponding_Body (Node5-Sem)
+
+      ---------------------
+      -- 10.1.3  Subunit --
+      ---------------------
+
+      --  SUBUNIT ::= separate (PARENT_UNIT_NAME) PROPER_BODY
+
+      --  N_Subunit
+      --  Sloc points to SEPARATE
+      --  Name (Node2) is the name of the parent unit
+      --  Proper_Body (Node1) is the subunit body
+      --  Corresponding_Stub (Node3-Sem) is the stub declaration for the unit.
+
+      ---------------------------------
+      -- 11.1  Exception Declaration --
+      ---------------------------------
+
+      --  EXCEPTION_DECLARATION ::= DEFINING_IDENTIFIER_LIST : exception;
+
+      --  For consistency with object declarations etc, the parser converts
+      --  the case of multiple identifiers being declared to a series of
+      --  declarations in which the expression is copied, using the More_Ids
+      --  and Prev_Ids flags to remember the souce form as described in the
+      --  section on "Handling of Defining Identifier Lists".
+
+      --  N_Exception_Declaration
+      --  Sloc points to EXCEPTION
+      --  Defining_Identifier (Node1)
+      --  Expression (Node3-Sem)
+      --  More_Ids (Flag5) (set to False if no more identifiers in list)
+      --  Prev_Ids (Flag6) (set to False if no previous identifiers in list)
+
+      ------------------------------------------
+      -- 11.2  Handled Sequence Of Statements --
+      ------------------------------------------
+
+      --  HANDLED_SEQUENCE_OF_STATEMENTS ::=
+      --      SEQUENCE_OF_STATEMENTS
+      --    [exception
+      --      EXCEPTION_HANDLER
+      --      {EXCEPTION_HANDLER}]
+      --    [at end
+      --      cleanup_procedure_call (param, param, param, ...);]
+
+      --  The AT END phrase is a GNAT extension to provide for cleanups. It is
+      --  used only internally currently, but is considered to be syntactic.
+      --  At the moment, the only cleanup action allowed is a single call to
+      --  a parameterless procedure, and the Identifier field of the node is
+      --  the procedure to be called. Also there is a current restriction
+      --  that exception handles and a cleanup cannot be present in the same
+      --  frame, so at least one of Exception_Handlers or the Identifier must
+      --  be missing.
+
+      --  Actually, more accurately, this restriction applies to the original
+      --  source program. In the expanded tree, if the At_End_Proc field is
+      --  present, then there will also be an exception handler of the form:
+
+      --     when all others =>
+      --        cleanup;
+      --        raise;
+
+      --  where cleanup is the procedure to be generated. The reason we do
+      --  this is so that the front end can handle the necessary entries in
+      --  the exception tables, and other exception handler actions required
+      --  as part of the normal handling for exception handlers.
+
+      --  The AT END cleanup handler protects only the sequence of statements
+      --  (not the associated declarations of the parent), just like exception
+      --  handlers. The big difference is that the cleanup procedure is called
+      --  on either a normal or an abnormal exit from the statement sequence.
+
+      --  Note: the list of Exception_Handlers can contain pragmas as well
+      --  as actual handlers. In practice these pragmas can only occur at
+      --  the start of the list, since any pragmas occurring later on will
+      --  be included in the statement list of the corresponding handler.
+
+      --  Note: although in the Ada syntax, the sequence of statements in
+      --  a handled sequence of statements can only contain statements, we
+      --  allow free mixing of declarations and statements in the resulting
+      --  expanded tree. This is for example used to deal with the case of
+      --  a cleanup procedure that must handle declarations as well as the
+      --  statements of a block.
+
+      --  N_Handled_Sequence_Of_Statements
+      --  Sloc points to first token of first statement
+      --  Statements (List3)
+      --  End_Label (Node4) (set to Empty if expander generated)
+      --  Exception_Handlers (List5) (set to No_List if none present)
+      --  At_End_Proc (Node1) (set to Empty if no clean up procedure)
+      --  First_Real_Statement (Node2-Sem)
+      --  Zero_Cost_Handling (Flag5-Sem)
+
+      --  Note: the parent always contains a Declarations field which contains
+      --  declarations associated with the handled sequence of statements. This
+      --  is true even in the case of an accept statement (see description of
+      --  the N_Accept_Statement node).
+
+      --  End_Label refers to the containing construct.
+
+      -----------------------------
+      -- 11.2  Exception Handler --
+      -----------------------------
+
+      --  EXCEPTION_HANDLER ::=
+      --    when [CHOICE_PARAMETER_SPECIFICATION :]
+      --      EXCEPTION_CHOICE {| EXCEPTION_CHOICE} =>
+      --        SEQUENCE_OF_STATEMENTS
+
+      --  Note: choice parameter specification is not allowed in Ada 83 mode
+
+      --  N_Exception_Handler
+      --  Sloc points to WHEN
+      --  Choice_Parameter (Node2) (set to Empty if not present)
+      --  Exception_Choices (List4)
+      --  Statements (List3)
+      --  Zero_Cost_Handling (Flag5-Sem)
+
+      ------------------------------------------
+      -- 11.2  Choice parameter specification --
+      ------------------------------------------
+
+      --  CHOICE_PARAMETER_SPECIFICATION ::= DEFINING_IDENTIFIER
+
+      ----------------------------
+      -- 11.2  Exception Choice --
+      ----------------------------
+
+      --  EXCEPTION_CHOICE ::= exception_NAME | others
+
+      --  Except in the case of OTHERS, no explicit node appears in the tree
+      --  for exception choice. Instead the exception name appears directly.
+      --  An OTHERS choice is represented by a N_Others_Choice node (see
+      --  section 3.8.1.
+
+      --  Note: for the exception choice created for an at end handler, the
+      --  exception choice is an N_Others_Choice node with All_Others set.
+
+      ---------------------------
+      -- 11.3  Raise Statement --
+      ---------------------------
+
+      --  RAISE_STATEMENT ::= raise [exception_NAME];
+
+      --  N_Raise_Statement
+      --  Sloc points to RAISE
+      --  Name (Node2) (set to Empty if no exception name present)
+
+      -------------------------------
+      -- 12.1  Generic Declaration --
+      -------------------------------
+
+      --  GENERIC_DECLARATION ::=
+      --    GENERIC_SUBPROGRAM_DECLARATION | GENERIC_PACKAGE_DECLARATION
+
+      ------------------------------------------
+      -- 12.1  Generic Subprogram Declaration --
+      ------------------------------------------
+
+      --  GENERIC_SUBPROGRAM_DECLARATION ::=
+      --    GENERIC_FORMAL_PART SUBPROGRAM_SPECIFICATION;
+
+      --  Note: Generic_Formal_Declarations can include pragmas
+
+      --  N_Generic_Subprogram_Declaration
+      --  Sloc points to GENERIC
+      --  Specification (Node1) subprogram specification
+      --  Corresponding_Body (Node5-Sem)
+      --  Generic_Formal_Declarations (List2) from generic formal part
+      --  Parent_Spec (Node4-Sem)
+
+      ---------------------------------------
+      -- 12.1  Generic Package Declaration --
+      ---------------------------------------
+
+      --  GENERIC_PACKAGE_DECLARATION ::=
+      --    GENERIC_FORMAL_PART PACKAGE_SPECIFICATION;
+
+      --  Note: when we do generics right, the Activation_Chain_Entity entry
+      --  for this node can be removed (since the expander won't see generic
+      --  units any more)???.
+
+      --  Note: Generic_Formal_Declarations can include pragmas
+
+      --  N_Generic_Package_Declaration
+      --  Sloc points to GENERIC
+      --  Specification (Node1) package specification
+      --  Corresponding_Body (Node5-Sem)
+      --  Generic_Formal_Declarations (List2) from generic formal part
+      --  Parent_Spec (Node4-Sem)
+      --  Activation_Chain_Entity (Node3-Sem)
+
+      -------------------------------
+      -- 12.1  Generic Formal Part --
+      -------------------------------
+
+      --  GENERIC_FORMAL_PART ::=
+      --    generic {GENERIC_FORMAL_PARAMETER_DECLARATION | USE_CLAUSE}
+
+      ------------------------------------------------
+      -- 12.1  Generic Formal Parameter Declaration --
+      ------------------------------------------------
+
+      --  GENERIC_FORMAL_PARAMETER_DECLARATION ::=
+      --    FORMAL_OBJECT_DECLARATION
+      --  | FORMAL_TYPE_DECLARATION
+      --  | FORMAL_SUBPROGRAM_DECLARATION
+      --  | FORMAL_PACKAGE_DECLARATION
+
+      ---------------------------------
+      -- 12.3  Generic Instantiation --
+      ---------------------------------
+
+      --  GENERIC_INSTANTIATION ::=
+      --    package DEFINING_PROGRAM_UNIT_NAME is
+      --      new generic_package_NAME [GENERIC_ACTUAL_PART];
+      --  | procedure DEFINING_PROGRAM_UNIT_NAME is
+      --      new generic_procedure_NAME [GENERIC_ACTUAL_PART];
+      --  | function DEFINING_DESIGNATOR is
+      --      new generic_function_NAME [GENERIC_ACTUAL_PART];
+
+      --  N_Package_Instantiation
+      --  Sloc points to PACKAGE
+      --  Defining_Unit_Name (Node1)
+      --  Name (Node2)
+      --  Generic_Associations (List3) (set to No_List if no
+      --   generic actual part)
+      --  Parent_Spec (Node4-Sem)
+      --  Instance_Spec (Node5-Sem)
+      --  ABE_Is_Certain (Flag18-Sem)
+
+      --  N_Procedure_Instantiation
+      --  Sloc points to PROCEDURE
+      --  Defining_Unit_Name (Node1)
+      --  Name (Node2)
+      --  Parent_Spec (Node4-Sem)
+      --  Generic_Associations (List3) (set to No_List if no
+      --   generic actual part)
+      --  Instance_Spec (Node5-Sem)
+      --  ABE_Is_Certain (Flag18-Sem)
+
+      --  N_Function_Instantiation
+      --  Sloc points to FUNCTION
+      --  Defining_Unit_Name (Node1)
+      --  Name (Node2)
+      --  Generic_Associations (List3) (set to No_List if no
+      --   generic actual part)
+      --  Parent_Spec (Node4-Sem)
+      --  Instance_Spec (Node5-Sem)
+      --  ABE_Is_Certain (Flag18-Sem)
+
+      ------------------------------
+      -- 12.3 Generic Actual Part --
+      ------------------------------
+
+      --  GENERIC_ACTUAL_PART ::=
+      --    (GENERIC_ASSOCIATION {, GENERIC_ASSOCIATION})
+
+      -------------------------------
+      -- 12.3  Generic Association --
+      -------------------------------
+
+      --  GENERIC_ASSOCIATION ::=
+      --    [generic_formal_parameter_SELECTOR_NAME =>]
+      --      EXPLICIT_GENERIC_ACTUAL_PARAMETER
+
+      --  Note: unlike the procedure call case, a generic association node
+      --  is generated for every association, even if no formal is present.
+      --  In this case the parser will leave the Selector_Name field set
+      --  to Empty, to be filled in later by the semantic pass.
+
+      --  N_Generic_Association
+      --  Sloc points to first token of generic association
+      --  Selector_Name (Node2) (set to Empty if no formal
+      --   parameter selector name)
+      --  Explicit_Generic_Actual_Parameter (Node1)
+
+      ---------------------------------------------
+      -- 12.3  Explicit Generic Actual Parameter --
+      ---------------------------------------------
+
+      --  EXPLICIT_GENERIC_ACTUAL_PARAMETER ::=
+      --    EXPRESSION      | variable_NAME   | subprogram_NAME
+      --  | entry_NAME      | SUBTYPE_MARK    | package_instance_NAME
+
+      -------------------------------------
+      -- 12.4  Formal Object Declaration --
+      -------------------------------------
+
+      --  FORMAL_OBJECT_DECLARATION ::=
+      --    DEFINING_IDENTIFIER_LIST :
+      --      MODE SUBTYPE_MARK [:= DEFAULT_EXPRESSION];
+
+      --  Although the syntax allows multiple identifiers in the list, the
+      --  semantics is as though successive declarations were given with
+      --  identical type definition and expression components. To simplify
+      --  semantic processing, the parser represents a multiple declaration
+      --  case as a sequence of single declarations, using the More_Ids and
+      --  Prev_Ids flags to preserve the original source form as described
+      --  in the section on "Handling of Defining Identifier Lists".
+
+      --  N_Formal_Object_Declaration
+      --  Sloc points to first identifier
+      --  Defining_Identifier (Node1)
+      --  In_Present (Flag15)
+      --  Out_Present (Flag17)
+      --  Subtype_Mark (Node4)
+      --  Expression (Node3) (set to Empty if no default expression)
+      --  More_Ids (Flag5) (set to False if no more identifiers in list)
+      --  Prev_Ids (Flag6) (set to False if no previous identifiers in list)
+
+      -----------------------------------
+      -- 12.5  Formal Type Declaration --
+      -----------------------------------
+
+      --  FORMAL_TYPE_DECLARATION ::=
+      --    type DEFINING_IDENTIFIER [DISCRIMINANT_PART]
+      --      is FORMAL_TYPE_DEFINITION;
+
+      --  N_Formal_Type_Declaration
+      --  Sloc points to TYPE
+      --  Defining_Identifier (Node1)
+      --  Formal_Type_Definition (Node3)
+      --  Discriminant_Specifications (List4) (set to No_List if no
+      --   discriminant part)
+      --  Unknown_Discriminants_Present (Flag13) set if (<>) discriminant
+
+      ----------------------------------
+      -- 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
+
+      ---------------------------------------------
+      -- 12.5.1  Formal Private Type Definition --
+      ---------------------------------------------
+
+      --  FORMAL_PRIVATE_TYPE_DEFINITION ::=
+      --    [[abstract] tagged] [limited] private
+
+      --  Note: TAGGED is not allowed in Ada 83 mode
+
+      --  N_Formal_Private_Type_Definition
+      --  Sloc points to PRIVATE
+      --  Abstract_Present (Flag4)
+      --  Tagged_Present (Flag15)
+      --  Limited_Present (Flag17)
+
+      --------------------------------------------
+      -- 12.5.1  Formal Derived Type Definition --
+      --------------------------------------------
+
+      --  FORMAL_DERIVED_TYPE_DEFINITION ::=
+      --    [abstract] new SUBTYPE_MARK [with private]
+
+      --  Note: this construct is not allowed in Ada 83 mode
+
+      --  N_Formal_Derived_Type_Definition
+      --  Sloc points to NEW
+      --  Subtype_Mark (Node4)
+      --  Private_Present (Flag15)
+      --  Abstract_Present (Flag4)
+
+      ---------------------------------------------
+      -- 12.5.2  Formal Discrete Type Definition --
+      ---------------------------------------------
+
+      --  FORMAL_DISCRETE_TYPE_DEFINITION ::= (<>)
+
+      --  N_Formal_Discrete_Type_Definition
+      --  Sloc points to (
+
+      ---------------------------------------------------
+      -- 12.5.2  Formal Signed Integer Type Definition --
+      ---------------------------------------------------
+
+      --  FORMAL_SIGNED_INTEGER_TYPE_DEFINITION ::= range <>
+
+      --  N_Formal_Signed_Integer_Type_Definition
+      --  Sloc points to RANGE
+
+      --------------------------------------------
+      -- 12.5.2  Formal Modular Type Definition --
+      --------------------------------------------
+
+      --  FORMAL_MODULAR_TYPE_DEFINITION ::= mod <>
+
+      --  N_Formal_Modular_Type_Definition
+      --  Sloc points to MOD
+
+      ----------------------------------------------
+      -- 12.5.2  Formal Floating Point Definition --
+      ----------------------------------------------
+
+      --  FORMAL_FLOATING_POINT_DEFINITION ::= digits <>
+
+      --  N_Formal_Floating_Point_Definition
+      --  Sloc points to DIGITS
+
+      ----------------------------------------------------
+      -- 12.5.2  Formal Ordinary Fixed Point Definition --
+      ----------------------------------------------------
+
+      --  FORMAL_ORDINARY_FIXED_POINT_DEFINITION ::= delta <>
+
+      --  N_Formal_Ordinary_Fixed_Point_Definition
+      --  Sloc points to DELTA
+
+      ---------------------------------------------------
+      -- 12.5.2  Formal Decimal Fixed Point Definition --
+      ---------------------------------------------------
+
+      --  FORMAL_DECIMAL_FIXED_POINT_DEFINITION ::= delta <> digits <>
+
+      --  Note: formal decimal fixed point definition not allowed in Ada 83
+
+      --  N_Formal_Decimal_Fixed_Point_Definition
+      --  Sloc points to DELTA
+
+      ------------------------------------------
+      -- 12.5.3  Formal Array Type Definition --
+      ------------------------------------------
+
+      --  FORMAL_ARRAY_TYPE_DEFINITION ::= ARRAY_TYPE_DEFINITION
+
+      -------------------------------------------
+      -- 12.5.4  Formal Access Type Definition --
+      -------------------------------------------
+
+      --  FORMAL_ACCESS_TYPE_DEFINITION ::= ACCESS_TYPE_DEFINITION
+
+      -----------------------------------------
+      -- 12.6  Formal Subprogram Declaration --
+      -----------------------------------------
+
+      --  FORMAL_SUBPROGRAM_DECLARATION ::=
+      --    with SUBPROGRAM_SPECIFICATION [is SUBPROGRAM_DEFAULT];
+
+      --  N_Formal_Subprogram_Declaration
+      --  Sloc points to WITH
+      --  Specification (Node1)
+      --  Default_Name (Node2) (set to Empty if no subprogram default)
+      --  Box_Present (Flag15)
+
+      --  Note: if no subprogram default is present, then Name is set
+      --  to Empty, and Box_Present is False.
+
+      ------------------------------
+      -- 12.6  Subprogram Default --
+      ------------------------------
+
+      --  SUBPROGRAM_DEFAULT ::= DEFAULT_NAME | <>
+
+      --  There is no separate node in the tree for a subprogram default.
+      --  Instead the parent (N_Formal_Subprogram_Declaration) node contains
+      --  the default name or box indication, as needed.
+
+      ------------------------
+      -- 12.6  Default Name --
+      ------------------------
+
+      --  DEFAULT_NAME ::= NAME
+
+      --------------------------------------
+      -- 12.7  Formal Package Declaration --
+      --------------------------------------
+
+      --  FORMAL_PACKAGE_DECLARATION ::=
+      --    with package DEFINING_IDENTIFIER
+      --      is new generic_package_NAME FORMAL_PACKAGE_ACTUAL_PART;
+
+      --  Note: formal package declarations not allowed in Ada 83 mode
+
+      --  N_Formal_Package_Declaration
+      --  Sloc points to WITH
+      --  Defining_Identifier (Node1)
+      --  Name (Node2)
+      --  Generic_Associations (List3) (set to No_List if (<>) case or
+      --   empty generic actual part)
+      --  Box_Present (Flag15)
+      --  Instance_Spec (Node5-Sem)
+      --  ABE_Is_Certain (Flag18-Sem)
+
+      --------------------------------------
+      -- 12.7  Formal Package Actual Part --
+      --------------------------------------
+
+      --  FORMAL_PACKAGE_ACTUAL_PART ::=
+      --    (<>) | [GENERIC_ACTUAL_PART]
+
+      --  There is no explicit node in the tree for a formal package
+      --  actual part. Instead the information appears in the parent node
+      --  (i.e. the formal package declaration node itself).
+
+      ---------------------------------
+      -- 13.1  Representation clause --
+      ---------------------------------
+
+      --  REPRESENTATION_CLAUSE ::=
+      --    ATTRIBUTE_DEFINITION_CLAUSE
+      --  | ENUMERATION_REPRESENTATION_CLAUSE
+      --  | RECORD_REPRESENTATION_CLAUSE
+      --  | AT_CLAUSE
+
+      ----------------------
+      -- 13.1  Local Name --
+      ----------------------
+
+      --  LOCAL_NAME :=
+      --    DIRECT_NAME
+      --  | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
+      --  | library_unit_NAME
+
+      --  The construct DIRECT_NAME'ATTRIBUTE_DESIGNATOR appears in the tree
+      --  as an attribute reference, which has essentially the same form.
+
+      ---------------------------------------
+      -- 13.3  Attribute definition clause --
+      ---------------------------------------
+
+      --  ATTRIBUTE_DEFINITION_CLAUSE ::=
+      --    for LOCAL_NAME'ATTRIBUTE_DESIGNATOR use EXPRESSION;
+      --  | for LOCAL_NAME'ATTRIBUTE_DESIGNATOR use NAME;
+
+      --  In Ada 83, the expression must be a simple expression and the
+      --  local name must be a direct name.
+
+      --  Note: The only attribute definition clause that is processed
+      --  by Gigi is the alignment clause (for all other cases, the
+      --  information is extracted by the front end and either results
+      --  in setting entity information, e.g. Esize for the Size case,
+      --  or in appropriate expansion actions (e.g. in the storage size
+      --  case). For the alignment case, Gigi requires that the expression
+      --  be an integer literal.
+
+      --  N_Attribute_Definition_Clause
+      --  Sloc points to FOR
+      --  Name (Node2) the local name
+      --  Chars (Name1) the identifier name from the attribute designator
+      --  Expression (Node3) the expression or name
+      --  Next_Rep_Item (Node4-Sem)
+      --  From_At_Mod (Flag4-Sem)
+
+      ---------------------------------------------
+      -- 13.4  Enumeration representation clause --
+      ---------------------------------------------
+
+      --  ENUMERATION_REPRESENTATION_CLAUSE ::=
+      --    for first_subtype_LOCAL_NAME use ENUMERATION_AGGREGATE;
+
+      --  In Ada 83, the name must be a direct name
+
+      --  N_Enumeration_Representation_Clause
+      --  Sloc points to FOR
+      --  Identifier (Node1) direct name
+      --  Array_Aggregate (Node3)
+      --  Next_Rep_Item (Node4-Sem)
+
+      ---------------------------------
+      -- 13.4  Enumeration aggregate --
+      ---------------------------------
+
+      --  ENUMERATION_AGGREGATE ::= ARRAY_AGGREGATE
+
+      ------------------------------------------
+      -- 13.5.1  Record representation clause --
+      ------------------------------------------
+
+      --  RECORD_REPRESENTATION_CLAUSE ::=
+      --    for first_subtype_LOCAL_NAME use
+      --      record [MOD_CLAUSE]
+      --        {COMPONENT_CLAUSE}
+      --      end record;
+
+      --  Gigi restriction: Mod_Clause is always Empty (if present it is
+      --  replaced by a corresponding Alignment attribute definition clause).
+
+      --  Note: Component_Clauses can include pragmas
+
+      --  N_Record_Representation_Clause
+      --  Sloc points to FOR
+      --  Identifier (Node1) direct name
+      --  Mod_Clause (Node2) (set to Empty if no mod clause present)
+      --  Component_Clauses (List3)
+      --  Next_Rep_Item (Node4-Sem)
+
+      ------------------------------
+      -- 13.5.1  Component clause --
+      ------------------------------
+
+      --  COMPONENT_CLAUSE ::=
+      --    component_LOCAL_NAME at POSITION
+      --      range FIRST_BIT .. LAST_BIT;
+
+      --  N_Component_Clause
+      --  Sloc points to AT
+      --  Component_Name (Node1) points to Name or Attribute_Reference
+      --  Position (Node2)
+      --  First_Bit (Node3)
+      --  Last_Bit (Node4)
+
+      ----------------------
+      -- 13.5.1  Position --
+      ----------------------
+
+      --  POSITION ::= static_EXPRESSION
+
+      -----------------------
+      -- 13.5.1  First_Bit --
+      -----------------------
+
+      --  FIRST_BIT ::= static_SIMPLE_EXPRESSION
+
+      ----------------------
+      -- 13.5.1  Last_Bit --
+      ----------------------
+
+      --  LAST_BIT ::= static_SIMPLE_EXPRESSION
+
+      --------------------------
+      -- 13.8  Code statement --
+      --------------------------
+
+      --  CODE_STATEMENT ::= QUALIFIED_EXPRESSION;
+
+      --  Note: in GNAT, the qualified expression has the form
+
+      --    Asm_Insn'(Asm (...));
+
+      --      or
+
+      --    Asm_Insn'(Asm_Volatile (...))
+
+      --  See package System.Machine_Code in file s-maccod.ads for details
+      --  on the allowed parameters to Asm[_Volatile]. There are two ways
+      --  this node can arise, as a code statement, in which case the
+      --  expression is the qualified expression, or as a result of the
+      --  expansion of an intrinsic call to the Asm or Asm_Input procedure.
+
+      --  N_Code_Statement
+      --  Sloc points to first token of the expression
+      --  Expression (Node3)
+
+      --  Note: package Exp_Code contains an abstract functional interface
+      --  for use by Gigi in accessing the data from N_Code_Statement nodes.
+
+      ------------------------
+      -- 13.12  Restriction --
+      ------------------------
+
+      --  RESTRICTION ::=
+      --    restriction_IDENTIFIER
+      --  | restriction_parameter_IDENTIFIER => EXPRESSION
+
+      --  There is no explicit node for restrictions. Instead the restriction
+      --  appears in normal pragma syntax as a pragma argument association,
+      --  which has the same syntactic form.
+
+      --------------------------
+      -- B.2  Shift Operators --
+      --------------------------
+
+      --  Calls to the intrinsic shift functions are converted to one of
+      --  the following shift nodes, which have the form of normal binary
+      --  operator names. Note that for a given shift operation, one node
+      --  covers all possible types, as for normal operators.
+
+      --  Note: it is perfectly permissible for the expander to generate
+      --  shift operation nodes directly, in which case they will be analyzed
+      --  and parsed in the usual manner.
+
+      --  Sprint syntax: shift-function-name!(expr, count)
+
+      --  Note: the Left_Opnd field holds the first argument (the value to
+      --  be shifted). The Right_Opnd field holds the second argument (the
+      --  shift count). The Chars field is the name of the intrinsic function.
+
+      --  N_Op_Rotate_Left
+      --  Sloc points to the function name
+      --  plus fields for binary operator
+      --  plus fields for expression
+      --  Shift_Count_OK (Flag4-Sem)
+
+      --  N_Op_Rotate_Right
+      --  Sloc points to the function name
+      --  plus fields for binary operator
+      --  plus fields for expression
+      --  Shift_Count_OK (Flag4-Sem)
+
+      --  N_Op_Shift_Left
+      --  Sloc points to the function name
+      --  plus fields for binary operator
+      --  plus fields for expression
+      --  Shift_Count_OK (Flag4-Sem)
+
+      --  N_Op_Shift_Right_Arithmetic
+      --  Sloc points to the function name
+      --  plus fields for binary operator
+      --  plus fields for expression
+      --  Shift_Count_OK (Flag4-Sem)
+
+      --  N_Op_Shift_Right
+      --  Sloc points to the function name
+      --  plus fields for binary operator
+      --  plus fields for expression
+      --  Shift_Count_OK (Flag4-Sem)
+
+   --------------------------
+   -- Obsolescent Features --
+   --------------------------
+
+      --  The syntax descriptions and tree nodes for obsolescent features are
+      --  grouped together, corresponding to their location in appendix I in
+      --  the RM. However, parsing and semantic analysis for these constructs
+      --  is located in an appropriate chapter (see individual notes).
+
+      ---------------------------
+      -- J.3  Delta Constraint --
+      ---------------------------
+
+      --  Note: the parse routine for this construct is located in section
+      --  3.5.9 of Par-Ch3, and semantic analysis is in Sem_Ch3, which is
+      --  where delta constraint logically belongs.
+
+      --  DELTA_CONSTRAINT ::= DELTA static_EXPRESSION [RANGE_CONSTRAINT]
+
+      --  N_Delta_Constraint
+      --  Sloc points to DELTA
+      --  Delta_Expression (Node3)
+      --  Range_Constraint (Node4) (set to Empty if not present)
+
+      --------------------
+      -- J.7  At Clause --
+      --------------------
+
+      --  AT_CLAUSE ::= for DIRECT_NAME use at EXPRESSION;
+
+      --  Note: the parse routine for this construct is located in Par-Ch13,
+      --  and the semantic analysis is in Sem_Ch13, where at clause logically
+      --  belongs if it were not obsolescent.
+
+      --  Note: in Ada 83 the expression must be a simple expression
+
+      --  Gigi restriction: This node never appears, it is rewritten as an
+      --  address attribute definition clause.
+
+      --  N_At_Clause
+      --  Sloc points to FOR
+      --  Identifier (Node1)
+      --  Expression (Node3)
+
+      ---------------------
+      -- J.8  Mod clause --
+      ---------------------
+
+      --  MOD_CLAUSE ::= at mod static_EXPRESSION;
+
+      --  Note: the parse routine for this construct is located in Par-Ch13,
+      --  and the semantic analysis is in Sem_Ch13, where mod clause logically
+      --  belongs if it were not obsolescent.
+
+      --  Note: in Ada 83, the expression must be a simple expression
+
+      --  Gigi restriction: this node never appears. It is replaced
+      --  by a corresponding Alignment attribute definition clause.
+
+      --  Note: pragmas can appear before and after the MOD_CLAUSE since
+      --  its name has "clause" in it. This is rather strange, but is quite
+      --  definitely specified. The pragmas before are collected in the
+      --  Pragmas_Before field of the mod clause node itself, and pragmas
+      --  after are simply swallowed up in the list of component clauses.
+
+      --  N_Mod_Clause
+      --  Sloc points to AT
+      --  Expression (Node3)
+      --  Pragmas_Before (List4) Pragmas before mod clause (No_List if none)
+
+   --------------------
+   -- Semantic Nodes --
+   --------------------
+
+   --  These semantic nodes are used to hold additional semantic information.
+   --  They are inserted into the tree as a result of semantic processing.
+   --  Although there are no legitimate source syntax constructions that
+   --  correspond directly to these nodes, we need a source syntax for the
+   --  reconstructed tree printed by Sprint, and the node descriptions here
+   --  show this syntax.
+
+      ----------------------------
+      -- Conditional Expression --
+      ----------------------------
+
+      --  This node is used to represent an expression corresponding to the
+      --  C construct (condition ? then-expression : else_expression), where
+      --  Expressions is a three element list, whose first expression is the
+      --  condition, and whose second and third expressions are the then and
+      --  else expressions respectively.
+
+      --  Note: the Then_Actions and Else_Actions fields are always set to
+      --  No_List in the tree passed to Gigi. These fields are used only
+      --  for temporary processing purposes in the expander.
+
+      --  Sprint syntax: (if expr then expr else expr)
+
+      --  N_Conditional_Expression
+      --  Sloc points to related node
+      --  Expressions (List1)
+      --  Then_Actions (List2-Sem)
+      --  Else_Actions (List3-Sem)
+      --  plus fields for expression
+
+      --  Note: in the case where a debug source file is generated, the Sloc
+      --  for this node points to the IF keyword in the Sprint file output.
+
+      -------------------
+      -- Expanded_Name --
+      -------------------
+
+      --  The N_Expanded_Name node is used to represent a selected component
+      --  name that has been resolved to an expanded name. The semantic phase
+      --  replaces N_Selected_Component nodes that represent names by the use
+      --  of this node, leaving the N_Selected_Component node used only when
+      --  the prefix is a record or protected type.
+
+      --  The fields of the N_Expanded_Name node are layed out identically
+      --  to those of the N_Selected_Component node, allowing conversion of
+      --  an expanded name node to a selected component node to be done
+      --  easily, see Sinfo.CN.Change_Selected_Component_To_Expanded_Name.
+
+      --  There is no special sprint syntax for an expanded name.
+
+      --  N_Expanded_Name
+      --  Sloc points to the period
+      --  Chars (Name1) copy of Chars field of selector name
+      --  Prefix (Node3)
+      --  Selector_Name (Node2)
+      --  Entity (Node4-Sem)
+      --  Redundant_Use (Flag13-Sem)
+      --  Has_Private_View (Flag11-Sem) set in generic units.
+      --  plus fields for expression
+
+      --------------------
+      -- Free Statement --
+      --------------------
+
+      --  The N_Free_Statement node is generated as a result of a call to an
+      --  instantiation of Unchecked_Deallocation. The instantiation of this
+      --  generic is handled specially and generates this node directly.
+
+      --  Sprint syntax: free expression
+
+      --  N_Free_Statement
+      --  Sloc is copied from the unchecked deallocation call
+      --  Expression (Node3) argument to unchecked deallocation call
+      --  Storage_Pool (Node1-Sem)
+      --  Procedure_To_Call (Node4-Sem)
+
+      --  Note: in the case where a debug source file is generated, the Sloc
+      --  for this node points to the FREE keyword in the Sprint file output.
+
+      -------------------
+      -- Freeze Entity --
+      -------------------
+
+      --  This node marks the point in a declarative part at which an entity
+      --  declared therein becomes frozen. The expander places initialization
+      --  procedures for types at those points. Gigi uses the freezing point
+      --  to elaborate entities that may depend on previous private types.
+
+      --  See the section in Einfo "Delayed Freezing and Elaboration" for
+      --  a full description of the use of this node.
+
+      --  The Entity field points back to the entity for the type (whose
+      --  Freeze_Node field points back to this freeze node).
+
+      --  The Actions field contains a list of declarations and statements
+      --  generated by the expander which are associated with the freeze
+      --  node, and are elaborated as though the freeze node were replaced
+      --  by this sequence of actions.
+
+      --  Note: the Sloc field in the freeze node references a construct
+      --  associated with the freezing point. This is used for posting
+      --  messages in some error/warning situations, e.g. the case where
+      --  a primitive operation of a tagged type is declared too late.
+
+      --  Sprint syntax: freeze entity-name [
+      --                   freeze actions
+      --                 ]
+
+      --  N_Freeze_Entity
+      --  Sloc points near freeze point (see above special note)
+      --  Entity (Node4-Sem)
+      --  Access_Types_To_Process (Elist2-Sem) (set to No_Elist if none)
+      --  TSS_Elist (Elist3-Sem) (set to No_Elist if no associated TSS's)
+      --  Actions (List1) (set to No_List if no freeze actions)
+      --  First_Subtype_Link (Node5-Sem) (set to Empty if no link)
+
+      --  The Actions field holds actions associated with the freeze. These
+      --  actions are elaborated at the point where the type is frozen.
+
+      --  Note: in the case where a debug source file is generated, the Sloc
+      --  for this node points to the FREEZE keyword in the Sprint file output.
+
+      --------------------------------
+      -- Implicit Label Declaration --
+      --------------------------------
+
+      --  An implicit label declaration is created for every occurrence of a
+      --  label on a statement or a label on a block or loop. It is chained
+      --  in the declarations of the innermost enclosing block as specified
+      --  in RM section 5.1 (3).
+
+      --  The Defining_Identifier is the actual identifier for the
+      --  statement identifier. Note that the occurrence of the label
+      --  is a reference, NOT the defining occurrence. The defining
+      --  occurrence occurs at the head of the innermost enclosing
+      --  block, and is represented by this node.
+
+      --  Note: from the grammar, this might better be called an implicit
+      --  statement identifier declaration, but the term we choose seems
+      --  friendlier, since at least informally statement identifiers are
+      --  called labels in both cases (i.e. when used in labels, and when
+      --  used as the identifiers of blocks and loops).
+
+      --  Note: although this is logically a semantic node, since it does
+      --  not correspond directly to a source syntax construction, these
+      --  nodes are actually created by the parser in a post pass done just
+      --  after parsing is complete, before semantic analysis is started (see
+      --  the Par.Labl subunit in file par-labl.adb).
+
+      --  Sprint syntax: labelname : label;
+
+      --  N_Implicit_Label_Declaration
+      --  Sloc points to the << of the label
+      --  Defining_Identifier (Node1)
+      --  Label_Construct (Node2-Sem)
+
+      --  Note: in the case where a debug source file is generated, the Sloc
+      --  for this node points to the label name in the generated declaration.
+
+      ---------------------
+      -- Itype_Reference --
+      ---------------------
+
+      --  This node is used to create a reference to an Itype. The only
+      --  purpose is to make sure that the Itype is defined if this is the
+      --  first reference.
+
+      --  A typical use of this node is when an Itype is to be referenced in
+      --  two branches of an if statement. In this case it is important that
+      --  the first use of the Itype not be inside the conditional, since
+      --  then it might not be defined if the wrong branch of the if is
+      --  taken in the case where the definition generates elaboration code.
+
+      --  The Itype field points to the referenced Itype
+
+      --  sprint syntax: reference itype-name
+
+      --  N_Itype_Reference
+      --  Sloc points to the node generating the reference
+      --  Itype (Node1-Sem)
+
+      --  Note: in the case where a debug source file is generated, the Sloc
+      --  for this node points to the REFERENCE keyword in the file output.
+
+      ---------------------
+      -- Raise_xxx_Error --
+      ---------------------
+
+      --  One of these nodes is created during semantic analysis to replace
+      --  a node for an expression that is determined to definitely raise
+      --  the corresponding exception.
+
+      --  The N_Raise_xxx_Error node may also stand alone in place
+      --  of a declaration or statement, in which case it simply causes
+      --  the exception to be raised (i.e. it is equivalent to a raise
+      --  statement that raises the corresponding exception). This use
+      --  is distinguished by the fact that the Etype in this case is
+      --  Standard_Void_Type, In the subexprssion case, the Etype is the
+      --  same as the type of the subexpression which it replaces.
+
+      --  If Condition is empty, then the raise is unconditional. If the
+      --  Condition field is non-empty, it is a boolean expression which
+      --  is first evaluated, and the exception is raised only if the
+      --  value of the expression is True. In the unconditional case, the
+      --  creation of this node is usually accompanied by a warning message
+      --  error. The creation of this node will usually be accompanied by a
+      --  message (unless it appears within the right operand of a short
+      --  circuit form whose left argument is static and decisively
+      --  eliminates elaboration of the raise operation.
+
+      --  Gigi restriction: This expander ensures that the type of the
+      --  Condition field is always Standard.Boolean, even if the type
+      --  in the source is some non-standard boolean type.
+
+      --  Sprint syntax: [xxx_error]
+      --             or: [xxx_error when condition]
+
+      --  N_Raise_Constraint_Error
+      --  Sloc references related construct
+      --  Condition (Node1) (set to Empty if no condition)
+      --  Sloc is copied from the expression generating the exception
+      --  plus fields for expression
+
+      --  N_Raise_Program_Error
+      --  Sloc references related construct
+      --  Condition (Node1) (set to Empty if no condition)
+      --  Sloc is copied from the construct generating the exception
+      --  plus fields for expression
+
+      --  N_Raise_Storage_Error
+      --  Sloc references related construct
+      --  Condition (Node1) (set to Empty if no condition)
+      --  Sloc is copied from the construct generating the exception
+      --  plus fields for expression
+
+      --  Note: in the case where a debug source file is generated, the Sloc
+      --  for this node points to the left bracket in the Sprint file output.
+
+      ---------------
+      -- Reference --
+      ---------------
+
+      --  For a number of purposes, we need to construct references to objects.
+      --  These references are subsequently treated as normal access values.
+      --  An example is the construction of the parameter block passed to a
+      --  task entry. The N_Reference node is provided for this purpose. It is
+      --  similar in effect to the use of the Unrestricted_Access attribute,
+      --  and like Unrestricted_Access can be applied to objects which would
+      --  not be valid prefixes for the Unchecked_Access attribute (e.g.
+      --  objects which are not aliased, and slices). In addition it can be
+      --  applied to composite type values as well as objects, including string
+      --  values and aggregates.
+
+      --  Note: we use the Prefix field for this expression so that the
+      --  resulting node can be treated using common code with the attribute
+      --  nodes for the 'Access and related attributes. Logically it would make
+      --  more sense to call it an Expression field, but then we would have to
+      --  special case the treatment of the N_Reference node.
+
+      --  Sprint syntax: prefix'reference
+
+      --  N_Reference
+      --  Sloc is copied from the expression
+      --  Prefix (Node3)
+      --  plus fields for expression
+
+      --  Note: in the case where a debug source file is generated, the Sloc
+      --  for this node points to the quote in the Sprint file output.
+
+      ---------------------
+      -- Subprogram_Info --
+      ---------------------
+
+      --  This node generates the appropriate Subprogram_Info value for a
+      --  given procedure. See Ada.Exceptions for further details
+
+      --  Sprint syntax: subprog'subprogram_info
+
+      --  N_Subprogram_Info
+      --  Sloc points to the entity for the procedure
+      --  Identifier (Node1) identifier referencing the procedure
+      --  Etype (Node5-Sem) type (always set to Ada.Exceptions.Code_Loc
+
+      --  Note: in the case where a debug source file is generated, the Sloc
+      --  for this node points to the quote in the Sprint file output.
+
+      --------------------------
+      -- Unchecked Expression --
+      --------------------------
+
+      --  An unchecked expression is one that must be analyzed and resolved
+      --  with all checks off, regardless of the current setting of scope
+      --  suppress flags.
+
+      --  Sprint syntax: `(expression).
+
+      --  Note: this node is always removed from the tree (and replaced by
+      --  its constituent expression) on completion of analysis, so it only
+      --  appears in intermediate trees, and will never be seen by Gigi.
+
+      --  N_Unchecked_Expression
+      --  Sloc is a copy of the Sloc of the expression
+      --  Expression (Node3)
+      --  plus fields for expression
+
+      --  Note: in the case where a debug source file is generated, the Sloc
+      --  for this node points to the back quote in the Sprint file output.
+
+      -------------------------------
+      -- Unchecked Type Conversion --
+      -------------------------------
+
+      --  An unchecked type conversion node represents the semantic action
+      --  corresponding to a call to an instantiation of Unchecked_Conversion.
+      --  It is generated as a result of actual use of Unchecked_Conversion
+      --  and also the expander generates unchecked type conversion nodes
+      --  directly for expansion of complex semantic actions.
+
+      --  Note: an unchecked type conversion is a variable as far as the
+      --  semantics are concerned, which is convenient for the expander.
+      --  This does not change what Ada source programs are legal, since
+      --  clearly a function call to an instantiation of Unchecked_Conversion
+      --  is not a variable in any case.
+
+      --  Sprint syntax: subtype-mark!(expression).
+
+      --  N_Unchecked_Type_Conversion
+      --  Sloc points to related node in source
+      --  Subtype_Mark (Node4)
+      --  Expression (Node3)
+      --  Kill_Range_Check (Flag11-Sem)
+      --  plus fields for expression
+
+      --  Note: in the case where a debug source file is generated, the Sloc
+      --  for this node points to the exclamation in the Sprint file output.
+
+      -----------------------------------
+      -- Validate_Unchecked_Conversion --
+      -----------------------------------
+
+      --  The front end does most of the validation of unchecked conversion,
+      --  including checking sizes (this is done after the back end is called
+      --  to take advantage of back-annotation of calculated sizes).
+
+      --  The front end also deals with specific cases that are not allowed
+      --  e.g. involving unconstrained array types.
+
+      --  For the case of the standard gigi backend, this means that all
+      --  checks are done in the front-end.
+
+      --  However, in the case of specialized back-ends, notably the JVM
+      --  backend for JGNAT, additional requirements and restrictions apply
+      --  to unchecked conversion, and these are most conveniently performed
+      --  in the specialized back-end.
+
+      --  To accomodate this requirement, for such back ends, the following
+      --  special node is generated recording an unchecked conversion that
+      --  needs to be validated. The back end should post an appropriate
+      --  error message if the unchecked conversion is invalid or warrants
+      --  a special warning message.
+
+      --  Source_Type and Target_Type point to the entities for the two
+      --  types involved in the unchecked conversion instantiation that
+      --  is to be validated.
+
+      --  Sprint syntax: validate Unchecked_Conversion (source, target);
+
+      --  N_Validate_Unchecked_Conversion
+      --  Sloc points to instantiation (location for warning message)
+      --  Source_Type (Node1-Sem)
+      --  Target_Type (Node2-Sem)
+
+      --  Note: in the case where a debug source file is generated, the Sloc
+      --  for this node points to the VALIDATE keyword in the file output.
+
+   -----------
+   -- Empty --
+   -----------
+
+   --  N_Empty
+   --  Chars (Name1) is set to No_Name
+   --  Used as the contents of the Nkind field of the dummy Empty node
+   --  and in some other situations to indicate an uninitialized value.
+
+   -----------
+   -- Error --
+   -----------
+
+   --  N_Error
+   --  Chars (Name1) is set to Error_Name
+   --  Used as the contents of the Nkind field of the dummy Error node
+
+   --------------------------
+   -- Node Type Definition --
+   --------------------------
+
+   --  The following is the definition of the Node_Kind type. As previously
+   --  discussed, this is separated off to allow rearrangement of the order
+   --  to facilitiate definition of subtype ranges. The comments show the
+   --  subtype classes which apply to each set of node kinds. The first
+   --  entry in the comment characterizes the following list of nodes.
+
+   type Node_Kind is (
+      N_Unused_At_Start,
+
+      --  N_Representation_Clause
+      N_At_Clause,
+      N_Component_Clause,
+      N_Enumeration_Representation_Clause,
+      N_Mod_Clause,
+      N_Record_Representation_Clause,
+
+      --  N_Representation_Clause, N_Has_Chars
+      N_Attribute_Definition_Clause,
+
+      --  N_Has_Chars
+      N_Empty,
+      N_Error,
+      N_Pragma,
+      N_Pragma_Argument_Association,
+
+      --  N_Entity, N_Has_Etype, N_Has_Chars
+      N_Defining_Character_Literal,
+      N_Defining_Identifier,
+      N_Defining_Operator_Symbol,
+
+      --  N_Subexpr, N_Has_Etype, N_Has_Chars, N_Has_Entity
+      N_Expanded_Name,
+
+      --  N_Direct_Name, N_Subexpr, N_Has_Etype,
+      --  N_Has_Chars, N_Has_Entity
+      N_Identifier,
+      N_Operator_Symbol,
+
+      --  N_Direct_Name, N_Subexpr, N_Has_Etype,
+      --  N_Has_Chars, N_Has_Entity
+      N_Character_Literal,
+
+      --  N_Binary_Op, N_Op, N_Subexpr,
+      --  N_Has_Etype, N_Has_Chars, N_Has_Entity
+      N_Op_Add,
+      N_Op_Concat,
+      N_Op_Divide,
+      N_Op_Expon,
+      N_Op_Mod,
+      N_Op_Multiply,
+      N_Op_Rem,
+      N_Op_Subtract,
+
+      --  N_Binary_Op, N_Op, N_Subexpr, N_Has_Etype
+      --  N_Has_Entity, N_Has_Chars, N_Op_Boolean
+      N_Op_And,
+
+      --  N_Binary_Op, N_Op, N_Subexpr, N_Has_Etype
+      --  N_Has_Entity, N_Has_Chars, N_Op_Boolean,
+      --  N_Op_Compare
+      N_Op_Eq,
+      N_Op_Ge,
+      N_Op_Gt,
+      N_Op_Le,
+      N_Op_Lt,
+      N_Op_Ne,
+
+      --  N_Binary_Op, N_Op, N_Subexpr, N_Has_Etype
+      --  N_Has_Entity, N_Has_Chars, N_Op_Boolean
+      N_Op_Or,
+      N_Op_Xor,
+
+      --  N_Binary_Op, N_Op, N_Subexpr, N_Has_Etype,
+      --  N_Op_Shift, N_Has_Chars, N_Has_Entity
+      N_Op_Rotate_Left,
+      N_Op_Rotate_Right,
+      N_Op_Shift_Left,
+      N_Op_Shift_Right,
+      N_Op_Shift_Right_Arithmetic,
+
+      --  N_Unary_Op, N_Op, N_Subexpr, N_Has_Etype,
+      --  N_Has_Chars, N_Has_Entity
+      N_Op_Abs,
+      N_Op_Minus,
+      N_Op_Not,
+      N_Op_Plus,
+
+      --  N_Subexpr, N_Has_Etype, N_Has_Entity
+      N_Attribute_Reference,
+
+      --  N_Subexpr, N_Has_Etype
+      N_And_Then,
+      N_Conditional_Expression,
+      N_Explicit_Dereference,
+      N_Function_Call,
+      N_In,
+      N_Indexed_Component,
+      N_Integer_Literal,
+      N_Not_In,
+      N_Null,
+      N_Or_Else,
+      N_Procedure_Call_Statement,
+      N_Qualified_Expression,
+
+      --  N_Raise_xxx_Error, N_Subexpr, N_Has_Etype
+
+      N_Raise_Constraint_Error,
+      N_Raise_Program_Error,
+      N_Raise_Storage_Error,
+
+      --  N_Subexpr, N_Has_Etype
+
+      N_Aggregate,
+      N_Allocator,
+      N_Extension_Aggregate,
+      N_Range,
+      N_Real_Literal,
+      N_Reference,
+      N_Selected_Component,
+      N_Slice,
+      N_String_Literal,
+      N_Subprogram_Info,
+      N_Type_Conversion,
+      N_Unchecked_Expression,
+      N_Unchecked_Type_Conversion,
+
+      --  N_Has_Etype
+      N_Subtype_Indication,
+
+      --  N_Declaration
+      N_Component_Declaration,
+      N_Entry_Declaration,
+      N_Formal_Object_Declaration,
+      N_Formal_Type_Declaration,
+      N_Full_Type_Declaration,
+      N_Incomplete_Type_Declaration,
+      N_Loop_Parameter_Specification,
+      N_Object_Declaration,
+      N_Protected_Type_Declaration,
+      N_Private_Extension_Declaration,
+      N_Private_Type_Declaration,
+      N_Subtype_Declaration,
+
+      --  N_Subprogram_Specification, N_Declaration
+      N_Function_Specification,
+      N_Procedure_Specification,
+
+      --  (nothing special)
+      N_Entry_Index_Specification,
+      N_Freeze_Entity,
+
+      --  N_Access_To_Subprogram_Definition
+      N_Access_Function_Definition,
+      N_Access_Procedure_Definition,
+
+      --  N_Later_Decl_Item,
+      N_Task_Type_Declaration,
+
+      --  N_Body_Stub, N_Later_Decl_Item
+      N_Package_Body_Stub,
+      N_Protected_Body_Stub,
+      N_Subprogram_Body_Stub,
+      N_Task_Body_Stub,
+
+      --  N_Generic_Instantiation, N_Later_Decl_Item
+      N_Function_Instantiation,
+      N_Package_Instantiation,
+      N_Procedure_Instantiation,
+
+      --  N_Unit_Body, N_Later_Decl_Item, N_Proper_Body
+      N_Package_Body,
+      N_Subprogram_Body,
+
+      --  N_Later_Decl_Item, N_Proper_Body
+      N_Protected_Body,
+      N_Task_Body,
+
+      --  N_Later_Decl_Item
+      N_Implicit_Label_Declaration,
+      N_Package_Declaration,
+      N_Single_Task_Declaration,
+      N_Subprogram_Declaration,
+      N_Use_Package_Clause,
+
+      --  N_Generic_Declaration, N_Later_Decl_Item
+      N_Generic_Package_Declaration,
+      N_Generic_Subprogram_Declaration,
+
+      --  N_Array_Type_Definition
+      N_Constrained_Array_Definition,
+      N_Unconstrained_Array_Definition,
+
+      --  N_Renaming_Declaration
+      N_Exception_Renaming_Declaration,
+      N_Object_Renaming_Declaration,
+      N_Package_Renaming_Declaration,
+      N_Subprogram_Renaming_Declaration,
+
+      --  N_Generic_Renaming_Declarations, N_Renaming_Declaration
+      N_Generic_Function_Renaming_Declaration,
+      N_Generic_Package_Renaming_Declaration,
+      N_Generic_Procedure_Renaming_Declaration,
+
+      --  N_Statement_Other_Than_Procedure_Call
+      N_Abort_Statement,
+      N_Accept_Statement,
+      N_Assignment_Statement,
+      N_Asynchronous_Select,
+      N_Block_Statement,
+      N_Case_Statement,
+      N_Code_Statement,
+      N_Conditional_Entry_Call,
+      N_Delay_Relative_Statement,
+      N_Delay_Until_Statement,
+      N_Entry_Call_Statement,
+      N_Free_Statement,
+      N_Goto_Statement,
+      N_Loop_Statement,
+      N_Null_Statement,
+      N_Raise_Statement,
+      N_Requeue_Statement,
+      N_Return_Statement,
+      N_Selective_Accept,
+      N_Timed_Entry_Call,
+
+      --  N_Statement_Other_Than_Procedure_Call, N_Has_Condition
+      N_Exit_Statement,
+      N_If_Statement,
+
+      --  N_Has_Condition
+      N_Accept_Alternative,
+      N_Delay_Alternative,
+      N_Elsif_Part,
+      N_Entry_Body_Formal_Part,
+      N_Iteration_Scheme,
+      N_Terminate_Alternative,
+
+      --  Other nodes (not part of any subtype class)
+      N_Abortable_Part,
+      N_Abstract_Subprogram_Declaration,
+      N_Access_Definition,
+      N_Access_To_Object_Definition,
+      N_Case_Statement_Alternative,
+      N_Compilation_Unit,
+      N_Compilation_Unit_Aux,
+      N_Component_Association,
+      N_Component_List,
+      N_Derived_Type_Definition,
+      N_Decimal_Fixed_Point_Definition,
+      N_Defining_Program_Unit_Name,
+      N_Delta_Constraint,
+      N_Designator,
+      N_Digits_Constraint,
+      N_Discriminant_Association,
+      N_Discriminant_Specification,
+      N_Enumeration_Type_Definition,
+      N_Entry_Body,
+      N_Entry_Call_Alternative,
+      N_Exception_Declaration,
+      N_Exception_Handler,
+      N_Floating_Point_Definition,
+      N_Formal_Decimal_Fixed_Point_Definition,
+      N_Formal_Derived_Type_Definition,
+      N_Formal_Discrete_Type_Definition,
+      N_Formal_Floating_Point_Definition,
+      N_Formal_Modular_Type_Definition,
+      N_Formal_Ordinary_Fixed_Point_Definition,
+      N_Formal_Package_Declaration,
+      N_Formal_Private_Type_Definition,
+      N_Formal_Signed_Integer_Type_Definition,
+      N_Formal_Subprogram_Declaration,
+      N_Generic_Association,
+      N_Handled_Sequence_Of_Statements,
+      N_Index_Or_Discriminant_Constraint,
+      N_Itype_Reference,
+      N_Label,
+      N_Modular_Type_Definition,
+      N_Number_Declaration,
+      N_Ordinary_Fixed_Point_Definition,
+      N_Others_Choice,
+      N_Package_Specification,
+      N_Parameter_Association,
+      N_Parameter_Specification,
+      N_Protected_Definition,
+      N_Range_Constraint,
+      N_Real_Range_Specification,
+      N_Record_Definition,
+      N_Signed_Integer_Type_Definition,
+      N_Single_Protected_Declaration,
+      N_Subunit,
+      N_Task_Definition,
+      N_Triggering_Alternative,
+      N_Use_Type_Clause,
+      N_Validate_Unchecked_Conversion,
+      N_Variant,
+      N_Variant_Part,
+      N_With_Clause,
+      N_With_Type_Clause,
+      N_Unused_At_End);
+
+   for Node_Kind'Size use 8;
+   --  The data structures in Atree assume this!
+
+   ----------------------------
+   -- Node Class Definitions --
+   ----------------------------
+
+   subtype N_Access_To_Subprogram_Definition is Node_Kind range
+     N_Access_Function_Definition ..
+     N_Access_Procedure_Definition;
+
+   subtype N_Array_Type_Definition is Node_Kind range
+     N_Constrained_Array_Definition ..
+     N_Unconstrained_Array_Definition;
+
+   subtype N_Binary_Op is Node_Kind range
+     N_Op_Add ..
+     N_Op_Shift_Right_Arithmetic;
+
+   subtype N_Body_Stub is Node_Kind range
+     N_Package_Body_Stub ..
+     N_Task_Body_Stub;
+
+   subtype N_Declaration is Node_Kind range
+     N_Component_Declaration ..
+     N_Procedure_Specification;
+   --  Note: this includes all constructs normally thought of as declarations
+   --  except those which are separately grouped as later declarations.
+
+   subtype N_Direct_Name is Node_Kind range
+     N_Identifier ..
+     N_Character_Literal;
+
+   subtype N_Entity is Node_Kind range
+     N_Defining_Character_Literal ..
+     N_Defining_Operator_Symbol;
+
+   subtype N_Generic_Declaration is Node_Kind range
+     N_Generic_Package_Declaration ..
+     N_Generic_Subprogram_Declaration;
+
+   subtype N_Generic_Instantiation is Node_Kind range
+     N_Function_Instantiation ..
+     N_Procedure_Instantiation;
+
+   subtype N_Generic_Renaming_Declaration is Node_Kind range
+     N_Generic_Function_Renaming_Declaration ..
+     N_Generic_Procedure_Renaming_Declaration;
+
+   subtype N_Has_Chars is Node_Kind range
+     N_Attribute_Definition_Clause ..
+     N_Op_Plus;
+
+   subtype N_Has_Entity is Node_Kind range
+     N_Expanded_Name ..
+     N_Attribute_Reference;
+   --  Nodes that have Entity fields
+   --  Warning: DOES NOT INCLUDE N_Freeze_Entity!
+
+   subtype N_Has_Etype is Node_Kind range
+     N_Defining_Character_Literal ..
+     N_Subtype_Indication;
+
+   subtype N_Later_Decl_Item is Node_Kind range
+     N_Task_Type_Declaration ..
+     N_Generic_Subprogram_Declaration;
+   --  Note: this is Ada 83 relevant only (see Ada 83 RM 3.9 (2)) and
+   --  includes only those items which can appear as later declarative
+   --  items. This also includes N_Implicit_Label_Declaration which is
+   --  not specifically in the grammar but may appear as a valid later
+   --  declarative items. It does NOT include N_Pragma which can also
+   --  appear among later declarative items. It does however include
+   --  N_Protected_Body, which is a bit peculiar, but harmless since
+   --  this cannot appear in Ada 83 mode anyway.
+
+   subtype N_Op is Node_Kind range
+     N_Op_Add ..
+     N_Op_Plus;
+
+   subtype N_Op_Boolean is Node_Kind range
+     N_Op_And ..
+     N_Op_Xor;
+   --  Binary operators which take operands of a boolean type, and yield
+   --  a result of a boolean type.
+
+   subtype N_Op_Compare is Node_Kind range
+     N_Op_Eq ..
+     N_Op_Ne;
+
+   subtype N_Op_Shift is Node_Kind range
+     N_Op_Rotate_Left ..
+     N_Op_Shift_Right_Arithmetic;
+
+   subtype N_Proper_Body is Node_Kind range
+     N_Package_Body ..
+     N_Task_Body;
+
+   subtype N_Raise_xxx_Error is Node_Kind range
+     N_Raise_Constraint_Error ..
+     N_Raise_Storage_Error;
+
+   subtype N_Renaming_Declaration is Node_Kind range
+     N_Exception_Renaming_Declaration ..
+     N_Generic_Procedure_Renaming_Declaration;
+
+   subtype N_Representation_Clause is Node_Kind range
+     N_At_Clause ..
+     N_Attribute_Definition_Clause;
+
+   subtype N_Statement_Other_Than_Procedure_Call is Node_Kind range
+     N_Abort_Statement ..
+     N_If_Statement;
+   --  Note that this includes all statement types except for the cases of the
+   --  N_Procedure_Call_Statement which is considered to be a subexpression
+   --  (since overloading is possible, so it needs to go through the normal
+   --  overloading resolution for expressions).
+
+   subtype N_Has_Condition is Node_Kind range
+     N_Exit_Statement ..
+     N_Terminate_Alternative;
+   --  Nodes with condition fields (does not include N_Raise_xxx_Error)
+
+   subtype N_Subexpr is Node_Kind range
+     N_Expanded_Name ..
+     N_Unchecked_Type_Conversion;
+   --  Nodes with expression fields
+
+   subtype N_Subprogram_Specification is Node_Kind range
+     N_Function_Specification ..
+     N_Procedure_Specification;
+
+   subtype N_Unary_Op is Node_Kind range
+     N_Op_Abs ..
+     N_Op_Plus;
+
+   subtype N_Unit_Body is Node_Kind range
+     N_Package_Body ..
+     N_Subprogram_Body;
+
+   ---------------------------
+   -- Node Access Functions --
+   ---------------------------
+
+   --  The following functions return the contents of the indicated field of
+   --  the node referenced by the argument, which is a Node_Id. They provide
+   --  logical access to fields in the node which could be accessed using the
+   --  Atree.Unchecked_Access package, but the idea is always to use these
+   --  higher level routines which preserve strong typing. In debug mode,
+   --  these routines check that they are being applied to an appropriate
+   --  node, as well as checking that the node is in range.
+
+   function ABE_Is_Certain
+     (N : Node_Id) return Boolean;    -- Flag18
+
+   function Abort_Present
+     (N : Node_Id) return Boolean;    -- Flag15
+
+   function Abortable_Part
+     (N : Node_Id) return Node_Id;    -- Node2
+
+   function Abstract_Present
+     (N : Node_Id) return Boolean;    -- Flag4
+
+   function Accept_Handler_Records
+     (N : Node_Id) return List_Id;    -- List5
+
+   function Accept_Statement
+     (N : Node_Id) return Node_Id;    -- Node2
+
+   function Access_Types_To_Process
+     (N : Node_Id) return Elist_Id;   -- Elist2
+
+   function Actions
+     (N : Node_Id) return List_Id;    -- List1
+
+   function Activation_Chain_Entity
+     (N : Node_Id) return Node_Id;    -- Node3
+
+   function Acts_As_Spec
+     (N : Node_Id) return Boolean;    -- Flag4
+
+   function Aggregate_Bounds
+     (N : Node_Id) return Node_Id;    -- Node3
+
+   function Aliased_Present
+     (N : Node_Id) return Boolean;    -- Flag4
+
+   function All_Others
+     (N : Node_Id) return Boolean;    -- Flag11
+
+   function All_Present
+     (N : Node_Id) return Boolean;    -- Flag15
+
+   function Alternatives
+     (N : Node_Id) return List_Id;    -- List4
+
+   function Ancestor_Part
+     (N : Node_Id) return Node_Id;    -- Node3
+
+   function Array_Aggregate
+     (N : Node_Id) return Node_Id;    -- Node3
+
+   function Assignment_OK
+     (N : Node_Id) return Boolean;    -- Flag15
+
+   function At_End_Proc
+     (N : Node_Id) return Node_Id;    -- Node1
+
+   function Attribute_Name
+     (N : Node_Id) return Name_Id;    -- Name2
+
+   function Aux_Decls_Node
+     (N : Node_Id) return Node_Id;    -- Node5
+
+   function Backwards_OK
+     (N : Node_Id) return Boolean;    -- Flag6
+
+   function Bad_Is_Detected
+     (N : Node_Id) return Boolean;    -- Flag15
+
+   function By_Ref
+     (N : Node_Id) return Boolean;    -- Flag5
+
+   function Body_Required
+     (N : Node_Id) return Boolean;    -- Flag13
+
+   function Body_To_Inline
+     (N : Node_Id) return Node_Id;    -- Node3
+
+   function Box_Present
+     (N : Node_Id) return Boolean;    -- Flag15
+
+   function Char_Literal_Value
+     (N : Node_Id) return Char_Code;  -- Char_Code2
+
+   function Chars
+     (N : Node_Id) return Name_Id;    -- Name1
+
+   function Choice_Parameter
+     (N : Node_Id) return Node_Id;    -- Node2
+
+   function Choices
+     (N : Node_Id) return List_Id;    -- List1
+
+   function Compile_Time_Known_Aggregate
+     (N : Node_Id) return Boolean;    -- Flag18
+
+   function Component_Associations
+     (N : Node_Id) return List_Id;    -- List2
+
+   function Component_Clauses
+     (N : Node_Id) return List_Id;    -- List3
+
+   function Component_Items
+     (N : Node_Id) return List_Id;    -- List3
+
+   function Component_List
+     (N : Node_Id) return Node_Id;    -- Node1
+
+   function Component_Name
+     (N : Node_Id) return Node_Id;    -- Node1
+
+   function Condition
+     (N : Node_Id) return Node_Id;    -- Node1
+
+   function Condition_Actions
+     (N : Node_Id) return List_Id;    -- List3
+
+   function Constant_Present
+     (N : Node_Id) return Boolean;    -- Flag17
+
+   function Constraint
+     (N : Node_Id) return Node_Id;    -- Node3
+
+   function Constraints
+     (N : Node_Id) return List_Id;    -- List1
+
+   function Context_Installed
+     (N : Node_Id) return Boolean;    -- Flag13
+
+   function Context_Items
+     (N : Node_Id) return List_Id;    -- List1
+
+   function Controlling_Argument
+     (N : Node_Id) return Node_Id;    -- Node1
+
+   function Conversion_OK
+     (N : Node_Id) return Boolean;    -- Flag14
+
+   function Corresponding_Body
+     (N : Node_Id) return Node_Id;    -- Node5
+
+   function Corresponding_Generic_Association
+     (N : Node_Id) return Node_Id;    -- Node5
+
+   function Corresponding_Integer_Value
+     (N : Node_Id) return Uint;       -- Uint4
+
+   function Corresponding_Spec
+     (N : Node_Id) return Node_Id;    -- Node5
+
+   function Corresponding_Stub
+     (N : Node_Id) return Node_Id;    -- Node3
+
+   function Dcheck_Function
+     (N : Node_Id) return Entity_Id;  -- Node5
+
+   function Debug_Statement
+     (N : Node_Id) return Node_Id;    -- Node3
+
+   function Declarations
+     (N : Node_Id) return List_Id;    -- List2
+
+   function Default_Expression
+     (N : Node_Id) return Node_Id;    -- Node5
+
+   function Default_Name
+     (N : Node_Id) return Node_Id;    -- Node2
+
+   function Defining_Identifier
+     (N : Node_Id) return Entity_Id;  -- Node1
+
+   function Defining_Unit_Name
+     (N : Node_Id) return Node_Id;    -- Node1
+
+   function Delay_Alternative
+     (N : Node_Id) return Node_Id;    -- Node4
+
+   function Delay_Finalize_Attach
+     (N : Node_Id) return Boolean;    -- Flag14
+
+   function Delay_Statement
+     (N : Node_Id) return Node_Id;    -- Node2
+
+   function Delta_Expression
+     (N : Node_Id) return Node_Id;    -- Node3
+
+   function Digits_Expression
+     (N : Node_Id) return Node_Id;    -- Node2
+
+   function Discr_Check_Funcs_Built
+     (N : Node_Id) return Boolean;    -- Flag11
+
+   function Discrete_Choices
+     (N : Node_Id) return List_Id;    -- List4
+
+   function Discrete_Range
+     (N : Node_Id) return Node_Id;    -- Node4
+
+   function Discrete_Subtype_Definition
+     (N : Node_Id) return Node_Id;    -- Node4
+
+   function Discrete_Subtype_Definitions
+     (N : Node_Id) return List_Id;    -- List2
+
+   function Discriminant_Specifications
+     (N : Node_Id) return List_Id;    -- List4
+
+   function Discriminant_Type
+     (N : Node_Id) return Node_Id;    -- Node5
+
+   function Do_Access_Check
+     (N : Node_Id) return Boolean;    -- Flag11
+
+   function Do_Accessibility_Check
+     (N : Node_Id) return Boolean;    -- Flag13
+
+   function Do_Discriminant_Check
+     (N : Node_Id) return Boolean;    -- Flag13
+
+   function Do_Division_Check
+     (N : Node_Id) return Boolean;    -- Flag13
+
+   function Do_Length_Check
+     (N : Node_Id) return Boolean;    -- Flag4
+
+   function Do_Overflow_Check
+     (N : Node_Id) return Boolean;    -- Flag17
+
+   function Do_Range_Check
+     (N : Node_Id) return Boolean;    -- Flag9
+
+   function Do_Storage_Check
+     (N : Node_Id) return Boolean;    -- Flag17
+
+   function Do_Tag_Check
+     (N : Node_Id) return Boolean;    -- Flag13
+
+   function Elaborate_All_Present
+     (N : Node_Id) return Boolean;    -- Flag15
+
+   function Elaborate_Present
+     (N : Node_Id) return Boolean;    -- Flag4
+
+   function Elaboration_Boolean
+     (N : Node_Id) return Node_Id;    -- Node2
+
+   function Else_Actions
+     (N : Node_Id) return List_Id;    -- List3
+
+   function Else_Statements
+     (N : Node_Id) return List_Id;    -- List4
+
+   function Elsif_Parts
+     (N : Node_Id) return List_Id;    -- List3
+
+   function Enclosing_Variant
+     (N : Node_Id) return Node_Id;    -- Node2
+
+   function End_Label
+     (N : Node_Id) return Node_Id;    -- Node4
+
+   function End_Span
+     (N : Node_Id) return Uint;       -- Uint5
+
+   function Entity
+     (N : Node_Id) return Node_Id;    -- Node4
+
+   function Entry_Body_Formal_Part
+     (N : Node_Id) return Node_Id;    -- Node5
+
+   function Entry_Call_Alternative
+     (N : Node_Id) return Node_Id;    -- Node1
+
+   function Entry_Call_Statement
+     (N : Node_Id) return Node_Id;    -- Node1
+
+   function Entry_Direct_Name
+     (N : Node_Id) return Node_Id;    -- Node1
+
+   function Entry_Index
+     (N : Node_Id) return Node_Id;    -- Node5
+
+   function Entry_Index_Specification
+     (N : Node_Id) return Node_Id;    -- Node4
+
+   function Etype
+     (N : Node_Id) return Node_Id;    -- Node5
+
+   function Exception_Choices
+     (N : Node_Id) return List_Id;    -- List4
+
+   function Exception_Handlers
+     (N : Node_Id) return List_Id;    -- List5
+
+   function Exception_Junk
+     (N : Node_Id) return Boolean;    -- Flag11
+
+   function Explicit_Actual_Parameter
+     (N : Node_Id) return Node_Id;    -- Node3
+
+   function Expansion_Delayed
+     (N : Node_Id) return Boolean;    -- Flag11
+
+   function Explicit_Generic_Actual_Parameter
+     (N : Node_Id) return Node_Id;    -- Node1
+
+   function Expression
+     (N : Node_Id) return Node_Id;    -- Node3
+
+   function Expressions
+     (N : Node_Id) return List_Id;    -- List1
+
+   function First_Bit
+     (N : Node_Id) return Node_Id;    -- Node3
+
+   function First_Inlined_Subprogram
+     (N : Node_Id) return Entity_Id;  -- Node3
+
+   function First_Name
+     (N : Node_Id) return Boolean;    -- Flag5
+
+   function First_Named_Actual
+     (N : Node_Id) return Node_Id;    -- Node4
+
+   function First_Real_Statement
+     (N : Node_Id) return Node_Id;    -- Node2
+
+   function First_Subtype_Link
+     (N : Node_Id) return Entity_Id;  -- Node5
+
+   function Float_Truncate
+     (N : Node_Id) return Boolean;    -- Flag11
+
+   function Formal_Type_Definition
+     (N : Node_Id) return Node_Id;    -- Node3
+
+   function Forwards_OK
+     (N : Node_Id) return Boolean;    -- Flag5
+
+   function From_At_Mod
+     (N : Node_Id) return Boolean;    -- Flag4
+
+   function Generic_Associations
+     (N : Node_Id) return List_Id;    -- List3
+
+   function Generic_Formal_Declarations
+     (N : Node_Id) return List_Id;    -- List2
+
+   function Generic_Parent
+     (N : Node_Id) return Node_Id;    -- Node5
+
+   function Generic_Parent_Type
+     (N : Node_Id) return Node_Id;    -- Node4
+
+   function Handled_Statement_Sequence
+     (N : Node_Id) return Node_Id;    -- Node4
+
+   function Handler_List_Entry
+     (N : Node_Id) return Node_Id;    -- Node2
+
+   function Has_Created_Identifier
+     (N : Node_Id) return Boolean;    -- Flag15
+
+   function Has_Dynamic_Length_Check
+     (N : Node_Id) return Boolean;    -- Flag10
+
+   function Has_Dynamic_Range_Check
+     (N : Node_Id) return Boolean;    -- Flag12
+
+   function Has_No_Elaboration_Code
+     (N : Node_Id) return Boolean;    -- Flag17
+
+   function Has_Priority_Pragma
+     (N : Node_Id) return Boolean;    -- Flag6
+
+   function Has_Private_View
+     (N : Node_Id) return Boolean;    -- Flag11
+
+   function Has_Storage_Size_Pragma
+     (N : Node_Id) return Boolean;    -- Flag5
+
+   function Has_Task_Info_Pragma
+     (N : Node_Id) return Boolean;    -- Flag7
+
+   function Has_Task_Name_Pragma
+     (N : Node_Id) return Boolean;    -- Flag8
+
+   function Has_Wide_Character
+     (N : Node_Id) return Boolean;    -- Flag11
+
+   function Hidden_By_Use_Clause
+     (N : Node_Id) return Elist_Id;   -- Elist4
+
+   function High_Bound
+     (N : Node_Id) return Node_Id;    -- Node2
+
+   function Identifier
+     (N : Node_Id) return Node_Id;    -- Node1
+
+   function Implicit_With
+     (N : Node_Id) return Boolean;    -- Flag17
+
+   function In_Present
+     (N : Node_Id) return Boolean;    -- Flag15
+
+   function Includes_Infinities
+     (N : Node_Id) return Boolean;    -- Flag11
+
+   function Instance_Spec
+     (N : Node_Id) return Node_Id;    -- Node5
+
+   function Intval
+     (N : Node_Id) return Uint;       -- Uint3
+
+   function Is_Asynchronous_Call_Block
+     (N : Node_Id) return Boolean;    -- Flag7
+
+   function Is_Component_Left_Opnd
+     (N : Node_Id) return Boolean;    -- Flag13
+
+   function Is_Component_Right_Opnd
+     (N : Node_Id) return Boolean;    -- Flag14
+
+   function Is_Controlling_Actual
+     (N : Node_Id) return Boolean;    -- Flag16
+
+   function Is_Machine_Number
+     (N : Node_Id) return Boolean;    -- Flag11
+
+   function Is_Overloaded
+     (N : Node_Id) return Boolean;    -- Flag5
+
+   function Is_Power_Of_2_For_Shift
+     (N : Node_Id) return Boolean;    -- Flag13
+
+   function Is_Protected_Subprogram_Body
+     (N : Node_Id) return Boolean;    -- Flag7
+
+   function Is_Static_Expression
+     (N : Node_Id) return Boolean;    -- Flag6
+
+   function Is_Subprogram_Descriptor
+     (N : Node_Id) return Boolean;    -- Flag16
+
+   function Is_Task_Allocation_Block
+     (N : Node_Id) return Boolean;    -- Flag6
+
+   function Is_Task_Master
+     (N : Node_Id) return Boolean;    -- Flag5
+
+   function Iteration_Scheme
+     (N : Node_Id) return Node_Id;    -- Node2
+
+   function Itype
+     (N : Node_Id) return Entity_Id;  -- Node1
+
+   function Kill_Range_Check
+     (N : Node_Id) return Boolean;    -- Flag11
+
+   function Label_Construct
+     (N : Node_Id) return Node_Id;    -- Node2
+
+   function Left_Opnd
+     (N : Node_Id) return Node_Id;    -- Node2
+
+   function Last_Bit
+     (N : Node_Id) return Node_Id;    -- Node4
+
+   function Last_Name
+     (N : Node_Id) return Boolean;    -- Flag6
+
+   function Library_Unit
+     (N : Node_Id) return Node_Id;    -- Node4
+
+   function Limited_Present
+     (N : Node_Id) return Boolean;    -- Flag17
+
+   function Literals
+     (N : Node_Id) return List_Id;    -- List1
+
+   function Loop_Actions
+     (N : Node_Id) return List_Id;    -- List2
+
+   function Loop_Parameter_Specification
+     (N : Node_Id) return Node_Id;    -- Node4
+
+   function Low_Bound
+     (N : Node_Id) return Node_Id;    -- Node1
+
+   function Mod_Clause
+     (N : Node_Id) return Node_Id;    -- Node2
+
+   function More_Ids
+     (N : Node_Id) return Boolean;    -- Flag5
+
+   function Must_Not_Freeze
+     (N : Node_Id) return Boolean;    -- Flag8
+
+   function Name
+     (N : Node_Id) return Node_Id;    -- Node2
+
+   function Names
+     (N : Node_Id) return List_Id;    -- List2
+
+   function Next_Entity
+     (N : Node_Id) return Node_Id;    -- Node2
+
+   function Next_Named_Actual
+     (N : Node_Id) return Node_Id;    -- Node4
+
+   function Next_Rep_Item
+     (N : Node_Id) return Node_Id;    -- Node4
+
+   function Next_Use_Clause
+     (N : Node_Id) return Node_Id;    -- Node3
+
+   function No_Ctrl_Actions
+     (N : Node_Id) return Boolean;    -- Flag7
+
+   function No_Entities_Ref_In_Spec
+     (N : Node_Id) return Boolean;    -- Flag8
+
+   function No_Initialization
+     (N : Node_Id) return Boolean;    -- Flag13
+
+   function Null_Present
+     (N : Node_Id) return Boolean;    -- Flag13
+
+   function Null_Record_Present
+     (N : Node_Id) return Boolean;    -- Flag17
+
+   function Object_Definition
+     (N : Node_Id) return Node_Id;    -- Node4
+
+   function OK_For_Stream
+     (N : Node_Id) return Boolean;    -- Flag4
+
+   function Original_Discriminant
+     (N : Node_Id) return Node_Id;    -- Node2
+
+   function Others_Discrete_Choices
+     (N : Node_Id) return List_Id;    -- List1
+
+   function Out_Present
+     (N : Node_Id) return Boolean;    -- Flag17
+
+   function Parameter_Associations
+     (N : Node_Id) return List_Id;    -- List3
+
+   function Parameter_List_Truncated
+     (N : Node_Id) return Boolean;    -- Flag17
+
+   function Parameter_Specifications
+     (N : Node_Id) return List_Id;    -- List3
+
+   function Parameter_Type
+     (N : Node_Id) return Node_Id;    -- Node2
+
+   function Parent_Spec
+     (N : Node_Id) return Node_Id;    -- Node4
+
+   function Position
+     (N : Node_Id) return Node_Id;    -- Node2
+
+   function Pragma_Argument_Associations
+     (N : Node_Id) return List_Id;    -- List2
+
+   function Pragmas_After
+     (N : Node_Id) return List_Id;    -- List5
+
+   function Pragmas_Before
+     (N : Node_Id) return List_Id;    -- List4
+
+   function Prefix
+     (N : Node_Id) return Node_Id;    -- Node3
+
+   function Present_Expr
+     (N : Node_Id) return Uint;       -- Uint3
+
+   function Prev_Ids
+     (N : Node_Id) return Boolean;    -- Flag6
+
+   function Print_In_Hex
+     (N : Node_Id) return Boolean;    -- Flag13
+
+   function Private_Declarations
+     (N : Node_Id) return List_Id;    -- List3
+
+   function Private_Present
+     (N : Node_Id) return Boolean;    -- Flag15
+
+   function Procedure_To_Call
+     (N : Node_Id) return Node_Id;    -- Node4
+
+   function Proper_Body
+     (N : Node_Id) return Node_Id;    -- Node1
+
+   function Protected_Definition
+     (N : Node_Id) return Node_Id;    -- Node3
+
+   function Protected_Present
+     (N : Node_Id) return Boolean;    -- Flag15
+
+   function Raises_Constraint_Error
+     (N : Node_Id) return Boolean;    -- Flag7
+
+   function Range_Constraint
+     (N : Node_Id) return Node_Id;    -- Node4
+
+   function Range_Expression
+     (N : Node_Id) return Node_Id;    -- Node4
+
+   function Real_Range_Specification
+     (N : Node_Id) return Node_Id;    -- Node4
+
+   function Realval
+     (N : Node_Id) return Ureal;      -- Ureal3
+
+   function Record_Extension_Part
+     (N : Node_Id) return Node_Id;    -- Node3
+
+   function Redundant_Use
+     (N : Node_Id) return Boolean;    -- Flag13
+
+   function Return_Type
+     (N : Node_Id) return Node_Id;    -- Node2
+
+   function Reverse_Present
+     (N : Node_Id) return Boolean;    -- Flag15
+
+   function Right_Opnd
+     (N : Node_Id) return Node_Id;    -- Node3
+
+   function Rounded_Result
+     (N : Node_Id) return Boolean;    -- Flag18
+
+   function Scope
+     (N : Node_Id) return Node_Id;    -- Node3
+
+   function Select_Alternatives
+     (N : Node_Id) return List_Id;    -- List1
+
+   function Selector_Name
+     (N : Node_Id) return Node_Id;    -- Node2
+
+   function Selector_Names
+     (N : Node_Id) return List_Id;    -- List1
+
+   function Shift_Count_OK
+     (N : Node_Id) return Boolean;    -- Flag4
+
+   function Source_Type
+     (N : Node_Id) return Entity_Id;  -- Node1
+
+   function Specification
+     (N : Node_Id) return Node_Id;    -- Node1
+
+   function Statements
+     (N : Node_Id) return List_Id;    -- List3
+
+   function Static_Processing_OK
+     (N : Node_Id) return Boolean;    -- Flag4
+
+   function Storage_Pool
+     (N : Node_Id) return Node_Id;    -- Node1
+
+   function Strval
+     (N : Node_Id) return String_Id;  -- Str3
+
+   function Subtype_Indication
+     (N : Node_Id) return Node_Id;    -- Node5
+
+   function Subtype_Mark
+     (N : Node_Id) return Node_Id;    -- Node4
+
+   function Subtype_Marks
+     (N : Node_Id) return List_Id;    -- List2
+
+   function Tagged_Present
+     (N : Node_Id) return Boolean;    -- Flag15
+
+   function Target_Type
+     (N : Node_Id) return Entity_Id;  -- Node2
+
+   function Task_Body_Procedure
+     (N : Node_Id) return Entity_Id;  -- Node2
+
+   function Task_Definition
+     (N : Node_Id) return Node_Id;    -- Node3
+
+   function Then_Actions
+     (N : Node_Id) return List_Id;    -- List2
+
+   function Then_Statements
+     (N : Node_Id) return List_Id;    -- List2
+
+   function Treat_Fixed_As_Integer
+     (N : Node_Id) return Boolean;    -- Flag14
+
+   function Triggering_Alternative
+     (N : Node_Id) return Node_Id;    -- Node1
+
+   function Triggering_Statement
+     (N : Node_Id) return Node_Id;    -- Node1
+
+   function TSS_Elist
+     (N : Node_Id) return Elist_Id;   -- Elist3
+
+   function Type_Definition
+     (N : Node_Id) return Node_Id;    -- Node3
+
+   function Unit
+     (N : Node_Id) return Node_Id;    -- Node2
+
+   function Unknown_Discriminants_Present
+     (N : Node_Id) return Boolean;    -- Flag13
+
+   function Unreferenced_In_Spec
+     (N : Node_Id) return Boolean;    -- Flag7
+
+   function Variant_Part
+     (N : Node_Id) return Node_Id;    -- Node4
+
+   function Variants
+     (N : Node_Id) return List_Id;    -- List1
+
+   function Visible_Declarations
+     (N : Node_Id) return List_Id;    -- List2
+
+   function Was_Originally_Stub
+     (N : Node_Id) return Boolean;    -- Flag13
+
+   function Zero_Cost_Handling
+     (N : Node_Id) return Boolean;    -- Flag5
+
+   --  End functions (note used by xsinfo utility program to end processing)
+
+   ----------------------------
+   -- Node Update Procedures --
+   ----------------------------
+
+   --  These are the corresponding node update routines, which again provide
+   --  a high level logical access with type checking. In addition to setting
+   --  the indicated field of the node N to the given Val, in the case of
+   --  tree pointers (List1-4), the parent pointer of the Val node is set to
+   --  point back to node N. This automates the setting of the parent pointer.
+
+   procedure Set_ABE_Is_Certain
+     (N : Node_Id; Val : Boolean := True);    -- Flag18
+
+   procedure Set_Abort_Present
+     (N : Node_Id; Val : Boolean := True);    -- Flag15
+
+   procedure Set_Abortable_Part
+     (N : Node_Id; Val : Node_Id);            -- Node2
+
+   procedure Set_Abstract_Present
+     (N : Node_Id; Val : Boolean := True);    -- Flag4
+
+   procedure Set_Accept_Handler_Records
+     (N : Node_Id; Val : List_Id);            -- List5
+
+   procedure Set_Accept_Statement
+     (N : Node_Id; Val : Node_Id);            -- Node2
+
+   procedure Set_Access_Types_To_Process
+     (N : Node_Id; Val : Elist_Id);           -- Elist2
+
+   procedure Set_Actions
+     (N : Node_Id; Val : List_Id);            -- List1
+
+   procedure Set_Activation_Chain_Entity
+     (N : Node_Id; Val : Node_Id);            -- Node3
+
+   procedure Set_Acts_As_Spec
+     (N : Node_Id; Val : Boolean := True);    -- Flag4
+
+   procedure Set_Aggregate_Bounds
+     (N : Node_Id; Val : Node_Id);            -- Node3
+
+   procedure Set_Aliased_Present
+     (N : Node_Id; Val : Boolean := True);    -- Flag4
+
+   procedure Set_All_Others
+     (N : Node_Id; Val : Boolean := True);    -- Flag11
+
+   procedure Set_All_Present
+     (N : Node_Id; Val : Boolean := True);    -- Flag15
+
+   procedure Set_Alternatives
+     (N : Node_Id; Val : List_Id);            -- List4
+
+   procedure Set_Ancestor_Part
+     (N : Node_Id; Val : Node_Id);            -- Node3
+
+   procedure Set_Array_Aggregate
+     (N : Node_Id; Val : Node_Id);            -- Node3
+
+   procedure Set_Assignment_OK
+     (N : Node_Id; Val : Boolean := True);    -- Flag15
+
+   procedure Set_Attribute_Name
+     (N : Node_Id; Val : Name_Id);            -- Name2
+
+   procedure Set_At_End_Proc
+     (N : Node_Id; Val : Node_Id);            -- Node1
+
+   procedure Set_Aux_Decls_Node
+     (N : Node_Id; Val : Node_Id);            -- Node5
+
+   procedure Set_Backwards_OK
+     (N : Node_Id; Val : Boolean := True);    -- Flag6
+
+   procedure Set_Bad_Is_Detected
+     (N : Node_Id; Val : Boolean := True);    -- Flag15
+
+   procedure Set_Body_Required
+     (N : Node_Id; Val : Boolean := True);    -- Flag13
+
+   procedure Set_Body_To_Inline
+     (N : Node_Id; Val : Node_Id);            -- Node3
+
+   procedure Set_Box_Present
+     (N : Node_Id; Val : Boolean := True);    -- Flag15
+
+   procedure Set_By_Ref
+     (N : Node_Id; Val : Boolean := True);    -- Flag5
+
+   procedure Set_Char_Literal_Value
+     (N : Node_Id; Val : Char_Code);          -- Char_Code2
+
+   procedure Set_Chars
+     (N : Node_Id; Val : Name_Id);            -- Name1
+
+   procedure Set_Choice_Parameter
+     (N : Node_Id; Val : Node_Id);            -- Node2
+
+   procedure Set_Choices
+     (N : Node_Id; Val : List_Id);            -- List1
+
+   procedure Set_Compile_Time_Known_Aggregate
+     (N : Node_Id; Val : Boolean := True);    -- Flag18
+
+   procedure Set_Component_Associations
+     (N : Node_Id; Val : List_Id);            -- List2
+
+   procedure Set_Component_Clauses
+     (N : Node_Id; Val : List_Id);            -- List3
+
+   procedure Set_Component_Items
+     (N : Node_Id; Val : List_Id);            -- List3
+
+   procedure Set_Component_List
+     (N : Node_Id; Val : Node_Id);            -- Node1
+
+   procedure Set_Component_Name
+     (N : Node_Id; Val : Node_Id);            -- Node1
+
+   procedure Set_Condition
+     (N : Node_Id; Val : Node_Id);            -- Node1
+
+   procedure Set_Condition_Actions
+     (N : Node_Id; Val : List_Id);            -- List3
+
+   procedure Set_Constant_Present
+     (N : Node_Id; Val : Boolean := True);    -- Flag17
+
+   procedure Set_Constraint
+     (N : Node_Id; Val : Node_Id);            -- Node3
+
+   procedure Set_Constraints
+     (N : Node_Id; Val : List_Id);            -- List1
+
+   procedure Set_Context_Installed
+     (N : Node_Id; Val : Boolean := True);    -- Flag13
+
+   procedure Set_Context_Items
+     (N : Node_Id; Val : List_Id);            -- List1
+
+   procedure Set_Controlling_Argument
+     (N : Node_Id; Val : Node_Id);            -- Node1
+
+   procedure Set_Conversion_OK
+     (N : Node_Id; Val : Boolean := True);    -- Flag14
+
+   procedure Set_Corresponding_Body
+     (N : Node_Id; Val : Node_Id);            -- Node5
+
+   procedure Set_Corresponding_Generic_Association
+     (N : Node_Id; Val : Node_Id);            -- Node5
+
+   procedure Set_Corresponding_Integer_Value
+     (N : Node_Id; Val : Uint);               -- Uint4
+
+   procedure Set_Corresponding_Spec
+     (N : Node_Id; Val : Node_Id);            -- Node5
+
+   procedure Set_Corresponding_Stub
+     (N : Node_Id; Val : Node_Id);            -- Node3
+
+   procedure Set_Dcheck_Function
+     (N : Node_Id; Val : Entity_Id);          -- Node5
+
+   procedure Set_Debug_Statement
+     (N : Node_Id; Val : Node_Id);            -- Node3
+
+   procedure Set_Declarations
+     (N : Node_Id; Val : List_Id);            -- List2
+
+   procedure Set_Default_Expression
+     (N : Node_Id; Val : Node_Id);            -- Node5
+
+   procedure Set_Default_Name
+     (N : Node_Id; Val : Node_Id);            -- Node2
+
+   procedure Set_Defining_Identifier
+     (N : Node_Id; Val : Entity_Id);          -- Node1
+
+   procedure Set_Defining_Unit_Name
+     (N : Node_Id; Val : Node_Id);            -- Node1
+
+   procedure Set_Delay_Alternative
+     (N : Node_Id; Val : Node_Id);            -- Node4
+
+   procedure Set_Delay_Finalize_Attach
+     (N : Node_Id; Val : Boolean := True);    -- Flag14
+
+   procedure Set_Delay_Statement
+     (N : Node_Id; Val : Node_Id);            -- Node2
+
+   procedure Set_Delta_Expression
+     (N : Node_Id; Val : Node_Id);            -- Node3
+
+   procedure Set_Digits_Expression
+     (N : Node_Id; Val : Node_Id);            -- Node2
+
+   procedure Set_Discr_Check_Funcs_Built
+     (N : Node_Id; Val : Boolean := True);    -- Flag11
+
+   procedure Set_Discrete_Choices
+     (N : Node_Id; Val : List_Id);            -- List4
+
+   procedure Set_Discrete_Range
+     (N : Node_Id; Val : Node_Id);            -- Node4
+
+   procedure Set_Discrete_Subtype_Definition
+     (N : Node_Id; Val : Node_Id);            -- Node4
+
+   procedure Set_Discrete_Subtype_Definitions
+     (N : Node_Id; Val : List_Id);            -- List2
+
+   procedure Set_Discriminant_Specifications
+     (N : Node_Id; Val : List_Id);            -- List4
+
+   procedure Set_Discriminant_Type
+     (N : Node_Id; Val : Node_Id);            -- Node5
+
+   procedure Set_Do_Access_Check
+     (N : Node_Id; Val : Boolean := True);    -- Flag11
+
+   procedure Set_Do_Accessibility_Check
+     (N : Node_Id; Val : Boolean := True);    -- Flag13
+
+   procedure Set_Do_Discriminant_Check
+     (N : Node_Id; Val : Boolean := True);    -- Flag13
+
+   procedure Set_Do_Division_Check
+     (N : Node_Id; Val : Boolean := True);    -- Flag13
+
+   procedure Set_Do_Length_Check
+     (N : Node_Id; Val : Boolean := True);    -- Flag4
+
+   procedure Set_Do_Overflow_Check
+     (N : Node_Id; Val : Boolean := True);    -- Flag17
+
+   procedure Set_Do_Range_Check
+     (N : Node_Id; Val : Boolean := True);    -- Flag9
+
+   procedure Set_Do_Storage_Check
+     (N : Node_Id; Val : Boolean := True);    -- Flag17
+
+   procedure Set_Do_Tag_Check
+     (N : Node_Id; Val : Boolean := True);    -- Flag13
+
+   procedure Set_Elaborate_All_Present
+     (N : Node_Id; Val : Boolean := True);    -- Flag15
+
+   procedure Set_Elaborate_Present
+     (N : Node_Id; Val : Boolean := True);    -- Flag4
+
+   procedure Set_Elaboration_Boolean
+     (N : Node_Id; Val : Node_Id);            -- Node2
+
+   procedure Set_Else_Actions
+     (N : Node_Id; Val : List_Id);            -- List3
+
+   procedure Set_Else_Statements
+     (N : Node_Id; Val : List_Id);            -- List4
+
+   procedure Set_Elsif_Parts
+     (N : Node_Id; Val : List_Id);            -- List3
+
+   procedure Set_Enclosing_Variant
+     (N : Node_Id; Val : Node_Id);            -- Node2
+
+   procedure Set_End_Label
+     (N : Node_Id; Val : Node_Id);            -- Node4
+
+   procedure Set_End_Span
+     (N : Node_Id; Val : Uint);               -- Uint5
+
+   procedure Set_Entity
+     (N : Node_Id; Val : Node_Id);            -- Node4
+
+   procedure Set_Entry_Body_Formal_Part
+     (N : Node_Id; Val : Node_Id);            -- Node5
+
+   procedure Set_Entry_Call_Alternative
+     (N : Node_Id; Val : Node_Id);            -- Node1
+
+   procedure Set_Entry_Call_Statement
+     (N : Node_Id; Val : Node_Id);            -- Node1
+
+   procedure Set_Entry_Direct_Name
+     (N : Node_Id; Val : Node_Id);            -- Node1
+
+   procedure Set_Entry_Index
+     (N : Node_Id; Val : Node_Id);            -- Node5
+
+   procedure Set_Entry_Index_Specification
+     (N : Node_Id; Val : Node_Id);            -- Node4
+
+   procedure Set_Etype
+     (N : Node_Id; Val : Node_Id);            -- Node5
+
+   procedure Set_Exception_Choices
+     (N : Node_Id; Val : List_Id);            -- List4
+
+   procedure Set_Exception_Handlers
+     (N : Node_Id; Val : List_Id);            -- List5
+
+   procedure Set_Exception_Junk
+     (N : Node_Id; Val : Boolean := True);    -- Flag11
+
+   procedure Set_Expansion_Delayed
+     (N : Node_Id; Val : Boolean := True);    -- Flag11
+
+   procedure Set_Explicit_Actual_Parameter
+     (N : Node_Id; Val : Node_Id);            -- Node3
+
+   procedure Set_Explicit_Generic_Actual_Parameter
+     (N : Node_Id; Val : Node_Id);            -- Node1
+
+   procedure Set_Expression
+     (N : Node_Id; Val : Node_Id);            -- Node3
+
+   procedure Set_Expressions
+     (N : Node_Id; Val : List_Id);            -- List1
+
+   procedure Set_First_Bit
+     (N : Node_Id; Val : Node_Id);            -- Node3
+
+   procedure Set_First_Inlined_Subprogram
+     (N : Node_Id; Val : Entity_Id);          -- Node3
+
+   procedure Set_First_Name
+     (N : Node_Id; Val : Boolean := True);    -- Flag5
+
+   procedure Set_First_Named_Actual
+     (N : Node_Id; Val : Node_Id);            -- Node4
+
+   procedure Set_First_Real_Statement
+     (N : Node_Id; Val : Node_Id);            -- Node2
+
+   procedure Set_First_Subtype_Link
+     (N : Node_Id; Val : Entity_Id);          -- Node5
+
+   procedure Set_Float_Truncate
+     (N : Node_Id; Val : Boolean := True);    -- Flag11
+
+   procedure Set_Formal_Type_Definition
+     (N : Node_Id; Val : Node_Id);            -- Node3
+
+   procedure Set_Forwards_OK
+     (N : Node_Id; Val : Boolean := True);    -- Flag5
+
+   procedure Set_From_At_Mod
+     (N : Node_Id; Val : Boolean := True);    -- Flag4
+
+   procedure Set_Generic_Associations
+     (N : Node_Id; Val : List_Id);            -- List3
+
+   procedure Set_Generic_Formal_Declarations
+     (N : Node_Id; Val : List_Id);            -- List2
+
+   procedure Set_Generic_Parent
+     (N : Node_Id; Val : Node_Id);            -- Node5
+
+   procedure Set_Generic_Parent_Type
+     (N : Node_Id; Val : Node_Id);            -- Node4
+
+   procedure Set_Handled_Statement_Sequence
+     (N : Node_Id; Val : Node_Id);            -- Node4
+
+   procedure Set_Handler_List_Entry
+     (N : Node_Id; Val : Node_Id);            -- Node2
+
+   procedure Set_Has_Created_Identifier
+     (N : Node_Id; Val : Boolean := True);    -- Flag15
+
+   procedure Set_Has_Dynamic_Length_Check
+     (N : Node_Id; Val : Boolean := True);    -- Flag10
+
+   procedure Set_Has_Dynamic_Range_Check
+     (N : Node_Id; Val : Boolean := True);    -- Flag12
+
+   procedure Set_Has_No_Elaboration_Code
+     (N : Node_Id; Val : Boolean := True);    -- Flag17
+
+   procedure Set_Has_Priority_Pragma
+     (N : Node_Id; Val : Boolean := True);    -- Flag6
+
+   procedure Set_Has_Private_View
+     (N : Node_Id; Val : Boolean := True);    -- Flag11
+
+   procedure Set_Has_Storage_Size_Pragma
+     (N : Node_Id; Val : Boolean := True);    -- Flag5
+
+   procedure Set_Has_Task_Info_Pragma
+     (N : Node_Id; Val : Boolean := True);    -- Flag7
+
+   procedure Set_Has_Task_Name_Pragma
+     (N : Node_Id; Val : Boolean := True);    -- Flag8
+
+   procedure Set_Has_Wide_Character
+     (N : Node_Id; Val : Boolean := True);    -- Flag11
+
+   procedure Set_Hidden_By_Use_Clause
+     (N : Node_Id; Val : Elist_Id);           -- Elist4
+
+   procedure Set_High_Bound
+     (N : Node_Id; Val : Node_Id);            -- Node2
+
+   procedure Set_Identifier
+     (N : Node_Id; Val : Node_Id);            -- Node1
+
+   procedure Set_Implicit_With
+     (N : Node_Id; Val : Boolean := True);    -- Flag17
+
+   procedure Set_In_Present
+     (N : Node_Id; Val : Boolean := True);    -- Flag15
+
+   procedure Set_Includes_Infinities
+     (N : Node_Id; Val : Boolean := True);    -- Flag11
+
+   procedure Set_Instance_Spec
+     (N : Node_Id; Val : Node_Id);            -- Node5
+
+   procedure Set_Intval
+     (N : Node_Id; Val : Uint);               -- Uint3
+
+   procedure Set_Is_Asynchronous_Call_Block
+     (N : Node_Id; Val : Boolean := True);    -- Flag7
+
+   procedure Set_Is_Component_Left_Opnd
+     (N : Node_Id; Val : Boolean := True);    -- Flag13
+
+   procedure Set_Is_Component_Right_Opnd
+     (N : Node_Id; Val : Boolean := True);    -- Flag14
+
+   procedure Set_Is_Controlling_Actual
+     (N : Node_Id; Val : Boolean := True);    -- Flag16
+
+   procedure Set_Is_Machine_Number
+     (N : Node_Id; Val : Boolean := True);    -- Flag11
+
+   procedure Set_Is_Overloaded
+     (N : Node_Id; Val : Boolean := True);    -- Flag5
+
+   procedure Set_Is_Power_Of_2_For_Shift
+     (N : Node_Id; Val : Boolean := True);    -- Flag13
+
+   procedure Set_Is_Protected_Subprogram_Body
+     (N : Node_Id; Val : Boolean := True);    -- Flag7
+
+   procedure Set_Is_Static_Expression
+     (N : Node_Id; Val : Boolean := True);    -- Flag6
+
+   procedure Set_Is_Subprogram_Descriptor
+     (N : Node_Id; Val : Boolean := True);    -- Flag16
+
+   procedure Set_Is_Task_Allocation_Block
+     (N : Node_Id; Val : Boolean := True);    -- Flag6
+
+   procedure Set_Is_Task_Master
+     (N : Node_Id; Val : Boolean := True);    -- Flag5
+
+   procedure Set_Iteration_Scheme
+     (N : Node_Id; Val : Node_Id);            -- Node2
+
+   procedure Set_Itype
+     (N : Node_Id; Val : Entity_Id);          -- Node1
+
+   procedure Set_Kill_Range_Check
+     (N : Node_Id; Val : Boolean := True);    -- Flag11
+
+   procedure Set_Last_Bit
+     (N : Node_Id; Val : Node_Id);            -- Node4
+
+   procedure Set_Last_Name
+     (N : Node_Id; Val : Boolean := True);    -- Flag6
+
+   procedure Set_Library_Unit
+     (N : Node_Id; Val : Node_Id);            -- Node4
+
+   procedure Set_Label_Construct
+     (N : Node_Id; Val : Node_Id);            -- Node2
+
+   procedure Set_Left_Opnd
+     (N : Node_Id; Val : Node_Id);            -- Node2
+
+   procedure Set_Limited_Present
+     (N : Node_Id; Val : Boolean := True);    -- Flag17
+
+   procedure Set_Literals
+     (N : Node_Id; Val : List_Id);            -- List1
+
+   procedure Set_Loop_Actions
+     (N : Node_Id; Val : List_Id);            -- List2
+
+   procedure Set_Loop_Parameter_Specification
+     (N : Node_Id; Val : Node_Id);            -- Node4
+
+   procedure Set_Low_Bound
+     (N : Node_Id; Val : Node_Id);            -- Node1
+
+   procedure Set_Mod_Clause
+     (N : Node_Id; Val : Node_Id);            -- Node2
+
+   procedure Set_More_Ids
+     (N : Node_Id; Val : Boolean := True);    -- Flag5
+
+   procedure Set_Must_Not_Freeze
+     (N : Node_Id; Val : Boolean := True);    -- Flag8
+
+   procedure Set_Name
+     (N : Node_Id; Val : Node_Id);            -- Node2
+
+   procedure Set_Names
+     (N : Node_Id; Val : List_Id);            -- List2
+
+   procedure Set_Next_Entity
+     (N : Node_Id; Val : Node_Id);            -- Node2
+
+   procedure Set_Next_Named_Actual
+     (N : Node_Id; Val : Node_Id);            -- Node4
+
+   procedure Set_Next_Rep_Item
+     (N : Node_Id; Val : Node_Id);            -- Node4
+
+   procedure Set_Next_Use_Clause
+     (N : Node_Id; Val : Node_Id);            -- Node3
+
+   procedure Set_No_Ctrl_Actions
+     (N : Node_Id; Val : Boolean := True);    -- Flag7
+
+   procedure Set_No_Entities_Ref_In_Spec
+     (N : Node_Id; Val : Boolean := True);    -- Flag8
+
+   procedure Set_No_Initialization
+     (N : Node_Id; Val : Boolean := True);    -- Flag13
+
+   procedure Set_Null_Present
+     (N : Node_Id; Val : Boolean := True);    -- Flag13
+
+   procedure Set_Null_Record_Present
+     (N : Node_Id; Val : Boolean := True);    -- Flag17
+
+   procedure Set_Object_Definition
+     (N : Node_Id; Val : Node_Id);            -- Node4
+
+   procedure Set_OK_For_Stream
+     (N : Node_Id; Val : Boolean := True);    -- Flag4
+
+   procedure Set_Original_Discriminant
+     (N : Node_Id; Val : Node_Id);            -- Node2
+
+   procedure Set_Others_Discrete_Choices
+     (N : Node_Id; Val : List_Id);            -- List1
+
+   procedure Set_Out_Present
+     (N : Node_Id; Val : Boolean := True);    -- Flag17
+
+   procedure Set_Parameter_Associations
+     (N : Node_Id; Val : List_Id);            -- List3
+
+   procedure Set_Parameter_List_Truncated
+     (N : Node_Id; Val : Boolean := True);    -- Flag17
+
+   procedure Set_Parameter_Specifications
+     (N : Node_Id; Val : List_Id);            -- List3
+
+   procedure Set_Parameter_Type
+     (N : Node_Id; Val : Node_Id);            -- Node2
+
+   procedure Set_Parent_Spec
+     (N : Node_Id; Val : Node_Id);            -- Node4
+
+   procedure Set_Position
+     (N : Node_Id; Val : Node_Id);            -- Node2
+
+   procedure Set_Pragma_Argument_Associations
+     (N : Node_Id; Val : List_Id);            -- List2
+
+   procedure Set_Pragmas_After
+     (N : Node_Id; Val : List_Id);            -- List5
+
+   procedure Set_Pragmas_Before
+     (N : Node_Id; Val : List_Id);            -- List4
+
+   procedure Set_Prefix
+     (N : Node_Id; Val : Node_Id);            -- Node3
+
+   procedure Set_Present_Expr
+     (N : Node_Id; Val : Uint);               -- Uint3
+
+   procedure Set_Prev_Ids
+     (N : Node_Id; Val : Boolean := True);    -- Flag6
+
+   procedure Set_Print_In_Hex
+     (N : Node_Id; Val : Boolean := True);    -- Flag13
+
+   procedure Set_Private_Declarations
+     (N : Node_Id; Val : List_Id);            -- List3
+
+   procedure Set_Private_Present
+     (N : Node_Id; Val : Boolean := True);    -- Flag15
+
+   procedure Set_Procedure_To_Call
+     (N : Node_Id; Val : Node_Id);            -- Node4
+
+   procedure Set_Proper_Body
+     (N : Node_Id; Val : Node_Id);            -- Node1
+
+   procedure Set_Protected_Definition
+     (N : Node_Id; Val : Node_Id);            -- Node3
+
+   procedure Set_Protected_Present
+     (N : Node_Id; Val : Boolean := True);    -- Flag15
+
+   procedure Set_Raises_Constraint_Error
+     (N : Node_Id; Val : Boolean := True);    -- Flag7
+
+   procedure Set_Range_Constraint
+     (N : Node_Id; Val : Node_Id);            -- Node4
+
+   procedure Set_Range_Expression
+     (N : Node_Id; Val : Node_Id);            -- Node4
+
+   procedure Set_Real_Range_Specification
+     (N : Node_Id; Val : Node_Id);            -- Node4
+
+   procedure Set_Realval
+     (N : Node_Id; Val : Ureal);              -- Ureal3
+
+   procedure Set_Record_Extension_Part
+     (N : Node_Id; Val : Node_Id);            -- Node3
+
+   procedure Set_Redundant_Use
+     (N : Node_Id; Val : Boolean := True);    -- Flag13
+
+   procedure Set_Return_Type
+     (N : Node_Id; Val : Node_Id);            -- Node2
+
+   procedure Set_Reverse_Present
+     (N : Node_Id; Val : Boolean := True);    -- Flag15
+
+   procedure Set_Right_Opnd
+     (N : Node_Id; Val : Node_Id);            -- Node3
+
+   procedure Set_Rounded_Result
+     (N : Node_Id; Val : Boolean := True);    -- Flag18
+
+   procedure Set_Scope
+     (N : Node_Id; Val : Node_Id);            -- Node3
+
+   procedure Set_Select_Alternatives
+     (N : Node_Id; Val : List_Id);            -- List1
+
+   procedure Set_Selector_Name
+     (N : Node_Id; Val : Node_Id);            -- Node2
+
+   procedure Set_Selector_Names
+     (N : Node_Id; Val : List_Id);            -- List1
+
+   procedure Set_Shift_Count_OK
+     (N : Node_Id; Val : Boolean := True);    -- Flag4
+
+   procedure Set_Source_Type
+     (N : Node_Id; Val : Entity_Id);          -- Node1
+
+   procedure Set_Specification
+     (N : Node_Id; Val : Node_Id);            -- Node1
+
+   procedure Set_Statements
+     (N : Node_Id; Val : List_Id);            -- List3
+
+   procedure Set_Static_Processing_OK
+     (N : Node_Id; Val : Boolean);            -- Flag4
+
+   procedure Set_Storage_Pool
+     (N : Node_Id; Val : Node_Id);            -- Node1
+
+   procedure Set_Strval
+     (N : Node_Id; Val : String_Id);          -- Str3
+
+   procedure Set_Subtype_Indication
+     (N : Node_Id; Val : Node_Id);            -- Node5
+
+   procedure Set_Subtype_Mark
+     (N : Node_Id; Val : Node_Id);            -- Node4
+
+   procedure Set_Subtype_Marks
+     (N : Node_Id; Val : List_Id);            -- List2
+
+   procedure Set_Tagged_Present
+     (N : Node_Id; Val : Boolean := True);    -- Flag15
+
+   procedure Set_Target_Type
+     (N : Node_Id; Val : Entity_Id);          -- Node2
+
+   procedure Set_Task_Body_Procedure
+     (N : Node_Id; Val : Entity_Id);          -- Node2
+
+   procedure Set_Task_Definition
+     (N : Node_Id; Val : Node_Id);            -- Node3
+
+   procedure Set_Then_Actions
+     (N : Node_Id; Val : List_Id);            -- List2
+
+   procedure Set_Then_Statements
+     (N : Node_Id; Val : List_Id);            -- List2
+
+   procedure Set_Treat_Fixed_As_Integer
+     (N : Node_Id; Val : Boolean := True);    -- Flag14
+
+   procedure Set_Triggering_Alternative
+     (N : Node_Id; Val : Node_Id);            -- Node1
+
+   procedure Set_Triggering_Statement
+     (N : Node_Id; Val : Node_Id);            -- Node1
+
+   procedure Set_TSS_Elist
+     (N : Node_Id; Val : Elist_Id);           -- Elist3
+
+   procedure Set_Type_Definition
+     (N : Node_Id; Val : Node_Id);            -- Node3
+
+   procedure Set_Unit
+     (N : Node_Id; Val : Node_Id);            -- Node2
+
+   procedure Set_Unknown_Discriminants_Present
+     (N : Node_Id; Val : Boolean := True);    -- Flag13
+
+   procedure Set_Unreferenced_In_Spec
+     (N : Node_Id; Val : Boolean := True);    -- Flag7
+
+   procedure Set_Variant_Part
+     (N : Node_Id; Val : Node_Id);            -- Node4
+
+   procedure Set_Variants
+     (N : Node_Id; Val : List_Id);            -- List1
+
+   procedure Set_Visible_Declarations
+     (N : Node_Id; Val : List_Id);            -- List2
+
+   procedure Set_Was_Originally_Stub
+     (N : Node_Id; Val : Boolean := True);    -- Flag13
+
+   procedure Set_Zero_Cost_Handling
+     (N : Node_Id; Val : Boolean := True);    -- Flag5
+
+   -------------------------
+   -- Iterator Procedures --
+   -------------------------
+
+   --  The call to Next_xxx (N) is equivalent to N := Next_xxx (N)
+
+   procedure Next_Entity       (N : in out Node_Id);
+   procedure Next_Named_Actual (N : in out Node_Id);
+   procedure Next_Rep_Item     (N : in out Node_Id);
+   procedure Next_Use_Clause   (N : in out Node_Id);
+
+   --------------------------------------
+   -- Logical Access to End_Span Field --
+   --------------------------------------
+
+   function End_Location (N : Node_Id) return Source_Ptr;
+   --  N is an N_If_Statement or N_Case_Statement node, and this
+   --  function returns the location of the IF token in the END IF
+   --  sequence by translating the value of the End_Span field.
+
+   procedure Set_End_Location (N : Node_Id; S : Source_Ptr);
+   --  N is an N_If_Statement or N_Case_Statement node. This procedure
+   --  sets the End_Span field to correspond to the given value S. In
+   --  other words, End_Span is set to the difference between S and
+   --  Sloc (N), the starting location.
+
+   --------------------
+   -- Inline Pragmas --
+   --------------------
+
+   pragma Inline (ABE_Is_Certain);
+   pragma Inline (Abort_Present);
+   pragma Inline (Abortable_Part);
+   pragma Inline (Abstract_Present);
+   pragma Inline (Accept_Handler_Records);
+   pragma Inline (Accept_Statement);
+   pragma Inline (Access_Types_To_Process);
+   pragma Inline (Actions);
+   pragma Inline (Activation_Chain_Entity);
+   pragma Inline (Acts_As_Spec);
+   pragma Inline (Aggregate_Bounds);
+   pragma Inline (Aliased_Present);
+   pragma Inline (All_Others);
+   pragma Inline (All_Present);
+   pragma Inline (Alternatives);
+   pragma Inline (Ancestor_Part);
+   pragma Inline (Array_Aggregate);
+   pragma Inline (Assignment_OK);
+   pragma Inline (At_End_Proc);
+   pragma Inline (Attribute_Name);
+   pragma Inline (Aux_Decls_Node);
+   pragma Inline (Backwards_OK);
+   pragma Inline (Bad_Is_Detected);
+   pragma Inline (Body_To_Inline);
+   pragma Inline (Body_Required);
+   pragma Inline (By_Ref);
+   pragma Inline (Box_Present);
+   pragma Inline (Char_Literal_Value);
+   pragma Inline (Chars);
+   pragma Inline (Choice_Parameter);
+   pragma Inline (Choices);
+   pragma Inline (Compile_Time_Known_Aggregate);
+   pragma Inline (Component_Associations);
+   pragma Inline (Component_Clauses);
+   pragma Inline (Component_Items);
+   pragma Inline (Component_List);
+   pragma Inline (Component_Name);
+   pragma Inline (Condition);
+   pragma Inline (Condition_Actions);
+   pragma Inline (Constant_Present);
+   pragma Inline (Constraint);
+   pragma Inline (Constraints);
+   pragma Inline (Context_Installed);
+   pragma Inline (Context_Items);
+   pragma Inline (Controlling_Argument);
+   pragma Inline (Conversion_OK);
+   pragma Inline (Corresponding_Body);
+   pragma Inline (Corresponding_Generic_Association);
+   pragma Inline (Corresponding_Integer_Value);
+   pragma Inline (Corresponding_Spec);
+   pragma Inline (Corresponding_Stub);
+   pragma Inline (Dcheck_Function);
+   pragma Inline (Debug_Statement);
+   pragma Inline (Declarations);
+   pragma Inline (Default_Expression);
+   pragma Inline (Default_Name);
+   pragma Inline (Defining_Identifier);
+   pragma Inline (Defining_Unit_Name);
+   pragma Inline (Delay_Alternative);
+   pragma Inline (Delay_Finalize_Attach);
+   pragma Inline (Delay_Statement);
+   pragma Inline (Delta_Expression);
+   pragma Inline (Digits_Expression);
+   pragma Inline (Discr_Check_Funcs_Built);
+   pragma Inline (Discrete_Choices);
+   pragma Inline (Discrete_Range);
+   pragma Inline (Discrete_Subtype_Definition);
+   pragma Inline (Discrete_Subtype_Definitions);
+   pragma Inline (Discriminant_Specifications);
+   pragma Inline (Discriminant_Type);
+   pragma Inline (Do_Access_Check);
+   pragma Inline (Do_Accessibility_Check);
+   pragma Inline (Do_Discriminant_Check);
+   pragma Inline (Do_Length_Check);
+   pragma Inline (Do_Division_Check);
+   pragma Inline (Do_Overflow_Check);
+   pragma Inline (Do_Range_Check);
+   pragma Inline (Do_Storage_Check);
+   pragma Inline (Do_Tag_Check);
+   pragma Inline (Elaborate_Present);
+   pragma Inline (Elaborate_All_Present);
+   pragma Inline (Elaboration_Boolean);
+   pragma Inline (Else_Actions);
+   pragma Inline (Else_Statements);
+   pragma Inline (Elsif_Parts);
+   pragma Inline (Enclosing_Variant);
+   pragma Inline (End_Label);
+   pragma Inline (End_Span);
+   pragma Inline (Entity);
+   pragma Inline (Entry_Body_Formal_Part);
+   pragma Inline (Entry_Call_Alternative);
+   pragma Inline (Entry_Call_Statement);
+   pragma Inline (Entry_Direct_Name);
+   pragma Inline (Entry_Index);
+   pragma Inline (Entry_Index_Specification);
+   pragma Inline (Etype);
+   pragma Inline (Exception_Choices);
+   pragma Inline (Exception_Junk);
+   pragma Inline (Exception_Handlers);
+   pragma Inline (Expansion_Delayed);
+   pragma Inline (Explicit_Actual_Parameter);
+   pragma Inline (Explicit_Generic_Actual_Parameter);
+   pragma Inline (Expression);
+   pragma Inline (Expressions);
+   pragma Inline (First_Bit);
+   pragma Inline (First_Inlined_Subprogram);
+   pragma Inline (First_Name);
+   pragma Inline (First_Named_Actual);
+   pragma Inline (First_Real_Statement);
+   pragma Inline (First_Subtype_Link);
+   pragma Inline (Float_Truncate);
+   pragma Inline (Formal_Type_Definition);
+   pragma Inline (Forwards_OK);
+   pragma Inline (From_At_Mod);
+   pragma Inline (Generic_Associations);
+   pragma Inline (Generic_Formal_Declarations);
+   pragma Inline (Generic_Parent);
+   pragma Inline (Generic_Parent_Type);
+   pragma Inline (Handled_Statement_Sequence);
+   pragma Inline (Handler_List_Entry);
+   pragma Inline (Has_Created_Identifier);
+   pragma Inline (Has_Dynamic_Length_Check);
+   pragma Inline (Has_Dynamic_Range_Check);
+   pragma Inline (Has_No_Elaboration_Code);
+   pragma Inline (Has_Priority_Pragma);
+   pragma Inline (Has_Private_View);
+   pragma Inline (Has_Storage_Size_Pragma);
+   pragma Inline (Has_Task_Info_Pragma);
+   pragma Inline (Has_Task_Name_Pragma);
+   pragma Inline (Has_Wide_Character);
+   pragma Inline (Hidden_By_Use_Clause);
+   pragma Inline (High_Bound);
+   pragma Inline (Identifier);
+   pragma Inline (Implicit_With);
+   pragma Inline (Includes_Infinities);
+   pragma Inline (In_Present);
+   pragma Inline (Instance_Spec);
+   pragma Inline (Intval);
+   pragma Inline (Is_Asynchronous_Call_Block);
+   pragma Inline (Is_Component_Left_Opnd);
+   pragma Inline (Is_Component_Right_Opnd);
+   pragma Inline (Is_Controlling_Actual);
+   pragma Inline (Is_Machine_Number);
+   pragma Inline (Is_Overloaded);
+   pragma Inline (Is_Power_Of_2_For_Shift);
+   pragma Inline (Is_Protected_Subprogram_Body);
+   pragma Inline (Is_Static_Expression);
+   pragma Inline (Is_Subprogram_Descriptor);
+   pragma Inline (Is_Task_Allocation_Block);
+   pragma Inline (Is_Task_Master);
+   pragma Inline (Iteration_Scheme);
+   pragma Inline (Itype);
+   pragma Inline (Kill_Range_Check);
+   pragma Inline (Last_Bit);
+   pragma Inline (Last_Name);
+   pragma Inline (Library_Unit);
+   pragma Inline (Label_Construct);
+   pragma Inline (Left_Opnd);
+   pragma Inline (Limited_Present);
+   pragma Inline (Literals);
+   pragma Inline (Loop_Actions);
+   pragma Inline (Loop_Parameter_Specification);
+   pragma Inline (Low_Bound);
+   pragma Inline (Mod_Clause);
+   pragma Inline (More_Ids);
+   pragma Inline (Must_Not_Freeze);
+   pragma Inline (Name);
+   pragma Inline (Names);
+   pragma Inline (Next_Entity);
+   pragma Inline (Next_Named_Actual);
+   pragma Inline (Next_Rep_Item);
+   pragma Inline (Next_Use_Clause);
+   pragma Inline (No_Ctrl_Actions);
+   pragma Inline (No_Entities_Ref_In_Spec);
+   pragma Inline (No_Initialization);
+   pragma Inline (Null_Present);
+   pragma Inline (Null_Record_Present);
+   pragma Inline (Object_Definition);
+   pragma Inline (OK_For_Stream);
+   pragma Inline (Original_Discriminant);
+   pragma Inline (Others_Discrete_Choices);
+   pragma Inline (Out_Present);
+   pragma Inline (Parameter_Associations);
+   pragma Inline (Parameter_Specifications);
+   pragma Inline (Parameter_List_Truncated);
+   pragma Inline (Parameter_Type);
+   pragma Inline (Parent_Spec);
+   pragma Inline (Position);
+   pragma Inline (Pragma_Argument_Associations);
+   pragma Inline (Pragmas_After);
+   pragma Inline (Pragmas_Before);
+   pragma Inline (Prefix);
+   pragma Inline (Present_Expr);
+   pragma Inline (Prev_Ids);
+   pragma Inline (Print_In_Hex);
+   pragma Inline (Private_Declarations);
+   pragma Inline (Private_Present);
+   pragma Inline (Procedure_To_Call);
+   pragma Inline (Proper_Body);
+   pragma Inline (Protected_Definition);
+   pragma Inline (Protected_Present);
+   pragma Inline (Raises_Constraint_Error);
+   pragma Inline (Range_Constraint);
+   pragma Inline (Range_Expression);
+   pragma Inline (Realval);
+   pragma Inline (Real_Range_Specification);
+   pragma Inline (Record_Extension_Part);
+   pragma Inline (Redundant_Use);
+   pragma Inline (Return_Type);
+   pragma Inline (Reverse_Present);
+   pragma Inline (Right_Opnd);
+   pragma Inline (Rounded_Result);
+   pragma Inline (Scope);
+   pragma Inline (Select_Alternatives);
+   pragma Inline (Selector_Name);
+   pragma Inline (Selector_Names);
+   pragma Inline (Shift_Count_OK);
+   pragma Inline (Source_Type);
+   pragma Inline (Specification);
+   pragma Inline (Statements);
+   pragma Inline (Static_Processing_OK);
+   pragma Inline (Storage_Pool);
+   pragma Inline (Strval);
+   pragma Inline (Subtype_Indication);
+   pragma Inline (Subtype_Mark);
+   pragma Inline (Subtype_Marks);
+   pragma Inline (Tagged_Present);
+   pragma Inline (Target_Type);
+   pragma Inline (Task_Body_Procedure);
+   pragma Inline (Task_Definition);
+   pragma Inline (Then_Actions);
+   pragma Inline (Then_Statements);
+   pragma Inline (Triggering_Alternative);
+   pragma Inline (Triggering_Statement);
+   pragma Inline (Treat_Fixed_As_Integer);
+   pragma Inline (TSS_Elist);
+   pragma Inline (Type_Definition);
+   pragma Inline (Unit);
+   pragma Inline (Unknown_Discriminants_Present);
+   pragma Inline (Unreferenced_In_Spec);
+   pragma Inline (Variant_Part);
+   pragma Inline (Variants);
+   pragma Inline (Visible_Declarations);
+   pragma Inline (Was_Originally_Stub);
+   pragma Inline (Zero_Cost_Handling);
+
+   pragma Inline (Set_ABE_Is_Certain);
+   pragma Inline (Set_Abort_Present);
+   pragma Inline (Set_Abortable_Part);
+   pragma Inline (Set_Abstract_Present);
+   pragma Inline (Set_Accept_Handler_Records);
+   pragma Inline (Set_Accept_Statement);
+   pragma Inline (Set_Access_Types_To_Process);
+   pragma Inline (Set_Actions);
+   pragma Inline (Set_Activation_Chain_Entity);
+   pragma Inline (Set_Acts_As_Spec);
+   pragma Inline (Set_Aggregate_Bounds);
+   pragma Inline (Set_Aliased_Present);
+   pragma Inline (Set_All_Others);
+   pragma Inline (Set_All_Present);
+   pragma Inline (Set_Alternatives);
+   pragma Inline (Set_Ancestor_Part);
+   pragma Inline (Set_Array_Aggregate);
+   pragma Inline (Set_Assignment_OK);
+   pragma Inline (Set_At_End_Proc);
+   pragma Inline (Set_Attribute_Name);
+   pragma Inline (Set_Aux_Decls_Node);
+   pragma Inline (Set_Backwards_OK);
+   pragma Inline (Set_Bad_Is_Detected);
+   pragma Inline (Set_Body_To_Inline);
+   pragma Inline (Set_Body_Required);
+   pragma Inline (Set_By_Ref);
+   pragma Inline (Set_Box_Present);
+   pragma Inline (Set_Char_Literal_Value);
+   pragma Inline (Set_Chars);
+   pragma Inline (Set_Choice_Parameter);
+   pragma Inline (Set_Choices);
+   pragma Inline (Set_Compile_Time_Known_Aggregate);
+   pragma Inline (Set_Component_Associations);
+   pragma Inline (Set_Component_Clauses);
+   pragma Inline (Set_Component_Items);
+   pragma Inline (Set_Component_List);
+   pragma Inline (Set_Component_Name);
+   pragma Inline (Set_Condition);
+   pragma Inline (Set_Condition_Actions);
+   pragma Inline (Set_Constant_Present);
+   pragma Inline (Set_Constraint);
+   pragma Inline (Set_Constraints);
+   pragma Inline (Set_Context_Installed);
+   pragma Inline (Set_Context_Items);
+   pragma Inline (Set_Controlling_Argument);
+   pragma Inline (Set_Conversion_OK);
+   pragma Inline (Set_Corresponding_Body);
+   pragma Inline (Set_Corresponding_Generic_Association);
+   pragma Inline (Set_Corresponding_Integer_Value);
+   pragma Inline (Set_Corresponding_Spec);
+   pragma Inline (Set_Corresponding_Stub);
+   pragma Inline (Set_Dcheck_Function);
+   pragma Inline (Set_Debug_Statement);
+   pragma Inline (Set_Declarations);
+   pragma Inline (Set_Default_Expression);
+   pragma Inline (Set_Default_Name);
+   pragma Inline (Set_Defining_Identifier);
+   pragma Inline (Set_Defining_Unit_Name);
+   pragma Inline (Set_Delay_Alternative);
+   pragma Inline (Set_Delay_Finalize_Attach);
+   pragma Inline (Set_Delay_Statement);
+   pragma Inline (Set_Delta_Expression);
+   pragma Inline (Set_Digits_Expression);
+   pragma Inline (Set_Discr_Check_Funcs_Built);
+   pragma Inline (Set_Discrete_Choices);
+   pragma Inline (Set_Discrete_Range);
+   pragma Inline (Set_Discrete_Subtype_Definition);
+   pragma Inline (Set_Discrete_Subtype_Definitions);
+   pragma Inline (Set_Discriminant_Specifications);
+   pragma Inline (Set_Discriminant_Type);
+   pragma Inline (Set_Do_Access_Check);
+   pragma Inline (Set_Do_Accessibility_Check);
+   pragma Inline (Set_Do_Discriminant_Check);
+   pragma Inline (Set_Do_Length_Check);
+   pragma Inline (Set_Do_Division_Check);
+   pragma Inline (Set_Do_Overflow_Check);
+   pragma Inline (Set_Do_Range_Check);
+   pragma Inline (Set_Do_Storage_Check);
+   pragma Inline (Set_Do_Tag_Check);
+   pragma Inline (Set_Elaborate_Present);
+   pragma Inline (Set_Elaborate_All_Present);
+   pragma Inline (Set_Elaboration_Boolean);
+   pragma Inline (Set_Else_Actions);
+   pragma Inline (Set_Else_Statements);
+   pragma Inline (Set_Elsif_Parts);
+   pragma Inline (Set_Enclosing_Variant);
+   pragma Inline (Set_End_Label);
+   pragma Inline (Set_End_Span);
+   pragma Inline (Set_Entity);
+   pragma Inline (Set_Entry_Body_Formal_Part);
+   pragma Inline (Set_Entry_Call_Alternative);
+   pragma Inline (Set_Entry_Call_Statement);
+   pragma Inline (Set_Entry_Direct_Name);
+   pragma Inline (Set_Entry_Index);
+   pragma Inline (Set_Entry_Index_Specification);
+   pragma Inline (Set_Etype);
+   pragma Inline (Set_Exception_Choices);
+   pragma Inline (Set_Exception_Junk);
+   pragma Inline (Set_Exception_Handlers);
+   pragma Inline (Set_Expansion_Delayed);
+   pragma Inline (Set_Explicit_Actual_Parameter);
+   pragma Inline (Set_Explicit_Generic_Actual_Parameter);
+   pragma Inline (Set_Expression);
+   pragma Inline (Set_Expressions);
+   pragma Inline (Set_First_Bit);
+   pragma Inline (Set_First_Inlined_Subprogram);
+   pragma Inline (Set_First_Name);
+   pragma Inline (Set_First_Named_Actual);
+   pragma Inline (Set_First_Real_Statement);
+   pragma Inline (Set_First_Subtype_Link);
+   pragma Inline (Set_Float_Truncate);
+   pragma Inline (Set_Formal_Type_Definition);
+   pragma Inline (Set_Forwards_OK);
+   pragma Inline (Set_From_At_Mod);
+   pragma Inline (Set_Generic_Associations);
+   pragma Inline (Set_Generic_Formal_Declarations);
+   pragma Inline (Set_Generic_Parent);
+   pragma Inline (Set_Generic_Parent_Type);
+   pragma Inline (Set_Handled_Statement_Sequence);
+   pragma Inline (Set_Handler_List_Entry);
+   pragma Inline (Set_Has_Created_Identifier);
+   pragma Inline (Set_Has_Dynamic_Length_Check);
+   pragma Inline (Set_Has_Dynamic_Range_Check);
+   pragma Inline (Set_Has_No_Elaboration_Code);
+   pragma Inline (Set_Has_Priority_Pragma);
+   pragma Inline (Set_Has_Private_View);
+   pragma Inline (Set_Has_Storage_Size_Pragma);
+   pragma Inline (Set_Has_Task_Info_Pragma);
+   pragma Inline (Set_Has_Task_Name_Pragma);
+   pragma Inline (Set_Has_Wide_Character);
+   pragma Inline (Set_Hidden_By_Use_Clause);
+   pragma Inline (Set_High_Bound);
+   pragma Inline (Set_Identifier);
+   pragma Inline (Set_Implicit_With);
+   pragma Inline (Set_Includes_Infinities);
+   pragma Inline (Set_In_Present);
+   pragma Inline (Set_Instance_Spec);
+   pragma Inline (Set_Intval);
+   pragma Inline (Set_Is_Asynchronous_Call_Block);
+   pragma Inline (Set_Is_Component_Left_Opnd);
+   pragma Inline (Set_Is_Component_Right_Opnd);
+   pragma Inline (Set_Is_Controlling_Actual);
+   pragma Inline (Set_Is_Machine_Number);
+   pragma Inline (Set_Is_Overloaded);
+   pragma Inline (Set_Is_Power_Of_2_For_Shift);
+   pragma Inline (Set_Is_Protected_Subprogram_Body);
+   pragma Inline (Set_Is_Static_Expression);
+   pragma Inline (Set_Is_Subprogram_Descriptor);
+   pragma Inline (Set_Is_Task_Allocation_Block);
+   pragma Inline (Set_Is_Task_Master);
+   pragma Inline (Set_Iteration_Scheme);
+   pragma Inline (Set_Itype);
+   pragma Inline (Set_Kill_Range_Check);
+   pragma Inline (Set_Last_Bit);
+   pragma Inline (Set_Last_Name);
+   pragma Inline (Set_Library_Unit);
+   pragma Inline (Set_Label_Construct);
+   pragma Inline (Set_Left_Opnd);
+   pragma Inline (Set_Limited_Present);
+   pragma Inline (Set_Literals);
+   pragma Inline (Set_Loop_Actions);
+   pragma Inline (Set_Loop_Parameter_Specification);
+   pragma Inline (Set_Low_Bound);
+   pragma Inline (Set_Mod_Clause);
+   pragma Inline (Set_More_Ids);
+   pragma Inline (Set_Must_Not_Freeze);
+   pragma Inline (Set_Name);
+   pragma Inline (Set_Names);
+   pragma Inline (Set_Next_Entity);
+   pragma Inline (Set_Next_Named_Actual);
+   pragma Inline (Set_Next_Use_Clause);
+   pragma Inline (Set_No_Ctrl_Actions);
+   pragma Inline (Set_No_Entities_Ref_In_Spec);
+   pragma Inline (Set_No_Initialization);
+   pragma Inline (Set_Null_Present);
+   pragma Inline (Set_Null_Record_Present);
+   pragma Inline (Set_Object_Definition);
+   pragma Inline (Set_OK_For_Stream);
+   pragma Inline (Set_Original_Discriminant);
+   pragma Inline (Set_Others_Discrete_Choices);
+   pragma Inline (Set_Out_Present);
+   pragma Inline (Set_Parameter_Associations);
+   pragma Inline (Set_Parameter_Specifications);
+   pragma Inline (Set_Parameter_List_Truncated);
+   pragma Inline (Set_Parameter_Type);
+   pragma Inline (Set_Parent_Spec);
+   pragma Inline (Set_Position);
+   pragma Inline (Set_Pragma_Argument_Associations);
+   pragma Inline (Set_Pragmas_After);
+   pragma Inline (Set_Pragmas_Before);
+   pragma Inline (Set_Prefix);
+   pragma Inline (Set_Present_Expr);
+   pragma Inline (Set_Prev_Ids);
+   pragma Inline (Set_Print_In_Hex);
+   pragma Inline (Set_Private_Declarations);
+   pragma Inline (Set_Private_Present);
+   pragma Inline (Set_Procedure_To_Call);
+   pragma Inline (Set_Proper_Body);
+   pragma Inline (Set_Protected_Definition);
+   pragma Inline (Set_Protected_Present);
+   pragma Inline (Set_Raises_Constraint_Error);
+   pragma Inline (Set_Range_Constraint);
+   pragma Inline (Set_Range_Expression);
+   pragma Inline (Set_Realval);
+   pragma Inline (Set_Real_Range_Specification);
+   pragma Inline (Set_Record_Extension_Part);
+   pragma Inline (Set_Redundant_Use);
+   pragma Inline (Set_Return_Type);
+   pragma Inline (Set_Reverse_Present);
+   pragma Inline (Set_Right_Opnd);
+   pragma Inline (Set_Rounded_Result);
+   pragma Inline (Set_Scope);
+   pragma Inline (Set_Select_Alternatives);
+   pragma Inline (Set_Selector_Name);
+   pragma Inline (Set_Selector_Names);
+   pragma Inline (Set_Shift_Count_OK);
+   pragma Inline (Set_Source_Type);
+   pragma Inline (Set_Specification);
+   pragma Inline (Set_Statements);
+   pragma Inline (Set_Static_Processing_OK);
+   pragma Inline (Set_Storage_Pool);
+   pragma Inline (Set_Strval);
+   pragma Inline (Set_Subtype_Indication);
+   pragma Inline (Set_Subtype_Mark);
+   pragma Inline (Set_Subtype_Marks);
+   pragma Inline (Set_Tagged_Present);
+   pragma Inline (Set_Target_Type);
+   pragma Inline (Set_Task_Body_Procedure);
+   pragma Inline (Set_Task_Definition);
+   pragma Inline (Set_Then_Actions);
+   pragma Inline (Set_Then_Statements);
+   pragma Inline (Set_Triggering_Alternative);
+   pragma Inline (Set_Triggering_Statement);
+   pragma Inline (Set_Treat_Fixed_As_Integer);
+   pragma Inline (Set_TSS_Elist);
+   pragma Inline (Set_Type_Definition);
+   pragma Inline (Set_Unit);
+   pragma Inline (Set_Unknown_Discriminants_Present);
+   pragma Inline (Set_Unreferenced_In_Spec);
+   pragma Inline (Set_Variant_Part);
+   pragma Inline (Set_Variants);
+   pragma Inline (Set_Visible_Declarations);
+   pragma Inline (Set_Was_Originally_Stub);
+   pragma Inline (Set_Zero_Cost_Handling);
+
+end Sinfo;
diff --git a/gcc/ada/sinput-l.adb b/gcc/ada/sinput-l.adb
new file mode 100644
index 00000000000..f00cbbd26dc
--- /dev/null
+++ b/gcc/ada/sinput-l.adb
@@ -0,0 +1,533 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             S I N P U T . L                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.40 $
+--                                                                          --
+--          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 Alloc;
+with Atree;  use Atree;
+with Debug;  use Debug;
+with Einfo;  use Einfo;
+with Namet;  use Namet;
+with Opt;
+with Osint;  use Osint;
+with Output; use Output;
+with Scans;  use Scans;
+with Scn;    use Scn;
+with Sinfo;  use Sinfo;
+with System; use System;
+
+with Unchecked_Conversion;
+
+package body Sinput.L is
+
+   Dfile : Source_File_Index;
+   --  Index of currently active debug source file
+
+   -----------------
+   -- Subprograms --
+   -----------------
+
+   procedure Trim_Lines_Table (S : Source_File_Index);
+   --  Set lines table size for entry S in the source file table to
+   --  correspond to the current value of Num_Source_Lines, releasing
+   --  any unused storage.
+
+   function Load_File
+     (N    : File_Name_Type;
+      T    : File_Type)
+      return Source_File_Index;
+   --  Load a source file or a configuration pragma file.
+
+   -------------------------------
+   -- Adjust_Instantiation_Sloc --
+   -------------------------------
+
+   procedure Adjust_Instantiation_Sloc (N : Node_Id; A : Sloc_Adjustment) is
+      Loc : constant Source_Ptr := Sloc (N);
+
+   begin
+      --  We only do the adjustment if the value is between the appropriate
+      --  low and high values. It is not clear that this should ever not be
+      --  the case, but in practice there seem to be some nodes that get
+      --  copied twice, and this is a defence against that happening.
+
+      if A.Lo <= Loc and then Loc <= A.Hi then
+         Set_Sloc (N, Loc + A.Adjust);
+      end if;
+   end Adjust_Instantiation_Sloc;
+
+   ------------------------
+   -- Close_Debug_Source --
+   ------------------------
+
+   procedure Close_Debug_Source is
+      S    : Source_File_Record renames Source_File.Table (Dfile);
+      Src  : Source_Buffer_Ptr;
+
+   begin
+      Trim_Lines_Table (Dfile);
+      Close_Debug_File;
+
+      --  Now we need to read the file that we wrote and store it
+      --  in memory for subsequent access.
+
+      Read_Source_File
+        (S.Debug_Source_Name, S.Source_First, S.Source_Last, Src);
+      S.Source_Text := Src;
+   end Close_Debug_Source;
+
+   --------------------------------
+   -- Complete_Source_File_Entry --
+   --------------------------------
+
+   procedure Complete_Source_File_Entry is
+      CSF : constant Source_File_Index := Current_Source_File;
+
+   begin
+      Trim_Lines_Table (CSF);
+      Source_File.Table (CSF).Source_Checksum := Checksum;
+   end Complete_Source_File_Entry;
+
+   -------------------------
+   -- Create_Debug_Source --
+   -------------------------
+
+   procedure Create_Debug_Source
+     (Source : Source_File_Index;
+      Loc    : out Source_Ptr)
+   is
+   begin
+      Loc := Source_File.Table (Source_File.Last).Source_Last + 1;
+      Source_File.Increment_Last;
+      Dfile := Source_File.Last;
+
+      declare
+         S : Source_File_Record renames Source_File.Table (Dfile);
+
+      begin
+         S := Source_File.Table (Source);
+         S.Debug_Source_Name := Create_Debug_File (S.File_Name);
+         S.Source_First      := Loc;
+         S.Source_Last       := Loc;
+         S.Lines_Table       := null;
+         S.Last_Source_Line  := 1;
+
+         --  Allocate lines table, guess that it needs to be three times
+         --  bigger than the original source (in number of lines).
+
+         Alloc_Line_Tables
+           (S, Int (Source_File.Table (Source).Last_Source_Line * 3));
+         S.Lines_Table (1) := Loc;
+      end;
+
+      if Debug_Flag_GG then
+         Write_Str ("---> Create_Debug_Source (Source => ");
+         Write_Int (Int (Source));
+         Write_Str (", Loc => ");
+         Write_Int (Int (Loc));
+         Write_Str (");");
+         Write_Eol;
+      end if;
+
+   end Create_Debug_Source;
+
+   ---------------------------------
+   -- Create_Instantiation_Source --
+   ---------------------------------
+
+   procedure Create_Instantiation_Source
+     (Inst_Node   : Entity_Id;
+      Template_Id : Entity_Id;
+      A           : out Sloc_Adjustment)
+   is
+      Dnod : constant Node_Id := Declaration_Node (Template_Id);
+      Xold : Source_File_Index;
+      Xnew : Source_File_Index;
+
+   begin
+      Xold := Get_Source_File_Index (Sloc (Template_Id));
+      A.Lo := Source_File.Table (Xold).Source_First;
+      A.Hi := Source_File.Table (Xold).Source_Last;
+
+      Source_File.Increment_Last;
+      Xnew := Source_File.Last;
+
+      Source_File.Table (Xnew)               := Source_File.Table (Xold);
+      Source_File.Table (Xnew).Instantiation := Sloc (Inst_Node);
+      Source_File.Table (Xnew).Template      := Xold;
+
+      --  Now we need to compute the new values of Source_First, Source_Last
+      --  and adjust the source file pointer to have the correct virtual
+      --  origin for the new range of values.
+
+      Source_File.Table (Xnew).Source_First :=
+        Source_File.Table (Xnew - 1).Source_Last + 1;
+
+      A.Adjust := Source_File.Table (Xnew).Source_First - A.Lo;
+      Source_File.Table (Xnew).Source_Last := A.Hi + A.Adjust;
+
+      Source_File.Table (Xnew).Sloc_Adjust :=
+        Source_File.Table (Xold).Sloc_Adjust - A.Adjust;
+
+      if Debug_Flag_L then
+         Write_Eol;
+         Write_Str ("*** Create instantiation source for ");
+
+         if Nkind (Dnod) in N_Proper_Body
+           and then Was_Originally_Stub (Dnod)
+         then
+            Write_Str ("subunit ");
+
+         elsif Ekind (Template_Id) = E_Generic_Package then
+            if Nkind (Dnod) = N_Package_Body then
+               Write_Str ("body of package ");
+            else
+               Write_Str ("spec of package ");
+            end if;
+
+         elsif Ekind (Template_Id) = E_Function then
+            Write_Str ("body of function ");
+
+         elsif Ekind (Template_Id) = E_Procedure then
+            Write_Str ("body of procedure ");
+
+         elsif Ekind (Template_Id) = E_Generic_Function then
+            Write_Str ("spec of function ");
+
+         elsif Ekind (Template_Id) = E_Generic_Procedure then
+            Write_Str ("spec of procedure ");
+
+         elsif Ekind (Template_Id) = E_Package_Body then
+            Write_Str ("body of package ");
+
+         else pragma Assert (Ekind (Template_Id) = E_Subprogram_Body);
+
+            if Nkind (Dnod) = N_Procedure_Specification then
+               Write_Str ("body of procedure ");
+            else
+               Write_Str ("body of function ");
+            end if;
+         end if;
+
+         Write_Name (Chars (Template_Id));
+         Write_Eol;
+
+         Write_Str ("  new source index = ");
+         Write_Int (Int (Xnew));
+         Write_Eol;
+
+         Write_Str ("  copying from file name = ");
+         Write_Name (File_Name (Xold));
+         Write_Eol;
+
+         Write_Str ("  old source index = ");
+         Write_Int (Int (Xold));
+         Write_Eol;
+
+         Write_Str ("  old lo = ");
+         Write_Int (Int (A.Lo));
+         Write_Eol;
+
+         Write_Str ("  old hi = ");
+         Write_Int (Int (A.Hi));
+         Write_Eol;
+
+         Write_Str ("  new lo = ");
+         Write_Int (Int (Source_File.Table (Xnew).Source_First));
+         Write_Eol;
+
+         Write_Str ("  new hi = ");
+         Write_Int (Int (Source_File.Table (Xnew).Source_Last));
+         Write_Eol;
+
+         Write_Str ("  adjustment factor = ");
+         Write_Int (Int (A.Adjust));
+         Write_Eol;
+
+         Write_Str ("  instantiation location: ");
+         Write_Location (Sloc (Inst_Node));
+         Write_Eol;
+      end if;
+
+      --  For a given character in the source, a higher subscript will be
+      --  used to access the instantiation, which means that the virtual
+      --  origin must have a corresponding lower value. We compute this
+      --  new origin by taking the address of the appropriate adjusted
+      --  element in the old array. Since this adjusted element will be
+      --  at a negative subscript, we must suppress checks.
+
+      declare
+         pragma Suppress (All_Checks);
+
+         function To_Source_Buffer_Ptr is new
+           Unchecked_Conversion (Address, Source_Buffer_Ptr);
+
+      begin
+         Source_File.Table (Xnew).Source_Text :=
+           To_Source_Buffer_Ptr
+             (Source_File.Table (Xold).Source_Text (-A.Adjust)'Address);
+      end;
+
+   end Create_Instantiation_Source;
+
+   ----------------------
+   -- Load_Config_File --
+   ----------------------
+
+   function Load_Config_File
+     (N    : File_Name_Type)
+      return Source_File_Index
+   is
+   begin
+      return Load_File (N, Osint.Config);
+   end Load_Config_File;
+
+   ---------------
+   -- Load_File --
+   ---------------
+
+   function Load_File
+     (N :    File_Name_Type;
+      T :    File_Type)
+      return Source_File_Index
+   is
+      Src  : Source_Buffer_Ptr;
+      X    : Source_File_Index;
+      Lo   : Source_Ptr;
+      Hi   : Source_Ptr;
+
+   begin
+      for J in 1 .. Source_File.Last loop
+         if Source_File.Table (J).File_Name = N then
+            return J;
+         end if;
+      end loop;
+
+      --  Here we must build a new entry in the file table
+
+      Source_File.Increment_Last;
+      X := Source_File.Last;
+
+      if X = Source_File.First then
+         Lo := First_Source_Ptr;
+      else
+         Lo := Source_File.Table (X - 1).Source_Last + 1;
+      end if;
+
+      Read_Source_File (N, Lo, Hi, Src, T);
+
+      if Src = null then
+         Source_File.Decrement_Last;
+         return No_Source_File;
+
+      else
+         if Debug_Flag_L then
+            Write_Eol;
+            Write_Str ("*** Build source file table entry, Index = ");
+            Write_Int (Int (X));
+            Write_Str (", file name = ");
+            Write_Name (N);
+            Write_Eol;
+            Write_Str ("  lo = ");
+            Write_Int (Int (Lo));
+            Write_Eol;
+            Write_Str ("  hi = ");
+            Write_Int (Int (Hi));
+            Write_Eol;
+
+            Write_Str ("  first 10 chars -->");
+
+            declare
+               procedure Wchar (C : Character);
+               --  Writes character or ? for control character
+
+               procedure Wchar (C : Character) is
+               begin
+                  if C < ' ' or C in ASCII.DEL .. Character'Val (16#9F#) then
+                     Write_Char ('?');
+                  else
+                     Write_Char (C);
+                  end if;
+               end Wchar;
+
+            begin
+               for J in Lo .. Lo + 9 loop
+                  Wchar (Src (J));
+               end loop;
+
+               Write_Str ("<--");
+               Write_Eol;
+
+               Write_Str ("  last 10 chars  -->");
+
+               for J in Hi - 10 .. Hi - 1 loop
+                  Wchar (Src (J));
+               end loop;
+
+               Write_Str ("<--");
+               Write_Eol;
+
+               if Src (Hi) /= EOF then
+                  Write_Str ("  error: no EOF at end");
+                  Write_Eol;
+               end if;
+            end;
+         end if;
+
+         declare
+            S : Source_File_Record renames Source_File.Table (X);
+
+         begin
+            S := (Debug_Source_Name   => Full_Source_Name,
+                  File_Name           => N,
+                  First_Mapped_Line   => No_Line_Number,
+                  Full_File_Name      => Full_Source_Name,
+                  Full_Ref_Name       => Full_Source_Name,
+                  Identifier_Casing   => Unknown,
+                  Instantiation       => No_Location,
+                  Keyword_Casing      => Unknown,
+                  Last_Source_Line    => 1,
+                  License             => Unknown,
+                  Lines_Table         => null,
+                  Lines_Table_Max     => 1,
+                  Logical_Lines_Table => null,
+                  Num_SRef_Pragmas    => 0,
+                  Reference_Name      => N,
+                  Sloc_Adjust         => 0,
+                  Source_Checksum     => 0,
+                  Source_First        => Lo,
+                  Source_Last         => Hi,
+                  Source_Text         => Src,
+                  Template            => No_Source_File,
+                  Time_Stamp          => Current_Source_File_Stamp);
+
+            Alloc_Line_Tables (S, Opt.Table_Factor * Alloc.Lines_Initial);
+            S.Lines_Table (1) := Lo;
+         end;
+
+         return X;
+      end if;
+   end Load_File;
+
+   ----------------------
+   -- Load_Source_File --
+   ----------------------
+
+   function Load_Source_File
+     (N    : File_Name_Type)
+      return Source_File_Index
+   is
+   begin
+      return Load_File (N, Osint.Source);
+   end Load_Source_File;
+
+   ----------------------------
+   -- Source_File_Is_Subunit --
+   ----------------------------
+
+   function Source_File_Is_Subunit (X : Source_File_Index) return Boolean is
+   begin
+      Initialize_Scanner (No_Unit, X);
+
+      --  We scan past junk to the first interesting compilation unit
+      --  token, to see if it is SEPARATE. We ignore WITH keywords during
+      --  this and also PRIVATE. The reason for ignoring PRIVATE is that
+      --  it handles some error situations, and also it is possible that
+      --  a PRIVATE WITH feature might be approved some time in the future.
+
+      while Token = Tok_With
+        or else Token = Tok_Private
+        or else (Token not in Token_Class_Cunit and then Token /= Tok_EOF)
+      loop
+         Scan;
+      end loop;
+
+      return Token = Tok_Separate;
+   end Source_File_Is_Subunit;
+
+   ----------------------
+   -- Trim_Lines_Table --
+   ----------------------
+
+   procedure Trim_Lines_Table (S : Source_File_Index) is
+
+      function realloc
+        (P        : Lines_Table_Ptr;
+         New_Size : Int)
+         return     Lines_Table_Ptr;
+      pragma Import (C, realloc);
+
+      Max : constant Nat := Nat (Source_File.Table (S).Last_Source_Line);
+
+   begin
+      --  Release allocated storage that is no longer needed
+
+      Source_File.Table (S).Lines_Table :=
+        realloc
+          (Source_File.Table (S).Lines_Table,
+           Max * (Lines_Table_Type'Component_Size / System.Storage_Unit));
+      Source_File.Table (S).Lines_Table_Max := Physical_Line_Number (Max);
+   end Trim_Lines_Table;
+
+   ----------------------
+   -- Write_Debug_Line --
+   ----------------------
+
+   procedure Write_Debug_Line (Str : String; Loc : in out Source_Ptr) is
+      S : Source_File_Record renames Source_File.Table (Dfile);
+
+   begin
+      --  Ignore write request if null line at start of file
+
+      if Str'Length = 0 and then Loc = S.Source_First then
+         return;
+
+      --  Here we write the line, and update the source record entry
+
+      else
+         Write_Debug_Info (Str);
+         Add_Line_Tables_Entry (S, Loc);
+         Loc := Loc + Source_Ptr (Str'Length + Debug_File_Eol_Length);
+         S.Source_Last := Loc;
+
+         if Debug_Flag_GG then
+            declare
+               Lin : constant String := Str;
+
+            begin
+               Column := 1;
+               Write_Str ("---> Write_Debug_Line (Str => """);
+               Write_Str (Lin);
+               Write_Str (""", Loc => ");
+               Write_Int (Int (Loc));
+               Write_Str (");");
+               Write_Eol;
+            end;
+         end if;
+      end if;
+   end Write_Debug_Line;
+
+end Sinput.L;
diff --git a/gcc/ada/sinput-l.ads b/gcc/ada/sinput-l.ads
new file mode 100644
index 00000000000..bba983fd00b
--- /dev/null
+++ b/gcc/ada/sinput-l.ads
@@ -0,0 +1,141 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             S I N P U T . L                              --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.14 $                             --
+--                                                                          --
+--          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 child package contains the routines used to actually load a source
+--  file and create entries in the source file table. It also contains the
+--  routines to create virtual entries for instantiations. This is separated
+--  off into a child package to avoid a dependence of Sinput on Osint which
+--  would cause trouble in the tree read/write routines.
+
+with Types; use Types;
+
+package Sinput.L is
+
+   -------------------------------------------
+   --  Subprograms for Loading Source Files --
+   -------------------------------------------
+
+   function Load_Source_File (N : File_Name_Type) return Source_File_Index;
+   --  Given a source file name, returns the index of the corresponding entry
+   --  in the source file table. If the file is not currently loaded, then
+   --  this is the call that causes the source file to be read and an entry
+   --  made in the table. A new entry in the table has the file name and time
+   --  stamp entries set and the Casing entries set to Unknown. Version is set
+   --  to all blanks, and the lines table is initialized but only the first
+   --  entry is set (and Last_Line is set to 1). If the given source file
+   --  cannot be opened, then the value returned is No_Source_File.
+
+   function Load_Config_File (N : File_Name_Type) return Source_File_Index;
+   --  Similar to Load_Source_File, except that the file name is always
+   --  interpreted in the context of the current working directory.
+
+   procedure Complete_Source_File_Entry;
+   --  Called on completing the parsing of a source file. This call completes
+   --  the source file table entry for the current source file.
+
+   function Source_File_Is_Subunit (X : Source_File_Index) return Boolean;
+   --  This function determines if a source file represents a subunit. It
+   --  works by scanning for the first compilation unit token, and returning
+   --  True if it is the token SEPARATE. It will return False otherwise,
+   --  meaning that the file cannot possibly be a legal subunit. This
+   --  function does NOT do a complete parse of the file, or build a
+   --  tree. It is used in the main driver in the check for bad bodies.
+
+   -------------------------------------------------
+   -- Subprograms for Dealing With Instantiations --
+   -------------------------------------------------
+
+   type Sloc_Adjustment is private;
+   --  Type returned by Create_Instantiation_Source for use in subsequent
+   --  calls to Adjust_Instantiation_Sloc.
+
+   procedure Create_Instantiation_Source
+     (Inst_Node   : Entity_Id;
+      Template_Id : Entity_Id;
+      A           : out Sloc_Adjustment);
+   --  This procedure creates the source table entry for an instantiation.
+   --  Inst_Node is the instantiation node, and Template_Id is the defining
+   --  identifier of the generic declaration or body unit as appropriate.
+   --  A is set to an adjustment factor to be used in subsequent calls to
+   --  Adjust_Instantiation_Sloc.
+
+   procedure Adjust_Instantiation_Sloc (N : Node_Id; A : Sloc_Adjustment);
+   --  The instantiation tree is created by copying the tree of the generic
+   --  template (including the original Sloc values), and then applying
+   --  Adjust_Instantiation_Sloc to each copied node to adjust the Sloc
+   --  to reference the source entry for the instantiation.
+
+   ------------------------------------------------
+   -- Subprograms for Writing Debug Source Files --
+   ------------------------------------------------
+
+   procedure Create_Debug_Source
+     (Source : Source_File_Index;
+      Loc    : out Source_Ptr);
+   --  Given a source file, creates a new source file table entry to be used
+   --  for the debug source file output (Debug_Generated_Code switch set).
+   --  Loc is set to the initial Sloc value for the first line. This call
+   --  also creates the debug source output file (using Create_Debug_File).
+
+   procedure Write_Debug_Line (Str : String; Loc : in out Source_Ptr);
+   --  This procedure is called to write a line to the debug source file
+   --  previously created by Create_Debug_Source using Write_Debug_Info.
+   --  Str is the source line to be written to the file (it does not include
+   --  an end of line character). On entry Loc is the Sloc value previously
+   --  returned by Create_Debug_Source or Write_Debug_Line, and on exit,
+   --  Sloc is updated to point to the start of the next line to be written,
+   --  taking into account the length of the ternminator that was written by
+   --  Write_Debug_Info.
+
+   procedure Close_Debug_Source;
+   --  This procedure completes the source table entry for the debug file
+   --  previously created by Create_Debug_Source, and written using the
+   --  Write_Debug_Line procedure. It then calls Close_Debug_File to
+   --  complete the writing of the file itself.
+
+private
+
+   type Sloc_Adjustment is record
+      Adjust : Source_Ptr;
+      --  Adjustment factor. To be added to source location values in the
+      --  source table entry for the template to get corresponding sloc
+      --  values for the instantiation image of the template. This is not
+      --  really a Source_Ptr value, but rather an offset, but it is more
+      --  convenient to represent it as a Source_Ptr value and this is a
+      --  private type anyway.
+
+      Lo, Hi : Source_Ptr;
+      --  Lo and hi values to which adjustment factor can legitimately
+      --  be applied, used to ensure that no incorrect adjustments are
+      --  made. Really it is a bug if anyone ever tries to adjust outside
+      --  this range, but since we are only doing this anyway for getting
+      --  better error messages, it is not critical
+
+   end record;
+
+end Sinput.L;
diff --git a/gcc/ada/sinput-p.adb b/gcc/ada/sinput-p.adb
new file mode 100644
index 00000000000..10a20f4db9a
--- /dev/null
+++ b/gcc/ada/sinput-p.adb
@@ -0,0 +1,233 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             S I N P U T . P                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.9 $
+--                                                                          --
+--          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 Ada.Unchecked_Conversion;
+
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+with Namet;       use Namet;
+with Opt;         use Opt;
+with System;      use System;
+
+package body Sinput.P is
+
+   First : Boolean := True;
+   --  Flag used when Load_Project_File is called the first time,
+   --  to set Main_Source_File.
+   --  The flag is reset to False at the first call to Load_Project_File
+
+   -----------------------
+   -- Load_Project_File --
+   -----------------------
+
+   function Load_Project_File (Path : String) return Source_File_Index is
+      Src  : Source_Buffer_Ptr;
+      X    : Source_File_Index;
+      Lo   : Source_Ptr;
+      Hi   : Source_Ptr;
+
+      Source_File_FD : File_Descriptor;
+      --  The file descriptor for the current source file. A negative value
+      --  indicates failure to open the specified source file.
+
+      Len : Integer;
+      --  Length of file. Assume no more than 2 gigabytes of source!
+
+      Actual_Len : Integer;
+
+      Path_Id : Name_Id;
+      File_Id : Name_Id;
+
+   begin
+      if Path = "" then
+         return No_Source_File;
+      end if;
+
+      Source_File.Increment_Last;
+      X := Source_File.Last;
+
+      if First then
+         Main_Source_File := X;
+         First := False;
+      end if;
+
+      if X = Source_File.First then
+         Lo := First_Source_Ptr;
+      else
+         Lo := Source_File.Table (X - 1).Source_Last + 1;
+      end if;
+
+      Name_Len := Path'Length;
+      Name_Buffer (1 .. Name_Len) := Path;
+      Path_Id := Name_Find;
+      Name_Buffer (Name_Len + 1) := ASCII.NUL;
+
+      --  Open the source FD, note that we open in binary mode, because as
+      --  documented in the spec, the caller is expected to handle either
+      --  DOS or Unix mode files, and there is no point in wasting time on
+      --  text translation when it is not required.
+
+      Source_File_FD := Open_Read (Name_Buffer'Address, Binary);
+
+      if Source_File_FD = Invalid_FD then
+         Source_File.Decrement_Last;
+         return No_Source_File;
+
+      end if;
+
+      Len := Integer (File_Length (Source_File_FD));
+
+      --  Set Hi so that length is one more than the physical length,
+      --  allowing for the extra EOF character at the end of the buffer
+
+      Hi := Lo + Source_Ptr (Len);
+
+      --  Do the actual read operation
+
+      declare
+         subtype Actual_Source_Buffer is Source_Buffer (Lo .. Hi);
+         --  Physical buffer allocated
+
+         type Actual_Source_Ptr is access Actual_Source_Buffer;
+         --  This is the pointer type for the physical buffer allocated
+
+         Actual_Ptr : Actual_Source_Ptr := new Actual_Source_Buffer;
+         --  And this is the actual physical buffer
+
+      begin
+         --  Allocate source buffer, allowing extra character at end for EOF
+
+         --  Some systems (e.g. VMS) have file types that require one
+         --  read per line, so read until we get the Len bytes or until
+         --  there are no more characters.
+
+         Hi := Lo;
+         loop
+            Actual_Len := Read (Source_File_FD, Actual_Ptr (Hi)'Address, Len);
+            Hi := Hi + Source_Ptr (Actual_Len);
+            exit when Actual_Len = Len or Actual_Len <= 0;
+         end loop;
+
+         Actual_Ptr (Hi) := EOF;
+
+         --  Now we need to work out the proper virtual origin pointer to
+         --  return. This is exactly Actual_Ptr (0)'Address, but we have
+         --  to be careful to suppress checks to compute this address.
+
+         declare
+            pragma Suppress (All_Checks);
+
+            function To_Source_Buffer_Ptr is new
+              Ada.Unchecked_Conversion (Address, Source_Buffer_Ptr);
+
+         begin
+            Src := To_Source_Buffer_Ptr (Actual_Ptr (0)'Address);
+         end;
+      end;
+
+      --  Read is complete, get time stamp and close file and we are done
+
+      Close (Source_File_FD);
+
+      --  Get the file name, without path information
+
+      declare
+         Index : Positive := Path'Last;
+
+      begin
+         while Index > Path'First loop
+            exit when Path (Index - 1) = '/';
+            exit when Path (Index - 1) = Directory_Separator;
+            Index := Index - 1;
+         end loop;
+
+         Name_Len := Path'Last - Index + 1;
+         Name_Buffer (1 .. Name_Len) := Path (Index .. Path'Last);
+         File_Id := Name_Find;
+      end;
+
+      declare
+         S : Source_File_Record renames Source_File.Table (X);
+
+      begin
+         S := (Debug_Source_Name   => Path_Id,
+               File_Name           => File_Id,
+               First_Mapped_Line   => No_Line_Number,
+               Full_File_Name      => Path_Id,
+               Full_Ref_Name       => Path_Id,
+               Identifier_Casing   => Unknown,
+               Instantiation       => No_Location,
+               Keyword_Casing      => Unknown,
+               Last_Source_Line    => 1,
+               License             => Unknown,
+               Lines_Table         => null,
+               Lines_Table_Max     => 1,
+               Logical_Lines_Table => null,
+               Num_SRef_Pragmas    => 0,
+               Reference_Name      => File_Id,
+               Sloc_Adjust         => 0,
+               Source_Checksum     => 0,
+               Source_First        => Lo,
+               Source_Last         => Hi,
+               Source_Text         => Src,
+               Template            => No_Source_File,
+               Time_Stamp          => Empty_Time_Stamp);
+
+         Alloc_Line_Tables (S, Opt.Table_Factor * Alloc.Lines_Initial);
+         S.Lines_Table (1) := Lo;
+      end;
+
+      return X;
+   end Load_Project_File;
+
+   --------------------------------
+   -- Restore_Project_Scan_State --
+   --------------------------------
+
+   procedure Restore_Project_Scan_State
+     (Saved_State : in Saved_Project_Scan_State)
+   is
+   begin
+      Restore_Scan_State (Saved_State.Scan_State);
+      Source              := Saved_State.Source;
+      Current_Source_File := Saved_State.Current_Source_File;
+   end Restore_Project_Scan_State;
+
+   -----------------------------
+   -- Save_Project_Scan_State --
+   -----------------------------
+
+   procedure Save_Project_Scan_State
+     (Saved_State : out Saved_Project_Scan_State)
+   is
+   begin
+      Save_Scan_State (Saved_State.Scan_State);
+      Saved_State.Source              := Source;
+      Saved_State.Current_Source_File := Current_Source_File;
+   end Save_Project_Scan_State;
+
+end Sinput.P;
diff --git a/gcc/ada/sinput-p.ads b/gcc/ada/sinput-p.ads
new file mode 100644
index 00000000000..9292eaba543
--- /dev/null
+++ b/gcc/ada/sinput-p.ads
@@ -0,0 +1,65 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             S I N P U T . P                              --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.3 $
+--                                                                          --
+--          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 child package contains the routines used to actually load a project
+--  file and create entries in the source file table. It also contains two
+--  routines to save and restore a project scan context.
+
+with Scans; use Scans;
+with Types; use Types;
+
+package Sinput.P is
+
+   function Load_Project_File (Path : String) return Source_File_Index;
+   --  Load into memory the source of a project source file.
+   --  Initialize the Scans state.
+
+   type Saved_Project_Scan_State is limited private;
+   --  Used to save project scan state in following two routines
+
+   procedure Save_Project_Scan_State
+     (Saved_State : out Saved_Project_Scan_State);
+   pragma Inline (Save_Project_Scan_State);
+   --  Save the Scans state, as well as the values of
+   --  Source and Current_Source_File.
+
+   procedure Restore_Project_Scan_State
+     (Saved_State : Saved_Project_Scan_State);
+   pragma Inline (Restore_Project_Scan_State);
+   --  Restore the Scans state and the values of
+   --  Source and Current_Source_File.
+
+private
+
+   type Saved_Project_Scan_State is record
+      Scan_State          : Saved_Scan_State;
+      Source              : Source_Buffer_Ptr;
+      Current_Source_File : Source_File_Index;
+   end record;
+
+end Sinput.P;
diff --git a/gcc/ada/sinput.adb b/gcc/ada/sinput.adb
new file mode 100644
index 00000000000..b8612882550
--- /dev/null
+++ b/gcc/ada/sinput.adb
@@ -0,0 +1,1132 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                               S I N P U T                                --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.99 $
+--                                                                          --
+--          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 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). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+pragma Style_Checks (All_Checks);
+--  Subprograms not all in alpha order
+
+with Debug;   use Debug;
+with Namet;   use Namet;
+with Opt;     use Opt;
+with Output;  use Output;
+with Tree_IO; use Tree_IO;
+with System;  use System;
+
+with Unchecked_Conversion;
+with Unchecked_Deallocation;
+
+package body Sinput is
+
+   use ASCII;
+   --  Make control characters visible
+
+   First_Time_Around : Boolean := True;
+
+   ---------------------------
+   -- Add_Line_Tables_Entry --
+   ---------------------------
+
+   procedure Add_Line_Tables_Entry
+     (S : in out Source_File_Record;
+      P : Source_Ptr)
+   is
+      LL : Physical_Line_Number;
+
+   begin
+      --  Reallocate the lines tables if necessary.
+
+      --  Note: the reason we do not use the normal Table package
+      --  mechanism is that we have several of these tables. We could
+      --  use the new GNAT.Dynamic_Tables package and that would probably
+      --  be a good idea ???
+
+      if S.Last_Source_Line = S.Lines_Table_Max then
+         Alloc_Line_Tables
+           (S,
+            Int (S.Last_Source_Line) *
+              ((100 + Alloc.Lines_Increment) / 100));
+
+         if Debug_Flag_D then
+            Write_Str ("--> Reallocating lines table, size = ");
+            Write_Int (Int (S.Lines_Table_Max));
+            Write_Eol;
+         end if;
+      end if;
+
+      S.Last_Source_Line := S.Last_Source_Line + 1;
+      LL := S.Last_Source_Line;
+
+      S.Lines_Table (LL) := P;
+
+      --  Deal with setting new entry in logical lines table if one is
+      --  present. Note that there is always space (because the call to
+      --  Alloc_Line_Tables makes sure both tables are the same length),
+
+      if S.Logical_Lines_Table /= null then
+
+         --  We can always set the entry from the previous one, because
+         --  the processing for a Source_Reference pragma ensures that
+         --  at least one entry following the pragma is set up correctly.
+
+         S.Logical_Lines_Table (LL) := S.Logical_Lines_Table (LL - 1) + 1;
+      end if;
+   end Add_Line_Tables_Entry;
+
+   -----------------------
+   -- Alloc_Line_Tables --
+   -----------------------
+
+   procedure Alloc_Line_Tables
+     (S       : in out Source_File_Record;
+      New_Max : Nat)
+   is
+      function realloc
+        (memblock : Lines_Table_Ptr;
+         size     : size_t)
+         return     Lines_Table_Ptr;
+      pragma Import (C, realloc, "realloc");
+
+      function reallocl
+        (memblock : Logical_Lines_Table_Ptr;
+         size     : size_t)
+         return     Logical_Lines_Table_Ptr;
+      pragma Import (C, reallocl, "realloc");
+
+      function malloc
+        (size   : size_t)
+         return Lines_Table_Ptr;
+      pragma Import (C, malloc, "malloc");
+
+      function mallocl
+        (size   : size_t)
+         return Logical_Lines_Table_Ptr;
+      pragma Import (C, mallocl, "malloc");
+
+      New_Table : Lines_Table_Ptr;
+
+      New_Logical_Table : Logical_Lines_Table_Ptr;
+
+      New_Size : constant size_t :=
+                   size_t (New_Max * Lines_Table_Type'Component_Size /
+                                                             Storage_Unit);
+
+   begin
+      if S.Lines_Table = null then
+         New_Table := malloc (New_Size);
+
+      else
+         New_Table :=
+           realloc (memblock => S.Lines_Table, size => New_Size);
+      end if;
+
+      if New_Table = null then
+         raise Storage_Error;
+      else
+         S.Lines_Table     := New_Table;
+         S.Lines_Table_Max := Physical_Line_Number (New_Max);
+      end if;
+
+      if S.Num_SRef_Pragmas /= 0 then
+         if S.Logical_Lines_Table = null then
+            New_Logical_Table := mallocl (New_Size);
+         else
+            New_Logical_Table :=
+              reallocl (memblock => S.Logical_Lines_Table, size => New_Size);
+         end if;
+
+         if New_Logical_Table = null then
+            raise Storage_Error;
+         else
+            S.Logical_Lines_Table := New_Logical_Table;
+         end if;
+      end if;
+   end Alloc_Line_Tables;
+
+   -----------------
+   -- Backup_Line --
+   -----------------
+
+   procedure Backup_Line (P : in out Source_Ptr) is
+      Sindex : constant Source_File_Index := Get_Source_File_Index (P);
+      Src    : constant Source_Buffer_Ptr :=
+                 Source_File.Table (Sindex).Source_Text;
+      Sfirst : constant Source_Ptr :=
+                 Source_File.Table (Sindex).Source_First;
+
+   begin
+      P := P - 1;
+
+      if P = Sfirst then
+         return;
+      end if;
+
+      if Src (P) = CR then
+         if Src (P - 1) = LF then
+            P := P - 1;
+         end if;
+
+      else -- Src (P) = LF
+         if Src (P - 1) = CR then
+            P := P - 1;
+         end if;
+      end if;
+
+      --  Now find first character of the previous line
+
+      while P > Sfirst
+        and then Src (P - 1) /= LF
+        and then Src (P - 1) /= CR
+      loop
+         P := P - 1;
+      end loop;
+   end Backup_Line;
+
+   ---------------------------
+   -- Build_Location_String --
+   ---------------------------
+
+   procedure Build_Location_String (Loc : Source_Ptr) is
+      Ptr : Source_Ptr;
+
+   begin
+      Name_Len := 0;
+
+      --  Loop through instantiations
+
+      Ptr := Loc;
+      loop
+         Get_Name_String_And_Append
+           (Reference_Name (Get_Source_File_Index (Ptr)));
+         Add_Char_To_Name_Buffer (':');
+         Add_Nat_To_Name_Buffer
+           (Nat (Get_Logical_Line_Number (Ptr)));
+
+         Ptr := Instantiation_Location (Ptr);
+         exit when Ptr = No_Location;
+         Add_Str_To_Name_Buffer (" instantiated at ");
+      end loop;
+
+      Name_Buffer (Name_Len + 1) := NUL;
+      return;
+   end Build_Location_String;
+
+   -----------------------
+   -- Get_Column_Number --
+   -----------------------
+
+   function Get_Column_Number (P : Source_Ptr) return Column_Number is
+      S      : Source_Ptr;
+      C      : Column_Number;
+      Sindex : Source_File_Index;
+      Src    : Source_Buffer_Ptr;
+
+   begin
+      --  If the input source pointer is not a meaningful value then return
+      --  at once with column number 1. This can happen for a file not found
+      --  condition for a file loaded indirectly by RTE, and also perhaps on
+      --  some unknown internal error conditions. In either case we certainly
+      --  don't want to blow up.
+
+      if P < 1 then
+         return 1;
+
+      else
+         Sindex := Get_Source_File_Index (P);
+         Src := Source_File.Table (Sindex).Source_Text;
+         S := Line_Start (P);
+         C := 1;
+
+         while S < P loop
+            if Src (S) = HT then
+               C := (C - 1) / 8 * 8 + (8 + 1);
+            else
+               C := C + 1;
+            end if;
+
+            S := S + 1;
+         end loop;
+
+         return C;
+      end if;
+   end Get_Column_Number;
+
+   -----------------------------
+   -- Get_Logical_Line_Number --
+   -----------------------------
+
+   function Get_Logical_Line_Number
+     (P    : Source_Ptr)
+      return Logical_Line_Number
+   is
+      SFR : Source_File_Record
+              renames Source_File.Table (Get_Source_File_Index (P));
+
+      L : constant Physical_Line_Number := Get_Physical_Line_Number (P);
+
+   begin
+      if SFR.Num_SRef_Pragmas = 0 then
+         return Logical_Line_Number (L);
+      else
+         return SFR.Logical_Lines_Table (L);
+      end if;
+   end Get_Logical_Line_Number;
+
+   ------------------------------
+   -- Get_Physical_Line_Number --
+   ------------------------------
+
+   function Get_Physical_Line_Number
+     (P    : Source_Ptr)
+      return Physical_Line_Number
+   is
+      Sfile : Source_File_Index;
+      Table : Lines_Table_Ptr;
+      Lo    : Physical_Line_Number;
+      Hi    : Physical_Line_Number;
+      Mid   : Physical_Line_Number;
+      Loc   : Source_Ptr;
+
+   begin
+      --  If the input source pointer is not a meaningful value then return
+      --  at once with line number 1. This can happen for a file not found
+      --  condition for a file loaded indirectly by RTE, and also perhaps on
+      --  some unknown internal error conditions. In either case we certainly
+      --  don't want to blow up.
+
+      if P < 1 then
+         return 1;
+
+      --  Otherwise we can do the binary search
+
+      else
+         Sfile := Get_Source_File_Index (P);
+         Loc   := P + Source_File.Table (Sfile).Sloc_Adjust;
+         Table := Source_File.Table (Sfile).Lines_Table;
+         Lo    := 1;
+         Hi    := Source_File.Table (Sfile).Last_Source_Line;
+
+         loop
+            Mid := (Lo + Hi) / 2;
+
+            if Loc < Table (Mid) then
+               Hi := Mid - 1;
+
+            else -- Loc >= Table (Mid)
+
+               if Mid = Hi or else
+                  Loc < Table (Mid + 1)
+               then
+                  return Mid;
+               else
+                  Lo := Mid + 1;
+               end if;
+
+            end if;
+
+         end loop;
+      end if;
+   end Get_Physical_Line_Number;
+
+   ---------------------------
+   -- Get_Source_File_Index --
+   ---------------------------
+
+   Source_Cache_First : Source_Ptr := 1;
+   Source_Cache_Last  : Source_Ptr := 0;
+   --  Records the First and Last subscript values for the most recently
+   --  referenced entry in the source table, to optimize the common case
+   --  of repeated references to the same entry. The initial values force
+   --  an initial search to set the cache value.
+
+   Source_Cache_Index : Source_File_Index := No_Source_File;
+   --  Contains the index of the entry corresponding to Source_Cache
+
+   function Get_Source_File_Index
+     (S    : Source_Ptr)
+      return Source_File_Index
+   is
+   begin
+      if S in Source_Cache_First .. Source_Cache_Last then
+         return Source_Cache_Index;
+
+      else
+         for J in 1 .. Source_File.Last loop
+            if S in Source_File.Table (J).Source_First ..
+                    Source_File.Table (J).Source_Last
+            then
+               Source_Cache_Index := J;
+               Source_Cache_First :=
+                 Source_File.Table (Source_Cache_Index).Source_First;
+               Source_Cache_Last :=
+                 Source_File.Table (Source_Cache_Index).Source_Last;
+               return Source_Cache_Index;
+            end if;
+         end loop;
+      end if;
+
+      --  We must find a matching entry in the above loop!
+
+      raise Program_Error;
+   end Get_Source_File_Index;
+
+   ----------------
+   -- Initialize --
+   ----------------
+
+   procedure Initialize is
+   begin
+      Source_File.Init;
+   end Initialize;
+
+   -------------------------
+   -- Instantiation_Depth --
+   -------------------------
+
+   function Instantiation_Depth (S : Source_Ptr) return Nat is
+      Sind  : Source_File_Index;
+      Sval  : Source_Ptr;
+      Depth : Nat;
+
+   begin
+      Sval := S;
+      Depth := 0;
+
+      loop
+         Sind := Get_Source_File_Index (Sval);
+         Sval := Instantiation (Sind);
+         exit when Sval = No_Location;
+         Depth := Depth + 1;
+      end loop;
+
+      return Depth;
+   end Instantiation_Depth;
+
+   ----------------------------
+   -- Instantiation_Location --
+   ----------------------------
+
+   function Instantiation_Location (S : Source_Ptr) return Source_Ptr is
+   begin
+      return Instantiation (Get_Source_File_Index (S));
+   end Instantiation_Location;
+
+   ----------------------
+   -- Last_Source_File --
+   ----------------------
+
+   function Last_Source_File return Source_File_Index is
+   begin
+      return Source_File.Last;
+   end Last_Source_File;
+
+   ----------------
+   -- Line_Start --
+   ----------------
+
+   function Line_Start (P : Source_Ptr) return Source_Ptr is
+      Sindex : constant Source_File_Index := Get_Source_File_Index (P);
+      Src    : constant Source_Buffer_Ptr :=
+                 Source_File.Table (Sindex).Source_Text;
+      Sfirst : constant Source_Ptr :=
+                 Source_File.Table (Sindex).Source_First;
+      S      : Source_Ptr;
+
+   begin
+      S := P;
+
+      while S > Sfirst
+        and then Src (S - 1) /= CR
+        and then Src (S - 1) /= LF
+      loop
+         S := S - 1;
+      end loop;
+
+      return S;
+   end Line_Start;
+
+   function Line_Start
+     (L    : Physical_Line_Number;
+      S    : Source_File_Index)
+      return Source_Ptr
+   is
+   begin
+      return Source_File.Table (S).Lines_Table (L);
+   end Line_Start;
+
+   ----------
+   -- Lock --
+   ----------
+
+   procedure Lock is
+   begin
+      Source_File.Locked := True;
+      Source_File.Release;
+   end Lock;
+
+   ----------------------
+   -- Num_Source_Files --
+   ----------------------
+
+   function Num_Source_Files return Nat is
+   begin
+      return Int (Source_File.Last) - Int (Source_File.First) + 1;
+   end Num_Source_Files;
+
+   ----------------------
+   -- Num_Source_Lines --
+   ----------------------
+
+   function Num_Source_Lines (S : Source_File_Index) return Nat is
+   begin
+      return Nat (Source_File.Table (S).Last_Source_Line);
+   end Num_Source_Lines;
+
+   -----------------------
+   -- Original_Location --
+   -----------------------
+
+   function Original_Location (S : Source_Ptr) return Source_Ptr is
+      Sindex : Source_File_Index;
+      Tindex : Source_File_Index;
+
+   begin
+      if S <= No_Location then
+         return S;
+
+      else
+         Sindex := Get_Source_File_Index (S);
+
+         if Instantiation (Sindex) = No_Location then
+            return S;
+
+         else
+            Tindex := Template (Sindex);
+            while Instantiation (Tindex) /= No_Location loop
+               Tindex := Template (Tindex);
+            end loop;
+
+            return S - Source_First (Sindex) + Source_First (Tindex);
+         end if;
+      end if;
+   end Original_Location;
+
+   -------------------------
+   -- Physical_To_Logical --
+   -------------------------
+
+   function Physical_To_Logical
+     (Line : Physical_Line_Number;
+      S    : Source_File_Index)
+      return Logical_Line_Number
+   is
+      SFR : Source_File_Record renames Source_File.Table (S);
+
+   begin
+      if SFR.Num_SRef_Pragmas = 0 then
+         return Logical_Line_Number (Line);
+      else
+         return SFR.Logical_Lines_Table (Line);
+      end if;
+   end Physical_To_Logical;
+
+   --------------------------------
+   -- Register_Source_Ref_Pragma --
+   --------------------------------
+
+   procedure Register_Source_Ref_Pragma
+     (File_Name          : Name_Id;
+      Stripped_File_Name : Name_Id;
+      Mapped_Line        : Nat;
+      Line_After_Pragma  : Physical_Line_Number)
+   is
+      SFR : Source_File_Record renames Source_File.Table (Current_Source_File);
+
+      function malloc
+        (size     : size_t)
+         return     Logical_Lines_Table_Ptr;
+      pragma Import (C, malloc);
+
+      ML : Logical_Line_Number;
+
+   begin
+      if File_Name /= No_Name then
+         SFR.Full_Ref_Name := File_Name;
+
+         if not Debug_Generated_Code then
+            SFR.Debug_Source_Name := File_Name;
+         end if;
+
+         SFR.Reference_Name   := Stripped_File_Name;
+         SFR.Num_SRef_Pragmas := SFR.Num_SRef_Pragmas + 1;
+      end if;
+
+      if SFR.Num_SRef_Pragmas = 1 then
+         SFR.First_Mapped_Line := Logical_Line_Number (Mapped_Line);
+      end if;
+
+      if SFR.Logical_Lines_Table = null then
+         SFR.Logical_Lines_Table :=
+           malloc
+             (size_t (SFR.Lines_Table_Max *
+                        Logical_Lines_Table_Type'Component_Size /
+                                                        Storage_Unit));
+      end if;
+
+      SFR.Logical_Lines_Table (Line_After_Pragma - 1) := No_Line_Number;
+
+      ML := Logical_Line_Number (Mapped_Line);
+      for J in Line_After_Pragma .. SFR.Last_Source_Line loop
+         SFR.Logical_Lines_Table (J) := ML;
+         ML := ML + 1;
+      end loop;
+   end Register_Source_Ref_Pragma;
+
+   ---------------------------
+   -- Skip_Line_Terminators --
+   ---------------------------
+
+   --  There are two distinct concepts of line terminator in GNAT
+
+   --    A logical line terminator is what corresponds to the "end of a line"
+   --    as described in RM 2.2 (13). Any of the characters FF, LF, CR or VT
+   --    acts as an end of logical line in this sense, and it is essentially
+   --    irrelevant whether one or more appears in sequence (since if a
+   --    sequence of such characters is regarded as separate ends of line,
+   --    then the intervening logical lines are null in any case).
+
+   --    A physical line terminator is a sequence of format effectors that
+   --    is treated as ending a physical line. Physical lines have no Ada
+   --    semantic significance, but they are significant for error reporting
+   --    purposes, since errors are identified by line and column location.
+
+   --  In GNAT, a physical line is ended by any of the sequences LF, CR/LF,
+   --  CR or LF/CR. LF is used in typical Unix systems, CR/LF in DOS systems,
+   --  and CR alone in System 7. We don't know of any system using LF/CR, but
+   --  it seems reasonable to include this case for consistency. In addition,
+   --  we recognize any of these sequences in any of the operating systems,
+   --  for better behavior in treating foreign files (e.g. a Unix file with
+   --  LF terminators transferred to a DOS system).
+
+   procedure Skip_Line_Terminators
+     (P        : in out Source_Ptr;
+      Physical : out Boolean)
+   is
+   begin
+      pragma Assert (Source (P) in Line_Terminator);
+
+      if Source (P) = CR then
+         if Source (P + 1) = LF then
+            P := P + 2;
+         else
+            P := P + 1;
+         end if;
+
+      elsif Source (P) = LF then
+         if Source (P + 1) = CR then
+            P := P + 2;
+         else
+            P := P + 1;
+         end if;
+
+      else -- Source (P) = FF or else Source (P) = VT
+         P := P + 1;
+         Physical := False;
+         return;
+      end if;
+
+      --  Fall through in the physical line terminator case. First deal with
+      --  making a possible entry into the lines table if one is needed.
+
+      --  Note: we are dealing with a real source file here, this cannot be
+      --  the instantiation case, so we need not worry about Sloc adjustment.
+
+      declare
+         S : Source_File_Record
+               renames Source_File.Table (Current_Source_File);
+
+      begin
+         Physical := True;
+
+         --  Make entry in lines table if not already made (in some scan backup
+         --  cases, we will be rescanning previously scanned source, so the
+         --  entry may have already been made on the previous forward scan).
+
+         if Source (P) /= EOF
+           and then P > S.Lines_Table (S.Last_Source_Line)
+         then
+            Add_Line_Tables_Entry (S, P);
+         end if;
+      end;
+   end Skip_Line_Terminators;
+
+   -------------------
+   -- Source_Offset --
+   -------------------
+
+   function Source_Offset (S : Source_Ptr) return Nat is
+      Sindex : constant Source_File_Index := Get_Source_File_Index (S);
+      Sfirst : constant Source_Ptr :=
+                 Source_File.Table (Sindex).Source_First;
+
+   begin
+      return Nat (S - Sfirst);
+   end Source_Offset;
+
+   ------------------------
+   -- Top_Level_Location --
+   ------------------------
+
+   function Top_Level_Location (S : Source_Ptr) return Source_Ptr is
+      Oldloc : Source_Ptr;
+      Newloc : Source_Ptr;
+
+   begin
+      Newloc := S;
+      loop
+         Oldloc := Newloc;
+         Newloc := Instantiation_Location (Oldloc);
+         exit when Newloc = No_Location;
+      end loop;
+
+      return Oldloc;
+   end Top_Level_Location;
+
+   ---------------
+   -- Tree_Read --
+   ---------------
+
+   procedure Tree_Read is
+   begin
+      --  First we must free any old source buffer pointers
+
+      if not First_Time_Around then
+         for J in Source_File.First .. Source_File.Last loop
+            declare
+               S : Source_File_Record renames Source_File.Table (J);
+
+               procedure Free_Ptr is new Unchecked_Deallocation
+                 (Big_Source_Buffer, Source_Buffer_Ptr);
+
+               --  Note: we are using free here, because we used malloc
+               --  or realloc directly to allocate the tables. That is
+               --  because we were playing the big array trick.
+
+               procedure free (X : Lines_Table_Ptr);
+               pragma Import (C, free, "free");
+
+               procedure freel (X : Logical_Lines_Table_Ptr);
+               pragma Import (C, freel, "free");
+
+               function To_Source_Buffer_Ptr is new
+                 Unchecked_Conversion (Address, Source_Buffer_Ptr);
+
+               Tmp1 : Source_Buffer_Ptr;
+
+            begin
+               if S.Instantiation /= No_Location then
+                  null;
+
+               else
+                  --  We have to recreate a proper pointer to the actual array
+                  --  from the zero origin pointer stored in the source table.
+
+                  Tmp1 :=
+                    To_Source_Buffer_Ptr
+                      (S.Source_Text (S.Source_First)'Address);
+                  Free_Ptr (Tmp1);
+
+                  if S.Lines_Table /= null then
+                     free (S.Lines_Table);
+                     S.Lines_Table := null;
+                  end if;
+
+                  if S.Logical_Lines_Table /= null then
+                     freel (S.Logical_Lines_Table);
+                     S.Logical_Lines_Table := null;
+                  end if;
+               end if;
+            end;
+         end loop;
+      end if;
+
+      --  Reset source cache pointers to force new read
+
+      Source_Cache_First := 1;
+      Source_Cache_Last  := 0;
+
+      --  Read in source file table
+
+      Source_File.Tree_Read;
+
+      --  The pointers we read in there for the source buffer and lines
+      --  table pointers are junk. We now read in the actual data that
+      --  is referenced by these two fields.
+
+      for J in Source_File.First .. Source_File.Last loop
+         declare
+            S : Source_File_Record renames Source_File.Table (J);
+
+         begin
+            --  For the instantiation case, we do not read in any data. Instead
+            --  we share the data for the generic template entry. Since the
+            --  template always occurs first, we can safetly refer to its data.
+
+            if S.Instantiation /= No_Location then
+               declare
+                  ST : Source_File_Record renames
+                         Source_File.Table (S.Template);
+
+               begin
+                  --  The lines tables are copied from the template entry
+
+                  S.Lines_Table :=
+                    Source_File.Table (S.Template).Lines_Table;
+                  S.Logical_Lines_Table :=
+                    Source_File.Table (S.Template).Logical_Lines_Table;
+
+                  --  In the case of the source table pointer, we share the
+                  --  same data as the generic template, but the virtual origin
+                  --  is adjusted. For example, if the first subscript of the
+                  --  template is 100, and that of the instantiation is 200,
+                  --  then the instantiation pointer is obtained by subtracting
+                  --  100 from the template pointer.
+
+                  declare
+                     pragma Suppress (All_Checks);
+
+                     function To_Source_Buffer_Ptr is new
+                       Unchecked_Conversion (Address, Source_Buffer_Ptr);
+
+                  begin
+                     S.Source_Text :=
+                       To_Source_Buffer_Ptr
+                          (ST.Source_Text
+                            (ST.Source_First - S.Source_First)'Address);
+                  end;
+               end;
+
+            --  Normal case (non-instantiation)
+
+            else
+               First_Time_Around := False;
+               S.Lines_Table := null;
+               S.Logical_Lines_Table := null;
+               Alloc_Line_Tables (S, Int (S.Last_Source_Line));
+
+               for J in 1 .. S.Last_Source_Line loop
+                  Tree_Read_Int (Int (S.Lines_Table (J)));
+               end loop;
+
+               if S.Num_SRef_Pragmas /= 0 then
+                  for J in 1 .. S.Last_Source_Line loop
+                     Tree_Read_Int (Int (S.Logical_Lines_Table (J)));
+                  end loop;
+               end if;
+
+               --  Allocate source buffer and read in the data and then set the
+               --  virtual origin to point to the logical zero'th element. This
+               --  address must be computed with subscript checks turned off.
+
+               declare
+                  subtype B is Text_Buffer (S.Source_First .. S.Source_Last);
+                  type Text_Buffer_Ptr is access B;
+                  T : Text_Buffer_Ptr;
+
+                  pragma Suppress (All_Checks);
+
+                  function To_Source_Buffer_Ptr is new
+                    Unchecked_Conversion (Address, Source_Buffer_Ptr);
+
+               begin
+                  T := new B;
+
+                  Tree_Read_Data (T (S.Source_First)'Address,
+                     Int (S.Source_Last) - Int (S.Source_First) + 1);
+
+                  S.Source_Text := To_Source_Buffer_Ptr (T (0)'Address);
+               end;
+            end if;
+         end;
+      end loop;
+   end Tree_Read;
+
+   ----------------
+   -- Tree_Write --
+   ----------------
+
+   procedure Tree_Write is
+   begin
+      Source_File.Tree_Write;
+
+      --  The pointers we wrote out there for the source buffer and lines
+      --  table pointers are junk, we now write out the actual data that
+      --  is referenced by these two fields.
+
+      for J in Source_File.First .. Source_File.Last loop
+         declare
+            S : Source_File_Record renames Source_File.Table (J);
+
+         begin
+            --  For instantiations, there is nothing to do, since the data is
+            --  shared with the generic template. When the tree is read, the
+            --  pointers must be set, but no extra data needs to be written.
+
+            if S.Instantiation /= No_Location then
+               null;
+
+            --  For the normal case, write out the data of the tables
+
+            else
+               --  Lines table
+
+               for J in 1 .. S.Last_Source_Line loop
+                  Tree_Write_Int (Int (S.Lines_Table (J)));
+               end loop;
+
+               --  Logical lines table if present
+
+               if S.Num_SRef_Pragmas /= 0 then
+                  for J in 1 .. S.Last_Source_Line loop
+                     Tree_Write_Int (Int (S.Logical_Lines_Table (J)));
+                  end loop;
+               end if;
+
+               --  Source buffer
+
+               Tree_Write_Data
+                 (S.Source_Text (S.Source_First)'Address,
+                   Int (S.Source_Last) - Int (S.Source_First) + 1);
+            end if;
+         end;
+      end loop;
+   end Tree_Write;
+
+   --------------------
+   -- Write_Location --
+   --------------------
+
+   procedure Write_Location (P : Source_Ptr) is
+   begin
+      if P = No_Location then
+         Write_Str ("<no location>");
+
+      elsif P <= Standard_Location then
+         Write_Str ("<standard location>");
+
+      else
+         declare
+            SI : constant Source_File_Index := Get_Source_File_Index (P);
+
+         begin
+            Write_Name (Debug_Source_Name (SI));
+            Write_Char (':');
+            Write_Int (Int (Get_Logical_Line_Number (P)));
+            Write_Char (':');
+            Write_Int (Int (Get_Column_Number (P)));
+
+            if Instantiation (SI) /= No_Location then
+               Write_Str (" [");
+               Write_Location (Instantiation (SI));
+               Write_Char (']');
+            end if;
+         end;
+      end if;
+   end Write_Location;
+
+   ----------------------
+   -- Write_Time_Stamp --
+   ----------------------
+
+   procedure Write_Time_Stamp (S : Source_File_Index) is
+      T : constant Time_Stamp_Type := Time_Stamp (S);
+      P : Natural;
+
+   begin
+      if T (1) = '9' then
+         Write_Str ("19");
+         P := 0;
+      else
+         Write_Char (T (1));
+         Write_Char (T (2));
+         P := 2;
+      end if;
+
+      Write_Char (T (P + 1));
+      Write_Char (T (P + 2));
+      Write_Char ('-');
+
+      Write_Char (T (P + 3));
+      Write_Char (T (P + 4));
+      Write_Char ('-');
+
+      Write_Char (T (P + 5));
+      Write_Char (T (P + 6));
+      Write_Char (' ');
+
+      Write_Char (T (P + 7));
+      Write_Char (T (P + 8));
+      Write_Char (':');
+
+      Write_Char (T (P + 9));
+      Write_Char (T (P + 10));
+      Write_Char (':');
+
+      Write_Char (T (P + 11));
+      Write_Char (T (P + 12));
+   end Write_Time_Stamp;
+
+   ----------------------------------------------
+   -- Access Subprograms for Source File Table --
+   ----------------------------------------------
+
+   function Debug_Source_Name (S : SFI) return File_Name_Type is
+   begin
+      return Source_File.Table (S).Debug_Source_Name;
+   end Debug_Source_Name;
+
+   function File_Name (S : SFI) return File_Name_Type is
+   begin
+      return Source_File.Table (S).File_Name;
+   end File_Name;
+
+   function First_Mapped_Line (S : SFI) return Logical_Line_Number is
+   begin
+      return Source_File.Table (S).First_Mapped_Line;
+   end First_Mapped_Line;
+
+   function Full_File_Name (S : SFI) return File_Name_Type is
+   begin
+      return Source_File.Table (S).Full_File_Name;
+   end Full_File_Name;
+
+   function Full_Ref_Name (S : SFI) return File_Name_Type is
+   begin
+      return Source_File.Table (S).Full_Ref_Name;
+   end Full_Ref_Name;
+
+   function Identifier_Casing (S : SFI) return Casing_Type is
+   begin
+      return Source_File.Table (S).Identifier_Casing;
+   end Identifier_Casing;
+
+   function Instantiation (S : SFI) return Source_Ptr is
+   begin
+      return Source_File.Table (S).Instantiation;
+   end Instantiation;
+
+   function Keyword_Casing (S : SFI) return Casing_Type is
+   begin
+      return Source_File.Table (S).Keyword_Casing;
+   end Keyword_Casing;
+
+   function Last_Source_Line (S : SFI) return Physical_Line_Number is
+   begin
+      return Source_File.Table (S).Last_Source_Line;
+   end Last_Source_Line;
+
+   function License (S : SFI) return License_Type is
+   begin
+      return Source_File.Table (S).License;
+   end License;
+
+   function Num_SRef_Pragmas (S : SFI) return Nat is
+   begin
+      return Source_File.Table (S).Num_SRef_Pragmas;
+   end Num_SRef_Pragmas;
+
+   function Reference_Name (S : SFI) return File_Name_Type is
+   begin
+      return Source_File.Table (S).Reference_Name;
+   end Reference_Name;
+
+   function Source_Checksum (S : SFI) return Word is
+   begin
+      return Source_File.Table (S).Source_Checksum;
+   end Source_Checksum;
+
+   function Source_First (S : SFI) return Source_Ptr is
+   begin
+      return Source_File.Table (S).Source_First;
+   end Source_First;
+
+   function Source_Last (S : SFI) return Source_Ptr is
+   begin
+      return Source_File.Table (S).Source_Last;
+   end Source_Last;
+
+   function Source_Text (S : SFI) return Source_Buffer_Ptr is
+   begin
+      return Source_File.Table (S).Source_Text;
+   end Source_Text;
+
+   function Template (S : SFI) return SFI is
+   begin
+      return Source_File.Table (S).Template;
+   end Template;
+
+   function Time_Stamp (S : SFI) return Time_Stamp_Type is
+   begin
+      return Source_File.Table (S).Time_Stamp;
+   end Time_Stamp;
+
+   ------------------------------------------
+   -- Set Procedures for Source File Table --
+   ------------------------------------------
+
+   procedure Set_Identifier_Casing (S : SFI; C : Casing_Type) is
+   begin
+      Source_File.Table (S).Identifier_Casing := C;
+   end Set_Identifier_Casing;
+
+   procedure Set_Keyword_Casing (S : SFI; C : Casing_Type) is
+   begin
+      Source_File.Table (S).Keyword_Casing := C;
+   end Set_Keyword_Casing;
+
+   procedure Set_License (S : SFI; L : License_Type) is
+   begin
+      Source_File.Table (S).License := L;
+   end Set_License;
+
+   --------
+   -- wl --
+   --------
+
+   procedure wl (P : Source_Ptr) is
+   begin
+      Write_Location (P);
+      Write_Eol;
+   end wl;
+
+end Sinput;
diff --git a/gcc/ada/sinput.ads b/gcc/ada/sinput.ads
new file mode 100644
index 00000000000..585a8b95ea0
--- /dev/null
+++ b/gcc/ada/sinput.ads
@@ -0,0 +1,650 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                               S I N P U T                                --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.69 $
+--                                                                          --
+--          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 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 input routines used for reading the
+--  input source file. The actual I/O routines are in OS_Interface,
+--  with this module containing only the system independent processing.
+
+--  General Note: throughout the compiler, we use the term line or source
+--  line to refer to a physical line in the source, terminated by the end of
+--  physical line sequence. See Skip_Line_Terminators procedure for a full
+--  description of the difference between logical and physical lines.
+
+with Alloc;
+with Casing; use Casing;
+with Table;
+with Types;  use Types;
+
+package Sinput is
+
+   ----------------------------
+   -- Source License Control --
+   ----------------------------
+
+   --  The following type indicates the license state of a source if it
+   --  is known.
+
+   type License_Type is
+     (Unknown,
+      --  Licensing status of this source unit is unknown
+
+      Restricted,
+      --  This is a non-GPL'ed unit that is restricted from depending
+      --  on GPL'ed units (e.g. proprietary code is in this category)
+
+      GPL,
+      --  This file is licensed under the unmodified GPL. It is not allowed
+      --  to depend on Non_GPL units, and Non_GPL units may not depend on
+      --  this source unit.
+
+      Modified_GPL,
+      --  This file is licensed under the GNAT modified GPL (see header of
+      --  This file for wording of the modification). It may depend on other
+      --  Modified_GPL units or on unrestricted units.
+
+      Unrestricted);
+      --  The license on this file is permitted to depend on any other
+      --  units, or have other units depend on it, without violating the
+      --  license of this unit. Examples are public domain units, and
+      --  units defined in the RM).
+
+   --  The above license status is checked when the appropriate check is
+   --  activated and one source depends on another, and the licensing state
+   --  of both files is known:
+
+   --  The prohibited combinations are:
+
+   --    Restricted file may not depend on GPL file
+
+   --    GPL file may not depend on Restricted file
+
+   --    Modified GPL file may not depend on Restricted file
+   --    Modified_GPL file may not depend on GPL file
+
+   --  The reason for the last restriction here is that a client depending
+   --  on a modified GPL file must be sure that the license condition is
+   --  correct considered transitively.
+
+   --  The licensing status is determined either by the presence of a
+   --  specific pragma License, or by scanning the header for a predefined
+   --  file, or any file if compiling in -gnatg mode.
+
+   -----------------------
+   -- Source File Table --
+   -----------------------
+
+   --  The source file table has an entry for each source file read in for
+   --  this run of the compiler. This table is (default) initialized when
+   --  the compiler is loaded, and simply accumulates entries as compilation
+   --  proceeds and the Sinput.L.Load_Source_File procedure is called to load
+   --  required source files.
+
+   --  Virtual entries are also created for generic templates when they are
+   --  instantiated, as described in a separate section later on.
+
+   --  In the case where there are multiple main units (e.g. in the case of
+   --  the cross-reference tool), this table is not reset between these units,
+   --  so that a given source file is only read once if it is used by two
+   --  separate main units.
+
+   --  The entries in the table are accessed using a Source_File_Index that
+   --  ranges from 1 to Last_Source_File. Each entry has the following fields
+
+   --  Note that entry 1 is always for system.ads (see Targparm for details
+   --  of why we always read this source file first), and we have defined a
+   --  constant Types.System_Source_File_Index as 1 to reflect this fact.
+
+   --  File_Name : File_Name_Type
+   --    Name of the source file (simple name with no directory information).
+   --    Set by Sinput.L.Load_Source_File and cannot be subequently changed.
+
+   --  Full_File_Name : File_Name_Type
+   --    Full file name (full name with directory info), used for generation
+   --    of error messages, etc. Set by Sinput.L.Load_Source_File and cannot
+   --    be subsequently changed.
+
+   --  Reference_Name : File_Name_Type
+   --    Name to be used for source file references in error messages where
+   --    only the simple name of the file is required. Identical to File_Name
+   --    unless pragma Source_Reference is used to change it. Only processing
+   --    for the Source_Reference pragma circuit may set this field.
+
+   --  Full_Ref_Name : File_Name_Type
+   --    Name to be used for source file references in error messages where
+   --    the full name of the file is required. Identical to Full_File_Name
+   --    unless pragma Source_Reference is used to change it. Only processing
+   --    for the Source_Reference pragma may set this field.
+
+   --  Debug_Source_Name : File_Name_Type
+   --    Name to be used for source file references in debugging information
+   --    where only the simple name of the file is required. Identical to
+   --    Full_Ref_Name unless the -gnatD (debug source file) switch is used.
+   --    Only processing in Sprint that generates this file is permitted to
+   --    set this field.
+
+   --  License : License_Type;
+   --    License status of source file
+
+   --  Num_SRef_Pragmas : Nat;
+   --    Number of source reference pragmas present in source file
+
+   --  First_Mapped_Line : Logical_Line_Number;
+   --    This field stores logical line number of the first line in the
+   --    file that is not a Source_Reference pragma. If no source reference
+   --    pragmas are used, then the value is set to No_Line_Number.
+
+   --  Source_Text : Source_Buffer_Ptr
+   --    Text of source file. Note that every source file has a distinct set
+   --    of non-overlapping logical bounds, so it is possible to determine
+   --    which file is referenced from a given subscript (Source_Ptr) value.
+   --    Set by Sinput.L.Load_Source_File and cannot be subsequently changed.
+
+   --  Source_First : Source_Ptr;
+   --    Subscript of first character in Source_Text. Note that this cannot
+   --    be obtained as Source_Text'First, because we use virtual origin
+   --    addressing. Set by Sinput.L procedures when the entry is first
+   --    created and never subsequently changed.
+
+   --  Source_Last : Source_Ptr;
+   --    Subscript of last character in Source_Text. Note that this cannot
+   --    be obtained as Source_Text'Last, because we use virtual origin
+   --    addressing, so this value is always Source_Ptr'Last. Set by
+   --    Sinput.L procedures when the entry is first created and never
+   --    subsequently changed.
+
+   --  Time_Stamp : Time_Stamp_Type;
+   --    Time stamp of the source file. Set by Sinput.L.Load_Source_File,
+   --    and cannot be subsequently changed.
+
+   --  Source_Checksum : Word;
+   --    Computed checksum for contents of source file. See separate section
+   --    later on in this spec for a description of the checksum algorithm.
+
+   --  Last_Source_Line : Physical_Line_Number;
+   --    Physical line number of last source line. Whlie a file is being
+   --    read, this refers to the last line scanned. Once a file has been
+   --    completely scanned, it is the number of the last line in the file,
+   --    and hence also gives the number of source lines in the file.
+
+   --  Keyword_Casing : Casing_Type;
+   --    Casing style used in file for keyword casing. This is initialized
+   --    to Unknown, and then set from the first occurrence of a keyword.
+   --    This value is used only for formatting of error messages.
+
+   --  Identifier_Casing : Casing_Type;
+   --    Casing style used in file for identifier casing. This is initialized
+   --    to Unknown, and then set from an identifier in the program as soon as
+   --    one is found whose casing is sufficiently clear to make a decision.
+   --    This value is used for formatting of error messages, and also is used
+   --    in the detection of keywords misused as identifiers.
+
+   --  Instantiation : Source_Ptr;
+   --    Source file location of the instantiation if this source file entry
+   --    represents a generic instantiation. Set to No_Location for the case
+   --    of a normal non-instantiation entry. See section below for details.
+   --    This field is read-only for clients.
+
+   --  Template : Source_File_Index;
+   --    Source file index of the source file containing the template if this
+   --    is a generic instantiation. Set to No_Source_File for the normal case
+   --    of a non-instantiation entry. See Sinput-L for details. This field is
+   --    read-only for clients.
+
+   --  The source file table is accessed by clients using the following
+   --  subprogram interface:
+
+   subtype SFI is Source_File_Index;
+
+   function Debug_Source_Name (S : SFI) return File_Name_Type;
+   function File_Name         (S : SFI) return File_Name_Type;
+   function First_Mapped_Line (S : SFI) return Logical_Line_Number;
+   function Full_File_Name    (S : SFI) return File_Name_Type;
+   function Full_Ref_Name     (S : SFI) return File_Name_Type;
+   function Identifier_Casing (S : SFI) return Casing_Type;
+   function Instantiation     (S : SFI) return Source_Ptr;
+   function Keyword_Casing    (S : SFI) return Casing_Type;
+   function Last_Source_Line  (S : SFI) return Physical_Line_Number;
+   function License           (S : SFI) return License_Type;
+   function Num_SRef_Pragmas  (S : SFI) return Nat;
+   function Reference_Name    (S : SFI) return File_Name_Type;
+   function Source_Checksum   (S : SFI) return Word;
+   function Source_First      (S : SFI) return Source_Ptr;
+   function Source_Last       (S : SFI) return Source_Ptr;
+   function Source_Text       (S : SFI) return Source_Buffer_Ptr;
+   function Template          (S : SFI) return Source_File_Index;
+   function Time_Stamp        (S : SFI) return Time_Stamp_Type;
+
+   procedure Set_Keyword_Casing    (S : SFI; C : Casing_Type);
+   procedure Set_Identifier_Casing (S : SFI; C : Casing_Type);
+   procedure Set_License           (S : SFI; L : License_Type);
+
+   function Last_Source_File return Source_File_Index;
+   --  Index of last source file table entry
+
+   function Num_Source_Files return Nat;
+   --  Number of source file table entries
+
+   procedure Initialize;
+   --  Initialize internal tables
+
+   procedure Lock;
+   --  Lock internal tables
+
+   Main_Source_File : Source_File_Index;
+   --  This is set to the source file index of the main unit
+
+   -----------------------
+   -- Checksum Handling --
+   -----------------------
+
+   --  As a source file is scanned, a checksum is computed by taking all the
+   --  non-blank characters in the file, excluding comment characters, the
+   --  minus-minus sequence starting a comment, and all control characters
+   --  except ESC.
+
+   --  These characters are used to compute a 31-bit checksum which is stored
+   --  in the variable Scans.Checksum, as follows:
+
+   --    If a character, C, is not part of a wide character sequence, then
+   --    either the character itself, or its lower case equivalent if it
+   --    is a letter outside a string literal is used in the computation:
+
+   --      Checksum := Checksum + Checksum + Character'Pos (C);
+   --      if Checksum > 16#8000_0000# then
+   --         Checksum := (Checksum + 1) and 16#7FFF_FFFF#;
+   --      end if;
+
+   --    For a wide character sequence, the checksum is computed using the
+   --    corresponding character code value C, as follows:
+
+   --      Checksum := Checksum + Checksum + Char_Code'Pos (C);
+   --      if Checksum > 16#8000_0000# then
+   --         Checksum := (Checksum + 1) and 16#7FFF_FFFF#;
+   --      end if;
+
+   --  This algorithm ensures that the checksum includes all semantically
+   --  significant aspects of the program represented by the source file,
+   --  but is insensitive to layout, presence or contents of comments, wide
+   --  character representation method, or casing conventions outside strings.
+
+   --  Scans.Checksum is initialized to zero at the start of scanning a file,
+   --  and copied into the Source_Checksum field of the file table entry when
+   --  the end of file is encountered.
+
+   -------------------------------------
+   -- Handling Generic Instantiations --
+   -------------------------------------
+
+   --  As described in Sem_Ch12, a generic instantiation involves making a
+   --  copy of the tree of the generic template. The source locations in
+   --  this tree directly reference the source of the template. However it
+   --  is also possible to find the location of the instantiation.
+
+   --  This is achieved as follows. When an instantiation occurs, a new entry
+   --  is made in the source file table. This entry points to the same source
+   --  text, i.e. the file that contains the instantiation, but has a distinct
+   --  set of Source_Ptr index values. The separate range of Sloc values avoids
+   --  confusion, and means that the Sloc values can still be used to uniquely
+   --  identify the source file table entry. It is possible for both entries
+   --  to point to the same text, because of the virtual origin pointers used
+   --  in the source table.
+
+   --  The Instantiation field of this source file index entry, usually set
+   --  to No_Source_File, instead contains the Sloc of the instantiation. In
+   --  the case of nested instantiations, this Sloc may itself refer to an
+   --  instantiation, so the complete chain can be traced.
+
+   --  Two routines are used to build these special entries in the source
+   --  file table. Create_Instantiation_Source is first called to build
+   --  the virtual source table entry for the instantiation, and then the
+   --  Sloc values in the copy are adjusted using Adjust_Instantiation_Sloc.
+   --  See child unit Sinput.L for details on these two routines.
+
+   -----------------
+   -- Global Data --
+   -----------------
+
+   Current_Source_File : Source_File_Index;
+   --  Source_File table index of source file currently being scanned
+
+   Current_Source_Unit : Unit_Number_Type;
+   --  Unit number of source file currently being scanned. The special value
+   --  of No_Unit indicates that the configuration pragma file is currently
+   --  being scanned (this has no entry in the unit table).
+
+   Source_gnat_adc : Source_File_Index := No_Source_File;
+   --  This is set if a gnat.adc file is present to reference this file
+
+   Source : Source_Buffer_Ptr;
+   --  Current source (copy of Source_File.Table (Current_Source_Unit).Source)
+
+   Internal_Source : aliased Source_Buffer (1 .. 81);
+   --  This buffer is used internally in the compiler when the lexical analyzer
+   --  is used to scan a string from within the compiler. The procedure is to
+   --  establish Internal_Source_Ptr as the value of Source, set the string to
+   --  be scanned, appropriately terminated, in this buffer, and set Scan_Ptr
+   --  to point to the start of the buffer. It is a fatal error if the scanner
+   --  signals an error while scanning a token in this internal buffer.
+
+   Internal_Source_Ptr : constant Source_Buffer_Ptr :=
+                           Internal_Source'Unrestricted_Access;
+   --  Pointer to internal source buffer
+
+   -----------------
+   -- Subprograms --
+   -----------------
+
+   procedure Backup_Line (P : in out Source_Ptr);
+   --  Back up the argument pointer to the start of the previous line. On
+   --  entry, P points to the start of a physical line in the source buffer.
+   --  On return, P is updated to point to the start of the previous line.
+   --  The caller has checked that a Line_Terminator character precedes P so
+   --  that there definitely is a previous line in the source buffer.
+
+   procedure Build_Location_String (Loc : Source_Ptr);
+   --  This function builds a string literal of the form "name:line",
+   --  where name is the file name corresponding to Loc, and line is
+   --  the line number. In the event that instantiations are involved,
+   --  additional suffixes of the same form are appended after the
+   --  separating string " instantiated at ". The returned string is
+   --  stored in Name_Buffer, terminated by ASCII.Nul, with Name_Length
+   --  indicating the length not including the terminating Nul.
+
+   function Get_Column_Number (P : Source_Ptr) return Column_Number;
+   --  The ones-origin column number of the specified Source_Ptr value is
+   --  determined and returned. Tab characters if present are assumed to
+   --  represent the standard 1,9,17.. spacing pattern.
+
+   function Get_Logical_Line_Number
+     (P    : Source_Ptr)
+      return Logical_Line_Number;
+   --  The line number of the specified source position is obtained by
+   --  doing a binary search on the source positions in the lines table
+   --  for the unit containing the given source position. The returned
+   --  value is the logical line number, already adjusted for the effect
+   --  of source reference pragmas. If P refers to the line of a source
+   --  reference pragma itself, then No_Line is returned. If no source
+   --  reference pragmas have been encountered, the value returned is
+   --  the same as the physical line number.
+
+   function Get_Physical_Line_Number
+     (P    : Source_Ptr)
+      return Physical_Line_Number;
+   --  The line number of the specified source position is obtained by
+   --  doing a binary search on the source positions in the lines table
+   --  for the unit containing the given source position. The returned
+   --  value is the physical line number in the source being compiled.
+
+   function Get_Source_File_Index (S : Source_Ptr) return Source_File_Index;
+   --  Return file table index of file identified by given source pointer
+   --  value. This call must always succeed, since any valid source pointer
+   --  value belongs to some previously loaded source file.
+
+   function Instantiation_Depth (S : Source_Ptr) return Nat;
+   --  Determine instantiation depth for given Sloc value. A value of
+   --  zero means that the given Sloc is not in an instantiation.
+
+   function Line_Start (P : Source_Ptr) return Source_Ptr;
+   --  Finds the source position of the start of the line containing the
+   --  given source location.
+
+   function Line_Start
+     (L    : Physical_Line_Number;
+      S    : Source_File_Index)
+      return Source_Ptr;
+   --  Finds the source position of the start of the given line in the
+   --  given source file, using a physical line number to identify the line.
+
+   function Num_Source_Lines (S : Source_File_Index) return Nat;
+   --  Returns the number of source lines (this is equivalent to reading
+   --  the value of Last_Source_Line, but returns Nat rathern than a
+   --  physical line number.
+
+   procedure Register_Source_Ref_Pragma
+     (File_Name          : Name_Id;
+      Stripped_File_Name : Name_Id;
+      Mapped_Line        : Nat;
+      Line_After_Pragma  : Physical_Line_Number);
+   --  Register a source reference pragma, the parameter File_Name is the
+   --  file name from the pragma, and Stripped_File_Name is this name with
+   --  the directory information stripped. Both these parameters are set
+   --  to No_Name if no file name parameter was given in the pragma.
+   --  (which can only happen for the second and subsequent pragmas).
+   --  Mapped_Line is the line number parameter from the pragma, and
+   --  Line_After_Pragma is the physical line number of the line that
+   --  follows the line containing the Source_Reference pragma.
+
+   function Original_Location (S : Source_Ptr) return Source_Ptr;
+   --  Given a source pointer S, returns the corresponding source pointer
+   --  value ignoring instantiation copies. For locations that do not
+   --  correspond to instantiation copies of templates, the argument is
+   --  returned unchanged. For locations that do correspond to copies of
+   --  templates from instantiations, the location within the original
+   --  template is returned. This is useful in canonicalizing locations.
+
+   function Instantiation_Location (S : Source_Ptr) return Source_Ptr;
+   pragma Inline (Instantiation_Location);
+   --  Given a source pointer S, returns the corresponding source pointer
+   --  value of the instantiation if this location is within an instance.
+   --  If S is not within an instance, then this returns No_Location.
+
+   function Top_Level_Location (S : Source_Ptr) return Source_Ptr;
+   --  Given a source pointer S, returns the argument unchanged if it is
+   --  not in an instantiation. If S is in an instantiation, then it returns
+   --  the location of the top level instantiation, i.e. the outer level
+   --  instantiation in the nested case.
+
+   function Physical_To_Logical
+     (Line : Physical_Line_Number;
+      S    : Source_File_Index)
+      return Logical_Line_Number;
+   --  Given a physical line number in source file whose source index is S,
+   --  return the corresponding logical line number. If the physical line
+   --  number is one containing a Source_Reference pragma, the result will
+   --  be No_Line_Number.
+
+   procedure Skip_Line_Terminators
+     (P        : in out Source_Ptr;
+      Physical : out Boolean);
+   --  On entry, Source (P) points to the line terminator character that
+   --  terminates a line. The result set in P is the location of the first
+   --  character of the following line (after skipping the sequence of line
+   --  terminator characters terminating the current line). In addition, if
+   --  the terminator sequence ends a physical line (the definition of what
+   --  constitutes a physical line is embodied in the implementation of this
+   --  function), and it is the first time this sequence is encountered, then
+   --  an entry is made in the lines table to record the location for further
+   --  use by functions such as Get_Line_Number. Physical is set to True if
+   --  the line terminator was the end of a physical line.
+
+   function Source_Offset (S : Source_Ptr) return Nat;
+   --  Returns the zero-origin offset of the given source location from the
+   --  start of its corresponding unit. This is used for creating canonical
+   --  names in some situations.
+
+   procedure Write_Location (P : Source_Ptr);
+   --  Writes out a string of the form fff:nn:cc, where fff, nn, cc are the
+   --  file name, line number and column corresponding to the given source
+   --  location. No_Location and Standard_Location appear as the strings
+   --  <no location> and <standard location>. If the location is within an
+   --  instantiation, then the instance location is appended, enclosed in
+   --  square brackets (which can nest if necessary). Note that this routine
+   --  is used only for internal compiler debugging output purposes (which
+   --  is why the somewhat cryptic use of brackets is acceptable).
+
+   procedure wl (P : Source_Ptr);
+   --  Equivalent to Write_Location (P); Write_Eol; for calls from GDB
+
+   procedure Write_Time_Stamp (S : Source_File_Index);
+   --  Writes time stamp of specified file in YY-MM-DD HH:MM.SS format
+
+   procedure Tree_Write;
+   --  Writes out internal tables to current tree file using Tree_Write
+
+   procedure Tree_Read;
+   --  Initializes internal tables from current tree file using Tree_Read
+
+private
+   pragma Inline (File_Name);
+   pragma Inline (First_Mapped_Line);
+   pragma Inline (Full_File_Name);
+   pragma Inline (Identifier_Casing);
+   pragma Inline (Instantiation);
+   pragma Inline (Keyword_Casing);
+   pragma Inline (Last_Source_Line);
+   pragma Inline (Last_Source_File);
+   pragma Inline (License);
+   pragma Inline (Num_SRef_Pragmas);
+   pragma Inline (Num_Source_Files);
+   pragma Inline (Num_Source_Lines);
+   pragma Inline (Reference_Name);
+   pragma Inline (Set_Keyword_Casing);
+   pragma Inline (Set_Identifier_Casing);
+   pragma Inline (Source_First);
+   pragma Inline (Source_Last);
+   pragma Inline (Source_Text);
+   pragma Inline (Template);
+   pragma Inline (Time_Stamp);
+
+   -------------------------
+   -- Source_Lines Tables --
+   -------------------------
+
+   type Lines_Table_Type is
+     array (Physical_Line_Number) of Source_Ptr;
+   --  Type used for lines table. The entries are indexed by physical line
+   --  numbers. The values are the starting Source_Ptr values for the start
+   --  of the corresponding physical line. Note that we make this a bogus
+   --  big array, sized as required, so that we avoid the use of fat pointers.
+
+   type Lines_Table_Ptr is access all Lines_Table_Type;
+   --  Type used for pointers to line tables
+
+   type Logical_Lines_Table_Type is
+     array (Physical_Line_Number) of Logical_Line_Number;
+   --  Type used for logical lines table. This table is used if a source
+   --  reference pragma is present. It is indexed by physical line numbers,
+   --  and contains the corresponding logical line numbers. An entry that
+   --  corresponds to a source reference pragma is set to No_Line_Number.
+   --  Note that we make this a bogus big array, sized as required, so that
+   --  we avoid the use of fat pointers.
+
+   type Logical_Lines_Table_Ptr is access all Logical_Lines_Table_Type;
+   --  Type used for pointers to logical line tables.
+
+   -----------------------
+   -- Source_File Table --
+   -----------------------
+
+   --  See earlier descriptions for meanings of public fields
+
+   type Source_File_Record is record
+
+      File_Name         : File_Name_Type;
+      Reference_Name    : File_Name_Type;
+      Debug_Source_Name : File_Name_Type;
+      Full_File_Name    : File_Name_Type;
+      Full_Ref_Name     : File_Name_Type;
+      License           : License_Type;
+      Num_SRef_Pragmas  : Nat;
+      First_Mapped_Line : Logical_Line_Number;
+      Source_Text       : Source_Buffer_Ptr;
+      Source_First      : Source_Ptr;
+      Source_Last       : Source_Ptr;
+      Time_Stamp        : Time_Stamp_Type;
+      Source_Checksum   : Word;
+      Last_Source_Line  : Physical_Line_Number;
+      Keyword_Casing    : Casing_Type;
+      Identifier_Casing : Casing_Type;
+      Instantiation     : Source_Ptr;
+      Template          : Source_File_Index;
+
+      --  The following fields are for internal use only (i.e. only in the
+      --  body of Sinput or its children, with no direct access by clients).
+
+      Sloc_Adjust : Source_Ptr;
+      --  A value to be added to Sloc values for this file to reference the
+      --  corresponding lines table. This is zero for the non-instantiation
+      --  case, and set so that the adition references the ultimate template
+      --  for the instantiation case. See Sinput-L for further details.
+
+      Lines_Table : Lines_Table_Ptr;
+      --  Pointer to lines table for this source. Updated as additional
+      --  lines are accessed using the Skip_Line_Terminators procedure.
+      --  Note: the lines table for an instantiation entry refers to the
+      --  original line numbers of the template see Sinput-L for details.
+
+      Logical_Lines_Table : Logical_Lines_Table_Ptr;
+      --  Pointer to logical lines table for this source. Non-null only if
+      --  a source reference pragma has been processed. Updated as lines
+      --  are accessed using the Skip_Line_Terminators procedure.
+
+      Lines_Table_Max : Physical_Line_Number;
+      --  Maximum subscript values for currently allocated Lines_Table
+      --  and (if present) the allocated Logical_Lines_Table. The value
+      --  Max_Source_Line gives the maximum used value, this gives the
+      --  maximum allocated value.
+
+   end record;
+
+   package Source_File is new Table.Table (
+     Table_Component_Type => Source_File_Record,
+     Table_Index_Type     => Source_File_Index,
+     Table_Low_Bound      => 1,
+     Table_Initial        => Alloc.Source_File_Initial,
+     Table_Increment      => Alloc.Source_File_Increment,
+     Table_Name           => "Source_File");
+
+   -----------------
+   -- Subprograms --
+   -----------------
+
+   procedure Alloc_Line_Tables
+     (S       : in out Source_File_Record;
+      New_Max : Nat);
+   --  Allocate or reallocate the lines table for the given source file so
+   --  that it can accomodate at least New_Max lines. Also allocates or
+   --  reallocates logical lines table if source ref pragmas are present.
+
+   procedure Add_Line_Tables_Entry
+     (S : in out Source_File_Record;
+      P : Source_Ptr);
+   --  Increment line table size by one (reallocating the lines table if
+   --  needed) and set the new entry to contain the value P. Also bumps
+   --  the Source_Line_Count field. If source reference pragmas are
+   --  present, also increments logical lines table size by one, and
+   --  sets new entry.
+
+end Sinput;
diff --git a/gcc/ada/snames.adb b/gcc/ada/snames.adb
new file mode 100644
index 00000000000..acda714b8ed
--- /dev/null
+++ b/gcc/ada/snames.adb
@@ -0,0 +1,883 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                               S N A M E S                                --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.205 $                            --
+--                                                                          --
+--          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 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 Namet; use Namet;
+
+package body Snames is
+
+   --  Table of names to be set by Initialize. Each name is terminated by a
+   --  single #, and the end of the list is marked by a null entry, i.e. by
+   --  two # marks in succession. Note that the table does not include the
+   --  entries for a-z, since these are initialized by Namet itself.
+
+   Preset_Names : constant String :=
+     "_parent#" &
+     "_tag#" &
+     "off#" &
+     "space#" &
+     "time#" &
+     "_init_proc#" &
+     "_size#" &
+     "_abort_signal#" &
+     "_address_resolver#" &
+     "_assign#" &
+     "_chain#" &
+     "_clean#" &
+     "_controller#" &
+     "_entry_bodies#" &
+     "_expunge#" &
+     "_final_list#" &
+     "_idepth#" &
+     "_init#" &
+     "_local_final_list#" &
+     "_master#" &
+     "_object#" &
+     "_priority#" &
+     "_service#" &
+     "_tags#" &
+     "_task#" &
+     "_task_id#" &
+     "_task_info#" &
+     "_task_name#" &
+     "_trace_sp#" &
+     "initialize#" &
+     "adjust#" &
+     "finalize#" &
+     "next#" &
+     "prev#" &
+     "_deep_adjust#" &
+     "_equality#" &
+     "_deep_finalize#" &
+     "_deep_initialize#" &
+     "_input#" &
+     "_output#" &
+     "_ras_access#" &
+     "_ras_dereference#" &
+     "_read#" &
+     "_rep_to_pos#" &
+     "_write#" &
+     "allocate#" &
+     "deallocate#" &
+     "dereference#" &
+     "decimal_io#" &
+     "enumeration_io#" &
+     "fixed_io#" &
+     "float_io#" &
+     "integer_io#" &
+     "modular_io#" &
+     "a_textio#" &
+     "a_witeio#" &
+     "const#" &
+     "<error>#" &
+     "go#" &
+     "put#" &
+     "put_line#" &
+     "to#" &
+     "finalization#" &
+     "finalization_root#" &
+     "interfaces#" &
+     "standard#" &
+     "system#" &
+     "text_io#" &
+     "wide_text_io#" &
+     "addr#" &
+     "async#" &
+     "get_active_partition_id#" &
+     "get_rci_package_receiver#" &
+     "origin#" &
+     "params#" &
+     "partition#" &
+     "partition_interface#" &
+     "ras#" &
+     "rci_name#" &
+     "receiver#" &
+     "result#" &
+     "rpc#" &
+     "subp_id#" &
+     "Oabs#" &
+     "Oand#" &
+     "Omod#" &
+     "Onot#" &
+     "Oor#" &
+     "Orem#" &
+     "Oxor#" &
+     "Oeq#" &
+     "One#" &
+     "Olt#" &
+     "Ole#" &
+     "Ogt#" &
+     "Oge#" &
+     "Oadd#" &
+     "Osubtract#" &
+     "Oconcat#" &
+     "Omultiply#" &
+     "Odivide#" &
+     "Oexpon#" &
+     "ada_83#" &
+     "ada_95#" &
+     "c_pass_by_copy#" &
+     "component_alignment#" &
+     "discard_names#" &
+     "elaboration_checks#" &
+     "eliminate#" &
+     "extend_system#" &
+     "extensions_allowed#" &
+     "external_name_casing#" &
+     "float_representation#" &
+     "initialize_scalars#" &
+     "license#" &
+     "locking_policy#" &
+     "long_float#" &
+     "no_run_time#" &
+     "normalize_scalars#" &
+     "polling#" &
+     "propagate_exceptions#" &
+     "queuing_policy#" &
+     "ravenscar#" &
+     "restricted_run_time#" &
+     "restrictions#" &
+     "reviewable#" &
+     "source_file_name#" &
+     "style_checks#" &
+     "suppress#" &
+     "task_dispatching_policy#" &
+     "unsuppress#" &
+     "use_vads_size#" &
+     "warnings#" &
+     "validity_checks#" &
+     "abort_defer#" &
+     "all_calls_remote#" &
+     "annotate#" &
+     "assert#" &
+     "asynchronous#" &
+     "atomic#" &
+     "atomic_components#" &
+     "attach_handler#" &
+     "comment#" &
+     "common_object#" &
+     "complex_representation#" &
+     "controlled#" &
+     "convention#" &
+     "cpp_class#" &
+     "cpp_constructor#" &
+     "cpp_virtual#" &
+     "cpp_vtable#" &
+     "debug#" &
+     "elaborate#" &
+     "elaborate_all#" &
+     "elaborate_body#" &
+     "export#" &
+     "export_exception#" &
+     "export_function#" &
+     "export_object#" &
+     "export_procedure#" &
+     "export_valued_procedure#" &
+     "finalize_storage_only#" &
+     "ident#" &
+     "import#" &
+     "import_exception#" &
+     "import_function#" &
+     "import_object#" &
+     "import_procedure#" &
+     "import_valued_procedure#" &
+     "inline#" &
+     "inline_always#" &
+     "inline_generic#" &
+     "inspection_point#" &
+     "interface#" &
+     "interface_name#" &
+     "interrupt_handler#" &
+     "interrupt_priority#" &
+     "java_constructor#" &
+     "java_interface#" &
+     "link_with#" &
+     "linker_alias#" &
+     "linker_options#" &
+     "linker_section#" &
+     "list#" &
+     "machine_attribute#" &
+     "main#" &
+     "main_storage#" &
+     "memory_size#" &
+     "no_return#" &
+     "optimize#" &
+     "pack#" &
+     "page#" &
+     "passive#" &
+     "preelaborate#" &
+     "priority#" &
+     "psect_object#" &
+     "pure#" &
+     "pure_function#" &
+     "remote_call_interface#" &
+     "remote_types#" &
+     "share_generic#" &
+     "shared#" &
+     "shared_passive#" &
+     "source_reference#" &
+     "stream_convert#" &
+     "subtitle#" &
+     "suppress_all#" &
+     "suppress_debug_info#" &
+     "suppress_initialization#" &
+     "system_name#" &
+     "task_info#" &
+     "task_name#" &
+     "task_storage#" &
+     "time_slice#" &
+     "title#" &
+     "unchecked_union#" &
+     "unimplemented_unit#" &
+     "unreserve_all_interrupts#" &
+     "volatile#" &
+     "volatile_components#" &
+     "weak_external#" &
+     "ada#" &
+     "asm#" &
+     "assembler#" &
+     "cobol#" &
+     "cpp#" &
+     "dll#" &
+     "fortran#" &
+     "intrinsic#" &
+     "java#" &
+     "stdcall#" &
+     "stubbed#" &
+     "win32#" &
+     "as_is#" &
+     "body_file_name#" &
+     "casing#" &
+     "code#" &
+     "component#" &
+     "component_size_4#" &
+     "copy#" &
+     "d_float#" &
+     "descriptor#" &
+     "default#" &
+     "dot_replacement#" &
+     "dynamic#" &
+     "entity#" &
+     "external#" &
+     "external_name#" &
+     "first_optional_parameter#" &
+     "form#" &
+     "g_float#" &
+     "gcc#" &
+     "gnat#" &
+     "gpl#" &
+     "ieee_float#" &
+     "internal#" &
+     "link_name#" &
+     "lowercase#" &
+     "max_size#" &
+     "mechanism#" &
+     "mixedcase#" &
+     "modified_gpl#" &
+     "name#" &
+     "nca#" &
+     "no#" &
+     "on#" &
+     "parameter_types#" &
+     "reference#" &
+     "restricted#" &
+     "result_mechanism#" &
+     "result_type#" &
+     "sb#" &
+     "section#" &
+     "semaphore#" &
+     "spec_file_name#" &
+     "static#" &
+     "stack_size#" &
+     "subunit_file_name#" &
+     "task_stack_size_default#" &
+     "task_type#" &
+     "time_slicing_enabled#" &
+     "top_guard#" &
+     "uba#" &
+     "ubs#" &
+     "ubsb#" &
+     "unit_name#" &
+     "unknown#" &
+     "unrestricted#" &
+     "uppercase#" &
+     "vax_float#" &
+     "vms#" &
+     "working_storage#" &
+     "abort_signal#" &
+     "access#" &
+     "address#" &
+     "address_size#" &
+     "aft#" &
+     "alignment#" &
+     "asm_input#" &
+     "asm_output#" &
+     "ast_entry#" &
+     "bit#" &
+     "bit_order#" &
+     "bit_position#" &
+     "body_version#" &
+     "callable#" &
+     "caller#" &
+     "code_address#" &
+     "component_size#" &
+     "compose#" &
+     "constrained#" &
+     "count#" &
+     "default_bit_order#" &
+     "definite#" &
+     "delta#" &
+     "denorm#" &
+     "digits#" &
+     "elaborated#" &
+     "emax#" &
+     "enum_rep#" &
+     "epsilon#" &
+     "exponent#" &
+     "external_tag#" &
+     "first#" &
+     "first_bit#" &
+     "fixed_value#" &
+     "fore#" &
+     "has_discriminants#" &
+     "identity#" &
+     "img#" &
+     "integer_value#" &
+     "large#" &
+     "last#" &
+     "last_bit#" &
+     "leading_part#" &
+     "length#" &
+     "machine_emax#" &
+     "machine_emin#" &
+     "machine_mantissa#" &
+     "machine_overflows#" &
+     "machine_radix#" &
+     "machine_rounds#" &
+     "machine_size#" &
+     "mantissa#" &
+     "max_interrupt_priority#" &
+     "max_priority#" &
+     "max_size_in_storage_elements#" &
+     "maximum_alignment#" &
+     "mechanism_code#" &
+     "model_emin#" &
+     "model_epsilon#" &
+     "model_mantissa#" &
+     "model_small#" &
+     "modulus#" &
+     "null_parameter#" &
+     "object_size#" &
+     "partition_id#" &
+     "passed_by_reference#" &
+     "pos#" &
+     "position#" &
+     "range#" &
+     "range_length#" &
+     "round#" &
+     "safe_emax#" &
+     "safe_first#" &
+     "safe_large#" &
+     "safe_last#" &
+     "safe_small#" &
+     "scale#" &
+     "scaling#" &
+     "signed_zeros#" &
+     "size#" &
+     "small#" &
+     "storage_size#" &
+     "storage_unit#" &
+     "tag#" &
+     "terminated#" &
+     "tick#" &
+     "to_address#" &
+     "type_class#" &
+     "uet_address#" &
+     "unbiased_rounding#" &
+     "unchecked_access#" &
+     "universal_literal_string#" &
+     "unrestricted_access#" &
+     "vads_size#" &
+     "val#" &
+     "valid#" &
+     "value_size#" &
+     "version#" &
+     "wchar_t_size#" &
+     "wide_width#" &
+     "width#" &
+     "word_size#" &
+     "adjacent#" &
+     "ceiling#" &
+     "copy_sign#" &
+     "floor#" &
+     "fraction#" &
+     "image#" &
+     "input#" &
+     "machine#" &
+     "max#" &
+     "min#" &
+     "model#" &
+     "pred#" &
+     "remainder#" &
+     "rounding#" &
+     "succ#" &
+     "truncation#" &
+     "value#" &
+     "wide_image#" &
+     "wide_value#" &
+     "output#" &
+     "read#" &
+     "write#" &
+     "elab_body#" &
+     "elab_spec#" &
+     "storage_pool#" &
+     "base#" &
+     "class#" &
+     "ceiling_locking#" &
+     "inheritance_locking#" &
+     "fifo_queuing#" &
+     "priority_queuing#" &
+     "fifo_within_priorities#" &
+     "access_check#" &
+     "accessibility_check#" &
+     "discriminant_check#" &
+     "division_check#" &
+     "elaboration_check#" &
+     "index_check#" &
+     "length_check#" &
+     "overflow_check#" &
+     "range_check#" &
+     "storage_check#" &
+     "tag_check#" &
+     "all_checks#" &
+     "abort#" &
+     "abs#" &
+     "accept#" &
+     "and#" &
+     "all#" &
+     "array#" &
+     "at#" &
+     "begin#" &
+     "body#" &
+     "case#" &
+     "constant#" &
+     "declare#" &
+     "delay#" &
+     "do#" &
+     "else#" &
+     "elsif#" &
+     "end#" &
+     "entry#" &
+     "exception#" &
+     "exit#" &
+     "for#" &
+     "function#" &
+     "generic#" &
+     "goto#" &
+     "if#" &
+     "in#" &
+     "is#" &
+     "limited#" &
+     "loop#" &
+     "mod#" &
+     "new#" &
+     "not#" &
+     "null#" &
+     "of#" &
+     "or#" &
+     "others#" &
+     "out#" &
+     "package#" &
+     "pragma#" &
+     "private#" &
+     "procedure#" &
+     "raise#" &
+     "record#" &
+     "rem#" &
+     "renames#" &
+     "return#" &
+     "reverse#" &
+     "select#" &
+     "separate#" &
+     "subtype#" &
+     "task#" &
+     "terminate#" &
+     "then#" &
+     "type#" &
+     "use#" &
+     "when#" &
+     "while#" &
+     "with#" &
+     "xor#" &
+     "divide#" &
+     "enclosing_entity#" &
+     "exception_information#" &
+     "exception_message#" &
+     "exception_name#" &
+     "file#" &
+     "import_address#" &
+     "import_largest_value#" &
+     "import_value#" &
+     "is_negative#" &
+     "line#" &
+     "rotate_left#" &
+     "rotate_right#" &
+     "shift_left#" &
+     "shift_right#" &
+     "shift_right_arithmetic#" &
+     "source_location#" &
+     "unchecked_conversion#" &
+     "unchecked_deallocation#" &
+     "abstract#" &
+     "aliased#" &
+     "protected#" &
+     "until#" &
+     "requeue#" &
+     "tagged#" &
+     "raise_exception#" &
+     "project#" &
+     "modifying#" &
+     "naming#" &
+     "object_dir#" &
+     "source_dirs#" &
+     "specification#" &
+     "body_part#" &
+     "specification_append#" &
+     "body_append#" &
+     "separate_append#" &
+     "source_files#" &
+     "source_list_file#" &
+     "switches#" &
+     "library_dir#" &
+     "library_name#" &
+     "library_kind#" &
+     "library_version#" &
+     "library_elaboration#" &
+     "gnatmake#" &
+     "gnatls#" &
+     "gnatxref#" &
+     "gnatfind#" &
+     "gnatbind#" &
+     "gnatlink#" &
+     "compiler#" &
+     "binder#" &
+     "linker#" &
+      "#";
+
+   ---------------------
+   -- Generated Names --
+   ---------------------
+
+   --  This section lists the various cases of generated names which are
+   --  built from existing names by adding unique leading and/or trailing
+   --  upper case letters. In some cases these names are built recursively,
+   --  in particular names built from types may be built from types which
+   --  themselves have generated names. In this list, xxx represents an
+   --  existing name to which identifying letters are prepended or appended,
+   --  and a trailing n represents a serial number in an external name that
+   --  has some semantic significance (e.g. the n'th index type of an array).
+
+   --    xxxA    access type for formal xxx in entry param record   (Exp_Ch9)
+   --    xxxB    tag table for tagged type xxx                      (Exp_Ch3)
+   --    xxxB    task body procedure for task xxx                   (Exp_Ch9)
+   --    xxxD    dispatch table for tagged type xxx                 (Exp_Ch3)
+   --    xxxD    discriminal for discriminant xxx                   (Sem_Ch3)
+   --    xxxDn   n'th discr check function for rec type xxx         (Exp_Ch3)
+   --    xxxE    elaboration boolean flag for task xxx              (Exp_Ch9)
+   --    xxxE    dispatch table pointer type for tagged type xxx    (Exp_Ch3)
+   --    xxxE    parameters for accept body for entry xxx           (Exp_Ch9)
+   --    xxxFn   n'th primitive of a tagged type (named xxx)        (Exp_Ch3)
+   --    xxxI    initialization procedure for type xxx              (Exp_Ch3)
+   --    xxxJ    tag table type index for tagged type xxx           (Exp_Ch3)
+   --    xxxM    master Id value for access type xxx                (Exp_Ch3)
+   --    xxxP    tag table pointer type for tagged type xxx         (Exp_Ch3)
+   --    xxxP    parameter record type for entry xxx                (Exp_Ch9)
+   --    xxxPA   access to parameter record type for entry xxx      (Exp_Ch9)
+   --    xxxPn   pointer type for n'th primitive of tagged type xxx (Exp_Ch3)
+   --    xxxR    dispatch table pointer for tagged type xxx         (Exp_Ch3)
+   --    xxxT    tag table type for tagged type xxx                 (Exp_Ch3)
+   --    xxxT    literal table for enumeration type xxx             (Sem_Ch3)
+   --    xxxV    type for task value record for task xxx            (Exp_Ch9)
+   --    xxxX    entry index constant                               (Exp_Ch9)
+   --    xxxY    dispatch table type for tagged type xxx            (Exp_Ch3)
+   --    xxxZ    size variable for task xxx                         (Exp_Ch9)
+
+   --  Implicit type names
+
+   --    TxxxT   type of literal table for enumeration type xxx     (Sem_Ch3)
+
+   --  (list not yet complete ???)
+
+   ----------------------
+   -- Get_Attribute_Id --
+   ----------------------
+
+   function Get_Attribute_Id (N : Name_Id) return Attribute_Id is
+   begin
+      return Attribute_Id'Val (N - First_Attribute_Name);
+   end Get_Attribute_Id;
+
+   ------------------
+   -- Get_Check_Id --
+   ------------------
+
+   function Get_Check_Id (N : Name_Id) return Check_Id is
+   begin
+      return Check_Id'Val (N - First_Check_Name);
+   end Get_Check_Id;
+
+   -----------------------
+   -- Get_Convention_Id --
+   -----------------------
+
+   function Get_Convention_Id (N : Name_Id) return Convention_Id is
+   begin
+      case N is
+         when Name_Ada        => return Convention_Ada;
+         when Name_Asm        => return Convention_Assembler;
+         when Name_Assembler  => return Convention_Assembler;
+         when Name_C          => return Convention_C;
+         when Name_COBOL      => return Convention_COBOL;
+         when Name_CPP        => return Convention_CPP;
+         when Name_DLL        => return Convention_Stdcall;
+         when Name_Fortran    => return Convention_Fortran;
+         when Name_Intrinsic  => return Convention_Intrinsic;
+         when Name_Java       => return Convention_Java;
+         when Name_Stdcall    => return Convention_Stdcall;
+         when Name_Stubbed    => return Convention_Stubbed;
+         when Name_Win32      => return Convention_Stdcall;
+         when others          =>
+            raise Program_Error;
+      end case;
+   end Get_Convention_Id;
+
+   ---------------------------
+   -- Get_Locking_Policy_Id --
+   ---------------------------
+
+   function Get_Locking_Policy_Id (N : Name_Id) return Locking_Policy_Id is
+   begin
+      return Locking_Policy_Id'Val (N - First_Locking_Policy_Name);
+   end Get_Locking_Policy_Id;
+
+   -------------------
+   -- Get_Pragma_Id --
+   -------------------
+
+   function Get_Pragma_Id (N : Name_Id) return Pragma_Id is
+   begin
+      if N = Name_AST_Entry then
+         return Pragma_AST_Entry;
+      elsif N = Name_Storage_Size then
+         return Pragma_Storage_Size;
+      elsif N = Name_Storage_Unit then
+         return Pragma_Storage_Unit;
+      else
+         return Pragma_Id'Val (N - First_Pragma_Name);
+      end if;
+   end Get_Pragma_Id;
+
+   ---------------------------
+   -- Get_Queuing_Policy_Id --
+   ---------------------------
+
+   function Get_Queuing_Policy_Id (N : Name_Id) return Queuing_Policy_Id is
+   begin
+      return Queuing_Policy_Id'Val (N - First_Queuing_Policy_Name);
+   end Get_Queuing_Policy_Id;
+
+   ------------------------------------
+   -- Get_Task_Dispatching_Policy_Id --
+   ------------------------------------
+
+   function Get_Task_Dispatching_Policy_Id (N : Name_Id)
+     return Task_Dispatching_Policy_Id is
+   begin
+      return Task_Dispatching_Policy_Id'Val
+        (N - First_Task_Dispatching_Policy_Name);
+   end Get_Task_Dispatching_Policy_Id;
+
+   ----------------
+   -- Initialize --
+   ----------------
+
+   procedure Initialize is
+      P_Index      : Natural;
+      Discard_Name : Name_Id;
+
+   begin
+      P_Index := Preset_Names'First;
+
+      loop
+         Name_Len := 0;
+
+         while Preset_Names (P_Index) /= '#' loop
+            Name_Len := Name_Len + 1;
+            Name_Buffer (Name_Len) := Preset_Names (P_Index);
+            P_Index := P_Index + 1;
+         end loop;
+
+         --  We do the Name_Find call to enter the name into the table, but
+         --  we don't need to do anything with the result, since we already
+         --  initialized all the preset names to have the right value (we
+         --  are depending on the order of the names and Preset_Names).
+
+         Discard_Name := Name_Find;
+         P_Index := P_Index + 1;
+         exit when Preset_Names (P_Index) = '#';
+      end loop;
+
+      --  Make sure that number of names in standard table is correct. If
+      --  this check fails, run utility program XSNAMES to construct a new
+      --  properly matching version of the body.
+
+      pragma Assert (Discard_Name = Last_Predefined_Name);
+   end Initialize;
+
+   -----------------------
+   -- Is_Attribute_Name --
+   -----------------------
+
+   function Is_Attribute_Name (N : Name_Id) return Boolean is
+   begin
+      return N in First_Attribute_Name .. Last_Attribute_Name;
+   end Is_Attribute_Name;
+
+   -------------------
+   -- Is_Check_Name --
+   -------------------
+
+   function Is_Check_Name (N : Name_Id) return Boolean is
+   begin
+      return N in First_Check_Name .. Last_Check_Name;
+   end Is_Check_Name;
+
+   ------------------------
+   -- Is_Convention_Name --
+   ------------------------
+
+   function Is_Convention_Name (N : Name_Id) return Boolean is
+   begin
+      return N in First_Convention_Name .. Last_Convention_Name
+        or else N = Name_C;
+   end Is_Convention_Name;
+
+   ------------------------------
+   -- Is_Entity_Attribute_Name --
+   ------------------------------
+
+   function Is_Entity_Attribute_Name (N : Name_Id) return Boolean is
+   begin
+      return N in First_Entity_Attribute_Name .. Last_Entity_Attribute_Name;
+   end Is_Entity_Attribute_Name;
+
+   --------------------------------
+   -- Is_Function_Attribute_Name --
+   --------------------------------
+
+   function Is_Function_Attribute_Name (N : Name_Id) return Boolean is
+   begin
+      return N in
+        First_Renamable_Function_Attribute ..
+          Last_Renamable_Function_Attribute;
+   end Is_Function_Attribute_Name;
+
+   ----------------------------
+   -- Is_Locking_Policy_Name --
+   ----------------------------
+
+   function Is_Locking_Policy_Name (N : Name_Id) return Boolean is
+   begin
+      return N in First_Locking_Policy_Name .. Last_Locking_Policy_Name;
+   end Is_Locking_Policy_Name;
+
+   -----------------------------
+   -- Is_Operator_Symbol_Name --
+   -----------------------------
+
+   function Is_Operator_Symbol_Name (N : Name_Id) return Boolean is
+   begin
+      return N in First_Operator_Name .. Last_Operator_Name;
+   end Is_Operator_Symbol_Name;
+
+   --------------------
+   -- Is_Pragma_Name --
+   --------------------
+
+   function Is_Pragma_Name (N : Name_Id) return Boolean is
+   begin
+      return N in First_Pragma_Name .. Last_Pragma_Name
+        or else N = Name_AST_Entry
+        or else N = Name_Storage_Size
+        or else N = Name_Storage_Unit;
+   end Is_Pragma_Name;
+
+   ---------------------------------
+   -- Is_Procedure_Attribute_Name --
+   ---------------------------------
+
+   function Is_Procedure_Attribute_Name (N : Name_Id) return Boolean is
+   begin
+      return N in First_Procedure_Attribute .. Last_Procedure_Attribute;
+   end Is_Procedure_Attribute_Name;
+
+   ----------------------------
+   -- Is_Queuing_Policy_Name --
+   ----------------------------
+
+   function Is_Queuing_Policy_Name (N : Name_Id) return Boolean is
+   begin
+      return N in First_Queuing_Policy_Name .. Last_Queuing_Policy_Name;
+   end Is_Queuing_Policy_Name;
+
+   -------------------------------------
+   -- Is_Task_Dispatching_Policy_Name --
+   -------------------------------------
+
+   function Is_Task_Dispatching_Policy_Name (N : Name_Id) return Boolean is
+   begin
+      return N in First_Task_Dispatching_Policy_Name ..
+                  Last_Task_Dispatching_Policy_Name;
+   end Is_Task_Dispatching_Policy_Name;
+
+   ----------------------------
+   -- Is_Type_Attribute_Name --
+   ----------------------------
+
+   function Is_Type_Attribute_Name (N : Name_Id) return Boolean is
+   begin
+      return N in First_Type_Attribute_Name .. Last_Type_Attribute_Name;
+   end Is_Type_Attribute_Name;
+
+end Snames;
diff --git a/gcc/ada/snames.ads b/gcc/ada/snames.ads
new file mode 100644
index 00000000000..4c365b8f63c
--- /dev/null
+++ b/gcc/ada/snames.ads
@@ -0,0 +1,1373 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                               S N A M E S                                --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.209 $
+--                                                                          --
+--          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 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 Types; use Types;
+
+package Snames is
+
+--  This package contains definitions of standard names (i.e. entries in the
+--  Names table) that are used throughout the GNAT compiler). It also contains
+--  the definitions of some enumeration types whose definitions are tied to
+--  the order of these preset names.
+
+--  WARNING: There is a C file, a-snames-h which duplicates some of the
+--  definitions in this file and must be kept properly synchronized.
+
+   ------------------
+   -- Preset Names --
+   ------------------
+
+   --  The following are preset entries in the names table, which are
+   --  entered at the start of every compilation for easy access. Note
+   --  that the order of initialization of these names in the body must
+   --  be coordinated with the order of names in this table.
+
+   --  Note: a name may not appear more than once in the following list.
+   --  If additional pragmas or attributes are introduced which might
+   --  otherwise cause a duplicate, then list it only once in this table,
+   --  and adjust the definition of the functions for testing for pragma
+   --  names and attribute names, and returning their ID values. Of course
+   --  everything is simpler if no such duplications occur!
+
+   --  First we have the one character names used to optimize the lookup
+   --  process for one character identifiers (avoid the hashing in this case)
+   --  There are a full 256 of these, but only the entries for lower case
+   --  and upper case letters have identifiers
+
+   --  The lower case letter entries are used for one character identifiers
+   --  appearing in the source, for example in pragma Interface (C).
+
+   Name_A         : constant Name_Id := First_Name_Id + Character'Pos ('a');
+   Name_B         : constant Name_Id := First_Name_Id + Character'Pos ('b');
+   Name_C         : constant Name_Id := First_Name_Id + Character'Pos ('c');
+   Name_D         : constant Name_Id := First_Name_Id + Character'Pos ('d');
+   Name_E         : constant Name_Id := First_Name_Id + Character'Pos ('e');
+   Name_F         : constant Name_Id := First_Name_Id + Character'Pos ('f');
+   Name_G         : constant Name_Id := First_Name_Id + Character'Pos ('g');
+   Name_H         : constant Name_Id := First_Name_Id + Character'Pos ('h');
+   Name_I         : constant Name_Id := First_Name_Id + Character'Pos ('i');
+   Name_J         : constant Name_Id := First_Name_Id + Character'Pos ('j');
+   Name_K         : constant Name_Id := First_Name_Id + Character'Pos ('k');
+   Name_L         : constant Name_Id := First_Name_Id + Character'Pos ('l');
+   Name_M         : constant Name_Id := First_Name_Id + Character'Pos ('m');
+   Name_N         : constant Name_Id := First_Name_Id + Character'Pos ('n');
+   Name_O         : constant Name_Id := First_Name_Id + Character'Pos ('o');
+   Name_P         : constant Name_Id := First_Name_Id + Character'Pos ('p');
+   Name_Q         : constant Name_Id := First_Name_Id + Character'Pos ('q');
+   Name_R         : constant Name_Id := First_Name_Id + Character'Pos ('r');
+   Name_S         : constant Name_Id := First_Name_Id + Character'Pos ('s');
+   Name_T         : constant Name_Id := First_Name_Id + Character'Pos ('t');
+   Name_U         : constant Name_Id := First_Name_Id + Character'Pos ('u');
+   Name_V         : constant Name_Id := First_Name_Id + Character'Pos ('v');
+   Name_W         : constant Name_Id := First_Name_Id + Character'Pos ('w');
+   Name_X         : constant Name_Id := First_Name_Id + Character'Pos ('x');
+   Name_Y         : constant Name_Id := First_Name_Id + Character'Pos ('y');
+   Name_Z         : constant Name_Id := First_Name_Id + Character'Pos ('z');
+
+   --  The upper case letter entries are used by expander code for local
+   --  variables that do not require unique names (e.g. formal parameter
+   --  names in constructed procedures)
+
+   Name_uA        : constant Name_Id := First_Name_Id + Character'Pos ('A');
+   Name_uB        : constant Name_Id := First_Name_Id + Character'Pos ('B');
+   Name_uC        : constant Name_Id := First_Name_Id + Character'Pos ('C');
+   Name_uD        : constant Name_Id := First_Name_Id + Character'Pos ('D');
+   Name_uE        : constant Name_Id := First_Name_Id + Character'Pos ('E');
+   Name_uF        : constant Name_Id := First_Name_Id + Character'Pos ('F');
+   Name_uG        : constant Name_Id := First_Name_Id + Character'Pos ('G');
+   Name_uH        : constant Name_Id := First_Name_Id + Character'Pos ('H');
+   Name_uI        : constant Name_Id := First_Name_Id + Character'Pos ('I');
+   Name_uJ        : constant Name_Id := First_Name_Id + Character'Pos ('J');
+   Name_uK        : constant Name_Id := First_Name_Id + Character'Pos ('K');
+   Name_uL        : constant Name_Id := First_Name_Id + Character'Pos ('L');
+   Name_uM        : constant Name_Id := First_Name_Id + Character'Pos ('M');
+   Name_uN        : constant Name_Id := First_Name_Id + Character'Pos ('N');
+   Name_uO        : constant Name_Id := First_Name_Id + Character'Pos ('O');
+   Name_uP        : constant Name_Id := First_Name_Id + Character'Pos ('P');
+   Name_uQ        : constant Name_Id := First_Name_Id + Character'Pos ('Q');
+   Name_uR        : constant Name_Id := First_Name_Id + Character'Pos ('R');
+   Name_uS        : constant Name_Id := First_Name_Id + Character'Pos ('S');
+   Name_uT        : constant Name_Id := First_Name_Id + Character'Pos ('T');
+   Name_uU        : constant Name_Id := First_Name_Id + Character'Pos ('U');
+   Name_uV        : constant Name_Id := First_Name_Id + Character'Pos ('V');
+   Name_uW        : constant Name_Id := First_Name_Id + Character'Pos ('W');
+   Name_uX        : constant Name_Id := First_Name_Id + Character'Pos ('X');
+   Name_uY        : constant Name_Id := First_Name_Id + Character'Pos ('Y');
+   Name_uZ        : constant Name_Id := First_Name_Id + Character'Pos ('Z');
+
+   --  Note: the following table is read by the utility program XSNAMES and
+   --  its format should not be changed without coordinating with this program.
+
+   N : constant Name_Id := First_Name_Id + 256;
+   --  Synonym used in standard name definitions
+
+   --  Some names that are used by gigi, and whose definitions are reflected
+   --  in the C header file a-snames.h. They are placed at the start so that
+   --  the need to modify a-snames.h is minimized.
+
+   Name_uParent                        : constant Name_Id := N + 000;
+   Name_uTag                           : constant Name_Id := N + 001;
+   Name_Off                            : constant Name_Id := N + 002;
+   Name_Space                          : constant Name_Id := N + 003;
+   Name_Time                           : constant Name_Id := N + 004;
+   Name_uInit_Proc                     : constant Name_Id := N + 005;
+   Name_uSize                          : constant Name_Id := N + 006;
+
+   --  Some special names used by the expander. Note that the lower case u's
+   --  at the start of these names get translated to extra underscores. These
+   --  names are only referenced internally by expander generated code.
+
+   Name_uAbort_Signal                  : constant Name_Id := N + 007;
+   Name_uAddress_Resolver              : constant Name_Id := N + 008;
+   Name_uAssign                        : constant Name_Id := N + 009;
+   Name_uChain                         : constant Name_Id := N + 010;
+   Name_uClean                         : constant Name_Id := N + 011;
+   Name_uController                    : constant Name_Id := N + 012;
+   Name_uEntry_Bodies                  : constant Name_Id := N + 013;
+   Name_uExpunge                       : constant Name_Id := N + 014;
+   Name_uFinal_List                    : constant Name_Id := N + 015;
+   Name_uIdepth                        : constant Name_Id := N + 016;
+   Name_uInit                          : constant Name_Id := N + 017;
+   Name_uLocal_Final_List              : constant Name_Id := N + 018;
+   Name_uMaster                        : constant Name_Id := N + 019;
+   Name_uObject                        : constant Name_Id := N + 020;
+   Name_uPriority                      : constant Name_Id := N + 021;
+   Name_uService                       : constant Name_Id := N + 022;
+   Name_uTags                          : constant Name_Id := N + 023;
+   Name_uTask                          : constant Name_Id := N + 024;
+   Name_uTask_Id                       : constant Name_Id := N + 025;
+   Name_uTask_Info                     : constant Name_Id := N + 026;
+   Name_uTask_Name                     : constant Name_Id := N + 027;
+   Name_uTrace_Sp                      : constant Name_Id := N + 028;
+
+   --  Names of routines in Ada.Finalization, needed by expander
+
+   Name_Initialize                     : constant Name_Id := N + 029;
+   Name_Adjust                         : constant Name_Id := N + 030;
+   Name_Finalize                       : constant Name_Id := N + 031;
+
+   --  Names of fields declared in System.Finalization_Implementation,
+   --  needed by the expander when generating code for finalization.
+
+   Name_Next                           : constant Name_Id := N + 032;
+   Name_Prev                           : constant Name_Id := N + 033;
+
+   --  Names of TSS routines (see Exp_TSS); Name_uInit_Proc above is also
+   --  one of these.
+
+   Name_uDeep_Adjust                   : constant Name_Id := N + 034;
+   Name_uEquality                      : constant Name_Id := N + 035;
+   Name_uDeep_Finalize                 : constant Name_Id := N + 036;
+   Name_uDeep_Initialize               : constant Name_Id := N + 037;
+   Name_uInput                         : constant Name_Id := N + 038;
+   Name_uOutput                        : constant Name_Id := N + 039;
+   Name_uRAS_Access                    : constant Name_Id := N + 040;
+   Name_uRAS_Dereference               : constant Name_Id := N + 041;
+   Name_uRead                          : constant Name_Id := N + 042;
+   Name_uRep_To_Pos                    : constant Name_Id := N + 043;
+   Name_uWrite                         : constant Name_Id := N + 044;
+
+   --  Names of allocation routines, also needed by expander
+
+   Name_Allocate                       : constant Name_Id := N + 045;
+   Name_Deallocate                     : constant Name_Id := N + 046;
+   Name_Dereference                    : constant Name_Id := N + 047;
+
+   --  Names of Text_IO generic subpackages (see Rtsfind.Text_IO_Kludge)
+
+   First_Text_IO_Package               : constant Name_Id := N + 048;
+   Name_Decimal_IO                     : constant Name_Id := N + 048;
+   Name_Enumeration_IO                 : constant Name_Id := N + 049;
+   Name_Fixed_IO                       : constant Name_Id := N + 050;
+   Name_Float_IO                       : constant Name_Id := N + 051;
+   Name_Integer_IO                     : constant Name_Id := N + 052;
+   Name_Modular_IO                     : constant Name_Id := N + 053;
+   Last_Text_IO_Package                : constant Name_Id := N + 053;
+
+   subtype Text_IO_Package_Name is Name_Id
+     range First_Text_IO_Package .. Last_Text_IO_Package;
+
+   --  Names of files in library for Ada.Text_IO and Ada.Wide_Text_IO
+
+   Name_a_textio                       : constant Name_Id := N + 054;
+   Name_a_witeio                       : constant Name_Id := N + 055;
+
+   --  Some miscellaneous names used for error detection/recovery
+
+   Name_Const                          : constant Name_Id := N + 056;
+   Name_Error                          : constant Name_Id := N + 057;
+   Name_Go                             : constant Name_Id := N + 058;
+   Name_Put                            : constant Name_Id := N + 059;
+   Name_Put_Line                       : constant Name_Id := N + 060;
+   Name_To                             : constant Name_Id := N + 061;
+
+   --  Names for packages that are treated specially by the compiler
+
+   Name_Finalization                   : constant Name_Id := N + 062;
+   Name_Finalization_Root              : constant Name_Id := N + 063;
+   Name_Interfaces                     : constant Name_Id := N + 064;
+   Name_Standard                       : constant Name_Id := N + 065;
+   Name_System                         : constant Name_Id := N + 066;
+   Name_Text_IO                        : constant Name_Id := N + 067;
+   Name_Wide_Text_IO                   : constant Name_Id := N + 068;
+
+   --  Names of identifiers used in expanding distribution stubs
+
+   Name_Addr                           : constant Name_Id := N + 069;
+   Name_Async                          : constant Name_Id := N + 070;
+   Name_Get_Active_Partition_ID        : constant Name_Id := N + 071;
+   Name_Get_RCI_Package_Receiver       : constant Name_Id := N + 072;
+   Name_Origin                         : constant Name_Id := N + 073;
+   Name_Params                         : constant Name_Id := N + 074;
+   Name_Partition                      : constant Name_Id := N + 075;
+   Name_Partition_Interface            : constant Name_Id := N + 076;
+   Name_Ras                            : constant Name_Id := N + 077;
+   Name_RCI_Name                       : constant Name_Id := N + 078;
+   Name_Receiver                       : constant Name_Id := N + 079;
+   Name_Result                         : constant Name_Id := N + 080;
+   Name_Rpc                            : constant Name_Id := N + 081;
+   Name_Subp_Id                        : constant Name_Id := N + 082;
+
+   --  Operator Symbol entries. The actual names have an upper case O at
+   --  the start in place of the Op_ prefix (e.g. the actual name that
+   --  corresponds to Name_Op_Abs is "Oabs".
+
+   First_Operator_Name                 : constant Name_Id := N + 083;
+   Name_Op_Abs                         : constant Name_Id := N + 083; -- "abs"
+   Name_Op_And                         : constant Name_Id := N + 084; -- "and"
+   Name_Op_Mod                         : constant Name_Id := N + 085; -- "mod"
+   Name_Op_Not                         : constant Name_Id := N + 086; -- "not"
+   Name_Op_Or                          : constant Name_Id := N + 087; -- "or"
+   Name_Op_Rem                         : constant Name_Id := N + 088; -- "rem"
+   Name_Op_Xor                         : constant Name_Id := N + 089; -- "xor"
+   Name_Op_Eq                          : constant Name_Id := N + 090; -- "="
+   Name_Op_Ne                          : constant Name_Id := N + 091; -- "/="
+   Name_Op_Lt                          : constant Name_Id := N + 092; -- "<"
+   Name_Op_Le                          : constant Name_Id := N + 093; -- "<="
+   Name_Op_Gt                          : constant Name_Id := N + 094; -- ">"
+   Name_Op_Ge                          : constant Name_Id := N + 095; -- ">="
+   Name_Op_Add                         : constant Name_Id := N + 096; -- "+"
+   Name_Op_Subtract                    : constant Name_Id := N + 097; -- "-"
+   Name_Op_Concat                      : constant Name_Id := N + 098; -- "&"
+   Name_Op_Multiply                    : constant Name_Id := N + 099; -- "*"
+   Name_Op_Divide                      : constant Name_Id := N + 100; -- "/"
+   Name_Op_Expon                       : constant Name_Id := N + 101; -- "**"
+   Last_Operator_Name                  : constant Name_Id := N + 101;
+
+   --  Names for all pragmas recognized by GNAT. The entries with the comment
+   --  "Ada 83" are pragmas that are defined in Ada 83, but not in Ada 95.
+   --  These pragmas are fully implemented in both Ada 83 and Ada 95 modes
+   --  in GNAT.
+
+   --  The entries marked GNAT are pragmas that are defined by GNAT
+   --  and implemented in both Ada 83 and Ada 95 modes. Full descriptions
+   --  of these implementation dependent pragmas may be found in the
+   --  appropriate section in unit Sem_Prag in file sem-prag.adb.
+
+   --  The entries marked VMS are VMS specific pragmas that are recognized
+   --  only in OpenVMS versions of GNAT. They are ignored in other versions
+   --  with an appropriate warning.
+
+   First_Pragma_Name                   : constant Name_Id := N + 102;
+
+   --  Configuration pragmas are grouped at start
+
+   Name_Ada_83                         : constant Name_Id := N + 102; -- GNAT
+   Name_Ada_95                         : constant Name_Id := N + 103; -- GNAT
+   Name_C_Pass_By_Copy                 : constant Name_Id := N + 104; -- GNAT
+   Name_Component_Alignment            : constant Name_Id := N + 105; -- GNAT
+   Name_Discard_Names                  : constant Name_Id := N + 106;
+   Name_Elaboration_Checks             : constant Name_Id := N + 107; -- GNAT
+   Name_Eliminate                      : constant Name_Id := N + 108; -- GNAT
+   Name_Extend_System                  : constant Name_Id := N + 109; -- GNAT
+   Name_Extensions_Allowed             : constant Name_Id := N + 110; -- GNAT
+   Name_External_Name_Casing           : constant Name_Id := N + 111; -- GNAT
+   Name_Float_Representation           : constant Name_Id := N + 112; -- GNAT
+   Name_Initialize_Scalars             : constant Name_Id := N + 113; -- GNAT
+   Name_License                        : constant Name_Id := N + 114; -- GNAT
+   Name_Locking_Policy                 : constant Name_Id := N + 115;
+   Name_Long_Float                     : constant Name_Id := N + 116; -- VMS
+   Name_No_Run_Time                    : constant Name_Id := N + 117; -- GNAT
+   Name_Normalize_Scalars              : constant Name_Id := N + 118;
+   Name_Polling                        : constant Name_Id := N + 119; -- GNAT
+   Name_Propagate_Exceptions           : constant Name_Id := N + 120; -- GNAT
+   Name_Queuing_Policy                 : constant Name_Id := N + 121;
+   Name_Ravenscar                      : constant Name_Id := N + 122;
+   Name_Restricted_Run_Time            : constant Name_Id := N + 123;
+   Name_Restrictions                   : constant Name_Id := N + 124;
+   Name_Reviewable                     : constant Name_Id := N + 125;
+   Name_Source_File_Name               : constant Name_Id := N + 126; -- GNAT
+   Name_Style_Checks                   : constant Name_Id := N + 127; -- GNAT
+   Name_Suppress                       : constant Name_Id := N + 128;
+   Name_Task_Dispatching_Policy        : constant Name_Id := N + 129;
+   Name_Unsuppress                     : constant Name_Id := N + 130; -- GNAT
+   Name_Use_VADS_Size                  : constant Name_Id := N + 131; -- GNAT
+   Name_Warnings                       : constant Name_Id := N + 132; -- GNAT
+   Name_Validity_Checks                : constant Name_Id := N + 133; -- GNAT
+   Last_Configuration_Pragma_Name      : constant Name_Id := N + 133;
+
+   --  Remaining pragma names
+
+   Name_Abort_Defer                    : constant Name_Id := N + 134; -- GNAT
+   Name_All_Calls_Remote               : constant Name_Id := N + 135;
+   Name_Annotate                       : constant Name_Id := N + 136; -- GNAT
+
+   --  Note: AST_Entry is not in this list because its name matches the
+   --  name of the corresponding attribute. However, it is included in the
+   --  definition of the type Attribute_Id, and the functions Get_Pragma_Id
+   --  and Check_Pragma_Id correctly recognize and process Name_AST_Entry.
+   --  AST_Entry is a VMS specific pragma.
+
+   Name_Assert                         : constant Name_Id := N + 137; -- GNAT
+   Name_Asynchronous                   : constant Name_Id := N + 138;
+   Name_Atomic                         : constant Name_Id := N + 139;
+   Name_Atomic_Components              : constant Name_Id := N + 140;
+   Name_Attach_Handler                 : constant Name_Id := N + 141;
+   Name_Comment                        : constant Name_Id := N + 142; -- GNAT
+   Name_Common_Object                  : constant Name_Id := N + 143; -- GNAT
+   Name_Complex_Representation         : constant Name_Id := N + 144; -- GNAT
+   Name_Controlled                     : constant Name_Id := N + 145;
+   Name_Convention                     : constant Name_Id := N + 146;
+   Name_CPP_Class                      : constant Name_Id := N + 147; -- GNAT
+   Name_CPP_Constructor                : constant Name_Id := N + 148; -- GNAT
+   Name_CPP_Virtual                    : constant Name_Id := N + 149; -- GNAT
+   Name_CPP_Vtable                     : constant Name_Id := N + 150; -- GNAT
+   Name_Debug                          : constant Name_Id := N + 151; -- GNAT
+   Name_Elaborate                      : constant Name_Id := N + 152; -- Ada 83
+   Name_Elaborate_All                  : constant Name_Id := N + 153;
+   Name_Elaborate_Body                 : constant Name_Id := N + 154;
+   Name_Export                         : constant Name_Id := N + 155;
+   Name_Export_Exception               : constant Name_Id := N + 156; -- VMS
+   Name_Export_Function                : constant Name_Id := N + 157; -- GNAT
+   Name_Export_Object                  : constant Name_Id := N + 158; -- GNAT
+   Name_Export_Procedure               : constant Name_Id := N + 159; -- GNAT
+   Name_Export_Valued_Procedure        : constant Name_Id := N + 160; -- GNAT
+   Name_Finalize_Storage_Only          : constant Name_Id := N + 161; -- GNAT
+   Name_Ident                          : constant Name_Id := N + 162; -- VMS
+   Name_Import                         : constant Name_Id := N + 163;
+   Name_Import_Exception               : constant Name_Id := N + 164; -- VMS
+   Name_Import_Function                : constant Name_Id := N + 165; -- GNAT
+   Name_Import_Object                  : constant Name_Id := N + 166; -- GNAT
+   Name_Import_Procedure               : constant Name_Id := N + 167; -- GNAT
+   Name_Import_Valued_Procedure        : constant Name_Id := N + 168; -- GNAT
+   Name_Inline                         : constant Name_Id := N + 169;
+   Name_Inline_Always                  : constant Name_Id := N + 170; -- GNAT
+   Name_Inline_Generic                 : constant Name_Id := N + 171; -- GNAT
+   Name_Inspection_Point               : constant Name_Id := N + 172;
+   Name_Interface                      : constant Name_Id := N + 173; -- Ada 83
+   Name_Interface_Name                 : constant Name_Id := N + 174; -- GNAT
+   Name_Interrupt_Handler              : constant Name_Id := N + 175;
+   Name_Interrupt_Priority             : constant Name_Id := N + 176;
+   Name_Java_Constructor               : constant Name_Id := N + 177; -- GNAT
+   Name_Java_Interface                 : constant Name_Id := N + 178; -- GNAT
+   Name_Link_With                      : constant Name_Id := N + 179; -- GNAT
+   Name_Linker_Alias                   : constant Name_Id := N + 180; -- GNAT
+   Name_Linker_Options                 : constant Name_Id := N + 181;
+   Name_Linker_Section                 : constant Name_Id := N + 182; -- GNAT
+   Name_List                           : constant Name_Id := N + 183;
+   Name_Machine_Attribute              : constant Name_Id := N + 184; -- GNAT
+   Name_Main                           : constant Name_Id := N + 185; -- GNAT
+   Name_Main_Storage                   : constant Name_Id := N + 186; -- GNAT
+   Name_Memory_Size                    : constant Name_Id := N + 187; -- Ada 83
+   Name_No_Return                      : constant Name_Id := N + 188; -- GNAT
+   Name_Optimize                       : constant Name_Id := N + 189;
+   Name_Pack                           : constant Name_Id := N + 190;
+   Name_Page                           : constant Name_Id := N + 191;
+   Name_Passive                        : constant Name_Id := N + 192; -- GNAT
+   Name_Preelaborate                   : constant Name_Id := N + 193;
+   Name_Priority                       : constant Name_Id := N + 194;
+   Name_Psect_Object                   : constant Name_Id := N + 195; -- VMS
+   Name_Pure                           : constant Name_Id := N + 196;
+   Name_Pure_Function                  : constant Name_Id := N + 197; -- GNAT
+   Name_Remote_Call_Interface          : constant Name_Id := N + 198;
+   Name_Remote_Types                   : constant Name_Id := N + 199;
+   Name_Share_Generic                  : constant Name_Id := N + 200; -- GNAT
+   Name_Shared                         : constant Name_Id := N + 201; -- Ada 83
+   Name_Shared_Passive                 : constant Name_Id := N + 202;
+
+   --  Note: Storage_Size is not in this list because its name matches the
+   --  name of the corresponding attribute. However, it is included in the
+   --  definition of the type Attribute_Id, and the functions Get_Pragma_Id
+   --  and Check_Pragma_Id correctly recognize and process Name_Storage_Size.
+
+   --  Note: Storage_Unit is also omitted from the list because of a clash
+   --  with an attribute name, and is treated similarly.
+
+   Name_Source_Reference               : constant Name_Id := N + 203; -- GNAT
+   Name_Stream_Convert                 : constant Name_Id := N + 204; -- GNAT
+   Name_Subtitle                       : constant Name_Id := N + 205; -- GNAT
+   Name_Suppress_All                   : constant Name_Id := N + 206; -- GNAT
+   Name_Suppress_Debug_Info            : constant Name_Id := N + 207; -- GNAT
+   Name_Suppress_Initialization        : constant Name_Id := N + 208; -- GNAT
+   Name_System_Name                    : constant Name_Id := N + 209; -- Ada 83
+   Name_Task_Info                      : constant Name_Id := N + 210; -- GNAT
+   Name_Task_Name                      : constant Name_Id := N + 211; -- GNAT
+   Name_Task_Storage                   : constant Name_Id := N + 212; -- VMS
+   Name_Time_Slice                     : constant Name_Id := N + 213; -- GNAT
+   Name_Title                          : constant Name_Id := N + 214; -- GNAT
+   Name_Unchecked_Union                : constant Name_Id := N + 215; -- GNAT
+   Name_Unimplemented_Unit             : constant Name_Id := N + 216; -- GNAT
+   Name_Unreserve_All_Interrupts       : constant Name_Id := N + 217; -- GNAT
+   Name_Volatile                       : constant Name_Id := N + 218;
+   Name_Volatile_Components            : constant Name_Id := N + 219;
+   Name_Weak_External                  : constant Name_Id := N + 220; -- GNAT
+   Last_Pragma_Name                    : constant Name_Id := N + 220;
+
+   --  Language convention names for pragma Convention/Export/Import/Interface
+   --  Note that Name_C is not included in this list, since it was already
+   --  declared earlier in the context of one-character identifier names
+   --  (where the order is critical to the fast look up process).
+
+   --  Note: there are no convention names corresponding to the conventions
+   --  Entry and Protected, this is because these conventions cannot be
+   --  specified by a pragma.
+
+   --  Note: The convention name C_Pass_By_Copy is treated as entirely
+   --  equivalent to C except when it is specified on a record type. In
+   --  this case the convention of the record type is set to C, but in
+   --  addition the flag C_Pass_By_Copy is set on the record type.
+
+   First_Convention_Name               : constant Name_Id := N + 221;
+   Name_Ada                            : constant Name_Id := N + 221;
+   Name_Asm                            : constant Name_Id := N + 222;
+   Name_Assembler                      : constant Name_Id := N + 223;
+   Name_COBOL                          : constant Name_Id := N + 224;
+   Name_CPP                            : constant Name_Id := N + 225;
+   Name_DLL                            : constant Name_Id := N + 226;
+   Name_Fortran                        : constant Name_Id := N + 227;
+   Name_Intrinsic                      : constant Name_Id := N + 228;
+   Name_Java                           : constant Name_Id := N + 229;
+   Name_Stdcall                        : constant Name_Id := N + 230;
+   Name_Stubbed                        : constant Name_Id := N + 231;
+   Name_Win32                          : constant Name_Id := N + 232;
+   Last_Convention_Name                : constant Name_Id := N + 232;
+
+   --  Other special names used in processing pragma arguments
+
+   Name_As_Is                          : constant Name_Id := N + 233;
+   Name_Body_File_Name                 : constant Name_Id := N + 234;
+   Name_Casing                         : constant Name_Id := N + 235;
+   Name_Code                           : constant Name_Id := N + 236;
+   Name_Component                      : constant Name_Id := N + 237;
+   Name_Component_Size_4               : constant Name_Id := N + 238;
+   Name_Copy                           : constant Name_Id := N + 239;
+   Name_D_Float                        : constant Name_Id := N + 240;
+   Name_Descriptor                     : constant Name_Id := N + 241;
+   Name_Default                        : constant Name_Id := N + 242;
+   Name_Dot_Replacement                : constant Name_Id := N + 243;
+   Name_Dynamic                        : constant Name_Id := N + 244;
+   Name_Entity                         : constant Name_Id := N + 245;
+   Name_External                       : constant Name_Id := N + 246;
+   Name_External_Name                  : constant Name_Id := N + 247;
+   Name_First_Optional_Parameter       : constant Name_Id := N + 248;
+   Name_Form                           : constant Name_Id := N + 249;
+   Name_G_Float                        : constant Name_Id := N + 250;
+   Name_Gcc                            : constant Name_Id := N + 251;
+   Name_Gnat                           : constant Name_Id := N + 252;
+   Name_GPL                            : constant Name_Id := N + 253;
+   Name_IEEE_Float                     : constant Name_Id := N + 254;
+   Name_Internal                       : constant Name_Id := N + 255;
+   Name_Link_Name                      : constant Name_Id := N + 256;
+   Name_Lowercase                      : constant Name_Id := N + 257;
+   Name_Max_Size                       : constant Name_Id := N + 258;
+   Name_Mechanism                      : constant Name_Id := N + 259;
+   Name_Mixedcase                      : constant Name_Id := N + 260;
+   Name_Modified_GPL                   : constant Name_Id := N + 261;
+   Name_Name                           : constant Name_Id := N + 262;
+   Name_NCA                            : constant Name_Id := N + 263;
+   Name_No                             : constant Name_Id := N + 264;
+   Name_On                             : constant Name_Id := N + 265;
+   Name_Parameter_Types                : constant Name_Id := N + 266;
+   Name_Reference                      : constant Name_Id := N + 267;
+   Name_Restricted                     : constant Name_Id := N + 268;
+   Name_Result_Mechanism               : constant Name_Id := N + 269;
+   Name_Result_Type                    : constant Name_Id := N + 270;
+   Name_SB                             : constant Name_Id := N + 271;
+   Name_Section                        : constant Name_Id := N + 272;
+   Name_Semaphore                      : constant Name_Id := N + 273;
+   Name_Spec_File_Name                 : constant Name_Id := N + 274;
+   Name_Static                         : constant Name_Id := N + 275;
+   Name_Stack_Size                     : constant Name_Id := N + 276;
+   Name_Subunit_File_Name              : constant Name_Id := N + 277;
+   Name_Task_Stack_Size_Default        : constant Name_Id := N + 278;
+   Name_Task_Type                      : constant Name_Id := N + 279;
+   Name_Time_Slicing_Enabled           : constant Name_Id := N + 280;
+   Name_Top_Guard                      : constant Name_Id := N + 281;
+   Name_UBA                            : constant Name_Id := N + 282;
+   Name_UBS                            : constant Name_Id := N + 283;
+   Name_UBSB                           : constant Name_Id := N + 284;
+   Name_Unit_Name                      : constant Name_Id := N + 285;
+   Name_Unknown                        : constant Name_Id := N + 286;
+   Name_Unrestricted                   : constant Name_Id := N + 287;
+   Name_Uppercase                      : constant Name_Id := N + 288;
+   Name_VAX_Float                      : constant Name_Id := N + 289;
+   Name_VMS                            : constant Name_Id := N + 290;
+   Name_Working_Storage                : constant Name_Id := N + 291;
+
+   --  Names of recognized attributes. The entries with the comment "Ada 83"
+   --  are attributes that are defined in Ada 83, but not in Ada 95. These
+   --  attributes are implemented in both Ada 83 and Ada 95 modes in GNAT.
+
+   --  The entries marked GNAT are attributes that are defined by GNAT
+   --  and implemented in both Ada 83 and Ada 95 modes. Full descriptions
+   --  of these implementation dependent attributes may be found in the
+   --  appropriate section in package Sem_Attr in file sem-attr.ads.
+
+   --  The entries marked VMS are recognized only in OpenVMS implementations
+   --  of GNAT, and are treated as illegal in all other contexts.
+
+   First_Attribute_Name                : constant Name_Id := N + 292;
+   Name_Abort_Signal                   : constant Name_Id := N + 292;  -- GNAT
+   Name_Access                         : constant Name_Id := N + 293;
+   Name_Address                        : constant Name_Id := N + 294;
+   Name_Address_Size                   : constant Name_Id := N + 295;  -- GNAT
+   Name_Aft                            : constant Name_Id := N + 296;
+   Name_Alignment                      : constant Name_Id := N + 297;
+   Name_Asm_Input                      : constant Name_Id := N + 298;  -- GNAT
+   Name_Asm_Output                     : constant Name_Id := N + 299;  -- GNAT
+   Name_AST_Entry                      : constant Name_Id := N + 300;  -- VMS
+   Name_Bit                            : constant Name_Id := N + 301;  -- GNAT
+   Name_Bit_Order                      : constant Name_Id := N + 302;
+   Name_Bit_Position                   : constant Name_Id := N + 303;  -- GNAT
+   Name_Body_Version                   : constant Name_Id := N + 304;
+   Name_Callable                       : constant Name_Id := N + 305;
+   Name_Caller                         : constant Name_Id := N + 306;
+   Name_Code_Address                   : constant Name_Id := N + 307;  -- GNAT
+   Name_Component_Size                 : constant Name_Id := N + 308;
+   Name_Compose                        : constant Name_Id := N + 309;
+   Name_Constrained                    : constant Name_Id := N + 310;
+   Name_Count                          : constant Name_Id := N + 311;
+   Name_Default_Bit_Order              : constant Name_Id := N + 312; -- GNAT
+   Name_Definite                       : constant Name_Id := N + 313;
+   Name_Delta                          : constant Name_Id := N + 314;
+   Name_Denorm                         : constant Name_Id := N + 315;
+   Name_Digits                         : constant Name_Id := N + 316;
+   Name_Elaborated                     : constant Name_Id := N + 317; -- GNAT
+   Name_Emax                           : constant Name_Id := N + 318; -- Ada 83
+   Name_Enum_Rep                       : constant Name_Id := N + 319; -- GNAT
+   Name_Epsilon                        : constant Name_Id := N + 320; -- Ada 83
+   Name_Exponent                       : constant Name_Id := N + 321;
+   Name_External_Tag                   : constant Name_Id := N + 322;
+   Name_First                          : constant Name_Id := N + 323;
+   Name_First_Bit                      : constant Name_Id := N + 324;
+   Name_Fixed_Value                    : constant Name_Id := N + 325; -- GNAT
+   Name_Fore                           : constant Name_Id := N + 326;
+   Name_Has_Discriminants              : constant Name_Id := N + 327; -- GNAT
+   Name_Identity                       : constant Name_Id := N + 328;
+   Name_Img                            : constant Name_Id := N + 329; -- GNAT
+   Name_Integer_Value                  : constant Name_Id := N + 330; -- GNAT
+   Name_Large                          : constant Name_Id := N + 331; -- Ada 83
+   Name_Last                           : constant Name_Id := N + 332;
+   Name_Last_Bit                       : constant Name_Id := N + 333;
+   Name_Leading_Part                   : constant Name_Id := N + 334;
+   Name_Length                         : constant Name_Id := N + 335;
+   Name_Machine_Emax                   : constant Name_Id := N + 336;
+   Name_Machine_Emin                   : constant Name_Id := N + 337;
+   Name_Machine_Mantissa               : constant Name_Id := N + 338;
+   Name_Machine_Overflows              : constant Name_Id := N + 339;
+   Name_Machine_Radix                  : constant Name_Id := N + 340;
+   Name_Machine_Rounds                 : constant Name_Id := N + 341;
+   Name_Machine_Size                   : constant Name_Id := N + 342; -- GNAT
+   Name_Mantissa                       : constant Name_Id := N + 343; -- Ada 83
+   Name_Max_Interrupt_Priority         : constant Name_Id := N + 344; -- GNAT
+   Name_Max_Priority                   : constant Name_Id := N + 345; -- GNAT
+   Name_Max_Size_In_Storage_Elements   : constant Name_Id := N + 346;
+   Name_Maximum_Alignment              : constant Name_Id := N + 347; -- GNAT
+   Name_Mechanism_Code                 : constant Name_Id := N + 348; -- GNAT
+   Name_Model_Emin                     : constant Name_Id := N + 349;
+   Name_Model_Epsilon                  : constant Name_Id := N + 350;
+   Name_Model_Mantissa                 : constant Name_Id := N + 351;
+   Name_Model_Small                    : constant Name_Id := N + 352;
+   Name_Modulus                        : constant Name_Id := N + 353;
+   Name_Null_Parameter                 : constant Name_Id := N + 354; -- GNAT
+   Name_Object_Size                    : constant Name_Id := N + 355; -- GNAT
+   Name_Partition_ID                   : constant Name_Id := N + 356;
+   Name_Passed_By_Reference            : constant Name_Id := N + 357; -- GNAT
+   Name_Pos                            : constant Name_Id := N + 358;
+   Name_Position                       : constant Name_Id := N + 359;
+   Name_Range                          : constant Name_Id := N + 360;
+   Name_Range_Length                   : constant Name_Id := N + 361; -- GNAT
+   Name_Round                          : constant Name_Id := N + 362;
+   Name_Safe_Emax                      : constant Name_Id := N + 363; -- Ada 83
+   Name_Safe_First                     : constant Name_Id := N + 364;
+   Name_Safe_Large                     : constant Name_Id := N + 365; -- Ada 83
+   Name_Safe_Last                      : constant Name_Id := N + 366;
+   Name_Safe_Small                     : constant Name_Id := N + 367; -- Ada 83
+   Name_Scale                          : constant Name_Id := N + 368;
+   Name_Scaling                        : constant Name_Id := N + 369;
+   Name_Signed_Zeros                   : constant Name_Id := N + 370;
+   Name_Size                           : constant Name_Id := N + 371;
+   Name_Small                          : constant Name_Id := N + 372;
+   Name_Storage_Size                   : constant Name_Id := N + 373;
+   Name_Storage_Unit                   : constant Name_Id := N + 374; -- GNAT
+   Name_Tag                            : constant Name_Id := N + 375;
+   Name_Terminated                     : constant Name_Id := N + 376;
+   Name_Tick                           : constant Name_Id := N + 377; -- GNAT
+   Name_To_Address                     : constant Name_Id := N + 378; -- GNAT
+   Name_Type_Class                     : constant Name_Id := N + 379; -- GNAT
+   Name_UET_Address                    : constant Name_Id := N + 380; -- GNAT
+   Name_Unbiased_Rounding              : constant Name_Id := N + 381;
+   Name_Unchecked_Access               : constant Name_Id := N + 382;
+   Name_Universal_Literal_String       : constant Name_Id := N + 383; -- GNAT
+   Name_Unrestricted_Access            : constant Name_Id := N + 384; -- GNAT
+   Name_VADS_Size                      : constant Name_Id := N + 385; -- GNAT
+   Name_Val                            : constant Name_Id := N + 386;
+   Name_Valid                          : constant Name_Id := N + 387;
+   Name_Value_Size                     : constant Name_Id := N + 388; -- GNAT
+   Name_Version                        : constant Name_Id := N + 389;
+   Name_Wchar_T_Size                   : constant Name_Id := N + 390; -- GNAT
+   Name_Wide_Width                     : constant Name_Id := N + 391;
+   Name_Width                          : constant Name_Id := N + 392;
+   Name_Word_Size                      : constant Name_Id := N + 393; -- GNAT
+
+   --  Attributes that designate attributes returning renamable functions,
+   --  i.e. functions that return other than a universal value.
+
+   First_Renamable_Function_Attribute  : constant Name_Id := N + 394;
+   Name_Adjacent                       : constant Name_Id := N + 394;
+   Name_Ceiling                        : constant Name_Id := N + 395;
+   Name_Copy_Sign                      : constant Name_Id := N + 396;
+   Name_Floor                          : constant Name_Id := N + 397;
+   Name_Fraction                       : constant Name_Id := N + 398;
+   Name_Image                          : constant Name_Id := N + 399;
+   Name_Input                          : constant Name_Id := N + 400;
+   Name_Machine                        : constant Name_Id := N + 401;
+   Name_Max                            : constant Name_Id := N + 402;
+   Name_Min                            : constant Name_Id := N + 403;
+   Name_Model                          : constant Name_Id := N + 404;
+   Name_Pred                           : constant Name_Id := N + 405;
+   Name_Remainder                      : constant Name_Id := N + 406;
+   Name_Rounding                       : constant Name_Id := N + 407;
+   Name_Succ                           : constant Name_Id := N + 408;
+   Name_Truncation                     : constant Name_Id := N + 409;
+   Name_Value                          : constant Name_Id := N + 410;
+   Name_Wide_Image                     : constant Name_Id := N + 411;
+   Name_Wide_Value                     : constant Name_Id := N + 412;
+   Last_Renamable_Function_Attribute   : constant Name_Id := N + 412;
+
+   --  Attributes that designate procedures
+
+   First_Procedure_Attribute           : constant Name_Id := N + 413;
+   Name_Output                         : constant Name_Id := N + 413;
+   Name_Read                           : constant Name_Id := N + 414;
+   Name_Write                          : constant Name_Id := N + 415;
+   Last_Procedure_Attribute            : constant Name_Id := N + 415;
+
+   --  Remaining attributes are ones that return entities
+
+   First_Entity_Attribute_Name         : constant Name_Id := N + 416;
+   Name_Elab_Body                      : constant Name_Id := N + 416; -- GNAT
+   Name_Elab_Spec                      : constant Name_Id := N + 417; -- GNAT
+   Name_Storage_Pool                   : constant Name_Id := N + 418;
+
+   --  These attributes are the ones that return types
+
+   First_Type_Attribute_Name           : constant Name_Id := N + 419;
+   Name_Base                           : constant Name_Id := N + 419;
+   Name_Class                          : constant Name_Id := N + 420;
+   Last_Type_Attribute_Name            : constant Name_Id := N + 420;
+   Last_Entity_Attribute_Name          : constant Name_Id := N + 420;
+   Last_Attribute_Name                 : constant Name_Id := N + 420;
+
+   --  Names of recognized locking policy identifiers
+
+   --  Note: policies are identified by the first character of the
+   --  name (e.g. C for Ceiling_Locking). If new policy names are added,
+   --  the first character must be distinct.
+
+   First_Locking_Policy_Name           : constant Name_Id := N + 421;
+   Name_Ceiling_Locking                : constant Name_Id := N + 421;
+   Name_Inheritance_Locking            : constant Name_Id := N + 422;
+   Last_Locking_Policy_Name            : constant Name_Id := N + 422;
+
+   --  Names of recognized queuing policy identifiers.
+
+   --  Note: policies are identified by the first character of the
+   --  name (e.g. F for FIFO_Queuing). If new policy names are added,
+   --  the first character must be distinct.
+
+   First_Queuing_Policy_Name           : constant Name_Id := N + 423;
+   Name_FIFO_Queuing                   : constant Name_Id := N + 423;
+   Name_Priority_Queuing               : constant Name_Id := N + 424;
+   Last_Queuing_Policy_Name            : constant Name_Id := N + 424;
+
+   --  Names of recognized task dispatching policy identifiers
+
+   --  Note: policies are identified by the first character of the
+   --  name (e.g. F for FIFO_WIthinn_Priorities). If new policy names
+   --  are added, the first character must be distinct.
+
+   First_Task_Dispatching_Policy_Name  : constant Name_Id := N + 425;
+   Name_Fifo_Within_Priorities         : constant Name_Id := N + 425;
+   Last_Task_Dispatching_Policy_Name   : constant Name_Id := N + 425;
+
+   --  Names of recognized checks for pragma Suppress
+
+   First_Check_Name                    : constant Name_Id := N + 426;
+   Name_Access_Check                   : constant Name_Id := N + 426;
+   Name_Accessibility_Check            : constant Name_Id := N + 427;
+   Name_Discriminant_Check             : constant Name_Id := N + 428;
+   Name_Division_Check                 : constant Name_Id := N + 429;
+   Name_Elaboration_Check              : constant Name_Id := N + 430;
+   Name_Index_Check                    : constant Name_Id := N + 431;
+   Name_Length_Check                   : constant Name_Id := N + 432;
+   Name_Overflow_Check                 : constant Name_Id := N + 433;
+   Name_Range_Check                    : constant Name_Id := N + 434;
+   Name_Storage_Check                  : constant Name_Id := N + 435;
+   Name_Tag_Check                      : constant Name_Id := N + 436;
+   Name_All_Checks                     : constant Name_Id := N + 437;
+   Last_Check_Name                     : constant Name_Id := N + 437;
+
+   --  Names corresponding to reserved keywords, excluding those already
+   --  declared in the attribute list (Access, Delta, Digits, Range).
+
+   Name_Abort                          : constant Name_Id := N + 438;
+   Name_Abs                            : constant Name_Id := N + 439;
+   Name_Accept                         : constant Name_Id := N + 440;
+   Name_And                            : constant Name_Id := N + 441;
+   Name_All                            : constant Name_Id := N + 442;
+   Name_Array                          : constant Name_Id := N + 443;
+   Name_At                             : constant Name_Id := N + 444;
+   Name_Begin                          : constant Name_Id := N + 445;
+   Name_Body                           : constant Name_Id := N + 446;
+   Name_Case                           : constant Name_Id := N + 447;
+   Name_Constant                       : constant Name_Id := N + 448;
+   Name_Declare                        : constant Name_Id := N + 449;
+   Name_Delay                          : constant Name_Id := N + 450;
+   Name_Do                             : constant Name_Id := N + 451;
+   Name_Else                           : constant Name_Id := N + 452;
+   Name_Elsif                          : constant Name_Id := N + 453;
+   Name_End                            : constant Name_Id := N + 454;
+   Name_Entry                          : constant Name_Id := N + 455;
+   Name_Exception                      : constant Name_Id := N + 456;
+   Name_Exit                           : constant Name_Id := N + 457;
+   Name_For                            : constant Name_Id := N + 458;
+   Name_Function                       : constant Name_Id := N + 459;
+   Name_Generic                        : constant Name_Id := N + 460;
+   Name_Goto                           : constant Name_Id := N + 461;
+   Name_If                             : constant Name_Id := N + 462;
+   Name_In                             : constant Name_Id := N + 463;
+   Name_Is                             : constant Name_Id := N + 464;
+   Name_Limited                        : constant Name_Id := N + 465;
+   Name_Loop                           : constant Name_Id := N + 466;
+   Name_Mod                            : constant Name_Id := N + 467;
+   Name_New                            : constant Name_Id := N + 468;
+   Name_Not                            : constant Name_Id := N + 469;
+   Name_Null                           : constant Name_Id := N + 470;
+   Name_Of                             : constant Name_Id := N + 471;
+   Name_Or                             : constant Name_Id := N + 472;
+   Name_Others                         : constant Name_Id := N + 473;
+   Name_Out                            : constant Name_Id := N + 474;
+   Name_Package                        : constant Name_Id := N + 475;
+   Name_Pragma                         : constant Name_Id := N + 476;
+   Name_Private                        : constant Name_Id := N + 477;
+   Name_Procedure                      : constant Name_Id := N + 478;
+   Name_Raise                          : constant Name_Id := N + 479;
+   Name_Record                         : constant Name_Id := N + 480;
+   Name_Rem                            : constant Name_Id := N + 481;
+   Name_Renames                        : constant Name_Id := N + 482;
+   Name_Return                         : constant Name_Id := N + 483;
+   Name_Reverse                        : constant Name_Id := N + 484;
+   Name_Select                         : constant Name_Id := N + 485;
+   Name_Separate                       : constant Name_Id := N + 486;
+   Name_Subtype                        : constant Name_Id := N + 487;
+   Name_Task                           : constant Name_Id := N + 488;
+   Name_Terminate                      : constant Name_Id := N + 489;
+   Name_Then                           : constant Name_Id := N + 490;
+   Name_Type                           : constant Name_Id := N + 491;
+   Name_Use                            : constant Name_Id := N + 492;
+   Name_When                           : constant Name_Id := N + 493;
+   Name_While                          : constant Name_Id := N + 494;
+   Name_With                           : constant Name_Id := N + 495;
+   Name_Xor                            : constant Name_Id := N + 496;
+
+   --  Names of intrinsic subprograms
+
+   --  Note: Asm is missing from this list, since Asm is a legitimate
+   --  convention name.
+
+   First_Intrinsic_Name                : constant Name_Id := N + 497;
+   Name_Divide                         : constant Name_Id := N + 497;
+   Name_Enclosing_Entity               : constant Name_Id := N + 498;
+   Name_Exception_Information          : constant Name_Id := N + 499;
+   Name_Exception_Message              : constant Name_Id := N + 500;
+   Name_Exception_Name                 : constant Name_Id := N + 501;
+   Name_File                           : constant Name_Id := N + 502;
+   Name_Import_Address                 : constant Name_Id := N + 503;
+   Name_Import_Largest_Value           : constant Name_Id := N + 504;
+   Name_Import_Value                   : constant Name_Id := N + 505;
+   Name_Is_Negative                    : constant Name_Id := N + 506;
+   Name_Line                           : constant Name_Id := N + 507;
+   Name_Rotate_Left                    : constant Name_Id := N + 508;
+   Name_Rotate_Right                   : constant Name_Id := N + 509;
+   Name_Shift_Left                     : constant Name_Id := N + 510;
+   Name_Shift_Right                    : constant Name_Id := N + 511;
+   Name_Shift_Right_Arithmetic         : constant Name_Id := N + 512;
+   Name_Source_Location                : constant Name_Id := N + 513;
+   Name_Unchecked_Conversion           : constant Name_Id := N + 514;
+   Name_Unchecked_Deallocation         : constant Name_Id := N + 515;
+   Last_Intrinsic_Name                 : constant Name_Id := N + 515;
+
+   --  Reserved words used only in Ada 95
+
+   First_95_Reserved_Word              : constant Name_Id := N + 516;
+   Name_Abstract                       : constant Name_Id := N + 516;
+   Name_Aliased                        : constant Name_Id := N + 517;
+   Name_Protected                      : constant Name_Id := N + 518;
+   Name_Until                          : constant Name_Id := N + 519;
+   Name_Requeue                        : constant Name_Id := N + 520;
+   Name_Tagged                         : constant Name_Id := N + 521;
+   Last_95_Reserved_Word               : constant Name_Id := N + 521;
+
+   subtype Ada_95_Reserved_Words is
+     Name_Id range First_95_Reserved_Word .. Last_95_Reserved_Word;
+
+   --  Miscellaneous names used in semantic checking
+
+   Name_Raise_Exception                : constant Name_Id := N + 522;
+
+   --  Reserved words of GNAT Project Files
+
+   Name_Project                        : constant Name_Id := N + 523;
+   Name_Modifying                      : constant Name_Id := N + 524;
+   --  Name_External is already declared as N + 243
+
+   --  Names used in GNAT Project Files
+
+   Name_Naming                         : constant Name_Id := N + 525;
+   Name_Object_Dir                     : constant Name_Id := N + 526;
+   Name_Source_Dirs                    : constant Name_Id := N + 527;
+   Name_Specification                  : constant Name_Id := N + 528;
+   Name_Body_Part                      : constant Name_Id := N + 529;
+   Name_Specification_Append           : constant Name_Id := N + 530;
+   Name_Body_Append                    : constant Name_Id := N + 531;
+   Name_Separate_Append                : constant Name_Id := N + 532;
+   Name_Source_Files                   : constant Name_Id := N + 533;
+   Name_Source_List_File               : constant Name_Id := N + 534;
+   Name_Switches                       : constant Name_Id := N + 535;
+   Name_Library_Dir                    : constant Name_Id := N + 536;
+   Name_Library_Name                   : constant Name_Id := N + 537;
+   Name_Library_Kind                   : constant Name_Id := N + 538;
+   Name_Library_Version                : constant Name_Id := N + 539;
+   Name_Library_Elaboration            : constant Name_Id := N + 540;
+
+   Name_Gnatmake                       : constant Name_Id := N + 541;
+   Name_Gnatls                         : constant Name_Id := N + 542;
+   Name_Gnatxref                       : constant Name_Id := N + 543;
+   Name_Gnatfind                       : constant Name_Id := N + 544;
+   Name_Gnatbind                       : constant Name_Id := N + 545;
+   Name_Gnatlink                       : constant Name_Id := N + 546;
+   Name_Compiler                       : constant Name_Id := N + 547;
+   Name_Binder                         : constant Name_Id := N + 548;
+   Name_Linker                         : constant Name_Id := N + 549;
+
+   --  Mark last defined name for consistency check in Snames body
+
+   Last_Predefined_Name                : constant Name_Id := N + 549;
+
+   subtype Any_Operator_Name is Name_Id range
+     First_Operator_Name .. Last_Operator_Name;
+
+   ------------------------------
+   -- Attribute ID Definitions --
+   ------------------------------
+
+   type Attribute_Id is (
+      Attribute_Abort_Signal,
+      Attribute_Access,
+      Attribute_Address,
+      Attribute_Address_Size,
+      Attribute_Aft,
+      Attribute_Alignment,
+      Attribute_Asm_Input,
+      Attribute_Asm_Output,
+      Attribute_AST_Entry,
+      Attribute_Bit,
+      Attribute_Bit_Order,
+      Attribute_Bit_Position,
+      Attribute_Body_Version,
+      Attribute_Callable,
+      Attribute_Caller,
+      Attribute_Code_Address,
+      Attribute_Component_Size,
+      Attribute_Compose,
+      Attribute_Constrained,
+      Attribute_Count,
+      Attribute_Default_Bit_Order,
+      Attribute_Definite,
+      Attribute_Delta,
+      Attribute_Denorm,
+      Attribute_Digits,
+      Attribute_Elaborated,
+      Attribute_Emax,
+      Attribute_Enum_Rep,
+      Attribute_Epsilon,
+      Attribute_Exponent,
+      Attribute_External_Tag,
+      Attribute_First,
+      Attribute_First_Bit,
+      Attribute_Fixed_Value,
+      Attribute_Fore,
+      Attribute_Has_Discriminants,
+      Attribute_Identity,
+      Attribute_Img,
+      Attribute_Integer_Value,
+      Attribute_Large,
+      Attribute_Last,
+      Attribute_Last_Bit,
+      Attribute_Leading_Part,
+      Attribute_Length,
+      Attribute_Machine_Emax,
+      Attribute_Machine_Emin,
+      Attribute_Machine_Mantissa,
+      Attribute_Machine_Overflows,
+      Attribute_Machine_Radix,
+      Attribute_Machine_Rounds,
+      Attribute_Machine_Size,
+      Attribute_Mantissa,
+      Attribute_Max_Interrupt_Priority,
+      Attribute_Max_Priority,
+      Attribute_Max_Size_In_Storage_Elements,
+      Attribute_Maximum_Alignment,
+      Attribute_Mechanism_Code,
+      Attribute_Model_Emin,
+      Attribute_Model_Epsilon,
+      Attribute_Model_Mantissa,
+      Attribute_Model_Small,
+      Attribute_Modulus,
+      Attribute_Null_Parameter,
+      Attribute_Object_Size,
+      Attribute_Partition_ID,
+      Attribute_Passed_By_Reference,
+      Attribute_Pos,
+      Attribute_Position,
+      Attribute_Range,
+      Attribute_Range_Length,
+      Attribute_Round,
+      Attribute_Safe_Emax,
+      Attribute_Safe_First,
+      Attribute_Safe_Large,
+      Attribute_Safe_Last,
+      Attribute_Safe_Small,
+      Attribute_Scale,
+      Attribute_Scaling,
+      Attribute_Signed_Zeros,
+      Attribute_Size,
+      Attribute_Small,
+      Attribute_Storage_Size,
+      Attribute_Storage_Unit,
+      Attribute_Tag,
+      Attribute_Terminated,
+      Attribute_Tick,
+      Attribute_To_Address,
+      Attribute_Type_Class,
+      Attribute_UET_Address,
+      Attribute_Unbiased_Rounding,
+      Attribute_Unchecked_Access,
+      Attribute_Universal_Literal_String,
+      Attribute_Unrestricted_Access,
+      Attribute_VADS_Size,
+      Attribute_Val,
+      Attribute_Valid,
+      Attribute_Value_Size,
+      Attribute_Version,
+      Attribute_Wchar_T_Size,
+      Attribute_Wide_Width,
+      Attribute_Width,
+      Attribute_Word_Size,
+
+      --  Attributes designating renamable functions
+
+      Attribute_Adjacent,
+      Attribute_Ceiling,
+      Attribute_Copy_Sign,
+      Attribute_Floor,
+      Attribute_Fraction,
+      Attribute_Image,
+      Attribute_Input,
+      Attribute_Machine,
+      Attribute_Max,
+      Attribute_Min,
+      Attribute_Model,
+      Attribute_Pred,
+      Attribute_Remainder,
+      Attribute_Rounding,
+      Attribute_Succ,
+      Attribute_Truncation,
+      Attribute_Value,
+      Attribute_Wide_Image,
+      Attribute_Wide_Value,
+
+      --  Attributes designating procedures
+
+      Attribute_Output,
+      Attribute_Read,
+      Attribute_Write,
+
+      --  Entity attributes (includes type attributes)
+
+      Attribute_Elab_Body,
+      Attribute_Elab_Spec,
+      Attribute_Storage_Pool,
+
+      --  Type attributes
+
+      Attribute_Base,
+      Attribute_Class);
+
+   -------------------------------
+   -- Check Name ID Definitions --
+   -------------------------------
+
+   type Check_Id is (
+      Access_Check,
+      Accessibility_Check,
+      Discriminant_Check,
+      Division_Check,
+      Elaboration_Check,
+      Index_Check,
+      Length_Check,
+      Overflow_Check,
+      Range_Check,
+      Storage_Check,
+      Tag_Check,
+      All_Checks);
+
+   ------------------------------------
+   -- Convention Name ID Definitions --
+   ------------------------------------
+
+   type Convention_Id is (
+
+      --  The conventions that are defined by the RM come first
+
+      Convention_Ada,
+      Convention_Intrinsic,
+      Convention_Entry,
+      Convention_Protected,
+
+      --  The remaining conventions are foreign language conventions
+
+      Convention_Assembler,
+      Convention_C,
+      Convention_COBOL,
+      Convention_CPP,
+      Convention_Fortran,
+      Convention_Java,
+      Convention_Stdcall,
+      Convention_Stubbed);
+
+      --  Note: Conventions C_Pass_By_Copy, External, and Default are all
+      --  treated as synonyms for convention C (with an appropriate flag
+      --  being set in a record type in the case of C_Pass_By_Copy). See
+      --  processing in Sem_Prag for details.
+
+      --  Note: convention Win32 has the same effect as convention Stdcall
+      --  and as a special exception to normal rules is considered to be
+      --  conformant with convention Stdcall. Therefore if the convention
+      --  Win32 is encountered, it is translated into Convention_Stdcall.
+
+   for Convention_Id'Size use 8;
+   --  Plenty of space for expansion
+
+   subtype Foreign_Convention is
+     Convention_Id range Convention_Assembler .. Convention_Stdcall;
+
+   -----------------------------------
+   -- Locking Policy ID Definitions --
+   -----------------------------------
+
+   type Locking_Policy_Id is (
+      Locking_Policy_Inheritance_Locking,
+      Locking_Policy_Ceiling_Locking);
+
+   ---------------------------
+   -- Pragma ID Definitions --
+   ---------------------------
+
+   type Pragma_Id is (
+
+      --  Configuration pragmas
+
+      Pragma_Ada_83,
+      Pragma_Ada_95,
+      Pragma_C_Pass_By_Copy,
+      Pragma_Component_Alignment,
+      Pragma_Discard_Names,
+      Pragma_Elaboration_Checks,
+      Pragma_Eliminate,
+      Pragma_Extend_System,
+      Pragma_Extensions_Allowed,
+      Pragma_External_Name_Casing,
+      Pragma_Float_Representation,
+      Pragma_Initialize_Scalars,
+      Pragma_License,
+      Pragma_Locking_Policy,
+      Pragma_Long_Float,
+      Pragma_No_Run_Time,
+      Pragma_Normalize_Scalars,
+      Pragma_Polling,
+      Pragma_Propagate_Exceptions,
+      Pragma_Queuing_Policy,
+      Pragma_Ravenscar,
+      Pragma_Restricted_Run_Time,
+      Pragma_Restrictions,
+      Pragma_Reviewable,
+      Pragma_Source_File_Name,
+      Pragma_Style_Checks,
+      Pragma_Suppress,
+      Pragma_Task_Dispatching_Policy,
+      Pragma_Unsuppress,
+      Pragma_Use_VADS_Size,
+      Pragma_Warnings,
+      Pragma_Validity_Checks,
+
+      --  Remaining (non-configuration) pragmas
+
+      Pragma_Abort_Defer,
+      Pragma_All_Calls_Remote,
+      Pragma_Annotate,
+      Pragma_Assert,
+      Pragma_Asynchronous,
+      Pragma_Atomic,
+      Pragma_Atomic_Components,
+      Pragma_Attach_Handler,
+      Pragma_Comment,
+      Pragma_Common_Object,
+      Pragma_Complex_Representation,
+      Pragma_Controlled,
+      Pragma_Convention,
+      Pragma_CPP_Class,
+      Pragma_CPP_Constructor,
+      Pragma_CPP_Virtual,
+      Pragma_CPP_Vtable,
+      Pragma_Debug,
+      Pragma_Elaborate,
+      Pragma_Elaborate_All,
+      Pragma_Elaborate_Body,
+      Pragma_Export,
+      Pragma_Export_Exception,
+      Pragma_Export_Function,
+      Pragma_Export_Object,
+      Pragma_Export_Procedure,
+      Pragma_Export_Valued_Procedure,
+      Pragma_Finalize_Storage_Only,
+      Pragma_Ident,
+      Pragma_Import,
+      Pragma_Import_Exception,
+      Pragma_Import_Function,
+      Pragma_Import_Object,
+      Pragma_Import_Procedure,
+      Pragma_Import_Valued_Procedure,
+      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_Link_With,
+      Pragma_Linker_Alias,
+      Pragma_Linker_Options,
+      Pragma_Linker_Section,
+      Pragma_List,
+      Pragma_Machine_Attribute,
+      Pragma_Main,
+      Pragma_Main_Storage,
+      Pragma_Memory_Size,
+      Pragma_No_Return,
+      Pragma_Optimize,
+      Pragma_Pack,
+      Pragma_Page,
+      Pragma_Passive,
+      Pragma_Preelaborate,
+      Pragma_Priority,
+      Pragma_Psect_Object,
+      Pragma_Pure,
+      Pragma_Pure_Function,
+      Pragma_Remote_Call_Interface,
+      Pragma_Remote_Types,
+      Pragma_Share_Generic,
+      Pragma_Shared,
+      Pragma_Shared_Passive,
+      Pragma_Source_Reference,
+      Pragma_Stream_Convert,
+      Pragma_Subtitle,
+      Pragma_Suppress_All,
+      Pragma_Suppress_Debug_Info,
+      Pragma_Suppress_Initialization,
+      Pragma_System_Name,
+      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_Volatile,
+      Pragma_Volatile_Components,
+      Pragma_Weak_External,
+
+      --  The following pragmas are on their own, out of order, because of
+      --  the special processing required to deal with the fact that their
+      --  names match existing attribute names.
+
+      Pragma_AST_Entry,
+      Pragma_Storage_Size,
+      Pragma_Storage_Unit);
+
+   -----------------------------------
+   -- Queuing Policy ID definitions --
+   -----------------------------------
+
+   type Queuing_Policy_Id is (
+      Queuing_Policy_FIFO_Queuing,
+      Queuing_Policy_Priority_Queuing);
+
+   --------------------------------------------
+   -- Task Dispatching Policy ID definitions --
+   --------------------------------------------
+
+   type Task_Dispatching_Policy_Id is (
+      Task_Dispatching_FIFO_Within_Priorities);
+   --  Id values used to identify task dispatching policies
+
+   -----------------
+   -- Subprograms --
+   -----------------
+
+   procedure Initialize;
+   --  Called to initialize the preset names in the names table.
+
+   function Is_Attribute_Name (N : Name_Id) return Boolean;
+   --  Test to see if the name N is the name of a recognized attribute
+
+   function Is_Entity_Attribute_Name (N : Name_Id) return Boolean;
+   --  Test to see if the name N is the name of a recognized entity attribute,
+   --  i.e. an attribute reference that returns an entity.
+
+   function Is_Procedure_Attribute_Name (N : Name_Id) return Boolean;
+   --  Test to see if the name N is the name of a recognized attribute that
+   --  designates a procedure (and can therefore appear as a statement).
+
+   function Is_Function_Attribute_Name (N : Name_Id) return Boolean;
+   --  Test to see if the name N is the name of a recognized attribute
+   --  that designates a renameable function, and can therefore appear in
+   --  a renaming statement. Note that not all attributes designating
+   --  functions are renamable, in particular, thos returning a universal
+   --  value cannot be renamed.
+
+   function Is_Type_Attribute_Name (N : Name_Id) return Boolean;
+   --  Test to see if the name N is the name of a recognized type attribute,
+   --  i.e. an attribute reference that returns a type
+
+   function Is_Check_Name (N : Name_Id) return Boolean;
+   --  Test to see if the name N is the name of a recognized suppress check
+   --  as required by pragma Suppress.
+
+   function Is_Convention_Name (N : Name_Id) return Boolean;
+   --  Test to see if the name N is the name of one of the recognized language
+   --  conventions, as required by pragma Convention, Import, Export, Interface
+
+   function Is_Locking_Policy_Name (N : Name_Id) return Boolean;
+   --  Test to see if the name N is the name of a recognized locking policy
+
+   function Is_Operator_Symbol_Name (N : Name_Id) return Boolean;
+   --  Test to see if the name N is the name of an operator symbol
+
+   function Is_Pragma_Name (N : Name_Id) return Boolean;
+   --  Test to see if the name N is the name of a recognized pragma. Note
+   --  that pragmas AST_Entry, Storage_Size, and Storage_Unit are recognized
+   --  as pragmas by this function even though their names are separate from
+   --  the other pragma names.
+
+   function Is_Queuing_Policy_Name (N : Name_Id) return Boolean;
+   --  Test to see if the name N is the name of a recognized queuing policy
+
+   function Is_Task_Dispatching_Policy_Name (N : Name_Id) return Boolean;
+   --  Test to see if the name N is the name of a recognized
+   --  task dispatching policy
+
+   function Get_Attribute_Id (N : Name_Id) return Attribute_Id;
+   --  Returns Id of attribute corresponding to given name. It is an error to
+   --  call this function with a name that is not the name of a attribute.
+
+   function Get_Convention_Id (N : Name_Id) return Convention_Id;
+   --  Returns Id of language convention corresponding to given name. It is an
+   --  to call this function with a name that is not the name of a check.
+
+   function Get_Check_Id (N : Name_Id) return Check_Id;
+   --  Returns Id of suppress check corresponding to given name. It is an error
+   --  to call this function with a name that is not the name of a check.
+
+   function Get_Locking_Policy_Id (N : Name_Id) return Locking_Policy_Id;
+   --  Returns Id of locking policy corresponding to given name. It is an error
+   --  to call this function with a name that is not the name of a check.
+
+   function Get_Pragma_Id (N : Name_Id) return Pragma_Id;
+   --  Returns Id of pragma corresponding to given name. It is an error to
+   --  call this function with a name that is not the name of a pragma. Note
+   --  that the function also works correctly for names of pragmas that are
+   --  not in the main list of pragma Names (AST_Entry, Storage_Size, and
+   --  Storage_Unit (e.g. Name_Storage_Size returns Pragma_Storage_Size).
+
+   function Get_Queuing_Policy_Id (N : Name_Id) return Queuing_Policy_Id;
+   --  Returns Id of queuing policy corresponding to given name. It is an error
+   --  to call this function with a name that is not the name of a check.
+
+   function Get_Task_Dispatching_Policy_Id
+     (N    : Name_Id)
+      return Task_Dispatching_Policy_Id;
+   --  Returns Id of task dispatching policy corresponding to given name. It
+   --  is an error to call this function with a name that is not the name
+   --  of a check.
+
+private
+   pragma Inline (Is_Attribute_Name);
+   pragma Inline (Is_Entity_Attribute_Name);
+   pragma Inline (Is_Type_Attribute_Name);
+   pragma Inline (Is_Check_Name);
+   pragma Inline (Is_Convention_Name);
+   pragma Inline (Is_Locking_Policy_Name);
+   pragma Inline (Is_Operator_Symbol_Name);
+   pragma Inline (Is_Queuing_Policy_Name);
+   pragma Inline (Is_Pragma_Name);
+   pragma Inline (Is_Task_Dispatching_Policy_Name);
+
+end Snames;
diff --git a/gcc/ada/snames.h b/gcc/ada/snames.h
new file mode 100644
index 00000000000..e0c9b506b26
--- /dev/null
+++ b/gcc/ada/snames.h
@@ -0,0 +1,345 @@
+/****************************************************************************
+ *                                                                          *
+ *                         GNAT COMPILER COMPONENTS                         *
+ *                                                                          *
+ *                               S N A M E S                                *
+ *                                                                          *
+ *                              C Header File                               *
+ *                                                                          *
+ *                            $Revision: 1.2 $
+ *                                                                          *
+ *          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 is the C file that corresponds to the Ada package specification
+   Snames. It was created manually from the file snames.ads. */
+
+/* Name_Id values */
+
+#define Name_uParent    (First_Name_Id + 256 + 0)
+#define Name_uTag       (First_Name_Id + 256 + 1)
+#define Name_Off        (First_Name_Id + 256 + 2)
+#define Name_Space		(First_Name_Id + 256 + 3)
+#define Name_Time       (First_Name_Id + 256 + 4)
+#define Name_uInit_Proc (First_Name_Id + 256 + 5)
+#define Name_uSize      (First_Name_Id + 256 + 6)
+
+/* Define the function to return one of the numeric values below. Note
+   that it actually returns a char since an enumeration value of less
+   than 256 entries is represented that way in Ada.  The operand is a Chars
+   field value.  */
+
+#define Get_Attribute_Id snames__get_attribute_id
+extern char Get_Attribute_Id PARAMS ((int));
+
+/* Define the numeric values for the attributes.  */
+
+#define  Attr_Abort_Signal                   0
+#define  Attr_Access                         1
+#define  Attr_Address                        2
+#define  Attr_Address_Size                   3
+#define  Attr_Aft                            4
+#define  Attr_Alignment                      5
+#define  Attr_Asm_Input                      6
+#define  Attr_Asm_Output                     7
+#define  Attr_AST_Entry                      8
+#define  Attr_Bit                            9
+#define  Attr_Bit_Order                     10
+#define  Attr_Bit_Position                  11
+#define  Attr_Body_Version                  12
+#define  Attr_Callable                      13
+#define  Attr_Caller                        14
+#define  Attr_Code_Address                  15
+#define  Attr_Component_Size                16
+#define  Attr_Compose                       17
+#define  Attr_Constrained                   18
+#define  Attr_Count                         19
+#define  Attr_Default_Bit_Order             20
+#define  Attr_Definite                      21
+#define  Attr_Delta                         22
+#define  Attr_Denorm                        23
+#define  Attr_Digits                        24
+#define  Attr_Elaborated                    25
+#define  Attr_Emax                          26
+#define  Attr_Enum_Rep                      27
+#define  Attr_Epsilon                       28
+#define  Attr_Exponent                      29
+#define  Attr_External_Tag                  30
+#define  Attr_First                         31
+#define  Attr_First_Bit                     32
+#define  Attr_Fixed_Value                   33
+#define  Attr_Fore                          34
+#define  Attr_Has_Discriminants             35
+#define  Attr_Identity                      36
+#define  Attr_Img                           37
+#define  Attr_Integer_Value                 38
+#define  Attr_Large                         39
+#define  Attr_Last                          40
+#define  Attr_Last_Bit                      41
+#define  Attr_Leading_Part                  42
+#define  Attr_Length                        43
+#define  Attr_Machine_Emax                  44
+#define  Attr_Machine_Emin                  45
+#define  Attr_Machine_Mantissa              46
+#define  Attr_Machine_Overflows             47
+#define  Attr_Machine_Radix                 48
+#define  Attr_Machine_Rounds                49
+#define  Attr_Machine_Size                  50
+#define  Attr_Mantissa                      51
+#define  Attr_Max_Interrupt_Priority        52
+#define  Attr_Max_Priority                  53
+#define  Attr_Max_Size_In_Storage_Elements  54
+#define  Attr_Maximum_Alignment             55
+#define  Attr_Mechanism_Code                56
+#define  Attr_Model_Emin                    57
+#define  Attr_Model_Epsilon                 58
+#define  Attr_Model_Mantissa                59
+#define  Attr_Model_Small                   60
+#define  Attr_Modulus                       61
+#define  Attr_Null_Parameter                62
+#define  Attr_Object_Size                   63
+#define  Attr_Partition_ID                  64
+#define  Attr_Passed_By_Reference           65
+#define  Attr_Pos                           66
+#define  Attr_Position                      67
+#define  Attr_Range                         68
+#define  Attr_Range_Length                  69
+#define  Attr_Round                         70
+#define  Attr_Safe_Emax                     71
+#define  Attr_Safe_First                    72
+#define  Attr_Safe_Large                    73
+#define  Attr_Safe_Last                     74
+#define  Attr_Safe_Small                    75
+#define  Attr_Scale                         76
+#define  Attr_Scaling                       77
+#define  Attr_Signed_Zeros                  78
+#define  Attr_Size                          79
+#define  Attr_Small                         80
+#define  Attr_Storage_Size                  81
+#define  Attr_Storage_Unit                  82
+#define  Attr_Tag                           83
+#define  Attr_Terminated                    84
+#define  Attr_Tick                          85
+#define  Attr_To_Address                    86
+#define  Attr_Type_Class                    87
+#define  Attr_UET_Address                   88
+#define  Attr_Unbiased_Rounding             89
+#define  Attr_Unchecked_Access              90
+#define  Attr_Universal_Literal_String      91
+#define  Attr_Unrestricted_Access           92
+#define  Attr_VADS_Size                     93
+#define  Attr_Val                           94
+#define  Attr_Valid                         95
+#define  Attr_Value_Size                    96
+#define  Attr_Version                       97
+#define  Attr_Wide_Character_Size           98
+#define  Attr_Wide_Width                    99
+#define  Attr_Width                        100
+#define  Attr_Word_Size                    101
+
+#define  Attr_Adjacent                     102
+#define  Attr_Ceiling                      103
+#define  Attr_Copy_Sign                    104
+#define  Attr_Floor                        105
+#define  Attr_Fraction                     106
+#define  Attr_Image                        107
+#define  Attr_Input                        108
+#define  Attr_Machine                      109
+#define  Attr_Max                          110
+#define  Attr_Min                          111
+#define  Attr_Model                        112
+#define  Attr_Pred                         113
+#define  Attr_Remainder                    114
+#define  Attr_Rounding                     115
+#define  Attr_Succ                         116
+#define  Attr_Truncation                   117
+#define  Attr_Value                        118
+#define  Attr_Wide_Image                   119
+#define  Attr_Wide_Value                   120
+
+#define  Attr_Output                       121
+#define  Attr_Read                         122
+#define  Attr_Write                        123
+
+#define  Attr_Elab_Body                    124
+#define  Attr_Elab_Spec                    125
+#define  Attr_Storage_Pool                 126
+
+#define  Attr_Base                         127
+#define  Attr_Class                        128
+
+/* Define the function to check if a Name_Id value is a valid pragma */
+
+#define Is_Pragma_Name snames__is_pragma_name
+extern Boolean Is_Pragma_Name PARAMS ((Name_Id));
+
+/* Define the function to return one of the numeric values below.  Note
+   that it actually returns a char since an enumeration value of less
+   than 256 entries is represented that way in Ada.  The operand is a Chars
+   field value.  */
+
+#define Get_Pragma_Id snames__get_pragma_id
+extern char Get_Pragma_Id PARAMS ((int));
+
+/* Define the numeric values for the pragmas. */
+
+/* Configuration pragmas first */
+
+#define  Pragma_Ada_83                       0
+#define  Pragma_Ada_95                       1
+#define  Pragma_C_Pass_By_Copy               2
+#define  Pragma_Component_Alignment          3
+#define  Pragma_Discard_Names                4
+#define  Pragma_Elaboration_Checking         5
+#define  Pragma_Eliminate                    6
+#define  Pragma_Extend_System                7
+#define  Pragma_Extensions_Allowed           8
+#define  Pragma_External_Name_Casing         9
+#define  Pragma_Float_Representation        10
+#define  Pragma_Initialize                  11
+#define  Pragma_License                     12
+#define  Pragma_Locking_Policy              13
+#define  Pragma_Long_Float                  14
+#define  Pragma_No_Run_Time                 15
+#define  Pragma_Normalize_Scalars           16
+#define  Pragma_Polling                     17
+#define  Pragma_Propagate_Exceptions        18
+#define  Pragma_Queuing_Policy              19
+#define  Pragma_Ravenscar                   20
+#define  Pragma_Restricted_Run_Time         21
+#define  Pragma_Restrictions                22
+#define  Pragma_Reviewable                  23
+#define  Pragma_Source_File_Name            24
+#define  Pragma_Style_Checks                25
+#define  Pragma_Suppress                    26
+#define  Pragma_Task_Dispatching_Policy     27
+#define  Pragma_Unsuppress                  28
+#define  Pragma_Use_VADS_Size               29
+#define  Pragma_Validity_Checks             30
+#define  Pragma_Warnings                    31
+
+/* Remaining pragmas */
+
+#define  Pragma_Abort_Defer                 32
+#define  Pragma_All_Calls_Remote            33
+#define  Pragma_Annotate                    34
+#define  Pragma_Assert                      35
+#define  Pragma_Asynchronous                36
+#define  Pragma_Atomic                      37
+#define  Pragma_Atomic_Components           38
+#define  Pragma_Attach_Handler              39
+#define  Pragma_Comment                     40
+#define  Pragma_Common_Object               41
+#define  Pragma_Complex_Representation      42
+#define  Pragma_Controlled                  43
+#define  Pragma_Convention                  44
+#define  Pragma_CPP_Class                   45
+#define  Pragma_CPP_Constructor             46
+#define  Pragma_CPP_Virtual                 47
+#define  Pragma_CPP_Vtable                  48
+#define  Pragma_Debug                       49
+#define  Pragma_Elaborate                   50
+#define  Pragma_Elaborate_All               51
+#define  Pragma_Elaborate_Body              52
+#define  Pragma_Export                      53
+#define  Pragma_Export_Exception            54
+#define  Pragma_Export_Function             55
+#define  Pragma_Export_Object               56
+#define  Pragma_Export_Procedure            57
+#define  Pragma_Export_Valued_Procedure     58
+#define  Pragma_Finalize_Storage_Only       59
+#define  Pragma_Ident                       60
+#define  Pragma_Import                      61
+#define  Pragma_Import_Exception            62
+#define  Pragma_Import_Function             63
+#define  Pragma_Import_Object               64
+#define  Pragma_Import_Procedure            65
+#define  Pragma_Import_Valued_Procedure     66
+#define  Pragma_Inline                      67
+#define  Pragma_Inline_Always               68
+#define  Pragma_Inline_Generic              69
+#define  Pragma_Inspection_Point            70
+#define  Pragma_Interface                   71
+#define  Pragma_Interface_Name              72
+#define  Pragma_Interrupt_Handler           73
+#define  Pragma_Interrupt_Priority          74
+#define  Pragma_Java_Constructor            75
+#define  Pragma_Java_Interface              76
+#define  Pragma_Link_With                   77
+#define  Pragma_Linker_Alias                78
+#define  Pragma_Linker_Options              79
+#define  Pragma_Linker_Section              80
+#define  Pragma_List                        81
+#define  Pragma_Machine_Attribute           82
+#define  Pragma_Main                        83
+#define  Pragma_Main_Storage                84
+#define  Pragma_Memory_Size                 85
+#define  Pragma_No_Return                   86
+#define  Pragma_Optimize                    87
+#define  Pragma_Pack                        88
+#define  Pragma_Page                        89
+#define  Pragma_Passive                     90
+#define  Pragma_Preelaborate                91
+#define  Pragma_Priority                    92
+#define  Pragma_Psect_Object                93
+#define  Pragma_Pure                        94
+#define  Pragma_Pure_Function               95
+#define  Pragma_Remote_Call_Interface       96
+#define  Pragma_Remote_Types                97
+#define  Pragma_Share_Generic               98
+#define  Pragma_Shared                      99
+#define  Pragma_Shared_Passive             100
+#define  Pragma_Source_Reference           101
+#define  Pragma_Stream_Convert             102
+#define  Pragma_Subtitle                   103
+#define  Pragma_Suppress_All               104
+#define  Pragma_Suppress_Debug_Info        105
+#define  Pragma_Suppress_Initialization    106
+#define  Pragma_System_Name                107
+#define  Pragma_Task_Info                  108
+#define  Pragma_Task_Name                  109
+#define  Pragma_Task_Storage               110
+#define  Pragma_Time_Slice                 111
+#define  Pragma_Title                      112
+#define  Pragma_Unchecked_Union            113
+#define  Pragma_Unimplemented_Unit         114
+#define  Pragma_Unreserve_All_Interrupts   115
+#define  Pragma_Volatile                   116
+#define  Pragma_Volatile_Components        117
+#define  Pragma_Weak_External              118
+
+/* The following are deliberately out of alphabetical order, see Snames */
+
+#define  Pragma_AST_Entry                  119
+#define  Pragma_Storage_Size               120
+#define  Pragma_Storage_Unit               121
+
+/* Define the numeric values for the conventions.  */
+
+#define  Convention_Ada                      0
+#define  Convention_Intrinsic                1
+#define  Convention_Entry                    2
+#define  Convention_Protected                3
+#define  Convention_Assembler                4
+#define  Convention_C                        5
+#define  Convention_COBOL                    6
+#define  Convention_CPP                      7
+#define  Convention_Fortran                  8
+#define  Convention_Java                     9
+#define  Convention_Stdcall                 10
+#define  Convention_Stubbed                 11
diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb
new file mode 100644
index 00000000000..8c58ca81540
--- /dev/null
+++ b/gcc/ada/sprint.adb
@@ -0,0 +1,3071 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                               S P R I N T                                --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.205 $
+--                                                                          --
+--          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 Debug;    use Debug;
+with Einfo;    use Einfo;
+with Lib;      use Lib;
+with Namet;    use Namet;
+with Nlists;   use Nlists;
+with Opt;      use Opt;
+with Output;   use Output;
+with Rtsfind;  use Rtsfind;
+with Sinfo;    use Sinfo;
+with Sinput;   use Sinput;
+with Sinput.L; use Sinput.L;
+with Snames;   use Snames;
+with Stand;    use Stand;
+with Stringt;  use Stringt;
+with Uintp;    use Uintp;
+with Uname;    use Uname;
+with Urealp;   use Urealp;
+
+package body Sprint is
+
+   Debug_Node : Node_Id := Empty;
+   --  If we are in Debug_Generated_Code mode, then this location is set
+   --  to the current node requiring Sloc fixup, until Set_Debug_Sloc is
+   --  called to set the proper value. The call clears it back to Empty.
+
+   Debug_Sloc : Source_Ptr;
+   --  Sloc of first byte of line currently being written if we are
+   --  generating a source debug file.
+
+   Dump_Original_Only : Boolean;
+   --  Set True if the -gnatdo (dump original tree) flag is set
+
+   Dump_Generated_Only : Boolean;
+   --  Set True if the -gnatG (dump generated tree) debug flag is set
+   --  or for Print_Generated_Code (-gnatG) or Dump_Gnerated_Code (-gnatD).
+
+   Dump_Freeze_Null : Boolean;
+   --  Set True if freeze nodes and non-source null statements output
+
+   Indent : Int := 0;
+   --  Number of columns for current line output indentation
+
+   Indent_Annull_Flag : Boolean := False;
+   --  Set True if subsequent Write_Indent call to be ignored, gets reset
+   --  by this call, so it is only active to suppress a single indent call.
+
+   Line_Limit : constant := 72;
+   --  Limit value for chopping long lines
+
+   Freeze_Indent : Int := 0;
+   --  Keep track of freeze indent level (controls blank lines before
+   --  procedures within expression freeze actions)
+
+   -----------------------
+   -- Local Subprograms --
+   -----------------------
+
+   procedure Col_Check (N : Nat);
+   --  Check that at least N characters remain on current line, and if not,
+   --  then start an extra line with two characters extra indentation for
+   --  continuing text on the next line.
+
+   procedure Indent_Annull;
+   --  Causes following call to Write_Indent to be ignored. This is used when
+   --  a higher level node wants to stop a lower level node from starting a
+   --  new line, when it would otherwise be inclined to do so (e.g. the case
+   --  of an accept statement called from an accept alternative with a guard)
+
+   procedure Indent_Begin;
+   --  Increase indentation level
+
+   procedure Indent_End;
+   --  Decrease indentation level
+
+   procedure Print_Eol;
+   --  Terminate current line in line buffer
+
+   procedure Process_TFAI_RR_Flags (Nod : Node_Id);
+   --  Given a divide, multiplication or division node, check the flags
+   --  Treat_Fixed_As_Integer and Rounded_Flags, and if set, output the
+   --  appropriate special syntax characters (# and @).
+
+   procedure Set_Debug_Sloc;
+   --  If Debug_Node is non-empty, this routine sets the appropriate value
+   --  in its Sloc field, from the current location in the debug source file
+   --  that is currently being written. Note that Debug_Node is always empty
+   --  if a debug source file is not being written.
+
+   procedure Sprint_Bar_List (List : List_Id);
+   --  Print the given list with items separated by vertical bars
+
+   procedure Sprint_Node_Actual (Node : Node_Id);
+   --  This routine prints its node argument. It is a lower level routine than
+   --  Sprint_Node, in that it does not bother about rewritten trees.
+
+   procedure Sprint_Node_Sloc (Node : Node_Id);
+   --  Like Sprint_Node, but in addition, in Debug_Generated_Code mode,
+   --  sets the Sloc of the current debug node to be a copy of the Sloc
+   --  of the sprinted node Node. Note that this is done after printing
+   --  Node, so that the Sloc is the proper updated value for the debug file.
+
+   procedure Write_Char_Sloc (C : Character);
+   --  Like Write_Char, except that if C is non-blank, Set_Debug_Sloc is
+   --  called to ensure that the current node has a proper Sloc set.
+
+   procedure Write_Discr_Specs (N : Node_Id);
+   --  Ouput discriminant specification for node, which is any of the type
+   --  declarations that can have discriminants.
+
+   procedure Write_Ekind (E : Entity_Id);
+   --  Write the String corresponding to the Ekind without "E_".
+
+   procedure Write_Id (N : Node_Id);
+   --  N is a node with a Chars field. This procedure writes the name that
+   --  will be used in the generated code associated with the name. For a
+   --  node with no associated entity, this is simply the Chars field. For
+   --  the case where there is an entity associated with the node, we print
+   --  the name associated with the entity (since it may have been encoded).
+   --  One other special case is that an entity has an active external name
+   --  (i.e. an external name present with no address clause), then this
+   --  external name is output.
+
+   function Write_Identifiers (Node : Node_Id) return Boolean;
+   --  Handle node where the grammar has a list of defining identifiers, but
+   --  the tree has a separate declaration for each identifier. Handles the
+   --  printing of the defining identifier, and returns True if the type and
+   --  initialization information is to be printed, False if it is to be
+   --  skipped (the latter case happens when printing defining identifiers
+   --  other than the first in the original tree output case).
+
+   procedure Write_Implicit_Def (E : Entity_Id);
+   pragma Warnings (Off, Write_Implicit_Def);
+   --  Write the definition of the implicit type E according to its Ekind
+   --  For now a debugging procedure, but might be used in the future.
+
+   procedure Write_Indent;
+   --  Start a new line and write indentation spacing
+
+   function Write_Indent_Identifiers (Node : Node_Id) return Boolean;
+   --  Like Write_Identifiers except that each new printed declaration
+   --  is at the start of a new line.
+
+   function Write_Indent_Identifiers_Sloc (Node : Node_Id) return Boolean;
+   --  Like Write_Indent_Identifiers except that in Debug_Generated_Code
+   --  mode, the Sloc of the current debug node is set to point ot the
+   --  first output identifier.
+
+   procedure Write_Indent_Str (S : String);
+   --  Start a new line and write indent spacing followed by given string
+
+   procedure Write_Indent_Str_Sloc (S : String);
+   --  Like Write_Indent_Str, but in addition, in Debug_Generated_Code mode,
+   --  the Sloc of the current node is set to the first non-blank character
+   --  in the string S.
+
+   procedure Write_Name_With_Col_Check (N : Name_Id);
+   --  Write name (using Write_Name) with initial column check, and possible
+   --  initial Write_Indent (to get new line) if current line is too full.
+
+   procedure Write_Name_With_Col_Check_Sloc (N : Name_Id);
+   --  Like Write_Name_With_Col_Check but in addition, in Debug_Generated_Code
+   --  mode, sets Sloc of current debug node to first character of name.
+
+   procedure Write_Operator (N : Node_Id; S : String);
+   --  Like Write_Str_Sloc, used for operators, encloses the string in
+   --  characters {} if the Do_Overflow flag is set on the node N.
+
+   procedure Write_Param_Specs (N : Node_Id);
+   --  Output parameter specifications for node (which is either a function
+   --  or procedure specification with a Parameter_Specifications field)
+
+   procedure Write_Rewrite_Str (S : String);
+   --  Writes out a string (typically containing <<< or >>>}) for a node
+   --  created by rewriting the tree. Suppressed if we are outputting the
+   --  generated code only, since in this case we don't specially mark nodes
+   --  created by rewriting).
+
+   procedure Write_Str_Sloc (S : String);
+   --  Like Write_Str, but sets debug Sloc of current debug node to first
+   --  non-blank character if a current debug node is active.
+
+   procedure Write_Str_With_Col_Check (S : String);
+   --  Write string (using Write_Str) with initial column check, and possible
+   --  initial Write_Indent (to get new line) if current line is too full.
+
+   procedure Write_Str_With_Col_Check_Sloc (S : String);
+   --  Like Write_Str_WIth_Col_Check, but sets debug Sloc of current debug
+   --  node to first non-blank character if a current debug node is active.
+
+   procedure Write_Uint_With_Col_Check_Sloc (U : Uint; Format : UI_Format);
+   --  Write Uint (using UI_Write) with initial column check, and possible
+   --  initial Write_Indent (to get new line) if current line is too full.
+   --  The format parameter determines the output format (see UI_Write).
+   --  In addition, in Debug_Generated_Code mode, sets the current node
+   --  Sloc to the first character of the output value.
+
+   procedure Write_Ureal_With_Col_Check_Sloc (U : Ureal);
+   --  Write Ureal (using same output format as UR_Write) with column checks
+   --  and a possible initial Write_Indent (to get new line) if current line
+   --  is too full. In addition, in Debug_Generated_Code mode, sets the
+   --  current node Sloc to the first character of the output value.
+
+   ---------------
+   -- Col_Check --
+   ---------------
+
+   procedure Col_Check (N : Nat) is
+   begin
+      if N + Column > Line_Limit then
+         Write_Indent_Str ("  ");
+      end if;
+   end Col_Check;
+
+   -------------------
+   -- Indent_Annull --
+   -------------------
+
+   procedure Indent_Annull is
+   begin
+      Indent_Annull_Flag := True;
+   end Indent_Annull;
+
+   ------------------
+   -- Indent_Begin --
+   ------------------
+
+   procedure Indent_Begin is
+   begin
+      Indent := Indent + 3;
+   end Indent_Begin;
+
+   ----------------
+   -- Indent_End --
+   ----------------
+
+   procedure Indent_End is
+   begin
+      Indent := Indent - 3;
+   end Indent_End;
+
+   --------
+   -- PG --
+   --------
+
+   procedure PG (Node : Node_Id) is
+   begin
+      Dump_Generated_Only := True;
+      Dump_Original_Only := False;
+      Sprint_Node (Node);
+      Print_Eol;
+   end PG;
+
+   --------
+   -- PO --
+   --------
+
+   procedure PO (Node : Node_Id) is
+   begin
+      Dump_Generated_Only := False;
+      Dump_Original_Only := True;
+      Sprint_Node (Node);
+      Print_Eol;
+   end PO;
+
+   ---------------
+   -- Print_Eol --
+   ---------------
+
+   procedure Print_Eol is
+   begin
+      --  If we are writing a debug source file, then grab it from the
+      --  Output buffer, and reset the column counter (the routines in
+      --  Output never actually write any output for us in this mode,
+      --  they just build line images in Buffer).
+
+      if Debug_Generated_Code then
+         Write_Debug_Line (Buffer (1 .. Natural (Column) - 1), Debug_Sloc);
+         Column := 1;
+
+      --  In normal mode, we call Write_Eol to write the line normally
+
+      else
+         Write_Eol;
+      end if;
+   end Print_Eol;
+
+   ---------------------------
+   -- Process_TFAI_RR_Flags --
+   ---------------------------
+
+   procedure Process_TFAI_RR_Flags (Nod : Node_Id) is
+   begin
+      if Treat_Fixed_As_Integer (Nod) then
+         Write_Char ('#');
+      end if;
+
+      if Rounded_Result (Nod) then
+         Write_Char ('@');
+      end if;
+   end Process_TFAI_RR_Flags;
+
+   --------
+   -- PS --
+   --------
+
+   procedure PS (Node : Node_Id) is
+   begin
+      Dump_Generated_Only := False;
+      Dump_Original_Only := False;
+      Sprint_Node (Node);
+      Print_Eol;
+   end PS;
+
+   --------------------
+   -- Set_Debug_Sloc --
+   --------------------
+
+   procedure Set_Debug_Sloc is
+   begin
+      if Present (Debug_Node) then
+         Set_Sloc (Debug_Node, Debug_Sloc + Source_Ptr (Column - 1));
+         Debug_Node := Empty;
+      end if;
+   end Set_Debug_Sloc;
+
+   -----------------
+   -- Source_Dump --
+   -----------------
+
+   procedure Source_Dump is
+
+      procedure Underline;
+      --  Put underline under string we just printed
+
+      procedure Underline is
+         Col : constant Int := Column;
+
+      begin
+         Print_Eol;
+
+         while Col > Column loop
+            Write_Char ('-');
+         end loop;
+
+         Print_Eol;
+      end Underline;
+
+   --  Start of processing for Tree_Dump.
+
+   begin
+      Dump_Generated_Only := Debug_Flag_G or
+                             Print_Generated_Code or
+                             Debug_Generated_Code;
+      Dump_Original_Only  := Debug_Flag_O;
+      Dump_Freeze_Null    := Debug_Flag_S or Debug_Flag_G;
+
+      --  Note that we turn off the tree dump flags immediately, before
+      --  starting the dump. This avoids generating two copies of the dump
+      --  if an abort occurs after printing the dump, and more importantly,
+      --  avoids an infinite loop if an abort occurs during the dump.
+
+      if Debug_Flag_Z then
+         Debug_Flag_Z := False;
+         Print_Eol;
+         Print_Eol;
+         Write_Str ("Source recreated from tree of Standard (spec)");
+         Underline;
+         Sprint_Node (Standard_Package_Node);
+         Print_Eol;
+         Print_Eol;
+      end if;
+
+      if Debug_Flag_S or Dump_Generated_Only or Dump_Original_Only then
+         Debug_Flag_G := False;
+         Debug_Flag_O := False;
+         Debug_Flag_S := False;
+
+         --  Dump requested units
+
+         for U in Main_Unit .. Last_Unit loop
+
+            --  Dump all units if -gnatdf set, otherwise we dump only
+            --  the source files that are in the extended main source.
+
+            if Debug_Flag_F
+              or else In_Extended_Main_Source_Unit (Cunit_Entity (U))
+            then
+               --  If we are generating debug files, setup to write them
+
+               if Debug_Generated_Code then
+                  Create_Debug_Source (Source_Index (U), Debug_Sloc);
+                  Sprint_Node (Cunit (U));
+                  Print_Eol;
+                  Close_Debug_Source;
+
+               --  Normal output to standard output file
+
+               else
+                  Write_Str ("Source recreated from tree for ");
+                  Write_Unit_Name (Unit_Name (U));
+                  Underline;
+                  Sprint_Node (Cunit (U));
+                  Write_Eol;
+                  Write_Eol;
+               end if;
+            end if;
+         end loop;
+      end if;
+   end Source_Dump;
+
+   ---------------------
+   -- Sprint_Bar_List --
+   ---------------------
+
+   procedure Sprint_Bar_List (List : List_Id) is
+      Node : Node_Id;
+
+   begin
+      if Is_Non_Empty_List (List) then
+         Node := First (List);
+
+         loop
+            Sprint_Node (Node);
+            Next (Node);
+            exit when Node = Empty;
+            Write_Str (" | ");
+         end loop;
+      end if;
+   end Sprint_Bar_List;
+
+   -----------------------
+   -- Sprint_Comma_List --
+   -----------------------
+
+   procedure Sprint_Comma_List (List : List_Id) is
+      Node : Node_Id;
+
+   begin
+      if Is_Non_Empty_List (List) then
+         Node := First (List);
+
+         loop
+            Sprint_Node (Node);
+            Next (Node);
+            exit when Node = Empty;
+
+            if not Is_Rewrite_Insertion (Node)
+              or else not Dump_Original_Only
+            then
+               Write_Str (", ");
+            end if;
+
+         end loop;
+      end if;
+   end Sprint_Comma_List;
+
+   --------------------------
+   -- Sprint_Indented_List --
+   --------------------------
+
+   procedure Sprint_Indented_List (List : List_Id) is
+   begin
+      Indent_Begin;
+      Sprint_Node_List (List);
+      Indent_End;
+   end Sprint_Indented_List;
+
+   -----------------
+   -- Sprint_Node --
+   -----------------
+
+   procedure Sprint_Node (Node : Node_Id) is
+   begin
+      if Is_Rewrite_Insertion (Node) then
+         if not Dump_Original_Only then
+
+            --  For special cases of nodes that always output <<< >>>
+            --  do not duplicate the output at this point.
+
+            if Nkind (Node) = N_Freeze_Entity
+              or else Nkind (Node) = N_Implicit_Label_Declaration
+            then
+               Sprint_Node_Actual (Node);
+
+            --  Normal case where <<< >>> may be required
+
+            else
+               Write_Rewrite_Str ("<<<");
+               Sprint_Node_Actual (Node);
+               Write_Rewrite_Str (">>>");
+            end if;
+         end if;
+
+      elsif Is_Rewrite_Substitution (Node) then
+
+         --  Case of dump generated only
+
+         if Dump_Generated_Only then
+            Sprint_Node_Actual (Node);
+
+         --  Case of dump original only
+
+         elsif Dump_Original_Only then
+            Sprint_Node_Actual (Original_Node (Node));
+
+         --  Case of both being dumped
+
+         else
+            Sprint_Node_Actual (Original_Node (Node));
+            Write_Rewrite_Str ("<<<");
+            Sprint_Node_Actual (Node);
+            Write_Rewrite_Str (">>>");
+         end if;
+
+      else
+         Sprint_Node_Actual (Node);
+      end if;
+   end Sprint_Node;
+
+   ------------------------
+   -- Sprint_Node_Actual --
+   ------------------------
+
+   procedure Sprint_Node_Actual (Node : Node_Id) is
+      Save_Debug_Node : constant Node_Id := Debug_Node;
+
+   begin
+      if Node = Empty then
+         return;
+      end if;
+
+      for J in 1 .. Paren_Count (Node) loop
+         Write_Str_With_Col_Check ("(");
+      end loop;
+
+      --  Setup node for Sloc fixup if writing a debug source file. Note
+      --  that we take care of any previous node not yet properly set.
+
+      if Debug_Generated_Code then
+         Debug_Node := Node;
+      end if;
+
+      if Nkind (Node) in N_Subexpr
+        and then Do_Range_Check (Node)
+      then
+         Write_Str_With_Col_Check ("{");
+      end if;
+
+      --  Select print circuit based on node kind
+
+      case Nkind (Node) is
+
+         when N_Abort_Statement =>
+            Write_Indent_Str_Sloc ("abort ");
+            Sprint_Comma_List (Names (Node));
+            Write_Char (';');
+
+         when N_Abortable_Part =>
+            Set_Debug_Sloc;
+            Write_Str_Sloc ("abort ");
+            Sprint_Indented_List (Statements (Node));
+
+         when N_Abstract_Subprogram_Declaration =>
+            Write_Indent;
+            Sprint_Node (Specification (Node));
+            Write_Str_With_Col_Check (" is ");
+            Write_Str_Sloc ("abstract;");
+
+         when N_Accept_Alternative =>
+            Sprint_Node_List (Pragmas_Before (Node));
+
+            if Present (Condition (Node)) then
+               Write_Indent_Str ("when ");
+               Sprint_Node (Condition (Node));
+               Write_Str (" => ");
+               Indent_Annull;
+            end if;
+
+            Sprint_Node_Sloc (Accept_Statement (Node));
+            Sprint_Node_List (Statements (Node));
+
+         when N_Accept_Statement =>
+            Write_Indent_Str_Sloc ("accept ");
+            Write_Id (Entry_Direct_Name (Node));
+
+            if Present (Entry_Index (Node)) then
+               Write_Str_With_Col_Check (" (");
+               Sprint_Node (Entry_Index (Node));
+               Write_Char (')');
+            end if;
+
+            Write_Param_Specs (Node);
+
+            if Present (Handled_Statement_Sequence (Node)) then
+               Write_Str_With_Col_Check (" do");
+               Sprint_Node (Handled_Statement_Sequence (Node));
+               Write_Indent_Str ("end ");
+               Write_Id (Entry_Direct_Name (Node));
+            end if;
+
+            Write_Char (';');
+
+         when N_Access_Definition =>
+            Write_Str_With_Col_Check_Sloc ("access ");
+            Sprint_Node (Subtype_Mark (Node));
+
+         when N_Access_Function_Definition =>
+            Write_Str_With_Col_Check_Sloc ("access ");
+
+            if Protected_Present (Node) then
+               Write_Str_With_Col_Check ("protected ");
+            end if;
+
+            Write_Str_With_Col_Check ("function");
+            Write_Param_Specs (Node);
+            Write_Str_With_Col_Check (" return ");
+            Sprint_Node (Subtype_Mark (Node));
+
+         when N_Access_Procedure_Definition =>
+            Write_Str_With_Col_Check_Sloc ("access ");
+
+            if Protected_Present (Node) then
+               Write_Str_With_Col_Check ("protected ");
+            end if;
+
+            Write_Str_With_Col_Check ("procedure");
+            Write_Param_Specs (Node);
+
+         when N_Access_To_Object_Definition =>
+            Write_Str_With_Col_Check_Sloc ("access ");
+
+            if All_Present (Node) then
+               Write_Str_With_Col_Check ("all ");
+            elsif Constant_Present (Node) then
+               Write_Str_With_Col_Check ("constant ");
+            end if;
+
+            Sprint_Node (Subtype_Indication (Node));
+
+         when N_Aggregate =>
+            if Null_Record_Present (Node) then
+               Write_Str_With_Col_Check_Sloc ("(null record)");
+
+            else
+               Write_Str_With_Col_Check_Sloc ("(");
+
+               if Present (Expressions (Node)) then
+                  Sprint_Comma_List (Expressions (Node));
+
+                  if Present (Component_Associations (Node)) then
+                     Write_Str (", ");
+                  end if;
+               end if;
+
+               if Present (Component_Associations (Node)) then
+                  Indent_Begin;
+
+                  declare
+                     Nd : Node_Id;
+
+                  begin
+                     Nd := First (Component_Associations (Node));
+
+                     loop
+                        Write_Indent;
+                        Sprint_Node (Nd);
+                        Next (Nd);
+                        exit when No (Nd);
+
+                        if not Is_Rewrite_Insertion (Nd)
+                          or else not Dump_Original_Only
+                        then
+                           Write_Str (", ");
+                        end if;
+                     end loop;
+                  end;
+
+                  Indent_End;
+               end if;
+
+               Write_Char (')');
+            end if;
+
+         when N_Allocator =>
+            Write_Str_With_Col_Check_Sloc ("new ");
+            Sprint_Node (Expression (Node));
+
+            if Present (Storage_Pool (Node)) then
+               Write_Str_With_Col_Check ("[storage_pool = ");
+               Sprint_Node (Storage_Pool (Node));
+               Write_Char (']');
+            end if;
+
+         when N_And_Then =>
+            Sprint_Node (Left_Opnd (Node));
+            Write_Str_Sloc (" and then ");
+            Sprint_Node (Right_Opnd (Node));
+
+         when N_At_Clause =>
+            Write_Indent_Str_Sloc ("for ");
+            Write_Id (Identifier (Node));
+            Write_Str_With_Col_Check (" use at ");
+            Sprint_Node (Expression (Node));
+            Write_Char (';');
+
+         when N_Assignment_Statement =>
+            Write_Indent;
+            Sprint_Node (Name (Node));
+            Write_Str_Sloc (" := ");
+            Sprint_Node (Expression (Node));
+            Write_Char (';');
+
+         when N_Asynchronous_Select =>
+            Write_Indent_Str_Sloc ("select");
+            Indent_Begin;
+            Sprint_Node (Triggering_Alternative (Node));
+            Indent_End;
+
+            --  Note: let the printing of Abortable_Part handle outputting
+            --  the ABORT keyword, so that the Slco can be set correctly.
+
+            Write_Indent_Str ("then ");
+            Sprint_Node (Abortable_Part (Node));
+            Write_Indent_Str ("end select;");
+
+         when N_Attribute_Definition_Clause =>
+            Write_Indent_Str_Sloc ("for ");
+            Sprint_Node (Name (Node));
+            Write_Char (''');
+            Write_Name_With_Col_Check (Chars (Node));
+            Write_Str_With_Col_Check (" use ");
+            Sprint_Node (Expression (Node));
+            Write_Char (';');
+
+         when N_Attribute_Reference =>
+            if Is_Procedure_Attribute_Name (Attribute_Name (Node)) then
+               Write_Indent;
+            end if;
+
+            Sprint_Node (Prefix (Node));
+            Write_Char_Sloc (''');
+            Write_Name_With_Col_Check (Attribute_Name (Node));
+            Sprint_Paren_Comma_List (Expressions (Node));
+
+            if Is_Procedure_Attribute_Name (Attribute_Name (Node)) then
+               Write_Char (';');
+            end if;
+
+         when N_Block_Statement =>
+            Write_Indent;
+
+            if Present (Identifier (Node))
+              and then (not Has_Created_Identifier (Node)
+                          or else not Dump_Original_Only)
+            then
+               Write_Rewrite_Str ("<<<");
+               Write_Id (Identifier (Node));
+               Write_Str (" : ");
+               Write_Rewrite_Str (">>>");
+            end if;
+
+            if Present (Declarations (Node)) then
+               Write_Str_With_Col_Check_Sloc ("declare");
+               Sprint_Indented_List (Declarations (Node));
+               Write_Indent;
+            end if;
+
+            Write_Str_With_Col_Check_Sloc ("begin");
+            Sprint_Node (Handled_Statement_Sequence (Node));
+            Write_Indent_Str ("end");
+
+            if Present (Identifier (Node))
+              and then (not Has_Created_Identifier (Node)
+                          or else not Dump_Original_Only)
+            then
+               Write_Rewrite_Str ("<<<");
+               Write_Char (' ');
+               Write_Id (Identifier (Node));
+               Write_Rewrite_Str (">>>");
+            end if;
+
+            Write_Char (';');
+
+         when N_Case_Statement =>
+            Write_Indent_Str_Sloc ("case ");
+            Sprint_Node (Expression (Node));
+            Write_Str (" is");
+            Sprint_Indented_List (Alternatives (Node));
+            Write_Indent_Str ("end case;");
+
+         when N_Case_Statement_Alternative =>
+            Write_Indent_Str_Sloc ("when ");
+            Sprint_Bar_List (Discrete_Choices (Node));
+            Write_Str (" => ");
+            Sprint_Indented_List (Statements (Node));
+
+         when N_Character_Literal =>
+            if Column > 70 then
+               Write_Indent_Str ("  ");
+            end if;
+
+            Write_Char_Sloc (''');
+            Write_Char_Code (Char_Literal_Value (Node));
+            Write_Char (''');
+
+         when N_Code_Statement =>
+            Write_Indent;
+            Set_Debug_Sloc;
+            Sprint_Node (Expression (Node));
+            Write_Char (';');
+
+         when N_Compilation_Unit =>
+            Sprint_Node_List (Context_Items (Node));
+            Sprint_Opt_Node_List (Declarations (Aux_Decls_Node (Node)));
+
+            if Private_Present (Node) then
+               Write_Indent_Str ("private ");
+               Indent_Annull;
+            end if;
+
+            Sprint_Node_Sloc (Unit (Node));
+
+            if Present (Actions (Aux_Decls_Node (Node)))
+                 or else
+               Present (Pragmas_After (Aux_Decls_Node (Node)))
+            then
+               Write_Indent;
+            end if;
+
+            Sprint_Opt_Node_List (Actions (Aux_Decls_Node (Node)));
+            Sprint_Opt_Node_List (Pragmas_After (Aux_Decls_Node (Node)));
+
+         when N_Compilation_Unit_Aux =>
+            null; -- nothing to do, never used, see above
+
+         when N_Component_Association =>
+            Set_Debug_Sloc;
+            Sprint_Bar_List (Choices (Node));
+            Write_Str (" => ");
+            Sprint_Node (Expression (Node));
+
+         when N_Component_Clause =>
+            Write_Indent;
+            Sprint_Node (Component_Name (Node));
+            Write_Str_Sloc (" at ");
+            Sprint_Node (Position (Node));
+            Write_Char (' ');
+            Write_Str_With_Col_Check ("range ");
+            Sprint_Node (First_Bit (Node));
+            Write_Str (" .. ");
+            Sprint_Node (Last_Bit (Node));
+            Write_Char (';');
+
+         when N_Component_Declaration =>
+            if Write_Indent_Identifiers_Sloc (Node) then
+               Write_Str (" : ");
+
+               if Aliased_Present (Node) then
+                  Write_Str_With_Col_Check ("aliased ");
+               end if;
+
+               Sprint_Node (Subtype_Indication (Node));
+
+               if Present (Expression (Node)) then
+                  Write_Str (" := ");
+                  Sprint_Node (Expression (Node));
+               end if;
+
+               Write_Char (';');
+            end if;
+
+         when N_Component_List =>
+            if Null_Present (Node) then
+               Indent_Begin;
+               Write_Indent_Str_Sloc ("null");
+               Write_Char (';');
+               Indent_End;
+
+            else
+               Set_Debug_Sloc;
+               Sprint_Indented_List (Component_Items (Node));
+               Sprint_Node (Variant_Part (Node));
+            end if;
+
+         when N_Conditional_Entry_Call =>
+            Write_Indent_Str_Sloc ("select");
+            Indent_Begin;
+            Sprint_Node (Entry_Call_Alternative (Node));
+            Indent_End;
+            Write_Indent_Str ("else");
+            Sprint_Indented_List (Else_Statements (Node));
+            Write_Indent_Str ("end select;");
+
+         when N_Conditional_Expression =>
+            declare
+               Condition : constant Node_Id := First (Expressions (Node));
+               Then_Expr : constant Node_Id := Next (Condition);
+               Else_Expr : constant Node_Id := Next (Then_Expr);
+
+            begin
+               Write_Str_With_Col_Check_Sloc ("(if ");
+               Sprint_Node (Condition);
+               Write_Str_With_Col_Check (" then ");
+               Sprint_Node (Then_Expr);
+               Write_Str_With_Col_Check (" else ");
+               Sprint_Node (Else_Expr);
+               Write_Char (')');
+            end;
+
+         when N_Constrained_Array_Definition =>
+            Write_Str_With_Col_Check_Sloc ("array ");
+            Sprint_Paren_Comma_List (Discrete_Subtype_Definitions (Node));
+            Write_Str (" of ");
+
+            if Aliased_Present (Node) then
+               Write_Str_With_Col_Check ("aliased ");
+            end if;
+
+            Sprint_Node (Subtype_Indication (Node));
+
+         when N_Decimal_Fixed_Point_Definition =>
+            Write_Str_With_Col_Check_Sloc (" delta ");
+            Sprint_Node (Delta_Expression (Node));
+            Write_Str_With_Col_Check ("digits ");
+            Sprint_Node (Digits_Expression (Node));
+            Sprint_Opt_Node (Real_Range_Specification (Node));
+
+         when N_Defining_Character_Literal =>
+            Write_Name_With_Col_Check_Sloc (Chars (Node));
+
+         when N_Defining_Identifier =>
+            Set_Debug_Sloc;
+            Write_Id (Node);
+
+         when N_Defining_Operator_Symbol =>
+            Write_Name_With_Col_Check_Sloc (Chars (Node));
+
+         when N_Defining_Program_Unit_Name =>
+            Set_Debug_Sloc;
+            Sprint_Node (Name (Node));
+            Write_Char ('.');
+            Write_Id (Defining_Identifier (Node));
+
+         when N_Delay_Alternative =>
+            Sprint_Node_List (Pragmas_Before (Node));
+
+            if Present (Condition (Node)) then
+               Write_Indent;
+               Write_Str_With_Col_Check ("when ");
+               Sprint_Node (Condition (Node));
+               Write_Str (" => ");
+               Indent_Annull;
+            end if;
+
+            Sprint_Node_Sloc (Delay_Statement (Node));
+            Sprint_Node_List (Statements (Node));
+
+         when N_Delay_Relative_Statement =>
+            Write_Indent_Str_Sloc ("delay ");
+            Sprint_Node (Expression (Node));
+            Write_Char (';');
+
+         when N_Delay_Until_Statement =>
+            Write_Indent_Str_Sloc ("delay until ");
+            Sprint_Node (Expression (Node));
+            Write_Char (';');
+
+         when N_Delta_Constraint =>
+            Write_Str_With_Col_Check_Sloc ("delta ");
+            Sprint_Node (Delta_Expression (Node));
+            Sprint_Opt_Node (Range_Constraint (Node));
+
+         when N_Derived_Type_Definition =>
+            if Abstract_Present (Node) then
+               Write_Str_With_Col_Check ("abstract ");
+            end if;
+
+            Write_Str_With_Col_Check_Sloc ("new ");
+            Sprint_Node (Subtype_Indication (Node));
+
+            if Present (Record_Extension_Part (Node)) then
+               Write_Str_With_Col_Check (" with ");
+               Sprint_Node (Record_Extension_Part (Node));
+            end if;
+
+         when N_Designator =>
+            Sprint_Node (Name (Node));
+            Write_Char_Sloc ('.');
+            Write_Id (Identifier (Node));
+
+         when N_Digits_Constraint =>
+            Write_Str_With_Col_Check_Sloc ("digits ");
+            Sprint_Node (Digits_Expression (Node));
+            Sprint_Opt_Node (Range_Constraint (Node));
+
+         when N_Discriminant_Association =>
+            Set_Debug_Sloc;
+
+            if Present (Selector_Names (Node)) then
+               Sprint_Bar_List (Selector_Names (Node));
+               Write_Str (" => ");
+            end if;
+
+            Set_Debug_Sloc;
+            Sprint_Node (Expression (Node));
+
+         when N_Discriminant_Specification =>
+            Set_Debug_Sloc;
+
+            if Write_Identifiers (Node) then
+               Write_Str (" : ");
+               Sprint_Node (Discriminant_Type (Node));
+
+               if Present (Expression (Node)) then
+                  Write_Str (" := ");
+                  Sprint_Node (Expression (Node));
+               end if;
+            else
+               Write_Str (", ");
+            end if;
+
+         when N_Elsif_Part =>
+            Write_Indent_Str_Sloc ("elsif ");
+            Sprint_Node (Condition (Node));
+            Write_Str_With_Col_Check (" then");
+            Sprint_Indented_List (Then_Statements (Node));
+
+         when N_Empty =>
+            null;
+
+         when N_Entry_Body =>
+            Write_Indent_Str_Sloc ("entry ");
+            Write_Id (Defining_Identifier (Node));
+            Sprint_Node (Entry_Body_Formal_Part (Node));
+            Write_Str_With_Col_Check (" is");
+            Sprint_Indented_List (Declarations (Node));
+            Write_Indent_Str ("begin");
+            Sprint_Node (Handled_Statement_Sequence (Node));
+            Write_Indent_Str ("end ");
+            Write_Id (Defining_Identifier (Node));
+            Write_Char (';');
+
+         when N_Entry_Body_Formal_Part =>
+            if Present (Entry_Index_Specification (Node)) then
+               Write_Str_With_Col_Check_Sloc (" (");
+               Sprint_Node (Entry_Index_Specification (Node));
+               Write_Char (')');
+            end if;
+
+            Write_Param_Specs (Node);
+            Write_Str_With_Col_Check_Sloc (" when ");
+            Sprint_Node (Condition (Node));
+
+         when N_Entry_Call_Alternative =>
+            Sprint_Node_List (Pragmas_Before (Node));
+            Sprint_Node_Sloc (Entry_Call_Statement (Node));
+            Sprint_Node_List (Statements (Node));
+
+         when N_Entry_Call_Statement =>
+            Write_Indent;
+            Sprint_Node_Sloc (Name (Node));
+            Sprint_Opt_Paren_Comma_List (Parameter_Associations (Node));
+            Write_Char (';');
+
+         when N_Entry_Declaration =>
+            Write_Indent_Str_Sloc ("entry ");
+            Write_Id (Defining_Identifier (Node));
+
+            if Present (Discrete_Subtype_Definition (Node)) then
+               Write_Str_With_Col_Check (" (");
+               Sprint_Node (Discrete_Subtype_Definition (Node));
+               Write_Char (')');
+            end if;
+
+            Write_Param_Specs (Node);
+            Write_Char (';');
+
+         when N_Entry_Index_Specification =>
+            Write_Str_With_Col_Check_Sloc ("for ");
+            Write_Id (Defining_Identifier (Node));
+            Write_Str_With_Col_Check (" in ");
+            Sprint_Node (Discrete_Subtype_Definition (Node));
+
+         when N_Enumeration_Representation_Clause =>
+            Write_Indent_Str_Sloc ("for ");
+            Write_Id (Identifier (Node));
+            Write_Str_With_Col_Check (" use ");
+            Sprint_Node (Array_Aggregate (Node));
+            Write_Char (';');
+
+         when N_Enumeration_Type_Definition =>
+            Set_Debug_Sloc;
+
+            --  Skip attempt to print Literals field if it's not there and
+            --  we are in package Standard (case of Character, which is
+            --  handled specially (without an explicit literals list).
+
+            if Sloc (Node) > Standard_Location
+              or else Present (Literals (Node))
+            then
+               Sprint_Paren_Comma_List (Literals (Node));
+            end if;
+
+         when N_Error =>
+            Write_Str_With_Col_Check_Sloc ("<error>");
+
+         when N_Exception_Declaration =>
+            if Write_Indent_Identifiers (Node) then
+               Write_Str_With_Col_Check (" : ");
+               Write_Str_Sloc ("exception;");
+            end if;
+
+         when N_Exception_Handler =>
+            Write_Indent_Str_Sloc ("when ");
+
+            if Present (Choice_Parameter (Node)) then
+               Sprint_Node (Choice_Parameter (Node));
+               Write_Str (" : ");
+            end if;
+
+            Sprint_Bar_List (Exception_Choices (Node));
+            Write_Str (" => ");
+            Sprint_Indented_List (Statements (Node));
+
+         when N_Exception_Renaming_Declaration =>
+            Write_Indent;
+            Set_Debug_Sloc;
+            Sprint_Node (Defining_Identifier (Node));
+            Write_Str_With_Col_Check (" : exception renames ");
+            Sprint_Node (Name (Node));
+            Write_Char (';');
+
+         when N_Exit_Statement =>
+            Write_Indent_Str_Sloc ("exit");
+            Sprint_Opt_Node (Name (Node));
+
+            if Present (Condition (Node)) then
+               Write_Str_With_Col_Check (" when ");
+               Sprint_Node (Condition (Node));
+            end if;
+
+            Write_Char (';');
+
+         when N_Explicit_Dereference =>
+            Sprint_Node (Prefix (Node));
+            Write_Char ('.');
+            Write_Str_Sloc ("all");
+
+         when N_Extension_Aggregate =>
+            Write_Str_With_Col_Check_Sloc ("(");
+            Sprint_Node (Ancestor_Part (Node));
+            Write_Str_With_Col_Check (" with ");
+
+            if Null_Record_Present (Node) then
+               Write_Str_With_Col_Check ("null record");
+            else
+               if Present (Expressions (Node)) then
+                  Sprint_Comma_List (Expressions (Node));
+
+                  if Present (Component_Associations (Node)) then
+                     Write_Str (", ");
+                  end if;
+               end if;
+
+               if Present (Component_Associations (Node)) then
+                  Sprint_Comma_List (Component_Associations (Node));
+               end if;
+            end if;
+
+            Write_Char (')');
+
+         when N_Floating_Point_Definition =>
+            Write_Str_With_Col_Check_Sloc ("digits ");
+            Sprint_Node (Digits_Expression (Node));
+            Sprint_Opt_Node (Real_Range_Specification (Node));
+
+         when N_Formal_Decimal_Fixed_Point_Definition =>
+            Write_Str_With_Col_Check_Sloc ("delta <> digits <>");
+
+         when N_Formal_Derived_Type_Definition =>
+            Write_Str_With_Col_Check_Sloc ("new ");
+            Sprint_Node (Subtype_Mark (Node));
+
+            if Private_Present (Node) then
+               Write_Str_With_Col_Check (" with private");
+            end if;
+
+         when N_Formal_Discrete_Type_Definition =>
+            Write_Str_With_Col_Check_Sloc ("<>");
+
+         when N_Formal_Floating_Point_Definition =>
+            Write_Str_With_Col_Check_Sloc ("digits <>");
+
+         when N_Formal_Modular_Type_Definition =>
+            Write_Str_With_Col_Check_Sloc ("mod <>");
+
+         when N_Formal_Object_Declaration =>
+            Set_Debug_Sloc;
+
+            if Write_Indent_Identifiers (Node) then
+               Write_Str (" : ");
+
+               if In_Present (Node) then
+                  Write_Str_With_Col_Check ("in ");
+               end if;
+
+               if Out_Present (Node) then
+                  Write_Str_With_Col_Check ("out ");
+               end if;
+
+               Sprint_Node (Subtype_Mark (Node));
+
+               if Present (Expression (Node)) then
+                  Write_Str (" := ");
+                  Sprint_Node (Expression (Node));
+               end if;
+
+               Write_Char (';');
+            end if;
+
+         when N_Formal_Ordinary_Fixed_Point_Definition =>
+            Write_Str_With_Col_Check_Sloc ("delta <>");
+
+         when N_Formal_Package_Declaration =>
+            Write_Indent_Str_Sloc ("with package ");
+            Write_Id (Defining_Identifier (Node));
+            Write_Str_With_Col_Check (" is new ");
+            Sprint_Node (Name (Node));
+            Write_Str_With_Col_Check (" (<>);");
+
+         when N_Formal_Private_Type_Definition =>
+            if Abstract_Present (Node) then
+               Write_Str_With_Col_Check ("abstract ");
+            end if;
+
+            if Tagged_Present (Node) then
+               Write_Str_With_Col_Check ("tagged ");
+            end if;
+
+            if Limited_Present (Node) then
+               Write_Str_With_Col_Check ("limited ");
+            end if;
+
+            Write_Str_With_Col_Check_Sloc ("private");
+
+         when N_Formal_Signed_Integer_Type_Definition =>
+            Write_Str_With_Col_Check_Sloc ("range <>");
+
+         when N_Formal_Subprogram_Declaration =>
+            Write_Indent_Str_Sloc ("with ");
+            Sprint_Node (Specification (Node));
+
+            if Box_Present (Node) then
+               Write_Str_With_Col_Check (" is <>");
+            elsif Present (Default_Name (Node)) then
+               Write_Str_With_Col_Check (" is ");
+               Sprint_Node (Default_Name (Node));
+            end if;
+
+            Write_Char (';');
+
+         when N_Formal_Type_Declaration =>
+            Write_Indent_Str_Sloc ("type ");
+            Write_Id (Defining_Identifier (Node));
+
+            if Present (Discriminant_Specifications (Node)) then
+               Write_Discr_Specs (Node);
+            elsif Unknown_Discriminants_Present (Node) then
+               Write_Str_With_Col_Check ("(<>)");
+            end if;
+
+            Write_Str_With_Col_Check (" is ");
+            Sprint_Node (Formal_Type_Definition (Node));
+            Write_Char (';');
+
+         when N_Free_Statement =>
+            Write_Indent_Str_Sloc ("free ");
+            Sprint_Node (Expression (Node));
+            Write_Char (';');
+
+         when N_Freeze_Entity =>
+            if Dump_Original_Only then
+               null;
+
+            elsif Present (Actions (Node)) or else Dump_Freeze_Null then
+               Write_Indent;
+               Write_Rewrite_Str ("<<<");
+               Write_Str_With_Col_Check_Sloc ("freeze ");
+               Write_Id (Entity (Node));
+               Write_Str (" [");
+
+               if No (Actions (Node)) then
+                  Write_Char (']');
+
+               else
+                  Freeze_Indent := Freeze_Indent + 1;
+                  Sprint_Indented_List (Actions (Node));
+                  Freeze_Indent := Freeze_Indent - 1;
+                  Write_Indent_Str ("]");
+               end if;
+
+               Write_Rewrite_Str (">>>");
+            end if;
+
+         when N_Full_Type_Declaration =>
+            Write_Indent_Str_Sloc ("type ");
+            Write_Id (Defining_Identifier (Node));
+            Write_Discr_Specs (Node);
+            Write_Str_With_Col_Check (" is ");
+            Sprint_Node (Type_Definition (Node));
+            Write_Char (';');
+
+         when N_Function_Call =>
+            Set_Debug_Sloc;
+            Sprint_Node (Name (Node));
+            Sprint_Opt_Paren_Comma_List (Parameter_Associations (Node));
+
+         when N_Function_Instantiation =>
+            Write_Indent_Str_Sloc ("function ");
+            Sprint_Node (Defining_Unit_Name (Node));
+            Write_Str_With_Col_Check (" is new ");
+            Sprint_Node (Name (Node));
+            Sprint_Opt_Paren_Comma_List (Generic_Associations (Node));
+            Write_Char (';');
+
+         when N_Function_Specification =>
+            Write_Str_With_Col_Check_Sloc ("function ");
+            Sprint_Node (Defining_Unit_Name (Node));
+            Write_Param_Specs (Node);
+            Write_Str_With_Col_Check (" return ");
+            Sprint_Node (Subtype_Mark (Node));
+
+         when N_Generic_Association =>
+            Set_Debug_Sloc;
+
+            if Present (Selector_Name (Node)) then
+               Sprint_Node (Selector_Name (Node));
+               Write_Str (" => ");
+            end if;
+
+            Sprint_Node (Explicit_Generic_Actual_Parameter (Node));
+
+         when N_Generic_Function_Renaming_Declaration =>
+            Write_Indent_Str_Sloc ("generic function ");
+            Sprint_Node (Defining_Unit_Name (Node));
+            Write_Str_With_Col_Check (" renames ");
+            Sprint_Node (Name (Node));
+            Write_Char (';');
+
+         when N_Generic_Package_Declaration =>
+            Write_Indent;
+            Write_Indent_Str_Sloc ("generic ");
+            Sprint_Indented_List (Generic_Formal_Declarations (Node));
+            Write_Indent;
+            Sprint_Node (Specification (Node));
+            Write_Char (';');
+
+         when N_Generic_Package_Renaming_Declaration =>
+            Write_Indent_Str_Sloc ("generic package ");
+            Sprint_Node (Defining_Unit_Name (Node));
+            Write_Str_With_Col_Check (" renames ");
+            Sprint_Node (Name (Node));
+            Write_Char (';');
+
+         when N_Generic_Procedure_Renaming_Declaration =>
+            Write_Indent_Str_Sloc ("generic procedure ");
+            Sprint_Node (Defining_Unit_Name (Node));
+            Write_Str_With_Col_Check (" renames ");
+            Sprint_Node (Name (Node));
+            Write_Char (';');
+
+         when N_Generic_Subprogram_Declaration =>
+            Write_Indent;
+            Write_Indent_Str_Sloc ("generic ");
+            Sprint_Indented_List (Generic_Formal_Declarations (Node));
+            Write_Indent;
+            Sprint_Node (Specification (Node));
+            Write_Char (';');
+
+         when N_Goto_Statement =>
+            Write_Indent_Str_Sloc ("goto ");
+            Sprint_Node (Name (Node));
+            Write_Char (';');
+
+            if Nkind (Next (Node)) = N_Label then
+               Write_Indent;
+            end if;
+
+         when N_Handled_Sequence_Of_Statements =>
+            Set_Debug_Sloc;
+            Sprint_Indented_List (Statements (Node));
+
+            if Present (Exception_Handlers (Node)) then
+               Write_Indent_Str ("exception");
+               Indent_Begin;
+               Sprint_Node_List (Exception_Handlers (Node));
+               Indent_End;
+            end if;
+
+            if Present (At_End_Proc (Node)) then
+               Write_Indent_Str ("at end");
+               Indent_Begin;
+               Write_Indent;
+               Sprint_Node (At_End_Proc (Node));
+               Write_Char (';');
+               Indent_End;
+            end if;
+
+         when N_Identifier =>
+            Set_Debug_Sloc;
+            Write_Id (Node);
+
+         when N_If_Statement =>
+            Write_Indent_Str_Sloc ("if ");
+            Sprint_Node (Condition (Node));
+            Write_Str_With_Col_Check (" then");
+            Sprint_Indented_List (Then_Statements (Node));
+            Sprint_Opt_Node_List (Elsif_Parts (Node));
+
+            if Present (Else_Statements (Node)) then
+               Write_Indent_Str ("else");
+               Sprint_Indented_List (Else_Statements (Node));
+            end if;
+
+            Write_Indent_Str ("end if;");
+
+         when N_Implicit_Label_Declaration =>
+            if not Dump_Original_Only then
+               Write_Indent;
+               Write_Rewrite_Str ("<<<");
+               Set_Debug_Sloc;
+               Write_Id (Defining_Identifier (Node));
+               Write_Str (" : ");
+               Write_Str_With_Col_Check ("label");
+               Write_Rewrite_Str (">>>");
+            end if;
+
+         when N_In =>
+            Sprint_Node (Left_Opnd (Node));
+            Write_Str_Sloc (" in ");
+            Sprint_Node (Right_Opnd (Node));
+
+         when N_Incomplete_Type_Declaration =>
+            Write_Indent_Str_Sloc ("type ");
+            Write_Id (Defining_Identifier (Node));
+
+            if Present (Discriminant_Specifications (Node)) then
+               Write_Discr_Specs (Node);
+            elsif Unknown_Discriminants_Present (Node) then
+               Write_Str_With_Col_Check ("(<>)");
+            end if;
+
+            Write_Char (';');
+
+         when N_Index_Or_Discriminant_Constraint =>
+            Set_Debug_Sloc;
+            Sprint_Paren_Comma_List (Constraints (Node));
+
+         when N_Indexed_Component =>
+            Sprint_Node_Sloc (Prefix (Node));
+            Sprint_Opt_Paren_Comma_List (Expressions (Node));
+
+         when N_Integer_Literal =>
+            if Print_In_Hex (Node) then
+               Write_Uint_With_Col_Check_Sloc (Intval (Node), Hex);
+            else
+               Write_Uint_With_Col_Check_Sloc (Intval (Node), Auto);
+            end if;
+
+         when N_Iteration_Scheme =>
+            if Present (Condition (Node)) then
+               Write_Str_With_Col_Check_Sloc ("while ");
+               Sprint_Node (Condition (Node));
+            else
+               Write_Str_With_Col_Check_Sloc ("for ");
+               Sprint_Node (Loop_Parameter_Specification (Node));
+            end if;
+
+            Write_Char (' ');
+
+         when N_Itype_Reference =>
+            Write_Indent_Str_Sloc ("reference ");
+            Write_Id (Itype (Node));
+
+         when N_Label =>
+            Write_Indent_Str_Sloc ("<<");
+            Write_Id (Identifier (Node));
+            Write_Str (">>");
+
+         when N_Loop_Parameter_Specification =>
+            Set_Debug_Sloc;
+            Write_Id (Defining_Identifier (Node));
+            Write_Str_With_Col_Check (" in ");
+
+            if Reverse_Present (Node) then
+               Write_Str_With_Col_Check ("reverse ");
+            end if;
+
+            Sprint_Node (Discrete_Subtype_Definition (Node));
+
+         when N_Loop_Statement =>
+            Write_Indent;
+
+            if Present (Identifier (Node))
+              and then (not Has_Created_Identifier (Node)
+                          or else not Dump_Original_Only)
+            then
+               Write_Rewrite_Str ("<<<");
+               Write_Id (Identifier (Node));
+               Write_Str (" : ");
+               Write_Rewrite_Str (">>>");
+               Sprint_Node (Iteration_Scheme (Node));
+               Write_Str_With_Col_Check_Sloc ("loop");
+               Sprint_Indented_List (Statements (Node));
+               Write_Indent_Str ("end loop ");
+               Write_Rewrite_Str ("<<<");
+               Write_Id (Identifier (Node));
+               Write_Rewrite_Str (">>>");
+               Write_Char (';');
+
+            else
+               Sprint_Node (Iteration_Scheme (Node));
+               Write_Str_With_Col_Check_Sloc ("loop");
+               Sprint_Indented_List (Statements (Node));
+               Write_Indent_Str ("end loop;");
+            end if;
+
+         when N_Mod_Clause =>
+            Sprint_Node_List (Pragmas_Before (Node));
+            Write_Str_With_Col_Check_Sloc ("at mod ");
+            Sprint_Node (Expression (Node));
+
+         when N_Modular_Type_Definition =>
+            Write_Str_With_Col_Check_Sloc ("mod ");
+            Sprint_Node (Expression (Node));
+
+         when N_Not_In =>
+            Sprint_Node (Left_Opnd (Node));
+            Write_Str_Sloc (" not in ");
+            Sprint_Node (Right_Opnd (Node));
+
+         when N_Null =>
+            Write_Str_With_Col_Check_Sloc ("null");
+
+         when N_Null_Statement =>
+            if Comes_From_Source (Node)
+              or else Dump_Freeze_Null
+              or else not Is_List_Member (Node)
+              or else (No (Prev (Node)) and then No (Next (Node)))
+            then
+               Write_Indent_Str_Sloc ("null;");
+            end if;
+
+         when N_Number_Declaration =>
+            Set_Debug_Sloc;
+
+            if Write_Indent_Identifiers (Node) then
+               Write_Str_With_Col_Check (" : constant ");
+               Write_Str (" := ");
+               Sprint_Node (Expression (Node));
+               Write_Char (';');
+            end if;
+
+         when N_Object_Declaration =>
+
+            --  Put extra blank line before and after if this is a handler
+            --  record or a subprogram descriptor.
+
+            declare
+               Typ : constant Entity_Id := Etype (Defining_Identifier (Node));
+               Exc : constant Boolean :=
+                       Is_RTE (Typ, RE_Handler_Record)
+                         or else
+                       Is_RTE (Typ, RE_Subprogram_Descriptor);
+
+            begin
+               if Exc then
+                  Write_Indent;
+               end if;
+
+               Set_Debug_Sloc;
+
+               if Write_Indent_Identifiers (Node) then
+                  Write_Str (" : ");
+
+                  if Aliased_Present (Node) then
+                     Write_Str_With_Col_Check ("aliased ");
+                  end if;
+
+                  if Constant_Present (Node) then
+                     Write_Str_With_Col_Check ("constant ");
+                  end if;
+
+                  Sprint_Node (Object_Definition (Node));
+
+                  if Present (Expression (Node)) then
+                     Write_Str (" := ");
+                     Sprint_Node (Expression (Node));
+                  end if;
+
+                  Write_Char (';');
+               end if;
+
+               if Exc then
+                  Write_Indent;
+               end if;
+            end;
+
+         when N_Object_Renaming_Declaration =>
+            Write_Indent;
+            Set_Debug_Sloc;
+            Sprint_Node (Defining_Identifier (Node));
+            Write_Str (" : ");
+            Sprint_Node (Subtype_Mark (Node));
+            Write_Str_With_Col_Check (" renames ");
+            Sprint_Node (Name (Node));
+            Write_Char (';');
+
+         when N_Op_Abs =>
+            Write_Operator (Node, "abs ");
+            Sprint_Node (Right_Opnd (Node));
+
+         when N_Op_Add =>
+            Sprint_Node (Left_Opnd (Node));
+            Write_Operator (Node, " + ");
+            Sprint_Node (Right_Opnd (Node));
+
+         when N_Op_And =>
+            Sprint_Node (Left_Opnd (Node));
+            Write_Operator (Node, " and ");
+            Sprint_Node (Right_Opnd (Node));
+
+         when N_Op_Concat =>
+            Sprint_Node (Left_Opnd (Node));
+            Write_Operator (Node, " & ");
+            Sprint_Node (Right_Opnd (Node));
+
+         when N_Op_Divide =>
+            Sprint_Node (Left_Opnd (Node));
+            Write_Char (' ');
+            Process_TFAI_RR_Flags (Node);
+            Write_Operator (Node, "/ ");
+            Sprint_Node (Right_Opnd (Node));
+
+         when N_Op_Eq =>
+            Sprint_Node (Left_Opnd (Node));
+            Write_Operator (Node, " = ");
+            Sprint_Node (Right_Opnd (Node));
+
+         when N_Op_Expon =>
+            Sprint_Node (Left_Opnd (Node));
+            Write_Operator (Node, " ** ");
+            Sprint_Node (Right_Opnd (Node));
+
+         when N_Op_Ge =>
+            Sprint_Node (Left_Opnd (Node));
+            Write_Operator (Node, " >= ");
+            Sprint_Node (Right_Opnd (Node));
+
+         when N_Op_Gt =>
+            Sprint_Node (Left_Opnd (Node));
+            Write_Operator (Node, " > ");
+            Sprint_Node (Right_Opnd (Node));
+
+         when N_Op_Le =>
+            Sprint_Node (Left_Opnd (Node));
+            Write_Operator (Node, " <= ");
+            Sprint_Node (Right_Opnd (Node));
+
+         when N_Op_Lt =>
+            Sprint_Node (Left_Opnd (Node));
+            Write_Operator (Node, " < ");
+            Sprint_Node (Right_Opnd (Node));
+
+         when N_Op_Minus =>
+            Write_Operator (Node, "-");
+            Sprint_Node (Right_Opnd (Node));
+
+         when N_Op_Mod =>
+            Sprint_Node (Left_Opnd (Node));
+
+            if Treat_Fixed_As_Integer (Node) then
+               Write_Str (" #");
+            end if;
+
+            Write_Operator (Node, " mod ");
+            Sprint_Node (Right_Opnd (Node));
+
+         when N_Op_Multiply =>
+            Sprint_Node (Left_Opnd (Node));
+            Write_Char (' ');
+            Process_TFAI_RR_Flags (Node);
+            Write_Operator (Node, "* ");
+            Sprint_Node (Right_Opnd (Node));
+
+         when N_Op_Ne =>
+            Sprint_Node (Left_Opnd (Node));
+            Write_Operator (Node, " /= ");
+            Sprint_Node (Right_Opnd (Node));
+
+         when N_Op_Not =>
+            Write_Operator (Node, "not ");
+            Sprint_Node (Right_Opnd (Node));
+
+         when N_Op_Or =>
+            Sprint_Node (Left_Opnd (Node));
+            Write_Operator (Node, " or ");
+            Sprint_Node (Right_Opnd (Node));
+
+         when N_Op_Plus =>
+            Write_Operator (Node, "+");
+            Sprint_Node (Right_Opnd (Node));
+
+         when N_Op_Rem =>
+            Sprint_Node (Left_Opnd (Node));
+
+            if Treat_Fixed_As_Integer (Node) then
+               Write_Str (" #");
+            end if;
+
+            Write_Operator (Node, " rem ");
+            Sprint_Node (Right_Opnd (Node));
+
+         when N_Op_Shift =>
+            Set_Debug_Sloc;
+            Write_Id (Node);
+            Write_Char ('!');
+            Write_Str_With_Col_Check ("(");
+            Sprint_Node (Left_Opnd (Node));
+            Write_Str (", ");
+            Sprint_Node (Right_Opnd (Node));
+            Write_Char (')');
+
+         when N_Op_Subtract =>
+            Sprint_Node (Left_Opnd (Node));
+            Write_Operator (Node, " - ");
+            Sprint_Node (Right_Opnd (Node));
+
+         when N_Op_Xor =>
+            Sprint_Node (Left_Opnd (Node));
+            Write_Operator (Node, " xor ");
+            Sprint_Node (Right_Opnd (Node));
+
+         when N_Operator_Symbol =>
+            Write_Name_With_Col_Check_Sloc (Chars (Node));
+
+         when N_Ordinary_Fixed_Point_Definition =>
+            Write_Str_With_Col_Check_Sloc ("delta ");
+            Sprint_Node (Delta_Expression (Node));
+            Sprint_Opt_Node (Real_Range_Specification (Node));
+
+         when N_Or_Else =>
+            Sprint_Node (Left_Opnd (Node));
+            Write_Str_Sloc (" or else ");
+            Sprint_Node (Right_Opnd (Node));
+
+         when N_Others_Choice =>
+            if All_Others (Node) then
+               Write_Str_With_Col_Check ("all ");
+            end if;
+
+            Write_Str_With_Col_Check_Sloc ("others");
+
+         when N_Package_Body =>
+            Write_Indent;
+            Write_Indent_Str_Sloc ("package body ");
+            Sprint_Node (Defining_Unit_Name (Node));
+            Write_Str (" is");
+            Sprint_Indented_List (Declarations (Node));
+
+            if Present (Handled_Statement_Sequence (Node)) then
+               Write_Indent_Str ("begin");
+               Sprint_Node (Handled_Statement_Sequence (Node));
+            end if;
+
+            Write_Indent_Str ("end ");
+            Sprint_Node (Defining_Unit_Name (Node));
+            Write_Char (';');
+
+         when N_Package_Body_Stub =>
+            Write_Indent_Str_Sloc ("package body ");
+            Sprint_Node (Defining_Identifier (Node));
+            Write_Str_With_Col_Check (" is separate;");
+
+         when N_Package_Declaration =>
+            Write_Indent;
+            Write_Indent;
+            Sprint_Node_Sloc (Specification (Node));
+            Write_Char (';');
+
+         when N_Package_Instantiation =>
+            Write_Indent;
+            Write_Indent_Str_Sloc ("package ");
+            Sprint_Node (Defining_Unit_Name (Node));
+            Write_Str (" is new ");
+            Sprint_Node (Name (Node));
+            Sprint_Opt_Paren_Comma_List (Generic_Associations (Node));
+            Write_Char (';');
+
+         when N_Package_Renaming_Declaration =>
+            Write_Indent_Str_Sloc ("package ");
+            Sprint_Node (Defining_Unit_Name (Node));
+            Write_Str_With_Col_Check (" renames ");
+            Sprint_Node (Name (Node));
+            Write_Char (';');
+
+         when N_Package_Specification =>
+            Write_Str_With_Col_Check_Sloc ("package ");
+            Sprint_Node (Defining_Unit_Name (Node));
+            Write_Str (" is");
+            Sprint_Indented_List (Visible_Declarations (Node));
+
+            if Present (Private_Declarations (Node)) then
+               Write_Indent_Str ("private");
+               Sprint_Indented_List (Private_Declarations (Node));
+            end if;
+
+            Write_Indent_Str ("end ");
+            Sprint_Node (Defining_Unit_Name (Node));
+
+         when N_Parameter_Association =>
+            Sprint_Node_Sloc (Selector_Name (Node));
+            Write_Str (" => ");
+            Sprint_Node (Explicit_Actual_Parameter (Node));
+
+         when N_Parameter_Specification =>
+            Set_Debug_Sloc;
+
+            if Write_Identifiers (Node) then
+               Write_Str (" : ");
+
+               if In_Present (Node) then
+                  Write_Str_With_Col_Check ("in ");
+               end if;
+
+               if Out_Present (Node) then
+                  Write_Str_With_Col_Check ("out ");
+               end if;
+
+               Sprint_Node (Parameter_Type (Node));
+
+               if Present (Expression (Node)) then
+                  Write_Str (" := ");
+                  Sprint_Node (Expression (Node));
+               end if;
+            else
+               Write_Str (", ");
+            end if;
+
+         when N_Pragma =>
+            Write_Indent_Str_Sloc ("pragma ");
+            Write_Name_With_Col_Check (Chars (Node));
+
+            if Present (Pragma_Argument_Associations (Node)) then
+               Sprint_Opt_Paren_Comma_List
+                 (Pragma_Argument_Associations (Node));
+            end if;
+
+            Write_Char (';');
+
+         when N_Pragma_Argument_Association =>
+            Set_Debug_Sloc;
+
+            if Chars (Node) /= No_Name then
+               Write_Name_With_Col_Check (Chars (Node));
+               Write_Str (" => ");
+            end if;
+
+            Sprint_Node (Expression (Node));
+
+         when N_Private_Type_Declaration =>
+            Write_Indent_Str_Sloc ("type ");
+            Write_Id (Defining_Identifier (Node));
+
+            if Present (Discriminant_Specifications (Node)) then
+               Write_Discr_Specs (Node);
+            elsif Unknown_Discriminants_Present (Node) then
+               Write_Str_With_Col_Check ("(<>)");
+            end if;
+
+            Write_Str (" is ");
+
+            if Tagged_Present (Node) then
+               Write_Str_With_Col_Check ("tagged ");
+            end if;
+
+            if Limited_Present (Node) then
+               Write_Str_With_Col_Check ("limited ");
+            end if;
+
+            Write_Str_With_Col_Check ("private;");
+
+         when N_Private_Extension_Declaration =>
+            Write_Indent_Str_Sloc ("type ");
+            Write_Id (Defining_Identifier (Node));
+
+            if Present (Discriminant_Specifications (Node)) then
+               Write_Discr_Specs (Node);
+            elsif Unknown_Discriminants_Present (Node) then
+               Write_Str_With_Col_Check ("(<>)");
+            end if;
+
+            Write_Str_With_Col_Check (" is new ");
+            Sprint_Node (Subtype_Indication (Node));
+            Write_Str_With_Col_Check (" with private;");
+
+         when N_Procedure_Call_Statement =>
+            Write_Indent;
+            Set_Debug_Sloc;
+            Sprint_Node (Name (Node));
+            Sprint_Opt_Paren_Comma_List (Parameter_Associations (Node));
+            Write_Char (';');
+
+         when N_Procedure_Instantiation =>
+            Write_Indent_Str_Sloc ("procedure ");
+            Sprint_Node (Defining_Unit_Name (Node));
+            Write_Str_With_Col_Check (" is new ");
+            Sprint_Node (Name (Node));
+            Sprint_Opt_Paren_Comma_List (Generic_Associations (Node));
+            Write_Char (';');
+
+         when N_Procedure_Specification =>
+            Write_Str_With_Col_Check_Sloc ("procedure ");
+            Sprint_Node (Defining_Unit_Name (Node));
+            Write_Param_Specs (Node);
+
+         when N_Protected_Body =>
+            Write_Indent_Str_Sloc ("protected body ");
+            Write_Id (Defining_Identifier (Node));
+            Write_Str (" is");
+            Sprint_Indented_List (Declarations (Node));
+            Write_Indent_Str ("end ");
+            Write_Id (Defining_Identifier (Node));
+            Write_Char (';');
+
+         when N_Protected_Body_Stub =>
+            Write_Indent_Str_Sloc ("protected body ");
+            Write_Id (Defining_Identifier (Node));
+            Write_Str_With_Col_Check (" is separate;");
+
+         when N_Protected_Definition =>
+            Set_Debug_Sloc;
+            Sprint_Indented_List (Visible_Declarations (Node));
+
+            if Present (Private_Declarations (Node)) then
+               Write_Indent_Str ("private");
+               Sprint_Indented_List (Private_Declarations (Node));
+            end if;
+
+            Write_Indent_Str ("end ");
+
+         when N_Protected_Type_Declaration =>
+            Write_Indent_Str_Sloc ("protected type ");
+            Write_Id (Defining_Identifier (Node));
+            Write_Discr_Specs (Node);
+            Write_Str (" is");
+            Sprint_Node (Protected_Definition (Node));
+            Write_Id (Defining_Identifier (Node));
+            Write_Char (';');
+
+         when N_Qualified_Expression =>
+            Sprint_Node (Subtype_Mark (Node));
+            Write_Char_Sloc (''');
+            Sprint_Node (Expression (Node));
+
+         when N_Raise_Constraint_Error =>
+
+            --  This node can be used either as a subexpression or as a
+            --  statement form. The following test is a reasonably reliable
+            --  way to distinguish the two cases.
+
+            if Is_List_Member (Node)
+              and then Nkind (Parent (Node)) not in N_Subexpr
+            then
+               Write_Indent;
+            end if;
+
+            Write_Str_With_Col_Check_Sloc ("[constraint_error");
+
+            if Present (Condition (Node)) then
+               Write_Str_With_Col_Check (" when ");
+               Sprint_Node (Condition (Node));
+            end if;
+
+            Write_Char (']');
+
+         when N_Raise_Program_Error =>
+            Write_Indent;
+            Write_Str_With_Col_Check_Sloc ("[program_error");
+
+            if Present (Condition (Node)) then
+               Write_Str_With_Col_Check (" when ");
+               Sprint_Node (Condition (Node));
+            end if;
+
+            Write_Char (']');
+
+         when N_Raise_Storage_Error =>
+            Write_Indent;
+            Write_Str_With_Col_Check_Sloc ("[storage_error");
+
+            if Present (Condition (Node)) then
+               Write_Str_With_Col_Check (" when ");
+               Sprint_Node (Condition (Node));
+            end if;
+
+            Write_Char (']');
+
+         when N_Raise_Statement =>
+            Write_Indent_Str_Sloc ("raise ");
+            Sprint_Node (Name (Node));
+            Write_Char (';');
+
+         when N_Range =>
+            Sprint_Node (Low_Bound (Node));
+            Write_Str_Sloc (" .. ");
+            Sprint_Node (High_Bound (Node));
+
+         when N_Range_Constraint =>
+            Write_Str_With_Col_Check_Sloc ("range ");
+            Sprint_Node (Range_Expression (Node));
+
+         when N_Real_Literal =>
+            Write_Ureal_With_Col_Check_Sloc (Realval (Node));
+
+         when N_Real_Range_Specification =>
+            Write_Str_With_Col_Check_Sloc ("range ");
+            Sprint_Node (Low_Bound (Node));
+            Write_Str (" .. ");
+            Sprint_Node (High_Bound (Node));
+
+         when N_Record_Definition =>
+            if Abstract_Present (Node) then
+               Write_Str_With_Col_Check ("abstract ");
+            end if;
+
+            if Tagged_Present (Node) then
+               Write_Str_With_Col_Check ("tagged ");
+            end if;
+
+            if Limited_Present (Node) then
+               Write_Str_With_Col_Check ("limited ");
+            end if;
+
+            if Null_Present (Node) then
+               Write_Str_With_Col_Check_Sloc ("null record");
+
+            else
+               Write_Str_With_Col_Check_Sloc ("record");
+               Sprint_Node (Component_List (Node));
+               Write_Indent_Str ("end record");
+            end if;
+
+         when N_Record_Representation_Clause =>
+            Write_Indent_Str_Sloc ("for ");
+            Sprint_Node (Identifier (Node));
+            Write_Str_With_Col_Check (" use record ");
+
+            if Present (Mod_Clause (Node)) then
+               Sprint_Node (Mod_Clause (Node));
+            end if;
+
+            Sprint_Indented_List (Component_Clauses (Node));
+            Write_Indent_Str ("end record;");
+
+         when N_Reference =>
+            Sprint_Node (Prefix (Node));
+            Write_Str_With_Col_Check_Sloc ("'reference");
+
+         when N_Requeue_Statement =>
+            Write_Indent_Str_Sloc ("requeue ");
+            Sprint_Node (Name (Node));
+
+            if Abort_Present (Node) then
+               Write_Str_With_Col_Check (" with abort");
+            end if;
+
+            Write_Char (';');
+
+         when N_Return_Statement =>
+            if Present (Expression (Node)) then
+               Write_Indent_Str_Sloc ("return ");
+               Sprint_Node (Expression (Node));
+               Write_Char (';');
+            else
+               Write_Indent_Str_Sloc ("return;");
+            end if;
+
+         when N_Selective_Accept =>
+            Write_Indent_Str_Sloc ("select");
+
+            declare
+               Alt_Node : Node_Id;
+
+            begin
+               Alt_Node := First (Select_Alternatives (Node));
+               loop
+                  Indent_Begin;
+                  Sprint_Node (Alt_Node);
+                  Indent_End;
+                  Next (Alt_Node);
+                  exit when No (Alt_Node);
+                  Write_Indent_Str ("or");
+               end loop;
+            end;
+
+            if Present (Else_Statements (Node)) then
+               Write_Indent_Str ("else");
+               Sprint_Indented_List (Else_Statements (Node));
+            end if;
+
+            Write_Indent_Str ("end select;");
+
+         when N_Signed_Integer_Type_Definition =>
+            Write_Str_With_Col_Check_Sloc ("range ");
+            Sprint_Node (Low_Bound (Node));
+            Write_Str (" .. ");
+            Sprint_Node (High_Bound (Node));
+
+         when N_Single_Protected_Declaration =>
+            Write_Indent_Str_Sloc ("protected ");
+            Write_Id (Defining_Identifier (Node));
+            Write_Str (" is");
+            Sprint_Node (Protected_Definition (Node));
+            Write_Id (Defining_Identifier (Node));
+            Write_Char (';');
+
+         when N_Single_Task_Declaration =>
+            Write_Indent_Str_Sloc ("task ");
+            Write_Id (Defining_Identifier (Node));
+
+            if Present (Task_Definition (Node)) then
+               Write_Str (" is");
+               Sprint_Node (Task_Definition (Node));
+               Write_Id (Defining_Identifier (Node));
+            end if;
+
+            Write_Char (';');
+
+         when N_Selected_Component | N_Expanded_Name =>
+            Sprint_Node (Prefix (Node));
+            Write_Char_Sloc ('.');
+            Sprint_Node (Selector_Name (Node));
+
+         when N_Slice =>
+            Set_Debug_Sloc;
+            Sprint_Node (Prefix (Node));
+            Write_Str_With_Col_Check (" (");
+            Sprint_Node (Discrete_Range (Node));
+            Write_Char (')');
+
+         when N_String_Literal =>
+            if String_Length (Strval (Node)) + Column > 75 then
+               Write_Indent_Str ("  ");
+            end if;
+
+            Set_Debug_Sloc;
+            Write_String_Table_Entry (Strval (Node));
+
+         when N_Subprogram_Body =>
+            if Freeze_Indent = 0 then
+               Write_Indent;
+            end if;
+
+            Write_Indent;
+            Sprint_Node_Sloc (Specification (Node));
+            Write_Str (" is");
+
+            Sprint_Indented_List (Declarations (Node));
+            Write_Indent_Str ("begin");
+            Sprint_Node (Handled_Statement_Sequence (Node));
+
+            Write_Indent_Str ("end ");
+            Sprint_Node (Defining_Unit_Name (Specification (Node)));
+            Write_Char (';');
+
+            if Is_List_Member (Node)
+              and then Present (Next (Node))
+              and then Nkind (Next (Node)) /= N_Subprogram_Body
+            then
+               Write_Indent;
+            end if;
+
+         when N_Subprogram_Body_Stub =>
+            Write_Indent;
+            Sprint_Node_Sloc (Specification (Node));
+            Write_Str_With_Col_Check (" is separate;");
+
+         when N_Subprogram_Declaration =>
+            Write_Indent;
+            Sprint_Node_Sloc (Specification (Node));
+            Write_Char (';');
+
+         when N_Subprogram_Info =>
+            Sprint_Node (Identifier (Node));
+            Write_Str_With_Col_Check_Sloc ("'subprogram_info");
+
+         when N_Subprogram_Renaming_Declaration =>
+            Write_Indent;
+            Sprint_Node (Specification (Node));
+            Write_Str_With_Col_Check_Sloc (" renames ");
+            Sprint_Node (Name (Node));
+            Write_Char (';');
+
+         when N_Subtype_Declaration =>
+            Write_Indent_Str_Sloc ("subtype ");
+            Write_Id (Defining_Identifier (Node));
+            Write_Str (" is ");
+            Sprint_Node (Subtype_Indication (Node));
+            Write_Char (';');
+
+         when N_Subtype_Indication =>
+            Sprint_Node_Sloc (Subtype_Mark (Node));
+            Write_Char (' ');
+            Sprint_Node (Constraint (Node));
+
+         when N_Subunit =>
+            Write_Indent_Str_Sloc ("separate (");
+            Sprint_Node (Name (Node));
+            Write_Char (')');
+            Print_Eol;
+            Sprint_Node (Proper_Body (Node));
+
+         when N_Task_Body =>
+            Write_Indent_Str_Sloc ("task body ");
+            Write_Id (Defining_Identifier (Node));
+            Write_Str (" is");
+            Sprint_Indented_List (Declarations (Node));
+            Write_Indent_Str ("begin");
+            Sprint_Node (Handled_Statement_Sequence (Node));
+            Write_Indent_Str ("end ");
+            Write_Id (Defining_Identifier (Node));
+            Write_Char (';');
+
+         when N_Task_Body_Stub =>
+            Write_Indent_Str_Sloc ("task body ");
+            Write_Id (Defining_Identifier (Node));
+            Write_Str_With_Col_Check (" is separate;");
+
+         when N_Task_Definition =>
+            Set_Debug_Sloc;
+            Sprint_Indented_List (Visible_Declarations (Node));
+
+            if Present (Private_Declarations (Node)) then
+               Write_Indent_Str ("private");
+               Sprint_Indented_List (Private_Declarations (Node));
+            end if;
+
+            Write_Indent_Str ("end ");
+
+         when N_Task_Type_Declaration =>
+            Write_Indent_Str_Sloc ("task type ");
+            Write_Id (Defining_Identifier (Node));
+            Write_Discr_Specs (Node);
+            if Present (Task_Definition (Node)) then
+               Write_Str (" is");
+               Sprint_Node (Task_Definition (Node));
+               Write_Id (Defining_Identifier (Node));
+            end if;
+
+            Write_Char (';');
+
+         when N_Terminate_Alternative =>
+            Sprint_Node_List (Pragmas_Before (Node));
+
+            Write_Indent;
+
+            if Present (Condition (Node)) then
+               Write_Str_With_Col_Check ("when ");
+               Sprint_Node (Condition (Node));
+               Write_Str (" => ");
+            end if;
+
+            Write_Str_With_Col_Check_Sloc ("terminate;");
+            Sprint_Node_List (Pragmas_After (Node));
+
+         when N_Timed_Entry_Call =>
+            Write_Indent_Str_Sloc ("select");
+            Indent_Begin;
+            Sprint_Node (Entry_Call_Alternative (Node));
+            Indent_End;
+            Write_Indent_Str ("or");
+            Indent_Begin;
+            Sprint_Node (Delay_Alternative (Node));
+            Indent_End;
+            Write_Indent_Str ("end select;");
+
+         when N_Triggering_Alternative =>
+            Sprint_Node_List (Pragmas_Before (Node));
+            Sprint_Node_Sloc (Triggering_Statement (Node));
+            Sprint_Node_List (Statements (Node));
+
+         when N_Type_Conversion =>
+            Set_Debug_Sloc;
+            Sprint_Node (Subtype_Mark (Node));
+            Col_Check (4);
+
+            if Conversion_OK (Node) then
+               Write_Char ('?');
+            end if;
+
+            if Float_Truncate (Node) then
+               Write_Char ('^');
+            end if;
+
+            if Rounded_Result (Node) then
+               Write_Char ('@');
+            end if;
+
+            Write_Char ('(');
+            Sprint_Node (Expression (Node));
+            Write_Char (')');
+
+         when N_Unchecked_Expression =>
+            Col_Check (10);
+            Write_Str ("`(");
+            Sprint_Node_Sloc (Expression (Node));
+            Write_Char (')');
+
+         when N_Unchecked_Type_Conversion =>
+            Sprint_Node (Subtype_Mark (Node));
+            Write_Char ('!');
+            Write_Str_With_Col_Check ("(");
+            Sprint_Node_Sloc (Expression (Node));
+            Write_Char (')');
+
+         when N_Unconstrained_Array_Definition =>
+            Write_Str_With_Col_Check_Sloc ("array (");
+
+            declare
+               Node1 : Node_Id;
+
+            begin
+               Node1 := First (Subtype_Marks (Node));
+               loop
+                  Sprint_Node (Node1);
+                  Write_Str_With_Col_Check (" range <>");
+                  Next (Node1);
+                  exit when Node1 = Empty;
+                  Write_Str (", ");
+               end loop;
+            end;
+
+            Write_Str (") of ");
+
+            if Aliased_Present (Node) then
+               Write_Str_With_Col_Check ("aliased ");
+            end if;
+
+            Sprint_Node (Subtype_Indication (Node));
+
+         when N_Unused_At_Start | N_Unused_At_End =>
+            Write_Indent_Str ("***** Error, unused node encountered *****");
+            Print_Eol;
+
+         when N_Use_Package_Clause =>
+            Write_Indent_Str_Sloc ("use ");
+            Sprint_Comma_List (Names (Node));
+            Write_Char (';');
+
+         when N_Use_Type_Clause =>
+            Write_Indent_Str_Sloc ("use type ");
+            Sprint_Comma_List (Subtype_Marks (Node));
+            Write_Char (';');
+
+         when N_Validate_Unchecked_Conversion =>
+            Write_Indent_Str_Sloc ("validate unchecked_conversion (");
+            Sprint_Node (Source_Type (Node));
+            Write_Str (", ");
+            Sprint_Node (Target_Type (Node));
+            Write_Str (");");
+
+         when N_Variant =>
+            Write_Indent_Str_Sloc ("when ");
+            Sprint_Bar_List (Discrete_Choices (Node));
+            Write_Str (" => ");
+            Sprint_Node (Component_List (Node));
+
+         when N_Variant_Part =>
+            Indent_Begin;
+            Write_Indent_Str_Sloc ("case ");
+            Sprint_Node (Name (Node));
+            Write_Str (" is ");
+            Sprint_Indented_List (Variants (Node));
+            Write_Indent_Str ("end case");
+            Indent_End;
+
+         when N_With_Clause =>
+
+            --  Special test, if we are dumping the original tree only,
+            --  then we want to eliminate the bogus with clauses that
+            --  correspond to the non-existent children of Text_IO.
+
+            if Dump_Original_Only
+              and then Is_Text_IO_Kludge_Unit (Name (Node))
+            then
+               null;
+
+            --  Normal case, output the with clause
+
+            else
+               if First_Name (Node) or else not Dump_Original_Only then
+                  Write_Indent_Str ("with ");
+               else
+                  Write_Str (", ");
+               end if;
+
+               Sprint_Node_Sloc (Name (Node));
+
+               if Last_Name (Node) or else not Dump_Original_Only then
+                  Write_Char (';');
+               end if;
+            end if;
+
+         when N_With_Type_Clause =>
+
+            Write_Indent_Str ("with type ");
+            Sprint_Node_Sloc (Name (Node));
+
+            if Tagged_Present (Node) then
+               Write_Str (" is tagged;");
+            else
+               Write_Str (" is access;");
+            end if;
+
+      end case;
+
+      if Nkind (Node) in N_Subexpr
+        and then Do_Range_Check (Node)
+      then
+         Write_Str ("}");
+      end if;
+
+      for J in 1 .. Paren_Count (Node) loop
+         Write_Char (')');
+      end loop;
+
+      pragma Assert (No (Debug_Node));
+      Debug_Node := Save_Debug_Node;
+   end Sprint_Node_Actual;
+
+   ----------------------
+   -- Sprint_Node_List --
+   ----------------------
+
+   procedure Sprint_Node_List (List : List_Id) is
+      Node : Node_Id;
+
+   begin
+      if Is_Non_Empty_List (List) then
+         Node := First (List);
+
+         loop
+            Sprint_Node (Node);
+            Next (Node);
+            exit when Node = Empty;
+         end loop;
+      end if;
+   end Sprint_Node_List;
+
+   ----------------------
+   -- Sprint_Node_Sloc --
+   ----------------------
+
+   procedure Sprint_Node_Sloc (Node : Node_Id) is
+   begin
+      Sprint_Node (Node);
+
+      if Present (Debug_Node) then
+         Set_Sloc (Debug_Node, Sloc (Node));
+         Debug_Node := Empty;
+      end if;
+   end Sprint_Node_Sloc;
+
+   ---------------------
+   -- Sprint_Opt_Node --
+   ---------------------
+
+   procedure Sprint_Opt_Node (Node : Node_Id) is
+   begin
+      if Present (Node) then
+         Write_Char (' ');
+         Sprint_Node (Node);
+      end if;
+   end Sprint_Opt_Node;
+
+   --------------------------
+   -- Sprint_Opt_Node_List --
+   --------------------------
+
+   procedure Sprint_Opt_Node_List (List : List_Id) is
+   begin
+      if Present (List) then
+         Sprint_Node_List (List);
+      end if;
+   end Sprint_Opt_Node_List;
+
+   ---------------------------------
+   -- Sprint_Opt_Paren_Comma_List --
+   ---------------------------------
+
+   procedure Sprint_Opt_Paren_Comma_List (List : List_Id) is
+   begin
+      if Is_Non_Empty_List (List) then
+         Write_Char (' ');
+         Sprint_Paren_Comma_List (List);
+      end if;
+   end Sprint_Opt_Paren_Comma_List;
+
+   -----------------------------
+   -- Sprint_Paren_Comma_List --
+   -----------------------------
+
+   procedure Sprint_Paren_Comma_List (List : List_Id) is
+      N           : Node_Id;
+      Node_Exists : Boolean := False;
+
+   begin
+
+      if Is_Non_Empty_List (List) then
+
+         if Dump_Original_Only then
+            N := First (List);
+
+            while Present (N) loop
+
+               if not Is_Rewrite_Insertion (N) then
+                  Node_Exists := True;
+                  exit;
+               end if;
+
+               Next (N);
+            end loop;
+
+            if not Node_Exists then
+               return;
+            end if;
+         end if;
+
+         Write_Str_With_Col_Check ("(");
+         Sprint_Comma_List (List);
+         Write_Char (')');
+      end if;
+   end Sprint_Paren_Comma_List;
+
+   ---------------------
+   -- Write_Char_Sloc --
+   ---------------------
+
+   procedure Write_Char_Sloc (C : Character) is
+   begin
+      if Debug_Generated_Code and then C /= ' ' then
+         Set_Debug_Sloc;
+      end if;
+
+      Write_Char (C);
+   end Write_Char_Sloc;
+
+   ------------------------
+   --  Write_Discr_Specs --
+   ------------------------
+
+   procedure Write_Discr_Specs (N : Node_Id) is
+      Specs  : List_Id;
+      Spec   : Node_Id;
+
+   begin
+      Specs := Discriminant_Specifications (N);
+
+      if Present (Specs) then
+         Write_Str_With_Col_Check (" (");
+         Spec := First (Specs);
+
+         loop
+            Sprint_Node (Spec);
+            Next (Spec);
+            exit when Spec = Empty;
+
+            --  Add semicolon, unless we are printing original tree and the
+            --  next specification is part of a list (but not the first
+            --  element of that list)
+
+            if not Dump_Original_Only or else not Prev_Ids (Spec) then
+               Write_Str ("; ");
+            end if;
+         end loop;
+
+         Write_Char (')');
+      end if;
+   end Write_Discr_Specs;
+
+   -----------------
+   -- Write_Ekind --
+   -----------------
+
+   procedure Write_Ekind (E : Entity_Id) is
+      S : constant String := Entity_Kind'Image (Ekind (E));
+
+   begin
+      Name_Len := S'Length;
+      Name_Buffer (1 .. Name_Len) := S;
+      Set_Casing (Mixed_Case);
+      Write_Str_With_Col_Check (Name_Buffer (1 .. Name_Len));
+   end Write_Ekind;
+
+   --------------
+   -- Write_Id --
+   --------------
+
+   procedure Write_Id (N : Node_Id) is
+   begin
+      --  Case of a defining identifier
+
+      if Nkind (N) = N_Defining_Identifier then
+
+         --  If defining identifier has an interface name (and no
+         --  address clause), then we output the interface name.
+
+         if (Is_Imported (N) or else Is_Exported (N))
+           and then Present (Interface_Name (N))
+           and then No (Address_Clause (N))
+         then
+            String_To_Name_Buffer (Strval (Interface_Name (N)));
+            Write_Str_With_Col_Check (Name_Buffer (1 .. Name_Len));
+
+         --  If no interface name (or inactive because there was
+         --  an address clause), then just output the Chars name.
+
+         else
+            Write_Name_With_Col_Check (Chars (N));
+         end if;
+
+      --  Case of selector of an expanded name where the expanded name
+      --  has an associated entity, output this entity.
+
+      elsif Nkind (Parent (N)) = N_Expanded_Name
+        and then Selector_Name (Parent (N)) = N
+        and then Present (Entity (Parent (N)))
+      then
+         Write_Id (Entity (Parent (N)));
+
+      --  For any other kind of node with an associated entity, output it.
+
+      elsif Nkind (N) in N_Has_Entity
+        and then Present (Entity (N))
+      then
+         Write_Id (Entity (N));
+
+      --  All other cases, we just print the Chars field
+
+      else
+         Write_Name_With_Col_Check (Chars (N));
+      end if;
+   end Write_Id;
+
+   -----------------------
+   -- Write_Identifiers --
+   -----------------------
+
+   function Write_Identifiers (Node : Node_Id) return Boolean is
+   begin
+      Sprint_Node (Defining_Identifier (Node));
+
+      --  The remainder of the declaration must be printed unless we are
+      --  printing the original tree and this is not the last identifier
+
+      return
+         not Dump_Original_Only or else not More_Ids (Node);
+
+   end Write_Identifiers;
+
+   ------------------------
+   -- Write_Implicit_Def --
+   ------------------------
+
+   procedure Write_Implicit_Def (E : Entity_Id) is
+      Ind : Node_Id;
+
+   begin
+      case Ekind (E) is
+         when E_Array_Subtype =>
+            Write_Str_With_Col_Check ("subtype ");
+            Write_Id (E);
+            Write_Str_With_Col_Check (" is ");
+            Write_Id (Base_Type (E));
+            Write_Str_With_Col_Check (" (");
+
+            Ind := First_Index (E);
+
+            while Present (Ind) loop
+               Sprint_Node (Ind);
+               Next_Index (Ind);
+
+               if Present (Ind) then
+                  Write_Str (", ");
+               end if;
+            end loop;
+
+            Write_Str (");");
+
+         when E_Signed_Integer_Subtype | E_Enumeration_Subtype =>
+            Write_Str_With_Col_Check ("subtype ");
+            Write_Id (E);
+            Write_Str (" is ");
+            Write_Id (Etype (E));
+            Write_Str_With_Col_Check (" range ");
+            Sprint_Node (Scalar_Range (E));
+            Write_Str (";");
+
+         when others =>
+            Write_Str_With_Col_Check ("type ");
+            Write_Id (E);
+            Write_Str_With_Col_Check (" is <");
+            Write_Ekind (E);
+            Write_Str (">;");
+      end case;
+
+   end Write_Implicit_Def;
+
+   ------------------
+   -- Write_Indent --
+   ------------------
+
+   procedure Write_Indent is
+   begin
+      if Indent_Annull_Flag then
+         Indent_Annull_Flag := False;
+      else
+         Print_Eol;
+         for J in 1 .. Indent loop
+            Write_Char (' ');
+         end loop;
+      end if;
+   end Write_Indent;
+
+   ------------------------------
+   -- Write_Indent_Identifiers --
+   ------------------------------
+
+   function Write_Indent_Identifiers (Node : Node_Id) return Boolean is
+   begin
+      --  We need to start a new line for every node, except in the case
+      --  where we are printing the original tree and this is not the first
+      --  defining identifier in the list.
+
+      if not Dump_Original_Only or else not Prev_Ids (Node) then
+         Write_Indent;
+
+      --  If printing original tree and this is not the first defining
+      --  identifier in the list, then the previous call to this procedure
+      --  printed only the name, and we add a comma to separate the names.
+
+      else
+         Write_Str (", ");
+      end if;
+
+      Sprint_Node (Defining_Identifier (Node));
+
+      --  The remainder of the declaration must be printed unless we are
+      --  printing the original tree and this is not the last identifier
+
+      return
+         not Dump_Original_Only or else not More_Ids (Node);
+
+   end Write_Indent_Identifiers;
+
+   -----------------------------------
+   -- Write_Indent_Identifiers_Sloc --
+   -----------------------------------
+
+   function Write_Indent_Identifiers_Sloc (Node : Node_Id) return Boolean is
+   begin
+      --  We need to start a new line for every node, except in the case
+      --  where we are printing the original tree and this is not the first
+      --  defining identifier in the list.
+
+      if not Dump_Original_Only or else not Prev_Ids (Node) then
+         Write_Indent;
+
+      --  If printing original tree and this is not the first defining
+      --  identifier in the list, then the previous call to this procedure
+      --  printed only the name, and we add a comma to separate the names.
+
+      else
+         Write_Str (", ");
+      end if;
+
+      Set_Debug_Sloc;
+      Sprint_Node (Defining_Identifier (Node));
+
+      --  The remainder of the declaration must be printed unless we are
+      --  printing the original tree and this is not the last identifier
+
+      return
+         not Dump_Original_Only or else not More_Ids (Node);
+
+   end Write_Indent_Identifiers_Sloc;
+
+   ----------------------
+   -- Write_Indent_Str --
+   ----------------------
+
+   procedure Write_Indent_Str (S : String) is
+   begin
+      Write_Indent;
+      Write_Str (S);
+   end Write_Indent_Str;
+
+   ---------------------------
+   -- Write_Indent_Str_Sloc --
+   ---------------------------
+
+   procedure Write_Indent_Str_Sloc (S : String) is
+   begin
+      Write_Indent;
+      Write_Str_Sloc (S);
+   end Write_Indent_Str_Sloc;
+
+   -------------------------------
+   -- Write_Name_With_Col_Check --
+   -------------------------------
+
+   procedure Write_Name_With_Col_Check (N : Name_Id) is
+      J : Natural;
+
+   begin
+      Get_Name_String (N);
+
+      --  Deal with -gnatI which replaces digits in an internal
+      --  name by three dots (e.g. R7b becomes R...b).
+
+      if Debug_Flag_II and then Name_Buffer (1) in 'A' .. 'Z' then
+
+         J := 2;
+         while J < Name_Len loop
+            exit when Name_Buffer (J) not in 'A' .. 'Z';
+            J := J + 1;
+         end loop;
+
+         if Name_Buffer (J) in '0' .. '9' then
+            Write_Str_With_Col_Check (Name_Buffer (1 .. J - 1));
+            Write_Str ("...");
+
+            while J <= Name_Len loop
+               if Name_Buffer (J) not in '0' .. '9' then
+                  Write_Str (Name_Buffer (J .. Name_Len));
+                  exit;
+
+               else
+                  J := J + 1;
+               end if;
+            end loop;
+
+            return;
+         end if;
+      end if;
+
+      --  Fall through for normal case
+
+      Write_Str_With_Col_Check (Name_Buffer (1 .. Name_Len));
+   end Write_Name_With_Col_Check;
+
+   ------------------------------------
+   -- Write_Name_With_Col_Check_Sloc --
+   ------------------------------------
+
+   procedure Write_Name_With_Col_Check_Sloc (N : Name_Id) is
+   begin
+      Get_Name_String (N);
+      Write_Str_With_Col_Check_Sloc (Name_Buffer (1 .. Name_Len));
+   end Write_Name_With_Col_Check_Sloc;
+
+   --------------------
+   -- Write_Operator --
+   --------------------
+
+   procedure Write_Operator (N : Node_Id; S : String) is
+      F : Natural := S'First;
+      T : Natural := S'Last;
+
+   begin
+      if S (F) = ' ' then
+         Write_Char (' ');
+         F := F + 1;
+      end if;
+
+      if S (T) = ' ' then
+         T := T - 1;
+      end if;
+
+      if Do_Overflow_Check (N) then
+         Write_Char ('{');
+         Write_Str_Sloc (S (F .. T));
+         Write_Char ('}');
+      else
+         Write_Str_Sloc (S);
+      end if;
+
+      if S (S'Last) = ' ' then
+         Write_Char (' ');
+      end if;
+   end Write_Operator;
+
+   -----------------------
+   -- Write_Param_Specs --
+   -----------------------
+
+   procedure Write_Param_Specs (N : Node_Id) is
+      Specs  : List_Id;
+      Spec   : Node_Id;
+      Formal : Node_Id;
+
+   begin
+      Specs := Parameter_Specifications (N);
+
+      if Is_Non_Empty_List (Specs) then
+         Write_Str_With_Col_Check (" (");
+         Spec := First (Specs);
+
+         loop
+            Sprint_Node (Spec);
+            Formal := Defining_Identifier (Spec);
+            Next (Spec);
+            exit when Spec = Empty;
+
+            --  Add semicolon, unless we are printing original tree and the
+            --  next specification is part of a list (but not the first
+            --  element of that list)
+
+            if not Dump_Original_Only or else not Prev_Ids (Spec) then
+               Write_Str ("; ");
+            end if;
+         end loop;
+
+         --  Write out any extra formals
+
+         while Present (Extra_Formal (Formal)) loop
+            Formal := Extra_Formal (Formal);
+            Write_Str ("; ");
+            Write_Name_With_Col_Check (Chars (Formal));
+            Write_Str (" : ");
+            Write_Name_With_Col_Check (Chars (Etype (Formal)));
+         end loop;
+
+         Write_Char (')');
+      end if;
+   end Write_Param_Specs;
+
+   --------------------------
+   -- Write_Rewrite_Str --
+   --------------------------
+
+   procedure Write_Rewrite_Str (S : String) is
+   begin
+      if not Dump_Generated_Only then
+         if S'Length = 3 and then S = ">>>" then
+            Write_Str (">>>");
+         else
+            Write_Str_With_Col_Check (S);
+         end if;
+      end if;
+   end Write_Rewrite_Str;
+
+   --------------------
+   -- Write_Str_Sloc --
+   --------------------
+
+   procedure Write_Str_Sloc (S : String) is
+   begin
+      for J in S'Range loop
+         Write_Char_Sloc (S (J));
+      end loop;
+   end Write_Str_Sloc;
+
+   ------------------------------
+   -- Write_Str_With_Col_Check --
+   ------------------------------
+
+   procedure Write_Str_With_Col_Check (S : String) is
+   begin
+      if Int (S'Last) + Column > Line_Limit then
+         Write_Indent_Str ("  ");
+
+         if S (1) = ' ' then
+            Write_Str (S (2 .. S'Length));
+         else
+            Write_Str (S);
+         end if;
+
+      else
+         Write_Str (S);
+      end if;
+   end Write_Str_With_Col_Check;
+
+   -----------------------------------
+   -- Write_Str_With_Col_Check_Sloc --
+   -----------------------------------
+
+   procedure Write_Str_With_Col_Check_Sloc (S : String) is
+   begin
+      if Int (S'Last) + Column > Line_Limit then
+         Write_Indent_Str ("  ");
+
+         if S (1) = ' ' then
+            Write_Str_Sloc (S (2 .. S'Length));
+         else
+            Write_Str_Sloc (S);
+         end if;
+
+      else
+         Write_Str_Sloc (S);
+      end if;
+   end Write_Str_With_Col_Check_Sloc;
+
+   ------------------------------------
+   -- Write_Uint_With_Col_Check_Sloc --
+   ------------------------------------
+
+   procedure Write_Uint_With_Col_Check_Sloc (U : Uint; Format : UI_Format) is
+   begin
+      Col_Check (UI_Decimal_Digits_Hi (U));
+      Set_Debug_Sloc;
+      UI_Write (U, Format);
+   end Write_Uint_With_Col_Check_Sloc;
+
+   -------------------------------------
+   -- Write_Ureal_With_Col_Check_Sloc --
+   -------------------------------------
+
+   procedure Write_Ureal_With_Col_Check_Sloc (U : Ureal) is
+      D : constant Uint := Denominator (U);
+      N : constant Uint := Numerator (U);
+
+   begin
+      Col_Check
+        (UI_Decimal_Digits_Hi (D) + UI_Decimal_Digits_Hi (N) + 4);
+      Set_Debug_Sloc;
+      UR_Write (U);
+   end Write_Ureal_With_Col_Check_Sloc;
+
+end Sprint;
diff --git a/gcc/ada/sprint.ads b/gcc/ada/sprint.ads
new file mode 100644
index 00000000000..d307eb74250
--- /dev/null
+++ b/gcc/ada/sprint.ads
@@ -0,0 +1,148 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                               S P R I N T                                --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.44 $
+--                                                                          --
+--          Copyright (C) 1992-1999, 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 (source print) contains routines for printing the source
+--  program corresponding to a specified syntax tree. These routines are
+--  intended for debugging use in the compiler (not as a user level pretty
+--  print tool). Only information present in the tree is output (e.g. no
+--  comments are present in the output), and as far as possible we avoid
+--  making any assumptions about the correctness of the tree, so a bad
+--  tree may either blow up on a debugging check, or list incorrect source.
+
+with Types; use Types;
+package Sprint is
+
+   -----------------------
+   -- Syntax Extensions --
+   -----------------------
+
+   --  When the generated tree is printed, it contains constructs that are not
+   --  pure Ada. For convenience, syntactic extensions to Ada have been defined
+   --  purely for the purposes of this printout (they are not recognized by the
+   --  parser)
+
+   --    Allocator                           new xxx [storage_pool = xxx]
+   --    Cleanup action                      at end procedure name;
+   --    Conditional expression              (if expr then expr else expr)
+   --    Conversion wi Float_Truncate        target^(source)
+   --    Convert wi Conversion_OK            target?(source)
+   --    Convert wi Rounded_Result           target@(source)
+   --    Divide wi Treat_Fixed_As_Integer    x #/ y
+   --    Divide wi Rounded_Result            x @/ y
+   --    Expression with range check         {expression}
+   --    Operator with range check           {operator} (e.g. {+})
+   --    Free statement                      free expr [storage_pool = xxx]
+   --    Freeze entity with freeze actions   freeze entityname [ actions ]
+   --    Interpretation                      interpretation type [, entity]
+   --    Intrinsic calls                     function-name!(arg, arg, arg)
+   --    Itype reference                     reference itype
+   --    Label declaration                   labelname : label
+   --    Mod wi Treat_Fixed_As_Integer       x #mod y
+   --    Multiple concatenation              expr && expr && expr ... && expr
+   --    Multiply wi Treat_Fixed_As_Integer  x #* y
+   --    Multiply wi Rounded_Result          x @* y
+   --    Others choice for cleanup           when all others
+   --    Raise xxx error                     [xxx_error [when condition]]
+   --    Rational literal                    See UR_Write for details
+   --    Rem wi Treat_Fixed_As_Integer       x #rem y
+   --    Reference                           expression'reference
+   --    Shift nodes                         shift_name!(expr, count)
+   --    Subprogram_Info                     subprog'Subprogram_Info
+   --    Unchecked conversion                target_type!(source_expression)
+   --    Unchecked expression                `(expression)
+   --    Validate_Unchecked_Conversion       validate unchecked_conversion
+   --                                                  (src-type, target-typ);
+
+   --  Note: the storage_pool parameters for allocators and the free node
+   --  are omitted if the Storage_Pool field is Empty, indicating use of
+   --  the standard default pool.
+
+   -----------------
+   -- Subprograms --
+   -----------------
+
+   procedure Source_Dump;
+   --  This routine is called from the GNAT main program to dump source as
+   --  requested by debug options. The relevant debug options are:
+   --    -ds  print source from tree, both original and generated code
+   --    -dg  print source from tree, including only the generated code
+   --    -do  print source from tree, including only the original code
+   --    -df  modify the above to include all units, not just the main unit
+   --    -sz  print source from tree for package Standard
+
+   procedure Sprint_Comma_List (List : List_Id);
+   --  Prints the nodes in a list, with separating commas. If the list
+   --  is empty then no output is generated.
+
+   procedure Sprint_Paren_Comma_List (List : List_Id);
+   --  Prints the nodes in a list, surrounded by parentheses, and separated
+   --  by comas. If the list is empty, then no output is generated. A blank
+   --  is output before the initial left parenthesis.
+
+   procedure Sprint_Opt_Paren_Comma_List (List : List_Id);
+   --  Same as normal Sprint_Paren_Comma_List procedure, except that
+   --  an extra blank is output if List is non-empty, and nothing at all is
+   --  printed it the argument is No_List.
+
+   procedure Sprint_Node_List (List : List_Id);
+   --  Prints the nodes in a list with no separating characters. This is used
+   --  in the case of lists of items which are printed on separate lines using
+   --  the current indentation amount. Note that Sprint_Node_List itself
+   --  does not generate any New_Line calls.
+
+   procedure Sprint_Opt_Node_List (List : List_Id);
+   --  Like Sprint_Node_List, but prints nothing if List = No_List.
+
+   procedure Sprint_Indented_List (List : List_Id);
+   --  Like Sprint_Line_List, except that the indentation level is
+   --  increased before outputting the list of items, and then decremented
+   --  (back to its original level) before returning to the caller.
+
+   procedure Sprint_Node (Node : Node_Id);
+   --  Prints a single node. No new lines are output, except as required for
+   --  splitting lines that are too long to fit on a single physical line.
+   --  No output is generated at all if Node is Empty. No trailing or leading
+   --  blank characters are generated.
+
+   procedure Sprint_Opt_Node (Node : Node_Id);
+   --  Same as normal Sprint_Node procedure, except that one leading
+   --  blank is output before the node if it is non-empty.
+
+   procedure PG (Node : Node_Id);
+   --  Print generated source for node N (like -gnatdg output). This is
+   --  intended only for use from gdb for debugging purposes.
+
+   procedure PO (Node : Node_Id);
+   --  Print original source for node N (like -gnatdo output). This is
+   --  intended only for use from gdb for debugging purposes.
+
+   procedure PS (Node : Node_Id);
+   --  Print generated and original source for node N (like -gnatds output).
+   --  This is intended only for use from gdb for debugging purposes.
+
+end Sprint;
diff --git a/gcc/ada/stand.adb b/gcc/ada/stand.adb
new file mode 100644
index 00000000000..b0001b17864
--- /dev/null
+++ b/gcc/ada/stand.adb
@@ -0,0 +1,131 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                                S T A N D                                 --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.6 $                              --
+--                                                                          --
+--     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.                                                      --
+--                                                                          --
+-- 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 System;  use System;
+with Tree_IO; use Tree_IO;
+
+package body Stand is
+
+   ---------------
+   -- Tree_Read --
+   ---------------
+
+   procedure Tree_Read is
+   begin
+      Tree_Read_Data (Standard_Entity'Address,
+                       Standard_Entity_Array_Type'Size / Storage_Unit);
+
+      Tree_Read_Int (Int (Standard_Package_Node));
+      Tree_Read_Int (Int (Last_Standard_Node_Id));
+      Tree_Read_Int (Int (Last_Standard_List_Id));
+      Tree_Read_Int (Int (Standard_Void_Type));
+      Tree_Read_Int (Int (Standard_Exception_Type));
+      Tree_Read_Int (Int (Standard_A_String));
+      Tree_Read_Int (Int (Any_Id));
+      Tree_Read_Int (Int (Any_Type));
+      Tree_Read_Int (Int (Any_Access));
+      Tree_Read_Int (Int (Any_Array));
+      Tree_Read_Int (Int (Any_Boolean));
+      Tree_Read_Int (Int (Any_Character));
+      Tree_Read_Int (Int (Any_Composite));
+      Tree_Read_Int (Int (Any_Discrete));
+      Tree_Read_Int (Int (Any_Fixed));
+      Tree_Read_Int (Int (Any_Integer));
+      Tree_Read_Int (Int (Any_Numeric));
+      Tree_Read_Int (Int (Any_Real));
+      Tree_Read_Int (Int (Any_Scalar));
+      Tree_Read_Int (Int (Any_String));
+      Tree_Read_Int (Int (Universal_Integer));
+      Tree_Read_Int (Int (Universal_Real));
+      Tree_Read_Int (Int (Universal_Fixed));
+      Tree_Read_Int (Int (Standard_Integer_8));
+      Tree_Read_Int (Int (Standard_Integer_16));
+      Tree_Read_Int (Int (Standard_Integer_32));
+      Tree_Read_Int (Int (Standard_Integer_64));
+      Tree_Read_Int (Int (Abort_Signal));
+      Tree_Read_Int (Int (Standard_Op_Rotate_Left));
+      Tree_Read_Int (Int (Standard_Op_Rotate_Right));
+      Tree_Read_Int (Int (Standard_Op_Shift_Left));
+      Tree_Read_Int (Int (Standard_Op_Shift_Right));
+      Tree_Read_Int (Int (Standard_Op_Shift_Right_Arithmetic));
+
+   end Tree_Read;
+
+   ----------------
+   -- Tree_Write --
+   ----------------
+
+   procedure Tree_Write is
+   begin
+      Tree_Write_Data (Standard_Entity'Address,
+                       Standard_Entity_Array_Type'Size / Storage_Unit);
+
+      Tree_Write_Int (Int (Standard_Package_Node));
+      Tree_Write_Int (Int (Last_Standard_Node_Id));
+      Tree_Write_Int (Int (Last_Standard_List_Id));
+      Tree_Write_Int (Int (Standard_Void_Type));
+      Tree_Write_Int (Int (Standard_Exception_Type));
+      Tree_Write_Int (Int (Standard_A_String));
+      Tree_Write_Int (Int (Any_Id));
+      Tree_Write_Int (Int (Any_Type));
+      Tree_Write_Int (Int (Any_Access));
+      Tree_Write_Int (Int (Any_Array));
+      Tree_Write_Int (Int (Any_Boolean));
+      Tree_Write_Int (Int (Any_Character));
+      Tree_Write_Int (Int (Any_Composite));
+      Tree_Write_Int (Int (Any_Discrete));
+      Tree_Write_Int (Int (Any_Fixed));
+      Tree_Write_Int (Int (Any_Integer));
+      Tree_Write_Int (Int (Any_Numeric));
+      Tree_Write_Int (Int (Any_Real));
+      Tree_Write_Int (Int (Any_Scalar));
+      Tree_Write_Int (Int (Any_String));
+      Tree_Write_Int (Int (Universal_Integer));
+      Tree_Write_Int (Int (Universal_Real));
+      Tree_Write_Int (Int (Universal_Fixed));
+      Tree_Write_Int (Int (Standard_Integer_8));
+      Tree_Write_Int (Int (Standard_Integer_16));
+      Tree_Write_Int (Int (Standard_Integer_32));
+      Tree_Write_Int (Int (Standard_Integer_64));
+      Tree_Write_Int (Int (Abort_Signal));
+      Tree_Write_Int (Int (Standard_Op_Rotate_Left));
+      Tree_Write_Int (Int (Standard_Op_Rotate_Right));
+      Tree_Write_Int (Int (Standard_Op_Shift_Left));
+      Tree_Write_Int (Int (Standard_Op_Shift_Right));
+      Tree_Write_Int (Int (Standard_Op_Shift_Right_Arithmetic));
+
+   end Tree_Write;
+
+end Stand;
diff --git a/gcc/ada/stand.ads b/gcc/ada/stand.ads
new file mode 100644
index 00000000000..65cfa4f5670
--- /dev/null
+++ b/gcc/ada/stand.ads
@@ -0,0 +1,456 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                                S T A N D                                 --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.68 $
+--                                                                          --
+--          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 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 declarations of entities in package Standard,
+--  These values are initialized either by calling CStand.Create_Standard,
+--  or by calling Stand.Tree_Read.
+
+with Types; use Types;
+
+--  Do we really need the with of Namet?
+
+pragma Warnings (Off);
+with Namet; use Namet;
+pragma Elaborate_All (Namet);
+pragma Warnings (On);
+
+package Stand is
+
+   type Standard_Entity_Type is (
+   --  This enumeration type contains an entry for each name in Standard
+
+      --  Package names
+
+      S_Standard,
+      S_ASCII,
+
+      --  Types defined in package Standard
+
+      S_Boolean,
+      S_Character,
+      S_Wide_Character,
+      S_String,
+      S_Wide_String,
+      S_Duration,
+
+      S_Short_Short_Integer,
+      S_Short_Integer,
+      S_Integer,
+      S_Long_Integer,
+      S_Long_Long_Integer,
+
+      S_Short_Float,
+      S_Float,
+      S_Long_Float,
+      S_Long_Long_Float,
+
+      --  Enumeration literals for type Boolean
+
+      S_False,
+      S_True,
+
+      --  Subtypes declared in package Standard
+
+      S_Natural,
+      S_Positive,
+
+      --  Exceptions declared in package Standard
+
+      S_Constraint_Error,
+      S_Numeric_Error,
+      S_Program_Error,
+      S_Storage_Error,
+      S_Tasking_Error,
+
+      --  Binary Operators declared in package Standard.
+
+      S_Op_Add,
+      S_Op_And,
+      S_Op_Concat,
+      S_Op_Concatw,
+      S_Op_Divide,
+      S_Op_Eq,
+      S_Op_Expon,
+      S_Op_Ge,
+      S_Op_Gt,
+      S_Op_Le,
+      S_Op_Lt,
+      S_Op_Mod,
+      S_Op_Multiply,
+      S_Op_Ne,
+      S_Op_Or,
+      S_Op_Rem,
+      S_Op_Subtract,
+      S_Op_Xor,
+
+      --  Unary operators declared in package Standard
+
+      S_Op_Abs,
+      S_Op_Minus,
+      S_Op_Not,
+      S_Op_Plus,
+
+      --  Constants defined in package ASCII (with value in hex).
+      --  First the thirty-two C0 control characters)
+
+      S_NUL,            -- 16#00#
+      S_SOH,            -- 16#01#
+      S_STX,            -- 16#02#
+      S_ETX,            -- 16#03#
+      S_EOT,            -- 16#04#
+      S_ENQ,            -- 16#05#
+      S_ACK,            -- 16#06#
+      S_BEL,            -- 16#07#
+      S_BS,             -- 16#08#
+      S_HT,             -- 16#09#
+      S_LF,             -- 16#0A#
+      S_VT,             -- 16#0B#
+      S_FF,             -- 16#0C#
+      S_CR,             -- 16#0D#
+      S_SO,             -- 16#0E#
+      S_SI,             -- 16#0F#
+      S_DLE,            -- 16#10#
+      S_DC1,            -- 16#11#
+      S_DC2,            -- 16#12#
+      S_DC3,            -- 16#13#
+      S_DC4,            -- 16#14#
+      S_NAK,            -- 16#15#
+      S_SYN,            -- 16#16#
+      S_ETB,            -- 16#17#
+      S_CAN,            -- 16#18#
+      S_EM,             -- 16#19#
+      S_SUB,            -- 16#1A#
+      S_ESC,            -- 16#1B#
+      S_FS,             -- 16#1C#
+      S_GS,             -- 16#1D#
+      S_RS,             -- 16#1E#
+      S_US,             -- 16#1F#
+
+      --  Here are the ones for Colonel Whitaker's O26 keypunch!
+
+      S_Exclam,         -- 16#21#
+      S_Quotation,      -- 16#22#
+      S_Sharp,          -- 16#23#
+      S_Dollar,         -- 16#24#
+      S_Percent,        -- 16#25#
+      S_Ampersand,      -- 16#26#
+
+      S_Colon,          -- 16#3A#
+      S_Semicolon,      -- 16#3B#
+
+      S_Query,          -- 16#3F#
+      S_At_Sign,        -- 16#40#
+
+      S_L_Bracket,      -- 16#5B#
+      S_Back_Slash,     -- 16#5C#
+      S_R_Bracket,      -- 16#5D#
+      S_Circumflex,     -- 16#5E#
+      S_Underline,      -- 16#5F#
+      S_Grave,          -- 16#60#
+
+      S_LC_A,           -- 16#61#
+      S_LC_B,           -- 16#62#
+      S_LC_C,           -- 16#63#
+      S_LC_D,           -- 16#64#
+      S_LC_E,           -- 16#65#
+      S_LC_F,           -- 16#66#
+      S_LC_G,           -- 16#67#
+      S_LC_H,           -- 16#68#
+      S_LC_I,           -- 16#69#
+      S_LC_J,           -- 16#6A#
+      S_LC_K,           -- 16#6B#
+      S_LC_L,           -- 16#6C#
+      S_LC_M,           -- 16#6D#
+      S_LC_N,           -- 16#6E#
+      S_LC_O,           -- 16#6F#
+      S_LC_P,           -- 16#70#
+      S_LC_Q,           -- 16#71#
+      S_LC_R,           -- 16#72#
+      S_LC_S,           -- 16#73#
+      S_LC_T,           -- 16#74#
+      S_LC_U,           -- 16#75#
+      S_LC_V,           -- 16#76#
+      S_LC_W,           -- 16#77#
+      S_LC_X,           -- 16#78#
+      S_LC_Y,           -- 16#79#
+      S_LC_Z,           -- 16#7A#
+
+      S_L_BRACE,        -- 16#7B#
+      S_BAR,            -- 16#7C#
+      S_R_BRACE,        -- 16#7D#
+      S_TILDE,          -- 16#7E#
+
+      --  And one more control character, all on its own
+
+      S_DEL);           -- 16#7F#
+
+   subtype S_Types is
+     Standard_Entity_Type range S_Boolean .. S_Long_Long_Float;
+
+   subtype S_Exceptions is
+     Standard_Entity_Type range S_Constraint_Error .. S_Tasking_Error;
+
+   subtype S_ASCII_Names is
+     Standard_Entity_Type range S_NUL .. S_DEL;
+
+   subtype S_Binary_Ops is
+      Standard_Entity_Type range S_Op_Add .. S_Op_Xor;
+
+   subtype S_Unary_Ops is
+      Standard_Entity_Type range S_Op_Abs .. S_Op_Plus;
+
+   type Standard_Entity_Array_Type is array (Standard_Entity_Type) of Node_Id;
+
+   Standard_Entity : Standard_Entity_Array_Type;
+   --  This array contains pointers to the Defining Identifier nodes
+   --  for each of the entities defined in Standard_Entities_Type. It
+   --  is initialized by the Create_Standard procedure.
+
+   Standard_Package_Node : Node_Id;
+   --  Points to the N_Package_Declaration node for standard. Also
+   --  initialized by the Create_Standard procedure.
+
+   --  The following Entities are the pointers to the Defining Identifier
+   --  nodes for some visible entities defined in Standard_Entities_Type.
+
+   SE : Standard_Entity_Array_Type renames Standard_Entity;
+
+   Standard_Standard            : Entity_Id renames SE (S_Standard);
+
+   Standard_ASCII               : Entity_Id renames SE (S_ASCII);
+   Standard_Character           : Entity_Id renames SE (S_Character);
+   Standard_Wide_Character      : Entity_Id renames SE (S_Wide_Character);
+   Standard_String              : Entity_Id renames SE (S_String);
+   Standard_Wide_String         : Entity_Id renames SE (S_Wide_String);
+
+   Standard_Boolean             : Entity_Id renames SE (S_Boolean);
+   Standard_False               : Entity_Id renames SE (S_False);
+   Standard_True                : Entity_Id renames SE (S_True);
+
+   Standard_Duration            : Entity_Id renames SE (S_Duration);
+
+   Standard_Natural             : Entity_Id renames SE (S_Natural);
+   Standard_Positive            : Entity_Id renames SE (S_Positive);
+
+   Standard_Constraint_Error    : Entity_Id renames SE (S_Constraint_Error);
+   Standard_Numeric_Error       : Entity_Id renames SE (S_Numeric_Error);
+   Standard_Program_Error       : Entity_Id renames SE (S_Program_Error);
+   Standard_Storage_Error       : Entity_Id renames SE (S_Storage_Error);
+   Standard_Tasking_Error       : Entity_Id renames SE (S_Tasking_Error);
+
+   Standard_Short_Float         : Entity_Id renames SE (S_Short_Float);
+   Standard_Float               : Entity_Id renames SE (S_Float);
+   Standard_Long_Float          : Entity_Id renames SE (S_Long_Float);
+   Standard_Long_Long_Float     : Entity_Id renames SE (S_Long_Long_Float);
+
+   Standard_Short_Short_Integer : Entity_Id renames SE (S_Short_Short_Integer);
+   Standard_Short_Integer       : Entity_Id renames SE (S_Short_Integer);
+   Standard_Integer             : Entity_Id renames SE (S_Integer);
+   Standard_Long_Integer        : Entity_Id renames SE (S_Long_Integer);
+   Standard_Long_Long_Integer   : Entity_Id renames SE (S_Long_Long_Integer);
+
+   Standard_Op_Add              : Entity_Id renames SE (S_Op_Add);
+   Standard_Op_And              : Entity_Id renames SE (S_Op_And);
+   Standard_Op_Concat           : Entity_Id renames SE (S_Op_Concat);
+   Standard_Op_Concatw          : Entity_Id renames SE (S_Op_Concatw);
+   Standard_Op_Divide           : Entity_Id renames SE (S_Op_Divide);
+   Standard_Op_Eq               : Entity_Id renames SE (S_Op_Eq);
+   Standard_Op_Expon            : Entity_Id renames SE (S_Op_Expon);
+   Standard_Op_Ge               : Entity_Id renames SE (S_Op_Ge);
+   Standard_Op_Gt               : Entity_Id renames SE (S_Op_Gt);
+   Standard_Op_Le               : Entity_Id renames SE (S_Op_Le);
+   Standard_Op_Lt               : Entity_Id renames SE (S_Op_Lt);
+   Standard_Op_Mod              : Entity_Id renames SE (S_Op_Mod);
+   Standard_Op_Multiply         : Entity_Id renames SE (S_Op_Multiply);
+   Standard_Op_Ne               : Entity_Id renames SE (S_Op_Ne);
+   Standard_Op_Or               : Entity_Id renames SE (S_Op_Or);
+   Standard_Op_Rem              : Entity_Id renames SE (S_Op_Rem);
+   Standard_Op_Subtract         : Entity_Id renames SE (S_Op_Subtract);
+   Standard_Op_Xor              : Entity_Id renames SE (S_Op_Xor);
+
+   Standard_Op_Abs              : Entity_Id renames SE (S_Op_Abs);
+   Standard_Op_Minus            : Entity_Id renames SE (S_Op_Minus);
+   Standard_Op_Not              : Entity_Id renames SE (S_Op_Not);
+   Standard_Op_Plus             : Entity_Id renames SE (S_Op_Plus);
+
+   Last_Standard_Node_Id : Node_Id;
+   --  Highest Node_Id value used by Standard
+
+   Last_Standard_List_Id : List_Id;
+   --  Highest List_Id value used by Standard (including those used by
+   --  normal list headers, element list headers, and list elements)
+
+   -------------------------------------
+   -- Semantic Phase Special Entities --
+   -------------------------------------
+
+   --  The semantic phase needs a number of entities for internal processing
+   --  that are logically at the level of Standard, and hence defined in this
+   --  package. However, they are never visible to a program, and are not
+   --  chained on to the Decls list of Standard. The names of all these
+   --  types are relevant only in certain debugging and error message
+   --  situations. They have names that are suitable for use in such
+   --  error messages (see body for actual names used).
+
+   Standard_Void_Type  : Entity_Id;
+   --  This is a type used to represent the return type of procedures
+
+   Standard_Exception_Type  : Entity_Id;
+   --  This is a type used to represent the Etype of exceptions.
+
+   Standard_A_String   : Entity_Id;
+   --  An access to String type used for building elements of tables
+   --  carrying the enumeration literal names.
+
+   Standard_A_Char : Entity_Id;
+   --  Access to character, used as a component of the exception type to
+   --  denote a thin pointer component.
+
+   --  The entities labeled Any_xxx are used in situations where the full
+   --  characteristics of an entity are not yet known, e.g. Any_Character
+   --  is used to label a character literal before resolution is complete.
+   --  These entities are also used to construct appropriate references in
+   --  error messages ("expecting an integer type").
+
+   Any_Id : Entity_Id;
+   --  Used to represent some unknown identifier. Used to lable undefined
+   --  identifier references to prevent cascaded errors.
+
+   Any_Type : Entity_Id;
+   --  Used to represent some unknown type. Plays an important role in
+   --  avoiding cascaded errors, since any node that remains labaled with
+   --  this type corresponds to an already issued error message. Any_Type
+   --  is propagated to avoid cascaded errors from a single type error.
+
+   Any_Access : Entity_Id;
+   --  Used to resolve the overloaded literal NULL.
+
+   Any_Array : Entity_Id;
+   --  Used to represent some unknown array type
+
+   Any_Boolean : Entity_Id;
+   --  The context type of conditions in IF and WHILE statements.
+
+   Any_Character : Entity_Id;
+   --  Any_Character is used to label character literals, which in general
+   --  will not have an explicit declaration (this is true of the predefined
+   --  character types).
+
+   Any_Composite : Entity_Id;
+   --  The type Any_Composite is used for aggregates before type resolution.
+   --  It is compatible with any array or non-limited record type.
+
+   Any_Discrete : Entity_Id;
+   --  Used to represent some unknown discrete type
+
+   Any_Fixed : Entity_Id;
+   --  Used to represent some unknown fixed-point type
+
+   Any_Integer : Entity_Id;
+   --  Used to represent some unknown integer type.
+
+   Any_Modular : Entity_Id;
+   --  Used to represent the result type of a boolean operation on an
+   --  integer literal. The result is not Universal_Integer, because it is
+   --  only legal in a modular context.
+
+   Any_Numeric : Entity_Id;
+   --  Used to represent some unknown numeric type.
+
+   Any_Real : Entity_Id;
+   --  Used to represent some unknown real type.
+
+   Any_Scalar : Entity_Id;
+   --  Used to represent some unknown scalar type
+
+   Any_String : Entity_Id;
+   --  The type Any_String is used for string literals before type
+   --  resolution. It corresponds to array (Positive range <>) of character
+   --  where the component type is compatible with any character type,
+   --  not just Standard_Character.
+
+   Universal_Integer : Entity_Id;
+   --  Entity for universal integer type. The bounds of this type correspond
+   --  to the largest supported integer type (i.e. Long_Long_Integer). It is
+   --  the type used for runtime calculations in type universal integer.
+
+   Universal_Real : Entity_Id;
+   --  Entity for universal real type. The bounds of this type correspond to
+   --  to the largest supported real type (i.e. Long_Long_Real). It is the
+   --  type used for runtime calculations in type universal real.
+
+   Universal_Fixed : Entity_Id;
+   --  Entity for universal fixed type. This is a type with  arbitrary
+   --  precision that can only appear in  a context with a specific type.
+   --  Universal_Fixed labels the result of multiplication or division of
+   --  two fixed point numbers, and has no specified bounds (since, unlike
+   --  universal integer and universal real, it is never used for runtime
+   --  calculations).
+
+   Standard_Integer_8  : Entity_Id;
+   Standard_Integer_16 : Entity_Id;
+   Standard_Integer_32 : Entity_Id;
+   Standard_Integer_64 : Entity_Id;
+   --  These are signed integer types with the indicated sizes, They are
+   --  used for the underlying implementation types for fixed-point and
+   --  enumeration types.
+
+   Standard_Unsigned : Entity_Id;
+   --  An unsigned type of the same size as Standard_Integer
+
+   Abort_Signal : Entity_Id;
+   --  Entity for abort signal exception
+
+   Standard_Op_Rotate_Left            : Entity_Id;
+   Standard_Op_Rotate_Right           : Entity_Id;
+   Standard_Op_Shift_Left             : Entity_Id;
+   Standard_Op_Shift_Right            : Entity_Id;
+   Standard_Op_Shift_Right_Arithmetic : Entity_Id;
+   --  These entities are used for shift operators generated by the expander
+
+   -----------------
+   -- Subprograms --
+   -----------------
+
+   procedure Tree_Read;
+   --  Initializes entity values in this package from the current tree
+   --  file using Osint.Tree_Read. Note that Tree_Read includes all the
+   --  initialization that is carried out by Create_Standard.
+
+   procedure Tree_Write;
+   --  Writes out the entity values in this package to the current
+   --  tree file using Osint.Tree_Write.
+
+end Stand;
diff --git a/gcc/ada/stringt.adb b/gcc/ada/stringt.adb
new file mode 100644
index 00000000000..b2631ad2c03
--- /dev/null
+++ b/gcc/ada/stringt.adb
@@ -0,0 +1,419 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              S T R I N G T                               --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.43 $
+--                                                                          --
+--          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 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;
+with Namet;  use Namet;
+with Output; use Output;
+with Table;
+
+package body Stringt is
+
+   --  The following table stores the sequence of character codes for the
+   --  stored string constants. The entries are referenced from the
+   --  separate Strings table.
+
+   package String_Chars is new Table.Table (
+     Table_Component_Type => Char_Code,
+     Table_Index_Type     => Int,
+     Table_Low_Bound      => 0,
+     Table_Initial        => Alloc.String_Chars_Initial,
+     Table_Increment      => Alloc.String_Chars_Increment,
+     Table_Name           => "String_Chars");
+
+   --  The String_Id values reference entries in the Strings table, which
+   --  contains String_Entry records that record the length of each stored
+   --  string and its starting location in the String_Chars table.
+
+   type String_Entry is record
+      String_Index : Int;
+      Length       : Nat;
+   end record;
+
+   package Strings is new Table.Table (
+     Table_Component_Type => String_Entry,
+     Table_Index_Type     => String_Id,
+     Table_Low_Bound      => First_String_Id,
+     Table_Initial        => Alloc.Strings_Initial,
+     Table_Increment      => Alloc.Strings_Increment,
+     Table_Name           => "Strings");
+
+   --  Note: it is possible that two entries in the Strings table can share
+   --  string data in the String_Chars table, and in particular this happens
+   --  when Start_String is called with a parameter that is the last string
+   --  currently allocated in the table.
+
+   -------------------------------
+   -- Add_String_To_Name_Buffer --
+   -------------------------------
+
+   procedure Add_String_To_Name_Buffer (S : String_Id) is
+      Len : constant Natural := Natural (String_Length (S));
+   begin
+      for J in 1 .. Len loop
+         Name_Buffer (Name_Len + J) :=
+           Get_Character (Get_String_Char (S, Int (J)));
+      end loop;
+
+      Name_Len := Name_Len + Len;
+   end Add_String_To_Name_Buffer;
+
+   ----------------
+   -- End_String --
+   ----------------
+
+   function End_String return String_Id is
+   begin
+      return Strings.Last;
+   end End_String;
+
+   ---------------------
+   -- Get_String_Char --
+   ---------------------
+
+   function Get_String_Char (Id : String_Id; Index : Int) return Char_Code is
+   begin
+      pragma Assert (Id in First_String_Id .. Strings.Last
+                       and then Index in 1 .. Strings.Table (Id).Length);
+
+      return String_Chars.Table (Strings.Table (Id).String_Index + Index - 1);
+   end Get_String_Char;
+
+   ----------------
+   -- Initialize --
+   ----------------
+
+   procedure Initialize is
+   begin
+      String_Chars.Init;
+      Strings.Init;
+   end Initialize;
+
+   ----------
+   -- Lock --
+   ----------
+
+   procedure Lock is
+   begin
+      String_Chars.Locked := True;
+      Strings.Locked := True;
+      String_Chars.Release;
+      Strings.Release;
+   end Lock;
+
+   ------------------
+   -- Start_String --
+   ------------------
+
+   --  Version to start completely new string
+
+   procedure Start_String is
+   begin
+      Strings.Increment_Last;
+      Strings.Table (Strings.Last).String_Index := String_Chars.Last + 1;
+      Strings.Table (Strings.Last).Length := 0;
+   end Start_String;
+
+   --  Version to start from initially stored string
+
+   procedure Start_String (S : String_Id) is
+   begin
+      Strings.Increment_Last;
+
+      --  Case of initial string value is at the end of the string characters
+      --  table, so it does not need copying, instead it can be shared.
+
+      if Strings.Table (S).String_Index + Strings.Table (S).Length =
+                                                    String_Chars.Last + 1
+      then
+         Strings.Table (Strings.Last).String_Index :=
+           Strings.Table (S).String_Index;
+
+      --  Case of initial string value must be copied to new string
+
+      else
+         Strings.Table (Strings.Last).String_Index :=
+           String_Chars.Last + 1;
+
+         for J in 1 .. Strings.Table (S).Length loop
+            String_Chars.Increment_Last;
+            String_Chars.Table (String_Chars.Last) :=
+              String_Chars.Table (Strings.Table (S).String_Index + (J - 1));
+         end loop;
+      end if;
+
+      --  In either case the result string length is copied from the argument
+
+      Strings.Table (Strings.Last).Length := Strings.Table (S).Length;
+   end Start_String;
+
+   -----------------------
+   -- Store_String_Char --
+   -----------------------
+
+   procedure Store_String_Char (C : Char_Code) is
+   begin
+      String_Chars.Increment_Last;
+      String_Chars.Table (String_Chars.Last) := C;
+      Strings.Table (Strings.Last).Length :=
+        Strings.Table (Strings.Last).Length + 1;
+   end Store_String_Char;
+
+   procedure Store_String_Char (C : Character) is
+   begin
+      Store_String_Char (Get_Char_Code (C));
+   end Store_String_Char;
+
+   ------------------------
+   -- Store_String_Chars --
+   ------------------------
+
+   procedure Store_String_Chars (S : String) is
+   begin
+      for J in S'First .. S'Last loop
+         Store_String_Char (Get_Char_Code (S (J)));
+      end loop;
+   end Store_String_Chars;
+
+   procedure Store_String_Chars (S : String_Id) is
+   begin
+      for J in 1 .. String_Length (S) loop
+         Store_String_Char (Get_String_Char (S, J));
+      end loop;
+   end Store_String_Chars;
+
+   ----------------------
+   -- Store_String_Int --
+   ----------------------
+
+   procedure Store_String_Int (N : Int) is
+   begin
+      if N < 0 then
+         Store_String_Char ('-');
+         Store_String_Int (-N);
+
+      else
+         if N > 9 then
+            Store_String_Int (N / 10);
+         end if;
+
+         Store_String_Char (Character'Val (Character'Pos ('0') + N mod 10));
+      end if;
+   end Store_String_Int;
+
+   --------------------------
+   -- String_Chars_Address --
+   --------------------------
+
+   function String_Chars_Address return System.Address is
+   begin
+      return String_Chars.Table (0)'Address;
+   end String_Chars_Address;
+
+   ------------------
+   -- String_Equal --
+   ------------------
+
+   function String_Equal (L, R : String_Id) return Boolean is
+      Len : constant Nat := Strings.Table (L).Length;
+
+   begin
+      if Len /= Strings.Table (R).Length then
+         return False;
+      else
+         for J in 1 .. Len loop
+            if Get_String_Char (L, J) /= Get_String_Char (R, J) then
+               return False;
+            end if;
+         end loop;
+
+         return True;
+      end if;
+   end String_Equal;
+
+   -----------------------------
+   -- String_From_Name_Buffer --
+   -----------------------------
+
+   function String_From_Name_Buffer return String_Id is
+   begin
+      Start_String;
+
+      for J in 1 .. Name_Len loop
+         Store_String_Char (Get_Char_Code (Name_Buffer (J)));
+      end loop;
+
+      return End_String;
+   end String_From_Name_Buffer;
+
+   -------------------
+   -- String_Length --
+   -------------------
+
+   function String_Length (Id : String_Id) return Nat is
+   begin
+      return Strings.Table (Id).Length;
+   end String_Length;
+
+   ---------------------------
+   -- String_To_Name_Buffer --
+   ---------------------------
+
+   procedure String_To_Name_Buffer (S : String_Id) is
+   begin
+      Name_Len := Natural (String_Length (S));
+
+      for J in 1 .. Name_Len loop
+         Name_Buffer (J) :=
+           Get_Character (Get_String_Char (S, Int (J)));
+      end loop;
+   end String_To_Name_Buffer;
+
+   ---------------------
+   -- Strings_Address --
+   ---------------------
+
+   function Strings_Address return System.Address is
+   begin
+      return Strings.Table (First_String_Id)'Address;
+   end Strings_Address;
+
+   ---------------
+   -- Tree_Read --
+   ---------------
+
+   procedure Tree_Read is
+   begin
+      String_Chars.Tree_Read;
+      Strings.Tree_Read;
+   end Tree_Read;
+
+   ----------------
+   -- Tree_Write --
+   ----------------
+
+   procedure Tree_Write is
+   begin
+      String_Chars.Tree_Write;
+      Strings.Tree_Write;
+   end Tree_Write;
+
+   ------------
+   -- Unlock --
+   ------------
+
+   procedure Unlock is
+   begin
+      String_Chars.Locked := False;
+      Strings.Locked := False;
+   end Unlock;
+
+   -------------------------
+   -- Unstore_String_Char --
+   -------------------------
+
+   procedure Unstore_String_Char is
+   begin
+      String_Chars.Decrement_Last;
+      Strings.Table (Strings.Last).Length :=
+        Strings.Table (Strings.Last).Length - 1;
+   end Unstore_String_Char;
+
+   ---------------------
+   -- Write_Char_Code --
+   ---------------------
+
+   procedure Write_Char_Code (Code : Char_Code) is
+
+      procedure Write_Hex_Byte (J : Natural);
+      --  Write single hex digit
+
+      procedure Write_Hex_Byte (J : Natural) is
+         Hexd : String := "0123456789abcdef";
+
+      begin
+         Write_Char (Hexd (J / 16 + 1));
+         Write_Char (Hexd (J mod 16 + 1));
+      end Write_Hex_Byte;
+
+   --  Start of processing for Write_Char_Code
+
+   begin
+      if Code in 16#20# .. 16#7E# then
+         Write_Char (Character'Val (Code));
+
+      else
+         Write_Char ('[');
+         Write_Char ('"');
+
+         if Code > 16#FF# then
+            Write_Hex_Byte (Natural (Code / 256));
+         end if;
+
+         Write_Hex_Byte (Natural (Code mod 256));
+         Write_Char ('"');
+         Write_Char (']');
+      end if;
+   end Write_Char_Code;
+
+   ------------------------------
+   -- Write_String_Table_Entry --
+   ------------------------------
+
+   procedure Write_String_Table_Entry (Id : String_Id) is
+      C : Char_Code;
+
+   begin
+      if Id = No_String then
+         Write_Str ("no string");
+
+      else
+         Write_Char ('"');
+
+         for J in 1 .. String_Length (Id) loop
+            C := Get_String_Char (Id, J);
+
+            if Character'Val (C) = '"' then
+               Write_Str ("""""");
+
+            else
+               Write_Char_Code (C);
+            end if;
+         end loop;
+
+         Write_Char ('"');
+      end if;
+   end Write_String_Table_Entry;
+
+end Stringt;
diff --git a/gcc/ada/stringt.ads b/gcc/ada/stringt.ads
new file mode 100644
index 00000000000..0d4350ec090
--- /dev/null
+++ b/gcc/ada/stringt.ads
@@ -0,0 +1,161 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              S T R I N G T                               --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.39 $
+--                                                                          --
+--          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 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 System; use System;
+with Types;  use Types;
+
+package Stringt is
+
+--  This package contains routines for handling the strings table which is
+--  used to store string constants encountered in the source, and also those
+--  additional string constants generated by compile time concatenation and
+--  other similar processing.
+
+--  A string constant in this table consists of a series of Char_Code values,
+--  so that 16-bit character codes can be properly handled if this feature
+--  is implemented in the scanner.
+
+--  There is no guarantee that hashing is used in the implementation, although
+--  it maybe. This means that the caller cannot count on having the same Id
+--  value for two identical strings stored separately and also cannot count on
+--  the two Id values being different.
+
+   --------------------------------------
+   -- String Table Access Subprograms --
+   --------------------------------------
+
+   procedure Initialize;
+   --  Initializes the strings table for a new compilation. Note that
+   --  Initialize must not be called if Tree_Read is used.
+
+   procedure Lock;
+   --  Lock internal tables before calling back end
+
+   procedure Unlock;
+   --  Unlock internal tables, in case back end needs to modify them
+
+   procedure Start_String;
+   --  Sets up for storing a new string in the table. To store a string, a
+   --  call is first made to Start_String, then successive calls are
+   --  made to Store_String_Character to store the characters of the string.
+   --  Finally, a call to End_String terminates the entry and returns it Id.
+
+   procedure Start_String (S : String_Id);
+   --  Like Start_String with no parameter, except that the contents of the
+   --  new string is initialized to be a copy of the given string. A test is
+   --  made to see if S is the last created string, and if so it is shared,
+   --  rather than copied, this can be particularly helpful for the case of
+   --  a continued concatenaion of string constants.
+
+   procedure Store_String_Char (C : Char_Code);
+   procedure Store_String_Char (C : Character);
+   --  Store next character of string, see description above for Start_String
+
+   procedure Store_String_Chars (S : String);
+   procedure Store_String_Chars (S : String_Id);
+   --  Store character codes of given string in sequence
+
+   procedure Store_String_Int (N : Int);
+   --  Stored decimal representation of integer with possible leading minus
+
+   procedure Unstore_String_Char;
+   --  Undoes effect of previous Store_String_Char call, used in some error
+   --  situations of unterminated string constants.
+
+   function End_String return String_Id;
+   --  Terminates current string and returns its Id
+
+   function String_Length (Id : String_Id) return Nat;
+   --  Returns length of previously stored string
+
+   function Get_String_Char (Id : String_Id; Index : Int) return Char_Code;
+   --  Obtains the specified character from a stored string. The lower bound
+   --  of stored strings is always 1, so the range is 1 .. String_Length (Id).
+
+   function String_Equal (L, R : String_Id) return Boolean;
+   --  Determines if two string literals represent the same string
+
+   procedure String_To_Name_Buffer (S : String_Id);
+   --  Place characters of given string in Name_Buffer, setting Name_Len
+
+   procedure Add_String_To_Name_Buffer (S : String_Id);
+   --  Append characters of given string to Name_Buffer, updating Name_Len
+
+   function String_Chars_Address return System.Address;
+   --  Return address of String_Chars table (used by Back_End call to Gigi)
+
+   function String_From_Name_Buffer return String_Id;
+   --  Given a name stored in Namet.Name_Buffer (length in Namet.Name_Len),
+   --  returns a string of the corresponding value. The value in Name_Buffer
+   --  is unchanged, and the cases of letters are unchanged.
+
+   function Strings_Address return System.Address;
+   --  Return address of Strings table (used by Back_End call to Gigi)
+
+   procedure Tree_Read;
+   --  Initializes internal tables from current tree file using Tree_Read.
+   --  Note that Initialize should not be called if Tree_Read is used.
+   --  Tree_Read includes all necessary initialization.
+
+   procedure Tree_Write;
+   --  Writes out internal tables to current tree file using Tree_Write
+
+   procedure Write_Char_Code (Code : Char_Code);
+   --  Procedure to write a character code value, used for debugging purposes
+   --  for writing character codes. If the character code is in the range
+   --  16#20# .. 16#7E#, then the single graphic character corresponding to
+   --  the code is output. For any other codes in the range 16#00# .. 16#FF#,
+   --  the code is output as ["hh"] where hh is the two digit hex value for
+   --  the code. Codes greater than 16#FF# are output as ["hhhh"] where hhhh
+   --  is the four digit hex representation of the code value (high order
+   --  byte first). Hex letters are always in upper case.
+
+   procedure Write_String_Table_Entry (Id : String_Id);
+   --  Writes a string value with enclosing quotes to the current file using
+   --  routines in package Output. Does not write an end of line character.
+   --  This procedure is used for debug output purposes, and also for output
+   --  of strings specified by pragma Linker Option to the ali file. 7-bit
+   --  ASCII graphics (except for double quote and left brace) are output
+   --  literally. The double quote appears as two successive double quotes.
+   --  All other codes, are output as described for Write_Char_Code. For
+   --  example, the string created by folding "A" & ASCII.LF & "Hello" will
+   --  print as "A{0A}Hello". A No_String value prints simply as "no string"
+   --  without surrounding quote marks.
+
+private
+   pragma Inline (End_String);
+   pragma Inline (String_Length);
+
+end Stringt;
diff --git a/gcc/ada/stringt.h b/gcc/ada/stringt.h
new file mode 100644
index 00000000000..3a1e1f684a3
--- /dev/null
+++ b/gcc/ada/stringt.h
@@ -0,0 +1,92 @@
+/****************************************************************************
+ *                                                                          *
+ *                         GNAT COMPILER COMPONENTS                         *
+ *                                                                          *
+ *                              S T R I N G T                               *
+ *                                                                          *
+ *                              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.                                                      *
+ *                                                                          *
+ * 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 is the C file that corresponds to the Ada package spec
+   Stringt. It was created manually from stringt.ads and stringt.adb
+									    
+   Note: only the access functions are provided, since the tree transformer
+   is not allowed to modify the tree or its auxiliary structures.
+									    
+   This package contains routines for handling the strings table which is
+   used to store string constants encountered in the source, and also those
+   additional string constants generated by compile time concatenation and
+   other similar processing.
+									    
+   A string constant in this table consists of a series of Char_Code values,
+   so that 16-bit character codes can be properly handled if this feature is
+   implemented in the scanner.
+									    
+   There is no guarantee that hashing is used in the implementation. This
+   means that the caller cannot count on having the same Id value for two
+   identical strings stored separately.
+									    
+   The String_Id values reference entries in the Strings table, which
+   contains String_Entry records that record the length of each stored string
+   and its starting location in the String_Chars table.  */
+
+struct String_Entry
+{
+  Int String_Index;
+  Int Length;
+};
+
+/* Pointer to string entry vector. This pointer is passed to the tree
+   transformer and stored in a global location for access from here after
+   subtracting String_First_Entry, so that String_Id values can be used as
+   subscripts into the vector. */
+extern struct String_Entry *Strings_Ptr;
+
+/* Pointer to name characters table. This pointer is passed to the tree
+   transformer and stored in a global location for access from here. The
+   String_Index values are subscripts into this array.  */
+extern Char_Code *String_Chars_Ptr;
+
+
+/* String_Length returns the length of the specified string.  */
+INLINE Int String_Length PARAMS ((String_Id));
+
+INLINE Int
+String_Length (Id)
+     String_Id Id;
+{
+  return Strings_Ptr [Id].Length;
+}
+
+
+/* Get_String_Char obtains the specified character from a stored string.  The
+   lower bound of stored strings is always 1, so the range of values is 1 to
+   String_Length (Id).  */
+INLINE Char_Code Get_String_Char PARAMS ((String_Id, Int));
+
+INLINE Char_Code
+Get_String_Char (Id, Index)
+     String_Id Id;
+     Int Index;
+{
+  return String_Chars_Ptr [Strings_Ptr [Id].String_Index + Index - 1];
+}
diff --git a/gcc/ada/style.adb b/gcc/ada/style.adb
new file mode 100644
index 00000000000..638333c0ee0
--- /dev/null
+++ b/gcc/ada/style.adb
@@ -0,0 +1,833 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                                S T Y L E                                 --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.48 $
+--                                                                          --
+--          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 version of the Style package implements the standard GNAT style
+--  checking rules. For documentation of these rules, see comments on the
+--  individual procedures.
+
+with Atree;    use Atree;
+with Casing;   use Casing;
+with Csets;    use Csets;
+with Einfo;    use Einfo;
+with Errout;   use Errout;
+with Namet;    use Namet;
+with Opt;      use Opt;
+with Scn;      use Scn;
+with Scans;    use Scans;
+with Sinfo;    use Sinfo;
+with Sinput;   use Sinput;
+with Stand;    use Stand;
+with Stylesw;  use Stylesw;
+
+package body Style is
+
+   -----------------------
+   -- Local Subprograms --
+   -----------------------
+
+   procedure Error_Space_Not_Allowed (S : Source_Ptr);
+   --  Posts an error message indicating that a space is not allowed
+   --  at the given source location.
+
+   procedure Error_Space_Required (S : Source_Ptr);
+   --  Posts an error message indicating that a space is required at
+   --  the given source location.
+
+   procedure Require_Following_Space;
+   pragma Inline (Require_Following_Space);
+   --  Require token to be followed by white space. Used only if in GNAT
+   --  style checking mode.
+
+   procedure Require_Preceding_Space;
+   pragma Inline (Require_Preceding_Space);
+   --  Require token to be preceded by white space. Used only if in GNAT
+   --  style checking mode.
+
+   -----------------------
+   -- Body_With_No_Spec --
+   -----------------------
+
+   --  If the check specs mode (-gnatys) is set, then all subprograms must
+   --  have specs unless they are parameterless procedures that are not child
+   --  units at the library level (i.e. they are possible main programs).
+
+   procedure Body_With_No_Spec (N : Node_Id) is
+   begin
+      if Style_Check_Specs then
+         if Nkind (Parent (N)) = N_Compilation_Unit then
+            declare
+               Spec  : constant Node_Id := Specification (N);
+               Defnm : constant Node_Id := Defining_Unit_Name (Spec);
+
+            begin
+               if Nkind (Spec) = N_Procedure_Specification
+                 and then Nkind (Defnm) = N_Defining_Identifier
+                 and then No (First_Formal (Defnm))
+               then
+                  return;
+               end if;
+            end;
+         end if;
+
+         Error_Msg_N ("(style): subprogram body has no previous spec", N);
+      end if;
+   end Body_With_No_Spec;
+
+   ----------------------
+   -- Check_Abs_Or_Not --
+   ----------------------
+
+   --  In check tokens mode (-gnatyt), ABS/NOT must be followed by a space
+
+   procedure Check_Abs_Not is
+   begin
+      if Style_Check_Tokens then
+         if Source (Scan_Ptr) > ' ' then
+            Error_Space_Required (Scan_Ptr);
+         end if;
+      end if;
+   end Check_Abs_Not;
+
+   -----------------
+   -- Check_Arrow --
+   -----------------
+
+   --  In check tokens mode (-gnatys), arrow must be surrounded by spaces
+
+   procedure Check_Arrow is
+   begin
+      if Style_Check_Tokens then
+         Require_Preceding_Space;
+         Require_Following_Space;
+      end if;
+   end Check_Arrow;
+
+   --------------------------
+   -- Check_Attribute_Name --
+   --------------------------
+
+   --  In check attribute casing mode (-gnatya), attribute names must be
+   --  mixed case, i.e. start with an upper case letter, and otherwise
+   --  lower case, except after an underline character.
+
+   procedure Check_Attribute_Name (Reserved : Boolean) is
+   begin
+      if Style_Check_Attribute_Casing then
+         if Determine_Token_Casing /= Mixed_Case then
+            Error_Msg_SC ("(style) bad capitalization, mixed case required");
+         end if;
+      end if;
+   end Check_Attribute_Name;
+
+   ---------------------------
+   -- Check_Binary_Operator --
+   ---------------------------
+
+   --  In check token mode (-gnatyt), binary operators other than the special
+   --  case of exponentiation require surrounding space characters.
+
+   procedure Check_Binary_Operator is
+   begin
+      if Style_Check_Tokens then
+         Require_Preceding_Space;
+         Require_Following_Space;
+      end if;
+   end Check_Binary_Operator;
+
+   ---------------
+   -- Check_Box --
+   ---------------
+
+   --  In check token mode (-gnatyt), box must be preceded by a space or by
+   --  a left parenthesis. Spacing checking on the surrounding tokens takes
+   --  care of the remaining checks.
+
+   procedure Check_Box is
+   begin
+      if Style_Check_Tokens then
+         if Prev_Token /= Tok_Left_Paren then
+            Require_Preceding_Space;
+         end if;
+      end if;
+   end Check_Box;
+
+   -----------------
+   -- Check_Colon --
+   -----------------
+
+   --  In check token mode (-gnatyt), colon must be surrounded by spaces
+
+   procedure Check_Colon is
+   begin
+      if Style_Check_Tokens then
+         Require_Preceding_Space;
+         Require_Following_Space;
+      end if;
+   end Check_Colon;
+
+   -----------------------
+   -- Check_Colon_Equal --
+   -----------------------
+
+   --  In check token mode (-gnatyt), := must be surrounded by spaces
+
+   procedure Check_Colon_Equal is
+   begin
+      if Style_Check_Tokens then
+         Require_Preceding_Space;
+         Require_Following_Space;
+      end if;
+   end Check_Colon_Equal;
+
+   -----------------
+   -- Check_Comma --
+   -----------------
+
+   --  In check token mode (-gnatyt), comma must be either the first
+   --  token on a line, or be preceded by a non-blank character.
+   --  It must also always be followed by a blank.
+
+   procedure Check_Comma is
+   begin
+      if Style_Check_Tokens then
+         if Token_Ptr > First_Non_Blank_Location
+           and then Source (Token_Ptr - 1) = ' '
+         then
+            Error_Space_Not_Allowed (Token_Ptr - 1);
+         end if;
+
+         if Source (Scan_Ptr) > ' ' then
+            Error_Space_Required (Scan_Ptr);
+         end if;
+      end if;
+   end Check_Comma;
+
+   -------------------
+   -- Check_Comment --
+   -------------------
+
+   --  In check comment mode (-gnatyc) there are several requirements on the
+   --  format of comments. The following are permissible comment formats:
+
+   --    1. Any comment that is not at the start of a line, i.e. where the
+   --       initial minuses are not the first non-blank characters on the
+   --       line must have at least one blank after the second minus.
+
+   --    2. A row of all minuses of any length is permitted (see procedure
+   --       box above in the source of this routine).
+
+   --    3. A comment line starting with two minuses and a space, and ending
+   --       with a space and two minuses. Again see the procedure title box
+   --       immediately above in the source.
+
+   --    4. A full line comment where two spaces follow the two minus signs.
+   --       This is the normal comment format in GNAT style, as typified by
+   --       the comments you are reading now.
+
+   --    5. A full line comment where the first character after the second
+   --       minus is a special character, i.e. a character in the ASCII
+   --       range 16#21#..16#2F# or 16#3A#..16#3F#. This allows special
+   --       comments, such as those generated by gnatprep, or those that
+   --       appear in the SPARK annotation language to be accepted.
+
+   procedure Check_Comment is
+      S : Source_Ptr;
+      C : Character;
+
+   begin
+      --  Can never have a non-blank character preceding the first minus
+
+      if Style_Check_Comments then
+         if Scan_Ptr > Source_First (Current_Source_File)
+           and then Source (Scan_Ptr - 1) > ' '
+         then
+            Error_Msg_S ("(style) space required");
+         end if;
+      end if;
+
+      --  For a comment that is not at the start of the line, the only
+      --  requirement is that we cannot have a non-blank character after
+      --  the second minus sign.
+
+      if Scan_Ptr /= First_Non_Blank_Location then
+         if Style_Check_Comments then
+            if Source (Scan_Ptr + 2) > ' ' then
+               Error_Msg ("(style) space required", Scan_Ptr + 2);
+            end if;
+         end if;
+
+         return;
+
+      --  Case of a comment that is at the start of a line
+
+      else
+         --  First check, must be in appropriately indented column
+
+         if Style_Check_Indentation /= 0 then
+            if Start_Column rem Style_Check_Indentation /= 0 then
+               Error_Msg_S ("(style) bad column");
+               return;
+            end if;
+         end if;
+
+         --  Now check form of the comment
+
+         if not Style_Check_Comments then
+            return;
+
+         --  Case of not followed by a blank. Usually wrong, but there are
+         --  some exceptions that we permit.
+
+         elsif Source (Scan_Ptr + 2) /= ' ' then
+            C := Source (Scan_Ptr + 2);
+
+            --  Case of -- all on its own on a line is OK
+
+            if C < ' ' then
+               return;
+
+            --  Case of --x, x special character is OK (gnatprep/SPARK/etc.)
+
+            elsif Character'Pos (C) in 16#21# .. 16#2F#
+                    or else
+                  Character'Pos (C) in 16#3A# .. 16#3F#
+            then
+               return;
+
+            --  Otherwise only cases allowed are when the entire line is
+            --  made up of minus signs (case of a box comment).
+
+            else
+               S := Scan_Ptr + 2;
+
+               while Source (S) >= ' ' loop
+                  if Source (S) /= '-' then
+                     Error_Space_Required (Scan_Ptr + 2);
+                     return;
+                  end if;
+
+                  S := S + 1;
+               end loop;
+            end if;
+
+         --  If we are followed by a blank, then the comment is OK if the
+         --  character following this blank is another blank or a format
+         --  effector.
+
+         elsif Source (Scan_Ptr + 3) <= ' ' then
+            return;
+
+         --  Here is the case where we only have one blank after the two minus
+         --  signs, which is an error unless the line ends with two blanks, the
+         --  case of a box comment.
+
+         else
+            S := Scan_Ptr + 3;
+
+            while Source (S) not in Line_Terminator loop
+               S := S + 1;
+            end loop;
+
+            if Source (S - 1) /= '-' or else Source (S - 2) /= '-' then
+               Error_Space_Required (Scan_Ptr + 3);
+            end if;
+         end if;
+      end if;
+   end Check_Comment;
+
+   -------------------
+   -- Check_Dot_Dot --
+   -------------------
+
+   --  In check token mode (-gnatyt), colon must be surrounded by spaces
+
+   procedure Check_Dot_Dot is
+   begin
+      if Style_Check_Tokens then
+         Require_Preceding_Space;
+         Require_Following_Space;
+      end if;
+   end Check_Dot_Dot;
+
+   -----------------------------------
+   -- Check_Exponentiation_Operator --
+   -----------------------------------
+
+   --  No spaces are required for the ** operator in GNAT style check mode
+
+   procedure Check_Exponentiation_Operator is
+   begin
+      null;
+   end Check_Exponentiation_Operator;
+
+   --------------
+   -- Check_HT --
+   --------------
+
+   --  In check horizontal tab mode (-gnatyh), tab characters are not allowed
+
+   procedure Check_HT is
+   begin
+      if Style_Check_Horizontal_Tabs then
+         Error_Msg_S ("(style) horizontal tab not allowed");
+      end if;
+   end Check_HT;
+
+   ----------------------
+   -- Check_Identifier --
+   ----------------------
+
+   --  In check references mode (-gnatyr), identifier uses must be cased
+   --  the same way as the corresponding identifier declaration.
+
+   procedure Check_Identifier
+     (Ref : Node_Or_Entity_Id;
+      Def : Node_Or_Entity_Id)
+   is
+      SRef : Source_Ptr := Sloc (Ref);
+      SDef : Source_Ptr := Sloc (Def);
+      TRef : Source_Buffer_Ptr;
+      TDef : Source_Buffer_Ptr;
+      Nlen : Nat;
+      Cas  : Casing_Type;
+
+   begin
+      --  If reference does not come from source, nothing to check
+
+      if not Comes_From_Source (Ref) then
+         return;
+
+      --  Case of definition comes from source
+
+      elsif Comes_From_Source (Def) then
+
+         --  Check same casing if we are checking references
+
+         if Style_Check_References then
+            TRef := Source_Text (Get_Source_File_Index (SRef));
+            TDef := Source_Text (Get_Source_File_Index (SDef));
+
+            --  Ignore operator name case completely. This also catches the
+            --  case of where one is an operator and the other is not. This
+            --  is a phenomenon from rewriting of operators as functions,
+            --  and is to be ignored.
+
+            if TRef (SRef) = '"' or else TDef (SDef) = '"' then
+               return;
+
+            else
+               for J in 1 .. Length_Of_Name (Chars (Ref)) loop
+                  if TRef (SRef) /= TDef (SDef) then
+                     Error_Msg_Node_1 := Def;
+                     Error_Msg_Sloc := Sloc (Def);
+                     Error_Msg
+                       ("(style) bad casing of & declared#", SRef);
+                     return;
+                  end if;
+
+                  SRef := SRef + 1;
+                  SDef := SDef + 1;
+               end loop;
+            end if;
+         end if;
+
+      --  Case of definition in package Standard
+
+      elsif SDef = Standard_Location then
+
+         --  Check case of identifiers in Standard
+
+         if Style_Check_Standard then
+            TRef := Source_Text (Get_Source_File_Index (SRef));
+
+            --  Ignore operators
+
+            if TRef (SRef) = '"' then
+               null;
+
+            --  Special case of ASCII
+
+            else
+               if Entity (Ref) = Standard_ASCII then
+                  Cas := All_Upper_Case;
+
+               elsif Entity (Ref) in SE (S_LC_A) .. SE (S_LC_Z)
+                       or else
+                     Entity (Ref) in SE (S_NUL) .. SE (S_US)
+                       or else
+                     Entity (Ref) = SE (S_DEL)
+               then
+                  Cas := All_Upper_Case;
+
+               else
+                  Cas := Mixed_Case;
+               end if;
+
+               Nlen  := Length_Of_Name (Chars (Ref));
+
+               if Determine_Casing
+                    (TRef (SRef .. SRef + Source_Ptr (Nlen) - 1)) = Cas
+               then
+                  null;
+               else
+                  Error_Msg_N
+                    ("(style) bad casing for entity in Standard", Ref);
+               end if;
+            end if;
+         end if;
+      end if;
+   end Check_Identifier;
+
+   -----------------------
+   -- Check_Indentation --
+   -----------------------
+
+   --  In check indentation mode (-gnatyn for n a digit), a new statement or
+   --  declaration is required to start in a column that is a multiple of the
+   --  indentiation amount.
+
+   procedure Check_Indentation is
+   begin
+      if Style_Check_Indentation /= 0 then
+         if Token_Ptr = First_Non_Blank_Location
+           and then Start_Column rem Style_Check_Indentation /= 0
+         then
+            Error_Msg_SC ("(style) bad indentation");
+         end if;
+      end if;
+   end Check_Indentation;
+
+   ----------------------
+   -- Check_Left_Paren --
+   ----------------------
+
+   --  In tone check mode (-gnatyt), left paren must not be preceded by an
+   --  identifier character or digit (a separating space is required) and
+   --  may never be followed by a space.
+
+   procedure Check_Left_Paren is
+      S : Source_Ptr;
+
+   begin
+      if Style_Check_Tokens then
+         if Token_Ptr > Source_First (Current_Source_File)
+           and then Identifier_Char (Source (Token_Ptr - 1))
+         then
+            Error_Space_Required (Token_Ptr);
+         end if;
+
+         if Source (Scan_Ptr) = ' ' then
+
+            --  Allow one or more spaces if followed by comment
+
+            S := Scan_Ptr + 1;
+            loop
+               if Source (S) = '-' and then Source (S + 1) = '-' then
+                  return;
+               elsif Source (S) /= ' ' then
+                  exit;
+               else
+                  S := S + 1;
+               end if;
+            end loop;
+
+            Error_Space_Not_Allowed (Scan_Ptr);
+         end if;
+      end if;
+   end Check_Left_Paren;
+
+   ---------------------------
+   -- Check_Line_Terminator --
+   ---------------------------
+
+   --  In check blanks at end mode (-gnatyb), lines may not end with a
+   --  trailing space.
+
+   --  In check max line length mode (-gnatym), the line length must
+   --  not exceed the permitted maximum value.
+
+   --  In check form feeds mode (-gnatyf), the line terminator may not
+   --  be either of the characters FF or VT.
+
+   procedure Check_Line_Terminator (Len : Int) is
+      S : Source_Ptr;
+
+   begin
+      --  Check FF/VT terminators
+
+      if Style_Check_Form_Feeds then
+         if Source (Scan_Ptr) = ASCII.FF then
+            Error_Msg_S ("(style) form feed not allowed");
+
+         elsif Source (Scan_Ptr) = ASCII.VT then
+            Error_Msg_S ("(style) vertical tab not allowed");
+         end if;
+      end if;
+
+      --  Check trailing space
+
+      if Style_Check_Blanks_At_End then
+         if Scan_Ptr >= First_Non_Blank_Location then
+            if Source (Scan_Ptr - 1) = ' ' then
+               S := Scan_Ptr - 1;
+
+               while Source (S - 1) = ' ' loop
+                  S := S - 1;
+               end loop;
+
+               Error_Msg ("(style) trailing spaces not permitted", S);
+            end if;
+         end if;
+      end if;
+
+      --  Check max line length
+
+      if Style_Check_Max_Line_Length then
+         if Len > Style_Max_Line_Length then
+            Error_Msg
+              ("(style) this line is too long",
+               Current_Line_Start + Source_Ptr (Style_Max_Line_Length));
+         end if;
+      end if;
+
+   end Check_Line_Terminator;
+
+   -----------------------
+   -- Check_Pragma_Name --
+   -----------------------
+
+   --  In check pragma casing mode (-gnatyp), pragma names must be mixed
+   --  case, i.e. start with an upper case letter, and otherwise lower case,
+   --  except after an underline character.
+
+   procedure Check_Pragma_Name is
+   begin
+      if Style_Check_Pragma_Casing then
+         if Determine_Token_Casing /= Mixed_Case then
+            Error_Msg_SC ("(style) bad capitalization, mixed case required");
+         end if;
+      end if;
+   end Check_Pragma_Name;
+
+   -----------------------
+   -- Check_Right_Paren --
+   -----------------------
+
+   --  In check tokens mode (-gnatyt), right paren must never be preceded by
+   --  a space unless it is the initial non-blank character on the line.
+
+   procedure Check_Right_Paren is
+   begin
+      if Style_Check_Tokens then
+         if Token_Ptr > First_Non_Blank_Location
+           and then Source (Token_Ptr - 1) = ' '
+         then
+            Error_Space_Not_Allowed (Token_Ptr - 1);
+         end if;
+      end if;
+   end Check_Right_Paren;
+
+   ---------------------
+   -- Check_Semicolon --
+   ---------------------
+
+   --  In check tokens mode (-gnatyt), semicolon does not permit a preceding
+   --  space and a following space is required.
+
+   procedure Check_Semicolon is
+   begin
+      if Style_Check_Tokens then
+         if Scan_Ptr > Source_First (Current_Source_File)
+           and then Source (Token_Ptr - 1) = ' '
+         then
+            Error_Space_Not_Allowed (Token_Ptr - 1);
+
+         elsif Source (Scan_Ptr) > ' ' then
+            Error_Space_Required (Scan_Ptr);
+         end if;
+      end if;
+   end Check_Semicolon;
+
+   ----------------
+   -- Check_Then --
+   ----------------
+
+   --  In check if then layout mode (-gnatyi), we expect a THEN keyword
+   --  to appear either on the same line as the IF, or on a separate line
+   --  after multiple conditions. In any case, it may not appear on the
+   --  line immediately following the line with the IF.
+
+   procedure Check_Then (If_Loc : Source_Ptr) is
+   begin
+      if Style_Check_If_Then_Layout then
+         if Get_Physical_Line_Number (Token_Ptr) =
+            Get_Physical_Line_Number (If_Loc) + 1
+         then
+            Error_Msg_SC ("(style) misplaced THEN");
+         end if;
+      end if;
+   end Check_Then;
+
+   -------------------------------
+   -- Check_Unary_Plus_Or_Minus --
+   -------------------------------
+
+   --  In check tokem mode (-gnatyt), unary plus or minus must not be
+   --  followed by a space.
+
+   procedure Check_Unary_Plus_Or_Minus is
+   begin
+      if Style_Check_Tokens then
+         if Source (Scan_Ptr) = ' ' then
+            Error_Space_Not_Allowed (Scan_Ptr);
+         end if;
+      end if;
+   end Check_Unary_Plus_Or_Minus;
+
+   ------------------------
+   -- Check_Vertical_Bar --
+   ------------------------
+
+   --  In check token mode (-gnatyt), vertical bar must be surrounded by spaces
+
+   procedure Check_Vertical_Bar is
+   begin
+      if Style_Check_Tokens then
+         Require_Preceding_Space;
+         Require_Following_Space;
+      end if;
+   end Check_Vertical_Bar;
+
+   -----------------------------
+   -- Error_Space_Not_Allowed --
+   -----------------------------
+
+   procedure Error_Space_Not_Allowed (S : Source_Ptr) is
+   begin
+      Error_Msg ("(style) space not allowed", S);
+   end Error_Space_Not_Allowed;
+
+   --------------------------
+   -- Error_Space_Required --
+   --------------------------
+
+   procedure Error_Space_Required (S : Source_Ptr) is
+   begin
+      Error_Msg ("(style) space required", S);
+   end Error_Space_Required;
+
+   -----------------
+   -- No_End_Name --
+   -----------------
+
+   --  In check end/exit labels mode (-gnatye), always require the name of
+   --  a subprogram or package to be present on the END, so this is an error.
+
+   procedure No_End_Name (Name : Node_Id) is
+   begin
+      if Style_Check_End_Labels then
+         Error_Msg_Node_1 := Name;
+         Error_Msg_SP ("(style) `END &` required");
+      end if;
+   end No_End_Name;
+
+   ------------------
+   -- No_Exit_Name --
+   ------------------
+
+   --  In check end/exit labels mode (-gnatye), always require the name of
+   --  the loop to be present on the EXIT when exiting a named loop.
+
+   procedure No_Exit_Name (Name : Node_Id) is
+   begin
+      if Style_Check_End_Labels then
+         Error_Msg_Node_1 := Name;
+         Error_Msg_SP ("(style) `EXIT &` required");
+      end if;
+   end No_Exit_Name;
+
+   ----------------------------
+   -- Non_Lower_Case_Keyword --
+   ----------------------------
+
+   --  In check casing mode (-gnatyk), reserved keywords must be be spelled
+   --  in all lower case (excluding keywords range, access, delta and digits
+   --  used as attribute designators).
+
+   procedure Non_Lower_Case_Keyword is
+   begin
+      if Style_Check_Keyword_Casing then
+         Error_Msg_SC ("(style) reserved words must be all lower case");
+      end if;
+   end Non_Lower_Case_Keyword;
+
+   -----------------------------
+   -- Require_Following_Space --
+   -----------------------------
+
+   procedure Require_Following_Space is
+   begin
+      if Source (Scan_Ptr) > ' ' then
+         Error_Space_Required (Scan_Ptr);
+      end if;
+   end Require_Following_Space;
+
+   -----------------------------
+   -- Require_Preceding_Space --
+   -----------------------------
+
+   procedure Require_Preceding_Space is
+   begin
+      if Token_Ptr > Source_First (Current_Source_File)
+        and then Source (Token_Ptr - 1) > ' '
+      then
+         Error_Space_Required (Token_Ptr);
+      end if;
+   end Require_Preceding_Space;
+
+   ---------------------
+   -- RM_Column_Check --
+   ---------------------
+
+   function RM_Column_Check return Boolean is
+   begin
+      return Style_Check and Style_Check_Layout;
+   end RM_Column_Check;
+
+   -----------------------------------
+   -- Subprogram_Not_In_Alpha_Order --
+   -----------------------------------
+
+   procedure Subprogram_Not_In_Alpha_Order (Name : Node_Id) is
+   begin
+      if Style_Check_Subprogram_Order then
+         Error_Msg_N
+           ("(style) subprogram body& not in alphabetical order", Name);
+      end if;
+   end Subprogram_Not_In_Alpha_Order;
+end Style;
diff --git a/gcc/ada/style.ads b/gcc/ada/style.ads
new file mode 100644
index 00000000000..a75807c1757
--- /dev/null
+++ b/gcc/ada/style.ads
@@ -0,0 +1,156 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                                S T Y L E                                 --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.12 $
+--                                                                          --
+--          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). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  This package collects all the routines used for style checking, as
+--  activated by the relevant command line option. These are gathered in
+--  a separate package so that they can more easily be customized. Calls
+--  to these subprograms are only made if Opt.Style_Check is set True.
+
+with Types; use Types;
+
+package Style is
+
+   procedure Body_With_No_Spec (N : Node_Id);
+   --  Called where N is a subprogram body node for a subprogram body
+   --  for which no spec was given, i.e. a body acting as its own spec.
+
+   procedure Check_Abs_Not;
+   --  Called after scanning an ABS or NOT operator to check spacing
+
+   procedure Check_Arrow;
+   --  Called after scanning out an arrow to check spacing
+
+   procedure Check_Attribute_Name (Reserved : Boolean);
+   --  The current token is an attribute designator. Check that it is
+   --  capitalized in an appropriate manner. Reserved is set if the
+   --  attribute designator is a reserved word (access, digits, delta
+   --  or range) to allow differing rules for the two cases.
+
+   procedure Check_Box;
+   --  Called after scanning out a box to check spacing
+
+   procedure Check_Binary_Operator;
+   --  Called after scanning out a binary operator other than a plus, minus
+   --  or exponentiation operator. Intended for checking spacing rules.
+
+   procedure Check_Exponentiation_Operator;
+   --  Called after scanning out an exponentiation operator. Intended for
+   --  checking spacing rules.
+
+   procedure Check_Colon;
+   --  Called after scanning out colon to check spacing
+
+   procedure Check_Colon_Equal;
+   --  Called after scanning out colon equal to check spacing
+
+   procedure Check_Comma;
+   --  Called after scanning out comma to check spacing
+
+   procedure Check_Comment;
+   --  Called with Scan_Ptr pointing to the first minus sign of a comment.
+   --  Intended for checking any specific rules for comment placement/format.
+
+   procedure Check_Dot_Dot;
+   --  Called after scanning out dot dot to check spacing
+
+   procedure Check_HT;
+   --  Called with Scan_Ptr pointing to a horizontal tab character
+
+   procedure Check_Identifier
+     (Ref : Node_Or_Entity_Id;
+      Def : Node_Or_Entity_Id);
+   --  Check style of identifier occurrence. Ref is an N_Identifier node whose
+   --  spelling is to be checked against the Chars spelling in identifier node
+   --  Def (which may be either an N_Identifier, or N_Defining_Identifier node)
+
+   procedure Check_Indentation;
+   --  Called at the start of a new statement or declaration, with Token_Ptr
+   --  pointing to the first token of the statement or declaration. The check
+   --  is that the starting column is appropriate to the indentation rules if
+   --  Token_Ptr is the first token on the line.
+
+   procedure Check_Left_Paren;
+   --  Called after scanning out a left parenthesis to check spacing.
+
+   procedure Check_Line_Terminator (Len : Int);
+   --  Called with Scan_Ptr pointing to the first line terminator terminating
+   --  the current line, used to check for appropriate line terminator and
+   --  to check the line length (Len is the length of the current line).
+   --  Note that the terminator may be the EOF character.
+
+   procedure Check_Pragma_Name;
+   --  The current token is a pragma identifier. Check that it is spelled
+   --  properly (i.e. with an appropriate casing convention).
+
+   procedure Check_Right_Paren;
+   --  Called after scanning out a right parenthesis to check spacing.
+
+   procedure Check_Semicolon;
+   --  Called after scanning out a semicolon to check spacing
+
+   procedure Check_Then (If_Loc : Source_Ptr);
+   --  Called to check that THEN and IF keywords are appropriately positioned.
+   --  The parameters show the first characters of the two keywords. This
+   --  procedure is called only if THEN appears at the start of a line with
+   --  Token_Ptr pointing to the THEN keyword.
+
+   procedure Check_Unary_Plus_Or_Minus;
+   --  Called after scanning a unary plus or minus to check spacing
+
+   procedure Check_Vertical_Bar;
+   --  Called after scanning a vertical bar to check spacing
+
+   procedure No_End_Name (Name : Node_Id);
+   --  Called if an END is encountered where a name is allowed but not present.
+   --  The parameter is the node whose name is the name that is permitted in
+   --  the END line, and the scan pointer is positioned so that if an error
+   --  message is to be generated in this situation, it should be generated
+   --  using Error_Msg_SP.
+
+   procedure No_Exit_Name (Name : Node_Id);
+   --  Called when exiting a named loop, but a name is not present on the EXIT.
+   --  The parameter is the node whose name should have followed EXIT, and the
+   --  scan pointer is positioned so that if an error message is to be
+   --  generated, it should be generated using Error_Msg_SP.
+
+   procedure Non_Lower_Case_Keyword;
+   --  Called if a reserved keyword is scanned which is not spelled in all
+   --  lower case letters. On entry Token_Ptr points to the keyword token.
+   --  This is not used for keywords appearing as attribute designators,
+   --  where instead Check_Attribute_Name (True) is called.
+
+   function RM_Column_Check return Boolean;
+   pragma Inline (RM_Column_Check);
+   --  Determines whether style checking is active and the RM column check
+   --  mode is set requiring checking of RM format layout.
+
+   procedure Subprogram_Not_In_Alpha_Order (Name : Node_Id);
+   --  Called if Name is the name of a subprogram body in a package body
+   --  that is not in alphabetical order.
+
+end Style;
diff --git a/gcc/ada/stylesw.adb b/gcc/ada/stylesw.adb
new file mode 100644
index 00000000000..aae4d0475e9
--- /dev/null
+++ b/gcc/ada/stylesw.adb
@@ -0,0 +1,255 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              S T Y L E S W                               --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.14 $
+--                                                                          --
+--          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 Hostparm; use Hostparm;
+with Opt;      use Opt;
+
+package body Stylesw is
+
+   -------------------------------
+   -- Reset_Style_Check_Options --
+   -------------------------------
+
+   procedure Reset_Style_Check_Options is
+   begin
+      Style_Check_Indentation      := 0;
+      Style_Check_Attribute_Casing := False;
+      Style_Check_Blanks_At_End    := False;
+      Style_Check_Comments         := False;
+      Style_Check_End_Labels       := False;
+      Style_Check_Form_Feeds       := False;
+      Style_Check_Horizontal_Tabs  := False;
+      Style_Check_If_Then_Layout   := False;
+      Style_Check_Keyword_Casing   := False;
+      Style_Check_Layout           := False;
+      Style_Check_Max_Line_Length  := False;
+      Style_Check_Pragma_Casing    := False;
+      Style_Check_References       := False;
+      Style_Check_Specs            := False;
+      Style_Check_Standard         := False;
+      Style_Check_Subprogram_Order := False;
+      Style_Check_Tokens           := False;
+   end Reset_Style_Check_Options;
+
+   ------------------------------
+   -- Save_Style_Check_Options --
+   ------------------------------
+
+   procedure Save_Style_Check_Options (Options : out Style_Check_Options) is
+      P : Natural := 0;
+      J : Natural;
+
+      procedure Add (C : Character; S : Boolean);
+      --  Add given character C to string if switch S is true
+
+      procedure Add (C : Character; S : Boolean) is
+      begin
+         if S then
+            P := P + 1;
+            Options (P) := C;
+         end if;
+      end Add;
+
+   --  Start of processing for Save_Style_Check_Options
+
+   begin
+      for K in Options'Range loop
+         Options (K) := ' ';
+      end loop;
+
+      Add (Character'Val (Style_Check_Indentation + Character'Pos ('0')),
+           Style_Check_Indentation /= 0);
+
+      Add ('a', Style_Check_Attribute_Casing);
+      Add ('b', Style_Check_Blanks_At_End);
+      Add ('c', Style_Check_Comments);
+      Add ('e', Style_Check_End_Labels);
+      Add ('f', Style_Check_Form_Feeds);
+      Add ('h', Style_Check_Horizontal_Tabs);
+      Add ('i', Style_Check_If_Then_Layout);
+      Add ('k', Style_Check_Keyword_Casing);
+      Add ('l', Style_Check_Layout);
+      Add ('m', Style_Check_Max_Line_Length);
+      Add ('n', Style_Check_Standard);
+      Add ('o', Style_Check_Subprogram_Order);
+      Add ('p', Style_Check_Pragma_Casing);
+      Add ('r', Style_Check_References);
+      Add ('s', Style_Check_Specs);
+      Add ('t', Style_Check_Tokens);
+
+      if Style_Check_Max_Line_Length then
+         P := Options'Last;
+         J := Natural (Style_Max_Line_Length);
+
+         loop
+            Options (P) := Character'Val (J mod 10 + Character'Pos ('0'));
+            P := P - 1;
+            J := J / 10;
+            exit when J = 0;
+         end loop;
+
+         Options (P) := 'M';
+      end if;
+
+   end Save_Style_Check_Options;
+
+   -------------------------------------
+   -- Set_Default_Style_Check_Options --
+   -------------------------------------
+
+   procedure Set_Default_Style_Check_Options is
+   begin
+      Reset_Style_Check_Options;
+      Set_Style_Check_Options ("3abcefhiklmnprst");
+   end Set_Default_Style_Check_Options;
+
+   -----------------------------
+   -- Set_Style_Check_Options --
+   -----------------------------
+
+   --  Version used when no error checking is required
+
+   procedure Set_Style_Check_Options (Options : String) is
+      OK : Boolean;
+      EC : Natural;
+
+   begin
+      Set_Style_Check_Options (Options, OK, EC);
+   end Set_Style_Check_Options;
+
+   --  Normal version with error checking
+
+   procedure Set_Style_Check_Options
+     (Options  : String;
+      OK       : out Boolean;
+      Err_Col  : out Natural)
+   is
+      J : Natural;
+      C : Character;
+
+   begin
+      J := Options'First;
+      while J <= Options'Last loop
+         C := Options (J);
+         J := J + 1;
+
+         case C is
+            when '1' .. '9' =>
+               Style_Check_Indentation
+                  := Character'Pos (C) - Character'Pos ('0');
+
+            when 'a' =>
+               Style_Check_Attribute_Casing := True;
+
+            when 'b' =>
+               Style_Check_Blanks_At_End    := True;
+
+            when 'c' =>
+               Style_Check_Comments         := True;
+
+            when 'e' =>
+               Style_Check_End_Labels       := True;
+
+            when 'f' =>
+               Style_Check_Form_Feeds       := True;
+
+            when 'h' =>
+               Style_Check_Horizontal_Tabs  := True;
+
+            when 'i' =>
+               Style_Check_If_Then_Layout   := True;
+
+            when 'k' =>
+               Style_Check_Keyword_Casing   := True;
+
+            when 'l' =>
+               Style_Check_Layout           := True;
+
+            when 'm' =>
+               Style_Check_Max_Line_Length  := True;
+               Style_Max_Line_Length        := 79;
+
+            when 'n' =>
+               Style_Check_Standard         := True;
+
+            when 'M' =>
+               Style_Max_Line_Length := 0;
+
+               if J > Options'Last
+                 or else Options (J) not in '0' .. '9'
+               then
+                  OK := False;
+                  Err_Col := J;
+                  return;
+               end if;
+
+               loop
+                  Style_Max_Line_Length :=
+                    Style_Max_Line_Length * 10 +
+                      Character'Pos (Options (J)) - Character'Pos ('0');
+                  J := J + 1;
+                  exit when J > Options'Last
+                    or else Options (J) not in '0' .. '9';
+               end loop;
+
+               Style_Max_Line_Length :=
+                  Int'Min (Style_Max_Line_Length, Hostparm.Max_Line_Length);
+
+               Style_Check_Max_Line_Length := Style_Max_Line_Length /= 0;
+
+            when 'o' =>
+               Style_Check_Subprogram_Order := True;
+
+            when 'p' =>
+               Style_Check_Pragma_Casing    := True;
+
+            when 'r' =>
+               Style_Check_References       := True;
+
+            when 's' =>
+               Style_Check_Specs            := True;
+
+            when 't' =>
+               Style_Check_Tokens           := True;
+
+            when ' ' =>
+               null;
+
+            when others =>
+               OK      := False;
+               Err_Col := J - 1;
+               return;
+         end case;
+      end loop;
+
+      Style_Check := True;
+      OK := True;
+      Err_Col := Options'Last + 1;
+   end Set_Style_Check_Options;
+
+end Stylesw;
diff --git a/gcc/ada/stylesw.ads b/gcc/ada/stylesw.ads
new file mode 100644
index 00000000000..3352b4cf0be
--- /dev/null
+++ b/gcc/ada/stylesw.ads
@@ -0,0 +1,264 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              S T Y L E S W                               --
+--                                                                          --
+--                                 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 contains the style switches used for setting style options.
+--  The only clients of this package are the body of Style and the body of
+--  Switches. All other style checking issues are handled using the public
+--  interfaces in the spec of Style.
+
+with Types; use Types;
+
+package Stylesw is
+
+   --------------------------
+   -- Style Check Switches --
+   --------------------------
+
+   --  These flags are used to control the details of the style checking
+   --  options. The default values shown here correspond to no style
+   --  checking. If any of these values is set to a non-default value,
+   --  then Opt.Style_Check is set True to active calls to this package.
+
+   --  The actual mechanism for setting these switches to other than
+   --  default values is via the Set_Style_Check_Option procedure or
+   --  through a call to Set_Default_Style_Check_Options. They should
+   --  not be set directly in any other manner.
+
+   Style_Check_Attribute_Casing : Boolean := False;
+   --  This can be set True by using the -gnatg or -gnatya switches. If
+   --  it is True, then attribute names (including keywords such as
+   --  digits used as attribute names) must be in mixed case.
+
+   Style_Check_Blanks_At_End : Boolean := False;
+   --  This can be set True by using the -gnatg or -gnatyb switches. If
+   --  it is True, then spaces at the end of lines are not permitted.
+
+   Style_Check_Comments : Boolean := False;
+   --  This can be set True by using the -gnatg or -gnatyc switches. If
+   --  it is True, then comments are style checked as follows:
+   --
+   --    All comments must be at the start of the line, or the first
+   --    minus must be preceded by at least one space.
+   --
+   --    For a comment that is not at the start of a line, the only
+   --    requirement is that a space follow the comment characters.
+   --
+   --    For a coment that is at the start of the line, one of the
+   --    following conditions must hold:
+   --
+   --      The comment characters are the only non-blank characters on the line
+   --
+   --      The comment characters are followed by an exclamation point (the
+   --      sequence --! is used by gnatprep for marking deleted lines).
+   --
+   --      The comment characters are followed by two space characters
+   --
+   --      The line consists entirely of minus signs
+   --
+   --      The comment characters are followed by a single space, and the
+   --      last two characters on the line are also comment characters.
+   --
+   --  Note: the reason for the last two conditions is to allow "boxed"
+   --  comments where only a single space separates the comment characters.
+
+   Style_Check_End_Labels : Boolean := False;
+   --  This can be set True by using the -gnatg or -gnatye switches. If
+   --  it is True, then optional END labels must always be present.
+
+   Style_Check_Form_Feeds : Boolean := False;
+   --  This can be set True by using the -gnatg or -gnatyf switches. If
+   --  it is True, then form feeds and vertical tabs are not allowed in
+   --  the source text.
+
+   Style_Check_Horizontal_Tabs : Boolean := False;
+   --  This can be set True by using the -gnatg or -gnatyh switches. If
+   --  it is True, then horizontal tabs are not allowed in source text.
+
+   Style_Check_If_Then_Layout : Boolean := False;
+   --  This can be set True by using the -gnatg or -gnatyi switches. If
+   --  it is True, then a THEN keyword may not appear on the line that
+   --  immediately follows the line containing the corresponding IF.
+   --
+   --  This permits one of two styles for IF-THEN layout. Either the
+   --  IF and THEN keywords are on the same line, where the condition
+   --  is short enough, or the conditions are continued over to the
+   --  lines following the IF and the THEN stands on its own. For
+   --  example:
+   --
+   --    if X > Y then
+   --
+   --    if X > Y
+   --      and then Y < Z
+   --    then
+   --
+   --  are allowed, but
+   --
+   --    if X > Y
+   --    then
+   --
+   --  is not allowed.
+
+   Style_Check_Indentation : Column_Number range 0 .. 9 := 0;
+   --  This can be set non-zero by using the -gnatg or -gnatyn (n a digit)
+   --  switches. If it is non-zero it activates indentation checking with
+   --  the indicated indentation value. A value of zero turns off checking.
+   --  The requirement is that any new statement, line comment, declaration
+   --  or keyword such as END, start on a column that is a multiple of the
+   --  indentiation value.
+
+   Style_Check_Keyword_Casing : Boolean := False;
+   --  This can be set True by using the -gnatg or -gnatyk switches. If
+   --  it is True, then keywords are required to be in all lower case.
+   --  This rule does not apply to keywords such as digits appearing as
+   --  an attribute name.
+
+   Style_Check_Max_Line_Length : Boolean := False;
+   --  This can be set True by using the -gnatg or -gnatym switches. If
+   --  it is True, it activates checking for a maximum line length of 79
+   --  characters (chosen to fit in standard 80 column displays that don't
+   --  handle the limiting case of 80 characters cleanly).
+
+   Style_Check_Pragma_Casing : Boolean := False;
+   --  This can be set True by using the -gnatg or -gnatyp switches. If
+   --  it is True, then pragma names must use mixed case.
+
+   Style_Check_Layout : Boolean := False;
+   --  This can be set True by using the -gnatg or -gnatyl switches. If
+   --  it is True, it activates checks that constructs are indented as
+   --  suggested by the examples in the RM syntax, e.g. that the ELSE
+   --  keyword must line up with the IF keyword.
+
+   Style_Check_References : Boolean := False;
+   --  This can be set True by using the -gnatg or -gnatyr switches. If
+   --  it is True, then all references to declared identifiers are
+   --  checked. The requirement is that casing of the reference be the
+   --  same as the casing of the corresponding declaration.
+
+   Style_Check_Specs : Boolean := False;
+   --  This can be set True by using the -gnatg or -gnatys switches. If
+   --  it is True, then separate specs are required to be present for
+   --  all procedures except parameterless library level procedures.
+   --  The exception means that typical main programs do not require
+   --  separate specs.
+
+   Style_Check_Standard : Boolean := False;
+   --  This can be set True by using the -gnatg or -gnatyn switches. If
+   --  it is True, then any references to names in Standard have to be
+   --  in mixed case mode (e.g. Integer, Boolean).
+
+   Style_Check_Tokens : Boolean := False;
+   --  This can be set True by using the -gnatg or -gnatyt switches. If
+   --  it is True, then the style check that requires canonical spacing
+   --  between various punctuation tokens as follows:
+   --
+   --    ABS and NOT must be followed by a space
+   --
+   --    => must be surrounded by spaces
+   --
+   --    <> must be preceded by a space or left paren
+   --
+   --    Binary operators other than ** must be surrounded by spaces.
+   --    There is no restriction on the layout of the ** binary operator.
+   --
+   --    Colon must be surrounded by spaces
+   --
+   --    Colon-equal (assignment) must be surrounded by spaces
+   --
+   --    Comma must be the first non-blank character on the line, or be
+   --    immediately preceded by a non-blank character, and must be followed
+   --    by a blank.
+   --
+   --    A space must precede a left paren following a digit or letter,
+   --    and a right paren must not be followed by a space (it can be
+   --    at the end of the line).
+   --
+   --    A right paren must either be the first non-blank character on
+   --    a line, or it must be preceded by a non-blank character.
+   --
+   --    A semicolon must not be preceded by a blank, and must not be
+   --    followed by a non-blank character.
+   --
+   --    A unary plus or minus may not be followed by a space
+   --
+   --    A vertical bar must be surrounded by spaces
+   --
+   --  Note that a requirement that a token be preceded by a space is
+   --  met by placing the token at the start of the line, and similarly
+   --  a requirement that a token be followed by a space is met by
+   --  placing the token at the end of the line. Note that in the case
+   --  where horizontal tabs are permitted, a horizontal tab is acceptable
+   --  for meeting the requirement for a space.
+
+   Style_Check_Subprogram_Order : Boolean := False;
+   --  This can be set True by using the -gnatg or -gnatyo switch. If it
+   --  is True, then names of subprogram bodies must be in alphabetical
+   --  order (not taking casing into account).
+
+   Style_Max_Line_Length : Int := 79;
+   --  Value used to check maximum line length. Can be reset by a call to
+   --  Set_Max_Line_Length. The value here is the default if no such call.
+
+   -----------------
+   -- Subprograms --
+   -----------------
+
+   procedure Set_Default_Style_Check_Options;
+   --  This procedure is called to set the default style checking options
+   --  in response to a -gnatg switch or -gnaty with no suboptions.
+
+   procedure Set_Style_Check_Options
+     (Options  : String;
+      OK       : out Boolean;
+      Err_Col  : out Natural);
+   --  This procedure is called to set the style check options that
+   --  correspond to the characters in the given Options string. If
+   --  all options are valid, they are set in an additive manner:
+   --  any previous options are retained unless overridden. If any
+   --  invalid character is found, then OK is False on exit, and
+   --  Err_Col is the index in options of the bad character. If all
+   --  options are valid, OK is True on return, and Err_Col is set
+   --  to Options'Last + 1.
+
+   procedure Set_Style_Check_Options (Options : String);
+   --  Like the above procedure, except that the call is simply ignored if
+   --  there are any error conditions, this is for example appopriate for
+   --  calls where the string is known to be valid, e.g. because it was
+   --  obtained by Save_Style_Check_Options.
+
+   procedure Reset_Style_Check_Options;
+   --  Sets all style check options to off
+
+   subtype Style_Check_Options is String (1 .. 32);
+   --  Long enough string to hold all options from Save call below
+
+   procedure Save_Style_Check_Options (Options : out Style_Check_Options);
+   --  Sets Options to represent current selection of options. This
+   --  set can be restored by first calling Reset_Style_Check_Options,
+   --  and then calling Set_Style_Check_Options with the Options string.
+
+end Stylesw;
diff --git a/gcc/ada/switch.adb b/gcc/ada/switch.adb
new file mode 100644
index 00000000000..ee97c6ff746
--- /dev/null
+++ b/gcc/ada/switch.adb
@@ -0,0 +1,1364 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                               S W I T C H                                --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.194 $
+--                                                                          --
+--          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). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  Option switch scanning for both the compiler and the binder
+
+--  Note: this version of the package should be usable in both Unix and DOS
+
+with Debug;    use Debug;
+with Osint;    use Osint;
+with Opt;      use Opt;
+with Validsw;  use Validsw;
+with Stylesw;  use Stylesw;
+with Types;    use Types;
+
+with System.WCh_Con; use System.WCh_Con;
+
+package body Switch is
+
+   Bad_Switch : exception;
+   --  Exception raised if bad switch encountered
+
+   Bad_Switch_Value : exception;
+   --  Exception raised if bad switch value encountered
+
+   Missing_Switch_Value : exception;
+   --  Exception raised if no switch value encountered
+
+   Too_Many_Output_Files : exception;
+   --  Exception raised if the -o switch is encountered more than once
+
+   Switch_Max_Value : constant := 999;
+   --  Maximum value permitted in switches that take a value
+
+   procedure Scan_Nat
+     (Switch_Chars : String;
+      Max          : Integer;
+      Ptr          : in out Integer;
+      Result       : out Nat);
+   --  Scan natural integer parameter for switch. On entry, Ptr points
+   --  just past the switch character, on exit it points past the last
+   --  digit of the integer value.
+
+   procedure Scan_Pos
+     (Switch_Chars : String;
+      Max          : Integer;
+      Ptr          : in out Integer;
+      Result       : out Pos);
+   --  Scan positive integer parameter for switch. On entry, Ptr points
+   --  just past the switch character, on exit it points past the last
+   --  digit of the integer value.
+
+   -------------------------
+   -- Is_Front_End_Switch --
+   -------------------------
+
+   function Is_Front_End_Switch (Switch_Chars : String) return Boolean is
+      Ptr       : constant Positive := Switch_Chars'First;
+   begin
+      return Is_Switch (Switch_Chars)
+        and then
+          (Switch_Chars (Ptr + 1) = 'I'
+             or else
+          (Switch_Chars'Length >= 5
+                         and then Switch_Chars (Ptr + 1 .. Ptr + 4) = "gnat"));
+   end Is_Front_End_Switch;
+
+   ---------------
+   -- Is_Switch --
+   ---------------
+
+   function Is_Switch (Switch_Chars : String) return Boolean is
+   begin
+      return Switch_Chars'Length > 1
+        and then (Switch_Chars (Switch_Chars'First) = '-'
+                     or
+                  Switch_Chars (Switch_Chars'First) = Switch_Character);
+   end Is_Switch;
+
+   --------------------------
+   -- Scan_Binder_Switches --
+   --------------------------
+
+   procedure Scan_Binder_Switches (Switch_Chars : String) is
+      Ptr : Integer := Switch_Chars'First;
+      Max : Integer := Switch_Chars'Last;
+      C   : Character := ' ';
+
+   begin
+      --  Skip past the initial character (must be the switch character)
+
+      if Ptr = Max then
+         raise Bad_Switch;
+      else
+         Ptr := Ptr + 1;
+      end if;
+
+      --  A little check, "gnat" at the start of a switch is not allowed
+      --  except for the compiler
+
+      if Switch_Chars'Last >= Ptr + 3
+        and then Switch_Chars (Ptr .. Ptr + 3) = "gnat"
+      then
+         Osint.Fail ("invalid switch: """, Switch_Chars, """"
+            & " (gnat not needed here)");
+
+      end if;
+
+      --  Loop to scan through switches given in switch string
+
+      while Ptr <= Max loop
+         C := Switch_Chars (Ptr);
+
+         case C is
+
+         --  Processing for A switch
+
+         when 'A' =>
+            Ptr := Ptr + 1;
+
+            Ada_Bind_File := True;
+
+         --  Processing for b switch
+
+         when 'b' =>
+            Ptr := Ptr + 1;
+            Brief_Output := True;
+
+         --  Processing for c switch
+
+         when 'c' =>
+            Ptr := Ptr + 1;
+
+            Check_Only := True;
+
+         --  Processing for C switch
+
+         when 'C' =>
+            Ptr := Ptr + 1;
+
+            Ada_Bind_File := False;
+
+         --  Processing for d switch
+
+         when 'd' =>
+
+            --  Note: for the debug switch, the remaining characters in this
+            --  switch field must all be debug flags, since all valid switch
+            --  characters are also valid debug characters.
+
+            --  Loop to scan out debug flags
+
+            while Ptr < Max loop
+               Ptr := Ptr + 1;
+               C := Switch_Chars (Ptr);
+               exit when C = ASCII.NUL or else C = '/' or else C = '-';
+
+               if C in '1' .. '9' or else
+                  C in 'a' .. 'z' or else
+                  C in 'A' .. 'Z'
+               then
+                  Set_Debug_Flag (C);
+               else
+                  raise Bad_Switch;
+               end if;
+            end loop;
+
+            --  Make sure Zero_Cost_Exceptions is set if gnatdX set. This
+            --  is for backwards compatibility with old versions and usage.
+
+            if Debug_Flag_XX then
+               Zero_Cost_Exceptions_Set := True;
+               Zero_Cost_Exceptions_Val := True;
+            end if;
+
+            return;
+
+         --  Processing for e switch
+
+         when 'e' =>
+            Ptr := Ptr + 1;
+            Elab_Dependency_Output := True;
+
+         --  Processing for E switch
+
+         when 'E' =>
+            Ptr := Ptr + 1;
+            Exception_Tracebacks := True;
+
+         --  Processing for f switch
+
+         when 'f' =>
+            Ptr := Ptr + 1;
+            Force_RM_Elaboration_Order := True;
+
+         --  Processing for g switch
+
+         when 'g' =>
+            Ptr := Ptr + 1;
+            if Ptr <= Max then
+               C := Switch_Chars (Ptr);
+               if C in '0' .. '3' then
+                  Debugger_Level :=
+                    Character'Pos
+                      (Switch_Chars (Ptr)) - Character'Pos ('0');
+                  Ptr := Ptr + 1;
+               end if;
+            else
+               Debugger_Level := 2;
+            end if;
+
+         --  Processing for G switch
+
+         when 'G' =>
+            Ptr := Ptr + 1;
+            Print_Generated_Code := True;
+
+         --  Processing for h switch
+
+         when 'h' =>
+            Ptr := Ptr + 1;
+            Usage_Requested := True;
+
+         --  Processing for i switch
+
+         when 'i' =>
+            if Ptr = Max then
+               raise Bad_Switch;
+            end if;
+
+            Ptr := Ptr + 1;
+            C := Switch_Chars (Ptr);
+
+            if C = '1' or else
+               C = '2' or else
+               C = '3' or else
+               C = '4' or else
+               C = '8' or else
+               C = 'p' or else
+               C = 'f' or else
+               C = 'n' or else
+               C = 'w'
+            then
+               Identifier_Character_Set := C;
+               Ptr := Ptr + 1;
+            else
+               raise Bad_Switch;
+            end if;
+
+         --  Processing for K switch
+
+         when 'K' =>
+            Ptr := Ptr + 1;
+
+            if Program = Binder then
+               Output_Linker_Option_List := True;
+            else
+               raise Bad_Switch;
+            end if;
+
+         --  Processing for l switch
+
+         when 'l' =>
+            Ptr := Ptr + 1;
+            Elab_Order_Output := True;
+
+         --  Processing for m switch
+
+         when 'm' =>
+            Ptr := Ptr + 1;
+            Scan_Pos (Switch_Chars, Max, Ptr, Maximum_Errors);
+
+         --  Processing for n switch
+
+         when 'n' =>
+            Ptr := Ptr + 1;
+            Bind_Main_Program := False;
+
+            --  Note: The -L option of the binder also implies -n, so
+            --  any change here must also be reflected in the processing
+            --  for -L that is found in Gnatbind.Scan_Bind_Arg.
+
+         --  Processing for o switch
+
+         when 'o' =>
+            Ptr := Ptr + 1;
+
+            if Output_File_Name_Present then
+               raise Too_Many_Output_Files;
+
+            else
+               Output_File_Name_Present := True;
+            end if;
+
+         --  Processing for O switch
+
+         when 'O' =>
+            Ptr := Ptr + 1;
+            Output_Object_List := True;
+
+         --  Processing for p switch
+
+         when 'p' =>
+            Ptr := Ptr + 1;
+            Pessimistic_Elab_Order := True;
+
+         --  Processing for q switch
+
+         when 'q' =>
+            Ptr := Ptr + 1;
+            Quiet_Output := True;
+
+         --  Processing for s switch
+
+         when 's' =>
+            Ptr := Ptr + 1;
+            All_Sources := True;
+            Check_Source_Files := True;
+
+         --  Processing for t switch
+
+         when 't' =>
+            Ptr := Ptr + 1;
+            Tolerate_Consistency_Errors := True;
+
+         --  Processing for T switch
+
+         when 'T' =>
+            Ptr := Ptr + 1;
+            Time_Slice_Set := True;
+            Scan_Nat (Switch_Chars, Max, Ptr, Time_Slice_Value);
+
+         --  Processing for v switch
+
+         when 'v' =>
+            Ptr := Ptr + 1;
+            Verbose_Mode := True;
+
+         --  Processing for w switch
+
+         when 'w' =>
+
+            --  For the binder we only allow suppress/error cases
+
+            Ptr := Ptr + 1;
+
+            case Switch_Chars (Ptr) is
+
+               when 'e' =>
+                  Warning_Mode  := Treat_As_Error;
+
+               when 's' =>
+                  Warning_Mode  := Suppress;
+
+               when others =>
+                  raise Bad_Switch;
+            end case;
+
+            Ptr := Ptr + 1;
+
+         --  Processing for W switch
+
+         when 'W' =>
+            Ptr := Ptr + 1;
+
+            for J in WC_Encoding_Method loop
+               if Switch_Chars (Ptr) = WC_Encoding_Letters (J) then
+                  Wide_Character_Encoding_Method := J;
+                  exit;
+
+               elsif J = WC_Encoding_Method'Last then
+                  raise Bad_Switch;
+               end if;
+            end loop;
+
+            Upper_Half_Encoding :=
+              Wide_Character_Encoding_Method in
+                WC_Upper_Half_Encoding_Method;
+
+            Ptr := Ptr + 1;
+
+         --  Processing for x switch
+
+         when 'x' =>
+            Ptr := Ptr + 1;
+            All_Sources := False;
+            Check_Source_Files := False;
+
+         --  Processing for z switch
+
+         when 'z' =>
+            Ptr := Ptr + 1;
+            No_Main_Subprogram := True;
+
+         --  Ignore extra switch character
+
+         when '/' | '-' =>
+            Ptr := Ptr + 1;
+
+         --  Anything else is an error (illegal switch character)
+
+         when others =>
+            raise Bad_Switch;
+         end case;
+      end loop;
+
+   exception
+      when Bad_Switch =>
+         Osint.Fail ("invalid switch: ", (1 => C));
+
+      when Bad_Switch_Value =>
+         Osint.Fail ("numeric value too big for switch: ", (1 => C));
+
+      when Missing_Switch_Value =>
+         Osint.Fail ("missing numeric value for switch: ", (1 => C));
+
+      when Too_Many_Output_Files =>
+         Osint.Fail ("duplicate -o switch");
+   end Scan_Binder_Switches;
+
+   -----------------------------
+   -- Scan_Front_End_Switches --
+   -----------------------------
+
+   procedure Scan_Front_End_Switches (Switch_Chars : String) is
+      Switch_Starts_With_Gnat : Boolean;
+      Ptr : Integer := Switch_Chars'First;
+      Max : constant Integer := Switch_Chars'Last;
+      C   : Character := ' ';
+
+   begin
+      --  Skip past the initial character (must be the switch character)
+
+      if Ptr = Max then
+         raise Bad_Switch;
+
+      else
+         Ptr := Ptr + 1;
+      end if;
+
+      --  A little check, "gnat" at the start of a switch is not allowed
+      --  except for the compiler (where it was already removed)
+
+      Switch_Starts_With_Gnat :=
+         Ptr + 3 <= Max and then Switch_Chars (Ptr .. Ptr + 3) = "gnat";
+
+      if Switch_Starts_With_Gnat then
+         Ptr := Ptr + 4;
+      end if;
+
+      --  Loop to scan through switches given in switch string
+
+      while Ptr <= Max loop
+         C := Switch_Chars (Ptr);
+
+         --  Processing for a switch
+
+         case Switch_Starts_With_Gnat is
+
+         when False =>
+            --  There is only one front-end switch that
+            --  does not start with -gnat, namely -I
+
+            case C is
+
+            when 'I' =>
+               Ptr := Ptr + 1;
+
+               if Ptr > Max then
+                  raise Bad_Switch;
+               end if;
+
+               --  Find out whether this is a -I- or regular -Ixxx switch
+
+               if Ptr = Max and then Switch_Chars (Ptr) = '-' then
+                  Look_In_Primary_Dir := False;
+
+               else
+                  Add_Src_Search_Dir (Switch_Chars (Ptr .. Max));
+               end if;
+
+               Ptr := Max + 1;
+
+            when others =>
+               --  Should not happen, as Scan_Switches is supposed
+               --  to be called for front-end switches only.
+               --  Still, it is safest to raise Bad_Switch error.
+
+               raise Bad_Switch;
+            end case;
+
+         when True =>
+            --  Process -gnat* options
+
+            case C is
+
+            when 'a' =>
+               Ptr := Ptr + 1;
+               Assertions_Enabled := True;
+
+            --  Processing for A switch
+
+            when 'A' =>
+               Ptr := Ptr + 1;
+               Config_File := False;
+
+            --  Processing for b switch
+
+            when 'b' =>
+               Ptr := Ptr + 1;
+               Brief_Output := True;
+
+            --  Processing for c switch
+
+            when 'c' =>
+               Ptr := Ptr + 1;
+               Operating_Mode := Check_Semantics;
+
+            --  Processing for C switch
+
+            when 'C' =>
+               Ptr := Ptr + 1;
+               Compress_Debug_Names := True;
+
+            --  Processing for d switch
+
+            when 'd' =>
+
+               --  Note: for the debug switch, the remaining characters in this
+               --  switch field must all be debug flags, since all valid switch
+               --  characters are also valid debug characters.
+
+               --  Loop to scan out debug flags
+
+               while Ptr < Max loop
+                  Ptr := Ptr + 1;
+                  C := Switch_Chars (Ptr);
+                  exit when C = ASCII.NUL or else C = '/' or else C = '-';
+
+                  if C in '1' .. '9' or else
+                     C in 'a' .. 'z' or else
+                     C in 'A' .. 'Z'
+                  then
+                     Set_Debug_Flag (C);
+
+                  else
+                     raise Bad_Switch;
+                  end if;
+               end loop;
+
+               --  Make sure Zero_Cost_Exceptions is set if gnatdX set. This
+               --  is for backwards compatibility with old versions and usage.
+
+               if Debug_Flag_XX then
+                  Zero_Cost_Exceptions_Set := True;
+                  Zero_Cost_Exceptions_Val := True;
+               end if;
+
+               return;
+
+            --  Processing for D switch
+
+            when 'D' =>
+               Ptr := Ptr + 1;
+
+               --  Note: -gnatD also sets -gnatx (to turn off cross-reference
+               --  generation in the ali file) since otherwise this generation
+               --  gets confused by the "wrong" Sloc values put in the tree.
+
+               Debug_Generated_Code := True;
+               Xref_Active := False;
+               Set_Debug_Flag ('g');
+
+            --  Processing for e switch
+
+            when 'e' =>
+               Ptr := Ptr + 1;
+
+               if Ptr > Max then
+                  raise Bad_Switch;
+               end if;
+
+               case Switch_Chars (Ptr) is
+
+                  when 'c' =>
+                     Ptr := Ptr + 1;
+                     if Ptr > Max then
+                        Osint.Fail ("Invalid switch: ", "ec");
+                     end if;
+
+                     Config_File_Name :=
+                        new String'(Switch_Chars (Ptr .. Max));
+
+                     return;
+
+                  when others =>
+                     Osint.Fail ("Invalid switch: ",
+                                   (1 => 'e', 2 => Switch_Chars (Ptr)));
+               end case;
+
+            --  Processing for E switch
+
+            when 'E' =>
+               Ptr := Ptr + 1;
+               Dynamic_Elaboration_Checks := True;
+
+            --  Processing for f switch
+
+            when 'f' =>
+               Ptr := Ptr + 1;
+               All_Errors_Mode := True;
+
+            --  Processing for F switch
+
+            when 'F' =>
+               Ptr := Ptr + 1;
+               External_Name_Exp_Casing := Uppercase;
+               External_Name_Imp_Casing := Uppercase;
+
+            --  Processing for g switch
+
+            when 'g' =>
+               Ptr := Ptr + 1;
+               GNAT_Mode                := True;
+               Identifier_Character_Set := 'n';
+               Warning_Mode             := Treat_As_Error;
+               Check_Unreferenced       := True;
+               Check_Withs              := True;
+
+               Set_Default_Style_Check_Options;
+
+            --  Processing for G switch
+
+            when 'G' =>
+               Ptr := Ptr + 1;
+               Print_Generated_Code := True;
+
+            --  Processing for h switch
+
+            when 'h' =>
+               Ptr := Ptr + 1;
+               Usage_Requested := True;
+
+            --  Processing for H switch
+
+            when 'H' =>
+               Ptr := Ptr + 1;
+               HLO_Active := True;
+
+            --  Processing for i switch
+
+            when 'i' =>
+               if Ptr = Max then
+                  raise Bad_Switch;
+               end if;
+
+               Ptr := Ptr + 1;
+               C := Switch_Chars (Ptr);
+
+               if C = '1' or else
+                  C = '2' or else
+                  C = '3' or else
+                  C = '4' or else
+                  C = '8' or else
+                  C = 'p' or else
+                  C = 'f' or else
+                  C = 'n' or else
+                  C = 'w'
+               then
+                  Identifier_Character_Set := C;
+                  Ptr := Ptr + 1;
+
+               else
+                  raise Bad_Switch;
+               end if;
+
+            --  Processing for k switch
+
+            when 'k' =>
+               Ptr := Ptr + 1;
+               Scan_Pos (Switch_Chars, Max, Ptr, Maximum_File_Name_Length);
+
+            --  Processing for l switch
+
+            when 'l' =>
+               Ptr := Ptr + 1;
+               Full_List := True;
+
+            --  Processing for L switch
+
+            when 'L' =>
+               Ptr := Ptr + 1;
+               Zero_Cost_Exceptions_Set := True;
+               Zero_Cost_Exceptions_Val := False;
+
+            --  Processing for m switch
+
+            when 'm' =>
+               Ptr := Ptr + 1;
+               Scan_Pos (Switch_Chars, Max, Ptr, Maximum_Errors);
+
+            --  Processing for n switch
+
+            when 'n' =>
+               Ptr := Ptr + 1;
+               Inline_Active := True;
+
+            --  Processing for N switch
+
+            when 'N' =>
+               Ptr := Ptr + 1;
+               Inline_Active := True;
+               Front_End_Inlining := True;
+
+            --  Processing for o switch
+
+            when 'o' =>
+               Ptr := Ptr + 1;
+               Suppress_Options.Overflow_Checks := False;
+
+            --  Processing for O switch
+
+            when 'O' =>
+               Ptr := Ptr + 1;
+               Output_File_Name_Present := True;
+
+            --  Processing for p switch
+
+            when 'p' =>
+               Ptr := Ptr + 1;
+               Suppress_Options.Access_Checks        := True;
+               Suppress_Options.Accessibility_Checks := True;
+               Suppress_Options.Discriminant_Checks  := True;
+               Suppress_Options.Division_Checks      := True;
+               Suppress_Options.Elaboration_Checks   := True;
+               Suppress_Options.Index_Checks         := True;
+               Suppress_Options.Length_Checks        := True;
+               Suppress_Options.Overflow_Checks      := True;
+               Suppress_Options.Range_Checks         := True;
+               Suppress_Options.Division_Checks      := True;
+               Suppress_Options.Length_Checks        := True;
+               Suppress_Options.Range_Checks         := True;
+               Suppress_Options.Storage_Checks       := True;
+               Suppress_Options.Tag_Checks           := True;
+
+               Validity_Checks_On := False;
+
+            --  Processing for P switch
+
+            when 'P' =>
+               Ptr := Ptr + 1;
+               Polling_Required := True;
+
+            --  Processing for q switch
+
+            when 'q' =>
+               Ptr := Ptr + 1;
+               Try_Semantics := True;
+
+            --  Processing for q switch
+
+            when 'Q' =>
+               Ptr := Ptr + 1;
+               Force_ALI_Tree_File := True;
+               Try_Semantics := True;
+
+            --  Processing for r switch
+
+            when 'r' =>
+               Ptr := Ptr + 1;
+
+               --  Temporarily allow -gnatr to mean -gnatyl (use RM layout)
+               --  for compatibility with pre 3.12 versions of GNAT,
+               --  to be removed for 3.13 ???
+
+               Set_Style_Check_Options ("l");
+
+            --  Processing for R switch
+
+            when 'R' =>
+               Ptr := Ptr + 1;
+               Back_Annotate_Rep_Info := True;
+
+               if Ptr <= Max
+                 and then Switch_Chars (Ptr) in '0' .. '9'
+               then
+                  C := Switch_Chars (Ptr);
+
+                  if C in '4' .. '9' then
+                     raise Bad_Switch;
+                  else
+                     List_Representation_Info :=
+                       Character'Pos (C) - Character'Pos ('0');
+                     Ptr := Ptr + 1;
+                  end if;
+
+               else
+                  List_Representation_Info := 1;
+               end if;
+
+            --  Processing for s switch
+
+            when 's' =>
+               Ptr := Ptr + 1;
+               Operating_Mode := Check_Syntax;
+
+            --  Processing for t switch
+
+            when 't' =>
+               Ptr := Ptr + 1;
+               Tree_Output := True;
+               Back_Annotate_Rep_Info := True;
+
+            --  Processing for T switch
+
+            when 'T' =>
+               Ptr := Ptr + 1;
+               Time_Slice_Set := True;
+               Scan_Nat (Switch_Chars, Max, Ptr, Time_Slice_Value);
+
+            --  Processing for u switch
+
+            when 'u' =>
+               Ptr := Ptr + 1;
+               List_Units := True;
+
+            --  Processing for U switch
+
+            when 'U' =>
+               Ptr := Ptr + 1;
+               Unique_Error_Tag := True;
+
+            --  Processing for v switch
+
+            when 'v' =>
+               Ptr := Ptr + 1;
+               Verbose_Mode := True;
+
+            --  Processing for V switch
+
+            when 'V' =>
+               Ptr := Ptr + 1;
+
+               if Ptr > Max then
+                  raise Bad_Switch;
+
+               else
+                  declare
+                     OK  : Boolean;
+
+                  begin
+                     Set_Validity_Check_Options
+                       (Switch_Chars (Ptr .. Max), OK, Ptr);
+
+                     if not OK then
+                        raise Bad_Switch;
+                     end if;
+                  end;
+               end if;
+
+            --  Processing for w switch
+
+            when 'w' =>
+               Ptr := Ptr + 1;
+
+               if Ptr > Max then
+                  raise Bad_Switch;
+               end if;
+
+               while Ptr <= Max loop
+                  C := Switch_Chars (Ptr);
+
+                  case C is
+
+                     when 'a' =>
+                        Constant_Condition_Warnings  := True;
+                        Elab_Warnings                := True;
+                        Check_Unreferenced           := True;
+                        Check_Withs                  := True;
+                        Implementation_Unit_Warnings := True;
+                        Ineffective_Inline_Warnings  := True;
+                        Warn_On_Redundant_Constructs := True;
+
+                     when 'A' =>
+                        Constant_Condition_Warnings  := False;
+                        Elab_Warnings                := False;
+                        Check_Unreferenced           := False;
+                        Check_Withs                  := False;
+                        Implementation_Unit_Warnings := False;
+                        Warn_On_Biased_Rounding      := False;
+                        Warn_On_Hiding               := False;
+                        Warn_On_Redundant_Constructs := False;
+                        Ineffective_Inline_Warnings  := False;
+
+                     when 'c' =>
+                        Constant_Condition_Warnings := True;
+
+                     when 'C' =>
+                        Constant_Condition_Warnings := False;
+
+                     when 'b' =>
+                        Warn_On_Biased_Rounding := True;
+
+                     when 'B' =>
+                        Warn_On_Biased_Rounding := False;
+
+                     when 'e' =>
+                        Warning_Mode := Treat_As_Error;
+
+                     when 'h' =>
+                        Warn_On_Hiding := True;
+
+                     when 'H' =>
+                        Warn_On_Hiding := False;
+
+                     when 'i' =>
+                        Implementation_Unit_Warnings := True;
+
+                     when 'I' =>
+                        Implementation_Unit_Warnings := False;
+
+                     when 'l' =>
+                        Elab_Warnings := True;
+
+                     when 'L' =>
+                        Elab_Warnings := False;
+
+                     when 'o' =>
+                        Address_Clause_Overlay_Warnings := True;
+
+                     when 'O' =>
+                        Address_Clause_Overlay_Warnings := False;
+
+                     when 'p' =>
+                        Ineffective_Inline_Warnings := True;
+
+                     when 'P' =>
+                        Ineffective_Inline_Warnings := False;
+
+                     when 'r' =>
+                        Warn_On_Redundant_Constructs := True;
+
+                     when 'R' =>
+                        Warn_On_Redundant_Constructs := False;
+
+                     when 's' =>
+                        Warning_Mode  := Suppress;
+
+                     when 'u' =>
+                        Check_Unreferenced := True;
+                        Check_Withs        := True;
+
+                     when 'U' =>
+                        Check_Unreferenced := False;
+                        Check_Withs        := False;
+
+                        --  Allow and ignore 'w' so that the old
+                        --  format (e.g. -gnatwuwl) will work.
+
+                     when 'w' =>
+                        null;
+
+                     when others =>
+                        raise Bad_Switch;
+                  end case;
+
+                  Ptr := Ptr + 1;
+               end loop;
+
+               return;
+
+            --  Processing for W switch
+
+            when 'W' =>
+               Ptr := Ptr + 1;
+
+               for J in WC_Encoding_Method loop
+                  if Switch_Chars (Ptr) = WC_Encoding_Letters (J) then
+                     Wide_Character_Encoding_Method := J;
+                     exit;
+
+                  elsif J = WC_Encoding_Method'Last then
+                     raise Bad_Switch;
+                  end if;
+               end loop;
+
+               Upper_Half_Encoding :=
+                 Wide_Character_Encoding_Method in
+                 WC_Upper_Half_Encoding_Method;
+
+               Ptr := Ptr + 1;
+
+            --  Processing for x switch
+
+            when 'x' =>
+               Ptr := Ptr + 1;
+               Xref_Active := False;
+
+            --  Processing for X switch
+
+            when 'X' =>
+               Ptr := Ptr + 1;
+               Extensions_Allowed := True;
+
+            --  Processing for y switch
+
+            when 'y' =>
+               Ptr := Ptr + 1;
+
+               if Ptr > Max then
+                  Set_Default_Style_Check_Options;
+
+               else
+                  declare
+                     OK  : Boolean;
+
+                  begin
+                     Set_Style_Check_Options
+                       (Switch_Chars (Ptr .. Max), OK, Ptr);
+
+                     if not OK then
+                        raise Bad_Switch;
+                     end if;
+                  end;
+               end if;
+
+            --  Processing for z switch
+
+            when 'z' =>
+               Ptr := Ptr + 1;
+
+               --  Allowed for compiler, only if this is the only
+               --  -z switch, we do not allow multiple occurrences
+
+               if Distribution_Stub_Mode = No_Stubs then
+                  case Switch_Chars (Ptr) is
+                     when 'r' =>
+                        Distribution_Stub_Mode := Generate_Receiver_Stub_Body;
+
+                     when 'c' =>
+                        Distribution_Stub_Mode := Generate_Caller_Stub_Body;
+
+                     when others =>
+                        raise Bad_Switch;
+                  end case;
+
+                  Ptr := Ptr + 1;
+
+               end if;
+
+            --  Processing for Z switch
+
+            when 'Z' =>
+               Ptr := Ptr + 1;
+               Zero_Cost_Exceptions_Set := True;
+               Zero_Cost_Exceptions_Val := True;
+
+            --  Processing for 83 switch
+
+            when '8' =>
+
+               if Ptr = Max then
+                  raise Bad_Switch;
+               end if;
+
+               Ptr := Ptr + 1;
+
+               if Switch_Chars (Ptr) /= '3' then
+                  raise Bad_Switch;
+               else
+                  Ptr := Ptr + 1;
+                  Ada_95 := False;
+                  Ada_83 := True;
+               end if;
+
+            --  Ignore extra switch character
+
+            when '/' | '-' =>
+               Ptr := Ptr + 1;
+
+            --  Anything else is an error (illegal switch character)
+
+            when others =>
+               raise Bad_Switch;
+            end case;
+         end case;
+      end loop;
+
+   exception
+      when Bad_Switch =>
+         Osint.Fail ("invalid switch: ", (1 => C));
+
+      when Bad_Switch_Value =>
+         Osint.Fail ("numeric value too big for switch: ", (1 => C));
+
+      when Missing_Switch_Value =>
+         Osint.Fail ("missing numeric value for switch: ", (1 => C));
+
+   end Scan_Front_End_Switches;
+
+   ------------------------
+   -- Scan_Make_Switches --
+   ------------------------
+
+   procedure Scan_Make_Switches (Switch_Chars : String) is
+      Ptr : Integer := Switch_Chars'First;
+      Max : Integer := Switch_Chars'Last;
+      C   : Character := ' ';
+
+   begin
+      --  Skip past the initial character (must be the switch character)
+
+      if Ptr = Max then
+         raise Bad_Switch;
+
+      else
+         Ptr := Ptr + 1;
+      end if;
+
+      --  A little check, "gnat" at the start of a switch is not allowed
+      --  except for the compiler (where it was already removed)
+
+      if Switch_Chars'Length >= Ptr + 3
+        and then Switch_Chars (Ptr .. Ptr + 3) = "gnat"
+      then
+         Osint.Fail
+           ("invalid switch: """, Switch_Chars, """ (gnat not needed here)");
+      end if;
+
+      --  Loop to scan through switches given in switch string
+
+      while Ptr <= Max loop
+         C := Switch_Chars (Ptr);
+
+         --  Processing for a switch
+
+         case C is
+
+         when 'a' =>
+            Ptr := Ptr + 1;
+            Check_Readonly_Files := True;
+
+         --  Processing for c switch
+
+         when 'c' =>
+            Ptr := Ptr + 1;
+            Compile_Only := True;
+
+         when 'd' =>
+
+            --  Note: for the debug switch, the remaining characters in this
+            --  switch field must all be debug flags, since all valid switch
+            --  characters are also valid debug characters.
+
+            --  Loop to scan out debug flags
+
+            while Ptr < Max loop
+               Ptr := Ptr + 1;
+               C := Switch_Chars (Ptr);
+               exit when C = ASCII.NUL or else C = '/' or else C = '-';
+
+               if C in '1' .. '9' or else
+                  C in 'a' .. 'z' or else
+                  C in 'A' .. 'Z'
+               then
+                  Set_Debug_Flag (C);
+               else
+                  raise Bad_Switch;
+               end if;
+            end loop;
+
+            --  Make sure Zero_Cost_Exceptions is set if gnatdX set. This
+            --  is for backwards compatibility with old versions and usage.
+
+            if Debug_Flag_XX then
+               Zero_Cost_Exceptions_Set := True;
+               Zero_Cost_Exceptions_Val := True;
+            end if;
+
+            return;
+
+         --  Processing for f switch
+
+         when 'f' =>
+            Ptr := Ptr + 1;
+            Force_Compilations := True;
+
+         --  Processing for G switch
+
+         when 'G' =>
+            Ptr := Ptr + 1;
+            Print_Generated_Code := True;
+
+         --  Processing for h switch
+
+         when 'h' =>
+            Ptr := Ptr + 1;
+            Usage_Requested := True;
+
+         --  Processing for i switch
+
+         when 'i' =>
+            Ptr := Ptr + 1;
+            In_Place_Mode := True;
+
+         --  Processing for j switch
+
+         when 'j' =>
+            Ptr := Ptr + 1;
+
+            declare
+               Max_Proc : Pos;
+            begin
+               Scan_Pos (Switch_Chars, Max, Ptr, Max_Proc);
+               Maximum_Processes := Positive (Max_Proc);
+            end;
+
+         --  Processing for k switch
+
+         when 'k' =>
+            Ptr := Ptr + 1;
+            Keep_Going := True;
+
+         when 'M' =>
+            Ptr := Ptr + 1;
+            List_Dependencies := True;
+
+         --  Processing for n switch
+
+         when 'n' =>
+            Ptr := Ptr + 1;
+            Do_Not_Execute := True;
+
+         --  Processing for o switch
+
+         when 'o' =>
+            Ptr := Ptr + 1;
+
+            if Output_File_Name_Present then
+               raise Too_Many_Output_Files;
+            else
+               Output_File_Name_Present := True;
+            end if;
+
+         --  Processing for q switch
+
+         when 'q' =>
+            Ptr := Ptr + 1;
+            Quiet_Output := True;
+
+         --  Processing for s switch
+
+         when 's' =>
+            Ptr := Ptr + 1;
+            Check_Switches := True;
+
+         --  Processing for v switch
+
+         when 'v' =>
+            Ptr := Ptr + 1;
+            Verbose_Mode := True;
+
+         --  Processing for z switch
+
+         when 'z' =>
+            Ptr := Ptr + 1;
+            No_Main_Subprogram := True;
+
+         --  Ignore extra switch character
+
+         when '/' | '-' =>
+            Ptr := Ptr + 1;
+
+         --  Anything else is an error (illegal switch character)
+
+         when others =>
+            raise Bad_Switch;
+
+         end case;
+      end loop;
+
+   exception
+      when Bad_Switch =>
+         Osint.Fail ("invalid switch: ", (1 => C));
+
+      when Bad_Switch_Value =>
+         Osint.Fail ("numeric value too big for switch: ", (1 => C));
+
+      when Missing_Switch_Value =>
+         Osint.Fail ("missing numeric value for switch: ", (1 => C));
+
+      when Too_Many_Output_Files =>
+         Osint.Fail ("duplicate -o switch");
+
+   end Scan_Make_Switches;
+
+   --------------
+   -- Scan_Nat --
+   --------------
+
+   procedure Scan_Nat
+     (Switch_Chars : String;
+      Max          : Integer;
+      Ptr          : in out Integer;
+      Result       : out Nat) is
+   begin
+      Result := 0;
+      if Ptr > Max or else Switch_Chars (Ptr) not in '0' .. '9' then
+         raise Missing_Switch_Value;
+      end if;
+
+      while Ptr <= Max and then Switch_Chars (Ptr) in '0' .. '9' loop
+         Result := Result * 10 +
+           Character'Pos (Switch_Chars (Ptr)) - Character'Pos ('0');
+         Ptr := Ptr + 1;
+
+         if Result > Switch_Max_Value then
+            raise Bad_Switch_Value;
+         end if;
+      end loop;
+   end Scan_Nat;
+
+   --------------
+   -- Scan_Pos --
+   --------------
+
+   procedure Scan_Pos
+     (Switch_Chars : String;
+      Max          : Integer;
+      Ptr          : in out Integer;
+      Result       : out Pos) is
+
+   begin
+      Scan_Nat (Switch_Chars, Max, Ptr, Result);
+      if Result = 0 then
+         raise Bad_Switch_Value;
+      end if;
+   end Scan_Pos;
+
+end Switch;
diff --git a/gcc/ada/switch.ads b/gcc/ada/switch.ads
new file mode 100644
index 00000000000..7153cdaa765
--- /dev/null
+++ b/gcc/ada/switch.ads
@@ -0,0 +1,69 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                               S W I T C H                                --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.17 $                             --
+--                                                                          --
+--          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 scans switches. Note that the body of Usage must be
+--  coordinated with the switches that are recognized by this package.
+--  The Usage package also acts as the official documentation for the
+--  switches that are recognized. In addition, package Debug documents
+--  the otherwise undocumented debug switches that are also recognized.
+
+package Switch is
+
+   --  Note: The default switch character is indicated by Switch_Character,
+   --  but regardless of what it is, a hyphen is always allowed as an
+   --  (alternative) switch character.
+
+   --  Note: In GNAT, the case of switches is not significant if
+   --  Switches_Case_Sensitive is False. If this is the case, switch
+   --  characters, or letters appearing in the parameter to a switch, may be
+   --  either upper case or lower case.
+
+   -----------------
+   -- Subprograms --
+   -----------------
+
+   function Is_Switch (Switch_Chars : String) return Boolean;
+   --  Returns True iff Switch_Chars is at least two characters long,
+   --  and the first character indicates it is a switch.
+
+   function Is_Front_End_Switch (Switch_Chars : String) return Boolean;
+   --  Returns True iff Switch_Chars represents a front-end switch,
+   --  ie. it starts with -I or -gnat.
+
+   procedure Scan_Front_End_Switches (Switch_Chars : String);
+   procedure Scan_Binder_Switches (Switch_Chars : String);
+   procedure Scan_Make_Switches (Switch_Chars : String);
+   --  Procedures to scan out switches stored in the given string. The first
+   --  character is known to be a valid switch character, and there are no
+   --  blanks or other switch terminator characters in the string, so the
+   --  entire string should consist of valid switch characters, except that
+   --  an optional terminating NUL character is allowed. A bad switch causes
+   --  a fatal error exit and control does not return. The call also sets
+   --  Usage_Requested to True if a ? switch is encountered.
+
+end Switch;
diff --git a/gcc/ada/sysdep.c b/gcc/ada/sysdep.c
new file mode 100644
index 00000000000..5473ebee42e
--- /dev/null
+++ b/gcc/ada/sysdep.c
@@ -0,0 +1,605 @@
+/****************************************************************************
+ *                                                                          *
+ *                         GNAT COMPILER COMPONENTS                         *
+ *                                                                          *
+ *                                S Y S D E P                               *
+ *                                                                          *
+ *                          C Implementation File                           *
+ *                                                                          *
+ *                            $Revision: 1.2 $
+ *                                                                          *
+ *          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). *
+ *                                                                          *
+ ****************************************************************************/
+
+/* This file contains system dependent symbols that are referenced in the
+   GNAT Run Time Library */
+
+#ifdef __vxworks
+#include "vxWorks.h"
+#endif
+#ifdef IN_RTS
+#define POSIX
+#include "tconfig.h"
+#include "tsystem.h"
+#include <fcntl.h>
+#include <sys/stat.h>
+#include "time.h"
+#else
+#include "config.h"
+#include "system.h"
+#endif
+
+#include "adaint.h"
+
+/*
+   mode_read_text
+   open text file for reading
+   rt for DOS and Windows NT, r for Unix
+
+   mode_write_text
+   truncate to zero length or create text file for writing
+   wt for DOS and Windows NT, w for Unix
+
+   mode_append_text
+   append; open or create text file for writing at end-of-file
+   at for DOS and Windows NT, a for Unix
+
+   mode_read_binary
+   open binary file for reading
+   rb for DOS and Windows NT, r for Unix
+
+   mode_write_binary
+   truncate to zero length or create binary file for writing
+   wb for DOS and Windows NT, w for Unix
+
+   mode_append_binary
+   append; open or create binary file for writing at end-of-file
+   ab for DOS and Windows NT, a for Unix
+
+   mode_read_text_plus
+   open text file for update (reading and writing)
+   r+t for DOS and Windows NT, r+ for Unix
+
+   mode_write_text_plus
+   truncate to zero length or create text file for update
+   w+t for DOS and Windows NT, w+ for Unix
+
+   mode_append_text_plus
+   append; open or create text file for update, writing at end-of-file
+   a+t for DOS and Windows NT, a+ for Unix
+
+   mode_read_binary_plus
+   open binary file for update (reading and writing)
+   r+b for DOS and Windows NT, r+ for Unix
+
+   mode_write_binary_plus
+   truncate to zero length or create binary file for update
+   w+b for DOS and Windows NT, w+ for Unix
+
+   mode_append_binary_plus
+   append; open or create binary file for update, writing at end-of-file
+   a+b for DOS and Windows NT, a+ for Unix
+
+   Notes:
+
+   (1) Opening a file with read mode fails if the file does not exist or
+   cannot be read.
+
+   (2) Opening a file with append mode causes all subsequent writes to the
+   file to be forced to the then current end-of-file, regardless of
+   intervening calls to the fseek function.
+
+   (3) When a file is opened with update mode, both input and output may be
+   performed on the associated stream.  However, output may not be directly
+   followed by input without an intervening call to the fflush function or
+   to a file positioning function (fseek, fsetpos, or rewind), and input
+   may not be directly followed by output without an intervening call to a
+   file positioning function, unless the input operation encounters
+   end-of-file.
+
+   The other target dependent declarations here are for the two functions
+   __gnat_set_binary_mode and __gnat_set_text_mode:
+
+      void __gnat_set_binary_mode (int handle);
+      void __gnat_set_text_mode   (int handle);
+
+   These functions have no effect in Unix (or similar systems where there is
+   no distinction between binary and text files), but in DOS (and similar
+   systems where text mode does CR/LF translation), these functions allow
+   the mode of the stream with the given handle (fileno can be used to get
+   the handle of a stream) to be changed dynamically. The returned result
+   is 0 if no error occurs and -1 if an error occurs.
+
+   Finally there is a boolean (character) variable
+
+      char __gnat_text_translation_required;
+
+   which is zero (false) in Unix mode, and one (true) in DOS mode, with a
+   true value indicating that text translation is required on text files
+   and that fopen supports the trailing t and b modifiers.
+
+*/
+
+#if defined(WINNT) || defined (MSDOS) || defined (__EMX__)
+const char *mode_read_text = "rt";
+const char *mode_write_text = "wt";
+const char *mode_append_text = "at";
+const char *mode_read_binary = "rb";
+const char *mode_write_binary = "wb";
+const char *mode_append_binary = "ab";
+const char *mode_read_text_plus = "r+t";
+const char *mode_write_text_plus = "w+t";
+const char *mode_append_text_plus = "a+t";
+const char *mode_read_binary_plus = "r+b";
+const char *mode_write_binary_plus = "w+b";
+const char *mode_append_binary_plus = "a+b";
+const char __gnat_text_translation_required = 1;
+
+void
+__gnat_set_binary_mode (handle)
+     int handle;
+{
+  _setmode (handle, O_BINARY);
+}
+
+void
+__gnat_set_text_mode (handle)
+     int handle;
+{
+  _setmode (handle, O_TEXT);
+}
+
+#ifdef __MINGW32__
+#include <windows.h>
+
+/* Return the name of the tty.   Under windows there is no name for
+   the tty, so this function, if connected to a tty, returns the generic name
+   "console".  */
+
+char *
+__gnat_ttyname (filedes)
+     int filedes;
+{
+  if (isatty (filedes))
+    return "console";
+  else
+    return NULL;
+}
+
+/* This function is needed to fix a bug under Win95/98. Under these plateforms
+   doing :
+                ch1 = getch();
+		ch2 = fgetc (stdin);
+
+   will put the same character into ch1 and ch2. It seem that the character
+   read by getch() is not correctly removed from the buffer. Even a
+   fflush(stdin) does not fix the bug. This bug does not appear under Window
+   NT. So we have two version of this routine below one for 95/98 and one for
+   NT/2000 version of Windows. There is also a special routine (winflushinit)
+   that will be called only the first time to check which version of Windows
+   we are running running on to set the right routine to use.
+
+   This problem occurs when using Text_IO.Get_Line after Text_IO.Get_Immediate
+   for example.
+
+   Calling FlushConsoleInputBuffer just after getch() fix the bug under 
+   95/98. */
+
+static void winflush_init PARAMS ((void));
+
+static void winflush_95 PARAMS ((void));
+
+static void winflush_nt PARAMS ((void));
+
+/* winflusfunction is set first to the winflushinit function which will check
+   the OS version 95/98 or NT/2000 */
+
+static void (*winflush_function) PARAMS ((void)) = winflush_init;
+
+/* This function does the runtime check of the OS version and then sets
+   winflush_function to the appropriate function and then call it. */ 
+
+static void
+winflush_init ()
+{ 
+  DWORD dwVersion = GetVersion();
+
+  if (dwVersion < 0x80000000)                /* Windows NT/2000 */
+    winflush_function = winflush_nt;
+  else                                       /* Windows 95/98   */
+    winflush_function = winflush_95;
+
+  (*winflush_function)();      /* Perform the 'flush' */
+
+}
+
+static void winflush_95 ()
+{ 
+  FlushConsoleInputBuffer (GetStdHandle (STD_INPUT_HANDLE));
+}
+
+static void winflush_nt ()
+{
+  /* Does nothing as there is no problem under NT.  */
+}
+#endif
+
+#else
+
+const char *mode_read_text = "r";
+const char *mode_write_text = "w";
+const char *mode_append_text = "a";
+const char *mode_read_binary = "r";
+const char *mode_write_binary = "w";
+const char *mode_append_binary = "a";
+const char *mode_read_text_plus = "r+";
+const char *mode_write_text_plus = "w+";
+const char *mode_append_text_plus = "a+";
+const char *mode_read_binary_plus = "r+";
+const char *mode_write_binary_plus = "w+";
+const char *mode_append_binary_plus = "a+";
+const char __gnat_text_translation_required = 0;
+
+/* These functions do nothing in non-DOS systems. */
+
+void
+__gnat_set_binary_mode (stream)
+     FILE *stream ATTRIBUTE_UNUSED;
+{
+}
+
+void
+__gnat_set_text_mode (stream)
+     FILE *stream ATTRIBUTE_UNUSED;
+{
+}
+char *
+__gnat_ttyname (filedes)
+     int filedes;
+{
+#ifndef __vxworks
+  extern char *ttyname PARAMS ((int));
+
+  return ttyname (filedes);
+
+#else
+  return "";
+
+#endif
+}
+#endif
+
+#if defined (linux) || defined (sun) || defined (sgi) || defined (__EMX__) \
+  || (defined (__osf__) && ! defined (__alpha_vxworks)) || defined (WINNT) \
+  || defined (__MACHTEN__)
+#include <termios.h>
+
+#elif defined (VMS)
+extern char *decc$ga_stdscr;
+static int initted = 0;
+#endif
+
+/* Implements the common processing for getc_immediate and
+   getc_immediate_nowait. */
+
+extern void getc_immediate		PARAMS ((FILE *, int *, int *));
+extern void getc_immediate_nowait	PARAMS ((FILE *, int *, int *, int *));
+extern void getc_immediate_common	PARAMS ((FILE *, int *, int *,
+						 int *, int));
+
+/* Called by Get_Immediate (Foo); */
+
+void
+getc_immediate (stream, ch, end_of_file)
+     FILE *stream;
+     int *ch;
+     int *end_of_file;
+{
+  int avail;
+
+  getc_immediate_common (stream, ch, end_of_file, &avail, 1);
+}
+
+/* Called by Get_Immediate (Foo, Available); */
+
+void
+getc_immediate_nowait (stream, ch, end_of_file, avail)
+     FILE *stream;
+     int *ch;
+     int *end_of_file;
+     int *avail;
+{
+  getc_immediate_common (stream, ch, end_of_file, avail, 0);
+}
+
+/* Called by getc_immediate () and getc_immediate_nowait () */
+
+void
+getc_immediate_common (stream, ch, end_of_file, avail, waiting)
+     FILE *stream;
+     int *ch;
+     int *end_of_file;
+     int *avail;
+     int waiting;
+{
+#if defined (linux) || defined (sun) || defined (sgi) || defined (__EMX__) \
+    || (defined (__osf__) && ! defined (__alpha_vxworks)) \
+    || defined (__CYGWIN32__) || defined (__MACHTEN__)
+  char c;
+  int nread;
+  int good_one = 0;
+  int eof_ch = 4; /* Ctrl-D */
+  int fd = fileno (stream);
+  struct termios otermios_rec, termios_rec;
+
+  if (isatty (fd))
+    {
+      tcgetattr (fd, &termios_rec);
+      memcpy (&otermios_rec, &termios_rec, sizeof (struct termios));
+      while (! good_one)
+        {
+          /* Set RAW mode */
+          termios_rec.c_lflag = termios_rec.c_lflag & ~ICANON;
+#if defined(sgi) || defined (sun) || defined (__EMX__) || defined (__osf__) \
+      || defined (linux) || defined (__MACHTEN__)
+          eof_ch = termios_rec.c_cc[VEOF];
+
+          /* If waiting (i.e. Get_Immediate (Char)), set MIN = 1 and wait for
+             a character forever. This doesn't seem to effect Ctrl-Z or
+             Ctrl-C processing except on OS/2 where Ctrl-C won't work right
+             unless we do a read loop. Luckily we can delay a bit between
+             iterations. If not waiting (i.e. Get_Immediate (Char, Available)),
+             don't wait for anything but timeout immediately. */
+#ifdef __EMX__
+          termios_rec.c_cc[VMIN] = 0;
+          termios_rec.c_cc[VTIME] = waiting;
+#else
+          termios_rec.c_cc[VMIN] = waiting;
+          termios_rec.c_cc[VTIME] = 0;
+#endif
+#endif
+          tcsetattr (fd, TCSANOW, &termios_rec);
+
+          /* Read() is used here instead of fread(), because fread() doesn't
+             work on Solaris5 and Sunos4 in this situation.  Maybe because we
+             are mixing calls that use file descriptors and streams. */
+
+          nread = read (fd, &c, 1);
+          if (nread > 0)
+            {
+              /* On Unix terminals, Ctrl-D (EOT) is an End of File. */
+              if (c == eof_ch)
+                {
+                  *avail = 0;
+                  *end_of_file = 1;
+                  good_one = 1;
+                }
+
+              /* Everything else is ok */
+              else if (c != eof_ch)
+                {
+                  *avail = 1;
+                  *end_of_file = 0;
+                  good_one = 1;
+                }
+            }
+
+          else if (! waiting)
+            {
+              *avail = 0;
+              *end_of_file = 0;
+              good_one = 1;
+            }
+          else
+            {
+              good_one = 0;
+            }
+        }
+
+      tcsetattr (fd, TCSANOW, &otermios_rec);
+      *ch = c;
+    }
+
+  else
+#elif defined (VMS)
+  int fd = fileno (stream);
+
+  if (isatty (fd))
+    {
+      if (initted == 0)
+	{
+	  decc$bsd_initscr ();
+	  initted = 1;
+	}
+      decc$bsd_cbreak ();
+      *ch = decc$bsd_wgetch (decc$ga_stdscr);
+
+      if (*ch == 4)
+	*end_of_file = 1;
+      else
+	*end_of_file = 0;
+
+      *avail = 1;
+      decc$bsd_nocbreak ();
+    }
+  else
+#elif defined (__MINGW32__)
+  int fd = fileno (stream);
+  int char_waiting;
+  int eot_ch = 4; /* Ctrl-D */
+
+  if (isatty (fd))
+    {
+      if (waiting)
+	{
+	  *ch = getch();
+	  (*winflush_function)();
+
+	  if (*ch == eot_ch)
+	    *end_of_file = 1;
+	  else
+	    *end_of_file = 0;
+
+	  *avail = 1;
+	}
+      else /* ! waiting */
+	{
+	  char_waiting = kbhit();
+
+	  if (char_waiting == 1)
+	    {
+	      *avail = 1;
+	      *ch = getch();
+	      (*winflush_function)();
+
+	      if (*ch == eot_ch)
+		*end_of_file = 1;
+	      else
+		*end_of_file = 0;
+	    }
+	  else
+	    {
+	      *avail = 0;
+	      *end_of_file = 0;
+	    }
+	}
+    }
+  else
+#endif
+    {
+      /* If we're not on a terminal, then we don't need any fancy processing.
+	 Also this is the only thing that's left if we're not on one of the
+	 supported systems. */
+      *ch = fgetc (stream);
+      if (feof (stream))
+        {
+          *end_of_file = 1;
+          *avail = 0;
+        }
+      else
+        {
+          *end_of_file = 0;
+          *avail = 1;
+        }
+    }
+}
+
+/* The following definitions are provided in NT to support Windows based
+   Ada programs.  */
+
+#ifdef WINNT
+#include <windows.h>
+
+/* Provide functions to echo the values passed to WinMain (windows bindings
+   will want to import these).  We use the same names as the routines used
+   by AdaMagic for compatibility.  */
+
+char *rts_get_hInstance     (void) { return (GetModuleHandleA (0)); }
+char *rts_get_hPrevInstance (void) { return (0); }
+char *rts_get_lpCommandLine (void) { return (GetCommandLineA ()); }
+int   rts_get_nShowCmd      (void) { return (1); }
+
+#endif /* WINNT */
+#ifdef VMS
+
+/* This gets around a problem with using the old threads library on VMS 7.0. */
+
+#include <time.h>
+
+extern long get_gmtoff PARAMS ((void));
+
+long
+get_gmtoff ()
+{
+  time_t t;
+  struct tm *ts;
+
+  t = time ((time_t) 0);
+  ts = localtime (&t);
+  return ts->tm_gmtoff;
+}
+#endif
+
+/* Definition of __gnat_locatime_r used by a-calend.adb */
+
+#if defined (_AIX) || defined (__EMX__)
+#define Lock_Task system__soft_links__lock_task
+extern void (*Lock_Task) (void);
+
+#define Unlock_Task system__soft_links__unlock_task
+extern void (*Unlock_Task) (void);
+
+/* Provide reentrant version of localtime on Aix and OS/2. Note that AiX does
+   provide localtime_r, but in the library libc_r which doesn't get included
+   systematically, so we can't use it. */
+
+exrern void struct tm *__gnat_localtime_r PARAMS ((const time_t *,
+						   struct tm *));
+
+struct tm *
+__gnat_localtime_r (timer, tp)
+     const time_t *timer;
+     struct tm *tp;
+{
+  struct tm *tmp;
+
+  (*Lock_Task) ();
+  tmp = localtime (timer);
+  memcpy (tp, tmp, sizeof (struct tm));
+  (*Unlock_Task) ();
+  return tp;
+}
+
+#elif defined (__Lynx__)
+
+/* LynxOS provides a non standard localtime_r */
+
+extern struct tm *__gnat_localtime_r PARAMS ((const time_t *, struct tm *));
+
+struct tm *
+__gnat_localtime_r (timer, tp)
+     const time_t *timer;
+     struct tm *tp;
+{
+  return localtime_r (tp, timer);
+}
+
+#elif defined (VMS) || defined (__MINGW32__)
+
+/* __gnat_localtime_r is not needed on NT and VMS */
+
+#else
+
+/* All other targets provide a standard localtime_r */
+
+extern struct tm *__gnat_localtime_r PARAMS ((const time_t *, struct tm *));
+
+struct tm *
+__gnat_localtime_r (timer, tp)
+     const time_t *timer;
+     struct tm *tp;
+{
+  return (struct tm *) localtime_r (timer, tp);
+}
+#endif