diff mbox series

[Ada] Proper freezing for dispatching expression functions.

Message ID 20220712122518.GA3404707@adacore.com
State New
Headers show
Series [Ada] Proper freezing for dispatching expression functions. | expand

Commit Message

Pierre-Marie de Rodat July 12, 2022, 12:25 p.m. UTC 
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.

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

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

Patch

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