[Ada] Expansion of renamings of unconstrained objects

[Arnaud Charlet <charlet at adacore dot com>]

When the subtype in an object renaming declaration is unconstrained, the
compiler builds an actual subtype using the bounds of the renamed object.
The actual subtype is not needed when the renamed object is a limited record.
This is a useful optimization, in particular for the expansion of iterators
where discriminated types with implicit defereference appear. It also solves
subtyping problems in the back-end, when the expansion of the renamed object
itself involves function calls with unconstrained actuals.

The following must compile quietly :

   gcc -c -gnat12a essai.adb

---
with Variants; use Variants;
with Variants.Iterators; use Variants.Iterators;
procedure Essai is
   function Count_Length_C(V : Variant) return Natural is
      Res : Natural := 0;
   begin
      for III of Text_Iteraton(V) loop
         Res := Res + III.S_Access.all'Length;
      end loop;
      return Res;
   end Count_Length_C;

   function Make_Huge_Text(N : Natural) return Variant is 
      Res : Variant := Make_Text ("YES", N);
   begin
      for I in 1..N loop
         Text_Append(Res, Natural'Image(I));
      end loop;
      return Res;
   end Make_Huge_Text;

   V : constant Variant := Make_Huge_Text(10);
begin
   null;
end Essai;
---
with Ada.Finalization; use Ada.Finalization;
with Ada.Strings; with Ada.Streams;
with Ada.Strings.Unbounded;
package Variants is

   type Variant is private;
   type Variant_Kind is (VK_Null, VK_Num, VK_String, VK_Vector, VK_Text);

   Null_Variant : constant Variant;

   Initial_Max_Text_Size   : constant := 16;
   Initial_Max_Vector_Size : constant := 16;

   procedure Text_Append (V : in out Variant; X : in String);
   function Make_Text (S : String; N : Positive) return Variant;

private
   package Internal is
      use Ada.Strings.Unbounded; -- only for String_Access

      Initial_Reference_Count : constant := 1;

      type String_Value (Size : Natural) is record
         Reference_Count : Integer := Initial_Reference_Count;
         Value           : String (1 .. Size);
      end record;
      type String_Value_Ptr is access all String_Value;

      type Vector_Value (Size : Natural) is record
         Reference_Count : Integer := Initial_Reference_Count;
         Current_Vector_Size : Natural := 0;
      end record;
      type Vector_Value_Ptr is access all Vector_Value;

      type String_Access_Vector is
          array (Positive range <>) of Ada.Strings.Unbounded.String_Access;
      type Text_Value (Size : Natural) is record
         Reference_Count : Integer := Initial_Reference_Count;
         Current_Text_Size : Natural := 0;
         Value             : String_Access_Vector (1 .. Size);
      end record;
      type Text_Value_Ptr is access all Text_Value;

      procedure String_Value_Ptr_Read
        (Stream : not null access Ada.Streams.Root_Stream_Type'Class;
         Item   : out String_Value_Ptr);

      procedure String_Value_Ptr_Write
        (Stream : not null access Ada.Streams.Root_Stream_Type'Class;
         Item   : in String_Value_Ptr);

      procedure Vector_Value_Ptr_Read
        (Stream : not null access Ada.Streams.Root_Stream_Type'Class;
         Item : out Vector_Value_Ptr);

      procedure Vector_Value_Ptr_Write
        (Stream : not null access Ada.Streams.Root_Stream_Type'Class;
         Item   : in Vector_Value_Ptr);

      procedure Text_Value_Ptr_Read
        (Stream : not null access Ada.Streams.Root_Stream_Type'Class;
         Item   : out Text_Value_Ptr);

      procedure Text_Value_Ptr_Write
        (Stream : not null access Ada.Streams.Root_Stream_Type'Class;
         Item   : in Text_Value_Ptr);

      for String_Value_Ptr'Read  use String_Value_Ptr_Read;
      for String_Value_Ptr'Write use String_Value_Ptr_Write;
      for Vector_Value_Ptr'Read  use Vector_Value_Ptr_Read;
      for Vector_Value_Ptr'Write use Vector_Value_Ptr_Write;
      for Text_Value_Ptr'Read    use Text_Value_Ptr_Read;
      for Text_Value_Ptr'Write   use Text_Value_Ptr_Write;

      procedure Free (S : in out String_Value_Ptr);
      procedure Free (S : in out Text_Value_Ptr);
      procedure Free (S : in out Vector_Value_Ptr);
      procedure Free (S : in out String_Access);

   end Internal;
   use Internal;

   type Variant_Internal (Kind : Variant_Kind := VK_Null) is record
      case Kind is
         when VK_Null =>
            null;
         when VK_Num =>
            Num_Value : Float := 0.0;
         when VK_String =>
            String_Value : String_Value_Ptr;
         when VK_Vector =>
            Vector_Value : Vector_Value_Ptr;
         when VK_Text =>
            Text_Value : Text_Value_Ptr;
      end case;
   end record;

   type Variant is new Ada.Finalization.Controlled with record
      V : Variant_Internal;
   end record;

   overriding procedure Adjust   (X : in out Variant);
   overriding procedure Finalize (X : in out Variant);

   procedure Finalize_Internal (V : in out Variant_Internal);
   procedure Adjust_Internal (V : in out Variant_Internal);

   function Clone_Internal (VI : Variant_Internal) return Variant_Internal;

   Null_Variant : constant Variant := Variant'(Ada.Finalization.Controlled with V => Variant_Internal'(Kind => VK_Null));

   function Is_Null (VI : in Variant_Internal) return Boolean;

end Variants;
---
with Ada.Iterator_Interfaces;
package Variants.Iterators is

   type Cursor is private;
   No_Element : constant Cursor;

   function Has_Element (Pos : Cursor) return Boolean;

   package List_Iterator_Interfaces is new
     Ada.Iterator_Interfaces (Cursor, Has_Element);

   type Constant_String_Access(S_Access : not null access constant String) is limited null record
      with Implicit_Dereference => S_Access;

   type Text_Container is tagged private
      with Default_Iterator  => Iterate,
           Iterator_Element  => Constant_String_Access,
           Constant_Indexing => Element_Value;

   package Text_Container_Iterator is
      new Ada.Iterator_Interfaces (Cursor, Has_Element);

   function Iterate (Container : Text_Container)
      return Text_Container_Iterator.Forward_Iterator'Class;

   function Element_Value (Container : Text_Container; Pos : Cursor) return Constant_String_Access;
   
   function Text_Iteraton(V : Variant) return Text_Container;

private
   type Text_Container is tagged record
      V : Variant := Null_Variant;
   end record;

   type Cursor is record
      P : Text_Value_Ptr := null;
      I : Natural := 0;
   end record;

   No_Element : constant Cursor := (others => <>);
end Variants.Iterators;

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

2012-11-06  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch8.adb (Check_Constrained_Object): Do nothing if the
	renamed object is a limited record.

Attachment: difs
Description: Text document