Commit d9ef7b97 by Ed Schonberg Committed by Pierre-Marie de Rodat

[Ada] Representation clause for derived enumeration type is mishandled

This patch fixes an old-standing problem with premature freezing. When a
derived type declaration includes a constraint, we generate a subtype
declaration of an anonymous base type, with the constraint given in the
original type declaration, Conceptually, the bounds are converted to the
new base type, and this conversion freezes (prematurely) that base type,
when the bounds are simply literals.  As a result, a representation
clause for the derived type is then rejected or ignared. This procedure
recognizes the simple case of literal bounds in derived enumeration type
declarations, which allows us to indicate that the conversions are not
freeze points, and the subsequent representation clause can be accepted.

2019-08-19  Ed Schonberg  <schonberg@adacore.com>

gcc/ada/

	* sem_ch3.adb (Derived_Enumeration_Type): Do no freeze anonymous
	base type if the bounds in the derived type declaration are
	literals of the type.

gcc/testsuite/

	* gnat.dg/rep_clause9.adb: New testcase.

From-SVN: r274641
parent c811dd91
2019-08-19 Ed Schonberg <schonberg@adacore.com>
* sem_ch3.adb (Derived_Enumeration_Type): Do no freeze anonymous
base type if the bounds in the derived type declaration are
literals of the type.
2019-08-19 Yannick Moy <moy@adacore.com> 2019-08-19 Yannick Moy <moy@adacore.com>
* sem_res.adb (Resolve_Call): Check non-aliasing rules before * sem_res.adb (Resolve_Call): Check non-aliasing rules before
......
...@@ -7135,6 +7135,27 @@ package body Sem_Ch3 is ...@@ -7135,6 +7135,27 @@ package body Sem_Ch3 is
Parent_Type : Entity_Id; Parent_Type : Entity_Id;
Derived_Type : Entity_Id) Derived_Type : Entity_Id)
is is
function Bound_Belongs_To_Type (B : Node_Id) return Boolean;
-- When the type declaration includes a constraint, we generate
-- a subtype declaration of an anonymous base type, with the constraint
-- given in the original type declaration. Conceptually, the bounds
-- are converted to the new base type, and this conversion freezes
-- (prematurely) that base type, when the bounds are simply literals.
-- As a result, a representation clause for the derived type is then
-- rejected or ignored. This procedure recognizes the simple case of
-- literal bounds, which allows us to indicate that the conversions
-- are not freeze points, and the subsequent representation clause
-- can be accepted.
-- A similar approach might be used to resolve the long-standing
-- problem of premature freezing of derived numeric types ???
function Bound_Belongs_To_Type (B : Node_Id) return Boolean is
begin
return Nkind (B) = N_Type_Conversion
and then Is_Entity_Name (Expression (B))
and then Ekind (Entity (Expression (B))) = E_Enumeration_Literal;
end Bound_Belongs_To_Type;
Loc : constant Source_Ptr := Sloc (N); Loc : constant Source_Ptr := Sloc (N);
Def : constant Node_Id := Type_Definition (N); Def : constant Node_Id := Type_Definition (N);
Indic : constant Node_Id := Subtype_Indication (Def); Indic : constant Node_Id := Subtype_Indication (Def);
...@@ -7350,7 +7371,9 @@ package body Sem_Ch3 is ...@@ -7350,7 +7371,9 @@ package body Sem_Ch3 is
-- However, if the type inherits predicates the expressions will -- However, if the type inherits predicates the expressions will
-- be elaborated earlier and must freeze. -- be elaborated earlier and must freeze.
if Nkind (Indic) /= N_Subtype_Indication if (Nkind (Indic) /= N_Subtype_Indication
or else
(Bound_Belongs_To_Type (Lo) and then Bound_Belongs_To_Type (Hi)))
and then not Has_Predicates (Derived_Type) and then not Has_Predicates (Derived_Type)
then then
Set_Must_Not_Freeze (Lo); Set_Must_Not_Freeze (Lo);
......
2019-08-19 Ed Schonberg <schonberg@adacore.com>
* gnat.dg/rep_clause9.adb: New testcase.
2019-08-19 Olivier Hainque <hainque@adacore.com> 2019-08-19 Olivier Hainque <hainque@adacore.com>
* gnat.dg/openacc1.adb: New testcase. * gnat.dg/openacc1.adb: New testcase.
......
-- { dg-do run }
procedure Rep_Clause9 is
type Day_Of_Week
is (Sunday, Monday, Tuesday, Wednesday, Thursday, Friday, Saturday);
type New_Day_Of_Week is new Day_Of_Week range Monday .. Friday;
for New_Day_Of_Week use
(Sunday => -4, Monday => -2, Tuesday => 1, Wednesday => 100,
Thursday => 1000, Friday => 10000, Saturday => 10001);
V1 : New_Day_Of_Week;
begin
if Integer'Image(New_Day_Of_Week'Pos(Monday)) /= " 1" then
raise Program_Error;
end if;
V1 := Monday;
if Integer'Image(New_Day_Of_Week'Pos(V1)) /= " 1" then
raise Program_Error;
end if;
end;
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