Patchwork [Ada] Renaming of unconstrained limited function calls

login
register
mail settings
Submitter Arnaud Charlet
Date Aug. 29, 2011, 10:19 a.m.
Message ID <20110829101925.GA9337@adacore.com>
Download mbox | patch
Permalink /patch/112011/
State New
Headers show

Comments

Arnaud Charlet - Aug. 29, 2011, 10:19 a.m.
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  <schonberg@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.

Patch

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);