ada: Fix crash on expression function returning tagged type in nested package

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.

diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index 548589284e24b4dc3d1710a271401f71a499d332..9c182b2c6b4780afc7d15a94e44b3f1c11a11990 100644 (file)
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -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.

diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index de096ea752a5c9affe387990587bb13f695b69c8..c5d3af7545e3245f8555c7a3575494900542f3a2 100644 (file)
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -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 --
    ------------------------------

diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads
index c772d411bcfd1dce975d6474d412126837d1037a..7fbbe5fc9fd28c36b158b17dbc54185a290020b2 100644 (file)
--- a/gcc/ada/exp_util.ads
+++ b/gcc/ada/exp_util.ads
@@ -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;

diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index cf7a22efcae14ba34fcdc9285b7b0b71c9462106..c8d20d020c70ac73d48734280523041d25448b96 100644 (file)
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -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 --
    ------------------