-- aspect node N for the given type (entity) of the aspect does not
-- appear too late according to the rules in RM 13.1(9) and 13.1(10).
- procedure Inherit_Delayed_Rep_Aspects (ASN : Node_Id);
- -- As discussed in the spec of Aspects (see Aspect_Delay declaration),
- -- a derived type can inherit aspects from its parent which have been
- -- specified at the time of the derivation using an aspect, as in:
- --
- -- type A is range 1 .. 10
- -- with Size => Not_Defined_Yet;
- -- ..
- -- type B is new A;
- -- ..
- -- Not_Defined_Yet : constant := 64;
- --
- -- In this example, the Size of A is considered to be specified prior
- -- to the derivation, and thus inherited, even though the value is not
- -- known at the time of derivation. To deal with this, we use two entity
- -- flags. The flag Has_Derived_Rep_Aspects is set in the parent type (A
- -- here), and then the flag May_Inherit_Delayed_Rep_Aspects is set in
- -- the derived type (B here). If this flag is set when the derived type
- -- is frozen, then this procedure is called to ensure proper inheritance
- -- of all delayed aspects from the parent type. The derived type is E,
- -- the argument to Analyze_Aspects_At_Freeze_Point. ASN is the first
- -- aspect specification node in the Rep_Item chain for the parent type.
-
procedure Make_Pragma_From_Boolean_Aspect (ASN : Node_Id);
-- Given an aspect specification node ASN whose expression is an
-- optional Boolean, this routines creates the corresponding pragma
end if;
end Check_Aspect_Too_Late;
- ---------------------------------
- -- Inherit_Delayed_Rep_Aspects --
- ---------------------------------
-
- procedure Inherit_Delayed_Rep_Aspects (ASN : Node_Id) is
- A_Id : constant Aspect_Id := Get_Aspect_Id (ASN);
- P : constant Entity_Id := Entity (ASN);
- -- Entity for parent type
-
- N : Node_Id;
- -- Item from Rep_Item chain
-
- A : Aspect_Id;
-
- begin
- -- Loop through delayed aspects for the parent type
-
- N := ASN;
- while Present (N) loop
- if Nkind (N) = N_Aspect_Specification then
- exit when Entity (N) /= P;
-
- if Is_Delayed_Aspect (N) then
- A := Get_Aspect_Id (Chars (Identifier (N)));
-
- -- Process delayed rep aspect. For Boolean attributes it is
- -- not possible to cancel an attribute once set (the attempt
- -- to use an aspect with xxx => False is an error) for a
- -- derived type. So for those cases, we do not have to check
- -- if a clause has been given for the derived type, since it
- -- is harmless to set it again if it is already set.
-
- case A is
-
- -- Alignment
-
- when Aspect_Alignment =>
- if not Has_Alignment_Clause (E) then
- Set_Alignment (E, Alignment (P));
- end if;
-
- -- Atomic
-
- when Aspect_Atomic =>
- if Is_Atomic (P) then
- Set_Is_Atomic (E);
- end if;
-
- -- Atomic_Components
-
- when Aspect_Atomic_Components =>
- if Has_Atomic_Components (P) then
- Set_Has_Atomic_Components (Base_Type (E));
- end if;
-
- -- Bit_Order
-
- when Aspect_Bit_Order =>
- if Is_Record_Type (E)
- and then No (Get_Attribute_Definition_Clause
- (E, Attribute_Bit_Order))
- and then Reverse_Bit_Order (P)
- then
- Set_Reverse_Bit_Order (Base_Type (E));
- end if;
-
- -- Component_Size
-
- when Aspect_Component_Size =>
- if Is_Array_Type (E)
- and then not Has_Component_Size_Clause (E)
- then
- Set_Component_Size
- (Base_Type (E), Component_Size (P));
- end if;
-
- -- Machine_Radix
-
- when Aspect_Machine_Radix =>
- if Is_Decimal_Fixed_Point_Type (E)
- and then not Has_Machine_Radix_Clause (E)
- then
- Set_Machine_Radix_10 (E, Machine_Radix_10 (P));
- end if;
-
- -- Object_Size (also Size which also sets Object_Size)
-
- when Aspect_Object_Size
- | Aspect_Size
- =>
- if not Has_Size_Clause (E)
- and then
- No (Get_Attribute_Definition_Clause
- (E, Attribute_Object_Size))
- then
- Set_Esize (E, Esize (P));
- end if;
-
- -- Pack
-
- when Aspect_Pack =>
- if not Is_Packed (E) then
- Set_Is_Packed (Base_Type (E));
-
- if Is_Bit_Packed_Array (P) then
- Set_Is_Bit_Packed_Array (Base_Type (E));
- Set_Packed_Array_Impl_Type
- (E, Packed_Array_Impl_Type (P));
- end if;
- end if;
-
- -- Scalar_Storage_Order
-
- when Aspect_Scalar_Storage_Order =>
- if (Is_Record_Type (E) or else Is_Array_Type (E))
- and then No (Get_Attribute_Definition_Clause
- (E, Attribute_Scalar_Storage_Order))
- and then Reverse_Storage_Order (P)
- then
- Set_Reverse_Storage_Order (Base_Type (E));
-
- -- Clear default SSO indications, since the aspect
- -- overrides the default.
-
- Set_SSO_Set_Low_By_Default (Base_Type (E), False);
- Set_SSO_Set_High_By_Default (Base_Type (E), False);
- end if;
-
- -- Small
-
- when Aspect_Small =>
- if Is_Fixed_Point_Type (E)
- and then not Has_Small_Clause (E)
- then
- Set_Small_Value (E, Small_Value (P));
- end if;
-
- -- Storage_Size
-
- when Aspect_Storage_Size =>
- if (Is_Access_Type (E) or else Is_Task_Type (E))
- and then not Has_Storage_Size_Clause (E)
- then
- Set_Storage_Size_Variable
- (Base_Type (E), Storage_Size_Variable (P));
- end if;
-
- -- Value_Size
-
- when Aspect_Value_Size =>
-
- -- Value_Size is never inherited, it is either set by
- -- default, or it is explicitly set for the derived
- -- type. So nothing to do here.
-
- null;
-
- -- Volatile
-
- when Aspect_Volatile =>
- if Is_Volatile (P) then
- Set_Is_Volatile (E);
- end if;
-
- -- Volatile_Full_Access (also Full_Access_Only)
-
- when Aspect_Volatile_Full_Access
- | Aspect_Full_Access_Only
- =>
- if Is_Volatile_Full_Access (P) then
- Set_Is_Volatile_Full_Access (E);
- end if;
-
- -- Volatile_Components
-
- when Aspect_Volatile_Components =>
- if Has_Volatile_Components (P) then
- Set_Has_Volatile_Components (Base_Type (E));
- end if;
-
- -- That should be all the Rep Aspects
-
- when others =>
- pragma Assert (Aspect_Delay (A_Id) /= Rep_Aspect);
- null;
- end case;
- end if;
- end if;
-
- Next_Rep_Item (N);
- end loop;
- end Inherit_Delayed_Rep_Aspects;
-
-------------------------------------
-- Make_Pragma_From_Boolean_Aspect --
-------------------------------------
Next_Rep_Item (ASN);
end loop;
- -- This is where we inherit delayed rep aspects from our parent. Note
- -- that if we fell out of the above loop with ASN non-empty, it means
- -- we hit an aspect for an entity other than E, and it must be the
- -- type from which we were derived.
-
- if May_Inherit_Delayed_Rep_Aspects (E) then
- Inherit_Delayed_Rep_Aspects (ASN);
- end if;
-
if In_Instance
and then E /= Base_Type (E)
and then Is_First_Subtype (E)
-- 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.
-
-- In addition, Convention must be propagated from base type to subtype,
-- because the subtype may have been declared on an incomplete view.
and then not 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))));
+ declare
+ E : Entity_Id;
+
+ begin
+ E := Entity (Get_Rep_Item (Typ, Name_Default_Component_Value));
+
+ -- Deal with private types
+
+ if Is_Private_Type (E) then
+ E := Full_View (E);
+ end if;
+
+ Set_Default_Aspect_Component_Value (Typ,
+ Default_Aspect_Component_Value (E));
+ end;
end if;
-- Default_Value
and then Has_Rep_Item (Typ, Name_Default_Value)
then
Set_Has_Default_Aspect (Typ);
- Set_Default_Aspect_Value (Typ,
- Default_Aspect_Value
- (Entity (Get_Rep_Item (Typ, Name_Default_Value))));
+
+ declare
+ E : Entity_Id;
+
+ begin
+ E := Entity (Get_Rep_Item (Typ, Name_Default_Value));
+
+ -- Deal with private types
+
+ if Is_Private_Type (E) then
+ E := Full_View (E);
+ end if;
+
+ Set_Default_Aspect_Value (Typ, Default_Aspect_Value (E));
+ end;
end if;
-- Discard_Names
end if;
end Inherit_Aspects_At_Freeze_Point;
+ ---------------------------------
+ -- Inherit_Delayed_Rep_Aspects --
+ ---------------------------------
+
+ procedure Inherit_Delayed_Rep_Aspects (Typ : Entity_Id) is
+ A : Aspect_Id;
+ N : Node_Id;
+ P : Entity_Id;
+
+ begin
+ -- Find the first aspect that has been inherited
+
+ N := First_Rep_Item (Typ);
+ while Present (N) loop
+ if Nkind (N) = N_Aspect_Specification then
+ exit when Entity (N) /= Typ;
+ end if;
+
+ Next_Rep_Item (N);
+ end loop;
+
+ -- There must be one if we reach here
+
+ pragma Assert (Present (N));
+ P := Entity (N);
+
+ -- Loop through delayed aspects for the parent type
+
+ while Present (N) loop
+ if Nkind (N) = N_Aspect_Specification then
+ exit when Entity (N) /= P;
+
+ if Is_Delayed_Aspect (N) then
+ A := Get_Aspect_Id (N);
+
+ -- Process delayed rep aspect. For Boolean attributes it is
+ -- not possible to cancel an attribute once set (the attempt
+ -- to use an aspect with xxx => False is an error) for a
+ -- derived type. So for those cases, we do not have to check
+ -- if a clause has been given for the derived type, since it
+ -- is harmless to set it again if it is already set.
+
+ case A is
+
+ -- Alignment
+
+ when Aspect_Alignment =>
+ if not Has_Alignment_Clause (Typ) then
+ Set_Alignment (Typ, Alignment (P));
+ end if;
+
+ -- Atomic
+
+ when Aspect_Atomic =>
+ if Is_Atomic (P) then
+ Set_Is_Atomic (Typ);
+ end if;
+
+ -- Atomic_Components
+
+ when Aspect_Atomic_Components =>
+ if Has_Atomic_Components (P) then
+ Set_Has_Atomic_Components (Base_Type (Typ));
+ end if;
+
+ -- Bit_Order
+
+ when Aspect_Bit_Order =>
+ if Is_Record_Type (Typ)
+ and then No (Get_Attribute_Definition_Clause
+ (Typ, Attribute_Bit_Order))
+ and then Reverse_Bit_Order (P)
+ then
+ Set_Reverse_Bit_Order (Base_Type (Typ));
+ end if;
+
+ -- Component_Size
+
+ when Aspect_Component_Size =>
+ if Is_Array_Type (Typ)
+ and then not Has_Component_Size_Clause (Typ)
+ then
+ Set_Component_Size
+ (Base_Type (Typ), Component_Size (P));
+ end if;
+
+ -- Machine_Radix
+
+ when Aspect_Machine_Radix =>
+ if Is_Decimal_Fixed_Point_Type (Typ)
+ and then not Has_Machine_Radix_Clause (Typ)
+ then
+ Set_Machine_Radix_10 (Typ, Machine_Radix_10 (P));
+ end if;
+
+ -- Object_Size (also Size which also sets Object_Size)
+
+ when Aspect_Object_Size
+ | Aspect_Size
+ =>
+ if not Has_Size_Clause (Typ)
+ and then
+ No (Get_Attribute_Definition_Clause
+ (Typ, Attribute_Object_Size))
+ then
+ Set_Esize (Typ, Esize (P));
+ end if;
+
+ -- Pack
+
+ when Aspect_Pack =>
+ if not Is_Packed (Typ) then
+ Set_Is_Packed (Base_Type (Typ));
+
+ if Is_Bit_Packed_Array (P) then
+ Set_Is_Bit_Packed_Array (Base_Type (Typ));
+ Set_Packed_Array_Impl_Type
+ (Typ, Packed_Array_Impl_Type (P));
+ end if;
+ end if;
+
+ -- Scalar_Storage_Order
+
+ when Aspect_Scalar_Storage_Order =>
+ if (Is_Record_Type (Typ) or else Is_Array_Type (Typ))
+ and then No (Get_Attribute_Definition_Clause
+ (Typ, Attribute_Scalar_Storage_Order))
+ and then Reverse_Storage_Order (P)
+ then
+ Set_Reverse_Storage_Order (Base_Type (Typ));
+
+ -- Clear default SSO indications, since the aspect
+ -- overrides the default.
+
+ Set_SSO_Set_Low_By_Default (Base_Type (Typ), False);
+ Set_SSO_Set_High_By_Default (Base_Type (Typ), False);
+ end if;
+
+ -- Small
+
+ when Aspect_Small =>
+ if Is_Fixed_Point_Type (Typ)
+ and then not Has_Small_Clause (Typ)
+ then
+ Set_Small_Value (Typ, Small_Value (P));
+ end if;
+
+ -- Storage_Size
+
+ when Aspect_Storage_Size =>
+ if (Is_Access_Type (Typ) or else Is_Task_Type (Typ))
+ and then not Has_Storage_Size_Clause (Typ)
+ then
+ Set_Storage_Size_Variable
+ (Base_Type (Typ), Storage_Size_Variable (P));
+ end if;
+
+ -- Value_Size
+
+ when Aspect_Value_Size =>
+
+ -- Value_Size is never inherited, it is either set by
+ -- default, or it is explicitly set for the derived
+ -- type. So nothing to do here.
+
+ null;
+
+ -- Volatile
+
+ when Aspect_Volatile =>
+ if Is_Volatile (P) then
+ Set_Is_Volatile (Typ);
+ end if;
+
+ -- Volatile_Full_Access (also Full_Access_Only)
+
+ when Aspect_Volatile_Full_Access
+ | Aspect_Full_Access_Only
+ =>
+ if Is_Volatile_Full_Access (P) then
+ Set_Is_Volatile_Full_Access (Typ);
+ end if;
+
+ -- Volatile_Components
+
+ when Aspect_Volatile_Components =>
+ if Has_Volatile_Components (P) then
+ Set_Has_Volatile_Components (Base_Type (Typ));
+ end if;
+
+ -- That should be all the Rep Aspects
+
+ when others =>
+ pragma Assert (Aspect_Delay (A) /= Rep_Aspect);
+ null;
+ end case;
+ end if;
+ end if;
+
+ Next_Rep_Item (N);
+ end loop;
+ end Inherit_Delayed_Rep_Aspects;
+
----------------
-- Initialize --
----------------
Analyze (High_Bound (Range_Expression (Constraint (Indic))));
end if;
- -- Introduce an implicit base type for the derived type even if there
+ -- Create an implicit base type for the derived type even if there
-- is no constraint attached to it, since this seems closer to the
- -- Ada semantics. Build a full type declaration tree for the derived
- -- type using the implicit base type as the defining identifier. Then
- -- build a subtype declaration tree which applies the constraint (if
- -- any) have it replace the derived type declaration.
+ -- Ada semantics. Use an Itype like for the implicit base type of
+ -- other kinds of derived type, but build a full type declaration
+ -- for it so as to analyze the new literals properly. Then build a
+ -- subtype declaration tree which applies the constraint (if any)
+ -- and have it replace the derived type declaration.
Literal := First_Literal (Parent_Type);
Literals_List := New_List;
end loop;
Implicit_Base :=
- Make_Defining_Identifier (Sloc (Derived_Type),
- Chars => New_External_Name (Chars (Derived_Type), 'B'));
+ Create_Itype (E_Enumeration_Type, N, Derived_Type, 'B');
-- Indicate the proper nature of the derived type. This must be done
-- before analysis of the literals, to recognize cases when a literal
Type_Decl :=
Make_Full_Type_Declaration (Loc,
Defining_Identifier => Implicit_Base,
- Discriminant_Specifications => No_List,
Type_Definition =>
Make_Enumeration_Type_Definition (Loc, Literals_List));
- Mark_Rewrite_Insertion (Type_Decl);
- Insert_Before (N, Type_Decl);
+ -- Do not insert the declarationn, just analyze it in the context
+
+ Set_Parent (Type_Decl, Parent (N));
Analyze (Type_Decl);
-- The anonymous base now has a full declaration, but this base
-- must be converted to the derived type.
Convert_Scalar_Bounds (N, Parent_Type, Derived_Type, Loc);
-
- -- The implicit_base should be frozen when the derived type is frozen,
- -- but note that it is used in the conversions of the bounds. For fixed
- -- types we delay the determination of the bounds until the proper
- -- freezing point. For other numeric types this is rejected by GCC, for
- -- reasons that are currently unclear (???), so we choose to freeze the
- -- implicit base now. In the case of integers and floating point types
- -- this is harmless because subsequent representation clauses cannot
- -- affect anything, but it is still baffling that we cannot use the
- -- same mechanism for all derived numeric types.
-
- -- There is a further complication: actually some representation
- -- clauses can affect the implicit base type. For example, attribute
- -- definition clauses for stream-oriented attributes need to set the
- -- corresponding TSS entries on the base type, and this normally
- -- cannot be done after the base type is frozen, so the circuitry in
- -- Sem_Ch13.New_Stream_Subprogram must account for this possibility
- -- and not use Set_TSS in this case.
-
- -- There are also consequences for the case of delayed representation
- -- aspects for some cases. For example, a Size aspect is delayed and
- -- should not be evaluated to the freeze point. This early freezing
- -- means that the size attribute evaluation happens too early???
-
- if Is_Fixed_Point_Type (Parent_Type) then
- Conditional_Delay (Implicit_Base, Parent_Type);
- else
- Freeze_Before (N, Implicit_Base);
- end if;
end Build_Derived_Numeric_Type;
--------------------------------
begin
Mutate_Ekind (Def_Id, E_Enumeration_Subtype);
- Set_First_Literal (Def_Id, First_Literal (Base_Type (T)));
+ Set_First_Literal (Def_Id, First_Literal (Base_Type (T)));
+ Set_Etype (Def_Id, Base_Type (T));
+ Set_Size_Info (Def_Id, (T));
+ Set_Is_Character_Type (Def_Id, Is_Character_Type (T));
+ Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T);
- Set_Etype (Def_Id, Base_Type (T));
- Set_Size_Info (Def_Id, (T));
- Set_First_Rep_Item (Def_Id, First_Rep_Item (T));
- Set_Is_Character_Type (Def_Id, Is_Character_Type (T));
+ -- Inherit the chain of representation items instead of replacing it
+ -- because Build_Derived_Enumeration_Type rewrites the declaration of
+ -- the derived type as a subtype declaration and the former needs to
+ -- preserve existing representation items (see Build_Derived_Type).
- Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T);
+ Inherit_Rep_Item_Chain (Def_Id, T);
Set_Discrete_RM_Size (Def_Id);
end Constrain_Enumeration;
Low_Bound => Lo,
High_Bound => Hi));
- Conditional_Delay (Derived_Type, Parent_Type);
-
- Mutate_Ekind (Derived_Type, E_Enumeration_Subtype);
- Set_Etype (Derived_Type, Implicit_Base);
- Set_Size_Info (Derived_Type, Parent_Type);
+ Mutate_Ekind (Derived_Type, E_Enumeration_Subtype);
+ Set_Etype (Derived_Type, Implicit_Base);
+ Set_Size_Info (Derived_Type, Parent_Type);
if not Known_RM_Size (Derived_Type) then
Set_RM_Size (Derived_Type, RM_Size (Parent_Type));
end if;
Convert_Scalar_Bounds (N, Parent_Type, Derived_Type, Loc);
-
- -- Because the implicit base is used in the conversion of the bounds, we
- -- have to freeze it now. This is similar to what is done for numeric
- -- types, and it equally suspicious, but otherwise a nonstatic bound
- -- will have a reference to an unfrozen type, which is rejected by Gigi
- -- (???). This requires specific care for definition of stream
- -- attributes. For details, see comments at the end of
- -- Build_Derived_Numeric_Type.
-
- Freeze_Before (N, Implicit_Base);
end Derived_Standard_Character;
------------------------------
projects / thirdparty / gcc.git / commitdiff
