Re: Classwide-type assignments [longish]

[Niklas Holsti <nholsti@icon.fi>]

This continues my earlier posting, where I wrote:
> 
> jsanchor@cs5.dasd.honeywell.com wrote:
>   [ snip ]
> > I have been trying to assign classwide types with no luck.
    [ snip ]
> I don't think that you can use ":=" to move class-wide
> data to an uninitialized memory area. Perhaps you could
> make a custom Storage Pool that allocates target objects
> from the NV RAM? Then you could clone the RAM object into
> the NV RAM using "new" for the NV RAM Storage Pool.
    [ snip ]

Just for fun, I wrote a custom Storage_Pool sketch to handle
allocations in a special RAM area. Source code included below.
The allocator is trivial (sequential allocation, no deallocation)
but may give you a starting point if you decide to use this
approach.

I tested the program on an i486 with Linux 2.0.0 and GNAT 3.05.
The program consists of
    nv_main.adb      Main procedure
    nv_pool.ad[sb]   Custom storage pool
    nv_user.ad[sb]   Example client with descendant type.

The expected output is:

My_Int.Value =  12345
Allocating 8 elements, alignment = 4
New NV_Off = 8
NV.Value =  12345


Good luck,
Niklas Holsti


-------------- nv_main.adb
with NV_User;

procedure NV_Main is
begin
   NV_User.Use_It;
end NV_Main;


-------------- nv_user.ads
-- This package makes a descendant type of NV_Pool.NV_Object
-- and tries it out.

package NV_User is

   procedure Use_It;

end NV_User;


-------------- nv_user.adb
with NV_Pool;
with Text_IO;
use  Text_IO;

package body NV_User is

   -- The descendant type:
   type NV_Int is new NV_Pool.NV_Object with record
      Value : integer;
   end record;

   type Int_Pointer is access all NV_Int'Class;
   -- This access type can access either RAM or NV RAM objects,
   -- but will create new objects in NV RAM only.

   for Int_Pointer'Storage_Pool use NV_Pool.NV_Pointer'Storage_Pool;
   -- It's a nuisance to have to define the Storage_Pool for
   -- all descendant pointers. Perhaps a generic package could
   -- be made to sort of "mix in" the NV'ness facet.


   My_Int : aliased NV_Int;
   -- The RAM object to be copied to NV RAM.


   procedure Use_It
   is

      RAM_Ptr : Int_Pointer := My_Int'Access;
      -- Pointer to the RAM object (specific type).

      RAM_Class_Ptr : NV_Pool.Pointer := NV_Pool.Pointer (RAM_Ptr);
      -- Pointer to the RAM object (class-wide).

      NV_Ptr : Int_Pointer;
      -- Pointer to the NV RAM copy (specific type).

      NV_Class_Ptr : NV_Pool.Pointer;
      -- Pointer to the NV RAM copy (class-wide).

   begin

      My_Int.Value := 12345;
      -- Define the RAM data.

      Put_Line ("My_Int.Value = " & integer'image(My_Int.Value));

      NV_Ptr := new NV_Int;
      -- Create a place in the NV RAM of this type.
      -- This uses the custom NV storage pool.

      -- Note that the copy in NV RAM could be created simply
      -- by  "NV_Ptr := new NV_Int'(My_Int);".
      -- The following stuff with class-wide accesses is only
      -- to answer the original question on comp.lang.ada.

      NV_Class_Ptr := NV_Pool.Pointer (NV_Ptr);
      -- Make a class-wide pointer to the NV RAM place.

      NV_Class_Ptr.all := RAM_Class_Ptr.all;
      -- Copy the data, class-wide to class-wide.
      -- This includes a tag check. Note that the "new"
      -- for NV_Ptr sets the tag of the NV RAM cell, although
      -- the other components are undefined.

      Put_Line ("NV.Value = " & integer'image(NV_Ptr.Value));

   end Use_It;

end NV_User;


-------------- nv_pool.ads
with System.Storage_Pools;
with System.Storage_Elements;
use  System.Storage_Elements;

package NV_Pool is

   type NV_Object is abstract tagged null record;
   -- The root type for objects that can be copied to
   -- Non-Volatile memory.

   type NV_Pointer is access NV_Object'Class;
   -- Pointer to an object in the Non-Volatile memory.
   -- This access type has a custom storage pool that
   -- allocates areas from the Non-Volatile memory.
   -- Note that access types for descendants of NV_Object
   -- will NOT inherit the custom storage pool, but must
   -- specify it, for example:
   --    for My_NV_Pointer'Storage_Pool use
   --       NV_Pool.NV_Pointer'Storage_Pool;

   type Pointer is access all NV_Object'Class;
   -- Pointer to an object in the volatile memory or in
   -- the non-volatile memory.
   -- This access type uses the default storage pool.


private

   -- Custom Storage Pool for Non-Volatile objects.

   type NV_Storage_Pool is
      new System.Storage_Pools.Root_Storage_Pool
      with null record;

   procedure Allocate (
      Pool            : in out NV_Storage_Pool;
      Storage_Address : out System.Address;
      Size_In_Storage_Elements : in Storage_Count;
      Alignment       : in Storage_Count);

   procedure Deallocate (
      Pool            : in out NV_Storage_Pool;
      Storage_Address : in System.Address;
      Size_In_Storage_Elements : in Storage_Count;
      Alignment       : in Storage_Count);

   function Storage_Size (Pool : NV_Storage_Pool) return Storage_Count;

   NV_Storage : NV_Storage_Pool;

   -- Use the custom allocator for NV objects.

   for NV_Pointer'Storage_Pool use NV_Storage;

end NV_Pool;


-------------- nv_pool.adb
with Text_IO;

package body NV_Pool is
   
   -- Storage to simulate the Non-Volatile area.
   -- The important parts are NV_Size and NV_Address which are
   -- used in the storage pool operations.
   -- For a real NV RAM, modify the value of NV_Size, delete
   -- NV_Simu, and set NV_Address to the literal starting
   -- address.

   NV_Size    : constant Storage_Count  := 1000;

   subtype NV_Count is Storage_Count range 0 .. NV_Size;
   subtype NV_Index is NV_Count range 0 .. NV_Count'last - 1;

   NV_Simu    : array (NV_Index) of Storage_Element;
   NV_Address : constant System.Address :=
NV_Simu(NV_Simu'first)'address;


   -- Custom pool defined as NV_Size storage-elements starting
   -- at address NV_Address.

   NV_Off  : Storage_Offset := 0;
   --  Offset from NV_Address to the next free location.


   procedure Allocate (
      Pool            : in out NV_Storage_Pool;
      Storage_Address : out System.Address;
      Size_In_Storage_Elements : in Storage_Count;
      Alignment       : in Storage_Count)
   --
   -- Allocates NV memory sequentially from NV_Off.
   -- Updates NV_Off.
   --
   is

      Misalign : constant Integer_Address :=
         To_Integer (NV_Address + NV_Off) mod Integer_Address
(Alignment);
      -- The amount of misalignment in NV_Off.

      Next_Off : Storage_Offset;
      -- The aligned value of NV_Off.

   begin
      Text_IO.Put_Line (
         "Allocating"
         & Storage_Count'image(Size_In_Storage_Elements)
         & " elements, alignment ="
         & Storage_Count'image(Alignment));

      -- Check for alignment.
      if Misalign > 0 then
         -- Advance offset to next aligned location.
         Next_Off := NV_Off + (Alignment - Storage_Count(Misalign));
      else
         -- Already aligned.
         Next_Off := NV_Off;
      end if;

      -- Check if storage left.
      if NV_Size - Next_Off < Size_In_Storage_Elements then
         raise Storage_Error;
      end if;

      -- Return address and reserve space.
      Storage_Address := NV_Address + Next_Off;
      NV_Off          := Next_Off + Size_In_Storage_Elements;

      Text_IO.Put_Line (
         "New NV_Off =" & Storage_Offset'image(NV_Off));

   end Allocate;


  procedure Deallocate (
      Pool            : in out NV_Storage_Pool;
      Storage_Address : in System.Address;
      Size_In_Storage_Elements : in Storage_Count;
      Alignment       : in Storage_Count)
   --
   -- Deallocation is not implemented.
   --
   is
   begin
      Text_IO.Put_Line (
         "Deallocating"
         & Storage_Count'image (Size_In_Storage_Elements)
         & " elements, alignment ="
         & Storage_Count'image (Alignment)
         & ", address ="
         & Integer_Address'image(To_Integer(Storage_Address)));

      null;

   end Deallocate;


   function Storage_Size (Pool : NV_Storage_Pool) return Storage_Count
   is
   begin
      return NV_Size;
   end Storage_Size;


end NV_Pool;