@@ -6989,14 +6989,7 @@ package body Exp_Ch6 is
if Present (Utyp)
and then Is_Tagged_Type (Utyp)
and then not Is_Class_Wide_Type (Utyp)
- and then (Nkind (Exp) in
- N_Type_Conversion | N_Unchecked_Type_Conversion
- or else (Nkind (Exp) = N_Explicit_Dereference
- and then Nkind (Prefix (Exp)) in
- N_Type_Conversion |
- N_Unchecked_Type_Conversion)
- or else (Is_Entity_Name (Exp)
- and then Is_Formal (Entity (Exp))))
+ and then Is_Conversion_Or_Reference_To_Formal (Exp)
then
-- When the return type is limited, perform a check that the tag of
-- the result is the same as the tag of the return type.
@@ -8560,6 +8560,22 @@ package body Exp_Util is
end if;
end Is_Captured_Function_Call;
+ ------------------------------------------
+ -- Is_Conversion_Or_Reference_To_Formal --
+ ------------------------------------------
+
+ function Is_Conversion_Or_Reference_To_Formal (N : Node_Id) return Boolean
+ is
+ begin
+ return Nkind (N) in N_Type_Conversion | N_Unchecked_Type_Conversion
+ or else (Nkind (N) = N_Explicit_Dereference
+ and then Nkind (Prefix (N)) in N_Type_Conversion
+ | N_Unchecked_Type_Conversion)
+ or else (Is_Entity_Name (N)
+ and then Present (Entity (N))
+ and then Is_Formal (Entity (N)));
+ end Is_Conversion_Or_Reference_To_Formal;
+
------------------------------
-- Is_Finalizable_Transient --
------------------------------
@@ -769,6 +769,10 @@ package Exp_Util is
-- Rnn : constant Ann := Func (...)'reference;
-- Rnn.all
+ function Is_Conversion_Or_Reference_To_Formal (N : Node_Id) return Boolean;
+ -- Return True if N is a type conversion, or a dereference thereof, or a
+ -- reference to a formal parameter.
+
function Is_Finalizable_Transient
(Decl : Node_Id;
N : Node_Id) return Boolean;
@@ -185,77 +185,6 @@ 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; N : Node_Id) return Boolean;
- -- If Typ is in the current scope, then return True.
- -- N is a node whose source location corresponds to the freeze point.
- -- ??? 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; N : Node_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) in N_Aggregate
- | N_Extension_Aggregate
- | N_Delta_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 (Nkind (N) = N_Subprogram_Renaming_Declaration
- and then Present (Corresponding_Formal_Spec (N)))
- 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);
@@ -282,6 +211,17 @@ package body Freeze is
-- attribute definition clause occurs, then these two flags are reset in
-- any case, so call will have no effect.
+ function Should_Freeze_Type
+ (Typ : Entity_Id;
+ E : Entity_Id;
+ N : Node_Id) return Boolean;
+ -- True if Typ should be frozen when the profile of E is being frozen at N.
+
+ -- ??? Expression functions that are not completions shouldn't freeze types
+ -- but our current expansion and freezing model requires an early freezing
+ -- when the tag of Typ is needed or for an aggregate with a subtype of Typ,
+ -- so we return True in these cases.
+
procedure Undelay_Type (T : Entity_Id);
-- T is a type of a component that we know to be an Itype. We don't want
-- this to have a Freeze_Node, so ensure it doesn't. Do the same for any
@@ -10592,6 +10532,104 @@ package body Freeze is
end if;
end Set_SSO_From_Default;
+ ------------------------
+ -- Should_Freeze_Type --
+ ------------------------
+
+ function Should_Freeze_Type
+ (Typ : Entity_Id;
+ E : Entity_Id;
+ N : Node_Id) return Boolean
+ is
+ Decl : constant Node_Id := Original_Node (Unit_Declaration_Node (E));
+
+ function Is_Dispatching_Call_Or_Tagged_Result_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 a tagged result that
+ -- needs specific expansion, or an aggregate whose type is Typ.
+
+ function Check_Freezing is new
+ Traverse_Func (Is_Dispatching_Call_Or_Tagged_Result_Or_Aggregate);
+ -- Return Abandon if the input expression requires freezing Typ
+
+ function Within_Simple_Return_Statement (N : Node_Id) return Boolean;
+ -- Determine whether N is the expression of a simple return statement,
+ -- or the dependent expression of a conditional expression which is
+ -- the expression of a simple return statement, including recursively.
+
+ -------------------------------------------------------
+ -- Is_Dispatching_Call_Or_Tagged_Result_Or_Aggregate --
+ -------------------------------------------------------
+
+ function Is_Dispatching_Call_Or_Tagged_Result_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;
+
+ -- The expansion done in Expand_Simple_Function_Return will assign
+ -- the tag to the result in this case.
+
+ elsif Is_Conversion_Or_Reference_To_Formal (N)
+ and then Within_Simple_Return_Statement (N)
+ and then Etype (N) = Typ
+ and then Is_Tagged_Type (Typ)
+ and then not Is_Class_Wide_Type (Typ)
+ then
+ return Abandon;
+
+ elsif Nkind (N) in N_Aggregate
+ | N_Delta_Aggregate
+ | N_Extension_Aggregate
+ and then Base_Type (Etype (N)) = Base_Type (Typ)
+ then
+ return Abandon;
+
+ else
+ return OK;
+ end if;
+ end Is_Dispatching_Call_Or_Tagged_Result_Or_Aggregate;
+
+ ------------------------------------
+ -- Within_Simple_Return_Statement --
+ ------------------------------------
+
+ function Within_Simple_Return_Statement (N : Node_Id) return Boolean is
+ Par : constant Node_Id := Parent (N);
+
+ begin
+ if Nkind (Par) = N_Simple_Return_Statement then
+ return True;
+
+ elsif Nkind (Par) = N_Case_Expression_Alternative then
+ return Within_Simple_Return_Statement (Parent (Par));
+
+ elsif Nkind (Par) = N_If_Expression
+ and then N /= First (Expressions (Par))
+ then
+ return Within_Simple_Return_Statement (Par);
+
+ else
+ return False;
+ end if;
+ end Within_Simple_Return_Statement;
+
+ -- Start of processing for Should_Freeze_Type
+
+ begin
+ return Within_Scope (Typ, Current_Scope)
+ or else (Nkind (N) = N_Subprogram_Renaming_Declaration
+ and then Present (Corresponding_Formal_Spec (N)))
+ or else (Present (Decl)
+ and then Nkind (Decl) = N_Expression_Function
+ and then Check_Freezing (Expression (Decl)) = Abandon);
+ end Should_Freeze_Type;
+
------------------
-- Undelay_Type --
------------------
From: Eric Botcazou <ebotcazou@adacore.com> This happens when the expression is a reference to a formal parameter of the function, or a conditional expression with such a reference as one of its dependent expressions, because the RM 6.5(8/5) subclause prescribes a tag reassignment in this case, which requires freezing the tagged type in the GNAT freezing model, although the language says there is no freezing. In other words, it's another occurrence of the discrepancy between this model tailored to Ada 95 and the freezing rules introduced in Ada 2012, that is papered over by Should_Freeze_Type and the associated processing. gcc/ada/ * exp_util.ads (Is_Conversion_Or_Reference_To_Formal): New function declaration. * exp_util.adb (Is_Conversion_Or_Reference_To_Formal): New function body. * exp_ch6.adb (Expand_Simple_Function_Return): Call the predicate Is_Conversion_Or_Reference_To_Formal in order to decide whether a tag check or reassignment is needed. * freeze.adb (Should_Freeze_Type): Move declaration and body to the appropriate places. Also return True for tagged results subject to the expansion done in Expand_Simple_Function_Return that is guarded by the predicate Is_Conversion_Or_Reference_To_Formal. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_ch6.adb | 9 +-- gcc/ada/exp_util.adb | 16 ++++ gcc/ada/exp_util.ads | 4 + gcc/ada/freeze.adb | 180 ++++++++++++++++++++++++++----------------- 4 files changed, 130 insertions(+), 79 deletions(-)