From 98376aab0368fd9a1a3c7393f302002cc5d30506 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Wed, 25 Mar 2020 06:15:26 -0400 Subject: [PATCH] [Ada] Missing errors on aspect checking 2020-06-15 Arnaud Charlet gcc/ada/ * sem_attr.adb (Eval_Attribute): Protect against previous errors. * sem_ch13.adb (Analyze_Aspect_Default_Value): Remove redundant error checking, handling in Analyze_Aspect_Specifications. (Analyze_Aspect_Specifications): Refine error messages on Default_[Component_]Value. (Check_Aspect_Too_Late): New procedure. (Rep_Item_Too_Late.Is_Derived_Type_With_Constraint): Remove, dead code. * aspects.ads (Is_Representation_Aspect): Default_Value is a representation aspect. --- gcc/ada/aspects.ads | 2 +- gcc/ada/sem_attr.adb | 23 ++++- gcc/ada/sem_ch13.adb | 237 +++++++++++++++++++++++++++++++-------------------- 3 files changed, 164 insertions(+), 98 deletions(-) diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads index 383a528..1c7d3c4 100644 --- a/gcc/ada/aspects.ads +++ b/gcc/ada/aspects.ads @@ -450,7 +450,7 @@ package Aspects is Aspect_Default_Initial_Condition => False, Aspect_Default_Iterator => False, Aspect_Default_Storage_Pool => True, - Aspect_Default_Value => False, + Aspect_Default_Value => True, Aspect_Depends => False, Aspect_Dimension => False, Aspect_Dimension_System => False, diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 2bb24a2..10b332b 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -7269,13 +7269,19 @@ package body Sem_Attr is procedure Eval_Attribute (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); - Aname : constant Name_Id := Attribute_Name (N); - Id : constant Attribute_Id := Get_Attribute_Id (Aname); - P : constant Node_Id := Prefix (N); C_Type : constant Entity_Id := Etype (N); -- The type imposed by the context + Aname : Name_Id; + -- Attribute_Name (N) after verification of validity of N + + Id : Attribute_Id; + -- Get_Attribute_Id (Aname) after Aname is set + + P : Node_Id; + -- Prefix (N) after verification of validity of N + E1 : Node_Id; -- First expression, or Empty if none @@ -7632,6 +7638,17 @@ package body Sem_Attr is -- Start of processing for Eval_Attribute begin + -- Return immediately if e.g. N has been rewritten or is malformed due + -- to previous errors. + + if Nkind (N) /= N_Attribute_Reference then + return; + end if; + + Aname := Attribute_Name (N); + Id := Get_Attribute_Id (Aname); + P := Prefix (N); + -- The To_Address attribute can be static, but it cannot be evaluated at -- compile time, so just return. diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 503fd15..3bdc39a 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -229,6 +229,10 @@ package body Sem_Ch13 is -- 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; @@ -885,6 +889,14 @@ package body Sem_Ch13 is -- 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 @@ -918,47 +930,110 @@ package body Sem_Ch13 is ---------------------------------- 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 -- @@ -967,7 +1042,7 @@ package body Sem_Ch13 is 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 @@ -3631,26 +3706,34 @@ package body Sem_Ch13 is -- 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; @@ -4157,13 +4240,9 @@ package body Sem_Ch13 is -- 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; @@ -12930,9 +13009,9 @@ package body Sem_Ch13 is return S; end Minimum_Size; - --------------------------- + ------------------------------ -- New_Put_Image_Subprogram -- - --------------------------- + ------------------------------ procedure New_Put_Image_Subprogram (N : Node_Id; @@ -13209,6 +13288,15 @@ package body Sem_Ch13 is 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 -- -------------- @@ -13365,17 +13453,6 @@ package body Sem_Ch13 is 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 @@ -13386,32 +13463,6 @@ package body Sem_Ch13 is -- 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 -- -------------- @@ -13437,9 +13488,7 @@ package body Sem_Ch13 is 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. @@ -13490,7 +13539,7 @@ package body Sem_Ch13 is 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 @@ -13500,7 +13549,7 @@ package body Sem_Ch13 is 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 -- 2.7.4