Patchwork [Ada] Next stage in implementation of Ada 2012 aspects

login
register
mail settings
Submitter Arnaud Charlet
Date Oct. 11, 2010, 10:35 a.m.
Message ID <20101011103505.GA12763@adacore.com>
Download mbox | patch
Permalink /patch/67408/
State New
Headers show

Comments

Arnaud Charlet - Oct. 11, 2010, 10:35 a.m.
This patch implements a major part of the syntax and semantics for
aspect specifications as described by AI05-0183-1/04. The things
still to do are:

a) Delay evaluation of aspects like size to freeze point
b) Complete parsing of aspect specifications for all cases
c) Make treepr list aspect specifications

The following are some test programs

This test is compiled with -gnat12 -gnata and it shows the use
of aspect specifications to set Sie, Address, Alignment:

     1. with Text_IO; use Text_IO;
     2. with System; use System;
     3. procedure AspectAttr is
     4.    type R is range 1 .. 10
     5.      with Size => 64;
     6.    X : Integer;
     7.    Y : Integer
     8.      with Address => X'Address;
     9.    pragma Assert (X'Address = Y'Address);
    10.    type Q is new Integer
    11.      with Alignment => 1;
    12. begin
    13.    Put_Line (R'Size'Img);
    14.    Put_Line (Q'Alignment'Img);
    15. end;

The output of this program is:

 64
 1

The following test shows how aspects can be cancelled for derived
types, using xxx => False, compiled with -gnata -gnat12

     1. with Text_IO; use Text_IO;
     2. procedure AspectCancel is
     3.    type R is array (0 .. 31) of Boolean;
     4.    pragma Assert (R'Size = 8 * 32);
     5.
     6.    type R1 is new R;
     7.    pragma Assert (R1'Size = 8 * 32);
     8.
     9.    type R2 is new R
    10.      with Pack => True;
    11.    pragma Assert (R2'Size = 32);
    12.
    13.    type R3 is new R2;
    14.    pragma Assert (R3'Size = 32);
    15.
    16.    type R4 is new R3
    17.      with Pack => False;
    18.    pragma Assert (R4'Size = 8 * 32);
    19. begin
    20.    Put_Line (R'Size'Img);
    21.    Put_Line (R1'Size'Img);
    22.    Put_Line (R2'Size'Img);
    23.    Put_Line (R3'Size'Img);
    24.    Put_Line (R4'Size'Img);
    25. end;

The output of this program is:

 256
 256
 32
 32
 256

and the last line shows the cancellation effect

The following test shows error messages for duplicate aspects
compile with -gnat12 -gnatj60:

     1. with System; use System;
     2. package DupAspect is
     3.    type R0 is array (0 .. 31) of Boolean;
     4.    pragma Pack (R0);
     5.    pragma Pack (R0);
           |
        >>> pragma "Pack" for "R0" duplicates pragma at
            line 4

     6.
     7.    type R1 is array (0 .. 31) of Boolean
     8.      with Pack => True;
     9.    pragma Pack (R1);
           |
        >>> aspect "Pack" for "R1" previously specified at
            line 8

    10.
    11.    type R2 is array (0 .. 31) of Boolean
    12.      with Pack => True,
    13.           Pack => True;
                  |
        >>> aspect "Pack" for "R2" ignored, already given
            at at line 12

    14.
    15.    type R3 is new Integer
    16.      with Size => 64;
    17.    for R3'Size use 128;
           |
        >>> aspect "Size" for "R3" previously specified at
            line 16

    18.
    19.    type R4 is new Integer
    20.      with Size => 64,
    21.           Size => 128;
                  |
        >>> aspect "Size" for "R4" ignored, already given
            at at line 20

    22.
    23.    type R5 is new Integer;
    24.    for R5'Size use 64;
    25.    for R5'Size use 128;
           |
        >>> aspect "Size" for "R5" previously specified at
            line 24

    26.
    27.    A, B, C : Integer;
    28.    for C'Address use A'Address;
    29.    for C'Address use B'Address;
           |
        >>> aspect "Address" for "C" previously specified
            at line 28

    30.
    31.    type Rec1 is record A : Integer; end record
    32.      with Bit_Order => High_Order_First;
    33.    for Rec1'Bit_Order use Low_Order_First;
           |
        >>> aspect "Bit_Order" for "Rec1" previously
            specified at line 32

    34.
    35. end;

Finally this test shows turning warnings on/off with aspects
to be compiled with -gnat12:

     1. procedure aspectwarn is
     2.    A : Integer with Warnings => Off;
     3.    B : Integer with Warnings => On;
           |
        >>> warning: variable "B" is never read and never assigned

     4. begin
     5.    null;
     6. end;

Tested on x86_64-pc-linux-gnu, committed on trunk

2010-10-11  Robert Dewar  <dewar@adacore.com>

	* aspects.ads, aspects.adb: Major revision of this package for 2nd
	stage of aspects implementation.
	* gcc-interface/Make-lang.in: Add entry for aspects.o
	* gcc-interface/Makefile.in: Add aspects.o to GNATMAKE_OBJS
	* par-ch13.adb (Aspect_Specifications_Present): New function
	(P_Aspect_Specifications): New procedure
	* par-ch3.adb (P_Type_Declaration): Handle aspect specifications
	(P_Derived_Type_Def_Or_Private_Ext_Decl): Handle aspect specifications
	(P_Identifier_Declarations): Handle aspect specifications
	(P_Component_Items): Handle aspect specifications
	(P_Subtype_Declaration): Handle aspect specifications
	* par-ch6.adb (P_Subprogram): Handle aspect specifications
	* par-ch9.adb (P_Entry_Declaration): Handle aspect specifications
	* par.adb (Aspect_Specifications_Present): New function
	(P_Aspect_Specifications): New procedure
	* sem.adb (Analyze_Full_Type_Declaration): New name for
	Analyze_Type_Declaration.
	(Analyze_Formal_Package_Declaration): New name (add _Declaration)
	(Analyze_Formal_Subprogram_Declaration): New name (add _Declaration)
	(Analyze_Protected_Type_Declaration): New name (add _Declaration)
	(Analyze_Single_Protected_Declaration): New name (add _Declaration)
	(Analyze_Single_Task_Declaration): New name (add _Declaration)
	(Analyze_Task_Type_Declaration): New name (add _Declaration)
	* sem_cat.adb (Analyze_Full_Type_Declaration): New name for
	Analyze_Type_Declaration.
	* sem_ch11.adb (Analyze_Exception_Declaration): Analyze aspect
	specifications.
	* sem_ch12.adb (Analyze_Formal_Object_Declaration): Handle aspect
	specifications.
	(Analyze_Formal_Package_Declaration): New name (add _Declaration)
	(Analyze_Formal_Package_Declaration): Handle aspect specifications
	(Analyze_Formal_Subprogram_Declaration): New name (add _Declaration)
	(Analyze_Formal_Subprogram_Declaration): Handle aspect specifications
	(Analyze_Formal_Type_Declaration): Handle aspect specifications
	(Analyze_Generic_Package_Declaration): Handle aspect specifications
	(Analyze_Generic_Subprogram_Declaration): Handle aspect specifications
	(Analyze_Package_Instantiation): Handle aspect specifications
	(Analyze_Subprogram_Instantiation): Handle aspect specifications
	* sem_ch12.ads (Analyze_Formal_Package_Declaration): New name (add
	_Declaration).
	(Analyze_Formal_Subprogram_Declaration): New name (add _Declaration)
	* sem_ch13.adb (Analyze_Aspect_Specifications): New procedure
	(Duplicate_Clause): New function, calls to this function are added to
	processing for all aspects.
	* sem_ch13.ads (Analyze_Aspect_Specifications): New procedure
	* sem_ch3.adb (Analyze_Full_Type_Declaration): New name for
	Analyze_Type_Declaration.
	* sem_ch3.ads (Analyze_Full_Type_Declaration): New name for
	Analyze_Type_Declaration.
	* sem_ch6.adb (Analyze_Abstract_Subprogram_Declaration): Analyze aspect
	specifications.
	(Analyze_Subprogram_Declaration): Analyze aspect specifications
	* sem_ch7.adb (Analyze_Package_Declaration): Analyze aspect
	specifications.
	(Analyze_Private_Type_Declaration): Analyze aspect specifications
	* sem_ch9.adb (Analyze_Protected_Type_Declaration): Analyze aspect
	specifications.
	(Analyze_Protected_Type_Declaration): New name (add _Declaration)
	(Analyze_Single_Protected_Declaration): Analyze aspect specifications
	(Analyze_Single_Protected_Declaration): New name (add _Declaration)
	(Analyze_Single_Task_Declaration): Analyze aspect specifications
	(Analyze_Single_Task_Declaration): New name (add _Declaration)
	(Analyze_Task_Type_Declaration): Analyze aspect specifications
	(Analyze_Task_Type_Declaration): New name (add _Declaration)
	* sem_ch9.ads (Analyze_Protected_Type_Declaration): New name (add
	_Declaration).
	(Analyze_Single_Protected_Declaration): New name (add _Declaration)
	(Analyze_Single_Task_Declaration): New name (add _Declaration)
	(Analyze_Task_Type_Declaration): New name (add _Declaration)
	* sem_prag.adb: Use Get_Pragma_Arg systematically so that we do not
	have to generate unnecessary pragma argument associations (this matches
	the doc).
	Throughout do changes to accomodate aspect specifications, including
	specializing messages, handling the case of not going through all
	homonyms, and allowing for cancellation.
	* sinfo.ads, sinfo.adb: Clean up obsolete documentation for Flag1,2,3
	(Aspect_Cancel): New flag
	(From_Aspect_Specification): New flag
	(First_Aspect): Removed flag
	(Last_Aspect): Removed flag
	* sprint.adb (Sprint_Aspect_Specifications): New procedure
	(Sprint_Node_Actual): Add calls to Sprint_Aspect_Specifications

Patch

Index: par-ch9.adb
===================================================================
--- par-ch9.adb	(revision 165283)
+++ par-ch9.adb	(working copy)
@@ -900,7 +900,7 @@  package body Ch9 is
          Discard_Junk_Node (P_Expression_No_Right_Paren);
       end if;
 
-      TF_Semicolon;
+      P_Aspect_Specifications (Decl_Node);
       return Decl_Node;
 
    exception
Index: sem_ch3.adb
===================================================================
--- sem_ch3.adb	(revision 165295)
+++ sem_ch3.adb	(working copy)
@@ -23,6 +23,7 @@ 
 --                                                                          --
 ------------------------------------------------------------------------------
 
+with Aspects;  use Aspects;
 with Atree;    use Atree;
 with Checks;   use Checks;
 with Debug;    use Debug;
@@ -1113,7 +1114,7 @@  package body Sem_Ch3 is
                else
                   if From_With_Type (Typ) then
 
-                     --  AI05-151 : incomplete types are allowed in all basic
+                     --  AI05-151: Incomplete types are allowed in all basic
                      --  declarations, including access to subprograms.
 
                      if Ada_Version >= Ada_2012 then
@@ -1618,6 +1619,7 @@  package body Sem_Ch3 is
    procedure Analyze_Component_Declaration (N : Node_Id) is
       Id : constant Entity_Id := Defining_Identifier (N);
       E  : constant Node_Id   := Expression (N);
+      AS : constant List_Id   := Aspect_Specifications (N);
       T  : Entity_Id;
       P  : Entity_Id;
 
@@ -1944,6 +1946,7 @@  package body Sem_Ch3 is
       end if;
 
       Set_Original_Record_Component (Id, Id);
+      Analyze_Aspect_Specifications (N, Id, AS);
    end Analyze_Component_Declaration;
 
    --------------------------
@@ -2069,2099 +2072,2112 @@  package body Sem_Ch3 is
       end loop;
    end Analyze_Declarations;
 
-   ----------------------------------
-   -- Analyze_Incomplete_Type_Decl --
-   ----------------------------------
+   -----------------------------------
+   -- Analyze_Full_Type_Declaration --
+   -----------------------------------
 
-   procedure Analyze_Incomplete_Type_Decl (N : Node_Id) is
-      F : constant Boolean := Is_Pure (Current_Scope);
-      T : Entity_Id;
+   procedure Analyze_Full_Type_Declaration (N : Node_Id) is
+      Def    : constant Node_Id   := Type_Definition (N);
+      Def_Id : constant Entity_Id := Defining_Identifier (N);
+      AS     : constant List_Id   := Aspect_Specifications (N);
+      T      : Entity_Id;
+      Prev   : Entity_Id;
 
-   begin
-      Generate_Definition (Defining_Identifier (N));
+      Is_Remote : constant Boolean :=
+                    (Is_Remote_Types (Current_Scope)
+                       or else Is_Remote_Call_Interface (Current_Scope))
+                    and then not (In_Private_Part (Current_Scope)
+                                    or else In_Package_Body (Current_Scope));
 
-      --  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.
+      procedure Check_Ops_From_Incomplete_Type;
+      --  If there is a tagged incomplete partial view of the type, transfer
+      --  its operations to the full view, and indicate that the type of the
+      --  controlling parameter (s) is this full view.
 
-      --  In this case, the discriminants (if any) must match
+      ------------------------------------
+      -- Check_Ops_From_Incomplete_Type --
+      ------------------------------------
 
-      T := Find_Type_Name (N);
+      procedure Check_Ops_From_Incomplete_Type is
+         Elmt   : Elmt_Id;
+         Formal : Entity_Id;
+         Op     : Entity_Id;
 
-      Set_Ekind (T, E_Incomplete_Type);
-      Init_Size_Align (T);
-      Set_Is_First_Subtype (T, True);
-      Set_Etype (T, T);
+      begin
+         if Prev /= T
+           and then Ekind (Prev) = E_Incomplete_Type
+           and then Is_Tagged_Type (Prev)
+           and then Is_Tagged_Type (T)
+         then
+            Elmt := First_Elmt (Primitive_Operations (Prev));
+            while Present (Elmt) loop
+               Op := Node (Elmt);
+               Prepend_Elmt (Op, Primitive_Operations (T));
 
-      --  Ada 2005 (AI-326): Minimum decoration to give support to tagged
-      --  incomplete types.
+               Formal := First_Formal (Op);
+               while Present (Formal) loop
+                  if Etype (Formal) = Prev then
+                     Set_Etype (Formal, T);
+                  end if;
 
-      if Tagged_Present (N) then
-         Set_Is_Tagged_Type (T);
-         Make_Class_Wide_Type (T);
-         Set_Primitive_Operations (T, New_Elmt_List);
-      end if;
+                  Next_Formal (Formal);
+               end loop;
 
-      Push_Scope (T);
+               if Etype (Op) = Prev then
+                  Set_Etype (Op, T);
+               end if;
 
-      Set_Stored_Constraint (T, No_Elist);
+               Next_Elmt (Elmt);
+            end loop;
+         end if;
+      end Check_Ops_From_Incomplete_Type;
 
-      if Present (Discriminant_Specifications (N)) then
-         Process_Discriminants (N);
-      end if;
+   --  Start of processing for Analyze_Full_Type_Declaration
 
-      End_Scope;
+   begin
+      Prev := Find_Type_Name (N);
 
-      --  If the type has discriminants, non-trivial subtypes may 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.
+      --  The full view, if present, now points to the current type
 
-      Set_Private_Dependents (T, New_Elmt_List);
-      Set_Is_Pure (T, F);
-   end Analyze_Incomplete_Type_Decl;
+      --  Ada 2005 (AI-50217): If the type was previously decorated when
+      --  imported through a LIMITED WITH clause, it appears as incomplete
+      --  but has no full view.
 
-   -----------------------------------
-   -- Analyze_Interface_Declaration --
-   -----------------------------------
+      --  If the incomplete view is tagged, a class_wide type has been
+      --  created already. Use it for the full view as well, to prevent
+      --  multiple incompatible class-wide types that may be  created for
+      --  self-referential anonymous access components.
 
-   procedure Analyze_Interface_Declaration (T : Entity_Id; Def : Node_Id) is
-      CW : constant Entity_Id := Class_Wide_Type (T);
+      if Ekind (Prev) = E_Incomplete_Type
+        and then Present (Full_View (Prev))
+      then
+         T := Full_View (Prev);
 
-   begin
-      Set_Is_Tagged_Type (T);
+         if Is_Tagged_Type (Prev)
+           and then Present (Class_Wide_Type (Prev))
+         then
+            Set_Ekind (T, Ekind (Prev));         --  will be reset later
+            Set_Class_Wide_Type (T, Class_Wide_Type (Prev));
+            Set_Etype (Class_Wide_Type (T), T);
+         end if;
 
-      Set_Is_Limited_Record (T, Limited_Present (Def)
-                                  or else Task_Present (Def)
-                                  or else Protected_Present (Def)
-                                  or else Synchronized_Present (Def));
+      else
+         T := Prev;
+      end if;
 
-      --  Type is abstract if full declaration carries keyword, or if previous
-      --  partial view did.
+      Set_Is_Pure (T, Is_Pure (Current_Scope));
 
-      Set_Is_Abstract_Type (T);
-      Set_Is_Interface (T);
+      --  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.
 
-      --  Type is a limited interface if it includes the keyword limited, task,
-      --  protected, or synchronized.
+      Set_Is_First_Subtype (T, True);
 
-      Set_Is_Limited_Interface
-        (T, Limited_Present (Def)
-              or else Protected_Present (Def)
-              or else Synchronized_Present (Def)
-              or else Task_Present (Def));
+      --  Only composite types other than array types are allowed to have
+      --  discriminants.
 
-      Set_Interfaces (T, New_Elmt_List);
-      Set_Primitive_Operations (T, New_Elmt_List);
+      case Nkind (Def) is
 
-      --  Complete the decoration of the class-wide entity if it was already
-      --  built (i.e. during the creation of the limited view)
+         --  For derived types, the rule will be checked once we've figured
+         --  out the parent type.
 
-      if Present (CW) then
-         Set_Is_Interface (CW);
-         Set_Is_Limited_Interface      (CW, Is_Limited_Interface (T));
-      end if;
+         when N_Derived_Type_Definition =>
+            null;
 
-      --  Check runtime support for synchronized interfaces
+         --  For record types, discriminants are allowed
 
-      if VM_Target = No_VM
-        and then (Is_Task_Interface (T)
-                    or else Is_Protected_Interface (T)
-                    or else Is_Synchronized_Interface (T))
-        and then not RTE_Available (RE_Select_Specific_Data)
-      then
-         Error_Msg_CRT ("synchronized interfaces", T);
-      end if;
-   end Analyze_Interface_Declaration;
+         when N_Record_Definition =>
+            null;
 
-   -----------------------------
-   -- Analyze_Itype_Reference --
-   -----------------------------
+         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;
 
-   --  Nothing to do. This node is placed in the tree only for the benefit of
-   --  back end processing, and has no effect on the semantic processing.
+      --  Elaborate the type definition according to kind, and generate
+      --  subsidiary (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).
 
-   procedure Analyze_Itype_Reference (N : Node_Id) is
-   begin
-      pragma Assert (Is_Itype (Itype (N)));
-      null;
-   end Analyze_Itype_Reference;
+      if not Analyzed (T) then
+         Set_Analyzed (T);
 
-   --------------------------------
-   -- Analyze_Number_Declaration --
-   --------------------------------
+         case Nkind (Def) is
 
-   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;
+            when N_Access_To_Subprogram_Definition =>
+               Access_Subprogram_Declaration (T, Def);
 
-   begin
-      Generate_Definition (Id);
-      Enter_Name (Id);
+               --  If this is a remote access to subprogram, we must create the
+               --  equivalent fat pointer type, and related subprograms.
 
-      --  This is an optimization of a common case of an integer literal
+               if Is_Remote then
+                  Process_Remote_AST_Declaration (N);
+               end if;
 
-      if Nkind (E) = N_Integer_Literal then
-         Set_Is_Static_Expression (E, True);
-         Set_Etype                (E, Universal_Integer);
+               --  Validate categorization rule against access type declaration
+               --  usually a violation in Pure unit, Shared_Passive unit.
 
-         Set_Etype     (Id, Universal_Integer);
-         Set_Ekind     (Id, E_Named_Integer);
-         Set_Is_Frozen (Id, True);
-         return;
-      end if;
+               Validate_Access_Type_Declaration (T, N);
 
-      Set_Is_Pure (Id, Is_Pure (Current_Scope));
+            when N_Access_To_Object_Definition =>
+               Access_Type_Declaration (T, Def);
 
-      --  Process expression, replacing error by integer zero, to avoid
-      --  cascaded errors or aborts further along in the processing
+               --  Validate categorization rule against access type declaration
+               --  usually a violation in Pure unit, Shared_Passive unit.
 
-      --  Replace Error by integer zero, which seems least likely to
-      --  cause cascaded errors.
+               Validate_Access_Type_Declaration (T, N);
 
-      if E = Error then
-         Rewrite (E, Make_Integer_Literal (Sloc (E), Uint_0));
-         Set_Error_Posted (E);
-      end if;
+               --  If we are in a Remote_Call_Interface package and define a
+               --  RACW, then calling stubs and specific stream attributes
+               --  must be added.
 
-      Analyze (E);
+               if Is_Remote
+                 and then Is_Remote_Access_To_Class_Wide_Type (Def_Id)
+               then
+                  Add_RACW_Features (Def_Id);
+               end if;
 
-      --  Verify that the expression is static and numeric. If
-      --  the expression is overloaded, we apply the preference
-      --  rule that favors root numeric types.
+               --  Set no strict aliasing flag if config pragma seen
 
-      if not Is_Overloaded (E) then
-         T := Etype (E);
+               if Opt.No_Strict_Aliasing then
+                  Set_No_Strict_Aliasing (Base_Type (Def_Id));
+               end if;
 
-      else
-         T := Any_Type;
+            when N_Array_Type_Definition =>
+               Array_Type_Declaration (T, Def);
 
-         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;
+            when N_Derived_Type_Definition =>
+               Derived_Type_Declaration (T, N, T /= Def_Id);
 
-      if Is_Integer_Type (T)  then
-         Resolve (E, T);
-         Set_Etype (Id, Universal_Integer);
-         Set_Ekind (Id, E_Named_Integer);
+            when N_Enumeration_Type_Definition =>
+               Enumeration_Type_Declaration (T, Def);
 
-      elsif Is_Real_Type (T) then
+            when N_Floating_Point_Definition =>
+               Floating_Point_Type_Declaration (T, Def);
 
-         --  Because the real value is converted to universal_real, this is a
-         --  legal context for a universal fixed expression.
+            when N_Decimal_Fixed_Point_Definition =>
+               Decimal_Fixed_Point_Type_Declaration (T, Def);
 
-         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));
+            when N_Ordinary_Fixed_Point_Definition =>
+               Ordinary_Fixed_Point_Type_Declaration (T, Def);
 
-            begin
-               Rewrite (E, Conv);
-               Analyze (E);
-            end;
+            when N_Signed_Integer_Type_Definition =>
+               Signed_Integer_Type_Declaration (T, Def);
 
-         elsif T = Any_Fixed then
-            Error_Msg_N ("illegal context for mixed mode operation", E);
+            when N_Modular_Type_Definition =>
+               Modular_Type_Declaration (T, Def);
 
-            --  Expression is of the form : universal_fixed * integer. Try to
-            --  resolve as universal_real.
+            when N_Record_Definition =>
+               Record_Type_Declaration (T, N, Prev);
 
-            T := Universal_Real;
-            Set_Etype (E, T);
-         end if;
+            --  If declaration has a parse error, nothing to elaborate.
 
-         Resolve (E, T);
-         Set_Etype (Id, Universal_Real);
-         Set_Ekind (Id, E_Named_Real);
+            when N_Error =>
+               null;
 
-      else
-         Wrong_Type (E, Any_Numeric);
-         Resolve (E, T);
+            when others =>
+               raise Program_Error;
 
-         Set_Etype               (Id, T);
-         Set_Ekind               (Id, E_Constant);
-         Set_Never_Set_In_Source (Id, True);
-         Set_Is_True_Constant    (Id, True);
-         return;
+         end case;
       end if;
 
-      if Nkind_In (E, N_Integer_Literal, N_Real_Literal) then
-         Set_Etype (E, Etype (Id));
+      if Etype (T) = Any_Type then
+         goto Leave;
       end if;
 
-      if not Is_OK_Static_Expression (E) then
-         Flag_Non_Static_Expr
-           ("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;
+      --  Some common processing for all types
 
-   --------------------------------
-   -- Analyze_Object_Declaration --
-   --------------------------------
+      Set_Depends_On_Private (T, Has_Private_Component (T));
+      Check_Ops_From_Incomplete_Type;
 
-   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;
+      --  Both the declared entity, and its anonymous base type if one
+      --  was created, need freeze nodes allocated.
 
-      E : Node_Id := Expression (N);
-      --  E is set to Expression (N) throughout this routine. When
-      --  Expression (N) is modified, E is changed accordingly.
+      declare
+         B : constant Entity_Id := Base_Type (T);
 
-      Prev_Entity : Entity_Id := Empty;
+      begin
+         --  In the case where the base type differs 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.
 
-      function Count_Tasks (T : Entity_Id) return Uint;
-      --  This function is called when a non-generic library level object of a
-      --  task type is declared. Its function is to count the static number of
-      --  tasks declared within the type (it is only called if Has_Tasks is set
-      --  for T). As a side effect, if an array of tasks with non-static bounds
-      --  or a variant record type is encountered, Check_Restrictions is called
-      --  indicating the count is unknown.
+         --  This does not apply if the base type is a generic type, whose
+         --  declaration is independent of the current derived definition.
 
-      -----------------
-      -- Count_Tasks --
-      -----------------
+         if B /= T and then not Is_Generic_Type (B) then
+            Ensure_Freeze_Node (B);
+            Set_First_Subtype_Link (Freeze_Node (B), T);
+         end if;
 
-      function Count_Tasks (T : Entity_Id) return Uint is
-         C : Entity_Id;
-         X : Node_Id;
-         V : Uint;
+         --  A type that is imported through a limited_with clause cannot
+         --  generate any code, and thus need not be frozen. However, an access
+         --  type with an imported designated type needs a finalization list,
+         --  which may be referenced in some other package that has non-limited
+         --  visibility on the designated type. Thus we must create the
+         --  finalization list at the point the access type is frozen, to
+         --  prevent unsatisfied references at link time.
 
-      begin
-         if Is_Task_Type (T) then
-            return Uint_1;
+         if not From_With_Type (T) or else Is_Access_Type (T) then
+            Set_Has_Delayed_Freeze (T);
+         end if;
+      end;
 
-         elsif Is_Record_Type (T) then
-            if Has_Discriminants (T) then
-               Check_Restriction (Max_Tasks, N);
-               return Uint_0;
+      --  Case where T is the full declaration of some private type which has
+      --  been swapped in Defining_Identifier (N).
 
-            else
-               V := Uint_0;
-               C := First_Component (T);
-               while Present (C) loop
-                  V := V + Count_Tasks (Etype (C));
-                  Next_Component (C);
-               end loop;
+      if T /= Def_Id and then Is_Private_Type (Def_Id) then
+         Process_Full_View (N, T, Def_Id);
 
-               return V;
-            end if;
+         --  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.
 
-         elsif Is_Array_Type (T) then
-            X := First_Index (T);
-            V := Count_Tasks (Component_Type (T));
-            while Present (X) loop
-               C := Etype (X);
+         --  Also, we want to kill Has_Pragma_Unreferenced temporarily here
+         --  since we don't want a complaint about the full type being an
+         --  unwanted reference to the private type
 
-               if not Is_Static_Subtype (C) then
-                  Check_Restriction (Max_Tasks, N);
-                  return Uint_0;
-               else
-                  V := V * (UI_Max (Uint_0,
-                                    Expr_Value (Type_High_Bound (C)) -
-                                    Expr_Value (Type_Low_Bound (C)) + Uint_1));
-               end if;
+         declare
+            B : constant Boolean := Has_Pragma_Unreferenced (T);
+         begin
+            Set_Has_Pragma_Unreferenced (T, False);
+            Generate_Reference (T, T, 'c');
+            Set_Has_Pragma_Unreferenced (T, B);
+         end;
 
-               Next_Index (X);
-            end loop;
+         Set_Completion_Referenced (Def_Id);
 
-            return V;
+      --  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).
 
-         else
-            return Uint_0;
-         end if;
-      end Count_Tasks;
+      elsif Ekind (Prev) = E_Incomplete_Type then
+         Process_Incomplete_Dependents (N, T, Prev);
+         Generate_Reference (Prev, Def_Id, 'c');
+         Set_Completion_Referenced (Def_Id);
 
-   --  Start of processing for Analyze_Object_Declaration
+      --  If not private type or incomplete type completion, this is a real
+      --  definition of a new entity, so record it.
 
-   begin
-      --  There are three kinds of implicit types generated by an
-      --  object declaration:
+      else
+         Generate_Definition (Def_Id);
+      end if;
 
-      --   1. Those for generated by the original Object Definition
+      if Chars (Scope (Def_Id)) = Name_System
+        and then Chars (Def_Id) = Name_Address
+        and then Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (N)))
+      then
+         Set_Is_Descendent_Of_Address (Def_Id);
+         Set_Is_Descendent_Of_Address (Base_Type (Def_Id));
+         Set_Is_Descendent_Of_Address (Prev);
+      end if;
 
-      --   2. Those generated by the Expression
+      Set_Optimize_Alignment_Flags (Def_Id);
+      Check_Eliminated (Def_Id);
 
-      --   3. Those used to constrained the Object Definition with the
-      --       expression constraints when it is unconstrained
+      <<Leave>> Analyze_Aspect_Specifications (N, Def_Id, AS);
+   end Analyze_Full_Type_Declaration;
 
-      --  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.
+   ----------------------------------
+   -- Analyze_Incomplete_Type_Decl --
+   ----------------------------------
 
-      if Constant_Present (N) then
-         Prev_Entity := Current_Entity_In_Scope (Id);
+   procedure Analyze_Incomplete_Type_Decl (N : Node_Id) is
+      F : constant Boolean := Is_Pure (Current_Scope);
+      T : Entity_Id;
 
-         if Present (Prev_Entity)
-           and then
-             --  If the homograph is an implicit subprogram, it is overridden
-             --  by the current declaration.
+   begin
+      Generate_Definition (Defining_Identifier (N));
 
-             ((Is_Overloadable (Prev_Entity)
-                and then Is_Inherited_Operation (Prev_Entity))
+      --  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.
 
-               --  The current object is a discriminal generated for an entry
-               --  family index. Even though the index is a constant, in this
-               --  particular context there is no true constant redeclaration.
-               --  Enter_Name will handle the visibility.
+      --  In this case, the discriminants (if any) must match
 
-               or else
-                (Is_Discriminal (Id)
-                   and then Ekind (Discriminal_Link (Id)) =
-                              E_Entry_Index_Parameter)
+      T := Find_Type_Name (N);
 
-               --  The current object is the renaming for a generic declared
-               --  within the instance.
+      Set_Ekind (T, E_Incomplete_Type);
+      Init_Size_Align (T);
+      Set_Is_First_Subtype (T, True);
+      Set_Etype (T, T);
 
-               or else
-                (Ekind (Prev_Entity) = E_Package
-                  and then Nkind (Parent (Prev_Entity)) =
-                                         N_Package_Renaming_Declaration
-                  and then not Comes_From_Source (Prev_Entity)
-                  and then Is_Generic_Instance (Renamed_Entity (Prev_Entity))))
-         then
-            Prev_Entity := Empty;
-         end if;
+      --  Ada 2005 (AI-326): Minimum decoration to give support to tagged
+      --  incomplete types.
+
+      if Tagged_Present (N) then
+         Set_Is_Tagged_Type (T);
+         Make_Class_Wide_Type (T);
+         Set_Primitive_Operations (T, New_Elmt_List);
       end if;
 
-      if Present (Prev_Entity) then
-         Constant_Redeclaration (Id, N, T);
+      Push_Scope (T);
 
-         Generate_Reference (Prev_Entity, Id, 'c');
-         Set_Completion_Referenced (Id);
+      Set_Stored_Constraint (T, No_Elist);
 
-         if Error_Posted (N) then
+      if Present (Discriminant_Specifications (N)) then
+         Process_Discriminants (N);
+      end if;
 
-            --  Type mismatch or illegal redeclaration, Do not analyze
-            --  expression to avoid cascaded errors.
+      End_Scope;
 
-            T := Find_Type_Of_Object (Object_Definition (N), N);
-            Set_Etype (Id, T);
-            Set_Ekind (Id, E_Variable);
-            return;
-         end if;
+      --  If the type has discriminants, non-trivial subtypes may 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.
 
-      --  In the normal case, enter identifier at the start to catch premature
-      --  usage in the initialization expression.
+      Set_Private_Dependents (T, New_Elmt_List);
+      Set_Is_Pure (T, F);
+   end Analyze_Incomplete_Type_Decl;
 
-      else
-         Generate_Definition (Id);
-         Enter_Name (Id);
+   -----------------------------------
+   -- Analyze_Interface_Declaration --
+   -----------------------------------
 
-         Mark_Coextensions (N, Object_Definition (N));
+   procedure Analyze_Interface_Declaration (T : Entity_Id; Def : Node_Id) is
+      CW : constant Entity_Id := Class_Wide_Type (T);
 
-         T := Find_Type_Of_Object (Object_Definition (N), N);
+   begin
+      Set_Is_Tagged_Type (T);
 
-         if Nkind (Object_Definition (N)) = N_Access_Definition
-           and then Present
-             (Access_To_Subprogram_Definition (Object_Definition (N)))
-           and then Protected_Present
-             (Access_To_Subprogram_Definition (Object_Definition (N)))
-         then
-            T := Replace_Anonymous_Access_To_Protected_Subprogram (N);
-         end if;
+      Set_Is_Limited_Record (T, Limited_Present (Def)
+                                  or else Task_Present (Def)
+                                  or else Protected_Present (Def)
+                                  or else Synchronized_Present (Def));
 
-         if Error_Posted (Id) then
-            Set_Etype (Id, T);
-            Set_Ekind (Id, E_Variable);
-            return;
-         end if;
-      end if;
+      --  Type is abstract if full declaration carries keyword, or if previous
+      --  partial view did.
 
-      --  Ada 2005 (AI-231): Propagate the null-excluding attribute and carry
-      --  out some static checks
+      Set_Is_Abstract_Type (T);
+      Set_Is_Interface (T);
 
-      if Ada_Version >= Ada_2005
-        and then Can_Never_Be_Null (T)
-      then
-         --  In case of aggregates we must also take care of the correct
-         --  initialization of nested aggregates bug this is done at the
-         --  point of the analysis of the aggregate (see sem_aggr.adb)
+      --  Type is a limited interface if it includes the keyword limited, task,
+      --  protected, or synchronized.
 
-         if Present (Expression (N))
-           and then Nkind (Expression (N)) = N_Aggregate
-         then
-            null;
+      Set_Is_Limited_Interface
+        (T, Limited_Present (Def)
+              or else Protected_Present (Def)
+              or else Synchronized_Present (Def)
+              or else Task_Present (Def));
 
-         else
-            declare
-               Save_Typ : constant Entity_Id := Etype (Id);
-            begin
-               Set_Etype (Id, T); --  Temp. decoration for static checks
-               Null_Exclusion_Static_Checks (N);
-               Set_Etype (Id, Save_Typ);
-            end;
-         end if;
-      end if;
+      Set_Interfaces (T, New_Elmt_List);
+      Set_Primitive_Operations (T, New_Elmt_List);
 
-      Set_Is_Pure (Id, Is_Pure (Current_Scope));
+      --  Complete the decoration of the class-wide entity if it was already
+      --  built (i.e. during the creation of the limited view)
 
-      --  If deferred constant, make sure context is appropriate. We detect
-      --  a deferred constant as a constant declaration with no expression.
-      --  A deferred constant can appear in a package body if its completion
-      --  is by means of an interface pragma.
+      if Present (CW) then
+         Set_Is_Interface (CW);
+         Set_Is_Limited_Interface      (CW, Is_Limited_Interface (T));
+      end if;
 
-      if Constant_Present (N)
-        and then No (E)
+      --  Check runtime support for synchronized interfaces
+
+      if VM_Target = No_VM
+        and then (Is_Task_Interface (T)
+                    or else Is_Protected_Interface (T)
+                    or else Is_Synchronized_Interface (T))
+        and then not RTE_Available (RE_Select_Specific_Data)
       then
-         --  A deferred constant may appear in the declarative part of the
-         --  following constructs:
+         Error_Msg_CRT ("synchronized interfaces", T);
+      end if;
+   end Analyze_Interface_Declaration;
 
-         --     blocks
-         --     entry bodies
-         --     extended return statements
-         --     package specs
-         --     package bodies
-         --     subprogram bodies
-         --     task bodies
+   -----------------------------
+   -- Analyze_Itype_Reference --
+   -----------------------------
 
-         --  When declared inside a package spec, a deferred constant must be
-         --  completed by a full constant declaration or pragma Import. In all
-         --  other cases, the only proper completion is pragma Import. Extended
-         --  return statements are flagged as invalid contexts because they do
-         --  not have a declarative part and so cannot accommodate the pragma.
+   --  Nothing to do. This node is placed in the tree only for the benefit of
+   --  back end processing, and has no effect on the semantic processing.
 
-         if Ekind (Current_Scope) = E_Return_Statement then
-            Error_Msg_N
-              ("invalid context for deferred constant declaration (RM 7.4)",
-               N);
-            Error_Msg_N
-              ("\declaration requires an initialization expression",
-                N);
-            Set_Constant_Present (N, False);
+   procedure Analyze_Itype_Reference (N : Node_Id) is
+   begin
+      pragma Assert (Is_Itype (Itype (N)));
+      null;
+   end Analyze_Itype_Reference;
 
-         --  In Ada 83, deferred constant must be of private type
+   --------------------------------
+   -- Analyze_Number_Declaration --
+   --------------------------------
 
-         elsif not Is_Private_Type (T) then
-            if Ada_Version = 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;
+   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;
 
-      --  If not a deferred constant, then object declaration freezes its type
+   begin
+      Generate_Definition (Id);
+      Enter_Name (Id);
 
-      else
-         Check_Fully_Declared (T, N);
-         Freeze_Before (N, T);
-      end if;
+      --  This is an optimization of a common case of an integer literal
 
-      --  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 (E) = N_Integer_Literal then
+         Set_Is_Static_Expression (E, True);
+         Set_Etype                (E, Universal_Integer);
 
-      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);
+         Set_Etype     (Id, Universal_Integer);
+         Set_Ekind     (Id, E_Named_Integer);
+         Set_Is_Frozen (Id, True);
+         return;
       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);
+      Set_Is_Pure (Id, Is_Pure (Current_Scope));
 
-         --  Protected objects with interrupt handlers must be at library level
+      --  Process expression, replacing error by integer zero, to avoid
+      --  cascaded errors or aborts further along in the processing
 
-         --  Ada 2005: this test is not needed (and the corresponding clause
-         --  in the RM is removed) because accessibility checks are sufficient
-         --  to make handlers not at the library level illegal.
+      --  Replace Error by integer zero, which seems least likely to
+      --  cause cascaded errors.
 
-         if Has_Interrupt_Handler (T)
-           and then Ada_Version < Ada_2005
-         then
-            Error_Msg_N
-              ("interrupt object can only be declared at library level", Id);
-         end if;
+      if E = Error then
+         Rewrite (E, Make_Integer_Literal (Sloc (E), Uint_0));
+         Set_Error_Posted (E);
       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;
+      Analyze (E);
 
-      --  Process initialization expression if present and not in error
+      --  Verify that the expression is static and numeric. If
+      --  the expression is overloaded, we apply the preference
+      --  rule that favors root numeric types.
 
-      if Present (E) and then E /= Error then
+      if not Is_Overloaded (E) then
+         T := Etype (E);
 
-         --  Generate an error in case of CPP class-wide object initialization.
-         --  Required because otherwise the expansion of the class-wide
-         --  assignment would try to use 'size to initialize the object
-         --  (primitive that is not available in CPP tagged types).
+      else
+         T := Any_Type;
 
-         if Is_Class_Wide_Type (Act_T)
-           and then
-             (Is_CPP_Class (Root_Type (Etype (Act_T)))
-               or else
-                 (Present (Full_View (Root_Type (Etype (Act_T))))
-                    and then
-                      Is_CPP_Class (Full_View (Root_Type (Etype (Act_T))))))
-         then
-            Error_Msg_N
-              ("predefined assignment not available for 'C'P'P tagged types",
-               E);
-         end if;
-
-         Mark_Coextensions (N, E);
-         Analyze (E);
-
-         --  In case of errors detected in the analysis of the expression,
-         --  decorate it with the expected type to avoid cascaded errors
-
-         if No (Etype (E)) then
-            Set_Etype (E, T);
-         end if;
-
-         --  If an initialization expression is present, then we set the
-         --  Is_True_Constant flag. It will be reset if this is a variable
-         --  and it is indeed modified.
-
-         Set_Is_True_Constant (Id, True);
+         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;
 
-         --  If we are analyzing a constant declaration, set its completion
-         --  flag after analyzing and resolving the expression.
+               elsif It.Typ = Universal_Real
+                 or else It.Typ = Universal_Integer
+               then
+                  --  Choose universal interpretation over any other
 
-         if Constant_Present (N) then
-            Set_Has_Completion (Id);
-         end if;
+                  T := It.Typ;
+                  exit;
+               end if;
+            end if;
 
-         --  Set type and resolve (type may be overridden later on)
+            Get_Next_Interp (Index, It);
+         end loop;
+      end if;
 
-         Set_Etype (Id, T);
+      if Is_Integer_Type (T)  then
          Resolve (E, T);
+         Set_Etype (Id, Universal_Integer);
+         Set_Ekind (Id, E_Named_Integer);
 
-         --  If E is null and has been replaced by an N_Raise_Constraint_Error
-         --  node (which was marked already-analyzed), we need to set the type
-         --  to something other than Any_Access in order to keep gigi happy.
-
-         if Etype (E) = Any_Access then
-            Set_Etype (E, T);
-         end if;
-
-         --  If the object is an access to variable, the initialization
-         --  expression cannot be an access to constant.
+      elsif Is_Real_Type (T) then
 
-         if Is_Access_Type (T)
-           and then not Is_Access_Constant (T)
-           and then Is_Access_Type (Etype (E))
-           and then Is_Access_Constant (Etype (E))
-         then
-            Error_Msg_N
-              ("access to variable cannot be initialized "
-               & "with an access-to-constant expression", E);
-         end if;
+         --  Because the real value is converted to universal_real, this is a
+         --  legal context for a universal fixed expression.
 
-         if not Assignment_OK (N) then
-            Check_Initialization (T, E);
-         end if;
+         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));
 
-         Check_Unset_Reference (E);
+            begin
+               Rewrite (E, Conv);
+               Analyze (E);
+            end;
 
-         --  If this is a variable, then set current value. If this is a
-         --  declared constant of a scalar type with a static expression,
-         --  indicate that it is always valid.
+         elsif T = Any_Fixed then
+            Error_Msg_N ("illegal context for mixed mode operation", E);
 
-         if not Constant_Present (N) then
-            if Compile_Time_Known_Value (E) then
-               Set_Current_Value (Id, E);
-            end if;
+            --  Expression is of the form : universal_fixed * integer. Try to
+            --  resolve as universal_real.
 
-         elsif Is_Scalar_Type (T)
-           and then Is_OK_Static_Expression (E)
-         then
-            Set_Is_Known_Valid (Id);
+            T := Universal_Real;
+            Set_Etype (E, T);
          end if;
 
-         --  Deal with setting of null flags
+         Resolve (E, T);
+         Set_Etype (Id, Universal_Real);
+         Set_Ekind (Id, E_Named_Real);
 
-         if Is_Access_Type (T) then
-            if Known_Non_Null (E) then
-               Set_Is_Known_Non_Null (Id, True);
-            elsif Known_Null (E)
-              and then not Can_Never_Be_Null (Id)
-            then
-               Set_Is_Known_Null (Id, True);
-            end if;
-         end if;
+      else
+         Wrong_Type (E, Any_Numeric);
+         Resolve (E, T);
 
-         --  Check incorrect use of dynamically tagged expressions.
+         Set_Etype               (Id, T);
+         Set_Ekind               (Id, E_Constant);
+         Set_Never_Set_In_Source (Id, True);
+         Set_Is_True_Constant    (Id, True);
+         return;
+      end if;
 
-         if Is_Tagged_Type (T) then
-            Check_Dynamically_Tagged_Expression
-              (Expr        => E,
-               Typ         => T,
-               Related_Nod => N);
-         end if;
+      if Nkind_In (E, N_Integer_Literal, N_Real_Literal) then
+         Set_Etype (E, Etype (Id));
+      end if;
 
-         Apply_Scalar_Range_Check (E, T);
-         Apply_Static_Length_Check (E, T);
+      if not Is_OK_Static_Expression (E) then
+         Flag_Non_Static_Expr
+           ("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;
 
-      --  If the No_Streams restriction is set, check that the type of the
-      --  object is not, and does not contain, any subtype derived from
-      --  Ada.Streams.Root_Stream_Type. Note that we guard the call to
-      --  Has_Stream just for efficiency reasons. There is no point in
-      --  spending time on a Has_Stream check if the restriction is not set.
+   --------------------------------
+   -- Analyze_Object_Declaration --
+   --------------------------------
 
-      if Restriction_Check_Required (No_Streams) then
-         if Has_Stream (T) then
-            Check_Restriction (No_Streams, N);
-         end if;
-      end if;
+   procedure Analyze_Object_Declaration (N : Node_Id) is
+      Loc   : constant Source_Ptr := Sloc (N);
+      Id    : constant Entity_Id  := Defining_Identifier (N);
+      AS    : constant List_Id    := Aspect_Specifications (N);
+      T     : Entity_Id;
+      Act_T : Entity_Id;
 
-      --  Case of unconstrained type
+      E : Node_Id := Expression (N);
+      --  E is set to Expression (N) throughout this routine. When
+      --  Expression (N) is modified, E is changed accordingly.
 
-      if Is_Indefinite_Subtype (T) then
+      Prev_Entity : Entity_Id := Empty;
 
-         --  Nothing to do in deferred constant case
+      function Count_Tasks (T : Entity_Id) return Uint;
+      --  This function is called when a non-generic library level object of a
+      --  task type is declared. Its function is to count the static number of
+      --  tasks declared within the type (it is only called if Has_Tasks is set
+      --  for T). As a side effect, if an array of tasks with non-static bounds
+      --  or a variant record type is encountered, Check_Restrictions is called
+      --  indicating the count is unknown.
 
-         if Constant_Present (N) and then No (E) then
-            null;
+      -----------------
+      -- Count_Tasks --
+      -----------------
 
-         --  Case of no initialization present
+      function Count_Tasks (T : Entity_Id) return Uint is
+         C : Entity_Id;
+         X : Node_Id;
+         V : Uint;
 
-         elsif No (E) then
-            if No_Initialization (N) then
-               null;
+      begin
+         if Is_Task_Type (T) then
+            return Uint_1;
 
-            elsif Is_Class_Wide_Type (T) then
-               Error_Msg_N
-                 ("initialization required in class-wide declaration ", N);
+         elsif Is_Record_Type (T) then
+            if Has_Discriminants (T) then
+               Check_Restriction (Max_Tasks, N);
+               return Uint_0;
 
             else
-               Error_Msg_N
-                 ("unconstrained subtype not allowed (need initialization)",
-                  Object_Definition (N));
+               V := Uint_0;
+               C := First_Component (T);
+               while Present (C) loop
+                  V := V + Count_Tasks (Etype (C));
+                  Next_Component (C);
+               end loop;
 
-               if Is_Record_Type (T) and then Has_Discriminants (T) then
-                  Error_Msg_N
-                    ("\provide initial value or explicit discriminant values",
-                     Object_Definition (N));
+               return V;
+            end if;
 
-                  Error_Msg_NE
-                    ("\or give default discriminant values for type&",
-                     Object_Definition (N), T);
+         elsif Is_Array_Type (T) then
+            X := First_Index (T);
+            V := Count_Tasks (Component_Type (T));
+            while Present (X) loop
+               C := Etype (X);
 
-               elsif Is_Array_Type (T) then
-                  Error_Msg_N
-                    ("\provide initial value or explicit array bounds",
-                     Object_Definition (N));
+               if not Is_Static_Subtype (C) then
+                  Check_Restriction (Max_Tasks, N);
+                  return Uint_0;
+               else
+                  V := V * (UI_Max (Uint_0,
+                                    Expr_Value (Type_High_Bound (C)) -
+                                    Expr_Value (Type_Low_Bound (C)) + Uint_1));
                end if;
-            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;
+               Next_Index (X);
+            end loop;
 
-         --  Case of initialization present
+            return V;
 
          else
-            --  Not allowed in Ada 83
+            return Uint_0;
+         end if;
+      end Count_Tasks;
 
-            if not Constant_Present (N) then
-               if Ada_Version = 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;
+   --  Start of processing for Analyze_Object_Declaration
 
-            --  Now we constrain the variable from the initializing expression
+   begin
+      --  There are three kinds of implicit types generated by an
+      --  object declaration:
 
-            --  If the expression is an aggregate, it has been expanded into
-            --  individual assignments. Retrieve the actual type from the
-            --  expanded construct.
+      --   1. Those for generated by the original Object Definition
 
-            if Is_Array_Type (T)
-              and then No_Initialization (N)
-              and then Nkind (Original_Node (E)) = N_Aggregate
-            then
-               Act_T := Etype (E);
+      --   2. Those generated by the Expression
 
-            --  In case of class-wide interface object declarations we delay
-            --  the generation of the equivalent record type declarations until
-            --  its expansion because there are cases in they are not required.
+      --   3. Those used to constrained the Object Definition with the
+      --       expression constraints when it is unconstrained
 
-            elsif Is_Interface (T) then
-               null;
+      --  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.
 
-            else
-               Expand_Subtype_From_Expr (N, T, Object_Definition (N), E);
-               Act_T := Find_Type_Of_Object (Object_Definition (N), N);
-            end if;
+      if Constant_Present (N) then
+         Prev_Entity := Current_Entity_In_Scope (Id);
 
-            Set_Is_Constr_Subt_For_U_Nominal (Act_T);
+         if Present (Prev_Entity)
+           and then
+             --  If the homograph is an implicit subprogram, it is overridden
+             --  by the current declaration.
 
-            if Aliased_Present (N) then
-               Set_Is_Constr_Subt_For_UN_Aliased (Act_T);
-            end if;
+             ((Is_Overloadable (Prev_Entity)
+                and then Is_Inherited_Operation (Prev_Entity))
 
-            Freeze_Before (N, Act_T);
-            Freeze_Before (N, T);
-         end if;
+               --  The current object is a discriminal generated for an entry
+               --  family index. Even though the index is a constant, in this
+               --  particular context there is no true constant redeclaration.
+               --  Enter_Name will handle the visibility.
 
-      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);
-            Check_Compile_Time_Size (Act_T);
+               or else
+                (Is_Discriminal (Id)
+                   and then Ekind (Discriminal_Link (Id)) =
+                              E_Entry_Index_Parameter)
 
-            if Aliased_Present (N) then
-               Set_Is_Constr_Subt_For_UN_Aliased (Act_T);
-            end if;
+               --  The current object is the renaming for a generic declared
+               --  within the instance.
+
+               or else
+                (Ekind (Prev_Entity) = E_Package
+                  and then Nkind (Parent (Prev_Entity)) =
+                                         N_Package_Renaming_Declaration
+                  and then not Comes_From_Source (Prev_Entity)
+                  and then Is_Generic_Instance (Renamed_Entity (Prev_Entity))))
+         then
+            Prev_Entity := Empty;
          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 Present (Prev_Entity) then
+         Constant_Redeclaration (Id, N, T);
 
-         if not Is_Constrained (T) then
-            null;
+         Generate_Reference (Prev_Entity, Id, 'c');
+         Set_Completion_Referenced (Id);
 
-         elsif Nkind (E) = N_Raise_Constraint_Error then
+         if Error_Posted (N) then
 
-            --  Aggregate is statically illegal. Place back in declaration
+            --  Type mismatch or illegal redeclaration, Do not analyze
+            --  expression to avoid cascaded errors.
 
-            Set_Expression (N, E);
-            Set_No_Initialization (N, False);
+            T := Find_Type_Of_Object (Object_Definition (N), N);
+            Set_Etype (Id, T);
+            Set_Ekind (Id, E_Variable);
+            goto Leave;
+         end if;
 
-         elsif T = Etype (E) then
-            null;
+      --  In the normal case, enter identifier at the start to catch premature
+      --  usage in the initialization expression.
 
-         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
+         Generate_Definition (Id);
+         Enter_Name (Id);
 
-         else
-            Apply_Length_Check (E, T);
-         end if;
+         Mark_Coextensions (N, Object_Definition (N));
 
-      --  If the type is limited unconstrained with defaulted discriminants and
-      --  there is no expression, then the object is constrained by the
-      --  defaults, so it is worthwhile building the corresponding subtype.
+         T := Find_Type_Of_Object (Object_Definition (N), N);
 
-      elsif (Is_Limited_Record (T) or else Is_Concurrent_Type (T))
-        and then not Is_Constrained (T)
-        and then Has_Discriminants (T)
-      then
-         if No (E) then
-            Act_T := Build_Default_Subtype (T, N);
-         else
-            --  Ada 2005:  a limited object may be initialized by means of an
-            --  aggregate. If the type has default discriminants it has an
-            --  unconstrained nominal type, Its actual subtype will be obtained
-            --  from the aggregate, and not from the default discriminants.
+         if Nkind (Object_Definition (N)) = N_Access_Definition
+           and then Present
+             (Access_To_Subprogram_Definition (Object_Definition (N)))
+           and then Protected_Present
+             (Access_To_Subprogram_Definition (Object_Definition (N)))
+         then
+            T := Replace_Anonymous_Access_To_Protected_Subprogram (N);
+         end if;
 
-            Act_T := Etype (E);
+         if Error_Posted (Id) then
+            Set_Etype (Id, T);
+            Set_Ekind (Id, E_Variable);
+            goto Leave;
          end if;
+      end if;
 
-         Rewrite (Object_Definition (N), New_Occurrence_Of (Act_T, Loc));
+      --  Ada 2005 (AI-231): Propagate the null-excluding attribute and carry
+      --  out some static checks
 
-      elsif Present (Underlying_Type (T))
-        and then not Is_Constrained (Underlying_Type (T))
-        and then Has_Discriminants (Underlying_Type (T))
-        and then Nkind (E) = N_Function_Call
-        and then Constant_Present (N)
+      if Ada_Version >= Ada_2005
+        and then Can_Never_Be_Null (T)
       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. ???
+         --  In case of aggregates we must also take care of the correct
+         --  initialization of nested aggregates bug this is done at the
+         --  point of the analysis of the aggregate (see sem_aggr.adb)
 
-         Remove_Side_Effects (E);
-      end if;
+         if Present (Expression (N))
+           and then Nkind (Expression (N)) = N_Aggregate
+         then
+            null;
 
-      --  Check No_Wide_Characters restriction
+         else
+            declare
+               Save_Typ : constant Entity_Id := Etype (Id);
+            begin
+               Set_Etype (Id, T); --  Temp. decoration for static checks
+               Null_Exclusion_Static_Checks (N);
+               Set_Etype (Id, Save_Typ);
+            end;
+         end if;
+      end if;
 
-      Check_Wide_Character_Restriction (T, Object_Definition (N));
+      Set_Is_Pure (Id, Is_Pure (Current_Scope));
 
-      --  Indicate this is not set in source. Certainly true for constants,
-      --  and true for variables so far (will be reset for a variable if and
-      --  when we encounter a modification in the source).
+      --  If deferred constant, make sure context is appropriate. We detect
+      --  a deferred constant as a constant declaration with no expression.
+      --  A deferred constant can appear in a package body if its completion
+      --  is by means of an interface pragma.
 
-      Set_Never_Set_In_Source (Id, True);
+      if Constant_Present (N)
+        and then No (E)
+      then
+         --  A deferred constant may appear in the declarative part of the
+         --  following constructs:
 
-      --  Now establish the proper kind and type of the object
+         --     blocks
+         --     entry bodies
+         --     extended return statements
+         --     package specs
+         --     package bodies
+         --     subprogram bodies
+         --     task bodies
 
-      if Constant_Present (N) then
-         Set_Ekind            (Id, E_Constant);
-         Set_Is_True_Constant (Id, True);
+         --  When declared inside a package spec, a deferred constant must be
+         --  completed by a full constant declaration or pragma Import. In all
+         --  other cases, the only proper completion is pragma Import. Extended
+         --  return statements are flagged as invalid contexts because they do
+         --  not have a declarative part and so cannot accommodate the pragma.
 
-      else
-         Set_Ekind (Id, E_Variable);
+         if Ekind (Current_Scope) = E_Return_Statement then
+            Error_Msg_N
+              ("invalid context for deferred constant declaration (RM 7.4)",
+               N);
+            Error_Msg_N
+              ("\declaration requires an initialization expression",
+                N);
+            Set_Constant_Present (N, False);
 
-         --  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.
+         --  In Ada 83, deferred constant must be of private type
 
-         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);
+         elsif not Is_Private_Type (T) then
+            if Ada_Version = 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;
 
-         --  Set Has_Initial_Value if initializing expression present. Note
-         --  that if there is no initializing expression, we leave the state
-         --  of this flag unchanged (usually it will be False, but notably in
-         --  the case of exception choice variables, it will already be true).
+      --  If not a deferred constant, then object declaration freezes its type
 
-         if Present (E) then
-            Set_Has_Initial_Value (Id, True);
-         end if;
+      else
+         Check_Fully_Declared (T, N);
+         Freeze_Before (N, T);
       end if;
 
-      --  Initialize alignment and size and capture alignment setting
+      --  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.
 
-      Init_Alignment               (Id);
-      Init_Esize                   (Id);
-      Set_Optimize_Alignment_Flags (Id);
+      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;
 
-      --  Deal with aliased case
+      --  Special checks for protected objects not at library level
 
-      if Aliased_Present (N) then
-         Set_Is_Aliased (Id);
+      if Is_Protected_Type (T)
+        and then not Is_Library_Level_Entity (Id)
+      then
+         Check_Restriction (No_Local_Protected_Objects, Id);
 
-         --  If the object is aliased and the type is unconstrained with
-         --  defaulted discriminants and there is no expression, then the
-         --  object is constrained by the defaults, so it is worthwhile
-         --  building the corresponding subtype.
+         --  Protected objects with interrupt handlers must be at library level
 
-         --  Ada 2005 (AI-363): If the aliased object is discriminated and
-         --  unconstrained, then only establish an actual subtype if the
-         --  nominal subtype is indefinite. In definite cases the object is
-         --  unconstrained in Ada 2005.
+         --  Ada 2005: this test is not needed (and the corresponding clause
+         --  in the RM is removed) because accessibility checks are sufficient
+         --  to make handlers not at the library level illegal.
 
-         if No (E)
-           and then Is_Record_Type (T)
-           and then not Is_Constrained (T)
-           and then Has_Discriminants (T)
-           and then (Ada_Version < Ada_2005 or else Is_Indefinite_Subtype (T))
+         if Has_Interrupt_Handler (T)
+           and then Ada_Version < Ada_2005
          then
-            Set_Actual_Subtype (Id, Build_Default_Subtype (T, N));
+            Error_Msg_N
+              ("interrupt object can only be declared at library level", Id);
          end if;
       end if;
 
-      --  Now we can set the type of the object
-
-      Set_Etype (Id, Act_T);
+      --  The actual subtype of the object is the nominal subtype, unless
+      --  the nominal one is unconstrained and obtained from the expression.
 
-      --  Deal with controlled types
+      Act_T := 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;
+      --  Process initialization expression if present and not in error
 
-         --  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.
+      if Present (E) and then E /= Error then
 
-         --  ??? at the moment we do not generate warnings for temporaries
-         --  created for those aggregates although Program_Error might be
-         --  generated if compiled with -gnato.
+         --  Generate an error in case of CPP class-wide object initialization.
+         --  Required because otherwise the expansion of the class-wide
+         --  assignment would try to use 'size to initialize the object
+         --  (primitive that is not available in CPP tagged types).
 
-         if Is_Controlled (Etype (Id))
-            and then Comes_From_Source (Id)
+         if Is_Class_Wide_Type (Act_T)
+           and then
+             (Is_CPP_Class (Root_Type (Etype (Act_T)))
+               or else
+                 (Present (Full_View (Root_Type (Etype (Act_T))))
+                    and then
+                      Is_CPP_Class (Full_View (Root_Type (Etype (Act_T))))))
          then
-            declare
-               BT : constant Entity_Id := Base_Type (Etype (Id));
-
-               Implicit_Call : Entity_Id;
-               pragma Warnings (Off, Implicit_Call);
-               --  ??? what is this for (never referenced!)
+            Error_Msg_N
+              ("predefined assignment not available for 'C'P'P tagged types",
+               E);
+         end if;
 
-               function Is_Aggr (N : Node_Id) return Boolean;
-               --  Check that N is an aggregate
+         Mark_Coextensions (N, E);
+         Analyze (E);
 
-               -------------
-               -- Is_Aggr --
-               -------------
+         --  In case of errors detected in the analysis of the expression,
+         --  decorate it with the expected type to avoid cascaded errors
 
-               function Is_Aggr (N : Node_Id) return Boolean is
-               begin
-                  case Nkind (Original_Node (N)) is
-                     when N_Aggregate | N_Extension_Aggregate =>
-                        return True;
+         if No (Etype (E)) then
+            Set_Etype (E, T);
+         end if;
 
-                     when N_Qualified_Expression |
-                          N_Type_Conversion      |
-                          N_Unchecked_Type_Conversion =>
-                        return Is_Aggr (Expression (Original_Node (N)));
+         --  If an initialization expression is present, then we set the
+         --  Is_True_Constant flag. It will be reset if this is a variable
+         --  and it is indeed modified.
 
-                     when others =>
-                        return False;
-                  end case;
-               end Is_Aggr;
+         Set_Is_True_Constant (Id, True);
 
-            begin
-               --  If no underlying type, we already are in an error situation.
-               --  Do not try to add a warning since we do not have access to
-               --  prim-op list.
+         --  If we are analyzing a constant declaration, set its completion
+         --  flag after analyzing and resolving the expression.
 
-               if No (Underlying_Type (BT)) then
-                  Implicit_Call := Empty;
+         if Constant_Present (N) then
+            Set_Has_Completion (Id);
+         end if;
 
-               --  A generic type does not have usable primitive operators.
-               --  Initialization calls are built for instances.
+         --  Set type and resolve (type may be overridden later on)
 
-               elsif Is_Generic_Type (BT) then
-                  Implicit_Call := Empty;
+         Set_Etype (Id, T);
+         Resolve (E, T);
 
-               --  If the init expression is not an aggregate, an adjust call
-               --  will be generated
+         --  If E is null and has been replaced by an N_Raise_Constraint_Error
+         --  node (which was marked already-analyzed), we need to set the type
+         --  to something other than Any_Access in order to keep gigi happy.
 
-               elsif Present (E) and then not Is_Aggr (E) then
-                  Implicit_Call := Find_Prim_Op (BT, Name_Adjust);
+         if Etype (E) = Any_Access then
+            Set_Etype (E, T);
+         end if;
 
-               --  If no init expression and we are not in the deferred
-               --  constant case, an Initialize call will be generated
+         --  If the object is an access to variable, the initialization
+         --  expression cannot be an access to constant.
 
-               elsif No (E) and then not Constant_Present (N) then
-                  Implicit_Call := Find_Prim_Op (BT, Name_Initialize);
+         if Is_Access_Type (T)
+           and then not Is_Access_Constant (T)
+           and then Is_Access_Type (Etype (E))
+           and then Is_Access_Constant (Etype (E))
+         then
+            Error_Msg_N
+              ("access to variable cannot be initialized "
+               & "with an access-to-constant expression", E);
+         end if;
 
-               else
-                  Implicit_Call := Empty;
-               end if;
-            end;
+         if not Assignment_OK (N) then
+            Check_Initialization (T, E);
          end if;
-      end if;
 
-      if Has_Task (Etype (Id)) then
-         Check_Restriction (No_Tasking, N);
+         Check_Unset_Reference (E);
 
-         --  Deal with counting max tasks
+         --  If this is a variable, then set current value. If this is a
+         --  declared constant of a scalar type with a static expression,
+         --  indicate that it is always valid.
 
-         --  Nothing to do if inside a generic
+         if not Constant_Present (N) then
+            if Compile_Time_Known_Value (E) then
+               Set_Current_Value (Id, E);
+            end if;
 
-         if Inside_A_Generic then
-            null;
+         elsif Is_Scalar_Type (T)
+           and then Is_OK_Static_Expression (E)
+         then
+            Set_Is_Known_Valid (Id);
+         end if;
 
-         --  If library level entity, then count tasks
+         --  Deal with setting of null flags
 
-         elsif Is_Library_Level_Entity (Id) then
-            Check_Restriction (Max_Tasks, N, Count_Tasks (Etype (Id)));
+         if Is_Access_Type (T) then
+            if Known_Non_Null (E) then
+               Set_Is_Known_Non_Null (Id, True);
+            elsif Known_Null (E)
+              and then not Can_Never_Be_Null (Id)
+            then
+               Set_Is_Known_Null (Id, True);
+            end if;
+         end if;
 
-         --  If not library level entity, then indicate we don't know max
-         --  tasks and also check task hierarchy restriction and blocking
-         --  operation (since starting a task is definitely blocking!)
+         --  Check incorrect use of dynamically tagged expressions.
 
-         else
-            Check_Restriction (Max_Tasks, N);
-            Check_Restriction (No_Task_Hierarchy, N);
-            Check_Potentially_Blocking_Operation (N);
+         if Is_Tagged_Type (T) then
+            Check_Dynamically_Tagged_Expression
+              (Expr        => E,
+               Typ         => T,
+               Related_Nod => N);
          end if;
 
-         --  A rather specialized test. If we see two tasks being declared
-         --  of the same type in the same object declaration, and the task
-         --  has an entry with an address clause, we know that program error
-         --  will be raised at run time since we can't have two tasks with
-         --  entries at the same address.
-
-         if Is_Task_Type (Etype (Id)) and then More_Ids (N) then
-            declare
-               E : Entity_Id;
+         Apply_Scalar_Range_Check (E, T);
+         Apply_Static_Length_Check (E, T);
+      end if;
 
-            begin
-               E := First_Entity (Etype (Id));
-               while Present (E) loop
-                  if Ekind (E) = E_Entry
-                    and then Present (Get_Attribute_Definition_Clause
-                                        (E, Attribute_Address))
-                  then
-                     Error_Msg_N
-                       ("?more than one task with same entry address", N);
-                     Error_Msg_N
-                       ("\?Program_Error will be raised at run time", N);
-                     Insert_Action (N,
-                       Make_Raise_Program_Error (Loc,
-                         Reason => PE_Duplicated_Entry_Address));
-                     exit;
-                  end if;
+      --  If the No_Streams restriction is set, check that the type of the
+      --  object is not, and does not contain, any subtype derived from
+      --  Ada.Streams.Root_Stream_Type. Note that we guard the call to
+      --  Has_Stream just for efficiency reasons. There is no point in
+      --  spending time on a Has_Stream check if the restriction is not set.
 
-                  Next_Entity (E);
-               end loop;
-            end;
+      if Restriction_Check_Required (No_Streams) then
+         if Has_Stream (T) then
+            Check_Restriction (No_Streams, 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.
+      --  Case of unconstrained type
 
-      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;
+      if Is_Indefinite_Subtype (T) then
 
-      --  Another optimization: if the nominal subtype is unconstrained and
-      --  the expression is a function call that returns an unconstrained
-      --  type, rewrite the declaration 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.
+         --  Nothing to do in deferred constant case
 
-      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 (Underlying_Type (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,
-             Access_Definition   => Empty,
-             Subtype_Mark        => New_Occurrence_Of
-                                      (Base_Type (Etype (Id)), Loc),
-             Name                => E));
+         if Constant_Present (N) and then No (E) then
+            null;
 
-         Set_Renamed_Object (Id, E);
+         --  Case of no initialization present
 
-         --  Force generation of debugging information for the constant and for
-         --  the renamed function call.
+         elsif No (E) then
+            if No_Initialization (N) then
+               null;
 
-         Set_Debug_Info_Needed (Id);
-         Set_Debug_Info_Needed (Entity (Prefix (E)));
-      end if;
+            elsif Is_Class_Wide_Type (T) then
+               Error_Msg_N
+                 ("initialization required in class-wide declaration ", N);
 
-      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;
+            else
+               Error_Msg_N
+                 ("unconstrained subtype not allowed (need initialization)",
+                  Object_Definition (N));
 
-      Check_Eliminated (Id);
+               if Is_Record_Type (T) and then Has_Discriminants (T) then
+                  Error_Msg_N
+                    ("\provide initial value or explicit discriminant values",
+                     Object_Definition (N));
 
-      --  Deal with setting In_Private_Part flag if in private part
+                  Error_Msg_NE
+                    ("\or give default discriminant values for type&",
+                     Object_Definition (N), T);
 
-      if Ekind (Scope (Id)) = E_Package
-        and then In_Private_Part (Scope (Id))
-      then
-         Set_In_Private_Part (Id);
-      end if;
+               elsif Is_Array_Type (T) then
+                  Error_Msg_N
+                    ("\provide initial value or explicit array bounds",
+                     Object_Definition (N));
+               end if;
+            end if;
 
-      --  Check for violation of No_Local_Timing_Events
+         --  Case of initialization present but in error. Set initial
+         --  expression as absent (but do not make above complaints)
 
-      if Is_RTE (Etype (Id), RE_Timing_Event)
-        and then not Is_Library_Level_Entity (Id)
-      then
-         Check_Restriction (No_Local_Timing_Events, N);
-      end if;
-   end Analyze_Object_Declaration;
+         elsif E = Error then
+            Set_Expression (N, Empty);
+            E := Empty;
 
-   ---------------------------
-   -- Analyze_Others_Choice --
-   ---------------------------
+         --  Case of initialization present
 
-   --  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
+         else
+            --  Not allowed in Ada 83
 
-   procedure Analyze_Others_Choice (N : Node_Id) is
-      pragma Warnings (Off, N);
-   begin
-      null;
-   end Analyze_Others_Choice;
+            if not Constant_Present (N) then
+               if Ada_Version = 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;
 
-   -------------------------------------------
-   -- Analyze_Private_Extension_Declaration --
-   -------------------------------------------
+            --  Now we constrain the variable from the initializing expression
 
-   procedure Analyze_Private_Extension_Declaration (N : Node_Id) is
-      T           : constant Entity_Id := Defining_Identifier (N);
-      Indic       : constant Node_Id   := Subtype_Indication (N);
-      Parent_Type : Entity_Id;
-      Parent_Base : Entity_Id;
+            --  If the expression is an aggregate, it has been expanded into
+            --  individual assignments. Retrieve the actual type from the
+            --  expanded construct.
 
-   begin
-      --  Ada 2005 (AI-251): Decorate all names in list of ancestor interfaces
+            if Is_Array_Type (T)
+              and then No_Initialization (N)
+              and then Nkind (Original_Node (E)) = N_Aggregate
+            then
+               Act_T := Etype (E);
 
-      if Is_Non_Empty_List (Interface_List (N)) then
-         declare
-            Intf : Node_Id;
-            T    : Entity_Id;
+            --  In case of class-wide interface object declarations we delay
+            --  the generation of the equivalent record type declarations until
+            --  its expansion because there are cases in they are not required.
 
-         begin
-            Intf := First (Interface_List (N));
-            while Present (Intf) loop
-               T := Find_Type_Of_Subtype_Indic (Intf);
+            elsif Is_Interface (T) then
+               null;
 
-               Diagnose_Interface (Intf, T);
-               Next (Intf);
-            end loop;
-         end;
-      end if;
+            else
+               Expand_Subtype_From_Expr (N, T, Object_Definition (N), E);
+               Act_T := Find_Type_Of_Object (Object_Definition (N), N);
+            end if;
 
-      Generate_Definition (T);
-      Enter_Name (T);
+            Set_Is_Constr_Subt_For_U_Nominal (Act_T);
 
-      Parent_Type := Find_Type_Of_Subtype_Indic (Indic);
-      Parent_Base := Base_Type (Parent_Type);
+            if Aliased_Present (N) then
+               Set_Is_Constr_Subt_For_UN_Aliased (Act_T);
+            end if;
 
-      if Parent_Type = Any_Type
-        or else Etype (Parent_Type) = Any_Type
+            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
-         Set_Ekind (T, Ekind (Parent_Type));
-         Set_Etype (T, Any_Type);
-         return;
+         if not Is_Entity_Name (Object_Definition (N)) then
+            Act_T := Etype (E);
+            Check_Compile_Time_Size (Act_T);
 
-      elsif not Is_Tagged_Type (Parent_Type) then
-         Error_Msg_N
-           ("parent of type extension must be a tagged type ", Indic);
-         return;
+            if Aliased_Present (N) then
+               Set_Is_Constr_Subt_For_UN_Aliased (Act_T);
+            end if;
+         end if;
 
-      elsif Ekind_In (Parent_Type, E_Void, E_Incomplete_Type) then
-         Error_Msg_N ("premature derivation of incomplete type", Indic);
-         return;
+         --  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 =>...)
 
-      elsif Is_Concurrent_Type (Parent_Type) then
-         Error_Msg_N
-           ("parent type of a private extension cannot be "
-            & "a synchronized tagged type (RM 3.9.1 (3/1))", N);
+         if not Is_Constrained (T) then
+            null;
 
-         Set_Etype              (T, Any_Type);
-         Set_Ekind              (T, E_Limited_Private_Type);
-         Set_Private_Dependents (T, New_Elmt_List);
-         Set_Error_Posted       (T);
-         return;
-      end if;
+         elsif Nkind (E) = N_Raise_Constraint_Error then
 
-      --  Perhaps the parent type should be changed to the class-wide type's
-      --  specific type in this case to prevent cascading errors ???
+            --  Aggregate is statically illegal. Place back in declaration
 
-      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;
+            Set_Expression (N, E);
+            Set_No_Initialization (N, False);
 
-      if (not Is_Package_Or_Generic_Package (Current_Scope)
-           and then Nkind (Parent (N)) /= N_Generic_Subprogram_Declaration)
-        or else In_Private_Part (Current_Scope)
+         elsif T = Etype (E) then
+            null;
 
-      then
-         Error_Msg_N ("invalid context for private extension", N);
-      end if;
+         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;
 
-      --  Set common attributes
+         else
+            Apply_Length_Check (E, T);
+         end if;
 
-      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);
+      --  If the type is limited unconstrained with defaulted discriminants and
+      --  there is no expression, then the object is constrained by the
+      --  defaults, so it is worthwhile building the corresponding subtype.
 
-      Set_Etype            (T,            Parent_Base);
-      Set_Has_Task         (T, Has_Task  (Parent_Base));
+      elsif (Is_Limited_Record (T) or else Is_Concurrent_Type (T))
+        and then not Is_Constrained (T)
+        and then Has_Discriminants (T)
+      then
+         if No (E) then
+            Act_T := Build_Default_Subtype (T, N);
+         else
+            --  Ada 2005:  a limited object may be initialized by means of an
+            --  aggregate. If the type has default discriminants it has an
+            --  unconstrained nominal type, Its actual subtype will be obtained
+            --  from the aggregate, and not from the default discriminants.
 
-      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);
+            Act_T := Etype (E);
+         end if;
 
-      if Unknown_Discriminants_Present (N) then
-         Set_Discriminant_Constraint (T, No_Elist);
+         Rewrite (Object_Definition (N), New_Occurrence_Of (Act_T, Loc));
+
+      elsif Present (Underlying_Type (T))
+        and then not Is_Constrained (Underlying_Type (T))
+        and then Has_Discriminants (Underlying_Type (T))
+        and then Nkind (E) = N_Function_Call
+        and then Constant_Present (N)
+      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;
 
-      Build_Derived_Record_Type (N, Parent_Type, T);
+      --  Check No_Wide_Characters restriction
 
-      --  Ada 2005 (AI-443): Synchronized private extension or a rewritten
-      --  synchronized formal derived type.
+      Check_Wide_Character_Restriction (T, Object_Definition (N));
 
-      if Ada_Version >= Ada_2005
-        and then Synchronized_Present (N)
-      then
-         Set_Is_Limited_Record (T);
+      --  Indicate this is not set in source. Certainly true for constants,
+      --  and true for variables so far (will be reset for a variable if and
+      --  when we encounter a modification in the source).
 
-         --  Formal derived type case
+      Set_Never_Set_In_Source (Id, True);
 
-         if Is_Generic_Type (T) then
+      --  Now establish the proper kind and type of the object
 
-            --  The parent must be a tagged limited type or a synchronized
-            --  interface.
+      if Constant_Present (N) then
+         Set_Ekind            (Id, E_Constant);
+         Set_Is_True_Constant (Id, True);
 
-            if (not Is_Tagged_Type (Parent_Type)
-                  or else not Is_Limited_Type (Parent_Type))
-              and then
-               (not Is_Interface (Parent_Type)
-                  or else not Is_Synchronized_Interface (Parent_Type))
-            then
-               Error_Msg_NE ("parent type of & must be tagged limited " &
-                             "or synchronized", N, T);
-            end if;
+      else
+         Set_Ekind (Id, E_Variable);
 
-            --  The progenitors (if any) must be limited or synchronized
-            --  interfaces.
+         --  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 Present (Interfaces (T)) then
-               declare
-                  Iface      : Entity_Id;
-                  Iface_Elmt : Elmt_Id;
+         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;
 
-               begin
-                  Iface_Elmt := First_Elmt (Interfaces (T));
-                  while Present (Iface_Elmt) loop
-                     Iface := Node (Iface_Elmt);
+         --  Set Has_Initial_Value if initializing expression present. Note
+         --  that if there is no initializing expression, we leave the state
+         --  of this flag unchanged (usually it will be False, but notably in
+         --  the case of exception choice variables, it will already be true).
 
-                     if not Is_Limited_Interface (Iface)
-                       and then not Is_Synchronized_Interface (Iface)
-                     then
-                        Error_Msg_NE ("progenitor & must be limited " &
-                                      "or synchronized", N, Iface);
-                     end if;
+         if Present (E) then
+            Set_Has_Initial_Value (Id, True);
+         end if;
+      end if;
 
-                     Next_Elmt (Iface_Elmt);
-                  end loop;
-               end;
-            end if;
+      --  Initialize alignment and size and capture alignment setting
 
-         --  Regular derived extension, the parent must be a limited or
-         --  synchronized interface.
+      Init_Alignment               (Id);
+      Init_Esize                   (Id);
+      Set_Optimize_Alignment_Flags (Id);
 
-         else
-            if not Is_Interface (Parent_Type)
-              or else (not Is_Limited_Interface (Parent_Type)
-                         and then
-                       not Is_Synchronized_Interface (Parent_Type))
-            then
-               Error_Msg_NE
-                 ("parent type of & must be limited interface", N, T);
-            end if;
-         end if;
+      --  Deal with aliased case
 
-      --  A consequence of 3.9.4 (6/2) and 7.3 (7.2/2) is that a private
-      --  extension with a synchronized parent must be explicitly declared
-      --  synchronized, because the full view will be a synchronized type.
-      --  This must be checked before the check for limited types below,
-      --  to ensure that types declared limited are not allowed to extend
-      --  synchronized interfaces.
+      if Aliased_Present (N) then
+         Set_Is_Aliased (Id);
 
-      elsif Is_Interface (Parent_Type)
-        and then Is_Synchronized_Interface (Parent_Type)
-        and then not Synchronized_Present (N)
-      then
-         Error_Msg_NE
-           ("private extension of& must be explicitly synchronized",
-             N, Parent_Type);
+         --  If the object is aliased and the type is unconstrained with
+         --  defaulted discriminants and there is no expression, then the
+         --  object is constrained by the defaults, so it is worthwhile
+         --  building the corresponding subtype.
 
-      elsif Limited_Present (N) then
-         Set_Is_Limited_Record (T);
+         --  Ada 2005 (AI-363): If the aliased object is discriminated and
+         --  unconstrained, then only establish an actual subtype if the
+         --  nominal subtype is indefinite. In definite cases the object is
+         --  unconstrained in Ada 2005.
 
-         if not Is_Limited_Type (Parent_Type)
-           and then
-             (not Is_Interface (Parent_Type)
-               or else not Is_Limited_Interface (Parent_Type))
+         if No (E)
+           and then Is_Record_Type (T)
+           and then not Is_Constrained (T)
+           and then Has_Discriminants (T)
+           and then (Ada_Version < Ada_2005 or else Is_Indefinite_Subtype (T))
          then
-            Error_Msg_NE ("parent type& of limited extension must be limited",
-              N, Parent_Type);
+            Set_Actual_Subtype (Id, Build_Default_Subtype (T, N));
          end if;
       end if;
-   end Analyze_Private_Extension_Declaration;
 
-   ---------------------------------
-   -- Analyze_Subtype_Declaration --
-   ---------------------------------
+      --  Now we can set the type of the object
 
-   procedure Analyze_Subtype_Declaration
-     (N    : Node_Id;
-      Skip : Boolean := False)
-   is
-      Id       : constant Entity_Id := Defining_Identifier (N);
-      T        : Entity_Id;
-      R_Checks : Check_Result;
+      Set_Etype (Id, Act_T);
 
-   begin
-      Generate_Definition (Id);
-      Set_Is_Pure (Id, Is_Pure (Current_Scope));
-      Init_Size_Align (Id);
+      --  Deal with controlled types
 
-      --  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.
+      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;
 
-      --  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)
+         --  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.
 
-      --  This also happens when the full view of a private type is derived
-      --  type with constraints. In this case the entity has been introduced
-      --  in the private declaration.
+         --  ??? at the moment we do not generate warnings for temporaries
+         --  created for those aggregates although Program_Error might be
+         --  generated if compiled with -gnato.
 
-      if Skip
-        or else (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;
+         if Is_Controlled (Etype (Id))
+            and then Comes_From_Source (Id)
+         then
+            declare
+               BT : constant Entity_Id := Base_Type (Etype (Id));
 
-      else
-         Enter_Name (Id);
-      end if;
+               Implicit_Call : Entity_Id;
+               pragma Warnings (Off, Implicit_Call);
+               --  ??? what is this for (never referenced!)
 
-      T := Process_Subtype (Subtype_Indication (N), N, Id, 'P');
+               function Is_Aggr (N : Node_Id) return Boolean;
+               --  Check that N is an aggregate
 
-      --  Inherit common attributes
+               -------------
+               -- Is_Aggr --
+               -------------
 
-      Set_Is_Generic_Type   (Id, Is_Generic_Type   (Base_Type (T)));
-      Set_Is_Volatile       (Id, Is_Volatile       (T));
-      Set_Treat_As_Volatile (Id, Treat_As_Volatile (T));
-      Set_Is_Atomic         (Id, Is_Atomic         (T));
-      Set_Is_Ada_2005_Only  (Id, Is_Ada_2005_Only  (T));
-      Set_Is_Ada_2012_Only  (Id, Is_Ada_2012_Only  (T));
-      Set_Convention        (Id, Convention        (T));
+               function Is_Aggr (N : Node_Id) return Boolean is
+               begin
+                  case Nkind (Original_Node (N)) is
+                     when N_Aggregate | N_Extension_Aggregate =>
+                        return True;
 
-      --  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.
+                     when N_Qualified_Expression |
+                          N_Type_Conversion      |
+                          N_Unchecked_Type_Conversion =>
+                        return Is_Aggr (Expression (Original_Node (N)));
 
-      if Nkind (Subtype_Indication (N)) /= N_Subtype_Indication then
-         Set_Etype (Id, Base_Type (T));
+                     when others =>
+                        return False;
+                  end case;
+               end Is_Aggr;
 
-         case Ekind (T) is
-            when Array_Kind =>
-               Set_Ekind                       (Id, E_Array_Subtype);
-               Copy_Array_Subtype_Attributes   (Id, T);
+            begin
+               --  If no underlying type, we already are in an error situation.
+               --  Do not try to add a warning since we do not have access to
+               --  prim-op list.
 
-            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_Is_Known_Valid       (Id, Is_Known_Valid     (T));
-               Set_RM_Size              (Id, RM_Size            (T));
+               if No (Underlying_Type (BT)) then
+                  Implicit_Call := Empty;
 
-            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_Is_Known_Valid       (Id, Is_Known_Valid     (T));
-               Set_RM_Size              (Id, RM_Size            (T));
+               --  A generic type does not have usable primitive operators.
+               --  Initialization calls are built for instances.
 
-            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_Is_Known_Valid       (Id, Is_Known_Valid     (T));
-               Set_RM_Size              (Id, RM_Size            (T));
+               elsif Is_Generic_Type (BT) then
+                  Implicit_Call := Empty;
 
-            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));
+               --  If the init expression is not an aggregate, an adjust call
+               --  will be generated
 
-            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_Is_Known_Valid       (Id, Is_Known_Valid     (T));
-               Set_RM_Size              (Id, RM_Size            (T));
+               elsif Present (E) and then not Is_Aggr (E) then
+                  Implicit_Call := Find_Prim_Op (BT, Name_Adjust);
 
-            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_Is_Known_Valid       (Id, Is_Known_Valid     (T));
-               Set_RM_Size              (Id, RM_Size            (T));
+               --  If no init expression and we are not in the deferred
+               --  constant case, an Initialize call will be generated
 
-            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);
+               elsif No (E) and then not Constant_Present (N) then
+                  Implicit_Call := Find_Prim_Op (BT, Name_Initialize);
 
-               if Ekind (T) = E_Class_Wide_Subtype then
-                  Set_Equivalent_Type   (Id, Equivalent_Type    (T));
+               else
+                  Implicit_Call := Empty;
                end if;
+            end;
+         end if;
+      end if;
 
-            when E_Record_Type | E_Record_Subtype =>
-               Set_Ekind                (Id, E_Record_Subtype);
+      if Has_Task (Etype (Id)) then
+         Check_Restriction (No_Tasking, N);
 
-               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;
+         --  Deal with counting max tasks
 
-               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));
+         --  Nothing to do if inside a generic
 
-               if Has_Discriminants (T) then
-                  Set_Discriminant_Constraint
-                                        (Id, Discriminant_Constraint (T));
-                  Set_Stored_Constraint_From_Discriminant_Constraint (Id);
+         if Inside_A_Generic then
+            null;
 
-               elsif Has_Unknown_Discriminants (Id) then
-                  Set_Discriminant_Constraint (Id, No_Elist);
-               end if;
+         --  If library level entity, then count tasks
 
-               if Is_Tagged_Type (T) then
-                  Set_Is_Tagged_Type    (Id);
-                  Set_Is_Abstract_Type  (Id, Is_Abstract_Type (T));
-                  Set_Primitive_Operations
-                                        (Id, Primitive_Operations (T));
-                  Set_Class_Wide_Type   (Id, Class_Wide_Type (T));
+         elsif Is_Library_Level_Entity (Id) then
+            Check_Restriction (Max_Tasks, N, Count_Tasks (Etype (Id)));
 
-                  if Is_Interface (T) then
-                     Set_Is_Interface (Id);
-                     Set_Is_Limited_Interface (Id, Is_Limited_Interface (T));
+         --  If not library level entity, then indicate we don't know max
+         --  tasks and also check task hierarchy restriction and blocking
+         --  operation (since starting a task is definitely blocking!)
+
+         else
+            Check_Restriction (Max_Tasks, N);
+            Check_Restriction (No_Task_Hierarchy, N);
+            Check_Potentially_Blocking_Operation (N);
+         end if;
+
+         --  A rather specialized test. If we see two tasks being declared
+         --  of the same type in the same object declaration, and the task
+         --  has an entry with an address clause, we know that program error
+         --  will be raised at run time since we can't have two tasks with
+         --  entries at the same address.
+
+         if Is_Task_Type (Etype (Id)) and then More_Ids (N) then
+            declare
+               E : Entity_Id;
+
+            begin
+               E := First_Entity (Etype (Id));
+               while Present (E) loop
+                  if Ekind (E) = E_Entry
+                    and then Present (Get_Attribute_Definition_Clause
+                                        (E, Attribute_Address))
+                  then
+                     Error_Msg_N
+                       ("?more than one task with same entry address", N);
+                     Error_Msg_N
+                       ("\?Program_Error will be raised at run time", N);
+                     Insert_Action (N,
+                       Make_Raise_Program_Error (Loc,
+                         Reason => PE_Duplicated_Entry_Address));
+                     exit;
                   end if;
-               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));
-               Set_Known_To_Have_Preelab_Init
-                                      (Id, Known_To_Have_Preelab_Init (T));
+                  Next_Entity (E);
+               end loop;
+            end;
+         end if;
+      end if;
 
-               if Is_Tagged_Type (T) then
-                  Set_Is_Tagged_Type       (Id);
-                  Set_Is_Abstract_Type     (Id, Is_Abstract_Type (T));
-                  Set_Primitive_Operations (Id, Primitive_Operations (T));
-                  Set_Class_Wide_Type      (Id, Class_Wide_Type (T));
-               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.
 
-               --  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 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;
 
-               if Has_Discriminants (T) then
-                  Set_Discriminant_Constraint
-                                     (Id, Discriminant_Constraint (T));
-                  Set_Stored_Constraint_From_Discriminant_Constraint (Id);
+      --  Another optimization: if the nominal subtype is unconstrained and
+      --  the expression is a function call that returns an unconstrained
+      --  type, rewrite the declaration 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.
 
-               elsif Present (Full_View (T))
-                 and then Has_Discriminants (Full_View (T))
-               then
-                  Set_Discriminant_Constraint
-                               (Id, Discriminant_Constraint (Full_View (T)));
-                  Set_Stored_Constraint_From_Discriminant_Constraint (Id);
+      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 (Underlying_Type (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,
+             Access_Definition   => Empty,
+             Subtype_Mark        => New_Occurrence_Of
+                                      (Base_Type (Etype (Id)), Loc),
+             Name                => E));
 
-                  --  This would seem semantically correct, but apparently
-                  --  confuses the back-end. To be explained and checked with
-                  --  current version ???
+         Set_Renamed_Object (Id, E);
 
-                  --  Set_Has_Discriminants (Id);
-               end if;
+         --  Force generation of debugging information for the constant and for
+         --  the renamed function call.
 
-               Prepare_Private_Subtype_Completion (Id, N);
+         Set_Debug_Info_Needed (Id);
+         Set_Debug_Info_Needed (Entity (Prefix (E)));
+      end if;
 
-            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));
-               Set_Can_Never_Be_Null (Id, Can_Never_Be_Null     (T));
+      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;
 
-               --  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, or if it has
-               --  a specified Storage_Size of zero (RM05-10.2.1(15.4-15.5)).
+      Check_Eliminated (Id);
 
-               if Comes_From_Source (Id)
-                 and then In_Pure_Unit
-                 and then not In_Subprogram_Task_Protected_Unit
-                 and then not No_Pool_Assigned (Id)
-               then
-                  Error_Msg_N
-                    ("named access types not allowed in pure unit", N);
-               end if;
+      --  Deal with setting In_Private_Part flag if in private part
 
-            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_Is_Tagged_Type       (Id, Is_Tagged_Type        (T));
-               Set_Last_Entity          (Id, Last_Entity           (T));
+      if Ekind (Scope (Id)) = E_Package
+        and then In_Private_Part (Scope (Id))
+      then
+         Set_In_Private_Part (Id);
+      end if;
 
-               if Has_Discriminants (T) then
-                  Set_Discriminant_Constraint (Id,
-                                           Discriminant_Constraint (T));
-                  Set_Stored_Constraint_From_Discriminant_Constraint (Id);
-               end if;
+      --  Check for violation of No_Local_Timing_Events
 
-            when E_Incomplete_Type =>
-               if Ada_Version >= Ada_2005 then
-                  Set_Ekind (Id, E_Incomplete_Subtype);
+      if Is_RTE (Etype (Id), RE_Timing_Event)
+        and then not Is_Library_Level_Entity (Id)
+      then
+         Check_Restriction (No_Local_Timing_Events, N);
+      end if;
 
-                  --  Ada 2005 (AI-412): Decorate an incomplete subtype
-                  --  of an incomplete type visible through a limited
-                  --  with clause.
+      <<Leave>> Analyze_Aspect_Specifications (N, Id, AS);
+   end Analyze_Object_Declaration;
 
-                  if From_With_Type (T)
-                    and then Present (Non_Limited_View (T))
-                  then
-                     Set_From_With_Type   (Id);
-                     Set_Non_Limited_View (Id, Non_Limited_View (T));
+   ---------------------------
+   -- Analyze_Others_Choice --
+   ---------------------------
 
-                  --  Ada 2005 (AI-412): Add the regular incomplete subtype
-                  --  to the private dependents of the original incomplete
-                  --  type for future transformation.
+   --  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
 
-                  else
-                     Append_Elmt (Id, Private_Dependents (T));
-                  end if;
+   procedure Analyze_Others_Choice (N : Node_Id) is
+      pragma Warnings (Off, N);
+   begin
+      null;
+   end Analyze_Others_Choice;
 
-               --  If the subtype name denotes an incomplete type an error
-               --  was already reported by Process_Subtype.
+   -------------------------------------------
+   -- Analyze_Private_Extension_Declaration --
+   -------------------------------------------
 
-               else
-                  Set_Etype (Id, Any_Type);
-               end if;
+   procedure Analyze_Private_Extension_Declaration (N : Node_Id) is
+      T           : constant Entity_Id := Defining_Identifier (N);
+      Indic       : constant Node_Id   := Subtype_Indication (N);
+      AS          : constant List_Id   := Aspect_Specifications (N);
+      Parent_Type : Entity_Id;
+      Parent_Base : Entity_Id;
 
-            when others =>
-               raise Program_Error;
-         end case;
-      end if;
+   begin
+      --  Ada 2005 (AI-251): Decorate all names in list of ancestor interfaces
 
-      if Etype (Id) = Any_Type then
-         return;
+      if Is_Non_Empty_List (Interface_List (N)) then
+         declare
+            Intf : Node_Id;
+            T    : Entity_Id;
+
+         begin
+            Intf := First (Interface_List (N));
+            while Present (Intf) loop
+               T := Find_Type_Of_Subtype_Indic (Intf);
+
+               Diagnose_Interface (Intf, T);
+               Next (Intf);
+            end loop;
+         end;
       end if;
 
-      --  Some common processing on all types
+      Generate_Definition (T);
+      Enter_Name (T);
 
-      Set_Size_Info      (Id,                 T);
-      Set_First_Rep_Item (Id, First_Rep_Item (T));
+      Parent_Type := Find_Type_Of_Subtype_Indic (Indic);
+      Parent_Base := Base_Type (Parent_Type);
 
-      T := Etype (Id);
+      if Parent_Type = Any_Type
+        or else Etype (Parent_Type) = Any_Type
+      then
+         Set_Ekind (T, Ekind (Parent_Type));
+         Set_Etype (T, Any_Type);
+         goto Leave;
 
-      Set_Is_Immediately_Visible   (Id, True);
-      Set_Depends_On_Private       (Id, Has_Private_Component (T));
-      Set_Is_Descendent_Of_Address (Id, Is_Descendent_Of_Address (T));
+      elsif not Is_Tagged_Type (Parent_Type) then
+         Error_Msg_N
+           ("parent of type extension must be a tagged type ", Indic);
+         goto Leave;
 
-      if Is_Interface (T) then
-         Set_Is_Interface (Id);
+      elsif Ekind_In (Parent_Type, E_Void, E_Incomplete_Type) then
+         Error_Msg_N ("premature derivation of incomplete type", Indic);
+         goto Leave;
+
+      elsif Is_Concurrent_Type (Parent_Type) then
+         Error_Msg_N
+           ("parent type of a private extension cannot be "
+            & "a synchronized tagged type (RM 3.9.1 (3/1))", N);
+
+         Set_Etype              (T, Any_Type);
+         Set_Ekind              (T, E_Limited_Private_Type);
+         Set_Private_Dependents (T, New_Elmt_List);
+         Set_Error_Posted       (T);
+         goto Leave;
+      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);
+         goto Leave;
       end if;
 
-      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)
+      if (not Is_Package_Or_Generic_Package (Current_Scope)
+           and then Nkind (Parent (N)) /= N_Generic_Subprogram_Declaration)
+        or else In_Private_Part (Current_Scope)
+
       then
-         if Is_Tagged_Type (Id) then
+         Error_Msg_N ("invalid context for private extension", N);
+      end if;
 
-            --  If this is a generic actual subtype for a synchronized type,
-            --  the primitive operations are those of the corresponding record
-            --  for which there is a separate subtype declaration.
+      --  Set common attributes
 
-            if Is_Concurrent_Type (Id) then
-               null;
-            elsif 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;
+      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);
 
-         elsif Scope (Etype (Id)) /= Standard_Standard then
-            Derive_Subprograms (Generic_Parent_Type (N), Id);
-         end if;
+      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);
+
+      if Unknown_Discriminants_Present (N) then
+         Set_Discriminant_Constraint (T, No_Elist);
       end if;
 
-      if Is_Private_Type (T)
-        and then Present (Full_View (T))
-      then
-         Conditional_Delay (Id, Full_View (T));
+      Build_Derived_Record_Type (N, Parent_Type, 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.
+      --  Ada 2005 (AI-443): Synchronized private extension or a rewritten
+      --  synchronized formal derived type.
 
-      elsif Ekind (Scope (Id)) /= E_Protected_Type
-        and then Present (Scope (Scope (Id))) -- error defense!
-        and then Ekind (Scope (Scope (Id))) /= E_Protected_Type
+      if Ada_Version >= Ada_2005
+        and then Synchronized_Present (N)
       then
-         Conditional_Delay (Id, T);
-      end if;
+         Set_Is_Limited_Record (T);
 
-      --  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.
+         --  Formal derived type case
 
-      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))));
+         if Is_Generic_Type (T) then
 
-         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???
+            --  The parent must be a tagged limited type or a synchronized
+            --  interface.
 
-            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)
+            if (not Is_Tagged_Type (Parent_Type)
+                  or else not Is_Limited_Type (Parent_Type))
               and then
-                Nkind (Scalar_Range (Etype (First_Index (Id)))) = N_Range
+               (not Is_Interface (Parent_Type)
+                  or else not Is_Synchronized_Interface (Parent_Type))
             then
+               Error_Msg_NE ("parent type of & must be tagged limited " &
+                             "or synchronized", N, T);
+            end if;
+
+            --  The progenitors (if any) must be limited or synchronized
+            --  interfaces.
+
+            if Present (Interfaces (T)) then
                declare
-                  Target_Typ : constant Entity_Id :=
-                                 Etype
-                                   (First_Index (Etype
-                                     (Subtype_Mark (Subtype_Indication (N)))));
+                  Iface      : Entity_Id;
+                  Iface_Elmt : Elmt_Id;
+
                begin
-                  R_Checks :=
-                    Get_Range_Checks
-                      (Scalar_Range (Etype (First_Index (Id))),
-                       Target_Typ,
-                       Etype (First_Index (Id)),
-                       Defining_Identifier (N));
+                  Iface_Elmt := First_Elmt (Interfaces (T));
+                  while Present (Iface_Elmt) loop
+                     Iface := Node (Iface_Elmt);
 
-                  Insert_Range_Checks
-                    (R_Checks,
-                     N,
-                     Target_Typ,
-                     Sloc (Defining_Identifier (N)));
+                     if not Is_Limited_Interface (Iface)
+                       and then not Is_Synchronized_Interface (Iface)
+                     then
+                        Error_Msg_NE ("progenitor & must be limited " &
+                                      "or synchronized", N, Iface);
+                     end if;
+
+                     Next_Elmt (Iface_Elmt);
+                  end loop;
                end;
             end if;
-         end if;
-      end if;
-
-      Set_Optimize_Alignment_Flags (Id);
-      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));
+         --  Regular derived extension, the parent must be a limited or
+         --  synchronized interface.
 
-   begin
-      Analyze (T);
+         else
+            if not Is_Interface (Parent_Type)
+              or else (not Is_Limited_Interface (Parent_Type)
+                         and then
+                       not Is_Synchronized_Interface (Parent_Type))
+            then
+               Error_Msg_NE
+                 ("parent type of & must be limited interface", N, T);
+            end if;
+         end if;
 
-      if R /= Error then
-         Analyze (R);
-         Set_Etype (N, Etype (R));
-         Resolve (R, Entity (T));
-      else
-         Set_Error_Posted (R);
-         Set_Error_Posted (T);
-      end if;
-   end Analyze_Subtype_Indication;
+      --  A consequence of 3.9.4 (6/2) and 7.3 (7.2/2) is that a private
+      --  extension with a synchronized parent must be explicitly declared
+      --  synchronized, because the full view will be a synchronized type.
+      --  This must be checked before the check for limited types below,
+      --  to ensure that types declared limited are not allowed to extend
+      --  synchronized interfaces.
 
-   ------------------------------
-   -- Analyze_Type_Declaration --
-   ------------------------------
+      elsif Is_Interface (Parent_Type)
+        and then Is_Synchronized_Interface (Parent_Type)
+        and then not Synchronized_Present (N)
+      then
+         Error_Msg_NE
+           ("private extension of& must be explicitly synchronized",
+             N, Parent_Type);
 
-   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;
+      elsif Limited_Present (N) then
+         Set_Is_Limited_Record (T);
 
-      Is_Remote : constant Boolean :=
-                    (Is_Remote_Types (Current_Scope)
-                       or else Is_Remote_Call_Interface (Current_Scope))
-                    and then not (In_Private_Part (Current_Scope)
-                                    or else In_Package_Body (Current_Scope));
+         if not Is_Limited_Type (Parent_Type)
+           and then
+             (not Is_Interface (Parent_Type)
+               or else not Is_Limited_Interface (Parent_Type))
+         then
+            Error_Msg_NE ("parent type& of limited extension must be limited",
+              N, Parent_Type);
+         end if;
+      end if;
 
-      procedure Check_Ops_From_Incomplete_Type;
-      --  If there is a tagged incomplete partial view of the type, transfer
-      --  its operations to the full view, and indicate that the type of the
-      --  controlling parameter (s) is this full view.
+      <<Leave>> Analyze_Aspect_Specifications (N, T, AS);
+   end Analyze_Private_Extension_Declaration;
 
-      ------------------------------------
-      -- Check_Ops_From_Incomplete_Type --
-      ------------------------------------
+   ---------------------------------
+   -- Analyze_Subtype_Declaration --
+   ---------------------------------
 
-      procedure Check_Ops_From_Incomplete_Type is
-         Elmt   : Elmt_Id;
-         Formal : Entity_Id;
-         Op     : Entity_Id;
+   procedure Analyze_Subtype_Declaration
+     (N    : Node_Id;
+      Skip : Boolean := False)
+   is
+      Id       : constant Entity_Id := Defining_Identifier (N);
+      AS       : constant List_Id   := Aspect_Specifications (N);
+      T        : Entity_Id;
+      R_Checks : Check_Result;
 
-      begin
-         if Prev /= T
-           and then Ekind (Prev) = E_Incomplete_Type
-           and then Is_Tagged_Type (Prev)
-           and then Is_Tagged_Type (T)
-         then
-            Elmt := First_Elmt (Primitive_Operations (Prev));
-            while Present (Elmt) loop
-               Op := Node (Elmt);
-               Prepend_Elmt (Op, Primitive_Operations (T));
+   begin
+      Generate_Definition (Id);
+      Set_Is_Pure (Id, Is_Pure (Current_Scope));
+      Init_Size_Align (Id);
 
-               Formal := First_Formal (Op);
-               while Present (Formal) loop
-                  if Etype (Formal) = Prev then
-                     Set_Etype (Formal, T);
-                  end if;
+      --  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.
 
-                  Next_Formal (Formal);
-               end loop;
+      --  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)
 
-               if Etype (Op) = Prev then
-                  Set_Etype (Op, T);
-               end if;
+      --  This also happens when the full view of a private type is derived
+      --  type with constraints. In this case the entity has been introduced
+      --  in the private declaration.
 
-               Next_Elmt (Elmt);
-            end loop;
-         end if;
-      end Check_Ops_From_Incomplete_Type;
+      if Skip
+        or else (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;
 
-   --  Start of processing for Analyze_Type_Declaration
+      else
+         Enter_Name (Id);
+      end if;
 
-   begin
-      Prev := Find_Type_Name (N);
+      T := Process_Subtype (Subtype_Indication (N), N, Id, 'P');
 
-      --  The full view, if present, now points to the current type
+      --  Inherit common attributes
 
-      --  Ada 2005 (AI-50217): If the type was previously decorated when
-      --  imported through a LIMITED WITH clause, it appears as incomplete
-      --  but has no full view.
-      --  If the incomplete view is tagged, a class_wide type has been
-      --  created already. Use it for the full view as well, to prevent
-      --  multiple incompatible class-wide types that may be  created for
-      --  self-referential anonymous access components.
+      Set_Is_Generic_Type   (Id, Is_Generic_Type   (Base_Type (T)));
+      Set_Is_Volatile       (Id, Is_Volatile       (T));
+      Set_Treat_As_Volatile (Id, Treat_As_Volatile (T));
+      Set_Is_Atomic         (Id, Is_Atomic         (T));
+      Set_Is_Ada_2005_Only  (Id, Is_Ada_2005_Only  (T));
+      Set_Is_Ada_2012_Only  (Id, Is_Ada_2012_Only  (T));
+      Set_Convention        (Id, Convention        (T));
 
-      if Ekind (Prev) = E_Incomplete_Type
-        and then Present (Full_View (Prev))
-      then
-         T := Full_View (Prev);
+      --  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 Is_Tagged_Type (Prev)
-           and then Present (Class_Wide_Type (Prev))
-         then
-            Set_Ekind (T, Ekind (Prev));         --  will be reset later
-            Set_Class_Wide_Type (T, Class_Wide_Type (Prev));
-            Set_Etype (Class_Wide_Type (T), T);
-         end if;
+      if Nkind (Subtype_Indication (N)) /= N_Subtype_Indication then
+         Set_Etype (Id, Base_Type (T));
 
-      else
-         T := Prev;
-      end if;
+         case Ekind (T) is
+            when Array_Kind =>
+               Set_Ekind                       (Id, E_Array_Subtype);
+               Copy_Array_Subtype_Attributes   (Id, T);
 
-      Set_Is_Pure (T, Is_Pure (Current_Scope));
+            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_Is_Known_Valid       (Id, Is_Known_Valid     (T));
+               Set_RM_Size              (Id, RM_Size            (T));
 
-      --  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.
+            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_Is_Known_Valid       (Id, Is_Known_Valid     (T));
+               Set_RM_Size              (Id, RM_Size            (T));
 
-      Set_Is_First_Subtype (T, True);
+            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_Is_Known_Valid       (Id, Is_Known_Valid     (T));
+               Set_RM_Size              (Id, RM_Size            (T));
 
-      --  Only composite types other than array types are allowed to have
-      --  discriminants.
+            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));
 
-      case Nkind (Def) is
+            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_Is_Known_Valid       (Id, Is_Known_Valid     (T));
+               Set_RM_Size              (Id, RM_Size            (T));
 
-         --  For derived types, the rule will be checked once we've figured
-         --  out the parent type.
+            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_Is_Known_Valid       (Id, Is_Known_Valid     (T));
+               Set_RM_Size              (Id, RM_Size            (T));
 
-         when N_Derived_Type_Definition =>
-            null;
+            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);
 
-         --  For record types, discriminants are allowed
+               if Ekind (T) = E_Class_Wide_Subtype then
+                  Set_Equivalent_Type   (Id, Equivalent_Type    (T));
+               end if;
 
-         when N_Record_Definition =>
-            null;
+            when E_Record_Type | E_Record_Subtype =>
+               Set_Ekind                (Id, E_Record_Subtype);
 
-         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;
+               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;
 
-      --  Elaborate the type definition according to kind, and generate
-      --  subsidiary (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).
+               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 not Analyzed (T) then
-         Set_Analyzed (T);
+               if Has_Discriminants (T) then
+                  Set_Discriminant_Constraint
+                                        (Id, Discriminant_Constraint (T));
+                  Set_Stored_Constraint_From_Discriminant_Constraint (Id);
 
-         case Nkind (Def) is
+               elsif Has_Unknown_Discriminants (Id) then
+                  Set_Discriminant_Constraint (Id, No_Elist);
+               end if;
 
-            when N_Access_To_Subprogram_Definition =>
-               Access_Subprogram_Declaration (T, Def);
+               if Is_Tagged_Type (T) then
+                  Set_Is_Tagged_Type    (Id);
+                  Set_Is_Abstract_Type  (Id, Is_Abstract_Type (T));
+                  Set_Primitive_Operations
+                                        (Id, Primitive_Operations (T));
+                  Set_Class_Wide_Type   (Id, Class_Wide_Type (T));
 
-               --  If this is a remote access to subprogram, we must create the
-               --  equivalent fat pointer type, and related subprograms.
+                  if Is_Interface (T) then
+                     Set_Is_Interface (Id);
+                     Set_Is_Limited_Interface (Id, Is_Limited_Interface (T));
+                  end if;
+               end if;
 
-               if Is_Remote then
-                  Process_Remote_AST_Declaration (N);
+            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));
+               Set_Known_To_Have_Preelab_Init
+                                      (Id, Known_To_Have_Preelab_Init (T));
+
+               if Is_Tagged_Type (T) then
+                  Set_Is_Tagged_Type       (Id);
+                  Set_Is_Abstract_Type     (Id, Is_Abstract_Type (T));
+                  Set_Primitive_Operations (Id, Primitive_Operations (T));
+                  Set_Class_Wide_Type      (Id, Class_Wide_Type (T));
                end if;
 
-               --  Validate categorization rule against access type declaration
-               --  usually a violation in Pure unit, Shared_Passive unit.
+               --  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.
 
-               Validate_Access_Type_Declaration (T, N);
+               if Has_Discriminants (T) then
+                  Set_Discriminant_Constraint
+                                     (Id, Discriminant_Constraint (T));
+                  Set_Stored_Constraint_From_Discriminant_Constraint (Id);
 
-            when N_Access_To_Object_Definition =>
-               Access_Type_Declaration (T, Def);
+               elsif Present (Full_View (T))
+                 and then Has_Discriminants (Full_View (T))
+               then
+                  Set_Discriminant_Constraint
+                               (Id, Discriminant_Constraint (Full_View (T)));
+                  Set_Stored_Constraint_From_Discriminant_Constraint (Id);
 
-               --  Validate categorization rule against access type declaration
-               --  usually a violation in Pure unit, Shared_Passive unit.
+                  --  This would seem semantically correct, but apparently
+                  --  confuses the back-end. To be explained and checked with
+                  --  current version ???
 
-               Validate_Access_Type_Declaration (T, N);
+                  --  Set_Has_Discriminants (Id);
+               end if;
 
-               --  If we are in a Remote_Call_Interface package and define a
-               --  RACW, then calling stubs and specific stream attributes
-               --  must be added.
+               Prepare_Private_Subtype_Completion (Id, N);
 
-               if Is_Remote
-                 and then Is_Remote_Access_To_Class_Wide_Type (Def_Id)
+            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));
+               Set_Can_Never_Be_Null (Id, Can_Never_Be_Null     (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, or if it has
+               --  a specified Storage_Size of zero (RM05-10.2.1(15.4-15.5)).
+
+               if Comes_From_Source (Id)
+                 and then In_Pure_Unit
+                 and then not In_Subprogram_Task_Protected_Unit
+                 and then not No_Pool_Assigned (Id)
                then
-                  Add_RACW_Features (Def_Id);
+                  Error_Msg_N
+                    ("named access types not allowed in pure unit", N);
                end if;
 
-               --  Set no strict aliasing flag if config pragma seen
+            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_Is_Tagged_Type       (Id, Is_Tagged_Type        (T));
+               Set_Last_Entity          (Id, Last_Entity           (T));
 
-               if Opt.No_Strict_Aliasing then
-                  Set_No_Strict_Aliasing (Base_Type (Def_Id));
+               if Has_Discriminants (T) then
+                  Set_Discriminant_Constraint (Id,
+                                           Discriminant_Constraint (T));
+                  Set_Stored_Constraint_From_Discriminant_Constraint (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 E_Incomplete_Type =>
+               if Ada_Version >= Ada_2005 then
+                  Set_Ekind (Id, E_Incomplete_Subtype);
 
-            when N_Ordinary_Fixed_Point_Definition =>
-               Ordinary_Fixed_Point_Type_Declaration (T, Def);
+                  --  Ada 2005 (AI-412): Decorate an incomplete subtype
+                  --  of an incomplete type visible through a limited
+                  --  with clause.
 
-            when N_Signed_Integer_Type_Definition =>
-               Signed_Integer_Type_Declaration (T, Def);
+                  if From_With_Type (T)
+                    and then Present (Non_Limited_View (T))
+                  then
+                     Set_From_With_Type   (Id);
+                     Set_Non_Limited_View (Id, Non_Limited_View (T));
 
-            when N_Modular_Type_Definition =>
-               Modular_Type_Declaration (T, Def);
+                  --  Ada 2005 (AI-412): Add the regular incomplete subtype
+                  --  to the private dependents of the original incomplete
+                  --  type for future transformation.
 
-            when N_Record_Definition =>
-               Record_Type_Declaration (T, N, Prev);
+                  else
+                     Append_Elmt (Id, Private_Dependents (T));
+                  end if;
 
-            --  If declaration has a parse error, nothing to elaborate.
+               --  If the subtype name denotes an incomplete type an error
+               --  was already reported by Process_Subtype.
 
-            when N_Error =>
-               null;
+               else
+                  Set_Etype (Id, Any_Type);
+               end if;
 
             when others =>
                raise Program_Error;
-
          end case;
       end if;
 
-      if Etype (T) = Any_Type then
-         return;
+      if Etype (Id) = Any_Type then
+         goto Leave;
       end if;
 
-      --  Some common processing for all types
+      --  Some common processing on all types
 
-      Set_Depends_On_Private (T, Has_Private_Component (T));
-      Check_Ops_From_Incomplete_Type;
+      Set_Size_Info      (Id,                 T);
+      Set_First_Rep_Item (Id, First_Rep_Item (T));
 
-      --  Both the declared entity, and its anonymous base type if one
-      --  was created, need freeze nodes allocated.
+      T := Etype (Id);
 
-      declare
-         B : constant Entity_Id := Base_Type (T);
+      Set_Is_Immediately_Visible   (Id, True);
+      Set_Depends_On_Private       (Id, Has_Private_Component (T));
+      Set_Is_Descendent_Of_Address (Id, Is_Descendent_Of_Address (T));
 
-      begin
-         --  In the case where the base type differs 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 Is_Interface (T) then
+         Set_Is_Interface (Id);
+      end if;
 
-         --  This does not apply if the base type is a generic type, whose
-         --  declaration is independent of the current derived definition.
+      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 B /= T and then not Is_Generic_Type (B) then
-            Ensure_Freeze_Node (B);
-            Set_First_Subtype_Link (Freeze_Node (B), T);
-         end if;
+            --  If this is a generic actual subtype for a synchronized type,
+            --  the primitive operations are those of the corresponding record
+            --  for which there is a separate subtype declaration.
 
-         --  A type that is imported through a limited_with clause cannot
-         --  generate any code, and thus need not be frozen. However, an access
-         --  type with an imported designated type needs a finalization list,
-         --  which may be referenced in some other package that has non-limited
-         --  visibility on the designated type. Thus we must create the
-         --  finalization list at the point the access type is frozen, to
-         --  prevent unsatisfied references at link time.
+            if Is_Concurrent_Type (Id) then
+               null;
+            elsif 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;
 
-         if not From_With_Type (T) or else Is_Access_Type (T) then
-            Set_Has_Delayed_Freeze (T);
+         elsif Scope (Etype (Id)) /= Standard_Standard then
+            Derive_Subprograms (Generic_Parent_Type (N), Id);
          end if;
-      end;
+      end if;
 
-      --  Case where T is the full declaration of some private type which has
-      --  been swapped in Defining_Identifier (N).
+      if Is_Private_Type (T)
+        and then Present (Full_View (T))
+      then
+         Conditional_Delay (Id, Full_View (T));
 
-      if T /= Def_Id and then Is_Private_Type (Def_Id) then
-         Process_Full_View (N, T, Def_Id);
+      --  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.
 
-         --  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.
+      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;
 
-         --  Also, we want to kill Has_Pragma_Unreferenced temporarily here
-         --  since we don't want a complaint about the full type being an
-         --  unwanted reference to the private type
+      --  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.
 
-         declare
-            B : constant Boolean := Has_Pragma_Unreferenced (T);
-         begin
-            Set_Has_Pragma_Unreferenced (T, False);
-            Generate_Reference (T, T, 'c');
-            Set_Has_Pragma_Unreferenced (T, B);
-         end;
+      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))));
 
-         Set_Completion_Referenced (Def_Id);
+         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???
 
-      --  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).
+            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 : constant Entity_Id :=
+                                 Etype
+                                   (First_Index (Etype
+                                     (Subtype_Mark (Subtype_Indication (N)))));
+               begin
+                  R_Checks :=
+                    Get_Range_Checks
+                      (Scalar_Range (Etype (First_Index (Id))),
+                       Target_Typ,
+                       Etype (First_Index (Id)),
+                       Defining_Identifier (N));
 
-      elsif Ekind (Prev) = E_Incomplete_Type then
-         Process_Incomplete_Dependents (N, T, Prev);
-         Generate_Reference (Prev, Def_Id, 'c');
-         Set_Completion_Referenced (Def_Id);
+                  Insert_Range_Checks
+                    (R_Checks,
+                     N,
+                     Target_Typ,
+                     Sloc (Defining_Identifier (N)));
+               end;
+            end if;
+         end if;
+      end if;
 
-      --  If not private type or incomplete type completion, this is a real
-      --  definition of a new entity, so record it.
+      Set_Optimize_Alignment_Flags (Id);
+      Check_Eliminated (Id);
 
-      else
-         Generate_Definition (Def_Id);
-      end if;
+      <<Leave>> Analyze_Aspect_Specifications (N, Id, AS);
+   end Analyze_Subtype_Declaration;
 
-      if Chars (Scope (Def_Id)) = Name_System
-        and then Chars (Def_Id) = Name_Address
-        and then Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (N)))
-      then
-         Set_Is_Descendent_Of_Address (Def_Id);
-         Set_Is_Descendent_Of_Address (Base_Type (Def_Id));
-         Set_Is_Descendent_Of_Address (Prev);
-      end if;
+   --------------------------------
+   -- Analyze_Subtype_Indication --
+   --------------------------------
 
-      Set_Optimize_Alignment_Flags (Def_Id);
-      Check_Eliminated (Def_Id);
-   end Analyze_Type_Declaration;
+   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);
+
+      if R /= Error then
+         Analyze (R);
+         Set_Etype (N, Etype (R));
+         Resolve (R, Entity (T));
+      else
+         Set_Error_Posted (R);
+         Set_Error_Posted (T);
+      end if;
+   end Analyze_Subtype_Indication;
 
    --------------------------
    -- Analyze_Variant_Part --
Index: sem_ch3.ads
===================================================================
--- sem_ch3.ads	(revision 165256)
+++ sem_ch3.ads	(working copy)
@@ -28,6 +28,7 @@  with Types;  use Types;
 
 package Sem_Ch3 is
    procedure Analyze_Component_Declaration         (N : Node_Id);
+   procedure Analyze_Full_Type_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);
@@ -35,7 +36,6 @@  package Sem_Ch3 is
    procedure Analyze_Others_Choice                 (N : Node_Id);
    procedure Analyze_Private_Extension_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);
 
    procedure Analyze_Subtype_Declaration
Index: sinfo.adb
===================================================================
--- sinfo.adb	(revision 165289)
+++ sinfo.adb	(working copy)
@@ -32,10 +32,8 @@ 
 pragma Style_Checks (All_Checks);
 --  No subprogram ordering check, due to logical grouping
 
-with Atree;  use Atree;
-with Nlists; use Nlists;
-
-with GNAT.HTable;
+with Aspects; use Aspects;
+with Atree;   use Atree;
 
 package body Sinfo is
 
@@ -56,30 +54,6 @@  package body Sinfo is
    NT : Nodes.Table_Ptr renames Nodes.Table;
    --  A short hand abbreviation, useful for the debugging checks
 
-   ------------------------------------------
-   -- Hash Table for Aspect Specifications --
-   ------------------------------------------
-
-   type Hash_Range is range 0 .. 510;
-   --  Size of hash table headers
-
-   function AS_Hash (F : Node_Id) return Hash_Range;
-   --  Hash function for hash table
-
-   function AS_Hash (F : Node_Id) return Hash_Range is
-   begin
-      return Hash_Range (F mod 511);
-   end AS_Hash;
-
-   package Aspect_Specifications_Hash_Table is new
-     GNAT.HTable.Simple_HTable
-       (Header_Num => Hash_Range,
-        Element    => List_Id,
-        No_Element => No_List,
-        Key        => Node_Id,
-        Hash       => AS_Hash,
-        Equal      => "=");
-
    ----------------------------
    -- Field Access Functions --
    ----------------------------
@@ -282,6 +256,14 @@  package body Sinfo is
       return Node3 (N);
    end Array_Aggregate;
 
+   function Aspect_Cancel
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Pragma);
+      return Flag11 (N);
+   end Aspect_Cancel;
+
    function Assignment_OK
       (N : Node_Id) return Boolean is
    begin
@@ -1251,14 +1233,6 @@  package body Sinfo is
       return List1 (N);
    end Expressions;
 
-   function First_Aspect
-      (N : Node_Id) return Boolean is
-   begin
-      pragma Assert (False
-        or else NT (N).Nkind = N_Aspect_Specification);
-      return Flag4 (N);
-   end First_Aspect;
-
    function First_Bit
       (N : Node_Id) return Node_Id is
    begin
@@ -1333,6 +1307,15 @@  package body Sinfo is
       return Flag5 (N);
    end Forwards_OK;
 
+   function From_Aspect_Specification
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Attribute_Definition_Clause
+        or else NT (N).Nkind = N_Pragma);
+      return Flag13 (N);
+   end From_Aspect_Specification;
+
    function From_At_End
       (N : Node_Id) return Boolean is
    begin
@@ -1869,14 +1852,6 @@  package body Sinfo is
       return Node2 (N);
    end Label_Construct;
 
-   function Last_Aspect
-      (N : Node_Id) return Boolean is
-   begin
-      pragma Assert (False
-        or else NT (N).Nkind = N_Aspect_Specification);
-      return Flag5 (N);
-   end Last_Aspect;
-
    function Last_Bit
       (N : Node_Id) return Node_Id is
    begin
@@ -3229,6 +3204,14 @@  package body Sinfo is
       Set_Node3_With_Parent (N, Val);
    end Set_Array_Aggregate;
 
+   procedure Set_Aspect_Cancel
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Pragma);
+      Set_Flag11 (N, Val);
+   end Set_Aspect_Cancel;
+
    procedure Set_Assignment_OK
       (N : Node_Id; Val : Boolean := True) is
    begin
@@ -4189,14 +4172,6 @@  package body Sinfo is
       Set_List1_With_Parent (N, Val);
    end Set_Expressions;
 
-   procedure Set_First_Aspect
-      (N : Node_Id; Val : Boolean := True) is
-   begin
-      pragma Assert (False
-        or else NT (N).Nkind = N_Aspect_Specification);
-      Set_Flag4 (N, Val);
-   end Set_First_Aspect;
-
    procedure Set_First_Bit
       (N : Node_Id; Val : Node_Id) is
    begin
@@ -4271,6 +4246,15 @@  package body Sinfo is
       Set_Flag5 (N, Val);
    end Set_Forwards_OK;
 
+   procedure Set_From_Aspect_Specification
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Attribute_Definition_Clause
+        or else NT (N).Nkind = N_Pragma);
+      Set_Flag13 (N, Val);
+   end Set_From_Aspect_Specification;
+
    procedure Set_From_At_End
       (N : Node_Id; Val : Boolean := True) is
    begin
@@ -4816,14 +4800,6 @@  package body Sinfo is
       Set_Node4_With_Parent (N, Val);
    end Set_Last_Bit;
 
-   procedure Set_Last_Aspect
-      (N : Node_Id; Val : Boolean := True) is
-   begin
-      pragma Assert (False
-        or else NT (N).Nkind = N_Aspect_Specification);
-      Set_Flag5 (N, Val);
-   end Set_Last_Aspect;
-
    procedure Set_Last_Name
       (N : Node_Id; Val : Boolean := True) is
    begin
@@ -6163,65 +6139,4 @@  package body Sinfo is
       return Chars (Pragma_Identifier (N));
    end Pragma_Name;
 
-   -----------------------------------
-   -- Permits_Aspect_Specifications --
-   -----------------------------------
-
-   Has_Aspect_Specifications_Flag : constant array (Node_Kind) of Boolean :=
-     (N_Abstract_Subprogram_Declaration        => True,
-      N_Component_Declaration                  => True,
-      N_Entry_Declaration                      => True,
-      N_Exception_Declaration                  => True,
-      N_Formal_Abstract_Subprogram_Declaration => True,
-      N_Formal_Concrete_Subprogram_Declaration => True,
-      N_Formal_Object_Declaration              => True,
-      N_Formal_Package_Declaration             => True,
-      N_Formal_Type_Declaration                => True,
-      N_Full_Type_Declaration                  => True,
-      N_Function_Instantiation                 => True,
-      N_Generic_Package_Declaration            => True,
-      N_Generic_Subprogram_Declaration         => True,
-      N_Object_Declaration                     => True,
-      N_Package_Declaration                    => True,
-      N_Package_Instantiation                  => True,
-      N_Private_Extension_Declaration          => True,
-      N_Private_Type_Declaration               => True,
-      N_Procedure_Instantiation                => True,
-      N_Protected_Type_Declaration             => True,
-      N_Single_Protected_Declaration           => True,
-      N_Single_Task_Declaration                => True,
-      N_Subprogram_Declaration                 => True,
-      N_Subtype_Declaration                    => True,
-      N_Task_Type_Declaration                  => True,
-      others                                   => False);
-
-   function Permits_Aspect_Specifications (N : Node_Id) return Boolean is
-   begin
-      return Has_Aspect_Specifications_Flag (Nkind (N));
-   end Permits_Aspect_Specifications;
-
-   ---------------------------
-   -- Aspect_Specifications --
-   ---------------------------
-
-   function Aspect_Specifications (N : Node_Id) return List_Id is
-   begin
-      return Aspect_Specifications_Hash_Table.Get (N);
-   end Aspect_Specifications;
-
-   -------------------------------
-   -- Set_Aspect_Specifications --
-   -------------------------------
-
-   procedure Set_Aspect_Specifications (N : Node_Id; L : List_Id) is
-   begin
-      pragma Assert (Permits_Aspect_Specifications (N));
-      pragma Assert (not Has_Aspect_Specifications (N));
-      pragma Assert (L /= No_List);
-
-      Set_Has_Aspect_Specifications (N);
-      Set_Parent (L, N);
-      Aspect_Specifications_Hash_Table.Set (N, L);
-   end Set_Aspect_Specifications;
-
 end Sinfo;
Index: sinfo.ads
===================================================================
--- sinfo.ads	(revision 165279)
+++ sinfo.ads	(working copy)
@@ -455,13 +455,13 @@  package Sinfo is
 
    --  The following flag fields appear in all nodes
 
-   --  Analyzed (Flag1)
+   --  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.
 
-   --  Comes_From_Source (Flag2)
+   --  Comes_From_Source
    --    This flag is set if the node comes directly from an explicit construct
    --    in the source. It is normally on for any nodes built by the scanner or
    --    parser from the source program, with the exception that in a few cases
@@ -475,7 +475,7 @@  package Sinfo is
    --    from the source program (e.g. the allocator built for build-in-place
    --    case), and the Comes_From_Source flag is deliberately set.
 
-   --  Error_Posted (Flag3)
+   --  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
@@ -587,6 +587,14 @@  package Sinfo is
    --    is used for translation of the at end handler into a normal exception
    --    handler.
 
+   --  Aspect_Cancel (Flag11-Sem)
+   --    Processing of aspect specifications typically generates pragmas and
+   --    attribute definition clauses that are inserted into the tree after
+   --    the declaration node to get the desired aspect effect. In the case
+   --    of Boolean aspects that use "=> False" to cancel the effect of an
+   --    aspect (i.e. turn if off), the generated pragma has the Aspect_Cancel
+   --    flag set to indicate that the pragma operates in the opposite sense.
+
    --  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
@@ -1056,6 +1064,12 @@  package Sinfo is
    --    cannot figure it out. If both flags Forwards_OK and Backwards_OK are
    --    set, it means that the front end can assure no overlap of operands.
 
+   --  From_Aspect_Specification (Flag13-Sem)
+   --    Processing of aspect specifications typically results in insertion in
+   --    the tree of corresponding pragma or attribute definition clause nodes.
+   --    These generated nodes have the From_Aspect_Specification flag set to
+   --    indicate that they came from aspect specifications originally.
+
    --  From_At_End (Flag4-Sem)
    --    This flag is set on an N_Raise_Statement node if it corresponds to
    --    the reraise statement generated as the last statement of an AT END
@@ -1996,11 +2010,13 @@  package Sinfo is
       --  Sloc points to PRAGMA
       --  Next_Pragma (Node1-Sem)
       --  Pragma_Argument_Associations (List2) (set to No_List if none)
-      --  Debug_Statement (Node3) (set to Empty if not Debug, Assert)
+      --  Debug_Statement (Node3) (set to Empty if not Debug)
       --  Pragma_Identifier (Node4)
       --  Next_Rep_Item (Node5-Sem)
       --  Pragma_Enabled (Flag5-Sem)
+      --  From_Aspect_Specification (Flag13-Sem)
       --  Import_Interface_Present (Flag16-Sem)
+      --  Aspect_Cancel (Flag11-Sem)
 
       --  Note: we should have a section on what pragmas are passed on to
       --  the back end to be processed. This section should note that pragma
@@ -2010,7 +2026,12 @@  package Sinfo is
       --  Note: a utility function Pragma_Name may be applied to pragma nodes
       --  to conveniently obtain the Chars field of the Pragma_Identifier.
 
-      --------------------------------------
+      --  Note: if From_Aspect_Specification is set, then Sloc points to the
+      --  aspect name, as does the Pragma_Identifier. In this case if the
+      --  pragma has a local name argument (such as pragma Inline), it is
+      --  resolved to point to the specific entity affected by the pragma.
+
+   --------------------------------------
       -- 2.8  Pragma Argument Association --
       --------------------------------------
 
@@ -2818,7 +2839,7 @@  package Sinfo is
 
       --  COMPONENT_DECLARATION ::=
       --    DEFINING_IDENTIFIER_LIST : COMPONENT_DEFINITION
-      --      [:= DEFAULT_EXPRESSION]
+      --      [:= 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
@@ -6395,30 +6416,48 @@  package Sinfo is
       --  Next_Rep_Item (Node5-Sem)
       --  From_At_Mod (Flag4-Sem)
       --  Check_Address_Alignment (Flag11-Sem)
+      --  From_Aspect_Specification (Flag13-Sem)
       --  Address_Warning_Posted (Flag18-Sem)
 
-      ----------------------------------
-      -- 13.3.1  Aspect Specification --
-      ----------------------------------
+      --  Note: if From_Aspect_Specification is set, then Sloc points to the
+      --  aspect name, and Entity is resolved already to reference the entity
+      --  to which the aspect applies.
+
+      -----------------------------------
+      -- 13.3.1  Aspect Specifications --
+      -----------------------------------
+
+      --  We modify the RM grammar here, the RM grammar is:
+
+      --     ASPECT_SPECIFICATION ::=
+      --       with ASPECT_MARK [=> ASPECT_DEFINITION] {.
+      --            ASPECT_MARK [=> ASPECT_DEFINITION] }
+
+      --     ASPECT_MARK ::= aspect_IDENTIFIER['Class]
+
+      --     ASPECT_DEFINITION ::= NAME | EXPRESSION
+
+      --  That's inconvenient, since there is no non-terminal name for a single
+      --  entry in the list of aspects. So we use this grammar instead:
+
+      --     ASPECT_SPECIFICATIONS ::=
+      --       with ASPECT_SPECIFICATION {, ASPECT_SPECIFICATION};
 
-      --  ASPECT_SPECIFICATION ::=
-      --    with ASPECT_MARK [=> ASPECT_DEFINITION] {.
-      --         ASPECT_MARK [=> ASPECT_DEFINITION] }
+      --     ASPECT_SPECIFICATION =>
+      --       ASPECT_MARK [=> ASPECT_DEFINITION]
 
-      --  ASPECT_MARK ::= aspect_IDENTIFIER['Class]
+      --     ASPECT_MARK ::= aspect_IDENTIFIER['Class]
 
-      --  ASPECT_DEFINITION ::= NAME | EXPRESSION
+      --     ASPECT_DEFINITION ::= NAME | EXPRESSION
 
-      --  See separate section "Handling of Aspect Specifications" for details
-      --  on the incorporation of these nodes into the tree, and association
-      --  with the related declaration node.
+      --  See separate package Aspects for details on the incorporation of
+      --  these nodes into the tree, and how aspect specifications for a given
+      --  declaration node are associated with that node.
 
       --  N_Aspect_Specification
       --  Sloc points to aspect identifier
       --  Identifier (Node1) aspect identifier
       --  Expression (Node3) Aspect_Definition (set to Empty if none)
-      --  First_Aspect (Flag4) Set for first aspect for a declaration
-      --  Last_Aspect (Flag5) Set for last aspect for a declaration
       --  Class_Present (Flag6) Set if 'Class present
 
       --  Note: Aspect_Specification is an Ada 2012 feature
@@ -7900,6 +7939,9 @@  package Sinfo is
    function Array_Aggregate
      (N : Node_Id) return Node_Id;    -- Node3
 
+   function Aspect_Cancel
+     (N : Node_Id) return Boolean;    -- Flag11
+
    function Assignment_OK
      (N : Node_Id) return Boolean;    -- Flag15
 
@@ -8197,9 +8239,6 @@  package Sinfo is
    function Expressions
      (N : Node_Id) return List_Id;    -- List1
 
-   function First_Aspect
-     (N : Node_Id) return Boolean;    -- Flag4
-
    function First_Bit
      (N : Node_Id) return Node_Id;    -- Node3
 
@@ -8227,6 +8266,9 @@  package Sinfo is
    function Forwards_OK
      (N : Node_Id) return Boolean;    -- Flag5
 
+   function From_Aspect_Specification
+     (N : Node_Id) return Boolean;    -- Flag13
+
    function From_At_End
      (N : Node_Id) return Boolean;    -- Flag4
 
@@ -8416,9 +8458,6 @@  package Sinfo is
    function Left_Opnd
      (N : Node_Id) return Node_Id;    -- Node2
 
-   function Last_Aspect
-     (N : Node_Id) return Boolean;    -- Flag5
-
    function Last_Bit
      (N : Node_Id) return Node_Id;    -- Node4
 
@@ -8845,6 +8884,9 @@  package Sinfo is
    procedure Set_Has_Aspect_Specifications
      (N : Node_Id; Val : Boolean := True);    -- Flag3
 
+   procedure Set_Aspect_Cancel
+     (N : Node_Id; Val : Boolean := True);    -- Flag11
+
    procedure Set_Assignment_OK
      (N : Node_Id; Val : Boolean := True);    -- Flag15
 
@@ -9139,9 +9181,6 @@  package Sinfo is
    procedure Set_Expressions
      (N : Node_Id; Val : List_Id);            -- List1
 
-   procedure Set_First_Aspect
-     (N : Node_Id; Val : Boolean := True);    -- Flag4
-
    procedure Set_First_Bit
      (N : Node_Id; Val : Node_Id);            -- Node3
 
@@ -9172,6 +9211,9 @@  package Sinfo is
    procedure Set_From_At_Mod
      (N : Node_Id; Val : Boolean := True);    -- Flag4
 
+   procedure Set_From_Aspect_Specification
+     (N : Node_Id; Val : Boolean := True);    -- Flag13
+
    procedure Set_From_At_End
      (N : Node_Id; Val : Boolean := True);    -- Flag4
 
@@ -9349,9 +9391,6 @@  package Sinfo is
    procedure Set_Kill_Range_Check
      (N : Node_Id; Val : Boolean := True);    -- Flag11
 
-   procedure Set_Last_Aspect
-     (N : Node_Id; Val : Boolean := True);    -- Flag5
-
    procedure Set_Last_Bit
      (N : Node_Id; Val : Node_Id);            -- Node4
 
@@ -11417,45 +11456,6 @@  package Sinfo is
         4 => False,   --  unused
         5 => False)); --  unused
 
-   ---------------------------------------
-   -- Handling of Aspect Specifications --
-   ---------------------------------------
-
-   --  Several kinds of declaration node permit aspect specifications in Ada
-   --  2012 mode. If there was room in all these declaration nodes, we could
-   --  just have a field Aspect_Specifications pointing to a list of nodes
-   --  for the aspects (N_Aspect_Specification nodes). But there isn't room,
-   --  so we adopt a different approach.
-
-   --  The following subprograms provide access to a specialized interface
-   --  implemented internally with a hash table in the body, that provides
-   --  access to aspect specifications.
-
-   function Permits_Aspect_Specifications (N : Node_Id) return Boolean;
-   --  Returns True if the node N is a declaration node that permits aspect
-   --  specifications. All such nodes have the Has_Aspect_Specifications
-   --  flag defined. Returns False for all other nodes.
-
-   function Aspect_Specifications (N : Node_Id) return List_Id;
-   --  Given a node N, returns the list of N_Aspect_Specification nodes that
-   --  are attached to this declaration node. If the node is in the class of
-   --  declaration nodes that permit aspect specifications, as defined by the
-   --  predicate above, and if their Has_Aspect_Specifications flag is set to
-   --  True, then this will always be a non-empty list. If this flag is set to
-   --  False, or the node is not in the declaration class permitting aspect
-   --  specifications, then No_List is returned.
-
-   procedure Set_Aspect_Specifications (N : Node_Id; L : List_Id);
-   --  The node N must be in the class of declaration nodes that permit aspect
-   --  specifications and the Has_Aspect_Specifications flag must be False on
-   --  entry. L must be a non-empty list of N_Aspect_Specification nodes. This
-   --  procedure sets the Has_Aspect_Specifications flag to True, and makes an
-   --  entry that can be retrieved by a subsequent Aspect_Specifications call.
-   --  The parent of list L is set to reference the declaration node N. It is
-   --  an error to call this procedure with a node that does not permit aspect
-   --  specifications, or a node that has its Has_Aspect_Specifications flag
-   --  set True on entry, or with L being an empty list or No_List.
-
    --------------------
    -- Inline Pragmas --
    --------------------
@@ -11481,6 +11481,7 @@  package Sinfo is
    pragma Inline (Alternatives);
    pragma Inline (Ancestor_Part);
    pragma Inline (Array_Aggregate);
+   pragma Inline (Aspect_Cancel);
    pragma Inline (Assignment_OK);
    pragma Inline (Associated_Node);
    pragma Inline (At_End_Proc);
@@ -11580,7 +11581,6 @@  package Sinfo is
    pragma Inline (Explicit_Generic_Actual_Parameter);
    pragma Inline (Expression);
    pragma Inline (Expressions);
-   pragma Inline (First_Aspect);
    pragma Inline (First_Bit);
    pragma Inline (First_Inlined_Subprogram);
    pragma Inline (First_Name);
@@ -11590,6 +11590,7 @@  package Sinfo is
    pragma Inline (Float_Truncate);
    pragma Inline (Formal_Type_Definition);
    pragma Inline (Forwards_OK);
+   pragma Inline (From_Aspect_Specification);
    pragma Inline (From_At_End);
    pragma Inline (From_At_Mod);
    pragma Inline (From_Default);
@@ -11651,7 +11652,6 @@  package Sinfo is
    pragma Inline (Iteration_Scheme);
    pragma Inline (Itype);
    pragma Inline (Kill_Range_Check);
-   pragma Inline (Last_Aspect);
    pragma Inline (Last_Bit);
    pragma Inline (Last_Name);
    pragma Inline (Library_Unit);
@@ -11792,6 +11792,7 @@  package Sinfo is
    pragma Inline (Set_Alternatives);
    pragma Inline (Set_Ancestor_Part);
    pragma Inline (Set_Array_Aggregate);
+   pragma Inline (Set_Aspect_Cancel);
    pragma Inline (Set_Assignment_OK);
    pragma Inline (Set_Associated_Node);
    pragma Inline (Set_At_End_Proc);
@@ -11890,7 +11891,6 @@  package Sinfo is
    pragma Inline (Set_Explicit_Generic_Actual_Parameter);
    pragma Inline (Set_Expression);
    pragma Inline (Set_Expressions);
-   pragma Inline (Set_First_Aspect);
    pragma Inline (Set_First_Bit);
    pragma Inline (Set_First_Inlined_Subprogram);
    pragma Inline (Set_First_Name);
@@ -11900,6 +11900,7 @@  package Sinfo is
    pragma Inline (Set_Float_Truncate);
    pragma Inline (Set_Formal_Type_Definition);
    pragma Inline (Set_Forwards_OK);
+   pragma Inline (Set_From_Aspect_Specification);
    pragma Inline (Set_From_At_End);
    pragma Inline (Set_From_At_Mod);
    pragma Inline (Set_From_Default);
@@ -11961,7 +11962,6 @@  package Sinfo is
    pragma Inline (Set_Iteration_Scheme);
    pragma Inline (Set_Itype);
    pragma Inline (Set_Kill_Range_Check);
-   pragma Inline (Set_Last_Aspect);
    pragma Inline (Set_Last_Bit);
    pragma Inline (Set_Last_Name);
    pragma Inline (Set_Library_Unit);
Index: sem_ch7.adb
===================================================================
--- sem_ch7.adb	(revision 165256)
+++ sem_ch7.adb	(working copy)
@@ -28,6 +28,7 @@ 
 --  handling of private and full declarations, and the construction of dispatch
 --  tables for tagged types.
 
+with Aspects;  use Aspects;
 with Atree;    use Atree;
 with Debug;    use Debug;
 with Einfo;    use Einfo;
@@ -51,6 +52,7 @@  with Sem_Ch6;  use Sem_Ch6;
 with Sem_Ch8;  use Sem_Ch8;
 with Sem_Ch10; use Sem_Ch10;
 with Sem_Ch12; use Sem_Ch12;
+with Sem_Ch13; use Sem_Ch13;
 with Sem_Disp; use Sem_Disp;
 with Sem_Eval; use Sem_Eval;
 with Sem_Prag; use Sem_Prag;
@@ -749,6 +751,7 @@  package body Sem_Ch7 is
 
    procedure Analyze_Package_Declaration (N : Node_Id) is
       Id : constant Node_Id := Defining_Entity (N);
+      AS : constant List_Id := Aspect_Specifications (N);
 
       PF : Boolean;
       --  True when in the context of a declared pure library unit
@@ -768,7 +771,7 @@  package body Sem_Ch7 is
       --     package Pkg is ...
 
       if From_With_Type (Id) then
-         return;
+         goto Leave;
       end if;
 
       if Debug_Flag_C then
@@ -842,6 +845,8 @@  package body Sem_Ch7 is
          Write_Location (Sloc (N));
          Write_Eol;
       end if;
+
+      <<Leave>> Analyze_Aspect_Specifications (N, Id, AS);
    end Analyze_Package_Declaration;
 
    -----------------------------------
@@ -1412,6 +1417,7 @@  package body Sem_Ch7 is
    procedure Analyze_Private_Type_Declaration (N : Node_Id) is
       PF : constant Boolean   := Is_Pure (Enclosing_Lib_Unit_Entity);
       Id : constant Entity_Id := Defining_Identifier (N);
+      AS : constant List_Id   := Aspect_Specifications (N);
 
    begin
       Generate_Definition (Id);
@@ -1426,6 +1432,7 @@  package body Sem_Ch7 is
 
       New_Private_Type (N, Id, N);
       Set_Depends_On_Private (Id);
+      Analyze_Aspect_Specifications (N, Id, AS);
    end Analyze_Private_Type_Declaration;
 
    ----------------------------------
Index: par-ch13.adb
===================================================================
--- par-ch13.adb	(revision 165256)
+++ par-ch13.adb	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2007, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2010, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -35,6 +35,91 @@  package body Ch13 is
    function P_Component_Clause return Node_Id;
    function P_Mod_Clause return Node_Id;
 
+   -----------------------------------
+   -- Aspect_Specifications_Present --
+   -----------------------------------
+
+   function Aspect_Specifications_Present return Boolean is
+      Scan_State : Saved_Scan_State;
+      Result     : Boolean;
+
+   begin
+      Save_Scan_State (Scan_State);
+
+      --  If we have a semicolon, test for semicolon followed by Aspect
+      --  Specifications, in which case we decide the semicolon is accidental.
+
+      if Token = Tok_Semicolon then
+         Scan; -- past semicolon
+
+         if Aspect_Specifications_Present then
+            Error_Msg_SP ("|extra "";"" ignored");
+            return True;
+
+         else
+            Restore_Scan_State (Scan_State);
+            return False;
+         end if;
+      end if;
+
+      --  Definitely must have WITH to consider aspect specs to be present
+
+      if Token /= Tok_With then
+         return False;
+      end if;
+
+      --  Have a WITH, see if it looks like an aspect specification
+
+      Save_Scan_State (Scan_State);
+      Scan; -- past WITH
+
+      --  If no identifier, then consider that we definitely do not have an
+      --  aspect specification.
+
+      if Token /= Tok_Identifier then
+         Result := False;
+
+      --  In Ada 2012 mode, we are less strict, and we consider that we have
+      --  an aspect specification if the identifier is an aspect name (even if
+      --  not followed by =>) or the identifier is not an aspect name but is
+      --  followed by =>. P_Aspect_Specifications will generate messages if the
+      --  aspect specification is ill-formed.
+
+      elsif Ada_Version >= Ada_2012 then
+         if Get_Aspect_Id (Token_Name) /= No_Aspect then
+            Result := True;
+         else
+            Scan; -- past identifier
+            Result := Token = Tok_Arrow;
+         end if;
+
+      --  If earlier than Ada 2012, check for valid aspect identifier followed
+      --  by an arrow, and consider that this is still an aspect specification
+      --  so we give an appropriate message.
+
+      else
+         if Get_Aspect_Id (Token_Name) = No_Aspect then
+            Result := False;
+
+         else
+            Scan; -- past aspect name
+
+            if Token /= Tok_Arrow then
+               Result := False;
+
+            else
+               Restore_Scan_State (Scan_State);
+               Error_Msg_SC ("|aspect specification is an Ada 2012 feature");
+               Error_Msg_SC ("\|unit must be compiled with -gnat2012 switch");
+               return True;
+            end if;
+         end if;
+      end if;
+
+      Restore_Scan_State (Scan_State);
+      return Result;
+   end Aspect_Specifications_Present;
+
    --------------------------------------------
    -- 13.1  Representation Clause (also I.7) --
    --------------------------------------------
@@ -274,6 +359,163 @@  package body Ch13 is
 
    --  Parsed by P_Representation_Clause (13.1)
 
+   ------------------------------
+   -- 13.1  Aspect Specifation --
+   ------------------------------
+
+   --  ASPECT_SPECIFICATION ::=
+   --    with ASPECT_MARK [=> ASPECT_DEFINITION] {.
+   --         ASPECT_MARK [=> ASPECT_DEFINITION] }
+
+   --  ASPECT_MARK ::= aspect_IDENTIFIER['Class]
+
+   --  ASPECT_DEFINITION ::= NAME | EXPRESSION
+
+   --  Error recovery: cannot raise Error_Resync
+
+   procedure P_Aspect_Specifications (Decl : Node_Id) is
+      Aspects : List_Id;
+      Aspect  : Node_Id;
+      A_Id    : Aspect_Id;
+      OK      : Boolean;
+
+   begin
+      --  Check if aspect specification present
+
+      if not Aspect_Specifications_Present then
+         T_Semicolon;
+         return;
+      end if;
+
+      --  Aspect Specification is present
+
+      Scan; -- past WITH
+
+      --  Here we have an aspect specification to scan, note that we don;t
+      --  set the flag till later, because it may turn out that we have no
+      --  valid aspects in the list.
+
+      Aspects := Empty_List;
+      loop
+         OK := True;
+
+         if Token /= Tok_Identifier then
+            Error_Msg_SC ("aspect identifier expected");
+            Resync_Past_Semicolon;
+            return;
+         end if;
+
+         --  We have an identifier (which should be an aspect identifier)
+
+         Aspect := Token_Node;
+         A_Id := Get_Aspect_Id (Token_Name);
+         Aspect :=
+           Make_Aspect_Specification (Sloc (Aspect),
+             Identifier => Token_Node);
+
+         --  No valid aspect identifier present
+
+         if A_Id = No_Aspect then
+            Error_Msg_SC ("aspect identifier expected");
+
+            if Token = Tok_Apostrophe then
+               Scan; -- past '
+               Scan; -- past presumably CLASS
+            end if;
+
+            if Token = Tok_Arrow then
+               Scan; -- Past arrow
+               Set_Expression (Aspect, P_Expression);
+               OK := False;
+
+            elsif Token = Tok_Comma then
+               OK := False;
+
+            else
+               Resync_Past_Semicolon;
+               return;
+            end if;
+
+         --  OK aspect scanned
+
+         else
+            Scan; -- past identifier
+
+            --  Check for 'Class present
+
+            if Token = Tok_Apostrophe then
+               if not Class_Aspect_OK (A_Id) then
+                  Error_Msg_Node_1 := Identifier (Aspect);
+                  Error_Msg_SC ("aspect& does not permit attribute here");
+                  Scan; -- past apostophe
+                  Scan; -- past presumed CLASS
+                  OK := False;
+
+               else
+                  Scan; -- past apostrophe
+
+                  if Token /= Tok_Identifier
+                    or else Token_Name /= Name_Class
+                  then
+                     Error_Msg_SC ("Class attribute expected here");
+                     OK := False;
+
+                     if Token = Tok_Identifier then
+                        Scan; -- past identifier not CLASS
+                     end if;
+                  end if;
+               end if;
+            end if;
+
+            --  Test case of missing aspect definition
+
+            if Token = Tok_Comma or else Token = Tok_Semicolon then
+               if Aspect_Argument (A_Id) /= Optional then
+                  Error_Msg_Node_1 := Aspect;
+                  Error_Msg_AP ("aspect& requires an aspect definition");
+                  OK := False;
+               end if;
+
+            --  Here we have an aspect definition
+
+            else
+               if Token = Tok_Arrow then
+                  Scan; -- past arrow
+               else
+                  T_Arrow;
+                  OK := False;
+               end if;
+
+               if Aspect_Argument (A_Id) = Name then
+                  Set_Expression (Aspect, P_Name);
+               else
+                  Set_Expression (Aspect, P_Expression);
+               end if;
+            end if;
+
+            --  If OK clause scanned, add it to the list
+
+            if OK then
+               Append (Aspect, Aspects);
+            end if;
+
+            if Token = Tok_Comma then
+               Scan; -- past comma
+            else
+               T_Semicolon;
+               exit;
+            end if;
+         end if;
+      end loop;
+
+      --  If aspects scanned, store them
+
+      if Is_Non_Empty_List (Aspects) then
+         Set_Parent (Aspects, Decl);
+         Set_Aspect_Specifications (Decl, Aspects);
+      end if;
+   end P_Aspect_Specifications;
+
    ---------------------------------------------
    -- 13.4  Enumeration Representation Clause --
    ---------------------------------------------
Index: sem_ch9.adb
===================================================================
--- sem_ch9.adb	(revision 165283)
+++ sem_ch9.adb	(working copy)
@@ -23,6 +23,7 @@ 
 --                                                                          --
 ------------------------------------------------------------------------------
 
+with Aspects;  use Aspects;
 with Atree;    use Atree;
 with Checks;   use Checks;
 with Einfo;    use Einfo;
@@ -44,6 +45,7 @@  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_Ch13; use Sem_Ch13;
 with Sem_Eval; use Sem_Eval;
 with Sem_Res;  use Sem_Res;
 with Sem_Type; use Sem_Type;
@@ -873,6 +875,7 @@  package body Sem_Ch9 is
       D_Sdef  : constant Node_Id   := Discrete_Subtype_Definition (N);
       Def_Id  : constant Entity_Id := Defining_Identifier (N);
       Formals : constant List_Id   := Parameter_Specifications (N);
+      AS      : constant List_Id   := Aspect_Specifications (N);
 
    begin
       Generate_Definition (Def_Id);
@@ -904,6 +907,7 @@  package body Sem_Ch9 is
       end if;
 
       Generate_Reference_To_Formals (Def_Id);
+      Analyze_Aspect_Specifications (N, Def_Id, AS);
    end Analyze_Entry_Declaration;
 
    ---------------------------------------
@@ -1122,19 +1126,20 @@  package body Sem_Ch9 is
       Process_End_Label (N, 'e', Current_Scope);
    end Analyze_Protected_Definition;
 
-   ----------------------------
-   -- Analyze_Protected_Type --
-   ----------------------------
+   ----------------------------------------
+   -- Analyze_Protected_Type_Declaration --
+   ----------------------------------------
 
-   procedure Analyze_Protected_Type (N : Node_Id) is
+   procedure Analyze_Protected_Type_Declaration (N : Node_Id) is
       Def_Id : constant Entity_Id := Defining_Identifier (N);
+      AS     : constant List_Id   := Aspect_Specifications (N);
       E      : Entity_Id;
       T      : Entity_Id;
 
    begin
       if No_Run_Time_Mode then
          Error_Msg_CRT ("protected type", N);
-         return;
+         goto Leave;
       end if;
 
       Tasking_Used := True;
@@ -1254,7 +1259,9 @@  package body Sem_Ch9 is
             Process_Full_View (N, T, Def_Id);
          end if;
       end if;
-   end Analyze_Protected_Type;
+
+      <<Leave>> Analyze_Aspect_Specifications (N, Def_Id, AS);
+   end Analyze_Protected_Type_Declaration;
 
    ---------------------
    -- Analyze_Requeue --
@@ -1651,13 +1658,14 @@  package body Sem_Ch9 is
       end if;
    end Analyze_Selective_Accept;
 
-   ------------------------------
-   -- Analyze_Single_Protected --
-   ------------------------------
+   ------------------------------------------
+   -- Analyze_Single_Protected_Declaration --
+   ------------------------------------------
 
-   procedure Analyze_Single_Protected (N : Node_Id) is
+   procedure Analyze_Single_Protected_Declaration (N : Node_Id) is
       Loc    : constant Source_Ptr := Sloc (N);
       Id     : constant Node_Id    := Defining_Identifier (N);
+      AS     : constant List_Id    := Aspect_Specifications (N);
       T      : Entity_Id;
       T_Decl : Node_Id;
       O_Decl : Node_Id;
@@ -1704,16 +1712,18 @@  package body Sem_Ch9 is
       --  procedure directly. Otherwise the node would be expanded twice, with
       --  disastrous result.
 
-      Analyze_Protected_Type (N);
-   end Analyze_Single_Protected;
-
-   -------------------------
-   -- Analyze_Single_Task --
-   -------------------------
+      Analyze_Protected_Type_Declaration (N);
+      Analyze_Aspect_Specifications (N, Id, AS);
+   end Analyze_Single_Protected_Declaration;
+
+   -------------------------------------
+   -- Analyze_Single_Task_Declaration --
+   -------------------------------------
 
-   procedure Analyze_Single_Task (N : Node_Id) is
+   procedure Analyze_Single_Task_Declaration (N : Node_Id) is
       Loc    : constant Source_Ptr := Sloc (N);
       Id     : constant Node_Id    := Defining_Identifier (N);
+      AS     : constant List_Id    := Aspect_Specifications (N);
       T      : Entity_Id;
       T_Decl : Node_Id;
       O_Decl : Node_Id;
@@ -1768,8 +1778,9 @@  package body Sem_Ch9 is
       --  procedure directly. Otherwise the node would be expanded twice, with
       --  disastrous result.
 
-      Analyze_Task_Type (N);
-   end Analyze_Single_Task;
+      Analyze_Task_Type_Declaration (N);
+      Analyze_Aspect_Specifications (N, Id, AS);
+   end Analyze_Single_Task_Declaration;
 
    -----------------------
    -- Analyze_Task_Body --
@@ -1935,12 +1946,13 @@  package body Sem_Ch9 is
       Process_End_Label (N, 'e', Current_Scope);
    end Analyze_Task_Definition;
 
-   -----------------------
-   -- Analyze_Task_Type --
-   -----------------------
+   -----------------------------------
+   -- Analyze_Task_Type_Declaration --
+   -----------------------------------
 
-   procedure Analyze_Task_Type (N : Node_Id) is
+   procedure Analyze_Task_Type_Declaration (N : Node_Id) is
       Def_Id : constant Entity_Id := Defining_Identifier (N);
+      AS     : constant List_Id   := Aspect_Specifications (N);
       T      : Entity_Id;
 
    begin
@@ -2038,7 +2050,9 @@  package body Sem_Ch9 is
             Process_Full_View (N, T, Def_Id);
          end if;
       end if;
-   end Analyze_Task_Type;
+
+      Analyze_Aspect_Specifications (N, Def_Id, AS);
+   end Analyze_Task_Type_Declaration;
 
    -----------------------------------
    -- Analyze_Terminate_Alternative --
Index: sem_ch9.ads
===================================================================
--- sem_ch9.ads	(revision 165256)
+++ sem_ch9.ads	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2007, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2010, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -41,14 +41,14 @@  package Sem_Ch9  is
    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_Protected_Type_Declaration         (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_Single_Protected_Declaration       (N : Node_Id);
+   procedure Analyze_Single_Task_Declaration            (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_Task_Type_Declaration              (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);
Index: sem_prag.adb
===================================================================
--- sem_prag.adb	(revision 165296)
+++ sem_prag.adb	(working copy)
@@ -287,6 +287,13 @@  package body Sem_Prag is
       Pname   : constant Name_Id    := Pragma_Name (N);
       Prag_Id : Pragma_Id;
 
+      Sense : constant Boolean := not Aspect_Cancel (N);
+      --  Sense is True if we have the normal case of a pragma that is active
+      --  and turns the corresponding aspect on. It is false only for the case
+      --  of a pragma coming from an aspect which is explicitly turned off by
+      --  using aspect => False. If Sense is False, the effect of the pragma
+      --  is to turn the corresponding aspect off.
+
       Pragma_Exit : exception;
       --  This exception is used to exit pragma processing completely. It is
       --  used when an error is detected, and no further processing is
@@ -410,7 +417,7 @@  package body Sem_Prag is
       procedure Check_Duplicate_Pragma (E : Entity_Id);
       --  Check if a pragma of the same name as the current pragma is already
       --  chained as a rep pragma to the given entity. if so give a message
-      --  about the duplicate, using Error_Pragma so the call does not return.
+      --  about the duplicate, and then raise Pragma_Exit so does not return.
 
       procedure Check_Duplicated_Export_Name (Nam : Node_Id);
       --  Nam is an N_String_Literal node containing the external name set by
@@ -562,6 +569,14 @@  package body Sem_Prag is
       --  procedure identified by Name, returns it if it exists, otherwise
       --  errors out and uses Arg as the pragma argument for the message.
 
+      procedure Fix_Error (Msg : in out String);
+      --  This is called prior to issuing an error message. Msg is a string
+      --  which typically contains the substring pragma. If the current pragma
+      --  comes from an aspect, each such "pragma" substring is replaced with
+      --  the characters "aspect", and in addition, if Error_Msg_Name_1 is
+      --  Name_Precondition (resp Name_Postcondition) it is replaced with
+      --  Name_Pre (resp Name_Post).
+
       procedure Gather_Associations
         (Names : Name_List;
          Args  : out Args_List);
@@ -817,10 +832,16 @@  package body Sem_Prag is
 
             else
                Error_Msg_Name_1 := Pname;
-               Flag_Non_Static_Expr
-                 ("argument for pragma% must be a identifier or " &
-                  "static string expression!", Argx);
-               raise Pragma_Exit;
+
+               declare
+                  Msg : String :=
+                          "argument for pragma% must be a identifier or "
+                          & "static string expression!";
+               begin
+                  Fix_Error (Msg);
+                  Flag_Non_Static_Expr (Msg, Argx);
+                  raise Pragma_Exit;
+               end;
             end if;
          end if;
       end Check_Arg_Is_External_Name;
@@ -864,7 +885,7 @@  package body Sem_Prag is
       begin
          Check_Arg_Is_Local_Name (Arg);
 
-         if not Is_Library_Level_Entity (Entity (Expression (Arg)))
+         if not Is_Library_Level_Entity (Entity (Get_Pragma_Arg (Arg)))
            and then Comes_From_Source (N)
          then
             Error_Pragma_Arg
@@ -1033,8 +1054,15 @@  package body Sem_Prag is
 
          else
             Error_Msg_Name_1 := Pname;
-            Flag_Non_Static_Expr
-              ("argument for pragma% must be a static expression!", Argx);
+
+            declare
+               Msg : String :=
+                       "argument for pragma% must be a static expression!";
+            begin
+               Fix_Error (Msg);
+               Flag_Non_Static_Expr (Msg, Argx);
+            end;
+
             raise Pragma_Exit;
          end if;
       end Check_Arg_Is_Static_Expression;
@@ -1208,6 +1236,17 @@  package body Sem_Prag is
          Arg : Node_Id;
 
       begin
+         --  Nothing to do if this pragma comes from an aspect specification,
+         --  since we could not be duplicating a pragma, and we dealt with the
+         --  case of duplicated aspects in Analyze_Aspect_Specifications.
+
+         if From_Aspect_Specification (N) then
+            return;
+         end if;
+
+         --  Otherwise current pragma may duplicate previous pragma or a
+         --  previously given aspect specification for the same pragma.
+
          if Present (P) then
 
             --  Make sure pragma is for this entity, and not for some parent
@@ -1220,7 +1259,13 @@  package body Sem_Prag is
             then
                Error_Msg_Name_1 := Pname;
                Error_Msg_Sloc := Sloc (P);
-               Error_Msg_NE ("pragma% for & duplicates one#", N, E);
+
+               if From_Aspect_Specification (P) then
+                  Error_Msg_NE ("aspect% for & previously specified#", N, E);
+               else
+                  Error_Msg_NE ("pragma% for & duplicates pragma#", N, E);
+               end if;
+
                raise Pragma_Exit;
             end if;
          end if;
@@ -1301,7 +1346,7 @@  package body Sem_Prag is
       ---------------------------------------
 
       procedure Check_Interrupt_Or_Attach_Handler is
-         Arg1_X : constant Node_Id := Expression (Arg1);
+         Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1);
          Handler_Proc, Proc_Scope : Entity_Id;
 
       begin
@@ -1402,7 +1447,9 @@  package body Sem_Prag is
 
       procedure Check_No_Identifier (Arg : Node_Id) is
       begin
-         if Chars (Arg) /= No_Name then
+         if Nkind (Arg) = N_Pragma_Argument_Association
+           and then Chars (Arg) /= No_Name
+         then
             Error_Pragma_Arg_Ident
               ("pragma% does not permit identifier& here", Arg);
          end if;
@@ -1706,7 +1753,7 @@  package body Sem_Prag is
                   Unit_Node := Unit (Parent (Parent_Node));
                   Unit_Kind := Nkind (Unit_Node);
 
-                  Analyze (Expression (Arg1));
+                  Analyze (Get_Pragma_Arg (Arg1));
 
                   if Unit_Kind = N_Generic_Subprogram_Declaration
                     or else Unit_Kind = N_Subprogram_Declaration
@@ -1721,7 +1768,7 @@  package body Sem_Prag is
                   end if;
 
                   if Chars (Unit_Name) /=
-                     Chars (Entity (Expression (Arg1)))
+                     Chars (Entity (Get_Pragma_Arg (Arg1)))
                   then
                      Error_Pragma_Arg
                        ("pragma% argument is not current unit name", Arg1);
@@ -1779,9 +1826,9 @@  package body Sem_Prag is
                      Pragma_Misplaced;
 
                   elsif Arg_Count > 0 then
-                     Analyze (Expression (Arg1));
+                     Analyze (Get_Pragma_Arg (Arg1));
 
-                     if Entity (Expression (Arg1)) /= Current_Scope then
+                     if Entity (Get_Pragma_Arg (Arg1)) /= Current_Scope then
                         Error_Pragma_Arg
                           ("name in pragma% must be enclosing unit", Arg1);
                      end if;
@@ -1834,9 +1881,11 @@  package body Sem_Prag is
       ------------------
 
       procedure Error_Pragma (Msg : String) is
+         MsgF : String := Msg;
       begin
          Error_Msg_Name_1 := Pname;
-         Error_Msg_N (Msg, N);
+         Fix_Error (MsgF);
+         Error_Msg_N (MsgF, N);
          raise Pragma_Exit;
       end Error_Pragma;
 
@@ -1845,16 +1894,20 @@  package body Sem_Prag is
       ----------------------
 
       procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id) is
+         MsgF : String := Msg;
       begin
          Error_Msg_Name_1 := Pname;
-         Error_Msg_N (Msg, Get_Pragma_Arg (Arg));
+         Fix_Error (MsgF);
+         Error_Msg_N (MsgF, Get_Pragma_Arg (Arg));
          raise Pragma_Exit;
       end Error_Pragma_Arg;
 
       procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id) is
+         MsgF : String := Msg1;
       begin
          Error_Msg_Name_1 := Pname;
-         Error_Msg_N (Msg1, Get_Pragma_Arg (Arg));
+         Fix_Error (MsgF);
+         Error_Msg_N (MsgF, Get_Pragma_Arg (Arg));
          Error_Pragma_Arg (Msg2, Arg);
       end Error_Pragma_Arg;
 
@@ -1863,9 +1916,11 @@  package body Sem_Prag is
       ----------------------------
 
       procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id) is
+         MsgF : String := Msg;
       begin
          Error_Msg_Name_1 := Pname;
-         Error_Msg_N (Msg, Arg);
+         Fix_Error (MsgF);
+         Error_Msg_N (MsgF, Arg);
          raise Pragma_Exit;
       end Error_Pragma_Arg_Ident;
 
@@ -1874,10 +1929,12 @@  package body Sem_Prag is
       ----------------------
 
       procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id) is
+         MsgF : String := Msg;
       begin
          Error_Msg_Name_1 := Pname;
+         Fix_Error (MsgF);
          Error_Msg_Sloc   := Sloc (Ref);
-         Error_Msg_NE (Msg, N, Ref);
+         Error_Msg_NE (MsgF, N, Ref);
          raise Pragma_Exit;
       end Error_Pragma_Ref;
 
@@ -2004,6 +2061,27 @@  package body Sem_Prag is
          return Proc;
       end Find_Unique_Parameterless_Procedure;
 
+      ---------------
+      -- Fix_Error --
+      ---------------
+
+      procedure Fix_Error (Msg : in out String) is
+      begin
+         if From_Aspect_Specification (N) then
+            for J in Msg'First .. Msg'Last - 5 loop
+               if Msg (J .. J + 5) = "pragma" then
+                  Msg (J .. J + 5) := "aspect";
+               end if;
+            end loop;
+         end if;
+
+         if Error_Msg_Name_1 = Name_Precondition then
+            Error_Msg_Name_1 := Name_Pre;
+         elsif Error_Msg_Name_1 = Name_Postcondition then
+            Error_Msg_Name_1 := Name_Post;
+         end if;
+      end Fix_Error;
+
       -------------------------
       -- Gather_Associations --
       -------------------------
@@ -2032,7 +2110,7 @@  package body Sem_Prag is
          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);
+            Args (Index) := Get_Pragma_Arg (Arg);
             Next (Arg);
          end loop;
 
@@ -2059,7 +2137,7 @@  package body Sem_Prag is
                         Error_Pragma_Arg
                           ("duplicate argument association for pragma%", Arg);
                      else
-                        Args (Index) := Expression (Arg);
+                        Args (Index) := Get_Pragma_Arg (Arg);
                         exit;
                      end if;
                   end if;
@@ -2240,9 +2318,9 @@  package body Sem_Prag is
 
          procedure Set_Atomic (E : Entity_Id) is
          begin
-            Set_Is_Atomic (E);
+            Set_Is_Atomic (E, Sense);
 
-            if not Has_Alignment_Clause (E) then
+            if Sense and then not Has_Alignment_Clause (E) then
                Set_Alignment (E, Uint_0);
             end if;
          end Set_Atomic;
@@ -2254,7 +2332,7 @@  package body Sem_Prag is
          Check_No_Identifiers;
          Check_Arg_Count (1);
          Check_Arg_Is_Local_Name (Arg1);
-         E_Id := Expression (Arg1);
+         E_Id := Get_Pragma_Arg (Arg1);
 
          if Etype (E_Id) = Any_Type then
             return;
@@ -2289,11 +2367,11 @@  package body Sem_Prag is
             --  Attribute belongs on the base type. If the view of the type is
             --  currently private, it also belongs on the underlying type.
 
-            Set_Is_Volatile (Base_Type (E));
-            Set_Is_Volatile (Underlying_Type (E));
+            Set_Is_Volatile (Base_Type (E), Sense);
+            Set_Is_Volatile (Underlying_Type (E), Sense);
 
-            Set_Treat_As_Volatile (E);
-            Set_Treat_As_Volatile (Underlying_Type (E));
+            Set_Treat_As_Volatile (E, Sense);
+            Set_Treat_As_Volatile (Underlying_Type (E), Sense);
 
          elsif K = N_Object_Declaration
            or else (K = N_Component_Declaration
@@ -2304,7 +2382,7 @@  package body Sem_Prag is
             end if;
 
             if Prag_Id /= Pragma_Volatile then
-               Set_Is_Atomic (E);
+               Set_Is_Atomic (E, Sense);
 
                --  If the object declaration has an explicit initialization, a
                --  temporary may have to be created to hold the expression, to
@@ -2312,6 +2390,7 @@  package body Sem_Prag is
 
                if Nkind (Parent (E)) = N_Object_Declaration
                  and then Present (Expression (Parent (E)))
+                 and then Sense
                then
                   Set_Has_Delayed_Freeze (E);
                end if;
@@ -2332,7 +2411,7 @@  package body Sem_Prag is
                    Get_Source_File_Index (Sloc (E)) =
                    Get_Source_File_Index (Sloc (Underlying_Type (Etype (E))))
                then
-                  Set_Is_Atomic (Underlying_Type (Etype (E)));
+                  Set_Is_Atomic (Underlying_Type (Etype (E)), Sense);
                end if;
             end if;
 
@@ -2715,7 +2794,7 @@  package body Sem_Prag is
          Check_At_Least_N_Arguments (2);
          Check_Optional_Identifier (Arg1, Name_Convention);
          Check_Arg_Is_Identifier (Arg1);
-         Cname := Chars (Expression (Arg1));
+         Cname := Chars (Get_Pragma_Arg (Arg1));
 
          --  C_Pass_By_Copy is treated as a synonym for convention C (this is
          --  tested again below to set the critical flag).
@@ -2725,7 +2804,7 @@  package body Sem_Prag is
          --  Otherwise we must have something in the standard convention list
 
          elsif Is_Convention_Name (Cname) then
-            C := Get_Convention_Id (Chars (Expression (Arg1)));
+            C := Get_Convention_Id (Chars (Get_Pragma_Arg (Arg1)));
 
          --  In DEC VMS, it seems that there is an undocumented feature that
          --  any unrecognized convention is treated as the default, which for
@@ -2737,7 +2816,7 @@  package body Sem_Prag is
             if Warn_On_Export_Import and not OpenVMS_On_Target then
                Error_Msg_N
                  ("?unrecognized convention name, C assumed",
-                  Expression (Arg1));
+                  Get_Pragma_Arg (Arg1));
             end if;
 
             C := Convention_C;
@@ -2746,7 +2825,7 @@  package body Sem_Prag is
          Check_Optional_Identifier (Arg2, Name_Entity);
          Check_Arg_Is_Local_Name (Arg2);
 
-         Id := Expression (Arg2);
+         Id := Get_Pragma_Arg (Arg2);
          Analyze (Id);
 
          if not Is_Entity_Name (Id) then
@@ -2923,6 +3002,10 @@  package body Sem_Prag is
                      Generate_Reference (E1, Id, 'b');
                   end if;
                end if;
+
+               --  For aspect case, do NOT apply to homonyms
+
+               exit when From_Aspect_Specification (N);
             end loop;
          end if;
       end Process_Convention;
@@ -3613,7 +3696,7 @@  package body Sem_Prag is
 
          Arg := Arg1;
          while Present (Arg) loop
-            Exp := Expression (Arg);
+            Exp := Get_Pragma_Arg (Arg);
             Analyze (Exp);
 
             if not Is_Entity_Name (Exp)
@@ -3643,7 +3726,7 @@  package body Sem_Prag is
       begin
          Process_Convention (C, Def_Id);
          Kill_Size_Check_Code (Def_Id);
-         Note_Possible_Modification (Expression (Arg2), Sure => False);
+         Note_Possible_Modification (Get_Pragma_Arg (Arg2), Sure => False);
 
          if Ekind_In (Def_Id, E_Variable, E_Constant) then
 
@@ -3770,7 +3853,8 @@  package body Sem_Prag is
                      --  is present, then this is handled by the back end.
 
                      if No (Arg3) then
-                        Check_Intrinsic_Subprogram (Def_Id, Expression (Arg2));
+                        Check_Intrinsic_Subprogram
+                          (Def_Id, Get_Pragma_Arg (Arg2));
                      end if;
                   end if;
 
@@ -4074,6 +4158,11 @@  package body Sem_Prag is
             --  entity (if declared in the same unit) is inlined.
 
             if Is_Subprogram (Subp) then
+
+               if not Sense then
+                  return;
+               end if;
+
                Inner_Subp := Ultimate_Alias (Inner_Subp);
 
                if In_Same_Source_Unit (Subp, Inner_Subp) then
@@ -4134,16 +4223,16 @@  package body Sem_Prag is
          procedure Set_Inline_Flags (Subp : Entity_Id) is
          begin
             if Active then
-               Set_Is_Inlined (Subp, True);
+               Set_Is_Inlined (Subp, Sense);
             end if;
 
             if not Has_Pragma_Inline (Subp) then
-               Set_Has_Pragma_Inline (Subp);
+               Set_Has_Pragma_Inline (Subp, Sense);
                Effective := True;
             end if;
 
             if Prag_Id = Pragma_Inline_Always then
-               Set_Has_Pragma_Inline_Always (Subp);
+               Set_Has_Pragma_Inline_Always (Subp, Sense);
             end if;
          end Set_Inline_Flags;
 
@@ -4159,7 +4248,7 @@  package body Sem_Prag is
 
          Assoc := Arg1;
          while Present (Assoc) loop
-            Subp_Id := Expression (Assoc);
+            Subp_Id := Get_Pragma_Arg (Assoc);
             Analyze (Subp_Id);
             Applies := False;
 
@@ -4176,12 +4265,14 @@  package body Sem_Prag is
                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;
+                  if not From_Aspect_Specification (N) then
+                     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;
             end if;
 
@@ -4406,7 +4497,7 @@  package body Sem_Prag is
       -----------------------------------------
 
       procedure Process_Interrupt_Or_Attach_Handler is
-         Arg1_X       : constant Node_Id   := Expression (Arg1);
+         Arg1_X       : constant Node_Id   := Get_Pragma_Arg (Arg1);
          Handler_Proc : constant Entity_Id := Entity (Arg1_X);
          Proc_Scope   : constant Entity_Id := Scope (Handler_Proc);
 
@@ -4478,7 +4569,7 @@  package body Sem_Prag is
          Arg := Arg1;
          while Present (Arg) loop
             Id := Chars (Arg);
-            Expr := Expression (Arg);
+            Expr := Get_Pragma_Arg (Arg);
 
             --  Case of no restriction identifier present
 
@@ -4708,7 +4799,7 @@  package body Sem_Prag is
          Check_No_Identifier (Arg1);
          Check_Arg_Is_Identifier (Arg1);
 
-         C := Get_Check_Id (Chars (Expression (Arg1)));
+         C := Get_Check_Id (Chars (Get_Pragma_Arg (Arg1)));
 
          if C = No_Check_Id then
             Error_Pragma_Arg
@@ -4766,7 +4857,7 @@  package body Sem_Prag is
             end if;
 
             Check_Optional_Identifier (Arg2, Name_On);
-            E_Id := Expression (Arg2);
+            E_Id := Get_Pragma_Arg (Arg2);
             Analyze (E_Id);
 
             if not Is_Entity_Name (E_Id) then
@@ -4808,8 +4899,9 @@  package body Sem_Prag is
                   Suppress_Unsuppress_Echeck (Alias (E), C);
                end if;
 
-               --  Move to next homonym
+               --  Move to next homonym if not aspect spec case
 
+               exit when From_Aspect_Specification (N);
                E := Homonym (E);
                exit when No (E);
 
@@ -5480,7 +5572,7 @@  package body Sem_Prag is
 
             if Arg_Count = 1 then
                Check_Arg_Is_Local_Name (Arg1);
-               E_Id := Expression (Arg1);
+               E_Id := Get_Pragma_Arg (Arg1);
 
                if Etype (E_Id) = Any_Type then
                   return;
@@ -5499,9 +5591,14 @@  package body Sem_Prag is
 
                Check_Valid_Configuration_Pragma;
 
-               --  Now set Ada 2005 mode
+               --  Now set appropriate Ada mode
+
+               if Sense then
+                  Ada_Version := Ada_2005;
+               else
+                  Ada_Version := Ada_Version_Default;
+               end if;
 
-               Ada_Version := Ada_2005;
                Ada_Version_Explicit := Ada_2005;
             end if;
          end;
@@ -5527,7 +5624,7 @@  package body Sem_Prag is
 
             if Arg_Count = 1 then
                Check_Arg_Is_Local_Name (Arg1);
-               E_Id := Expression (Arg1);
+               E_Id := Get_Pragma_Arg (Arg1);
 
                if Etype (E_Id) = Any_Type then
                   return;
@@ -5547,9 +5644,14 @@  package body Sem_Prag is
 
                Check_Valid_Configuration_Pragma;
 
-               --  Now set Ada 2012 mode
+               --  Now set appropriate Ada mode
+
+               if Sense then
+                  Ada_Version := Ada_2012;
+               else
+                  Ada_Version := Ada_Version_Default;
+               end if;
 
-               Ada_Version := Ada_2012;
                Ada_Version_Explicit := Ada_2012;
             end if;
          end;
@@ -5620,7 +5722,7 @@  package body Sem_Prag is
                else
                   Arg := Next (Arg2);
                   while Present (Arg) loop
-                     Exp := Expression (Arg);
+                     Exp := Get_Pragma_Arg (Arg);
                      Analyze (Exp);
 
                      if Is_Entity_Name (Exp) then
@@ -5758,7 +5860,7 @@  package body Sem_Prag is
             Check_No_Identifiers;
             Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
 
-            if Chars (Expression (Arg1)) = Name_On then
+            if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
                Assume_No_Invalid_Values := True;
             else
                Assume_No_Invalid_Values := False;
@@ -5779,7 +5881,7 @@  package body Sem_Prag is
             Check_Arg_Count (1);
             Check_No_Identifiers;
             Check_Arg_Is_Local_Name (Arg1);
-            Ent := Entity (Expression (Arg1));
+            Ent := Entity (Get_Pragma_Arg (Arg1));
 
             --  Note: the implementation of the AST_Entry pragma could handle
             --  the entry family case fine, but for now we are consistent with
@@ -5882,8 +5984,8 @@  package body Sem_Prag is
             end if;
 
             C_Ent := Cunit_Entity (Current_Sem_Unit);
-            Analyze (Expression (Arg1));
-            Nm := Entity (Expression (Arg1));
+            Analyze (Get_Pragma_Arg (Arg1));
+            Nm := Entity (Get_Pragma_Arg (Arg1));
 
             if not Is_Remote_Call_Interface (C_Ent)
               and then not Is_Remote_Types (C_Ent)
@@ -5995,7 +6097,7 @@  package body Sem_Prag is
             Check_No_Identifiers;
             Check_Arg_Count (1);
             Check_Arg_Is_Local_Name (Arg1);
-            E_Id := Expression (Arg1);
+            E_Id := Get_Pragma_Arg (Arg1);
 
             if Etype (E_Id) = Any_Type then
                return;
@@ -6028,10 +6130,10 @@  package body Sem_Prag is
                   E := Base_Type (E);
                end if;
 
-               Set_Has_Volatile_Components (E);
+               Set_Has_Volatile_Components (E, Sense);
 
                if Prag_Id = Pragma_Atomic_Components then
-                  Set_Has_Atomic_Components (E);
+                  Set_Has_Atomic_Components (E, Sense);
                end if;
 
             else
@@ -6055,24 +6157,23 @@  package body Sem_Prag is
             else
                Check_Interrupt_Or_Attach_Handler;
 
-               --  The expression that designates the attribute may
-               --  depend on a discriminant, and is therefore a per-
-               --  object expression, to be expanded in the init proc.
-               --  If expansion is enabled, perform semantic checks
-               --  on a copy only.
+               --  The expression that designates the attribute may depend on a
+               --  discriminant, and is therefore a per- object expression, to
+               --  be expanded in the init proc. If expansion is enabled, then
+               --  perform semantic checks on a copy only.
 
                if Expander_Active then
                   declare
                      Temp : constant Node_Id :=
-                              New_Copy_Tree (Expression (Arg2));
+                              New_Copy_Tree (Get_Pragma_Arg (Arg2));
                   begin
                      Set_Parent (Temp, N);
                      Preanalyze_And_Resolve (Temp, RTE (RE_Interrupt_ID));
                   end;
 
                else
-                  Analyze (Expression (Arg2));
-                  Resolve (Expression (Arg2), RTE (RE_Interrupt_ID));
+                  Analyze (Get_Pragma_Arg (Arg2));
+                  Resolve (Get_Pragma_Arg (Arg2), RTE (RE_Interrupt_ID));
                end if;
 
                Process_Interrupt_Or_Attach_Handler;
@@ -6094,7 +6195,7 @@  package body Sem_Prag is
             Check_Arg_Count (1);
             Check_Optional_Identifier (Arg1, "max_size");
 
-            Arg := Expression (Arg1);
+            Arg := Get_Pragma_Arg (Arg1);
             Check_Arg_Is_Static_Expression (Arg, Any_Integer);
 
             Val := Expr_Value (Arg);
@@ -6174,7 +6275,7 @@  package body Sem_Prag is
             --  compile time, and we do not want to delete this warning when we
             --  delete the if statement.
 
-            Expr := Expression (Arg2);
+            Expr := Get_Pragma_Arg (Arg2);
 
             if Expander_Active and then not Check_On then
                Eloc := Sloc (Expr);
@@ -6211,7 +6312,7 @@  package body Sem_Prag is
             Check_Arg_Is_Identifier (Arg1);
 
             declare
-               Nam : constant Name_Id := Chars (Expression (Arg1));
+               Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
 
             begin
                for J in Check_Names.First .. Check_Names.Last loop
@@ -6349,7 +6450,7 @@  package body Sem_Prag is
             Check_Arg_Count (1);
             Check_Optional_Identifier (Arg1, Name_Entity);
             Check_Arg_Is_Local_Name (Arg1);
-            E_Id := Expression (Arg1);
+            E_Id := Get_Pragma_Arg (Arg1);
 
             if Etype (E_Id) = Any_Type then
                return;
@@ -6497,7 +6598,7 @@  package body Sem_Prag is
             Check_No_Identifiers;
             Check_Arg_Count (1);
             Check_Arg_Is_Local_Name (Arg1);
-            Arg := Expression (Arg1);
+            Arg := Get_Pragma_Arg (Arg1);
 
             if not Is_Entity_Name (Arg)
               or else not Is_Access_Type (Entity (Arg))
@@ -6546,8 +6647,8 @@  package body Sem_Prag is
             Check_Optional_Identifier (Arg2, Name_Convention);
             Check_Arg_Is_Identifier (Arg1);
             Check_Arg_Is_Identifier (Arg2);
-            Idnam := Chars (Expression (Arg1));
-            Cname := Chars (Expression (Arg2));
+            Idnam := Chars (Get_Pragma_Arg (Arg1));
+            Cname := Chars (Get_Pragma_Arg (Arg2));
 
             if Is_Convention_Name (Cname) then
                Record_Convention_Identifier
@@ -6580,7 +6681,7 @@  package body Sem_Prag is
             Check_Optional_Identifier (Arg1, Name_Entity);
             Check_Arg_Is_Local_Name (Arg1);
 
-            Arg := Expression (Arg1);
+            Arg := Get_Pragma_Arg (Arg1);
             Analyze (Arg);
 
             if Etype (Arg) = Any_Type then
@@ -6697,7 +6798,7 @@  package body Sem_Prag is
             Check_Optional_Identifier (Arg1, Name_Entity);
             Check_Arg_Is_Local_Name (Arg1);
 
-            Id := Expression (Arg1);
+            Id := Get_Pragma_Arg (Arg1);
             Find_Program_Unit_Name (Id);
 
             --  If we did not find the name, we are done
@@ -6819,7 +6920,7 @@  package body Sem_Prag is
                Cond :=
                  Make_And_Then (Loc,
                    Left_Opnd   => Relocate_Node (Cond),
-                   Right_Opnd  => Expression (Arg1));
+                   Right_Opnd  => Get_Pragma_Arg (Arg1));
             end if;
 
             --  Rewrite into a conditional with an appropriate condition. We
@@ -6848,7 +6949,8 @@  package body Sem_Prag is
             GNAT_Pragma;
             Check_Arg_Count (1);
             Check_Arg_Is_One_Of (Arg1, Name_Check, Name_Ignore);
-            Debug_Pragmas_Enabled := Chars (Expression (Arg1)) = Name_Check;
+            Debug_Pragmas_Enabled :=
+              Chars (Get_Pragma_Arg (Arg1)) = Name_Check;
 
          ---------------------
          -- Detect_Blocking --
@@ -6911,7 +7013,7 @@  package body Sem_Prag is
                   --  defined in the current declarative part, and recursively
                   --  to any nested scope.
 
-                  Set_Discard_Names (Current_Scope);
+                  Set_Discard_Names (Current_Scope, Sense);
                   return;
 
                else
@@ -6919,7 +7021,7 @@  package body Sem_Prag is
                   Check_Optional_Identifier (Arg1, Name_On);
                   Check_Arg_Is_Local_Name (Arg1);
 
-                  E_Id := Expression (Arg1);
+                  E_Id := Get_Pragma_Arg (Arg1);
 
                   if Etype (E_Id) = Any_Type then
                      return;
@@ -6932,7 +7034,7 @@  package body Sem_Prag is
                         (Is_Enumeration_Type (E) or else Is_Tagged_Type (E)))
                     or else Ekind (E) = E_Exception
                   then
-                     Set_Discard_Names (E);
+                     Set_Discard_Names (E, Sense);
                   else
                      Error_Pragma_Arg
                        ("inappropriate entity for pragma%", Arg1);
@@ -6997,10 +7099,10 @@  package body Sem_Prag is
                Citem := First (List_Containing (N));
                Inner : while Citem /= N loop
                   if Nkind (Citem) = N_With_Clause
-                    and then Same_Name (Name (Citem), Expression (Arg))
+                    and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
                   then
                      Set_Elaborate_Present (Citem, True);
-                     Set_Unit_Name (Expression (Arg), Name (Citem));
+                     Set_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
 
                      --  With the pragma present, elaboration calls on
                      --  subprograms from the named unit need no further
@@ -7079,10 +7181,10 @@  package body Sem_Prag is
                Citem := First (List_Containing (N));
                Innr : while Citem /= N loop
                   if Nkind (Citem) = N_With_Clause
-                    and then Same_Name (Name (Citem), Expression (Arg))
+                    and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
                   then
                      Set_Elaborate_All_Present (Citem, True);
-                     Set_Unit_Name (Expression (Arg), Name (Citem));
+                     Set_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
 
                      --  Suppress warnings and elaboration checks on the named
                      --  unit if the pragma is in the current compilation, as
@@ -7281,7 +7383,8 @@  package body Sem_Prag is
             Process_Convention (C, Def_Id);
 
             if Ekind (Def_Id) /= E_Constant then
-               Note_Possible_Modification (Expression (Arg2), Sure => False);
+               Note_Possible_Modification
+                 (Get_Pragma_Arg (Arg2), Sure => False);
             end if;
 
             Process_Interface_Name (Def_Id, Arg3, Arg4);
@@ -7619,13 +7722,13 @@  package body Sem_Prag is
             Check_Optional_Identifier (Arg1, Name_Name);
             Check_Arg_Is_Identifier (Arg1);
 
-            Get_Name_String (Chars (Expression (Arg1)));
+            Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
 
             if Name_Len > 4
               and then Name_Buffer (1 .. 4) = "aux_"
             then
                if Present (System_Extend_Pragma_Arg) then
-                  if Chars (Expression (Arg1)) =
+                  if Chars (Get_Pragma_Arg (Arg1)) =
                      Chars (Expression (System_Extend_Pragma_Arg))
                   then
                      null;
@@ -7658,7 +7761,7 @@  package body Sem_Prag is
             Check_No_Identifiers;
             Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
 
-            if Chars (Expression (Arg1)) = Name_On then
+            if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
                Extensions_Allowed := True;
                Ada_Version := Ada_Version_Type'Last;
 
@@ -7693,7 +7796,8 @@  package body Sem_Prag is
             Check_At_Least_N_Arguments (2);
             Check_At_Most_N_Arguments  (4);
             Process_Convention (C, Def_Id);
-            Note_Possible_Modification (Expression (Arg2), Sure => False);
+            Note_Possible_Modification
+              (Get_Pragma_Arg (Arg2), Sure => False);
             Process_Interface_Name (Def_Id, Arg3, Arg4);
             Set_Exported (Def_Id, Arg2);
          end External;
@@ -7761,19 +7865,22 @@  package body Sem_Prag is
             Check_No_Identifiers;
             Check_Arg_Count (1);
             Check_Arg_Is_Local_Name (Arg1);
-            Named_Entity := Entity (Expression (Arg1));
+            Named_Entity := Entity (Get_Pragma_Arg (Arg1));
 
             --  If it's an access-to-subprogram type (in particular, not a
             --  subtype), set the flag on that type.
 
             if Is_Access_Subprogram_Type (Named_Entity) then
-               Set_Can_Use_Internal_Rep (Named_Entity, False);
+               if Sense then
+                  Set_Can_Use_Internal_Rep (Named_Entity, False);
+               end if;
 
             --  Otherwise it's an error (name denotes the wrong sort of entity)
 
             else
                Error_Pragma_Arg
-                 ("access-to-subprogram type expected", Expression (Arg1));
+                 ("access-to-subprogram type expected",
+                  Get_Pragma_Arg (Arg1));
             end if;
          end Favor_Top_Level;
 
@@ -7797,7 +7904,7 @@  package body Sem_Prag is
 
          when Pragma_Finalize_Storage_Only => Finalize_Storage : declare
             Assoc   : constant Node_Id := Arg1;
-            Type_Id : constant Node_Id := Expression (Assoc);
+            Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
             Typ     : Entity_Id;
 
          begin
@@ -7859,7 +7966,7 @@  package body Sem_Prag is
             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
+               if Chars (Get_Pragma_Arg (Arg1)) = Name_VAX_Float then
                   Error_Pragma
                     ("?pragma% ignored (applies only to Open'V'M'S)");
                end if;
@@ -7870,7 +7977,7 @@  package body Sem_Prag is
             --  One argument case
 
             if Arg_Count = 1 then
-               if Chars (Expression (Arg1)) = Name_VAX_Float then
+               if Chars (Get_Pragma_Arg (Arg1)) = Name_VAX_Float then
                   if Opt.Float_Format = 'I' then
                      Error_Pragma ("'I'E'E'E format previously specified");
                   end if;
@@ -7905,7 +8012,7 @@  package body Sem_Prag is
 
                --  Two arguments, VAX_Float case
 
-               if Chars (Expression (Arg1)) = Name_VAX_Float then
+               if Chars (Get_Pragma_Arg (Arg1)) = Name_VAX_Float then
                   case Digs is
                      when  6 => Set_F_Float (Ent);
                      when  9 => Set_D_Float (Ent);
@@ -7959,7 +8066,7 @@  package body Sem_Prag is
                Check_Is_In_Decl_Part_Or_Package_Spec;
             end if;
 
-            Str := Expr_Value_S (Expression (Arg1));
+            Str := Expr_Value_S (Get_Pragma_Arg (Arg1));
 
             declare
                CS : Node_Id;
@@ -8061,7 +8168,7 @@  package body Sem_Prag is
 
             --  Extract the name of the local procedure
 
-            Proc_Id := Entity (Expression (Arg1));
+            Proc_Id := Entity (Get_Pragma_Arg (Arg1));
 
             --  Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
             --  primitive procedure of a synchronized tagged type.
@@ -8459,7 +8566,7 @@  package body Sem_Prag is
             Check_No_Identifiers;
             Check_Arg_Count (1);
             Check_Arg_Is_Local_Name (Arg1);
-            E_Id := Expression (Arg1);
+            E_Id := Get_Pragma_Arg (Arg1);
 
             if Etype (E_Id) = Any_Type then
                return;
@@ -8521,7 +8628,7 @@  package body Sem_Prag is
             Check_No_Identifiers;
             Check_Arg_Count (1);
             Check_Arg_Is_Local_Name (Arg1);
-            E_Id := Expression (Arg1);
+            E_Id := Get_Pragma_Arg (Arg1);
 
             if Etype (E_Id) = Any_Type then
                return;
@@ -8634,7 +8741,7 @@  package body Sem_Prag is
             if Arg_Count > 0 then
                Arg := Arg1;
                loop
-                  Exp := Expression (Arg);
+                  Exp := Get_Pragma_Arg (Arg);
                   Analyze (Exp);
 
                   if not Is_Entity_Name (Exp)
@@ -8699,7 +8806,7 @@  package body Sem_Prag is
               ((Name_Entity, Name_External_Name, Name_Link_Name));
             Check_At_Least_N_Arguments (2);
             Check_At_Most_N_Arguments  (3);
-            Id := Expression (Arg1);
+            Id := Get_Pragma_Arg (Arg1);
             Analyze (Id);
 
             if not Is_Entity_Name (Id) then
@@ -8769,6 +8876,7 @@  package body Sem_Prag is
                      Found := True;
                   end if;
 
+                  exit when From_Aspect_Specification (N);
                   Hom_Id := Homonym (Hom_Id);
 
                   exit when No (Hom_Id)
@@ -8815,7 +8923,7 @@  package body Sem_Prag is
             Check_Ada_83_Warning;
 
             if Arg_Count /= 0 then
-               Arg := Expression (Arg1);
+               Arg := Get_Pragma_Arg (Arg1);
                Check_Arg_Count (1);
                Check_No_Identifiers;
 
@@ -8990,7 +9098,7 @@  package body Sem_Prag is
             Check_Optional_Identifier (Arg1, Name_Entity);
             Check_Arg_Is_Local_Name (Arg1);
 
-            Id := Expression (Arg1);
+            Id := Get_Pragma_Arg (Arg1);
             Find_Program_Unit_Name (Id);
 
             --  If we did not find the name, we are done
@@ -9233,6 +9341,7 @@  package body Sem_Prag is
                Set_Convention     (Def_Id, Convention);
                Set_Is_Imported    (Def_Id);
 
+               exit when From_Aspect_Specification (N);
                Hom_Id := Homonym (Hom_Id);
 
                exit when No (Hom_Id) or else Scope (Hom_Id) /= Current_Scope;
@@ -9255,7 +9364,7 @@  package body Sem_Prag is
             Check_Optional_Identifier (Arg1, Name_Entity);
             Check_Arg_Is_Local_Name (Arg1);
 
-            Arg := Expression (Arg1);
+            Arg := Get_Pragma_Arg (Arg1);
             Analyze (Arg);
 
             if Etype (Arg) = Any_Type then
@@ -9307,7 +9416,7 @@  package body Sem_Prag is
             Check_Optional_Identifier (Arg1, Name_On);
             Check_Arg_Is_Local_Name (Arg1);
 
-            Arg := Expression (Arg1);
+            Arg := Get_Pragma_Arg (Arg1);
             Analyze (Arg);
 
             if Etype (Arg) = Any_Type then
@@ -9392,7 +9501,7 @@  package body Sem_Prag is
                   Arg_Store : declare
                      C : constant Char_Code := Get_Char_Code (' ');
                      S : constant String_Id :=
-                           Strval (Expr_Value_S (Expression (Arg)));
+                           Strval (Expr_Value_S (Get_Pragma_Arg (Arg)));
                      L : constant Nat := String_Length (S);
                      F : Nat := 1;
 
@@ -9465,10 +9574,10 @@  package body Sem_Prag is
             --  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
+            if Rep_Item_Too_Late (Entity (Get_Pragma_Arg (Arg1)), N) then
                return;
             else
-               Set_Has_Gigi_Rep_Item (Entity (Expression (Arg1)));
+               Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
             end if;
 
          ------------------------
@@ -9496,7 +9605,7 @@  package body Sem_Prag is
             Check_Arg_Count (1);
             Check_No_Identifiers;
             Check_Arg_Is_Local_Name (Arg1);
-            Arg1_X := Expression (Arg1);
+            Arg1_X := Get_Pragma_Arg (Arg1);
             Analyze (Arg1_X);
             Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
 
@@ -9532,13 +9641,14 @@  package body Sem_Prag is
             Check_Arg_Count (1);
             Check_Is_In_Decl_Part_Or_Package_Spec;
             Check_Arg_Is_Static_Expression (Arg1, Standard_String);
-            Start_String (Strval (Expr_Value_S (Expression (Arg1))));
+            Start_String (Strval (Expr_Value_S (Get_Pragma_Arg (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))));
+               Store_String_Chars
+                 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg))));
                Arg := Next (Arg);
             end loop;
 
@@ -9568,7 +9678,7 @@  package body Sem_Prag is
 
             --  This pragma applies only to objects
 
-            if not Is_Object (Entity (Expression (Arg1))) then
+            if not Is_Object (Entity (Get_Pragma_Arg (Arg1))) then
                Error_Pragma_Arg ("pragma% applies only to objects", Arg1);
             end if;
 
@@ -9577,10 +9687,10 @@  package body Sem_Prag is
             --  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
+            if Rep_Item_Too_Late (Entity (Get_Pragma_Arg (Arg1)), N) then
                return;
             else
-               Set_Has_Gigi_Rep_Item (Entity (Expression (Arg1)));
+               Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
             end if;
 
          ----------
@@ -9611,7 +9721,7 @@  package body Sem_Prag is
             Check_No_Identifiers;
             Check_Arg_Is_Locking_Policy (Arg1);
             Check_Valid_Configuration_Pragma;
-            Get_Name_String (Chars (Expression (Arg1)));
+            Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
             LP := Fold_Upper (Name_Buffer (1));
 
             if Locking_Policy /= ' '
@@ -9651,7 +9761,7 @@  package body Sem_Prag is
 
             --  D_Float case
 
-            if Chars (Expression (Arg1)) = Name_D_Float then
+            if Chars (Get_Pragma_Arg (Arg1)) = Name_D_Float then
                if Opt.Float_Format_Long = 'G' then
                   Error_Pragma ("G_Float previously specified");
                end if;
@@ -9697,7 +9807,7 @@  package body Sem_Prag is
             Check_Optional_Identifier (Arg2, Name_Attribute_Name);
             Check_Arg_Is_Local_Name (Arg1);
             Check_Arg_Is_Static_Expression (Arg2, Standard_String);
-            Def_Id := Entity (Expression (Arg1));
+            Def_Id := Entity (Get_Pragma_Arg (Arg1));
 
             if Is_Access_Type (Def_Id) then
                Def_Id := Designated_Type (Def_Id);
@@ -9717,7 +9827,7 @@  package body Sem_Prag is
             if Rep_Item_Too_Late (Def_Id, N) then
                return;
             else
-               Set_Has_Gigi_Rep_Item (Entity (Expression (Arg1)));
+               Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
             end if;
          end Machine_Attribute;
 
@@ -9866,7 +9976,7 @@  package body Sem_Prag is
             Arg := Arg1;
             while Present (Arg) loop
                Check_Arg_Is_Local_Name (Arg);
-               Id := Expression (Arg);
+               Id := Get_Pragma_Arg (Arg);
                Analyze (Id);
 
                if not Is_Entity_Name (Id) then
@@ -9896,6 +10006,7 @@  package body Sem_Prag is
                      Found := True;
                   end if;
 
+                  exit when From_Aspect_Specification (N);
                   E := Homonym (E);
                end loop;
 
@@ -9957,7 +10068,7 @@  package body Sem_Prag is
             else
                Check_Optional_Identifier (Arg2, Name_Entity);
                Check_Arg_Is_Local_Name (Arg1);
-               E_Id := Entity (Expression (Arg1));
+               E_Id := Entity (Get_Pragma_Arg (Arg1));
 
                if E_Id = Any_Type then
                   return;
@@ -10068,7 +10179,7 @@  package body Sem_Prag is
                   --  Deal with static string argument
 
                   Check_Arg_Is_Static_Expression (Arg1, Standard_String);
-                  S := Strval (Expression (Arg1));
+                  S := Strval (Get_Pragma_Arg (Arg1));
 
                   for J in 1 .. String_Length (S) loop
                      if not In_Character_Range (Get_String_Char (S, J)) then
@@ -10079,7 +10190,7 @@  package body Sem_Prag is
                   end loop;
 
                   Obsolescent_Warnings.Append
-                    ((Ent => Ent, Msg => Strval (Expression (Arg1))));
+                    ((Ent => Ent, Msg => Strval (Get_Pragma_Arg (Arg1))));
 
                   --  Check for Ada_05 parameter
 
@@ -10272,7 +10383,7 @@  package body Sem_Prag is
             Check_Arg_Count (1);
             Check_Arg_Is_Local_Name (Arg1);
 
-            Type_Id := Expression (Assoc);
+            Type_Id := Get_Pragma_Arg (Assoc);
             Find_Type (Type_Id);
             Typ := Entity (Type_Id);
 
@@ -10308,7 +10419,7 @@  package body Sem_Prag is
             Check_Arg_Count (1);
             Check_Arg_Is_Local_Name (Arg1);
 
-            Type_Id := Expression (Assoc);
+            Type_Id := Get_Pragma_Arg (Assoc);
             Find_Type (Type_Id);
             Typ := Entity (Type_Id);
 
@@ -10325,13 +10436,11 @@  package body Sem_Prag is
             end if;
 
             Check_First_Subtype (Arg1);
-
-            if Has_Pragma_Pack (Typ) then
-               Error_Pragma ("duplicate pragma%, only one allowed");
+            Check_Duplicate_Pragma (Typ);
 
             --  Array type
 
-            elsif Is_Array_Type (Typ) then
+            if Is_Array_Type (Typ) then
                Ctyp := Component_Type (Typ);
 
                --  Ignore pack that does nothing
@@ -10357,22 +10466,59 @@  package body Sem_Prag is
                   if CodePeer_Mode then
                      null;
 
-                  --  For normal non-VM target, do the packing
+                  --  Don't attempt any packing for VM targets. We possibly
+                  --  could deal with some cases of array bit-packing, but we
+                  --  don't bother, since this is not a typical kind of
+                  --  representation in the VM context anyway (and would not
+                  --  for example work nicely with the debugger).
+
+                  elsif VM_Target /= No_VM then
+                     if not GNAT_Mode then
+                        Error_Pragma
+                          ("?pragma% ignored in this configuration");
+                     end if;
+
+                  --  Normal case where we do the pack action
 
-                  elsif VM_Target = No_VM then
+                  else
                      if not Ignore then
-                        Set_Is_Packed            (Base_Type (Typ));
-                        Set_Has_Non_Standard_Rep (Base_Type (Typ));
+                        Set_Is_Packed            (Base_Type (Typ), Sense);
+                        Set_Has_Non_Standard_Rep (Base_Type (Typ), Sense);
                      end if;
 
-                     Set_Has_Pragma_Pack (Base_Type (Typ));
+                     Set_Has_Pragma_Pack (Base_Type (Typ), Sense);
 
-                  --  If we ignore the pack for VM_Targets, then warn about
-                  --  this, except suppress the warning in GNAT mode.
+                     --  Complete reset action for Aspect_Cancel case
 
-                  elsif not GNAT_Mode then
-                     Error_Pragma
-                       ("?pragma% ignored in this configuration");
+                     if Sense = False then
+
+                        --  Cancel size unless explicitly set
+
+                        if not Has_Size_Clause (Typ)
+                           and then not Has_Object_Size_Clause (Typ)
+                        then
+                           Set_Esize     (Typ, Uint_0);
+                           Set_RM_Size   (Typ, Uint_0);
+                           Set_Alignment (Typ, Uint_0);
+                           Set_Packed_Array_Type (Typ, Empty);
+                        end if;
+
+                        --  Reset component size unless explicitly set
+
+                        if not Has_Component_Size_Clause (Typ) then
+                           if Known_Static_Esize (Ctyp)
+                             and then Known_Static_RM_Size (Ctyp)
+                             and then Esize (Ctyp) = RM_Size (Ctyp)
+                             and then Addressable (Esize (Ctyp))
+                           then
+                              Set_Component_Size
+                                (Base_Type (Typ), Esize (Ctyp));
+                           else
+                              Set_Component_Size
+                                (Base_Type (Typ), Uint_0);
+                           end if;
+                        end if;
+                     end if;
                   end if;
                end if;
 
@@ -10380,13 +10526,36 @@  package body Sem_Prag is
 
             else pragma Assert (Is_Record_Type (Typ));
                if not Rep_Item_Too_Late (Typ, N) then
-                  if VM_Target = No_VM then
-                     Set_Is_Packed            (Base_Type (Typ));
-                     Set_Has_Pragma_Pack      (Base_Type (Typ));
-                     Set_Has_Non_Standard_Rep (Base_Type (Typ));
 
-                  elsif not GNAT_Mode then
-                     Error_Pragma ("?pragma% ignored in this configuration");
+                  --  Ignore pack request with warning in VM mode (skip warning
+                  --  if we are compiling GNAT run time library).
+
+                  if VM_Target /= No_VM then
+                     if not GNAT_Mode then
+                        Error_Pragma
+                          ("?pragma% ignored in this configuration");
+                     end if;
+
+                  --  Normal case of pack request active
+
+                  else
+                     Set_Is_Packed            (Base_Type (Typ), Sense);
+                     Set_Has_Pragma_Pack      (Base_Type (Typ), Sense);
+                     Set_Has_Non_Standard_Rep (Base_Type (Typ), Sense);
+
+                     --  Complete reset action for Aspect_Cancel case
+
+                     if Sense = False then
+
+                        --  Cancel size if not explicitly given
+
+                        if not Has_Size_Clause (Typ)
+                          and then not Has_Object_Size_Clause (Typ)
+                        then
+                           Set_Esize     (Typ, Uint_0);
+                           Set_Alignment (Typ, Uint_0);
+                        end if;
+                     end if;
                   end if;
                end if;
             end if;
@@ -10441,7 +10610,7 @@  package body Sem_Prag is
             Check_Arg_Is_Identifier (Arg1);
             Check_Arg_Is_Local_Name (Arg1);
             Check_First_Subtype (Arg1);
-            Ent := Entity (Expression (Arg1));
+            Ent := Entity (Get_Pragma_Arg (Arg1));
 
             if not Is_Private_Type (Ent)
               and then not Is_Protected_Type (Ent)
@@ -10498,15 +10667,15 @@  package body Sem_Prag is
             if Arg_Count = 1 then
                Check_Arg_Is_Library_Level_Local_Name (Arg1);
 
-               if not Is_Entity_Name (Expression (Arg1))
-                 or else
-                  (Ekind (Entity (Expression (Arg1))) /= E_Variable
-                    and then Ekind (Entity (Expression (Arg1))) /= E_Constant)
+               if not Is_Entity_Name (Get_Pragma_Arg (Arg1))
+                 or else not
+                  Ekind_In (Entity (Get_Pragma_Arg (Arg1)), E_Variable,
+                                                            E_Constant)
                then
                   Error_Pragma_Arg ("pragma% only applies to objects", Arg1);
                end if;
 
-               Ent := Entity (Expression (Arg1));
+               Ent := Entity (Get_Pragma_Arg (Arg1));
                Decl := Parent (Ent);
 
                if Rep_Item_Too_Late (Ent, N) then
@@ -10524,11 +10693,15 @@  package body Sem_Prag is
                      Arg1);
                end if;
 
-               Prag :=
-                 Make_Linker_Section_Pragma
-                   (Ent, Sloc (N), ".persistent.bss");
-               Insert_After (N, Prag);
-               Analyze (Prag);
+               Check_Duplicate_Pragma (Ent);
+
+               if Sense then
+                  Prag :=
+                    Make_Linker_Section_Pragma
+                      (Ent, Sloc (N), ".persistent.bss");
+                  Insert_After (N, Prag);
+                  Analyze (Prag);
+               end if;
 
             --  Case of use as configuration pragma with no arguments
 
@@ -10549,7 +10722,7 @@  package body Sem_Prag is
             Check_Arg_Count (1);
             Check_No_Identifiers;
             Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
-            Polling_Required := (Chars (Expression (Arg1)) = Name_On);
+            Polling_Required := (Chars (Get_Pragma_Arg (Arg1)) = Name_On);
 
          -------------------
          -- Postcondition --
@@ -10648,6 +10821,7 @@  package body Sem_Prag is
             end if;
 
             Ent := Find_Lib_Unit_Name;
+            Check_Duplicate_Pragma (Ent);
 
             --  This filters out pragmas inside generic parent then
             --  show up inside instantiation
@@ -10657,8 +10831,8 @@  package body Sem_Prag is
                               and then Present (Generic_Parent (Pa)))
             then
                if not Debug_Flag_U then
-                  Set_Is_Preelaborated (Ent);
-                  Set_Suppress_Elaboration_Warnings (Ent);
+                  Set_Is_Preelaborated (Ent, Sense);
+                  Set_Suppress_Elaboration_Warnings (Ent, Sense);
                end if;
             end if;
          end Preelaborate;
@@ -10720,7 +10894,7 @@  package body Sem_Prag is
             if Nkind (P) = N_Subprogram_Body then
                Check_In_Main_Program;
 
-               Arg := Expression (Arg1);
+               Arg := Get_Pragma_Arg (Arg1);
                Analyze_And_Resolve (Arg, Standard_Integer);
 
                --  Must be static
@@ -10770,7 +10944,7 @@  package body Sem_Prag is
             --  Task or Protected, must be of type Integer
 
             elsif Nkind_In (P, N_Protected_Definition, N_Task_Definition) then
-               Arg := Expression (Arg1);
+               Arg := Get_Pragma_Arg (Arg1);
 
                --  The expression must be analyzed in the special manner
                --  described in "Handling of Default and Per-Object
@@ -10826,14 +11000,14 @@  package body Sem_Prag is
             Check_No_Identifiers;
             Check_Arg_Is_Task_Dispatching_Policy (Arg1);
             Check_Valid_Configuration_Pragma;
-            Get_Name_String (Chars (Expression (Arg1)));
+            Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
             DP := Fold_Upper (Name_Buffer (1));
 
-            Lower_Bound := Expression (Arg2);
+            Lower_Bound := Get_Pragma_Arg (Arg2);
             Check_Arg_Is_Static_Expression (Lower_Bound, Standard_Integer);
             Lower_Val := Expr_Value (Lower_Bound);
 
-            Upper_Bound := Expression (Arg3);
+            Upper_Bound := Get_Pragma_Arg (Arg3);
             Check_Arg_Is_Static_Expression (Upper_Bound, Standard_Integer);
             Upper_Val := Expr_Value (Upper_Bound);
 
@@ -11219,7 +11393,7 @@  package body Sem_Prag is
             Check_Arg_Count (1);
             Check_Optional_Identifier (Arg1, Name_Entity);
             Check_Arg_Is_Local_Name (Arg1);
-            E_Id := Expression (Arg1);
+            E_Id := Get_Pragma_Arg (Arg1);
 
             if Error_Posted (E_Id) then
                return;
@@ -11241,18 +11415,19 @@  package body Sem_Prag is
                        ("pragma% requires a function name", Arg1);
                   end if;
 
-                  Set_Is_Pure (Def_Id);
+                  Set_Is_Pure (Def_Id, Sense);
 
                   if not Has_Pragma_Pure_Function (Def_Id) then
-                     Set_Has_Pragma_Pure_Function (Def_Id);
-                     Effective := True;
+                     Set_Has_Pragma_Pure_Function (Def_Id, Sense);
+                     Effective := Sense;
                   end if;
 
+                  exit when From_Aspect_Specification (N);
                   E := Homonym (E);
                   exit when No (E) or else Scope (E) /= Current_Scope;
                end loop;
 
-               if not Effective
+               if Sense and then not Effective
                  and then Warn_On_Redundant_Constructs
                then
                   Error_Msg_NE
@@ -11277,7 +11452,7 @@  package body Sem_Prag is
             Check_No_Identifiers;
             Check_Arg_Is_Queuing_Policy (Arg1);
             Check_Valid_Configuration_Pragma;
-            Get_Name_String (Chars (Expression (Arg1)));
+            Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
             QP := Fold_Upper (Name_Buffer (1));
 
             if Queuing_Policy /= ' '
@@ -11313,7 +11488,7 @@  package body Sem_Prag is
             Check_No_Identifiers;
             Check_Arg_Count (1);
 
-            Arg := Expression (Arg1);
+            Arg := Get_Pragma_Arg (Arg1);
 
             --  The expression must be analyzed in the special manner described
             --  in "Handling of Default and Per-Object Expressions" in sem.ads.
@@ -11702,7 +11877,7 @@  package body Sem_Prag is
             --  The expression must be analyzed in the special manner described
             --  in "Handling of Default Expressions" in sem.ads.
 
-            Arg := Expression (Arg1);
+            Arg := Get_Pragma_Arg (Arg1);
             Preanalyze_Spec_Expression (Arg, Any_Integer);
 
             if not Is_Static_Expression (Arg) then
@@ -11738,7 +11913,7 @@  package body Sem_Prag is
             Check_Arg_Count (1);
             Check_Arg_Is_Integer_Literal (Arg1);
 
-            if Intval (Expression (Arg1)) /=
+            if Intval (Get_Pragma_Arg (Arg1)) /=
               UI_From_Int (Ttypes.System_Storage_Unit)
             then
                Error_Msg_Uint_1 := UI_From_Int (Ttypes.System_Storage_Unit);
@@ -11772,7 +11947,7 @@  package body Sem_Prag is
 
             begin
                Check_Arg_Is_Local_Name (Arg);
-               Ent := Entity (Expression (Arg));
+               Ent := Entity (Get_Pragma_Arg (Arg));
 
                if Has_Homonym (Ent) then
                   Error_Pragma_Arg
@@ -11804,9 +11979,9 @@  package body Sem_Prag is
 
             declare
                Typ   : constant Entity_Id :=
-                         Underlying_Type (Entity (Expression (Arg1)));
-               Read  : constant Entity_Id := Entity (Expression (Arg2));
-               Write : constant Entity_Id := Entity (Expression (Arg3));
+                         Underlying_Type (Entity (Get_Pragma_Arg (Arg1)));
+               Read  : constant Entity_Id := Entity (Get_Pragma_Arg (Arg2));
+               Write : constant Entity_Id := Entity (Get_Pragma_Arg (Arg3));
 
             begin
                Check_First_Subtype (Arg1);
@@ -11869,7 +12044,7 @@  package body Sem_Prag is
          --  we don't need to issue error messages here.
 
          when Pragma_Style_Checks => Style_Checks : declare
-            A  : constant Node_Id   := Expression (Arg1);
+            A  : constant Node_Id   := Get_Pragma_Arg (Arg1);
             S  : String_Id;
             C  : Char_Code;
 
@@ -11887,7 +12062,7 @@  package body Sem_Prag is
                   E    : Entity_Id;
 
                begin
-                  E_Id := Expression (Arg2);
+                  E_Id := Get_Pragma_Arg (Arg2);
                   Analyze (E_Id);
 
                   if not Is_Entity_Name (E_Id) then
@@ -11903,7 +12078,7 @@  package body Sem_Prag is
                   else
                      loop
                         Set_Suppress_Style_Checks (E,
-                          (Chars (Expression (Arg1)) = Name_Off));
+                          (Chars (Get_Pragma_Arg (Arg1)) = Name_Off));
                         exit when No (Homonym (E));
                         E := Homonym (E);
                      end loop;
@@ -12019,7 +12194,7 @@  package body Sem_Prag is
             Check_Arg_Count (1);
             Check_Optional_Identifier (Arg1, Name_Entity);
             Check_Arg_Is_Local_Name (Arg1);
-            Set_Debug_Info_Off (Entity (Get_Pragma_Arg (Arg1)));
+            Set_Debug_Info_Off (Entity (Get_Pragma_Arg (Arg1)), Sense);
 
          ----------------------------------
          -- Suppress_Exception_Locations --
@@ -12049,7 +12224,7 @@  package body Sem_Prag is
             Check_Optional_Identifier (Arg1, Name_Entity);
             Check_Arg_Is_Local_Name (Arg1);
 
-            E_Id := Expression (Arg1);
+            E_Id := Get_Pragma_Arg (Arg1);
 
             if Etype (E_Id) = Any_Type then
                return;
@@ -12106,7 +12281,7 @@  package body Sem_Prag is
             Check_No_Identifiers;
             Check_Arg_Is_Task_Dispatching_Policy (Arg1);
             Check_Valid_Configuration_Pragma;
-            Get_Name_String (Chars (Expression (Arg1)));
+            Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
             DP := Fold_Upper (Name_Buffer (1));
 
             if Task_Dispatching_Policy /= ' '
@@ -12147,9 +12322,10 @@  package body Sem_Prag is
             Check_No_Identifiers;
             Check_Arg_Count (1);
 
-            Analyze_And_Resolve (Expression (Arg1), RTE (RE_Task_Info_Type));
+            Analyze_And_Resolve
+              (Get_Pragma_Arg (Arg1), RTE (RE_Task_Info_Type));
 
-            if Etype (Expression (Arg1)) = Any_Type then
+            if Etype (Get_Pragma_Arg (Arg1)) = Any_Type then
                return;
             end if;
 
@@ -12174,7 +12350,7 @@  package body Sem_Prag is
             Check_No_Identifiers;
             Check_Arg_Count (1);
 
-            Arg := Expression (Arg1);
+            Arg := Get_Pragma_Arg (Arg1);
 
             --  The expression is used in the call to Create_Task, and must be
             --  expanded there, not in the context of the current spec. It must
@@ -12262,7 +12438,7 @@  package body Sem_Prag is
             Check_Optional_Identifier (Arg1, Name_Entity);
             Check_Arg_Is_Library_Level_Local_Name (Arg1);
 
-            Id := Expression (Arg1);
+            Id := Get_Pragma_Arg (Arg1);
             Analyze (Id);
 
             if not Is_Entity_Name (Id)
@@ -12318,7 +12494,7 @@  package body Sem_Prag is
 
             if Get_Source_Unit (Loc) = Main_Unit then
                Opt.Time_Slice_Set := True;
-               Val := Expr_Value_R (Expression (Arg1));
+               Val := Expr_Value_R (Get_Pragma_Arg (Arg1));
 
                if Val <= Ureal_0 then
                   Opt.Time_Slice_Value := 0;
@@ -12369,7 +12545,7 @@  package body Sem_Prag is
 
          when Pragma_Unchecked_Union => Unchecked_Union : declare
             Assoc   : constant Node_Id := Arg1;
-            Type_Id : constant Node_Id := Expression (Assoc);
+            Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
             Typ     : Entity_Id;
             Discr   : Entity_Id;
             Tdef    : Node_Id;
@@ -12433,6 +12609,7 @@  package body Sem_Prag is
                        ("Unchecked_Union discriminant must have default value",
                         Discr);
                   end if;
+
                   Next_Discriminant (Discr);
                end loop;
 
@@ -12461,11 +12638,14 @@  package body Sem_Prag is
                end loop;
             end if;
 
-            Set_Is_Unchecked_Union  (Typ, True);
-            Set_Convention          (Typ, Convention_C);
+            Set_Is_Unchecked_Union  (Typ, Sense);
 
-            Set_Has_Unchecked_Union (Base_Type (Typ), True);
-            Set_Is_Unchecked_Union  (Base_Type (Typ), True);
+            if Sense then
+               Set_Convention (Typ, Convention_C);
+            end if;
+
+            Set_Has_Unchecked_Union (Base_Type (Typ), Sense);
+            Set_Is_Unchecked_Union  (Base_Type (Typ), Sense);
          end Unchecked_Union;
 
          ------------------------
@@ -12516,7 +12696,7 @@  package body Sem_Prag is
             Check_Arg_Count (1);
             Check_Optional_Identifier (Arg2, Name_Entity);
             Check_Arg_Is_Local_Name (Arg1);
-            E_Id := Entity (Expression (Arg1));
+            E_Id := Entity (Get_Pragma_Arg (Arg1));
 
             if E_Id = Any_Type then
                return;
@@ -12524,7 +12704,7 @@  package body Sem_Prag is
                Error_Pragma_Arg ("pragma% requires type", Arg1);
             end if;
 
-            Set_Universal_Aliasing (Implementation_Base_Type (E_Id));
+            Set_Universal_Aliasing (Implementation_Base_Type (E_Id), Sense);
          end Universal_Alias;
 
          --------------------
@@ -12592,7 +12772,7 @@  package body Sem_Prag is
                        ("pragma% can only be applied to a variable",
                         Arg_Expr);
                   else
-                     Set_Has_Pragma_Unmodified (Arg_Ent);
+                     Set_Has_Pragma_Unmodified (Arg_Ent, Sense);
                   end if;
                end if;
 
@@ -12634,13 +12814,15 @@  package body Sem_Prag is
                   Citem := First (List_Containing (N));
                   while Citem /= N loop
                      if Nkind (Citem) = N_With_Clause
-                       and then Same_Name (Name (Citem), Expression (Arg_Node))
+                       and then
+                         Same_Name (Name (Citem), Get_Pragma_Arg (Arg_Node))
                      then
                         Set_Has_Pragma_Unreferenced
                           (Cunit_Entity
                              (Get_Source_Unit
                                 (Library_Unit (Citem))));
-                        Set_Unit_Name (Expression (Arg_Node), Name (Citem));
+                        Set_Unit_Name
+                          (Get_Pragma_Arg (Arg_Node), Name (Citem));
                         exit;
                      end if;
 
@@ -12685,7 +12867,7 @@  package body Sem_Prag is
                         Generate_Reference (Arg_Ent, N);
                      end if;
 
-                     Set_Has_Pragma_Unreferenced (Arg_Ent);
+                     Set_Has_Pragma_Unreferenced (Arg_Ent, Sense);
                   end if;
 
                   Next (Arg_Node);
@@ -12720,7 +12902,7 @@  package body Sem_Prag is
                     ("argument for pragma% must be type or subtype", Arg_Node);
                end if;
 
-               Set_Has_Pragma_Unreferenced_Objects (Entity (Arg_Expr));
+               Set_Has_Pragma_Unreferenced_Objects (Entity (Arg_Expr), Sense);
                Next (Arg_Node);
             end loop;
          end Unreferenced_Objects;
@@ -12768,7 +12950,7 @@  package body Sem_Prag is
          --  pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
 
          when Pragma_Validity_Checks => Validity_Checks : declare
-            A  : constant Node_Id   := Expression (Arg1);
+            A  : constant Node_Id   := Get_Pragma_Arg (Arg1);
             S  : String_Id;
             C  : Char_Code;
 
@@ -12944,7 +13126,7 @@  package body Sem_Prag is
                      Err  : Boolean;
 
                   begin
-                     E_Id := Expression (Arg2);
+                     E_Id := Get_Pragma_Arg (Arg2);
                      Analyze (E_Id);
 
                      --  In the expansion of an inlined body, a reference to
@@ -12968,9 +13150,10 @@  package body Sem_Prag is
                         else
                            loop
                               Set_Warnings_Off
-                                (E, (Chars (Expression (Arg1)) = Name_Off));
+                                (E, (Chars (Get_Pragma_Arg (Arg1)) =
+                                                              Name_Off));
 
-                              if Chars (Expression (Arg1)) = Name_Off
+                              if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
                                 and then Warn_On_Warnings_Off
                               then
                                  Warnings_Off_Pragmas.Append ((N, E));
@@ -13004,7 +13187,7 @@  package body Sem_Prag is
 
                      else
                         String_To_Name_Buffer
-                          (Strval (Expr_Value_S (Expression (Arg2))));
+                          (Strval (Expr_Value_S (Get_Pragma_Arg (Arg2))));
 
                         --  Note on configuration pragma case: If this is a
                         --  configuration pragma, then for an OFF pragma, we
@@ -13051,7 +13234,7 @@  package body Sem_Prag is
             Check_Arg_Count (1);
             Check_Optional_Identifier (Arg1, Name_Entity);
             Check_Arg_Is_Library_Level_Local_Name (Arg1);
-            Ent := Entity (Expression (Arg1));
+            Ent := Entity (Get_Pragma_Arg (Arg1));
 
             if Rep_Item_Too_Early (Ent, N) then
                return;
Index: sem_ch12.adb
===================================================================
--- sem_ch12.adb	(revision 165283)
+++ sem_ch12.adb	(working copy)
@@ -23,6 +23,7 @@ 
 --                                                                          --
 ------------------------------------------------------------------------------
 
+with Aspects;  use Aspects;
 with Atree;    use Atree;
 with Einfo;    use Einfo;
 with Elists;   use Elists;
@@ -1801,6 +1802,7 @@  package body Sem_Ch12 is
    procedure Analyze_Formal_Object_Declaration (N : Node_Id) is
       E  : constant Node_Id := Default_Expression (N);
       Id : constant Node_Id := Defining_Identifier (N);
+      AS : constant List_Id := Aspect_Specifications (N);
       K  : Entity_Kind;
       T  : Node_Id;
 
@@ -1929,6 +1931,8 @@  package body Sem_Ch12 is
               ("initialization not allowed for `IN OUT` formals", N);
          end if;
       end if;
+
+      Analyze_Aspect_Specifications (N, Id, AS);
    end Analyze_Formal_Object_Declaration;
 
    ----------------------------------------------
@@ -1972,13 +1976,14 @@  package body Sem_Ch12 is
       Check_Restriction (No_Fixed_Point, Def);
    end Analyze_Formal_Ordinary_Fixed_Point_Type;
 
-   ----------------------------
-   -- Analyze_Formal_Package --
-   ----------------------------
+   ----------------------------------------
+   -- Analyze_Formal_Package_Declaration --
+   ----------------------------------------
 
-   procedure Analyze_Formal_Package (N : Node_Id) is
+   procedure Analyze_Formal_Package_Declaration (N : Node_Id) is
       Loc              : constant Source_Ptr := Sloc (N);
       Pack_Id          : constant Entity_Id  := Defining_Identifier (N);
+      AS               : constant List_Id    := Aspect_Specifications (N);
       Formal           : Entity_Id;
       Gen_Id           : constant Node_Id    := Name (N);
       Gen_Decl         : Node_Id;
@@ -2115,14 +2120,14 @@  package body Sem_Ch12 is
       if Ekind (Gen_Unit) /= E_Generic_Package then
          Error_Msg_N ("expect generic package name", Gen_Id);
          Restore_Env;
-         return;
+         goto Leave;
 
       elsif  Gen_Unit = Current_Scope then
          Error_Msg_N
            ("generic package cannot be used as a formal package of itself",
              Gen_Id);
          Restore_Env;
-         return;
+         goto Leave;
 
       elsif In_Open_Scopes (Gen_Unit) then
          if Is_Compilation_Unit (Gen_Unit)
@@ -2142,7 +2147,7 @@  package body Sem_Ch12 is
                 & "within itself",
                 Gen_Id);
             Restore_Env;
-            return;
+            goto Leave;
          end if;
       end if;
 
@@ -2190,7 +2195,7 @@  package body Sem_Ch12 is
                Remove_Parent;
             end if;
 
-            return;
+            goto Leave;
       end;
 
       Rewrite (N, New_N);
@@ -2273,7 +2278,9 @@  package body Sem_Ch12 is
       Set_Etype (Pack_Id, Standard_Void_Type);
       Set_Scope (Pack_Id, Scope (Formal));
       Set_Has_Completion (Pack_Id, True);
-   end Analyze_Formal_Package;
+
+      <<Leave>> Analyze_Aspect_Specifications (N, Pack_Id, AS);
+   end Analyze_Formal_Package_Declaration;
 
    ---------------------------------
    -- Analyze_Formal_Private_Type --
@@ -2323,14 +2330,15 @@  package body Sem_Ch12 is
       Set_Parent          (Base, Parent (Def));
    end Analyze_Formal_Signed_Integer_Type;
 
-   -------------------------------
-   -- Analyze_Formal_Subprogram --
-   -------------------------------
+   -------------------------------------------
+   -- Analyze_Formal_Subprogram_Declaration --
+   -------------------------------------------
 
-   procedure Analyze_Formal_Subprogram (N : Node_Id) is
+   procedure Analyze_Formal_Subprogram_Declaration (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);
+      AS   : constant List_Id   := Aspect_Specifications (N);
       Subp : Entity_Id;
 
    begin
@@ -2340,7 +2348,7 @@  package body Sem_Ch12 is
 
       if Nkind (Nam) = N_Defining_Program_Unit_Name then
          Error_Msg_N ("name of formal subprogram must be a direct name", Nam);
-         return;
+         goto Leave;
       end if;
 
       Analyze_Subprogram_Declaration (N);
@@ -2384,7 +2392,7 @@  package body Sem_Ch12 is
 
             Analyze (Prefix (Def));
             Valid_Default_Attribute (Nam, Def);
-            return;
+            goto Leave;
          end if;
 
          --  Default name may be overloaded, in which case the interpretation
@@ -2394,7 +2402,7 @@  package body Sem_Ch12 is
          --  can be a protected operation.
 
          if Etype (Def) = Any_Type then
-            return;
+            goto Leave;
 
          elsif Nkind (Def) = N_Selected_Component then
             if not Is_Overloadable (Entity (Selector_Name (Def))) then
@@ -2416,7 +2424,7 @@  package body Sem_Ch12 is
 
             else
                Error_Msg_N ("expect valid subprogram name as default", Def);
-               return;
+               goto Leave;
             end if;
 
          elsif Nkind (Def) = N_Character_Literal then
@@ -2429,7 +2437,7 @@  package body Sem_Ch12 is
            or else not Is_Overloadable (Entity (Def))
          then
             Error_Msg_N ("expect valid subprogram name as default", Def);
-            return;
+            goto Leave;
 
          elsif not Is_Overloaded (Def) then
             Subp := Entity (Def);
@@ -2491,7 +2499,9 @@  package body Sem_Ch12 is
             end if;
          end if;
       end if;
-   end Analyze_Formal_Subprogram;
+
+      <<Leave>> Analyze_Aspect_Specifications (N, Nam, AS);
+   end Analyze_Formal_Subprogram_Declaration;
 
    -------------------------------------
    -- Analyze_Formal_Type_Declaration --
@@ -2499,6 +2509,7 @@  package body Sem_Ch12 is
 
    procedure Analyze_Formal_Type_Declaration (N : Node_Id) is
       Def : constant Node_Id := Formal_Type_Definition (N);
+      AS  : constant List_Id := Aspect_Specifications (N);
       T   : Entity_Id;
 
    begin
@@ -2564,6 +2575,7 @@  package body Sem_Ch12 is
       end case;
 
       Set_Is_Generic_Type (T);
+      Analyze_Aspect_Specifications (N, T, AS);
    end Analyze_Formal_Type_Declaration;
 
    ------------------------------------
@@ -2630,6 +2642,7 @@  package body Sem_Ch12 is
 
    procedure Analyze_Generic_Package_Declaration (N : Node_Id) is
       Loc         : constant Source_Ptr := Sloc (N);
+      AS          : constant List_Id    := Aspect_Specifications (N);
       Id          : Entity_Id;
       New_N       : Node_Id;
       Save_Parent : Node_Id;
@@ -2740,6 +2753,8 @@  package body Sem_Ch12 is
             Check_References (Id);
          end if;
       end if;
+
+      Analyze_Aspect_Specifications (N, Id, AS);
    end Analyze_Generic_Package_Declaration;
 
    --------------------------------------------
@@ -2747,6 +2762,7 @@  package body Sem_Ch12 is
    --------------------------------------------
 
    procedure Analyze_Generic_Subprogram_Declaration (N : Node_Id) is
+      AS          : constant List_Id := Aspect_Specifications (N);
       Spec        : Node_Id;
       Id          : Entity_Id;
       Formals     : List_Id;
@@ -2865,6 +2881,7 @@  package body Sem_Ch12 is
       End_Scope;
       Exit_Generic_Scope (Id);
       Generate_Reference_To_Formals (Id);
+      Analyze_Aspect_Specifications (N, Id, AS);
    end Analyze_Generic_Subprogram_Declaration;
 
    -----------------------------------
@@ -2874,6 +2891,7 @@  package body Sem_Ch12 is
    procedure Analyze_Package_Instantiation (N : Node_Id) is
       Loc    : constant Source_Ptr := Sloc (N);
       Gen_Id : constant Node_Id    := Name (N);
+      AS     : constant List_Id    := Aspect_Specifications (N);
 
       Act_Decl      : Node_Id;
       Act_Decl_Name : Node_Id;
@@ -3014,7 +3032,7 @@  package body Sem_Ch12 is
 
       if Etype (Gen_Unit) = Any_Type then
          Restore_Env;
-         return;
+         goto Leave;
 
       elsif Ekind (Gen_Unit) /= E_Generic_Package then
 
@@ -3029,7 +3047,7 @@  package body Sem_Ch12 is
          end if;
 
          Restore_Env;
-         return;
+         goto Leave;
       end if;
 
       if In_Extended_Main_Source_Unit (N) then
@@ -3072,7 +3090,7 @@  package body Sem_Ch12 is
       if In_Open_Scopes (Gen_Unit) then
          Error_Msg_NE ("instantiation of & within itself", N, Gen_Unit);
          Restore_Env;
-         return;
+         goto Leave;
 
       elsif Contains_Instance_Of (Gen_Unit, Current_Scope, Gen_Id) then
          Error_Msg_Node_2 := Current_Scope;
@@ -3080,7 +3098,7 @@  package body Sem_Ch12 is
            ("circular Instantiation: & instantiated in &!", N, Gen_Unit);
          Circularity_Detected := True;
          Restore_Env;
-         return;
+         goto Leave;
 
       else
          Gen_Decl := Unit_Declaration_Node (Gen_Unit);
@@ -3537,6 +3555,8 @@  package body Sem_Ch12 is
          Set_Defining_Identifier (N, Act_Decl_Id);
       end if;
 
+      <<Leave>> Analyze_Aspect_Specifications (N, Act_Decl_Id, AS);
+
    exception
       when Instantiation_Error =>
          if Parent_Installed then
@@ -3890,6 +3910,7 @@  package body Sem_Ch12 is
    is
       Loc    : constant Source_Ptr := Sloc (N);
       Gen_Id : constant Node_Id    := Name (N);
+      AS     : constant List_Id    := Aspect_Specifications (N);
 
       Anon_Id : constant Entity_Id :=
                   Make_Defining_Identifier (Sloc (Defining_Entity (N)),
@@ -4153,7 +4174,7 @@  package body Sem_Ch12 is
             Error_Msg_NE
               ("circular Instantiation: & instantiated in &!", N, Gen_Unit);
             Circularity_Detected := True;
-            return;
+            goto Leave;
          end if;
 
          Gen_Decl := Unit_Declaration_Node (Gen_Unit);
@@ -4311,6 +4332,8 @@  package body Sem_Ch12 is
          Generic_Renamings_HTable.Reset;
       end if;
 
+      <<Leave>> Analyze_Aspect_Specifications (N, Act_Decl_Id, AS);
+
    exception
       when Instantiation_Error =>
          if Parent_Installed then
Index: sem_ch12.ads
===================================================================
--- sem_ch12.ads	(revision 165256)
+++ sem_ch12.ads	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2010, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -34,8 +34,8 @@  package Sem_Ch12 is
    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 Analyze_Formal_Subprogram_Declaration      (N : Node_Id);
+   procedure Analyze_Formal_Package_Declaration         (N : Node_Id);
 
    procedure Start_Generic;
    --  Must be invoked before starting to process a generic spec or body
Index: sem.adb
===================================================================
--- sem.adb	(revision 165279)
+++ sem.adb	(working copy)
@@ -237,10 +237,10 @@  package body Sem is
             Analyze_Formal_Object_Declaration (N);
 
          when N_Formal_Package_Declaration =>
-            Analyze_Formal_Package (N);
+            Analyze_Formal_Package_Declaration (N);
 
          when N_Formal_Subprogram_Declaration =>
-            Analyze_Formal_Subprogram (N);
+            Analyze_Formal_Subprogram_Declaration (N);
 
          when N_Formal_Type_Declaration =>
             Analyze_Formal_Type_Declaration (N);
@@ -252,7 +252,7 @@  package body Sem is
             Analyze_Freeze_Entity (N);
 
          when N_Full_Type_Declaration =>
-            Analyze_Type_Declaration (N);
+            Analyze_Full_Type_Declaration (N);
 
          when N_Function_Call =>
             Analyze_Function_Call (N);
@@ -465,7 +465,7 @@  package body Sem is
             Analyze_Protected_Definition (N);
 
          when N_Protected_Type_Declaration =>
-            Analyze_Protected_Type (N);
+            Analyze_Protected_Type_Declaration (N);
 
          when N_Qualified_Expression =>
             Analyze_Qualified_Expression (N);
@@ -505,10 +505,10 @@  package body Sem is
             Analyze_Selective_Accept (N);
 
          when N_Single_Protected_Declaration =>
-            Analyze_Single_Protected (N);
+            Analyze_Single_Protected_Declaration (N);
 
          when N_Single_Task_Declaration =>
-            Analyze_Single_Task (N);
+            Analyze_Single_Task_Declaration (N);
 
          when N_Slice =>
             Analyze_Slice (N);
@@ -550,7 +550,7 @@  package body Sem is
             Analyze_Task_Definition (N);
 
          when N_Task_Type_Declaration =>
-            Analyze_Task_Type (N);
+            Analyze_Task_Type_Declaration (N);
 
          when N_Terminate_Alternative =>
             Analyze_Terminate_Alternative (N);
Index: par.adb
===================================================================
--- par.adb	(revision 165286)
+++ par.adb	(working copy)
@@ -23,6 +23,7 @@ 
 --                                                                          --
 ------------------------------------------------------------------------------
 
+with Aspects;  use Aspects;
 with Atree;    use Atree;
 with Casing;   use Casing;
 with Debug;    use Debug;
@@ -836,6 +837,25 @@  function Par (Configuration_Pragmas : Bo
    package Ch13 is
       function P_Representation_Clause                return Node_Id;
 
+      function Aspect_Specifications_Present return Boolean;
+      --  This function tests whether the next keyword is WITH followed by
+      --  something that looks reasonably like an aspect specification. If so,
+      --  True is returned. Otherwise False is returned. In either case control
+      --  returns with the token pointer unchanged (i.e. pointing to the WITH
+      --  token in the case where True is returned). This function takes care
+      --  of generating appropriate messages if aspect specifications appear
+      --  in versions of Ada prior to Ada 2012.
+
+      procedure P_Aspect_Specifications (Decl : Node_Id);
+      --  This subprogram is called with the current token pointing to either a
+      --  WITH keyword starting an aspect specification, or a semicolon. In the
+      --  former case, the aspect specifications are scanned out including the
+      --  terminating semicolon, the Has_Aspect_Specifications flag is set in
+      --  the given declaration node, and the list of aspect specifications is
+      --  constructed and associated with this declaration node using a call to
+      --  Set_Aspect_Specifications. If no WITH keyword is present, then this
+      --  call has no effect other than scanning out the semicolon.
+
       function P_Code_Statement (Subtype_Mark : Node_Id) return Node_Id;
       --  Function to parse a code statement. The caller has scanned out
       --  the name to be used as the subtype mark (but has not checked that
Index: par-ch6.adb
===================================================================
--- par-ch6.adb	(revision 165283)
+++ par-ch6.adb	(working copy)
@@ -305,7 +305,7 @@  package body Ch6 is
 
             Set_Defining_Unit_Name (Inst_Node, Name_Node);
             Set_Generic_Associations (Inst_Node, P_Generic_Actual_Part_Opt);
-            TF_Semicolon;
+            P_Aspect_Specifications (Inst_Node);
             Pop_Scope_Stack; -- Don't need scope stack entry in this case
 
             if Is_Overriding then
@@ -525,7 +525,7 @@  package body Ch6 is
                Set_Specification (Absdec_Node, Specification_Node);
                Pop_Scope_Stack; -- discard unneeded entry
                Scan; -- past ABSTRACT
-               TF_Semicolon;
+               P_Aspect_Specifications (Absdec_Node);
                return Absdec_Node;
 
             --  Ada 2005 (AI-248): Parse a null procedure declaration
Index: aspects.adb
===================================================================
--- aspects.adb	(revision 165281)
+++ aspects.adb	(working copy)
@@ -29,10 +29,43 @@ 
 --                                                                          --
 ------------------------------------------------------------------------------
 
+with Atree;  use Atree;
+with Nlists; use Nlists;
+with Sinfo;  use Sinfo;
 with Snames; use Snames;
 
+with GNAT.HTable; use GNAT.HTable;
+
 package body Aspects is
 
+   ------------------------------------------
+   -- Hash Table for Aspect Specifications --
+   ------------------------------------------
+
+   type AS_Hash_Range is range 0 .. 510;
+   --  Size of hash table headers
+
+   function AS_Hash (F : Node_Id) return AS_Hash_Range;
+   --  Hash function for hash table
+
+   function AS_Hash (F : Node_Id) return AS_Hash_Range is
+   begin
+      return AS_Hash_Range (F mod 511);
+   end AS_Hash;
+
+   package Aspect_Specifications_Hash_Table is new
+     GNAT.HTable.Simple_HTable
+       (Header_Num => AS_Hash_Range,
+        Element    => List_Id,
+        No_Element => No_List,
+        Key        => Node_Id,
+        Hash       => AS_Hash,
+        Equal      => "=");
+
+   -----------------------------------------
+   -- Table Linking Names and Aspect_Id's --
+   -----------------------------------------
+
    type Aspect_Entry is record
       Nam : Name_Id;
       Asp : Aspect_Id;
@@ -42,12 +75,10 @@  package body Aspects is
      (Name_Ada_2005,                     Aspect_Ada_2005),
      (Name_Ada_2012,                     Aspect_Ada_2012),
      (Name_Address,                      Aspect_Address),
-     (Name_Aliased,                      Aspect_Aliased),
      (Name_Alignment,                    Aspect_Alignment),
      (Name_Atomic,                       Aspect_Atomic),
      (Name_Atomic_Components,            Aspect_Atomic_Components),
      (Name_Bit_Order,                    Aspect_Bit_Order),
-     (Name_C_Pass_By_Copy,               Aspect_C_Pass_By_Copy),
      (Name_Component_Size,               Aspect_Component_Size),
      (Name_Discard_Names,                Aspect_Discard_Names),
      (Name_External_Tag,                 Aspect_External_Tag),
@@ -60,12 +91,9 @@  package body Aspects is
      (Name_Pack,                         Aspect_Pack),
      (Name_Persistent_BSS,               Aspect_Persistent_BSS),
      (Name_Post,                         Aspect_Post),
-     (Name_Postcondition,                Aspect_Postcondition),
      (Name_Pre,                          Aspect_Pre),
-     (Name_Precondition,                 Aspect_Precondition),
      (Name_Predicate,                    Aspect_Predicate),
      (Name_Preelaborable_Initialization, Aspect_Preelaborable_Initialization),
-     (Name_Psect_Object,                 Aspect_Psect_Object),
      (Name_Pure_Function,                Aspect_Pure_Function),
      (Name_Shared,                       Aspect_Shared),
      (Name_Size,                         Aspect_Size),
@@ -83,8 +111,31 @@  package body Aspects is
      (Name_Value_Size,                   Aspect_Value_Size),
      (Name_Volatile,                     Aspect_Volatile),
      (Name_Volatile_Components,          Aspect_Volatile_Components),
-     (Name_Warnings,                     Aspect_Warnings),
-     (Name_Weak_External,                Aspect_Weak_External));
+     (Name_Warnings,                     Aspect_Warnings));
+
+   -------------------------------------
+   -- Hash Table for Aspect Id Values --
+   -------------------------------------
+
+   type AI_Hash_Range is range 0 .. 112;
+   --  Size of hash table headers
+
+   function AI_Hash (F : Name_Id) return AI_Hash_Range;
+   --  Hash function for hash table
+
+   function AI_Hash (F : Name_Id) return AI_Hash_Range is
+   begin
+      return AI_Hash_Range (F mod 113);
+   end AI_Hash;
+
+   package Aspect_Id_Hash_Table is new
+     GNAT.HTable.Simple_HTable
+       (Header_Num => AI_Hash_Range,
+        Element    => Aspect_Id,
+        No_Element => No_Aspect,
+        Key        => Name_Id,
+        Hash       => AI_Hash,
+        Equal      => "=");
 
    -------------------
    -- Get_Aspect_Id --
@@ -92,13 +143,74 @@  package body Aspects is
 
    function Get_Aspect_Id (Name : Name_Id) return Aspect_Id is
    begin
-      for J in Aspect_Names'Range loop
-         if Aspect_Names (J).Nam = Name then
-            return Aspect_Names (J).Asp;
-         end if;
-      end loop;
-
-      return No_Aspect;
+      return Aspect_Id_Hash_Table.Get (Name);
    end Get_Aspect_Id;
 
+   ---------------------------
+   -- Aspect_Specifications --
+   ---------------------------
+
+   function Aspect_Specifications (N : Node_Id) return List_Id is
+   begin
+      return Aspect_Specifications_Hash_Table.Get (N);
+   end Aspect_Specifications;
+
+   -----------------------------------
+   -- Permits_Aspect_Specifications --
+   -----------------------------------
+
+   Has_Aspect_Specifications_Flag : constant array (Node_Kind) of Boolean :=
+     (N_Abstract_Subprogram_Declaration        => True,
+      N_Component_Declaration                  => True,
+      N_Entry_Declaration                      => True,
+      N_Exception_Declaration                  => True,
+      N_Formal_Abstract_Subprogram_Declaration => True,
+      N_Formal_Concrete_Subprogram_Declaration => True,
+      N_Formal_Object_Declaration              => True,
+      N_Formal_Package_Declaration             => True,
+      N_Formal_Type_Declaration                => True,
+      N_Full_Type_Declaration                  => True,
+      N_Function_Instantiation                 => True,
+      N_Generic_Package_Declaration            => True,
+      N_Generic_Subprogram_Declaration         => True,
+      N_Object_Declaration                     => True,
+      N_Package_Declaration                    => True,
+      N_Package_Instantiation                  => True,
+      N_Private_Extension_Declaration          => True,
+      N_Private_Type_Declaration               => True,
+      N_Procedure_Instantiation                => True,
+      N_Protected_Type_Declaration             => True,
+      N_Single_Protected_Declaration           => True,
+      N_Single_Task_Declaration                => True,
+      N_Subprogram_Declaration                 => True,
+      N_Subtype_Declaration                    => True,
+      N_Task_Type_Declaration                  => True,
+      others                                   => False);
+
+   function Permits_Aspect_Specifications (N : Node_Id) return Boolean is
+   begin
+      return Has_Aspect_Specifications_Flag (Nkind (N));
+   end Permits_Aspect_Specifications;
+
+   -------------------------------
+   -- Set_Aspect_Specifications --
+   -------------------------------
+
+   procedure Set_Aspect_Specifications (N : Node_Id; L : List_Id) is
+   begin
+      pragma Assert (Permits_Aspect_Specifications (N));
+      pragma Assert (not Has_Aspect_Specifications (N));
+      pragma Assert (L /= No_List);
+
+      Set_Has_Aspect_Specifications (N);
+      Set_Parent (L, N);
+      Aspect_Specifications_Hash_Table.Set (N, L);
+   end Set_Aspect_Specifications;
+
+--  Package initialization sets up Aspect Id hash table
+
+begin
+   for J in Aspect_Names'Range loop
+      Aspect_Id_Hash_Table.Set (Aspect_Names (J).Nam, Aspect_Names (J).Asp);
+   end loop;
 end Aspects;
Index: aspects.ads
===================================================================
--- aspects.ads	(revision 165281)
+++ aspects.ads	(working copy)
@@ -29,25 +29,27 @@ 
 --                                                                          --
 ------------------------------------------------------------------------------
 
---  This package defines the aspects that are recognized in aspect
---  specifications. We separate this off in its own packages to that
---  it can be accessed by the parser without dragging in Sem_Asp
+--  This package defines the aspects that are recognized by GNAT in aspect
+--  specifications. It also contains the subprograms for storing/retrieving
+--  aspect speciciations from the tree. The semantic processing for aspect
+--  specifications is found in Sem_Ch13.Analyze_Aspect_Specifications.
 
 with Namet; use Namet;
+with Types; use Types;
 
 package Aspects is
 
+   --  Type defining recognized aspects
+
    type Aspect_Id is
      (No_Aspect,                            -- Dummy entry for no aspect
       Aspect_Ada_2005,                      -- GNAT
       Aspect_Ada_2012,                      -- GNAT
       Aspect_Address,
-      Aspect_Aliased,
       Aspect_Alignment,
       Aspect_Atomic,
       Aspect_Atomic_Components,
       Aspect_Bit_Order,
-      Aspect_C_Pass_By_Copy,
       Aspect_Component_Size,
       Aspect_Discard_Names,
       Aspect_External_Tag,
@@ -56,16 +58,14 @@  package Aspects is
       Aspect_Inline_Always,                 -- GNAT
       Aspect_Invariant,
       Aspect_Machine_Radix,
+      Aspect_No_Return,
       Aspect_Object_Size,                   -- GNAT
       Aspect_Pack,
       Aspect_Persistent_BSS,                -- GNAT
       Aspect_Post,
-      Aspect_Postcondition,                 -- GNAT (equivalent to Post)
       Aspect_Pre,
-      Aspect_Precondition,                  -- GNAT (equivalent to Pre)
       Aspect_Predicate,                     -- GNAT???
       Aspect_Preelaborable_Initialization,
-      Aspect_Psect_Object,                  -- GNAT
       Aspect_Pure_Function,                 -- GNAT
       Aspect_Shared,                        -- GNAT (equivalent to Atomic)
       Aspect_Size,
@@ -83,17 +83,15 @@  package Aspects is
       Aspect_Value_Size,                    -- GNAT
       Aspect_Volatile,
       Aspect_Volatile_Components,
-      Aspect_Warnings,                      -- GNAT
-      Aspect_Weak_External);                -- GNAT
+      Aspect_Warnings);                     -- GNAT
 
    --  The following array indicates aspects that accept 'Class
 
    Class_Aspect_OK : constant array (Aspect_Id) of Boolean :=
                        (Aspect_Invariant     => True,
                         Aspect_Pre           => True,
-                        Aspect_Precondition  => True,
+                        Aspect_Predicate     => True,
                         Aspect_Post          => True,
-                        Aspect_Postcondition => True,
                         others               => False);
 
    --  The following type is used for indicating allowed expression forms
@@ -110,12 +108,10 @@  package Aspects is
                         Aspect_Ada_2005                     => Optional,
                         Aspect_Ada_2012                     => Optional,
                         Aspect_Address                      => Expression,
-                        Aspect_Aliased                      => Optional,
                         Aspect_Alignment                    => Expression,
                         Aspect_Atomic                       => Optional,
                         Aspect_Atomic_Components            => Optional,
                         Aspect_Bit_Order                    => Expression,
-                        Aspect_C_Pass_By_Copy               => Optional,
                         Aspect_Component_Size               => Expression,
                         Aspect_Discard_Names                => Optional,
                         Aspect_External_Tag                 => Expression,
@@ -124,20 +120,18 @@  package Aspects is
                         Aspect_Inline_Always                => Optional,
                         Aspect_Invariant                    => Expression,
                         Aspect_Machine_Radix                => Expression,
+                        Aspect_No_Return                    => Optional,
                         Aspect_Object_Size                  => Expression,
-                        Aspect_Pack                         => Optional,
                         Aspect_Persistent_BSS               => Optional,
+                        Aspect_Pack                         => Optional,
                         Aspect_Post                         => Expression,
-                        Aspect_Postcondition                => Expression,
                         Aspect_Pre                          => Expression,
-                        Aspect_Precondition                 => Expression,
                         Aspect_Predicate                    => Expression,
                         Aspect_Preelaborable_Initialization => Optional,
-                        Aspect_Psect_Object                 => Optional,
                         Aspect_Pure_Function                => Optional,
                         Aspect_Shared                       => Optional,
                         Aspect_Size                         => Expression,
-                        Aspect_Storage_Pool                 => Expression,
+                        Aspect_Storage_Pool                 => Name,
                         Aspect_Storage_Size                 => Expression,
                         Aspect_Stream_Size                  => Expression,
                         Aspect_Suppress                     => Name,
@@ -151,11 +145,50 @@  package Aspects is
                         Aspect_Value_Size                   => Expression,
                         Aspect_Volatile                     => Optional,
                         Aspect_Volatile_Components          => Optional,
-                        Aspect_Warnings                     => Name,
-                        Aspect_Weak_External                => Optional);
+                        Aspect_Warnings                     => Name);
 
    function Get_Aspect_Id (Name : Name_Id) return Aspect_Id;
+   pragma Inline (Get_Aspect_Id);
    --  Given a name Nam, returns the corresponding aspect id value. If the name
    --  does not match any aspect, then No_Aspect is returned as the result.
 
+   ---------------------------------------------------
+   -- Handling of Aspect Specifications in the Tree --
+   ---------------------------------------------------
+
+   --  Several kinds of declaration node permit aspect specifications in Ada
+   --  2012 mode. If there was room in all the corresponding declaration nodes,
+   --  we could just have a field Aspect_Specifications pointing to a list of
+   --  nodes for the aspects (N_Aspect_Specification nodes). But there isn't
+   --  room, so we adopt a different approach.
+
+   --  The following subprograms provide access to a specialized interface
+   --  implemented internally with a hash table in the body, that provides
+   --  access to aspect specifications.
+
+   function Permits_Aspect_Specifications (N : Node_Id) return Boolean;
+   --  Returns True if the node N is a declaration node that permits aspect
+   --  specifications. All such nodes have the Has_Aspect_Specifications
+   --  flag defined. Returns False for all other nodes.
+
+   function Aspect_Specifications (N : Node_Id) return List_Id;
+   --  Given a node N, returns the list of N_Aspect_Specification nodes that
+   --  are attached to this declaration node. If the node is in the class of
+   --  declaration nodes that permit aspect specifications, as defined by the
+   --  predicate above, and if their Has_Aspect_Specifications flag is set to
+   --  True, then this will always be a non-empty list. If this flag is set to
+   --  False, or the node is not in the declaration class permitting aspect
+   --  specifications, then No_List is returned.
+
+   procedure Set_Aspect_Specifications (N : Node_Id; L : List_Id);
+   --  The node N must be in the class of declaration nodes that permit aspect
+   --  specifications and the Has_Aspect_Specifications flag must be False on
+   --  entry. L must be a non-empty list of N_Aspect_Specification nodes. This
+   --  procedure sets the Has_Aspect_Specifications flag to True, and makes an
+   --  entry that can be retrieved by a subsequent Aspect_Specifications call.
+   --  The parent of list L is set to reference the declaration node N. It is
+   --  an error to call this procedure with a node that does not permit aspect
+   --  specifications, or a node that has its Has_Aspect_Specifications flag
+   --  set True on entry, or with L being an empty list or No_List.
+
 end Aspects;
Index: sem_ch6.adb
===================================================================
--- sem_ch6.adb	(revision 165295)
+++ sem_ch6.adb	(working copy)
@@ -23,6 +23,7 @@ 
 --                                                                          --
 ------------------------------------------------------------------------------
 
+with Aspects;  use Aspects;
 with Atree;    use Atree;
 with Checks;   use Checks;
 with Debug;    use Debug;
@@ -59,6 +60,7 @@  with Sem_Ch5;  use Sem_Ch5;
 with Sem_Ch8;  use Sem_Ch8;
 with Sem_Ch10; use Sem_Ch10;
 with Sem_Ch12; use Sem_Ch12;
+with Sem_Ch13; use Sem_Ch13;
 with Sem_Disp; use Sem_Disp;
 with Sem_Dist; use Sem_Dist;
 with Sem_Elim; use Sem_Elim;
@@ -352,6 +354,7 @@  package body Sem_Ch6 is
       Designator : constant Entity_Id :=
                      Analyze_Subprogram_Specification (Specification (N));
       Scop       : constant Entity_Id := Current_Scope;
+      AS         : constant List_Id   := Aspect_Specifications (N);
 
    begin
       Generate_Definition (Designator);
@@ -381,6 +384,7 @@  package body Sem_Ch6 is
 
       Generate_Reference_To_Formals (Designator);
       Check_Eliminated (Designator);
+      Analyze_Aspect_Specifications (N, Designator, AS);
    end Analyze_Abstract_Subprogram_Declaration;
 
    ----------------------------------------
@@ -2696,9 +2700,10 @@  package body Sem_Ch6 is
 
    procedure Analyze_Subprogram_Declaration (N : Node_Id) is
       Loc        : constant Source_Ptr := Sloc (N);
+      AS         : constant List_Id    := Aspect_Specifications (N);
+      Scop       : constant Entity_Id  := Current_Scope;
       Designator : Entity_Id;
       Form       : Node_Id;
-      Scop       : constant Entity_Id := Current_Scope;
       Null_Body  : Node_Id := Empty;
 
    --  Start of processing for Analyze_Subprogram_Declaration
@@ -2891,6 +2896,8 @@  package body Sem_Ch6 is
          Write_Location (Sloc (N));
          Write_Eol;
       end if;
+
+      Analyze_Aspect_Specifications (N, Designator, AS);
    end Analyze_Subprogram_Declaration;
 
    --------------------------------------
@@ -8334,20 +8341,19 @@  package body Sem_Ch6 is
                      if Is_Tagged_Type (Formal_Type) then
                         null;
 
-                     elsif Nkind_In (Parent (Parent (T)),
-                        N_Accept_Statement,
-                        N_Entry_Body,
-                        N_Subprogram_Body)
+                     elsif Nkind_In (Parent (Parent (T)), N_Accept_Statement,
+                                                          N_Entry_Body,
+                                                          N_Subprogram_Body)
                      then
                         Error_Msg_NE
                           ("invalid use of untagged incomplete type&",
-                             Ptype, Formal_Type);
+                           Ptype, Formal_Type);
                      end if;
 
                   else
                      Error_Msg_NE
                        ("invalid use of incomplete type&",
-                          Param_Spec, Formal_Type);
+                        Param_Spec, Formal_Type);
 
                      --  Further checks on the legality of incomplete types
                      --  in formal parts are delayed until the freeze point
@@ -8356,8 +8362,9 @@  package body Sem_Ch6 is
                end if;
 
             elsif Ekind (Formal_Type) = E_Void then
-               Error_Msg_NE ("premature use of&",
-                 Parameter_Type (Param_Spec), Formal_Type);
+               Error_Msg_NE
+                 ("premature use of&",
+                  Parameter_Type (Param_Spec), Formal_Type);
             end if;
 
             --  Ada 2005 (AI-231): Create and decorate an internal subtype
@@ -8378,8 +8385,7 @@  package body Sem_Ch6 is
                   then
                      Error_Msg_NE
                        ("`NOT NULL` not allowed (& already excludes null)",
-                        Param_Spec,
-                        Formal_Type);
+                        Param_Spec, Formal_Type);
                   end if;
 
                   Formal_Type :=
Index: sem_ch11.adb
===================================================================
--- sem_ch11.adb	(revision 165256)
+++ sem_ch11.adb	(working copy)
@@ -23,6 +23,7 @@ 
 --                                                                          --
 ------------------------------------------------------------------------------
 
+with Aspects;  use Aspects;
 with Atree;    use Atree;
 with Checks;   use Checks;
 with Einfo;    use Einfo;
@@ -39,6 +40,7 @@  with Rtsfind;  use Rtsfind;
 with Sem;      use Sem;
 with Sem_Ch5;  use Sem_Ch5;
 with Sem_Ch8;  use Sem_Ch8;
+with Sem_Ch13; use Sem_Ch13;
 with Sem_Res;  use Sem_Res;
 with Sem_Util; use Sem_Util;
 with Sem_Warn; use Sem_Warn;
@@ -55,6 +57,7 @@  package body Sem_Ch11 is
    procedure Analyze_Exception_Declaration (N : Node_Id) is
       Id : constant Entity_Id := Defining_Identifier (N);
       PF : constant Boolean   := Is_Pure (Current_Scope);
+      AS : constant List_Id   := Aspect_Specifications (N);
    begin
       Generate_Definition         (Id);
       Enter_Name                  (Id);
@@ -63,6 +66,7 @@  package body Sem_Ch11 is
       Set_Etype                   (Id, Standard_Exception_Type);
       Set_Is_Statically_Allocated (Id);
       Set_Is_Pure                 (Id, PF);
+      Analyze_Aspect_Specifications (N, Id, AS);
    end Analyze_Exception_Declaration;
 
    --------------------------------
Index: sem_cat.adb
===================================================================
--- sem_cat.adb	(revision 165283)
+++ sem_cat.adb	(working copy)
@@ -1754,8 +1754,8 @@  package body Sem_Cat is
    --  Start of processing for Validate_Remote_Access_Object_Type_Declaration
 
    begin
-      --  We are called from Analyze_Type_Declaration, and the Nkind of the
-      --  given node is N_Access_To_Object_Definition.
+      --  We are called from Analyze_Full_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))
@@ -2055,7 +2055,7 @@  package body Sem_Cat is
    --  Start of processing for Validate_SP_Access_Object_Type_Decl
 
    begin
-      --  We are called from Sem_Ch3.Analyze_Type_Declaration, and the
+      --  We are called from Sem_Ch3.Analyze_Full_Type_Declaration, and the
       --  Nkind of the given entity is N_Access_To_Object_Definition.
 
       if not Comes_From_Source (T)
Index: sprint.adb
===================================================================
--- sprint.adb	(revision 165281)
+++ sprint.adb	(working copy)
@@ -23,6 +23,7 @@ 
 --                                                                          --
 ------------------------------------------------------------------------------
 
+with Aspects;  use Aspects;
 with Atree;    use Atree;
 with Casing;   use Casing;
 with Csets;    use Csets;
@@ -182,6 +183,12 @@  package body Sprint is
    procedure Sprint_And_List (List : List_Id);
    --  Print the given list with items separated by vertical "and"
 
+   procedure Sprint_Aspect_Specifications (Node : Node_Id);
+   --  Node is a declaration node that accepts aspect specifications. This
+   --  procedure tests if aspect specifications are present, and if so prints
+   --  them, with a terminating semicolon. If no aspect specifications are
+   --  present, then a single semicolon is output.
+
    procedure Sprint_Bar_List (List : List_Id);
    --  Print the given list with items separated by vertical bars
 
@@ -619,6 +626,48 @@  package body Sprint is
       end if;
    end Sprint_And_List;
 
+   ----------------------------------
+   -- Sprint_Aspect_Specifications --
+   ----------------------------------
+
+   procedure Sprint_Aspect_Specifications (Node : Node_Id) is
+      AS : List_Id;
+      A  : Node_Id;
+
+   begin
+      if Has_Aspect_Specifications (Node) then
+         AS := Aspect_Specifications (Node);
+         Indent := Indent + 2;
+         Write_Indent;
+         Write_Str ("with ");
+         Indent := Indent + 5;
+
+         A := First (AS);
+         loop
+            Sprint_Node (Identifier (A));
+
+            if Class_Present (A) then
+               Write_Str ("'Class");
+            end if;
+
+            if Present (Expression (A)) then
+               Write_Str (" => ");
+               Sprint_Node (Expression (A));
+            end if;
+
+            Next (A);
+
+            exit when No (A);
+            Write_Char (',');
+            Write_Indent;
+         end loop;
+
+         Indent := Indent - 7;
+      end if;
+
+      Write_Char (';');
+   end Sprint_Aspect_Specifications;
+
    ---------------------
    -- Sprint_Bar_List --
    ---------------------
@@ -815,7 +864,8 @@  package body Sprint is
             Write_Indent;
             Sprint_Node (Specification (Node));
             Write_Str_With_Col_Check (" is ");
-            Write_Str_Sloc ("abstract;");
+            Write_Str_Sloc ("abstract");
+            Sprint_Aspect_Specifications (Node);
 
          when N_Accept_Alternative =>
             Sprint_Node_List (Pragmas_Before (Node));
@@ -1224,7 +1274,7 @@  package body Sprint is
                   Sprint_Node (Expression (Node));
                end if;
 
-               Write_Char (';');
+               Sprint_Aspect_Specifications (Node);
             end if;
 
          when N_Component_List =>
@@ -1453,7 +1503,7 @@  package body Sprint is
             end if;
 
             Write_Param_Specs (Node);
-            Write_Char (';');
+            Sprint_Aspect_Specifications (Node);
 
          when N_Entry_Index_Specification =>
             Write_Str_With_Col_Check_Sloc ("for ");
@@ -1499,7 +1549,7 @@  package body Sprint is
                   Sprint_Node (Expression (Node));
                end if;
 
-               Write_Char (';');
+               Sprint_Aspect_Specifications (Node);
             end if;
 
          when N_Exception_Handler =>
@@ -1625,7 +1675,7 @@  package body Sprint is
                Sprint_Node (Default_Name (Node));
             end if;
 
-            Write_Char (';');
+            Sprint_Aspect_Specifications (Node);
 
          when N_Formal_Concrete_Subprogram_Declaration =>
             Write_Indent_Str_Sloc ("with ");
@@ -1638,7 +1688,7 @@  package body Sprint is
                Sprint_Node (Default_Name (Node));
             end if;
 
-            Write_Char (';');
+            Sprint_Aspect_Specifications (Node);
 
          when N_Formal_Discrete_Type_Definition =>
             Write_Str_With_Col_Check_Sloc ("<>");
@@ -1686,7 +1736,7 @@  package body Sprint is
                   Sprint_Node (Default_Expression (Node));
                end if;
 
-               Write_Char (';');
+               Sprint_Aspect_Specifications (Node);
             end if;
 
          when N_Formal_Ordinary_Fixed_Point_Definition =>
@@ -1697,7 +1747,8 @@  package body Sprint is
             Write_Id (Defining_Identifier (Node));
             Write_Str_With_Col_Check (" is new ");
             Sprint_Node (Name (Node));
-            Write_Str_With_Col_Check (" (<>);");
+            Write_Str_With_Col_Check (" (<>)");
+            Sprint_Aspect_Specifications (Node);
 
          when N_Formal_Private_Type_Definition =>
             if Abstract_Present (Node) then
@@ -1729,7 +1780,7 @@  package body Sprint is
 
             Write_Str_With_Col_Check (" is ");
             Sprint_Node (Formal_Type_Definition (Node));
-            Write_Char (';');
+            Sprint_Aspect_Specifications (Node);
 
          when N_Free_Statement =>
             Write_Indent_Str_Sloc ("free ");
@@ -1770,7 +1821,7 @@  package body Sprint is
             Write_Discr_Specs (Node);
             Write_Str_With_Col_Check (" is ");
             Sprint_Node (Type_Definition (Node));
-            Write_Char (';');
+            Sprint_Aspect_Specifications (Node);
 
          when N_Function_Call =>
             Set_Debug_Sloc;
@@ -1783,7 +1834,7 @@  package body Sprint is
             Write_Str_With_Col_Check (" is new ");
             Sprint_Node (Name (Node));
             Sprint_Opt_Paren_Comma_List (Generic_Associations (Node));
-            Write_Char (';');
+            Sprint_Aspect_Specifications (Node);
 
          when N_Function_Specification =>
             Write_Str_With_Col_Check_Sloc ("function ");
@@ -1824,7 +1875,7 @@  package body Sprint is
             Sprint_Indented_List (Generic_Formal_Declarations (Node));
             Write_Indent;
             Sprint_Node (Specification (Node));
-            Write_Char (';');
+            Sprint_Aspect_Specifications (Node);
 
          when N_Generic_Package_Renaming_Declaration =>
             Write_Indent_Str_Sloc ("generic package ");
@@ -1846,7 +1897,7 @@  package body Sprint is
             Sprint_Indented_List (Generic_Formal_Declarations (Node));
             Write_Indent;
             Sprint_Node (Specification (Node));
-            Write_Char (';');
+            Sprint_Aspect_Specifications (Node);
 
          when N_Goto_Statement =>
             Write_Indent_Str_Sloc ("goto ");
@@ -2077,7 +2128,7 @@  package body Sprint is
                      Sprint_Node (Expression (Node));
                   end if;
 
-                  Write_Char (';');
+                  Sprint_Aspect_Specifications (Node);
 
                   --  Handle implicit importation and implicit exportation of
                   --  object declarations:
@@ -2318,7 +2369,7 @@  package body Sprint is
             Extra_Blank_Line;
             Write_Indent;
             Sprint_Node_Sloc (Specification (Node));
-            Write_Char (';');
+            Sprint_Aspect_Specifications (Node);
 
          when N_Package_Instantiation =>
             Extra_Blank_Line;
@@ -2327,7 +2378,7 @@  package body Sprint is
             Write_Str (" is new ");
             Sprint_Node (Name (Node));
             Sprint_Opt_Paren_Comma_List (Generic_Associations (Node));
-            Write_Char (';');
+            Sprint_Aspect_Specifications (Node);
 
          when N_Package_Renaming_Declaration =>
             Write_Indent_Str_Sloc ("package ");
@@ -2410,6 +2461,50 @@  package body Sprint is
          when N_Pop_Storage_Error_Label =>
             Write_Indent_Str ("%pop_storage_error_label");
 
+         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));
+
+            if Present (Interface_List (Node)) then
+               Write_Str_With_Col_Check (" and ");
+               Sprint_And_List (Interface_List (Node));
+            end if;
+
+            Write_Str_With_Col_Check (" with private");
+            Sprint_Aspect_Specifications (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");
+            Sprint_Aspect_Specifications (Node);
+
          when N_Push_Constraint_Error_Label =>
             Write_Indent_Str ("%push_constraint_error_label (");
 
@@ -2458,48 +2553,6 @@  package body Sprint is
 
             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));
-
-            if Present (Interface_List (Node)) then
-               Write_Str_With_Col_Check (" and ");
-               Sprint_And_List (Interface_List (Node));
-            end if;
-
-            Write_Str_With_Col_Check (" with private;");
-
          when N_Procedure_Call_Statement =>
             Write_Indent;
             Set_Debug_Sloc;
@@ -2513,7 +2566,7 @@  package body Sprint is
             Write_Str_With_Col_Check (" is new ");
             Sprint_Node (Name (Node));
             Sprint_Opt_Paren_Comma_List (Generic_Associations (Node));
-            Write_Char (';');
+            Sprint_Aspect_Specifications (Node);
 
          when N_Procedure_Specification =>
             Write_Str_With_Col_Check_Sloc ("procedure ");
@@ -2560,7 +2613,7 @@  package body Sprint is
 
             Sprint_Node (Protected_Definition (Node));
             Write_Id (Defining_Identifier (Node));
-            Write_Char (';');
+            Sprint_Aspect_Specifications (Node);
 
          when N_Qualified_Expression =>
             Sprint_Node (Subtype_Mark (Node));
@@ -2756,7 +2809,7 @@  package body Sprint is
             Write_Str (" is");
             Sprint_Node (Protected_Definition (Node));
             Write_Id (Defining_Identifier (Node));
-            Write_Char (';');
+            Sprint_Aspect_Specifications (Node);
 
          when N_Single_Task_Declaration =>
             Write_Indent_Str_Sloc ("task ");
@@ -2767,7 +2820,7 @@  package body Sprint is
                Sprint_Node (Task_Definition (Node));
             end if;
 
-            Write_Char (';');
+            Sprint_Aspect_Specifications (Node);
 
          when N_Selected_Component =>
             Sprint_Node (Prefix (Node));
@@ -2840,7 +2893,7 @@  package body Sprint is
                Write_Str_With_Col_Check (" is null");
             end if;
 
-            Write_Char (';');
+            Sprint_Aspect_Specifications (Node);
 
          when N_Subprogram_Info =>
             Sprint_Node (Identifier (Node));
@@ -2865,7 +2918,7 @@  package body Sprint is
             end if;
 
             Sprint_Node (Subtype_Indication (Node));
-            Write_Char (';');
+            Sprint_Aspect_Specifications (Node);
 
          when N_Subtype_Indication =>
             Sprint_Node_Sloc (Subtype_Mark (Node));
@@ -2928,11 +2981,10 @@  package body Sprint is
                Sprint_Node (Task_Definition (Node));
             end if;
 
-            Write_Char (';');
+            Sprint_Aspect_Specifications (Node);
 
          when N_Terminate_Alternative =>
             Sprint_Node_List (Pragmas_Before (Node));
-
             Write_Indent;
 
             if Present (Condition (Node)) then
Index: sem_ch13.adb
===================================================================
--- sem_ch13.adb	(revision 165283)
+++ sem_ch13.adb	(working copy)
@@ -23,6 +23,7 @@ 
 --                                                                          --
 ------------------------------------------------------------------------------
 
+with Aspects;  use Aspects;
 with Atree;    use Atree;
 with Checks;   use Checks;
 with Einfo;    use Einfo;
@@ -618,6 +619,217 @@  package body Sem_Ch13 is
       end if;
    end Alignment_Check_For_Esize_Change;
 
+   -----------------------------------
+   -- Analyze_Aspect_Specifications --
+   -----------------------------------
+
+   procedure Analyze_Aspect_Specifications
+     (N : Node_Id;
+      E : Entity_Id;
+      L : List_Id)
+   is
+      Aspect : Node_Id;
+      Ent    : Node_Id;
+      Result : Boolean;
+      Ritem  : Node_Id;
+
+      Ins_Node : Node_Id := N;
+      --  Insert pragmas after this node
+
+   begin
+      if L = No_List then
+         return;
+      end if;
+
+      Aspect := First (L);
+      while Present (Aspect) loop
+         declare
+            Id   : constant Node_Id  := Identifier (Aspect);
+            Expr : constant Node_Id  := Expression (Aspect);
+            Nam  : constant Name_Id  := Chars (Id);
+            Anod : Node_Id;
+
+         begin
+            --  Check for duplicate aspect
+
+            Anod := First (L);
+            while Anod /= Aspect loop
+               if Nam = Chars (Identifier (Anod)) then
+                  Error_Msg_Name_1 := Nam;
+                  Error_Msg_Sloc := Sloc (Anod);
+                  Error_Msg_NE
+                    ("aspect% for & ignored, already given at#", Id, E);
+                  goto Continue;
+               end if;
+
+               Next (Anod);
+            end loop;
+
+            --  Processing based on specific aspect
+
+            case Get_Aspect_Id (Nam) is
+
+               --  No_Aspect should be impossible
+
+               when No_Aspect =>
+                  raise Program_Error;
+
+                  --  Aspects taking an optional boolean argument. For all of
+                  --  these we just create a matching pragma and insert it,
+                  --  setting flag Cancel_Aspect if the expression is False.
+
+               when Aspect_Ada_2005                     |
+                    Aspect_Ada_2012                     |
+                    Aspect_Atomic                       |
+                    Aspect_Atomic_Components            |
+                    Aspect_Discard_Names                |
+                    Aspect_Favor_Top_Level              |
+                    Aspect_Inline                       |
+                    Aspect_Inline_Always                |
+                    Aspect_No_Return                    |
+                    Aspect_Pack                         |
+                    Aspect_Persistent_BSS               |
+                    Aspect_Preelaborable_Initialization |
+                    Aspect_Pure_Function                |
+                    Aspect_Shared                       |
+                    Aspect_Suppress_Debug_Info          |
+                    Aspect_Unchecked_Union              |
+                    Aspect_Universal_Aliasing           |
+                    Aspect_Unmodified                   |
+                    Aspect_Unreferenced                 |
+                    Aspect_Unreferenced_Objects         |
+                    Aspect_Volatile                     |
+                    Aspect_Volatile_Components          =>
+
+                  if No (Expr) then
+                     Result := True;
+
+                  else
+                     Analyze_And_Resolve (Expr);
+
+                     if not Is_OK_Static_Expression (Expr) then
+                        Error_Msg_N
+                          ("static boolean expression required here", Expr);
+                        Result := True;
+
+                     else
+                        Result := Is_True (Expr_Value (Expr));
+                     end if;
+                  end if;
+
+                  Ent := New_Occurrence_Of (E, Sloc (Id));
+
+                  Ritem :=
+                    Make_Pragma (Sloc (Aspect),
+                      Pragma_Argument_Associations => New_List (Ent),
+                      Pragma_Identifier            =>
+                         Make_Identifier (Sloc (Id), Chars (Id)));
+
+                  if Result = False then
+                     Set_Aspect_Cancel (Ritem);
+                  end if;
+
+               --  Aspects corresponding to attribute definition clauses. We
+               --  create the matching clause and insert it following the
+               --  declaration in the tree.
+
+               when Aspect_Address        |
+                    Aspect_Alignment      |
+                    Aspect_Bit_Order      |
+                    Aspect_Component_Size |
+                    Aspect_External_Tag   |
+                    Aspect_Machine_Radix  |
+                    Aspect_Object_Size    |
+                    Aspect_Size           |
+                    Aspect_Storage_Pool   |
+                    Aspect_Storage_Size   |
+                    Aspect_Stream_Size    |
+                    Aspect_Value_Size     =>
+
+                  Ritem :=
+                    Make_Attribute_Definition_Clause (Sloc (Aspect),
+                      Name       => New_Occurrence_Of (E, Sloc (Id)),
+                      Chars      => Chars (Id),
+                      Expression => Relocate_Node (Expr));
+
+               --  Aspects corresponding to pragmas with two arguments, where
+               --  the first argument is a local name referring to the entity,
+               --  and the second argument is the aspect definition expression.
+
+               when Aspect_Suppress   |
+                    Aspect_Unsuppress =>
+
+                  Ritem :=
+                    Make_Pragma (Sloc (Aspect),
+                      Pragma_Argument_Associations => New_List (
+                        New_Occurrence_Of (E, Sloc (Expr)),
+                        Relocate_Node (Expr)),
+                      Pragma_Identifier            =>
+                         Make_Identifier (Sloc (Id), Chars (Id)));
+
+               --  Aspects corresponding to pragmas with two arguments, where
+               --  the second argument is a local name referring to the entity,
+               --  and the first argument is the aspect definition expression.
+
+               when Aspect_Warnings =>
+
+                  Ritem :=
+                    Make_Pragma (Sloc (Aspect),
+                      Pragma_Argument_Associations => New_List (
+                        Relocate_Node (Expr),
+                        New_Occurrence_Of (E, Sloc (Expr))),
+                      Pragma_Identifier            =>
+                         Make_Identifier (Sloc (Id), Chars (Id)));
+
+               --  Aspect Post corresponds to pragma Postcondition with single
+               --  argument that is the expression (we never give a message
+               --  argument. This is inserted right after the declaration, to
+               --  to get the required pragma placement.
+
+               when Aspect_Post =>
+
+                  Insert_After (N,
+                    Make_Pragma (Sloc (Expr),
+                      Pragma_Argument_Associations => New_List (
+                        Relocate_Node (Expr)),
+                      Pragma_Identifier            =>
+                         Make_Identifier (Sloc (Id), Name_Postcondition)));
+                  goto Continue;
+
+               --  Aspect Pre corresponds to pragma Precondition with single
+               --  argument that is the expression (we never give a message
+               --  argument. This is inserted right after the declaration, to
+               --  get the required pragma placement.
+
+               when Aspect_Pre =>
+
+                  Insert_After (N,
+                    Make_Pragma (Sloc (Expr),
+                      Pragma_Argument_Associations => New_List (
+                        Relocate_Node (Expr)),
+                      Pragma_Identifier            =>
+                        Make_Identifier (Sloc (Id), Name_Precondition)));
+                  goto Continue;
+
+               --  Aspects currently unimplemented
+
+               when Aspect_Invariant |
+                    Aspect_Predicate =>
+
+                  Error_Msg_N ("aspect& not implemented", Identifier (Aspect));
+                  goto Continue;
+            end case;
+
+            Set_From_Aspect_Specification (Ritem);
+            Insert_After (Ins_Node, Ritem);
+            Ins_Node := Ritem;
+         end;
+
+         <<Continue>>
+            Next (Aspect);
+      end loop;
+   end Analyze_Aspect_Specifications;
+
    -----------------------
    -- Analyze_At_Clause --
    -----------------------
@@ -684,6 +896,12 @@  package body Sem_Ch13 is
       --  Common processing for 'Read, 'Write, 'Input and 'Output attribute
       --  definition clauses.
 
+      function Duplicate_Clause return Boolean;
+      --  This routine checks if the aspect for U_Ent being given by attribute
+      --  definition clause N is for an aspect that has already been specified,
+      --  and if so gives an error message. If there is a duplicate, True is
+      --  returned, otherwise if there is no error, False is returned.
+
       -----------------------------------
       -- Analyze_Stream_TSS_Definition --
       -----------------------------------
@@ -820,6 +1038,40 @@  package body Sem_Ch13 is
          end if;
       end Analyze_Stream_TSS_Definition;
 
+      ----------------------
+      -- Duplicate_Clause --
+      ----------------------
+
+      function Duplicate_Clause return Boolean is
+         A   : constant Node_Id :=
+                 Get_Attribute_Definition_Clause
+                   (U_Ent, Get_Attribute_Id (Chars (N)));
+
+      begin
+         --  Nothing to do if this attribute definition clause comes from an
+         --  aspect specification, since we could not be duplicating an
+         --  explicit clause, and we dealt with the case of duplicated aspects
+         --  in Analyze_Aspect_Specifications.
+
+         if From_Aspect_Specification (N) then
+            return False;
+         end if;
+
+         --  Otherwise current pragma may duplicate previous pragma or a
+         --  previously given aspect specification for the same pragma.
+
+         if Present (A) then
+            if Entity (A) = U_Ent then
+               Error_Msg_Name_1 := Chars (N);
+               Error_Msg_Sloc := Sloc (A);
+               Error_Msg_NE ("aspect% for & previously specified#", N, U_Ent);
+               return True;
+            end if;
+         end if;
+
+         return False;
+      end Duplicate_Clause;
+
    --  Start of processing for Analyze_Attribute_Definition_Clause
 
    begin
@@ -928,6 +1180,8 @@  package body Sem_Ch13 is
          return;
       end if;
 
+      Set_Entity (N, U_Ent);
+
       --  Switch on particular attribute
 
       case Id is
@@ -969,8 +1223,8 @@  package body Sem_Ch13 is
                return;
             end if;
 
-            if Present (Address_Clause (U_Ent)) then
-               Error_Msg_N ("address already given for &", Nam);
+            if Duplicate_Clause then
+               null;
 
             --  Case of address clause for subprogram
 
@@ -1235,9 +1489,8 @@  package body Sem_Ch13 is
             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 Duplicate_Clause then
+               null;
 
             elsif Align /= No_Uint then
                Set_Has_Alignment_Clause (U_Ent);
@@ -1266,6 +1519,9 @@  package body Sem_Ch13 is
                Error_Msg_N
                  ("Bit_Order can only be defined for record type", Nam);
 
+            elsif Duplicate_Clause then
+               null;
+
             else
                Analyze_And_Resolve (Expr, RTE (RE_Bit_Order));
 
@@ -1307,9 +1563,8 @@  package body Sem_Ch13 is
             Btype := Base_Type (U_Ent);
             Ctyp := Component_Type (Btype);
 
-            if Has_Component_Size_Clause (Btype) then
-               Error_Msg_N
-                 ("component size clause for& previously given", Nam);
+            if Duplicate_Clause then
+               null;
 
             elsif Rep_Item_Too_Early (Btype, N) then
                null;
@@ -1391,28 +1646,33 @@  package body Sem_Ch13 is
                Error_Msg_N ("should be a tagged type", Nam);
             end if;
 
-            Analyze_And_Resolve (Expr, Standard_String);
-
-            if not Is_Static_Expression (Expr) then
-               Flag_Non_Static_Expr
-                 ("static string required for tag name!", Nam);
-            end if;
+            if Duplicate_Clause then
+               null;
 
-            if VM_Target = No_VM then
-               Set_Has_External_Tag_Rep_Clause (U_Ent);
             else
-               Error_Msg_Name_1 := Attr;
-               Error_Msg_N
-                 ("% attribute unsupported in this configuration", Nam);
-            end if;
+               Analyze_And_Resolve (Expr, Standard_String);
 
-            if not Is_Library_Level_Entity (U_Ent) then
-               Error_Msg_NE
-                 ("?non-unique external tag supplied for &", N, U_Ent);
-               Error_Msg_N
-                 ("?\same external tag applies to all subprogram calls", N);
-               Error_Msg_N
-                 ("?\corresponding internal tag cannot be obtained", N);
+               if not Is_Static_Expression (Expr) then
+                  Flag_Non_Static_Expr
+                    ("static string required for tag name!", Nam);
+               end if;
+
+               if VM_Target = No_VM then
+                  Set_Has_External_Tag_Rep_Clause (U_Ent);
+               else
+                  Error_Msg_Name_1 := Attr;
+                  Error_Msg_N
+                    ("% attribute unsupported in this configuration", Nam);
+               end if;
+
+               if not Is_Library_Level_Entity (U_Ent) then
+                  Error_Msg_NE
+                    ("?non-unique external tag supplied for &", N, U_Ent);
+                  Error_Msg_N
+                    ("?\same external tag applies to all subprogram calls", N);
+                  Error_Msg_N
+                    ("?\corresponding internal tag cannot be obtained", N);
+               end if;
             end if;
          end External_Tag;
 
@@ -1437,9 +1697,8 @@  package body Sem_Ch13 is
             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 Duplicate_Clause then
+               null;
 
             elsif Radix /= No_Uint then
                Set_Has_Machine_Radix_Clause (U_Ent);
@@ -1471,8 +1730,8 @@  package body Sem_Ch13 is
             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);
+            elsif Duplicate_Clause then
+               null;
 
             else
                Check_Size (Expr, U_Ent, Size, Biased);
@@ -1526,8 +1785,8 @@  package body Sem_Ch13 is
          begin
             FOnly := True;
 
-            if Has_Size_Clause (U_Ent) then
-               Error_Msg_N ("size already given for &", Nam);
+            if Duplicate_Clause then
+               null;
 
             elsif not Is_Type (U_Ent)
               and then Ekind (U_Ent) /= E_Variable
@@ -1709,8 +1968,7 @@  package body Sem_Ch13 is
                  ("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);
+            elsif Duplicate_Clause then
                return;
 
             elsif Present (Associated_Storage_Pool (U_Ent)) then
@@ -1839,8 +2097,8 @@  package body Sem_Ch13 is
                  ("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);
+            elsif Duplicate_Clause then
+               null;
 
             else
                Analyze_And_Resolve (Expr, Any_Integer);
@@ -1884,8 +2142,8 @@  package body Sem_Ch13 is
                Check_Restriction (No_Implementation_Attributes, N);
             end if;
 
-            if Has_Stream_Size_Clause (U_Ent) then
-               Error_Msg_N ("Stream_Size already given for &", Nam);
+            if Duplicate_Clause then
+               null;
 
             elsif Is_Elementary_Type (U_Ent) then
                if Size /= System_Storage_Unit
@@ -1929,11 +2187,8 @@  package body Sem_Ch13 is
             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);
+            elsif Duplicate_Clause then
+               null;
 
             elsif Is_Array_Type (U_Ent)
               and then not Is_Constrained (U_Ent)
Index: sem_ch13.ads
===================================================================
--- sem_ch13.ads	(revision 165256)
+++ sem_ch13.ads	(working copy)
@@ -36,6 +36,17 @@  package Sem_Ch13 is
    procedure Analyze_Record_Representation_Clause       (N : Node_Id);
    procedure Analyze_Code_Statement                     (N : Node_Id);
 
+   procedure Analyze_Aspect_Specifications
+     (N : Node_Id;
+      E : Entity_Id;
+      L : List_Id);
+   --  This procedure is called to analyze aspect spefications for node N. E is
+   --  the corresponding entity declared by the declaration node N, and L is
+   --  the list of aspect specifications for this node. If L is No_List, the
+   --  call is ignored. Note that we can't use a simpler interface of just
+   --  passing the node N, since the analysis of the node may cause it to be
+   --  rewritten to a node not permitting aspect specifications.
+
    procedure Adjust_Record_For_Reverse_Bit_Order (R : Entity_Id);
    --  Called from Freeze where R is a record entity for which reverse bit
    --  order is specified and there is at least one component clause. Adjusts
Index: par-ch3.adb
===================================================================
--- par-ch3.adb	(revision 165283)
+++ par-ch3.adb	(working copy)
@@ -327,7 +327,7 @@  package body Ch3 is
       Type_Start_Col   : Column_Number;
       Unknown_Dis      : Boolean;
 
-      Typedef_Node     : Node_Id;
+      Typedef_Node : Node_Id;
       --  Normally holds type definition, except in the case of a private
       --  extension declaration, in which case it holds the declaration itself
 
@@ -476,22 +476,18 @@  package body Ch3 is
             when Tok_Access |
                  Tok_Not    => --  Ada 2005 (AI-231)
                Typedef_Node := P_Access_Type_Definition;
-               TF_Semicolon;
                exit;
 
             when Tok_Array =>
                Typedef_Node := P_Array_Type_Definition;
-               TF_Semicolon;
                exit;
 
             when Tok_Delta =>
                Typedef_Node := P_Fixed_Point_Definition;
-               TF_Semicolon;
                exit;
 
             when Tok_Digits =>
                Typedef_Node := P_Floating_Point_Definition;
-               TF_Semicolon;
                exit;
 
             when Tok_In =>
@@ -500,12 +496,10 @@  package body Ch3 is
             when Tok_Integer_Literal =>
                T_Range;
                Typedef_Node := P_Signed_Integer_Type_Definition;
-               TF_Semicolon;
                exit;
 
             when Tok_Null =>
                Typedef_Node := P_Record_Definition;
-               TF_Semicolon;
                exit;
 
             when Tok_Left_Paren =>
@@ -517,12 +511,10 @@  package body Ch3 is
                Set_Comes_From_Source (End_Labl, False);
 
                Set_End_Label (Typedef_Node, End_Labl);
-               TF_Semicolon;
                exit;
 
             when Tok_Mod =>
                Typedef_Node := P_Modular_Type_Definition;
-               TF_Semicolon;
                exit;
 
             when Tok_New =>
@@ -540,12 +532,10 @@  package body Ch3 is
                     (Record_Extension_Part (Typedef_Node), End_Labl);
                end if;
 
-               TF_Semicolon;
                exit;
 
             when Tok_Range =>
                Typedef_Node := P_Signed_Integer_Type_Definition;
-               TF_Semicolon;
                exit;
 
             when Tok_Record =>
@@ -557,7 +547,6 @@  package body Ch3 is
                Set_Comes_From_Source (End_Labl, False);
 
                Set_End_Label (Typedef_Node, End_Labl);
-               TF_Semicolon;
                exit;
 
             when Tok_Tagged =>
@@ -640,7 +629,6 @@  package body Ch3 is
                   end if;
                end if;
 
-               TF_Semicolon;
                exit;
 
             when Tok_Limited =>
@@ -733,7 +721,6 @@  package body Ch3 is
                   T_Private; -- past PRIVATE (or complain if not there!)
                end if;
 
-               TF_Semicolon;
                exit;
 
             --  Here we have an identifier after the IS, which is certainly
@@ -748,7 +735,6 @@  package body Ch3 is
 
                if not Token_Is_At_Start_Of_Line then
                   Typedef_Node := P_Derived_Type_Def_Or_Private_Ext_Decl;
-                  TF_Semicolon;
 
                --  If the identifier is at the start of the line, and is in the
                --  same column as the type declaration itself then we consider
@@ -769,7 +755,6 @@  package body Ch3 is
 
                else
                   Typedef_Node := P_Record_Definition;
-                  TF_Semicolon;
                end if;
 
                exit;
@@ -779,13 +764,11 @@  package body Ch3 is
             when Tok_Interface =>
                Typedef_Node := P_Interface_Type_Definition (Abstract_Present);
                Abstract_Present := True;
-               TF_Semicolon;
                exit;
 
             when Tok_Private =>
                Decl_Node := New_Node (N_Private_Type_Declaration, Type_Loc);
                Scan; -- past PRIVATE
-               TF_Semicolon;
                exit;
 
             --  Ada 2005 (AI-345): Protected, synchronized or task interface
@@ -849,7 +832,6 @@  package body Ch3 is
                   end if;
                end;
 
-               TF_Semicolon;
                exit;
 
             --  Anything else is an error
@@ -933,6 +915,7 @@  package body Ch3 is
 
       Set_Defining_Identifier (Decl_Node, Ident_Node);
       Set_Discriminant_Specifications (Decl_Node, Discr_List);
+      P_Aspect_Specifications (Decl_Node);
       return Decl_Node;
    end P_Type_Declaration;
 
@@ -980,7 +963,7 @@  package body Ch3 is
 
       Set_Subtype_Indication
         (Decl_Node, P_Subtype_Indication (Not_Null_Present));
-      TF_Semicolon;
+      P_Aspect_Specifications (Decl_Node);
       return Decl_Node;
    end P_Subtype_Declaration;
 
@@ -1836,8 +1819,8 @@  package body Ch3 is
             end if;
          end if;
 
-         TF_Semicolon;
          Set_Defining_Identifier (Decl_Node, Idents (Ident));
+         P_Aspect_Specifications (Decl_Node);
 
          if List_OK then
             if Ident < Num_Idents then
@@ -1976,7 +1959,16 @@  package body Ch3 is
       --  missing in the case of "type X is new Y record ..." or in the
       --  case of "type X is new Y null record".
 
-      if Token = Tok_With
+      --  First make sure we don't have an aspect specification. If we do
+      --  return now, so that our caller can check it (the WITH here is not
+      --  part of a type extension).
+
+      if Aspect_Specifications_Present then
+         return Typedef_Node;
+
+      --  OK, not an aspect specification, so continue test for extension
+
+      elsif Token = Tok_With
         or else Token = Tok_Record
         or else Token = Tok_Null
       then
@@ -3470,10 +3462,9 @@  package body Ch3 is
          Ident := Ident + 1;
          Restore_Scan_State (Scan_State);
          T_Colon;
-
       end loop Ident_Loop;
 
-      TF_Semicolon;
+      P_Aspect_Specifications (Decl_Node);
    end P_Component_Items;
 
    --------------------------------
Index: gcc-interface/Makefile.in
===================================================================
--- gcc-interface/Makefile.in	(revision 165256)
+++ gcc-interface/Makefile.in	(working copy)
@@ -296,7 +296,7 @@  GNATLINK_OBJS = gnatlink.o \
  sdefault.o snames.o stylesw.o switch.o system.o table.o targparm.o tree_io.o \
  types.o validsw.o widechar.o
 
-GNATMAKE_OBJS = a-except.o ali.o ali-util.o s-casuti.o \
+GNATMAKE_OBJS = a-except.o ali.o ali-util.o aspects.o s-casuti.o \
  alloc.o atree.o binderr.o butil.o casing.o csets.o debug.o elists.o einfo.o\
  erroutc.o errutil.o err_vars.o fmap.o fname.o fname-uf.o fname-sf.o \
  gnatmake.o gnatvsn.o hostparm.o interfac.o i-c.o i-cstrin.o krunch.o lib.o \
Index: gcc-interface/Make-lang.in
===================================================================
--- gcc-interface/Make-lang.in	(revision 165281)
+++ gcc-interface/Make-lang.in	(working copy)
@@ -368,6 +368,7 @@  GNATBIND_OBJS = \
  ada/ali-util.o   \
  ada/ali.o        \
  ada/alloc.o      \
+ ada/aspects.o    \
  ada/atree.o      \
  ada/bcheck.o     \
  ada/binde.o      \