-- renaming_as_body. For tagged types, the specification is one of the
-- primitive specs.
+ procedure No_Type_Rep_Item (N : Node_Id);
+ -- Output message indicating that no type-related aspects can be
+ -- specified due to some property of the parent type.
+
procedure Register_Address_Clause_Check
(N : Node_Id;
X : Entity_Id;
-- This routine analyzes an Aspect_Default_[Component_]Value denoted by
-- the aspect specification node ASN.
+ procedure Check_Aspect_Too_Late (N : Node_Id);
+ -- This procedure is similar to Rep_Item_Too_Late for representation
+ -- aspects that apply to type and that do not have a corresponding
+ -- pragma.
+ -- Used to check in particular that the expression associated with
+ -- 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
----------------------------------
procedure Analyze_Aspect_Default_Value (ASN : Node_Id) is
- A_Id : constant Aspect_Id := Get_Aspect_Id (ASN);
Ent : constant Entity_Id := Entity (ASN);
Expr : constant Node_Id := Expression (ASN);
- Id : constant Node_Id := Identifier (ASN);
begin
- Error_Msg_Name_1 := Chars (Id);
+ Set_Has_Default_Aspect (Base_Type (Ent));
- if not Is_Type (Ent) then
- Error_Msg_N ("aspect% can only apply to a type", Id);
- return;
+ if Is_Scalar_Type (Ent) then
+ Set_Default_Aspect_Value (Base_Type (Ent), Expr);
+ else
+ Set_Default_Aspect_Component_Value (Base_Type (Ent), Expr);
+ end if;
- elsif not Is_First_Subtype (Ent) then
- Error_Msg_N ("aspect% cannot apply to subtype", Id);
- return;
+ Check_Aspect_Too_Late (ASN);
+ end Analyze_Aspect_Default_Value;
- elsif A_Id = Aspect_Default_Value
- and then not Is_Scalar_Type (Ent)
- then
- Error_Msg_N ("aspect% can only be applied to scalar type", Id);
- return;
+ ---------------------------
+ -- Check_Aspect_Too_Late --
+ ---------------------------
- elsif A_Id = Aspect_Default_Component_Value then
- if not Is_Array_Type (Ent) then
- Error_Msg_N ("aspect% can only be applied to array type", Id);
- return;
+ procedure Check_Aspect_Too_Late (N : Node_Id) is
+ Typ : constant Entity_Id := Entity (N);
+ Expr : constant Node_Id := Expression (N);
+ A_Id : constant Aspect_Id := Get_Aspect_Id (N);
- elsif not Is_Scalar_Type (Component_Type (Ent)) then
- Error_Msg_N ("aspect% requires scalar components", Id);
- return;
+ function Find_Type_Reference
+ (Typ : Entity_Id; Expr : Node_Id) return Boolean;
+ -- Return True if a reference to type Typ is found in the expression
+ -- Expr.
+
+ -------------------------
+ -- Find_Type_Reference --
+ -------------------------
+
+ function Find_Type_Reference
+ (Typ : Entity_Id; Expr : Node_Id) return Boolean
+ is
+ function Find_Type (N : Node_Id) return Traverse_Result;
+ -- Set Found to True if N refers to Typ
+
+ ---------------
+ -- Find_Type --
+ ---------------
+
+ function Find_Type (N : Node_Id) return Traverse_Result is
+ begin
+ if N = Typ
+ or else (Nkind_In (N, N_Identifier, N_Expanded_Name)
+ and then Present (Entity (N))
+ and then Entity (N) = Typ)
+ then
+ return Abandon;
+ else
+ return OK;
+ end if;
+ end Find_Type;
+
+ function Search_Type_Reference is new Traverse_Func (Find_Type);
+
+ begin
+ return Search_Type_Reference (Expr) = Abandon;
+ end Find_Type_Reference;
+
+ Parent_Type : Entity_Id;
+
+ begin
+ if A_Id /= Aspect_Default_Value then
+
+ -- Ensure Expr is analyzed so that e.g. all types are properly
+ -- resolved for Find_Type_Reference.
+
+ Analyze (Expr);
+
+ -- A self-referential aspect is illegal if it forces freezing the
+ -- entity before the corresponding aspect has been analyzed.
+
+ if Find_Type_Reference (Typ, Expr) then
+ Error_Msg_NE
+ ("aspect specification causes premature freezing of&",
+ N, Typ);
end if;
end if;
- Set_Has_Default_Aspect (Base_Type (Ent));
+ -- For representation aspects, check for case of untagged derived
+ -- type whose parent either has primitive operations, or is a by
+ -- reference type (RM 13.1(10)).
- if Is_Scalar_Type (Ent) then
- Set_Default_Aspect_Value (Base_Type (Ent), Expr);
- else
- Set_Default_Aspect_Component_Value (Base_Type (Ent), Expr);
+ if Is_Representation_Aspect (A_Id)
+ and then Is_Derived_Type (Typ)
+ and then not Is_Tagged_Type (Typ)
+ then
+ Parent_Type := Etype (Base_Type (Typ));
+
+ if Has_Primitive_Operations (Parent_Type) then
+ No_Type_Rep_Item (N);
+ Error_Msg_NE
+ ("\parent type & has primitive operations!", N, Parent_Type);
+
+ elsif Is_By_Reference_Type (Parent_Type) then
+ No_Type_Rep_Item (N);
+ Error_Msg_NE
+ ("\parent type & is a by reference type!", N, Parent_Type);
+ end if;
end if;
- end Analyze_Aspect_Default_Value;
+ 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);
- -- Entithy for parent type
+ -- Entity for parent type
N : Node_Id;
-- Item from Rep_Item chain
-- Case 3a: The aspects listed below don't correspond to
-- pragmas/attributes but do require delayed analysis.
- -- Default_Value can only apply to a scalar type
-
- when Aspect_Default_Value =>
- if not Is_Scalar_Type (E) then
- Error_Msg_N
- ("aspect Default_Value must apply to a scalar type", N);
- end if;
+ when Aspect_Default_Value | Aspect_Default_Component_Value =>
+ Error_Msg_Name_1 := Chars (Id);
- Aitem := Empty;
+ if not Is_Type (E) then
+ Error_Msg_N ("aspect% can only apply to a type", Id);
+ goto Continue;
- -- Default_Component_Value can only apply to an array type
- -- with scalar components.
+ elsif not Is_First_Subtype (E) then
+ Error_Msg_N ("aspect% cannot apply to subtype", Id);
+ goto Continue;
- when Aspect_Default_Component_Value =>
- if not (Is_Array_Type (E)
- and then Is_Scalar_Type (Component_Type (E)))
+ elsif A_Id = Aspect_Default_Value
+ and then not Is_Scalar_Type (E)
then
- Error_Msg_N
- ("aspect Default_Component_Value can only apply to an "
- & "array of scalar components", N);
+ Error_Msg_N ("aspect% can only be applied to scalar type",
+ Id);
+ goto Continue;
+
+ elsif A_Id = Aspect_Default_Component_Value then
+ if not Is_Array_Type (E) then
+ Error_Msg_N ("aspect% can only be applied to array " &
+ "type", Id);
+ goto Continue;
+
+ elsif not Is_Scalar_Type (Component_Type (E)) then
+ Error_Msg_N ("aspect% requires scalar components", Id);
+ goto Continue;
+ end if;
end if;
Aitem := Empty;
-- as well, even though it appears on a first subtype. This is
-- mandated by the semantics of the aspect. Do not establish
-- the link when processing the base type itself as this leads
- -- to a rep item circularity. Verify that we are dealing with
- -- a scalar type to prevent cascaded errors.
+ -- to a rep item circularity.
- if A_Id = Aspect_Default_Value
- and then Is_Scalar_Type (E)
- and then Base_Type (E) /= E
- then
+ if A_Id = Aspect_Default_Value and then Base_Type (E) /= E then
Set_Has_Delayed_Aspects (Base_Type (E));
Record_Rep_Item (Base_Type (E), Aspect);
end if;
return S;
end Minimum_Size;
- ---------------------------
+ ------------------------------
-- New_Put_Image_Subprogram --
- ---------------------------
+ ------------------------------
procedure New_Put_Image_Subprogram
(N : Node_Id;
end if;
end New_Stream_Subprogram;
+ ----------------------
+ -- No_Type_Rep_Item --
+ ----------------------
+
+ procedure No_Type_Rep_Item (N : Node_Id) is
+ begin
+ Error_Msg_N ("|type-related representation item not permitted!", N);
+ end No_Type_Rep_Item;
+
--------------
-- Pop_Type --
--------------
N : Node_Id;
FOnly : Boolean := False) return Boolean
is
- function Is_Derived_Type_With_Constraint return Boolean;
- -- Check whether T is a derived type with an explicit constraint, in
- -- which case the constraint has frozen the type and the item is too
- -- late. This compensates for the fact that for derived scalar types
- -- we freeze the base type unconditionally on account of a long-standing
- -- issue in gigi.
-
- procedure No_Type_Rep_Item;
- -- Output message indicating that no type-related aspects can be
- -- specified due to some property of the parent type.
-
procedure Too_Late;
-- Output message for an aspect being specified too late
-- document the requirement in the spec of Rep_Item_Too_Late that
-- if True is returned, then the rep item must be completely ignored???
- --------------------------------------
- -- Is_Derived_Type_With_Constraint --
- --------------------------------------
-
- function Is_Derived_Type_With_Constraint return Boolean is
- Decl : constant Node_Id := Declaration_Node (T);
-
- begin
- return Is_Derived_Type (T)
- and then Is_Frozen (Base_Type (T))
- and then Is_Enumeration_Type (T)
- and then False
- and then Nkind (N) = N_Enumeration_Representation_Clause
- and then Nkind (Decl) = N_Subtype_Declaration
- and then not Is_Entity_Name (Subtype_Indication (Decl));
- end Is_Derived_Type_With_Constraint;
-
- ----------------------
- -- No_Type_Rep_Item --
- ----------------------
-
- procedure No_Type_Rep_Item is
- begin
- Error_Msg_N ("|type-related representation item not permitted!", N);
- end No_Type_Rep_Item;
-
--------------
-- Too_Late --
--------------
begin
-- First make sure entity is not frozen (RM 13.1(9))
- if (Is_Frozen (T)
- or else (Is_Type (T)
- and then Is_Derived_Type_With_Constraint))
+ if Is_Frozen (T)
-- Exclude imported types, which may be frozen if they appear in a
-- representation clause for a local type.
Parent_Type := Etype (Base_Type (T));
if Has_Primitive_Operations (Parent_Type) then
- No_Type_Rep_Item;
+ No_Type_Rep_Item (N);
if not Relaxed_RM_Semantics then
Error_Msg_NE
return True;
elsif Is_By_Reference_Type (Parent_Type) then
- No_Type_Rep_Item;
+ No_Type_Rep_Item (N);
if not Relaxed_RM_Semantics then
Error_Msg_NE
projects / platform / upstream / gcc.git / commitdiff