diff mbox series

[Ada] Premature freezing of types

Message ID 20210618083827.GA129766@adacore.com
State New
Headers show
Series [Ada] Premature freezing of types | expand

Commit Message

Pierre-Marie de Rodat June 18, 2021, 8:38 a.m. UTC 
GNAT was freezing prematurely any type referenced in a subprogram
profile as part of freezing, regardless of the scope involved, causing
premature freezing of types and therefore preventing declaration of
additional primitive operations.

This is now almost fully fixed. There is one remaining catch related to
the handling of expression functions whose body sometimes perform
dispatching calls: when these dispatching calls involve types in the
relevant scope, we still have to perform an early freeze in order to
properly build the dispatch table which would otherwise be unavailable
and cause many errors down the path.

Tested on x86_64-pc-linux-gnu, committed on trunk

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 mbox series

Patch

diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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))