When subtype predicate checks are added for object declarations, it
could lead to a compiler crash or to an incorrect check.
When the subtype for the object being declared is built later by
Analyze_Object_Declaration, the predicate check can't be applied on the
object instead of a copy as the call will be incorrect after the subtype
has been built.
When subtypes for LHS and RHS do not statically match, only checking the
predicate on the object after it has been initialized may miss a failing
predicate on the RHS.
In both cases, skip the optimization and check the predicate on a copy.
Rename Should_Build_Subtype into Build_Default_Subtype_OK and move it
out of sem_ch3 to make it available to other part of the compiler (in
particular to checks.adb).
Tested on x86_64-pc-linux-gnu, committed on trunk
gcc/ada/
* checks.adb (Apply_Predicate_Check): Refine condition for
applying optimization.
* sem_ch3.adb (Analyze_Component_Declaration): Adjust calls to
Should_Build_Subtype.
(Analyze_Object_Declaration): Likewise.
(Should_Build_Subtype): Rename/move to ...
* sem_util.ads (Build_Default_Subtype_OK): ... this.
* sem_util.adb (Build_Default_Subtype_OK): Moved from
sem_ch3.adb.diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb
--- a/gcc/ada/checks.adb
+++ b/gcc/ada/checks.adb
@@ -2944,14 +2944,28 @@ package body Checks is
-- Similarly, if the expression is an aggregate in an object
-- declaration, apply it to the object after the declaration.
- -- This is only necessary in rare cases of tagged extensions
- -- initialized with an aggregate with an "others => <>" clause.
+
+ -- This is only necessary in cases of tagged extensions
+ -- initialized with an aggregate with an "others => <>" clause,
+ -- when the subtypes of LHS and RHS do not statically match or
+ -- when we know the object's type will be rewritten later.
+ -- The condition for the later is copied from the
+ -- Analyze_Object_Declaration procedure when it actually builds the
+ -- subtype.
elsif Nkind (Par) = N_Object_Declaration then
- Insert_Action_After (Par,
- Make_Predicate_Check (Typ,
- New_Occurrence_Of (Defining_Identifier (Par), Sloc (N))));
- return;
+ if Subtypes_Statically_Match
+ (Etype (Defining_Identifier (Par)), Typ)
+ and then (Nkind (N) = N_Extension_Aggregate
+ or else (Is_Definite_Subtype (Typ)
+ and then Build_Default_Subtype_OK (Typ)))
+ then
+ Insert_Action_After (Par,
+ Make_Predicate_Check (Typ,
+ New_Occurrence_Of (Defining_Identifier (Par), Sloc (N))));
+ return;
+ end if;
+
end if;
end if;
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -725,16 +725,6 @@ package body Sem_Ch3 is
-- sets the flags SSO_Set_Low_By_Default/SSO_Set_High_By_Default according
-- to the setting of Opt.Default_SSO.
- function Should_Build_Subtype (T : Entity_Id) return Boolean;
- -- When analyzing components or object declarations, it is possible, in
- -- some cases, to build subtypes for discriminated types. This is
- -- worthwhile to avoid the backend allocating the maximum possible size for
- -- objects of the type.
- -- In particular, when T is limited, the discriminants and therefore the
- -- size of an object of type T cannot change. Furthermore, if T is definite
- -- with statically initialized defaulted discriminants, we are able and
- -- want to build a constrained subtype of the right size.
-
procedure Signed_Integer_Type_Declaration (T : Entity_Id; Def : Node_Id);
-- Create a new signed integer entity, and apply the constraint to obtain
-- the required first named subtype of this type.
@@ -2214,7 +2204,7 @@ package body Sem_Ch3 is
-- When possible, build the default subtype
- if Should_Build_Subtype (T) then
+ if Build_Default_Subtype_OK (T) then
declare
Act_T : constant Entity_Id := Build_Default_Subtype (T, N);
@@ -4815,7 +4805,7 @@ package body Sem_Ch3 is
-- When possible, build the default subtype
- elsif Should_Build_Subtype (T) then
+ elsif Build_Default_Subtype_OK (T) then
if No (E) then
Act_T := Build_Default_Subtype (T, N);
else
@@ -22963,80 +22953,6 @@ package body Sem_Ch3 is
end if;
end Set_Stored_Constraint_From_Discriminant_Constraint;
- --------------------------
- -- Should_Build_Subtype --
- --------------------------
-
- function Should_Build_Subtype (T : Entity_Id) return Boolean is
-
- function Default_Discriminant_Values_Known_At_Compile_Time
- (T : Entity_Id) return Boolean;
- -- For an unconstrained type T, return False if the given type has a
- -- discriminant with default value not known at compile time. Return
- -- True otherwise.
-
- ---------------------------------------------------------
- -- Default_Discriminant_Values_Known_At_Compile_Time --
- ---------------------------------------------------------
-
- function Default_Discriminant_Values_Known_At_Compile_Time
- (T : Entity_Id) return Boolean
- is
- Discr : Entity_Id;
- DDV : Node_Id;
-
- begin
-
- -- If the type has no discriminant, we know them all at compile time
-
- if not Has_Discriminants (T) then
- return True;
- end if;
-
- -- The type has discriminants, check that none of them has a default
- -- value not known at compile time.
-
- Discr := First_Discriminant (T);
-
- while Present (Discr) loop
- DDV := Discriminant_Default_Value (Discr);
-
- if Present (DDV) and then not Compile_Time_Known_Value (DDV) then
- return False;
- end if;
-
- Next_Discriminant (Discr);
- end loop;
-
- return True;
- end Default_Discriminant_Values_Known_At_Compile_Time;
-
- -- Start of processing for Should_Build_Subtype
-
- begin
-
- if Is_Constrained (T) then
-
- -- We won't build a new subtype if T is constrained
-
- return False;
- end if;
-
- if not Default_Discriminant_Values_Known_At_Compile_Time (T) then
-
- -- This is a special case of definite subtypes. To allocate a
- -- specific size to the subtype, we need to know the value at compile
- -- time. This might not be the case if the default value is the
- -- result of a function. In that case, the object might be definite
- -- and limited but the needed size might not be statically known or
- -- too tricky to obtain. In that case, we will not build the subtype.
-
- return False;
- end if;
-
- return Is_Definite_Subtype (T) and then Is_Limited_View (T);
- end Should_Build_Subtype;
-
-------------------------------------
-- Signed_Integer_Type_Declaration --
-------------------------------------
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -2533,6 +2533,80 @@ package body Sem_Util is
end;
end Build_Default_Subtype;
+ ------------------------------
+ -- Build_Default_Subtype_OK --
+ ------------------------------
+
+ function Build_Default_Subtype_OK (T : Entity_Id) return Boolean is
+
+ function Default_Discriminant_Values_Known_At_Compile_Time
+ (T : Entity_Id) return Boolean;
+ -- For an unconstrained type T, return False if the given type has a
+ -- discriminant with default value not known at compile time. Return
+ -- True otherwise.
+
+ ---------------------------------------------------------
+ -- Default_Discriminant_Values_Known_At_Compile_Time --
+ ---------------------------------------------------------
+
+ function Default_Discriminant_Values_Known_At_Compile_Time
+ (T : Entity_Id) return Boolean
+ is
+ Discr : Entity_Id;
+ DDV : Node_Id;
+
+ begin
+
+ -- If the type has no discriminant, we know them all at compile time
+
+ if not Has_Discriminants (T) then
+ return True;
+ end if;
+
+ -- The type has discriminants, check that none of them has a default
+ -- value not known at compile time.
+
+ Discr := First_Discriminant (T);
+
+ while Present (Discr) loop
+ DDV := Discriminant_Default_Value (Discr);
+
+ if Present (DDV) and then not Compile_Time_Known_Value (DDV) then
+ return False;
+ end if;
+
+ Next_Discriminant (Discr);
+ end loop;
+
+ return True;
+ end Default_Discriminant_Values_Known_At_Compile_Time;
+
+ -- Start of processing for Build_Default_Subtype_OK
+
+ begin
+
+ if Is_Constrained (T) then
+
+ -- We won't build a new subtype if T is constrained
+
+ return False;
+ end if;
+
+ if not Default_Discriminant_Values_Known_At_Compile_Time (T) then
+
+ -- This is a special case of definite subtypes. To allocate a
+ -- specific size to the subtype, we need to know the value at compile
+ -- time. This might not be the case if the default value is the
+ -- result of a function. In that case, the object might be definite
+ -- and limited but the needed size might not be statically known or
+ -- too tricky to obtain. In that case, we will not build the subtype.
+
+ return False;
+ end if;
+
+ return Is_Definite_Subtype (T) and then Is_Limited_View (T);
+ end Build_Default_Subtype_OK;
+
--------------------------------------------
-- Build_Discriminal_Subtype_Of_Component --
--------------------------------------------
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -320,6 +320,16 @@ package Sem_Util is
-- declaration in the tree before N, and return the entity of that
-- subtype. Otherwise, simply return T.
+ function Build_Default_Subtype_OK (T : Entity_Id) return Boolean;
+ -- When analyzing components or object declarations, it is possible, in
+ -- some cases, to build subtypes for discriminated types. This is
+ -- worthwhile to avoid the backend allocating the maximum possible size for
+ -- objects of the type.
+ -- In particular, when T is limited, the discriminants and therefore the
+ -- size of an object of type T cannot change. Furthermore, if T is definite
+ -- with statically initialized defaulted discriminants, we are able and
+ -- want to build a constrained subtype of the right size.
+
function Build_Discriminal_Subtype_Of_Component
(T : Entity_Id) return Node_Id;
-- Determine whether a record component has a type that depends on
