Re: Dynamic Instantiation in Ada95 ?

[Stephen Leake <Stephen.Leake@gsfc.nasa.gov>]

Matthias Oltmanns wrote:
> 
> Hi all,
> 
> I would like to implement a kind of runtime instantiation for class-wide
> types, where the concrete type is not known
> at compile time.
> I've searched for a method in exact that way as S'Class'Input is working.
> S'Class'Input first reads the external tag name from a stream and than
> makes a dispatching call to the appropriate S'Input method.
> 
> Example:
> ...
>     type Base is tagged with null record;
> 
>     function Create return Base;
>     --
>     function Create_Dynamic (Tag_Name : String) return Base'Class;
>  ...
>    << Some type-extensions for the type Base >>
> ...
> 
> I would like to implement the function as follows:
> 
>    function Create_Dynamic (Tag_Name : String) return Base'Class is
>      T : Ada.Tags.Tag := Ada.Tags.Internal_Tag (Tag_Name);
>     begin
>         return <<dispatching call to Create using tag T>>;
>     end Create_Dynamic;
> 
> Is there a way to do that? I've found only some dirty hacks, using
> unchecked_deallocation , for T'Address use ...
> and so on.
> 
> I'am interresting for a more portable approach. Any suggestions?

You can read from a string using 'Input; you just have to define String
Streams. Here's some code that defines Memory Streams; you'll have to
replace Address with String'access or something like that. Let me know
if you get it to work!

-- 
- Stephe

with System.Address_To_Access_Conversions;
with Ada.Streams; use Ada.Streams;
package SAL.Memory_Streams is
   pragma Preelaborate;

   -- we can't use IO_Exceptions, because that package doesn't have
Preelaborate.
   Status_Error : exception;
   End_Error : exception;

private
   package Stream_Element_Address_Conversions is new
System.Address_To_Access_Conversions (Stream_Element);

   type Direction_Type is (In_Stream, Out_Stream);

end SAL.Memory_Streams;

-- Abstract:
--  A memory stream type, for obtaining raw byte images of types.
--
with System;
with Ada.Streams; use Ada.Streams;
package SAL.Memory_Streams.Bounded is
   pragma Preelaborate;

   type Stream_Type (Max_Length : Stream_Element_Count)
   is new Root_Stream_Type with private;

   procedure Create (Stream : in out Stream_Type);
   -- create an empty Stream with direction Out_Stream, for writing.

   procedure Create
      (Stream : in out Stream_Type;
       Data : in Stream_Element_Array);
   -- create a Stream with data, with direction In_Stream, for reading.
   -- raises Constraint_Error if Data overflows Stream

   procedure Create
      (Stream : in out Stream_Type;
       Address : in System.Address);
   -- create a Stream with data from Address, copying Stream.Max_Length
   -- bytes, with direction In_Stream, for reading.

   function Length (Stream : in Stream_Type) return
Stream_Element_Count;
   -- for an In_Stream, the amount of data left to be read.
   -- for an Out_Stream, the amount of data written.

   function Address (Stream : in Stream_Type) return System.Address;
   -- for an In_Stream, raises Status_Error.
   -- for an Out_Stream, the address of the first element of the raw
   -- Stream, for passing to system routines.

   procedure Read
     (Stream : in out Stream_Type;
      Item   : out Stream_Element_Array;
      Last   : out Stream_Element_Offset);
   -- for an In_Stream, reads elements from Stream, storing them in
   -- Item. Stops when Item'Last or end of Stream is reached, setting
Last to
   -- last element of Item written.
   --
   -- for an Out_Stream, raises Status_Error.

   procedure Write
     (Stream : in out Stream_Type;
      Item   : in Stream_Element_Array);
   -- for an In_Stream, raises Status_Error.
   --
   -- for an Out_Stream, writes elements from Item to the Stream,
stopping
   -- when Item'last is reached. Raises End_Error if attempt
   -- to write past end of Stream.

private
   type Stream_Type (Max_Length : Stream_Element_Count)
   is new Ada.Streams.Root_Stream_Type with
   record
      -- Direction is not a discriminant, because we anticipate changing
      -- direction on some streams.
      Direction : Direction_Type;
      Last : Stream_Element_Offset := 0; 
	-- last element of Raw that has been read/written
      Raw : Stream_Element_Array (1 .. Max_Length);
   end record;

end SAL.Memory_Streams.Bounded;
-- Abstract:
--  see spec
--
with System.Address_To_Access_Conversions;
with System.Storage_Elements;
package body SAL.Memory_Streams.Bounded is

   procedure Create (Stream : in out Stream_Type)
   is begin
      Stream.Last := 0;
      Stream.Direction := Out_Stream;
   end Create;

   procedure Create
      (Stream : in out Stream_Type;
       Data : in Stream_Element_Array)
   is begin
      Stream.Raw (1 .. Data'Length) := Data;
      Stream.Last := 0;
      Stream.Direction := In_Stream;
   end Create;

   package Stream_Element_Address_Conversions is new
System.Address_To_Access_Conversions (Stream_Element);

   procedure Create
      (Stream : in out Stream_Type;
       Address : in System.Address)
   is
      function "+" (Left : System.Address; Right :
System.Storage_Elements.Storage_Offset)
                    return System.Address renames
System.Storage_Elements."+";

      Temp : System.Address := Address;
   begin
      for I in Stream.Raw'Range loop
         Stream.Raw (I) := Stream_Element_Address_Conversions.To_Pointer
(Address).all;
         Temp := Temp + 1;
      end loop;
      Stream.Direction := In_Stream;
      Stream.Last := 0;
   end Create;

   function Length (Stream : in Stream_Type) return Stream_Element_Count
   is begin
      case Stream.Direction is
      when In_Stream =>
         return Stream.Raw'Last - Stream.Last;
      when Out_Stream =>
         return Stream.Last;
      end case;
   end Length;

   function Address (Stream : in Stream_Type) return System.Address
   is begin
      case Stream.Direction is
      when In_Stream =>
         raise Status_Error;
      when Out_Stream =>
         return Stream.Raw (1)'Address;
      end case;
   end Address;

   procedure Read
     (Stream : in out Stream_Type;
      Item   : out Stream_Element_Array;
      Last   : out Stream_Element_Offset)
   is begin
      case Stream.Direction is
      when In_Stream =>
         declare
            Remaining : constant Stream_Element_Offset :=
Stream.Raw'Last - Stream.Last;
         begin
            if Remaining >= Item'Length then
               Item := Stream.Raw (Stream.Last + 1 .. Stream.Last +
Item'Length);
               Stream.Last := Stream.Last + Item'Length;
               Last := Item'Last;
            else
               Last := Item'First + Remaining - 1;
               Item (Item'First .. Last) := Stream.Raw (Stream.Last + 1
.. Stream.Raw'Last);
               Stream.Last := Stream.Raw'Last;
            end if;
         end;
      when Out_Stream =>
         raise Status_Error;
      end case;
   end Read;

   procedure Write
     (Stream : in out Stream_Type;
      Item   : in Stream_Element_Array)
   is begin
      case Stream.Direction is
      when In_Stream =>
         raise Status_Error;
      when Out_Stream =>
         declare
            Remaining : constant Stream_Element_Offset :=
Stream.Raw'Last - Stream.Last;
         begin
            if Remaining >= Item'Length then
               Stream.Raw (Stream.Last + 1 .. Stream.Last + Item'Length)
:= Item;
               Stream.Last := Stream.Last + Item'Length;
            else
               raise End_Error;
            end if;
         end;
      end case;
   end Write;

end SAL.Memory_Streams.Bounded;

-- and some code to test the above

package SAL.Memory_Streams.Bounded.Test is
   pragma Elaborate_Body;
end SAL.Memory_Streams.Bounded.Test;

with Ada.Text_IO; use Ada.Text_IO;
package body SAL.Memory_Streams.Bounded.Test
is
   type Point_Type is record
      X : Integer;
      Y : Integer;
   end record;

   Point : Point_Type := (0, 0);

   Memory_Buffer : aliased Stream_Type (10);

   procedure Put (Item : in Point_Type)
   is begin
      Put ("(" & Integer'Image (Item.X) & ", ");
      Put (Integer'Image (Item.Y) & ")");
   end Put;

   procedure Put (Item : in Stream_Element_Array)
   is begin
      Put ("(");
      for I in Item'First .. Item'Last - 1 loop
         Put (Stream_Element'Image (Item (I)) & ", ");
      end loop;
      Put (Stream_Element'Image (Item (Item'last)) & ")");
   end Put;
begin
   Put_Line ("testing SAL.Memory_Streams.Bounded");

   Put_Line ("write => (1, 2)");
   Create (Memory_Buffer);
   Point_Type'Write (Memory_Buffer'access, Point_Type'(1, 2));
   Put ("Got => "); Put (Memory_Buffer.Raw (1 .. Memory_Buffer.Last));
   New_Line (2);

   Put_Line ("read => ");
   Create (Memory_Buffer, Memory_Buffer.Raw (1 .. Memory_Buffer.Last));
   Point_Type'Read (Memory_Buffer'Access, Point);
   Put (Point);
   New_Line (2);

   Put_Line ("done");
end SAL.Memory_Streams.Bounded.Test;

with SAL.Memory_Streams.Bounded.Test;
procedure Test_Memory_Streams_Bounded
is begin
   null;
end Test_Memory_Streams_Bounded;