public inbox for gcc-cvs@sourceware.org
help / color / mirror / Atom feed
* [gcc r12-1630] [Ada] Premature freezing of types
@ 2021-06-18 8:39 Pierre-Marie de Rodat
0 siblings, 0 replies; only message in thread
From: Pierre-Marie de Rodat @ 2021-06-18 8:39 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:4edcee5b2bf6ca2c0f7dcf5edcbe6daf715fc26a
commit r12-1630-g4edcee5b2bf6ca2c0f7dcf5edcbe6daf715fc26a
Author: Arnaud Charlet <charlet@adacore.com>
Date: Fri Mar 19 03:54:38 2021 -0400
[Ada] Premature freezing of types
gcc/ada/
* exp_ch4.adb (Expand_N_Quantified_Expression): Ensure the type
of the name of a "for of" loop is frozen.
* exp_disp.adb (Check_Premature_Freezing): Complete condition to
take into account a private type completed by another private
type now that the freezing rule are better implemented.
* freeze.adb (Freeze_Entity.Freeze_Profile): Do not perform an
early freeze on types if not in the proper scope. Special case
expression functions that requires access to the dispatch table.
(Should_Freeze_Type): New.
* sem_ch13.adb (Resolve_Aspect_Expressions): Prevent assert
failure in case of an invalid tree (previous errors detected).
* sem_res.adb (Resolve): Remove kludge related to entities
causing incorrect premature freezing.
* sem_util.adb (Ensure_Minimum_Decoration): Add protection
against non base types.
Diff:
---
gcc/ada/exp_ch4.adb | 13 +++++---
gcc/ada/exp_disp.adb | 2 ++
gcc/ada/freeze.adb | 83 ++++++++++++++++++++++++++++++++++++++++++++++++----
gcc/ada/sem_ch13.adb | 6 +++-
gcc/ada/sem_res.adb | 7 ++---
gcc/ada/sem_util.adb | 1 +
6 files changed, 96 insertions(+), 16 deletions(-)
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index 1d04a0613ca..9c585e74e50 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -10851,10 +10851,11 @@ package body Exp_Ch4 is
Var : Entity_Id;
begin
- -- Ensure that the bound variable is properly frozen. We must do
- -- this before expansion because the expression is about to be
- -- converted into a loop, and resulting freeze nodes may end up
- -- in the wrong place in the tree.
+ -- Ensure that the bound variable as well as the type of Name of the
+ -- Iter_Spec if present are properly frozen. We must do this before
+ -- expansion because the expression is about to be converted into a
+ -- loop, and resulting freeze nodes may end up in the wrong place in the
+ -- tree.
if Present (Iter_Spec) then
Var := Defining_Identifier (Iter_Spec);
@@ -10869,6 +10870,10 @@ package body Exp_Ch4 is
P := Parent (P);
end loop;
+ if Present (Iter_Spec) then
+ Freeze_Before (P, Etype (Name (Iter_Spec)));
+ end if;
+
Freeze_Before (P, Etype (Var));
end;
diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb
index eb6b352bef9..a2ea7c6e88a 100644
--- a/gcc/ada/exp_disp.adb
+++ b/gcc/ada/exp_disp.adb
@@ -4052,6 +4052,7 @@ package body Exp_Disp is
if Present (N)
and then Is_Private_Type (Typ)
and then No (Full_View (Typ))
+ and then not Has_Private_Declaration (Typ)
and then not Is_Generic_Type (Typ)
and then not Is_Tagged_Type (Typ)
and then not Is_Frozen (Typ)
@@ -4070,6 +4071,7 @@ package body Exp_Disp is
if not Is_Tagged_Type (Typ)
and then Present (Comp)
and then not Is_Frozen (Comp)
+ and then not Has_Private_Declaration (Comp)
and then not Is_Actual_For_Formal_Incomplete_Type (Comp)
then
Error_Msg_Sloc := Sloc (Subp);
diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index b539e59ae4c..9bb27320573 100644
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -186,6 +186,72 @@ package body Freeze is
-- the designated type. Otherwise freezing the access type does not freeze
-- the designated type.
+ function Should_Freeze_Type (Typ : Entity_Id; E : Entity_Id) return Boolean;
+ -- If Typ is in the current scope or in an instantiation, then return True.
+ -- ???Expression functions (represented by E) shouldn't freeze types in
+ -- general, but our current expansion and freezing model requires an early
+ -- freezing when the dispatch table is needed or when building an aggregate
+ -- with a subtype of Typ, so return True also in this case.
+ -- Note that expression function completions do freeze and are
+ -- handled in Sem_Ch6.Analyze_Expression_Function.
+
+ ------------------------
+ -- Should_Freeze_Type --
+ ------------------------
+
+ function Should_Freeze_Type
+ (Typ : Entity_Id; E : Entity_Id) return Boolean
+ is
+ function Is_Dispatching_Call_Or_Aggregate
+ (N : Node_Id) return Traverse_Result;
+ -- Return Abandon if N is a dispatching call to a subprogram
+ -- declared in the same scope as Typ or an aggregate whose type
+ -- is Typ.
+
+ --------------------------------------
+ -- Is_Dispatching_Call_Or_Aggregate --
+ --------------------------------------
+
+ function Is_Dispatching_Call_Or_Aggregate
+ (N : Node_Id) return Traverse_Result is
+ begin
+ if Nkind (N) = N_Function_Call
+ and then Present (Controlling_Argument (N))
+ and then Scope (Entity (Original_Node (Name (N))))
+ = Scope (Typ)
+ then
+ return Abandon;
+ elsif Nkind (N) = N_Aggregate
+ and then Base_Type (Etype (N)) = Base_Type (Typ)
+ then
+ return Abandon;
+ else
+ return OK;
+ end if;
+ end Is_Dispatching_Call_Or_Aggregate;
+
+ -------------------------
+ -- Need_Dispatch_Table --
+ -------------------------
+
+ function Need_Dispatch_Table is new
+ Traverse_Func (Is_Dispatching_Call_Or_Aggregate);
+ -- Return Abandon if the input expression requires access to
+ -- Typ's dispatch table.
+
+ Decl : constant Node_Id :=
+ (if No (E) then E else Original_Node (Unit_Declaration_Node (E)));
+
+ -- Start of processing for Should_Freeze_Type
+
+ begin
+ return Within_Scope (Typ, Current_Scope)
+ or else In_Instance
+ or else (Present (Decl)
+ and then Nkind (Decl) = N_Expression_Function
+ and then Need_Dispatch_Table (Expression (Decl)) = Abandon);
+ end Should_Freeze_Type;
+
procedure Process_Default_Expressions
(E : Entity_Id;
After : in out Node_Id);
@@ -4006,7 +4072,9 @@ package body Freeze is
Set_Etype (Formal, F_Type);
end if;
- if not From_Limited_With (F_Type) then
+ if not From_Limited_With (F_Type)
+ and then Should_Freeze_Type (F_Type, E)
+ then
Freeze_And_Append (F_Type, N, Result);
end if;
@@ -4183,7 +4251,9 @@ package body Freeze is
Set_Etype (E, R_Type);
end if;
- Freeze_And_Append (R_Type, N, Result);
+ if Should_Freeze_Type (R_Type, E) then
+ Freeze_And_Append (R_Type, N, Result);
+ end if;
-- Check suspicious return type for C function
@@ -5951,11 +6021,12 @@ package body Freeze is
-- Here for other than a subprogram or type
else
- -- If entity has a type, and it is not a generic unit, then freeze
- -- it first (RM 13.14(10)).
+ -- If entity has a type declared in the current scope, and it is
+ -- not a generic unit, then freeze it first.
if Present (Etype (E))
and then Ekind (E) /= E_Generic_Function
+ and then Within_Scope (Etype (E), Current_Scope)
then
Freeze_And_Append (Etype (E), N, Result);
@@ -7783,7 +7854,7 @@ package body Freeze is
-- tree. This is an unusual case, but there are some legitimate
-- situations in which this occurs, notably when the expressions
-- in the range of a type declaration are resolved. We simply
- -- ignore the freeze request in this case. Is this right ???
+ -- ignore the freeze request in this case.
if No (Parent_P) then
return;
@@ -8043,7 +8114,7 @@ package body Freeze is
end case;
-- We fall through the case if we did not yet find the proper
- -- place in the free for inserting the freeze node, so climb.
+ -- place in the tree for inserting the freeze node, so climb.
P := Parent_P;
end loop;
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index 22eb168d413..062aa50017a 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -15106,7 +15106,11 @@ package body Sem_Ch13 is
begin
Assoc := First (Component_Associations (Expr));
while Present (Assoc) loop
- Find_Direct_Name (Expression (Assoc));
+ if Nkind (Expression (Assoc)) in N_Has_Entity
+ then
+ Find_Direct_Name (Expression (Assoc));
+ end if;
+
Next (Assoc);
end loop;
end;
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index 720f170ff73..be0945325fd 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -3391,12 +3391,9 @@ package body Sem_Res is
-- Here we are resolving the corresponding expanded body, so we do
-- need to perform normal freezing.
- -- As elsewhere we do not emit freeze node within a generic. We make
- -- an exception for entities that are expressions, only to detect
- -- misuses of deferred constants and preserve the output of various
- -- tests.
+ -- As elsewhere we do not emit freeze node within a generic.
- if not Inside_A_Generic or else Is_Entity_Name (N) then
+ if not Inside_A_Generic then
Freeze_Expression (N);
end if;
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 9849071fe0d..cfbbae0e2d5 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -26744,6 +26744,7 @@ package body Sem_Util is
if Present (Typ)
and then not Is_Frozen (Typ)
+ and then Is_Base_Type (Typ)
and then (Is_Record_Type (Typ)
or else Is_Concurrent_Type (Typ)
or else Is_Incomplete_Or_Private_Type (Typ))
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2021-06-18 8:39 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2021-06-18 8:39 [gcc r12-1630] [Ada] Premature freezing of types Pierre-Marie de Rodat
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).