Commit 7f9747c6 by Ed Schonberg Committed by Arnaud Charlet

freeze.adb (Statically_Discriminated_Components): Return false if the bounds of…

freeze.adb (Statically_Discriminated_Components): Return false if the bounds of the type of the discriminant are not static...

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.

From-SVN: r111187
parent faad2f7e
...@@ -887,12 +887,31 @@ package body Freeze is ...@@ -887,12 +887,31 @@ package body Freeze is
(T : Entity_Id) return Boolean (T : Entity_Id) return Boolean
is is
Constraint : Elmt_Id; Constraint : Elmt_Id;
Discr : Entity_Id;
begin begin
if Has_Discriminants (T) if Has_Discriminants (T)
and then Present (Discriminant_Constraint (T)) and then Present (Discriminant_Constraint (T))
and then Present (First_Component (T)) and then Present (First_Component (T))
then 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)); Constraint := First_Elmt (Discriminant_Constraint (T));
while Present (Constraint) loop while Present (Constraint) loop
if not Compile_Time_Known_Value (Node (Constraint)) then if not Compile_Time_Known_Value (Node (Constraint)) then
......
...@@ -731,13 +731,10 @@ package body Sem_Aggr is ...@@ -731,13 +731,10 @@ package body Sem_Aggr is
Name_Buffer (1 .. Name_Len); Name_Buffer (1 .. Name_Len);
begin begin
Component_Elmt := First_Elmt (Elements); Component_Elmt := First_Elmt (Elements);
while Nr_Of_Suggestions <= Max_Suggestions while Nr_Of_Suggestions <= Max_Suggestions
and then Present (Component_Elmt) and then Present (Component_Elmt)
loop loop
Get_Name_String (Chars (Node (Component_Elmt))); Get_Name_String (Chars (Node (Component_Elmt)));
if Is_Bad_Spelling_Of (Name_Buffer (1 .. Name_Len), S) then if Is_Bad_Spelling_Of (Name_Buffer (1 .. Name_Len), S) then
...@@ -785,12 +782,23 @@ package body Sem_Aggr is ...@@ -785,12 +782,23 @@ package body Sem_Aggr is
elsif Nkind (V) /= N_Integer_Literal then elsif Nkind (V) /= N_Integer_Literal then
return; 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; end if;
Comp := First_Component (T); Comp := First_Component (T);
while Present (Comp) loop while Present (Comp) loop
if Is_Scalar_Type (Etype (Comp)) then if Is_Scalar_Type (Etype (Comp)) then
null; null;
...@@ -801,15 +809,12 @@ package body Sem_Aggr is ...@@ -801,15 +809,12 @@ package body Sem_Aggr is
null; null;
elsif Is_Array_Type (Etype (Comp)) then elsif Is_Array_Type (Etype (Comp)) then
if Is_Bit_Packed_Array (Etype (Comp)) then if Is_Bit_Packed_Array (Etype (Comp)) then
return; return;
end if; end if;
Ind := First_Index (Etype (Comp)); Ind := First_Index (Etype (Comp));
while Present (Ind) loop while Present (Ind) loop
if Nkind (Ind) /= N_Range if Nkind (Ind) /= N_Range
or else Nkind (Low_Bound (Ind)) /= N_Integer_Literal or else Nkind (Low_Bound (Ind)) /= N_Integer_Literal
or else Nkind (High_Bound (Ind)) /= N_Integer_Literal or else Nkind (High_Bound (Ind)) /= N_Integer_Literal
...@@ -1615,7 +1620,6 @@ package body Sem_Aggr is ...@@ -1615,7 +1620,6 @@ package body Sem_Aggr is
Assoc := First (Component_Associations (N)); Assoc := First (Component_Associations (N));
while Present (Assoc) loop while Present (Assoc) loop
Prev_Nb_Discrete_Choices := Nb_Discrete_Choices; Prev_Nb_Discrete_Choices := Nb_Discrete_Choices;
Choice := First (Choices (Assoc)); Choice := First (Choices (Assoc));
loop loop
...@@ -2058,10 +2062,9 @@ package body Sem_Aggr is ...@@ -2058,10 +2062,9 @@ package body Sem_Aggr is
elsif Nkind (A) /= N_Aggregate then elsif Nkind (A) /= N_Aggregate then
if Is_Overloaded (A) then if Is_Overloaded (A) then
A_Type := Any_Type; A_Type := Any_Type;
Get_First_Interp (A, I, It);
Get_First_Interp (A, I, It);
while Present (It.Typ) loop while Present (It.Typ) loop
if Is_Tagged_Type (It.Typ) if Is_Tagged_Type (It.Typ)
and then not Is_Limited_Type (It.Typ) and then not Is_Limited_Type (It.Typ)
then then
...@@ -2555,7 +2558,7 @@ package body Sem_Aggr is ...@@ -2555,7 +2558,7 @@ package body Sem_Aggr is
if Is_Array_Type (Expr_Type) then if Is_Array_Type (Expr_Type) then
declare declare
Index : Node_Id := First_Index (Expr_Type); Index : Node_Id;
-- Range of the current constrained index in the array -- Range of the current constrained index in the array
Orig_Index : Node_Id := First_Index (Etype (Component)); Orig_Index : Node_Id := First_Index (Etype (Component));
...@@ -2569,6 +2572,7 @@ package body Sem_Aggr is ...@@ -2569,6 +2572,7 @@ package body Sem_Aggr is
-- range checks. -- range checks.
begin begin
Index := First_Index (Expr_Type);
while Present (Index) loop while Present (Index) loop
if Depends_On_Discriminant (Orig_Index) then if Depends_On_Discriminant (Orig_Index) then
Apply_Range_Check (Index, Etype (Unconstr_Index)); Apply_Range_Check (Index, Etype (Unconstr_Index));
...@@ -2890,7 +2894,6 @@ package body Sem_Aggr is ...@@ -2890,7 +2894,6 @@ package body Sem_Aggr is
Parent_Typ := Base_Type (Typ); Parent_Typ := Base_Type (Typ);
while Parent_Typ /= Root_Typ loop while Parent_Typ /= Root_Typ loop
Prepend_Elmt (Parent_Typ, To => Parent_Typ_List); Prepend_Elmt (Parent_Typ, To => Parent_Typ_List);
Parent_Typ := Etype (Parent_Typ); Parent_Typ := Etype (Parent_Typ);
...@@ -3208,11 +3211,10 @@ package body Sem_Aggr is ...@@ -3208,11 +3211,10 @@ package body Sem_Aggr is
begin begin
K := L; K := L;
while K /= U loop while K /= U loop
T := Case_Table (K + 1); T := Case_Table (K + 1);
J := K + 1;
J := K + 1;
while J /= L while J /= L
and then Expr_Value (Case_Table (J - 1).Choice_Lo) > and then Expr_Value (Case_Table (J - 1).Choice_Lo) >
Expr_Value (T.Choice_Lo) Expr_Value (T.Choice_Lo)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment