[Ada] Actuals that are function calls returning unconstrained limited types

[Ada] Actuals that are function calls returning unconstrained limited types

[Arnaud Charlet]

[-- Attachment #1: Type: text/plain, Size: 3184 bytes --]

This patch fixes an omission in the code that resolves actuals in a call.
Previous to this patch, and actual in a call that is an overloaded function
call, one of whose interpretations returns an unconstrained limited type may
be resolved incorrectly.
The command

      gnatmake -q -gnat05 main
      main

Must yield

      Create for Type_A

---
with Lib; use Lib;
procedure Main is
   A : Type_A (2);
begin
   Set (A, Create (2));
end Main;
---
private with Ada.Finalization;
package Lib is

   type Type_B (Value : Integer) is tagged limited private;
   function Create (Value : Integer) return Type_B;

   type Type_A (Value : Integer) is tagged limited private;
   function Create (Value : Integer) return Type_A;
   procedure Set (Left : in out Type_A; Right : Type_A);

private
   use Ada.Finalization;

   type Type_B (Value : Integer) is new Limited_Controlled with null record;

   type Natural_A is access Natural;

   type Type_A (Value : Integer) is new Limited_Controlled with record
      Refcount : Natural_A;
   end record;

   overriding
   procedure Initialize (Object : in out Type_A);

   procedure Adjust (Object : in out Type_A);

   overriding
   procedure Finalize (Object : in out Type_A);
end Lib;
---
with Ada.Text_IO;
with System.Storage_Elements;
with Unchecked_Deallocation;

package body Lib is

   use Ada.Text_IO;

   procedure Free is new Unchecked_Deallocation (Natural, Natural_A);


   overriding
   procedure Initialize (Object : in out Type_A) is
   begin
      Object.Refcount := new Natural'(1);
   end Initialize;

   procedure Adjust (Object : in out Type_A) is
   begin
      raise Program_Error with "Never override Adjust for Limited type.";
   end Adjust;

   overriding
   procedure Finalize (Object : in out Type_A) is
      Refcount : Natural_A := Object.Refcount;
   begin
      Object.Refcount := null;  -- Finalize must be idempotent

      if Refcount = null then
         null;
      else
         Refcount.all := Refcount.all - 1;

         if Refcount.all = 0 then
            Free (Refcount);
         end if;
      end if;
   end Finalize;

   procedure Set (Left : in out Type_A; Right : Type_A) is
   begin
      if Left.Value /= Right.Value then
         Put_Line
           ("Left.Value, Right.Value : " &
            Left.Value'Img &
            ", " &
            Right.Value'Img);
         raise Constraint_Error with "Set : Discriminant Values don't match";
      end if;

      Left.Finalize;

      Left.Refcount     := Right.Refcount;
      Left.Refcount.all := Left.Refcount.all + 1;

   end Set;

   function Create (Value : Integer) return Type_A is
   begin
      return R : Type_A (Value) do
         Put_Line ("Create for Type_A");
      end return;
   end Create;

   function Create (Value : Integer) return Type_B is
   begin
      return R : Type_B (Value) do
         Put_Line ("Create for Type_B");
      end return;
   end Create;
end Lib;

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

2011-09-02  Ed Schonberg  <schonberg@adacore.com>

	* sem_res.adb (Resolve_Actuals): add missing call to Resolve
	for an actual that is a function call returning an unconstrained
	limited controlled type.


[-- Attachment #2: difs --]
[-- Type: text/plain, Size: 529 bytes --]

Index: sem_res.adb
===================================================================
--- sem_res.adb	(revision 178381)
+++ sem_res.adb	(working copy)
@@ -3446,6 +3446,7 @@
               and then (Is_Controlled (Etype (F)) or else Has_Task (Etype (F)))
             then
                Establish_Transient_Scope (A, False);
+               Resolve (A, Etype (F));
 
             --  A small optimization: if one of the actuals is a concatenation
             --  create a block around a procedure call to recover stack space.