From d251bf503c380e6bcf7ac566b71ba7052b6952e3 Mon Sep 17 00:00:00 2001
From: charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4>
Date: Fri, 17 Feb 2006 16:06:57 +0000
Subject: [PATCH] 2006-02-17 Ed Schonberg <schonberg@adacore.com>
* freeze.adb (Statically_Discriminated_Components): Return false if
the bounds of the type of the discriminant are not static expressions.
* sem_aggr.adb (Check_Static_Discriminated_Subtype): Return false if
the bounds of the discriminant type are not static.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@111187 138bc75d-0d04-0410-961f-82ee72b054a4
---
gcc/ada/freeze.adb | 19 +++++++++++++++++++
gcc/ada/sem_aggr.adb | 32 +++++++++++++++++---------------
2 files changed, 36 insertions(+), 15 deletions(-)
diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index 09363af823e6..da997c0dac6b 100644
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -887,12 +887,31 @@ package body Freeze is
(T : Entity_Id) return Boolean
is
Constraint : Elmt_Id;
+ Discr : Entity_Id;
begin
if Has_Discriminants (T)
and then Present (Discriminant_Constraint (T))
and then Present (First_Component (T))
then
+ Discr := First_Discriminant (T);
+
+ if Is_Access_Type (Etype (Discr)) then
+ null;
+
+ -- If the bounds of the discriminant are not compile-time known,
+ -- treat this as non-static, even if the value of the discriminant
+ -- is compile-time known, because the back-end treats aggregates
+ -- of such a subtype as having unknown size.
+
+ elsif not
+ (Compile_Time_Known_Value (Type_Low_Bound (Etype (Discr)))
+ and then
+ Compile_Time_Known_Value (Type_High_Bound (Etype (Discr))))
+ then
+ return False;
+ end if;
+
Constraint := First_Elmt (Discriminant_Constraint (T));
while Present (Constraint) loop
if not Compile_Time_Known_Value (Node (Constraint)) then
diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb
index 580dc29af450..9f0c5fc80dd0 100644
--- a/gcc/ada/sem_aggr.adb
+++ b/gcc/ada/sem_aggr.adb
@@ -731,13 +731,10 @@ package body Sem_Aggr is
Name_Buffer (1 .. Name_Len);
begin
-
Component_Elmt := First_Elmt (Elements);
-
while Nr_Of_Suggestions <= Max_Suggestions
and then Present (Component_Elmt)
loop
-
Get_Name_String (Chars (Node (Component_Elmt)));
if Is_Bad_Spelling_Of (Name_Buffer (1 .. Name_Len), S) then
@@ -785,12 +782,23 @@ package body Sem_Aggr is
elsif Nkind (V) /= N_Integer_Literal then
return;
+
+ elsif Is_Access_Type (Etype (Disc)) then
+ null;
+
+ -- If the bounds of the discriminant type are not compile time known,
+ -- the back-end will treat this as a variable-size object.
+
+ elsif not
+ (Compile_Time_Known_Value (Type_Low_Bound (Etype (Disc)))
+ and then
+ Compile_Time_Known_Value (Type_High_Bound (Etype (Disc))))
+ then
+ return;
end if;
Comp := First_Component (T);
-
while Present (Comp) loop
-
if Is_Scalar_Type (Etype (Comp)) then
null;
@@ -801,15 +809,12 @@ package body Sem_Aggr is
null;
elsif Is_Array_Type (Etype (Comp)) then
-
if Is_Bit_Packed_Array (Etype (Comp)) then
return;
end if;
Ind := First_Index (Etype (Comp));
-
while Present (Ind) loop
-
if Nkind (Ind) /= N_Range
or else Nkind (Low_Bound (Ind)) /= N_Integer_Literal
or else Nkind (High_Bound (Ind)) /= N_Integer_Literal
@@ -1615,7 +1620,6 @@ package body Sem_Aggr is
Assoc := First (Component_Associations (N));
while Present (Assoc) loop
-
Prev_Nb_Discrete_Choices := Nb_Discrete_Choices;
Choice := First (Choices (Assoc));
loop
@@ -2058,10 +2062,9 @@ package body Sem_Aggr is
elsif Nkind (A) /= N_Aggregate then
if Is_Overloaded (A) then
A_Type := Any_Type;
- Get_First_Interp (A, I, It);
+ Get_First_Interp (A, I, It);
while Present (It.Typ) loop
-
if Is_Tagged_Type (It.Typ)
and then not Is_Limited_Type (It.Typ)
then
@@ -2555,7 +2558,7 @@ package body Sem_Aggr is
if Is_Array_Type (Expr_Type) then
declare
- Index : Node_Id := First_Index (Expr_Type);
+ Index : Node_Id;
-- Range of the current constrained index in the array
Orig_Index : Node_Id := First_Index (Etype (Component));
@@ -2569,6 +2572,7 @@ package body Sem_Aggr is
-- range checks.
begin
+ Index := First_Index (Expr_Type);
while Present (Index) loop
if Depends_On_Discriminant (Orig_Index) then
Apply_Range_Check (Index, Etype (Unconstr_Index));
@@ -2890,7 +2894,6 @@ package body Sem_Aggr is
Parent_Typ := Base_Type (Typ);
while Parent_Typ /= Root_Typ loop
-
Prepend_Elmt (Parent_Typ, To => Parent_Typ_List);
Parent_Typ := Etype (Parent_Typ);
@@ -3208,11 +3211,10 @@ package body Sem_Aggr is
begin
K := L;
-
while K /= U loop
T := Case_Table (K + 1);
- J := K + 1;
+ J := K + 1;
while J /= L
and then Expr_Value (Case_Table (J - 1).Choice_Lo) >
Expr_Value (T.Choice_Lo)
--
GitLab