Patchwork [Ada] Allocation of coextensions

login
register
mail settings
Submitter Arnaud Charlet
Date Dec. 21, 2011, 1:47 p.m.
Message ID <20111221134721.GA21673@adacore.com>
Download mbox | patch
Permalink /patch/132642/
State New
Headers show

Comments

Arnaud Charlet - Dec. 21, 2011, 1:47 p.m.
In certain cases the object designated by an access discriminant can be stack-
allocated, for example when the enclosing object is a local object declaration.
However, if the access discriminant is an aggregate component of a return
expression or a return object, it must be allocated dynamically.

The following must output
    42
    84

--- 
   gnatmake -q -gnat05 test_driver
   test_driver
---
with test_package;
with Text_IO;
procedure test_driver is
begin
   declare
      foo : test_package.test_type := test_package.get (-1);
      bar : access Integer := new Integer'(69);
   begin
      Text_IO.Put_Line(foo.p_obj.all'img);
   end;

   declare
      foo : test_package.test_type := test_package.get (42);
      bar : access Integer := new Integer'(1234);
   begin
      Text_IO.Put_Line(foo.p_obj.all'img);
   end;
end test_driver;
---
package test_package is
   type test_type (p_obj : access Integer) is limited private;

   function get (X : Integer) return test_type;
private
   type test_type (p_obj : access Integer) is limited null record;
end test_package;
---
package body test_package is
   function get (X : Integer)  return test_type is
   begin
      if X < 0 then
         return test_type'(p_obj => new Integer'(42));
      else
         return result : test_Type := (p_obj => new Integer'(2 * X));
      end if;
   end get;
end test_package;

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

2011-12-21  Ed Schonberg  <schonberg@adacore.com>

	* sem_util.adb (Mark_Coextensions): A coextension for an
	object that is part of the expression in a return statement,
	or part of the return object in an extended return statement,
	must be allocated dynamically.

Patch

Index: sem_util.adb
===================================================================
--- sem_util.adb	(revision 182572)
+++ sem_util.adb	(working copy)
@@ -9331,7 +9331,6 @@ 
               and then Nkind (Expression (Expression (N))) = N_Op_Concat
             then
                Set_Is_Dynamic_Coextension (N);
-
             else
                Set_Is_Static_Coextension (N);
             end if;
@@ -9346,12 +9345,33 @@ 
 
    begin
       case Nkind (Context_Nod) is
-         when N_Assignment_Statement    |
-              N_Simple_Return_Statement =>
+
+         --  Comment here ???
+
+         when N_Assignment_Statement    =>
             Is_Dynamic := Nkind (Expression (Context_Nod)) = N_Allocator;
 
+         --  An allocator that is a component of a returned aggregate
+         --  must be dynamic.
+
+         when N_Simple_Return_Statement =>
+            declare
+               Expr : constant Node_Id := Expression (Context_Nod);
+            begin
+               Is_Dynamic :=
+                 Nkind (Expr) = N_Allocator
+                   or else
+                     (Nkind (Expr) = N_Qualified_Expression
+                       and then Nkind (Expression (Expr)) = N_Aggregate);
+            end;
+
+         --  An alloctor within an object declaration in an extended return
+         --  statement is of necessity dynamic.
+
          when N_Object_Declaration =>
-            Is_Dynamic := Nkind (Root_Nod) = N_Allocator;
+            Is_Dynamic := Nkind (Root_Nod) = N_Allocator
+              or else
+                Nkind (Parent (Context_Nod)) = N_Extended_Return_Statement;
 
          --  This routine should not be called for constructs which may not
          --  contain coextensions.
@@ -9371,9 +9391,9 @@ 
       Formal : Entity_Id;
 
    begin
-      if Ada_Version >= Ada_2005
-        and then Present (First_Formal (E))
-      then
+      --  Ada 2005 or later, and formals present
+
+      if Ada_Version >= Ada_2005 and then Present (First_Formal (E)) then
          Formal := Next_Formal (First_Formal (E));
          while Present (Formal) loop
             if No (Default_Value (Formal)) then
@@ -9385,6 +9405,8 @@ 
 
          return True;
 
+      --  Ada 83/95 or no formals
+
       else
          return False;
       end if;