From: Arnaud Charlet <charlet@adacore.com>
Date: Wed, 30 Mar 2022 19:00:27 +0000 (+0000)
Subject: [Ada] Freezing too strict in instances
X-Git-Tag: basepoints/gcc-14~6619
X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=54cf6609e0c52123db5c600db197647491c33395;p=thirdparty%2Fgcc.git

[Ada] Freezing too strict in instances

Should_Freeze_Type is relaxed to only take the relevant case into
account (entities denoted by generic actual parameters as per
13.14(5/3), as well as profile of any subprograms named as per
13.14(10.2/4)), instead of being overly conservative wrt instances and
as a result, wrongly rejecting some legal code.

In practice this means we only need to worry about profile of
subprograms named as part of instances.

gcc/ada/

	* freeze.adb (Should_Freeze_Type): Fix handling of freezing in
	instances.
---

diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index b75f9ef07d5..4ff70367014 100644
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -184,9 +184,11 @@ 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
+   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.
@@ -198,7 +200,7 @@ package body Freeze is
    ------------------------
 
    function Should_Freeze_Type
-     (Typ : Entity_Id; E : Entity_Id) return Boolean
+     (Typ : Entity_Id; E : Entity_Id; N : Node_Id) return Boolean
    is
       function Is_Dispatching_Call_Or_Aggregate
         (N : Node_Id) return Traverse_Result;
@@ -244,7 +246,8 @@ package body Freeze is
 
    begin
       return Within_Scope (Typ, Current_Scope)
-        or else In_Instance
+        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);
@@ -4606,7 +4609,7 @@ package body Freeze is
             end if;
 
             if not From_Limited_With (F_Type)
-              and then Should_Freeze_Type (F_Type, E)
+              and then Should_Freeze_Type (F_Type, E, N)
             then
                Freeze_And_Append (F_Type, N, Result);
             end if;
@@ -4786,7 +4789,7 @@ package body Freeze is
                Set_Etype (E, R_Type);
             end if;
 
-            if Should_Freeze_Type (R_Type, E) then
+            if Should_Freeze_Type (R_Type, E, N) then
                Freeze_And_Append (R_Type, N, Result);
             end if;