Patchwork [Ada] Inheritance of representation aspects at freezing point

login
register
mail settings
Submitter Arnaud Charlet
Date Aug. 6, 2012, 8:48 a.m.
Message ID <20120806084832.GA5261@adacore.com>
Download mbox | patch
Permalink /patch/175301/
State New
Headers show

Comments

Arnaud Charlet - Aug. 6, 2012, 8:48 a.m.
The test presented below deals with the aspect Volatile. Indeed it's illegal to
instantiate non-volatile formal object with volatile actual.

------------
-- Source --
------------

package Volatile is
   type Volatile is tagged record
      R : Integer;
   end record with Volatile;  --  Volatile

   type Der_Volatile is new Volatile with record
      R2 : Integer;
   end record;  --  Volatile by inheritance

   generic
      Non_Formal_Object : in out Integer;
   package Non_Volatile_Formal is end;

   DerVol : Der_Volatile;

   package Error is new Non_Volatile_Formal (DerVol.R2);
   --  instantiation error since the actual DerVol.R2 is volatile whereas the
   --  formal Non_Formal_Object is non-volatile.
end Volatile;

-----------------
-- Compilation --
-----------------

$ gcc -c -gnat12 volatile.ads
volatile.ads:16:52: cannot instantiate non-volatile formal object with volatile actual

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

2012-08-06  Vincent Pucci  <pucci@adacore.com>

	* freeze.adb (Freeze_Entity): Inherit_Aspects_At_Freeze_Point
	calls added for derived types and subtypes.
	* sem_aux.adb, sem_aux.ads (Get_Rep_Item, Get_Rep_Pragma,
	Has_Rep_Pragma): New routines.
	* sem_ch13.ads (Inherit_Aspects_At_Freeze_Point): New routine.
	* sem_ch13.adb (Analyze_Aspect_Specifications): Error message
	for aspect Lock_Free fixed.
	(Inherits_Aspects_At_Freeze_Point): New routine.
	* sem_ch3.adb: Several flag settings removed since inheritance
	of aspects must be performed at freeze point.

Patch

Index: sem_ch3.adb
===================================================================
--- sem_ch3.adb	(revision 190171)
+++ sem_ch3.adb	(working copy)
@@ -4048,12 +4048,9 @@ 
 
       --  Inherit common attributes
 
-      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_Is_Generic_Type   (Id, Is_Generic_Type   (Base_Type (T)));
       Set_Convention        (Id, Convention        (T));
 
       --  If ancestor has predicates then so does the subtype, and in addition
@@ -5855,13 +5852,6 @@ 
 
          Analyze (N);
 
-         --  If pragma Discard_Names applies on the first subtype of the parent
-         --  type, then it must be applied on this subtype as well.
-
-         if Einfo.Discard_Names (First_Subtype (Parent_Type)) then
-            Set_Discard_Names (Derived_Type);
-         end if;
-
          --  Apply a range check. Since this range expression doesn't have an
          --  Etype, we have to specifically pass the Source_Typ parameter. Is
          --  this right???
@@ -7666,8 +7656,6 @@ 
 
       --  Fields inherited from the Parent_Type
 
-      Set_Discard_Names
-        (Derived_Type, Einfo.Discard_Names  (Parent_Type));
       Set_Has_Specified_Layout
         (Derived_Type, Has_Specified_Layout (Parent_Type));
       Set_Is_Limited_Composite
@@ -7711,20 +7699,9 @@ 
 
             Set_OK_To_Reorder_Components
               (Derived_Type, OK_To_Reorder_Components (Parent_Full));
-            Set_Reverse_Bit_Order
-              (Derived_Type, Reverse_Bit_Order (Parent_Full));
-            Set_Reverse_Storage_Order
-              (Derived_Type, Reverse_Storage_Order (Parent_Full));
          end;
       end if;
 
-      --  Direct controlled types do not inherit Finalize_Storage_Only flag
-
-      if not Is_Controlled (Parent_Type) then
-         Set_Finalize_Storage_Only
-           (Derived_Type, Finalize_Storage_Only (Parent_Type));
-      end if;
-
       --  Set fields for private derived types
 
       if Is_Private_Type (Derived_Type) then
@@ -8043,11 +8020,6 @@ 
       --  they are inherited from the parent type, and these invariants can
       --  be further inherited, so both flags are set.
 
-      if Has_Inheritable_Invariants (Parent_Type) then
-         Set_Has_Inheritable_Invariants (Derived_Type);
-         Set_Has_Invariants (Derived_Type);
-      end if;
-
       --  We similarly inherit predicates
 
       if Has_Predicates (Parent_Type) then
@@ -12218,7 +12190,6 @@ 
       Set_Component_Type           (T1, Component_Type           (T2));
       Set_Component_Size           (T1, Component_Size           (T2));
       Set_Has_Controlled_Component (T1, Has_Controlled_Component (T2));
-      Set_Finalize_Storage_Only    (T1, Finalize_Storage_Only    (T2));
       Set_Has_Non_Standard_Rep     (T1, Has_Non_Standard_Rep     (T2));
       Set_Has_Task                 (T1, Has_Task                 (T2));
       Set_Is_Packed                (T1, Is_Packed                (T2));
@@ -12237,7 +12208,6 @@ 
 
       Set_First_Index          (T1, First_Index           (T2));
       Set_Is_Aliased           (T1, Is_Aliased            (T2));
-      Set_Is_Atomic            (T1, Is_Atomic             (T2));
       Set_Is_Volatile          (T1, Is_Volatile           (T2));
       Set_Treat_As_Volatile    (T1, Treat_As_Volatile     (T2));
       Set_Is_Constrained       (T1, Is_Constrained        (T2));
Index: sem_aux.adb
===================================================================
--- sem_aux.adb	(revision 190155)
+++ sem_aux.adb	(working copy)
@@ -489,6 +489,40 @@ 
       return Empty;
    end Get_Rep_Item;
 
+   function Get_Rep_Item
+     (E             : Entity_Id;
+      Nam1          : Name_Id;
+      Nam2          : Name_Id;
+      Check_Parents : Boolean := True) return Node_Id
+   is
+      Nam1_Item : constant Node_Id := Get_Rep_Item (E, Nam1, Check_Parents);
+      Nam2_Item : constant Node_Id := Get_Rep_Item (E, Nam2, Check_Parents);
+
+      N : Node_Id;
+
+   begin
+      --  Check both Nam1_Item and Nam2_Item are present
+
+      if No (Nam1_Item) then
+         return Nam2_Item;
+      elsif No (Nam2_Item) then
+         return Nam1_Item;
+      end if;
+
+      --  Return the first node encountered in the list
+
+      N := First_Rep_Item (E);
+      while Present (N) loop
+         if N = Nam1_Item or else N = Nam2_Item then
+            return N;
+         end if;
+
+         Next_Rep_Item (N);
+      end loop;
+
+      return Empty;
+   end Get_Rep_Item;
+
    --------------------
    -- Get_Rep_Pragma --
    --------------------
@@ -501,31 +535,41 @@ 
       N : Node_Id;
 
    begin
-      N := First_Rep_Item (E);
-      while Present (N) loop
-         if Nkind (N) = N_Pragma
-           and then
-             (Pragma_Name (N) = Nam
-               or else (Nam = Name_Interrupt_Priority
-                         and then Pragma_Name (N) = Name_Priority))
-         then
-            if Check_Parents then
-               return N;
+      N := Get_Rep_Item (E, Nam, Check_Parents);
 
-            --  If Check_Parents is False, return N if the pragma doesn't
-            --  appear in the Rep_Item chain of the parent.
+      if Present (N) and then Nkind (N) = N_Pragma then
+         return N;
+      end if;
 
-            else
-               declare
-                  Par : constant Entity_Id := Nearest_Ancestor (E);
-                  --  This node represents the parent type of type E (if any)
+      return Empty;
+   end Get_Rep_Pragma;
 
-               begin
-                  if No (Par) or else not Present_In_Rep_Item (Par, N) then
-                     return N;
-                  end if;
-               end;
-            end if;
+   function Get_Rep_Pragma
+     (E             : Entity_Id;
+      Nam1          : Name_Id;
+      Nam2          : Name_Id;
+      Check_Parents : Boolean := True) return Node_Id
+   is
+      Nam1_Item : constant Node_Id := Get_Rep_Pragma (E, Nam1, Check_Parents);
+      Nam2_Item : constant Node_Id := Get_Rep_Pragma (E, Nam2, Check_Parents);
+
+      N : Node_Id;
+
+   begin
+      --  Check both Nam1_Item and Nam2_Item are present
+
+      if No (Nam1_Item) then
+         return Nam2_Item;
+      elsif No (Nam2_Item) then
+         return Nam1_Item;
+      end if;
+
+      --  Return the first node encountered in the list
+
+      N := First_Rep_Item (E);
+      while Present (N) loop
+         if N = Nam1_Item or else N = Nam2_Item then
+            return N;
          end if;
 
          Next_Rep_Item (N);
@@ -547,6 +591,16 @@ 
       return Present (Get_Rep_Item (E, Nam, Check_Parents));
    end Has_Rep_Item;
 
+   function Has_Rep_Item
+     (E             : Entity_Id;
+      Nam1          : Name_Id;
+      Nam2          : Name_Id;
+      Check_Parents : Boolean := True) return Boolean
+   is
+   begin
+      return Present (Get_Rep_Item (E, Nam1, Nam2, Check_Parents));
+   end Has_Rep_Item;
+
    --------------------
    -- Has_Rep_Pragma --
    --------------------
@@ -560,6 +614,16 @@ 
       return Present (Get_Rep_Pragma (E, Nam, Check_Parents));
    end Has_Rep_Pragma;
 
+   function Has_Rep_Pragma
+     (E             : Entity_Id;
+      Nam1          : Name_Id;
+      Nam2          : Name_Id;
+      Check_Parents : Boolean := True) return Boolean
+   is
+   begin
+      return Present (Get_Rep_Pragma (E, Nam1, Nam2, Check_Parents));
+   end Has_Rep_Pragma;
+
    -------------------------------
    -- Initialization_Suppressed --
    -------------------------------
Index: sem_aux.ads
===================================================================
--- sem_aux.ads	(revision 190155)
+++ sem_aux.ads	(working copy)
@@ -168,18 +168,47 @@ 
    --  otherwise Empty is returned. A special case is that when Nam is
    --  Name_Priority, the call will also find Interrupt_Priority.
 
+   function Get_Rep_Item
+     (E             : Entity_Id;
+      Nam1          : Name_Id;
+      Nam2          : Name_Id;
+      Check_Parents : Boolean := True) return Node_Id;
+   --  Searches the Rep_Item chain for a given entity E, for an instance of a
+   --  rep item (pragma, attribute definition clause, or aspect specification)
+   --  whose name matches one of the given names Nam1 or Nam2. If Check_Parents
+   --  is False then it only returns rep item that has been directly specified
+   --  for E (and not inherited from its parents, if any). If one is found, it
+   --  is returned, otherwise Empty is returned. A special case is that when
+   --  one of the given names is Name_Priority, the call will also find
+   --  Interrupt_Priority.
+
    function Get_Rep_Pragma
      (E             : Entity_Id;
       Nam           : Name_Id;
       Check_Parents : Boolean := True) return Node_Id;
-   --  Searches the Rep_Item chain for a given entity E, for an instance
-   --  of a representation pragma whose name matches the given name Nam. If
+   --  Searches the Rep_Item chain for a given entity E, for an instance of a
+   --  representation pragma whose name matches the given name Nam. If
    --  Check_Parents is False then it only returns representation pragma that
    --  has been directly specified for E (and not inherited from its parents,
-   --  if any). If one is found, it is returned, otherwise Empty is returned. A
-   --  special case is that when Nam is Name_Priority, the call will also find
+   --  if any). If one is found and if it is the first rep item in the list
+   --  that matches Nam, it is returned, otherwise Empty is returned. A special
+   --  case is that when Nam is Name_Priority, the call will also find
    --  Interrupt_Priority.
 
+   function Get_Rep_Pragma
+     (E             : Entity_Id;
+      Nam1          : Name_Id;
+      Nam2          : Name_Id;
+      Check_Parents : Boolean := True) return Node_Id;
+   --  Searches the Rep_Item chain for a given entity E, for an instance of a
+   --  representation pragma whose name matches one of the given names Nam1 or
+   --  Nam2. If Check_Parents is False then it only returns representation
+   --  pragma that has been directly specified for E (and not inherited from
+   --  its parents, if any). If one is found and if it is the first rep item in
+   --  the list that matches one of the given names, it is returned, otherwise
+   --  Empty is returned. A special case is that when one of the given names is
+   --  Name_Priority, the call will also find Interrupt_Priority.
+
    function Has_Rep_Item
      (E             : Entity_Id;
       Nam           : Name_Id;
@@ -191,6 +220,18 @@ 
    --  from its parents, if any). If found then True is returned, otherwise
    --  False indicates that no matching entry was found.
 
+   function Has_Rep_Item
+     (E             : Entity_Id;
+      Nam1          : Name_Id;
+      Nam2          : Name_Id;
+      Check_Parents : Boolean := True) return Boolean;
+   --  Searches the Rep_Item chain for the given entity E, for an instance of a
+   --  rep item (pragma, attribute definition clause, or aspect specification)
+   --  with the given names Nam1 or Nam2. If Check_Parents is False then it
+   --  only checks for a rep item that has been directly specified for E (and
+   --  not inherited from its parents, if any). If found then True is returned,
+   --  otherwise False indicates that no matching entry was found.
+
    function Has_Rep_Pragma
      (E             : Entity_Id;
       Nam           : Name_Id;
@@ -199,9 +240,22 @@ 
    --  representation pragma with the given name Nam. If Check_Parents is False
    --  then it only checks for a representation pragma that has been directly
    --  specified for E (and not inherited from its parents, if any). If found
-   --  then True is returned, otherwise False indicates that no matching entry
-   --  was found.
+   --  and if it is the first rep item in the list that matches Nam then True
+   --  is returned, otherwise False indicates that no matching entry was found.
 
+   function Has_Rep_Pragma
+     (E             : Entity_Id;
+      Nam1          : Name_Id;
+      Nam2          : Name_Id;
+      Check_Parents : Boolean := True) return Boolean;
+   --  Searches the Rep_Item chain for the given entity E, for an instance of a
+   --  representation pragma with the given names Nam1 or Nam2. If
+   --  Check_Parents is False then it only checks for a rep item that has been
+   --  directly specified for E (and not inherited from its parents, if any).
+   --  If found and if it is the first rep item in the list that matches one of
+   --  the given names then True is returned, otherwise False indicates that no
+   --  matching entry was found.
+
    function In_Generic_Body (Id : Entity_Id) return Boolean;
    --  Determine whether entity Id appears inside a generic body
 
Index: freeze.adb
===================================================================
--- freeze.adb	(revision 190155)
+++ freeze.adb	(working copy)
@@ -3434,11 +3434,22 @@ 
                end if;
             end if;
 
+            --  A subtype inherits all the type-related representation aspects
+            --  from its parents (RM 13.1(8)).
+
+            Inherit_Aspects_At_Freeze_Point (E);
+
          --  For a derived type, freeze its parent type first (RM 13.14(15))
 
          elsif Is_Derived_Type (E) then
             Freeze_And_Append (Etype (E), N, Result);
             Freeze_And_Append (First_Subtype (Etype (E)), N, Result);
+
+            --  A derived type inherits each type-related representation aspect
+            --  of its parent type that was directly specified before the
+            --  declaration of the derived type (RM 13.1(15)).
+
+            Inherit_Aspects_At_Freeze_Point (E);
          end if;
 
          --  For array type, freeze index types and component type first
Index: sem_ch13.adb
===================================================================
--- sem_ch13.adb	(revision 190161)
+++ sem_ch13.adb	(working copy)
@@ -856,9 +856,7 @@ 
    --  Start of processing for Analyze_Aspects_At_Freeze_Point
 
    begin
-      --  Must be visible in current scope. Note that this is needed for
-      --  entities that creates their own scope such as protected objects,
-      --  tasks, etc.
+      --  Must be visible in current scope.
 
       if not Scope_Within_Or_Same (Current_Scope, Scope (E)) then
          return;
@@ -1650,6 +1648,7 @@ 
 
                   if A_Id = Aspect_Lock_Free then
                      if Ekind (E) /= E_Protected_Type then
+                        Error_Msg_Name_1 := Nam;
                         Error_Msg_N
                           ("aspect % only applies to a protected object",
                            Aspect);
@@ -7943,6 +7942,223 @@ 
       end if;
    end Get_Alignment_Value;
 
+   -------------------------------------
+   -- Inherit_Aspects_At_Freeze_Point --
+   -------------------------------------
+
+   procedure Inherit_Aspects_At_Freeze_Point (Typ : Entity_Id) is
+      function Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
+        (Rep_Item : Node_Id) return Boolean;
+      --  This routine checks if Rep_Item is either a pragma or an aspect
+      --  specification node whose correponding pragma (if any) is present in
+      --  the Rep Item chain of the entity it has been specified to.
+
+      --------------------------------------------------
+      -- Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item --
+      --------------------------------------------------
+
+      function Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
+        (Rep_Item : Node_Id) return Boolean
+      is
+      begin
+         return Nkind (Rep_Item) = N_Pragma
+           or else Present_In_Rep_Item
+                     (Entity (Rep_Item), Aspect_Rep_Item (Rep_Item));
+      end Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item;
+
+   begin
+      --  A representation item is either subtype-specific (Size and Alignment
+      --  clauses) or type-related (all others).  Subtype-specific aspects may
+      --  differ for different subtypes of the same type.(RM 13.1.8)
+
+      --  A derived type inherits each type-related representation aspect of
+      --  its parent type that was directly specified before the declaration of
+      --  the derived type. (RM 13.1.15)
+
+      --  A derived subtype inherits each subtype-specific representation
+      --  aspect of its parent subtype that was directly specified before the
+      --  declaration of the derived type .(RM 13.1.15)
+
+      --  The general processing involves inheriting a representation aspect
+      --  from a parent type whenever the first rep item (aspect specification,
+      --  attribute definition clause, pragma) corresponding to the given
+      --  representation aspect in the rep item chain of Typ, if any, isn't
+      --  directly specified to Typ but to one of its parents.
+
+      --  ??? Note that, for now, just a limited number of representation
+      --  aspects have been inherited here so far. Many of them are still
+      --  inherited in Sem_Ch3. This will be fixed soon. Here is a
+      --  non-exhaustive list of aspects that likely also need to be moved to
+      --  this routine: Alignment, Component_Alignment, Component_Size,
+      --  Machine_Radix, Object_Size, Pack, Predicates,
+      --  Preelaborable_Initialization, RM_Size and Small.
+
+      if Nkind (Parent (Typ)) = N_Private_Extension_Declaration then
+         return;
+      end if;
+
+      --  Ada_05/Ada_2005
+
+      if not Has_Rep_Item (Typ, Name_Ada_05, Name_Ada_2005, False)
+        and then Has_Rep_Item (Typ, Name_Ada_05, Name_Ada_2005)
+        and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
+                   (Get_Rep_Item (Typ, Name_Ada_05, Name_Ada_2005))
+      then
+         Set_Is_Ada_2005_Only (Typ);
+      end if;
+
+      --  Ada_12/Ada_2012
+
+      if not Has_Rep_Item (Typ, Name_Ada_12, Name_Ada_2012, False)
+        and then Has_Rep_Item (Typ, Name_Ada_12, Name_Ada_2012)
+        and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
+                   (Get_Rep_Item (Typ, Name_Ada_12, Name_Ada_2012))
+      then
+         Set_Is_Ada_2012_Only (Typ);
+      end if;
+
+      --  Atomic/Shared
+
+      if not Has_Rep_Item (Typ, Name_Atomic, Name_Shared, False)
+        and then Has_Rep_Pragma (Typ, Name_Atomic, Name_Shared)
+        and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
+                   (Get_Rep_Item (Typ, Name_Atomic, Name_Shared))
+      then
+         Set_Is_Atomic (Typ);
+         Set_Treat_As_Volatile (Typ);
+         Set_Is_Volatile (Typ);
+      end if;
+
+      --  Default_Component_Value.
+
+      if Is_Array_Type (Typ)
+        and then Has_Rep_Item (Typ, Name_Default_Component_Value, False)
+        and then Has_Rep_Item (Typ, Name_Default_Component_Value)
+      then
+         Set_Default_Aspect_Component_Value (Typ,
+           Default_Aspect_Component_Value
+             (Entity (Get_Rep_Item (Typ, Name_Default_Component_Value))));
+      end if;
+
+      --  Default_Value.
+
+      if Is_Scalar_Type (Typ)
+        and then Has_Rep_Item (Typ, Name_Default_Value, False)
+        and then Has_Rep_Item (Typ, Name_Default_Value)
+      then
+         Set_Default_Aspect_Value (Typ,
+           Default_Aspect_Value
+             (Entity (Get_Rep_Item (Typ, Name_Default_Value))));
+      end if;
+
+      --  Discard_Names
+
+      if not Has_Rep_Item (Typ, Name_Discard_Names, False)
+        and then Has_Rep_Item (Typ, Name_Discard_Names)
+        and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
+                   (Get_Rep_Item (Typ, Name_Discard_Names))
+      then
+         Set_Discard_Names (Typ);
+      end if;
+
+      --  Invariants
+
+      if not Has_Rep_Item (Typ, Name_Invariant, False)
+        and then Has_Rep_Item (Typ, Name_Invariant)
+        and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
+                   (Get_Rep_Item (Typ, Name_Invariant))
+      then
+         Set_Has_Invariants (Typ);
+
+         if Class_Present (Get_Rep_Item (Typ, Name_Invariant)) then
+            Set_Has_Inheritable_Invariants (Typ);
+         end if;
+      end if;
+
+      --  Volatile
+
+      if not Has_Rep_Item (Typ, Name_Volatile, False)
+        and then Has_Rep_Item (Typ, Name_Volatile)
+        and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
+                   (Get_Rep_Item (Typ, Name_Volatile))
+      then
+         Set_Treat_As_Volatile (Typ);
+         Set_Is_Volatile (Typ);
+      end if;
+
+      --  Inheritance for derived types only
+
+      if Is_Derived_Type (Typ) then
+         declare
+            Bas_Typ     : constant Entity_Id := Base_Type (Typ);
+            Imp_Bas_Typ : constant Entity_Id := Implementation_Base_Type (Typ);
+
+         begin
+            --  Atomic_Components
+
+            if not Has_Rep_Item (Typ, Name_Atomic_Components, False)
+              and then Has_Rep_Item (Typ, Name_Atomic_Components)
+              and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
+                   (Get_Rep_Item (Typ, Name_Atomic_Components))
+            then
+               Set_Has_Atomic_Components (Imp_Bas_Typ);
+            end if;
+
+            --  Volatile_Components
+
+            if not Has_Rep_Item (Typ, Name_Volatile_Components, False)
+              and then Has_Rep_Item (Typ, Name_Volatile_Components)
+              and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
+                   (Get_Rep_Item (Typ, Name_Volatile_Components))
+            then
+               Set_Has_Volatile_Components (Imp_Bas_Typ);
+            end if;
+
+            --  Finalize_Storage_Only.
+
+            if not Has_Rep_Pragma (Typ, Name_Finalize_Storage_Only, False)
+              and then Has_Rep_Pragma (Typ, Name_Finalize_Storage_Only)
+            then
+               Set_Finalize_Storage_Only (Bas_Typ);
+            end if;
+
+            --  Universal_Aliasing
+
+            if not Has_Rep_Item (Typ, Name_Universal_Aliasing, False)
+              and then Has_Rep_Item (Typ, Name_Universal_Aliasing)
+              and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
+                   (Get_Rep_Item (Typ, Name_Universal_Aliasing))
+            then
+               Set_Universal_Aliasing (Imp_Bas_Typ);
+            end if;
+
+            --  Record type specific aspects
+
+            if Is_Record_Type (Typ) then
+               --  Bit_Order
+
+               if not Has_Rep_Item (Typ, Name_Bit_Order, False)
+                 and then Has_Rep_Item (Typ, Name_Bit_Order)
+               then
+                  Set_Reverse_Bit_Order (Bas_Typ,
+                    Reverse_Bit_Order (Entity (Name
+                      (Get_Rep_Item (Typ, Name_Bit_Order)))));
+               end if;
+
+               --  Scalar_Storage_Order
+
+               if not Has_Rep_Item (Typ, Name_Scalar_Storage_Order, False)
+                 and then Has_Rep_Item (Typ, Name_Scalar_Storage_Order)
+               then
+                  Set_Reverse_Storage_Order (Bas_Typ,
+                    Reverse_Storage_Order (Entity (Name
+                      (Get_Rep_Item (Typ, Name_Scalar_Storage_Order)))));
+               end if;
+            end if;
+         end;
+      end if;
+   end Inherit_Aspects_At_Freeze_Point;
+
    ----------------
    -- Initialize --
    ----------------
Index: sem_ch13.ads
===================================================================
--- sem_ch13.ads	(revision 190155)
+++ sem_ch13.ads	(working copy)
@@ -310,4 +310,8 @@ 
    --  Performs the processing described above at the freeze all point, and
    --  issues appropriate error messages if the visibility has indeed changed.
    --  Again, ASN is the N_Aspect_Specification node for the aspect.
+
+   procedure Inherit_Aspects_At_Freeze_Point (Typ : Entity_Id);
+   --  Given an entity Typ that denotes a derived type or a subtype, this
+   --  routine performs the inheritance of aspects at the freeze point.
 end Sem_Ch13;