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 <schonb...@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.
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.
