From: Ed Schonberg <schonberg@adacore.com>
Date: Tue, 7 Jun 2022 20:22:04 +0000 (-0700)
Subject: [Ada] Proper freezing for dispatching expression functions.
X-Git-Tag: basepoints/gcc-14~5580
X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=be4ab2ae015e1e18a4e5b57ab5d87e6f30e6749e;p=thirdparty%2Fgcc.git

[Ada] Proper freezing for dispatching expression functions.

In the case of an expression function that is a primitive function of a
tagged type, freezing the tagged type needs to freeze the function (and
its return expression). A bug in this area could result in incorrect
behavior both at compile time and at run time. At compile time, freezing
rule violations could go undetected so that an illegal program could be
incorrectly accepted. At run time, a dispatching call to the primitive
function could end up dispatching through a not-yet-initialized slot in
the dispatch table, typically (although not always) resulting in a
segmentation fault.

gcc/ada/

	* freeze.adb (Check_Expression_Function.Find_Constant): Add a
	check that a type that is referenced as the prefix of an
	attribute is fully declared.
	(Freeze_And_Append): Do not freeze the profile when freezing an
	expression function.
	(Freeze_Entity): When a tagged type is frozen, also freeze any
	primitive operations of the type that are expression functions.
	* sem_ch6.adb (Analyze_Subprogram_Body_Helper): Do not prevent
	freezing associated with an expression function body if the
	function is a dispatching op.
---

diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index 3a333735cef..382e5b4b06b 100644
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -1470,6 +1470,10 @@ package body Freeze is
             if Is_Entity_Name (Prefix (Nod))
               and then Is_Type (Entity (Prefix (Nod)))
             then
+               if Expander_Active then
+                  Check_Fully_Declared (Entity (Prefix (Nod)), N);
+               end if;
+
                Freeze_Before (N, Entity (Prefix (Nod)));
             end if;
          end if;
@@ -2632,7 +2636,13 @@ package body Freeze is
       N      : Node_Id;
       Result : in out List_Id)
    is
-      L : constant List_Id := Freeze_Entity (Ent, N);
+      --  Freezing an Expression_Function does not freeze its profile:
+      --  the formals will have been frozen otherwise before the E_F
+      --  can be called.
+
+      L : constant List_Id :=
+        Freeze_Entity
+          (Ent, N, Do_Freeze_Profile => not Is_Expression_Function (Ent));
    begin
       if Is_Non_Empty_List (L) then
          if Result = No_List then
@@ -7807,11 +7817,37 @@ package body Freeze is
          --  type itself is frozen, because the class-wide type refers to the
          --  tagged type which generates the class.
 
+         --  For a tagged type, freeze explicitly those primitive operations
+         --  that are expression functions, which otherwise have no clear
+         --  freeze point: these have to be frozen before the dispatch table
+         --  for the type is built, and before any explicit call to the
+         --  primitive, which would otherwise be the freeze point for it.
+
          if Is_Tagged_Type (E)
            and then not Is_Class_Wide_Type (E)
            and then Present (Class_Wide_Type (E))
          then
             Freeze_And_Append (Class_Wide_Type (E), N, Result);
+
+            declare
+               Ops  : constant Elist_Id := Primitive_Operations (E);
+
+               Elmt : Elmt_Id;
+               Subp : Entity_Id;
+
+            begin
+               if Ops /= No_Elist  then
+                  Elmt := First_Elmt (Ops);
+                  while Present (Elmt) loop
+                     Subp := Node (Elmt);
+                     if Is_Expression_Function (Subp) then
+                        Freeze_And_Append (Subp, N, Result);
+                     end if;
+
+                     Next_Elmt (Elmt);
+                  end loop;
+               end if;
+            end;
          end if;
       end if;
 
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index 8334647028a..85edfab6b3d 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -4508,7 +4508,16 @@ package body Sem_Ch6 is
             --  This also needs to be done in the case of an ignored Ghost
             --  expression function, where the expander isn't active.
 
-            Set_Is_Frozen (Spec_Id);
+            --  A further complication arises if the expression function is
+            --  a primitive operation of a tagged type: in that case the
+            --  function entity must be frozen before the dispatch table for
+            --  the type is constructed, so it will be frozen like other local
+            --  entities, at the end of the current scope.
+
+            if not Is_Dispatching_Operation (Spec_Id) then
+               Set_Is_Frozen (Spec_Id);
+            end if;
+
             Mask_Types := Mask_Unfrozen_Types (Spec_Id);
 
          elsif not Is_Frozen (Spec_Id)