@@ -78,8 +78,11 @@ package body Exp_Tss is
else
Proc := Init_Proc (Base_Type (Full_Type), Ref);
+ -- For derived record types, if the base type does not have one,
+ -- we use the Init_Proc of the ancestor type.
+
if No (Proc)
- and then Is_Composite_Type (Full_Type)
+ and then Is_Record_Type (Full_Type)
and then Is_Derived_Type (Full_Type)
then
return Init_Proc (Root_Type (Full_Type), Ref);
@@ -13493,12 +13493,68 @@ package body Sem_Ch13 is
-------------------------------------
procedure Inherit_Aspects_At_Freeze_Point (Typ : Entity_Id) is
+ function Get_Inherited_Rep_Item
+ (E : Entity_Id;
+ Nam : Name_Id) return Node_Id;
+ -- Search the Rep_Item chain of entity E for an instance of a rep item
+ -- (pragma, attribute definition clause, or aspect specification) whose
+ -- name matches the given name Nam, and that has been inherited from its
+ -- parent, i.e. that has not been directly specified for E . If one is
+ -- found, it is returned, otherwise Empty is returned.
+
+ function Get_Inherited_Rep_Item
+ (E : Entity_Id;
+ Nam1 : Name_Id;
+ Nam2 : Name_Id) return Node_Id;
+ -- Search the Rep_Item chain of 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, and that has been
+ -- inherited from its parent, i.e. that has not been directly specified
+ -- for E . If one is found, it is returned, otherwise Empty is returned.
+
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 corresponding pragma (if any) is present in
-- the Rep Item chain of the entity it has been specified to.
+ ----------------------------
+ -- Get_Inherited_Rep_Item --
+ ----------------------------
+
+ function Get_Inherited_Rep_Item
+ (E : Entity_Id;
+ Nam : Name_Id) return Node_Id
+ is
+ Rep : constant Node_Id
+ := Get_Rep_Item (E, Nam, Check_Parents => True);
+ begin
+ if Present (Rep)
+ and then not Has_Rep_Item (E, Nam, Check_Parents => False)
+ then
+ return Rep;
+ else
+ return Empty;
+ end if;
+ end Get_Inherited_Rep_Item;
+
+ function Get_Inherited_Rep_Item
+ (E : Entity_Id;
+ Nam1 : Name_Id;
+ Nam2 : Name_Id) return Node_Id
+ is
+ Rep : constant Node_Id
+ := Get_Rep_Item (E, Nam1, Nam2, Check_Parents => True);
+ begin
+ if Present (Rep)
+ and then not Has_Rep_Item (E, Nam1, Nam2, Check_Parents => False)
+ then
+ return Rep;
+ else
+ return Empty;
+ end if;
+ end Get_Inherited_Rep_Item;
+
--------------------------------------------------
-- Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item --
--------------------------------------------------
@@ -13513,6 +13569,8 @@ package body Sem_Ch13 is
Present_In_Rep_Item (Entity (Rep_Item), Aspect_Rep_Item (Rep_Item));
end Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item;
+ Rep : Node_Id;
+
-- Start of processing for Inherit_Aspects_At_Freeze_Point
begin
@@ -13543,40 +13601,36 @@ package body Sem_Ch13 is
-- 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))
+ Rep := Get_Inherited_Rep_Item (Typ, Name_Ada_05, Name_Ada_2005);
+ if Present (Rep)
+ and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item (Rep)
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))
+ Rep := Get_Inherited_Rep_Item (Typ, Name_Ada_12, Name_Ada_2012);
+ if Present (Rep)
+ and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item (Rep)
then
Set_Is_Ada_2012_Only (Typ);
end if;
-- Ada_2022
- if not Has_Rep_Item (Typ, Name_Ada_2022, False)
- and then Has_Rep_Item (Typ, Name_Ada_2022)
- and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
- (Get_Rep_Item (Typ, Name_Ada_2022))
+ Rep := Get_Inherited_Rep_Item (Typ, Name_Ada_2022);
+ if Present (Rep)
+ and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item (Rep)
then
Set_Is_Ada_2022_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))
+ Rep := Get_Inherited_Rep_Item (Typ, Name_Atomic, Name_Shared);
+ if Present (Rep)
+ and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item (Rep)
then
Set_Is_Atomic (Typ);
Set_Is_Volatile (Typ);
@@ -13591,74 +13645,80 @@ package body Sem_Ch13 is
Set_Convention (Typ, Convention (Base_Type (Typ)));
end if;
- -- Default_Component_Value
+ -- Default_Component_Value (for base types only)
- -- Verify that there is no rep_item declared for the type, and there
- -- is one coming from an ancestor.
+ -- Note that we need to look into the first subtype because the base
+ -- type may be the implicit base type built by the compiler for the
+ -- declaration of a constrained subtype with the aspect.
- if Is_Array_Type (Typ)
- and then Is_Base_Type (Typ)
- and then not Has_Rep_Item (Typ, Name_Default_Component_Value, False)
- and then Has_Rep_Item (Typ, Name_Default_Component_Value)
- then
+ if Is_Array_Type (Typ) and then Is_Base_Type (Typ) then
declare
+ F_Typ : constant Entity_Id := First_Subtype (Typ);
+
E : Entity_Id;
begin
- E := Entity (Get_Rep_Item (Typ, Name_Default_Component_Value));
+ Rep :=
+ Get_Inherited_Rep_Item (F_Typ, Name_Default_Component_Value);
+ if Present (Rep) then
+ E := Entity (Rep);
- -- Deal with private types
+ -- Deal with private types
- if Is_Private_Type (E) then
- E := Full_View (E);
- end if;
+ if Is_Private_Type (E) then
+ E := Full_View (E);
+ end if;
- Set_Default_Aspect_Component_Value (Typ,
- Default_Aspect_Component_Value (E));
+ Set_Default_Aspect_Component_Value
+ (Typ, Default_Aspect_Component_Value (E));
+ Set_Has_Default_Aspect (Typ);
+ end if;
end;
end if;
- -- Default_Value
+ -- Default_Value (for base types only)
- if Is_Scalar_Type (Typ)
- and then Is_Base_Type (Typ)
- and then not Has_Rep_Item (Typ, Name_Default_Value, False)
- and then Has_Rep_Item (Typ, Name_Default_Value)
- then
- Set_Has_Default_Aspect (Typ);
+ -- Note that we need to look into the first subtype because the base
+ -- type may be the implicit base type built by the compiler for the
+ -- declaration of a constrained subtype with the aspect.
+ if Is_Scalar_Type (Typ) and then Is_Base_Type (Typ) then
declare
+ F_Typ : constant Entity_Id := First_Subtype (Typ);
+
E : Entity_Id;
begin
- E := Entity (Get_Rep_Item (Typ, Name_Default_Value));
+ Rep := Get_Inherited_Rep_Item (F_Typ, Name_Default_Value);
+ if Present (Rep) then
+ E := Entity (Rep);
- -- Deal with private types
+ -- Deal with private types
- if Is_Private_Type (E) then
- E := Full_View (E);
- end if;
+ if Is_Private_Type (E) then
+ E := Full_View (E);
+ end if;
- Set_Default_Aspect_Value (Typ, Default_Aspect_Value (E));
+ Set_Default_Aspect_Value (Typ, Default_Aspect_Value (E));
+ Set_Has_Default_Aspect (Typ);
+ end if;
end;
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))
+ Rep := Get_Inherited_Rep_Item (Typ, Name_Discard_Names);
+ if Present (Rep)
+ and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item (Rep)
then
Set_Discard_Names (Typ);
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))
+ Rep := Get_Inherited_Rep_Item (Typ, Name_Volatile);
+ if Present (Rep)
+ and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item (Rep)
then
Set_Is_Volatile (Typ);
Set_Treat_As_Volatile (Typ);
@@ -13666,12 +13726,10 @@ package body Sem_Ch13 is
-- Volatile_Full_Access and Full_Access_Only
- if not Has_Rep_Item (Typ, Name_Volatile_Full_Access, False)
- and then not Has_Rep_Item (Typ, Name_Full_Access_Only, False)
- and then (Has_Rep_Item (Typ, Name_Volatile_Full_Access)
- or else Has_Rep_Item (Typ, Name_Full_Access_Only))
- and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
- (Get_Rep_Item (Typ, Name_Volatile_Full_Access))
+ Rep := Get_Inherited_Rep_Item
+ (Typ, Name_Volatile_Full_Access, Name_Full_Access_Only);
+ if Present (Rep)
+ and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item (Rep)
then
Set_Is_Volatile_Full_Access (Typ);
Set_Is_Volatile (Typ);
@@ -13688,38 +13746,34 @@ package body Sem_Ch13 is
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))
+ Rep := Get_Inherited_Rep_Item (Typ, Name_Atomic_Components);
+ if Present (Rep)
+ and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item (Rep)
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))
+ Rep := Get_Inherited_Rep_Item (Typ, Name_Volatile_Components);
+ if Present (Rep)
+ and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item (Rep)
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
+ Rep := Get_Inherited_Rep_Item (Typ, Name_Finalize_Storage_Only);
+ if Present (Rep) 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))
+ Rep := Get_Inherited_Rep_Item (Typ, Name_Universal_Aliasing);
+ if Present (Rep)
+ and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item (Rep)
then
Set_Universal_Aliasing (Imp_Bas_Typ);
end if;
@@ -13727,9 +13781,8 @@ package body Sem_Ch13 is
-- Bit_Order
if Is_Record_Type (Typ) and then Typ = Bas_Typ then
- if not Has_Rep_Item (Typ, Name_Bit_Order, False)
- and then Has_Rep_Item (Typ, Name_Bit_Order)
- then
+ Rep := Get_Inherited_Rep_Item (Typ, Name_Bit_Order);
+ if Present (Rep) then
Set_Reverse_Bit_Order (Bas_Typ,
Reverse_Bit_Order
(Implementation_Base_Type (Etype (Bas_Typ))));