If the renamed object in an object renaming declaration is a function call of a
limited type, the expansion of the renaming is complicated by the presence of
various temporaries and subtypes that capture constraints of the renamed object.
This patch rewrites the renaming as an object declaration, whose expansion is
simpler. Given that the object is immutably limited there is no copy involved
and no performance hit.
The following must compile quietly:
gcc -c -gnat05 smart_pointers-test.adb
with Smart_Integer_Pointer; use Smart_Integer_Pointer;
procedure Smart_Pointers.Test is
P: Smart_Pointer;
begin
Set (P, Int_Data'(Client_Data with I => -10));
declare
A: Accessor renames Get (P);
begin
null;
end;
end Smart_Pointers.Test;
---
with Smart_Pointers; use Smart_Pointers;
package Smart_Integer_Pointer is
type Int_Data is new Client_Data with record
I: Integer;
end record;
end Smart_Integer_Pointer;
---
with Ada.Unchecked_Deallocation;
package body Smart_Pointers is
procedure Free is new Ada.Unchecked_Deallocation (Client_Data'Class,
Client_Data_Ptr);
procedure Set (Self: in out Smart_Pointer; Data: in Client_Data'Class) is
begin
Self := (Ada.Finalization.Controlled with Pointer => new
Client_Data'Class'(Data));
end Set;
procedure Unset (Self: in out Smart_Pointer) renames Finalize;
function Get (Self: Smart_Pointer) return Accessor is
begin
if Self.Pointer = null then
return Accessor'(Data => null, Hold => <>);
else
return Accessor'(Data => Self.Pointer, Hold => Self);
end if;
end Get;
procedure Adjust (Self: in out Smart_Pointer) is
begin
if Self.Pointer /= null then
Self.Pointer.Count := Self.Pointer.Count + 1;
end if;
end Adjust;
procedure Finalize (Self: in out Smart_Pointer) is
Pointer: Client_Data_Ptr := Self.Pointer;
begin
Self.Pointer := null; -- idempotence
if Pointer /= null then
Pointer.Count := Pointer.Count - 1;
if Pointer.Count = 0 then
Free (Pointer);
end if;
end if;
end Finalize;
function Get_Count (Self: Smart_Pointer) return Natural is
begin
return Self.Pointer.Count;
end Get_Count;
end Smart_Pointers;
---
private with Ada.Finalization;
package Smart_Pointers is
type Client_Data is abstract tagged private;
type Accessor (Data: access Client_Data'Class) is limited private;
type Smart_Pointer is private;
procedure Set (Self: in out Smart_Pointer; Data: in Client_Data'Class);
function Get (Self: Smart_Pointer) return Accessor;
procedure Unset (Self: in out Smart_Pointer);
private
function Get_Count (Self: Smart_Pointer) return Natural; -- Self /= null
(for test only)
type Client_Data is abstract tagged record
Count: Natural := 1; -- the reference count
end record;
type Accessor (Data: access Client_Data'Class) is limited record
Hold: Smart_Pointer;
end record;
type Client_Data_Ptr is access Client_Data'Class;
type Smart_Pointer is new Ada.Finalization.Controlled with record
Pointer: Client_Data_Ptr;
end record;
overriding procedure Adjust (Self: in out Smart_Pointer);
overriding procedure Finalize (Self: in out Smart_Pointer);
end Smart_Pointers;
`
Tested on x86_64-pc-linux-gnu, committed on trunk
2011-08-29 Ed Schonberg <schonb...@adacore.com>
* sem_ch8.adb (Analyze_Object_Renaming): If the renamed object is a
function call of a limited type, the expansion of the renaming is
complicated by the presence of various temporaries and subtypes that
capture constraints of the renamed object.
Rewrite node as an object declaration, whose expansion is simpler.
Given that the object is limited there is no copy involved and no
performance hit.
Index: sem_ch8.adb
===================================================================
--- sem_ch8.adb (revision 178155)
+++ sem_ch8.adb (working copy)
@@ -682,9 +682,10 @@
-----------------------------
procedure Analyze_Object_Renaming (N : Node_Id) is
- Id : constant Entity_Id := Defining_Identifier (N);
+ Loc : constant Source_Ptr := Sloc (N);
+ Id : constant Entity_Id := Defining_Identifier (N);
Dec : Node_Id;
- Nam : constant Node_Id := Name (N);
+ Nam : constant Node_Id := Name (N);
T : Entity_Id;
T2 : Entity_Id;
@@ -704,7 +705,6 @@
------------------------------
procedure Check_Constrained_Object is
- Loc : constant Source_Ptr := Sloc (N);
Subt : Entity_Id;
begin
@@ -805,6 +805,29 @@
Resolve (Nam, T);
+ -- If the renamed object is a function call of a limited type,
+ -- the expansion of the renaming is complicated by the presence
+ -- of various temporaries and subtypes that capture constraints
+ -- of the renamed object. Rewrite node as an object declaration,
+ -- whose expansion is simpler. Given that the object is limited
+ -- there is no copy involved and no performance hit.
+
+ if Nkind (Nam) = N_Function_Call
+ and then Is_Immutably_Limited_Type (Etype (Nam))
+ and then not Is_Constrained (T)
+ and then Comes_From_Source (N)
+ then
+ Set_Etype (Id, T);
+ Set_Ekind (Id, E_Constant);
+ Rewrite (N,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Id,
+ Constant_Present => True,
+ Object_Definition => New_Occurrence_Of (T, Loc),
+ Expression => Relocate_Node (Nam)));
+ return;
+ end if;
+
-- Check that a class-wide object is not being renamed as an object
-- of a specific type. The test for access types is needed to exclude
-- cases where the renamed object is a dynamically tagged access
@@ -2330,9 +2353,7 @@
-- of a generic, its entity is set to the first available homonym.
-- We must first disambiguate the name, then set the proper entity.
- if Is_Actual
- and then Is_Overloaded (Nam)
- then
+ if Is_Actual and then Is_Overloaded (Nam) then
Set_Entity (Nam, Old_S);
end if;
end if;
@@ -2403,9 +2424,7 @@
end if;
if Old_S /= Any_Id then
- if Is_Actual
- and then From_Default (N)
- then
+ if Is_Actual and then From_Default (N) then
-- This is an implicit reference to the default actual
Generate_Reference (Old_S, Nam, Typ => 'i', Force => True);
