Re: Persistence of limited tagged types

[Nick Roberts <nickroberts@blueyonder.co.uk>]

I hope it won't be taken too amiss that a post a piece of code here.

This little test program is to illustrate the how the 'lifetime' concept (a 
fairly significant concept in computer science these days) applies to the 
persistence of 'live' objects.

A live object is an object which parallels (analogises, models) some 
conceptual or real-world entity, and therefore cannot validly be copied 
(unless it is to model the parallel entity also being duplicated). Live 
objects, therefore (to my mind) correspond, in Ada terms, to a limited type 
(hierarchy).

Live objects, because they cannot just be copied, cannot be directly 
archived or restored, but must first be properly deactivated and 
reactivated, by specific operations that have the correct specific logic 
for each live (limited) type.

In my example 'lifetime' package I have declared roots for the live objects 
(Root_Object) and for a co-hierarchy of their mothballed equivalents 
(Root_Parcel). To deactivate a live object you must call Mothball, and to 
reactivate one you must call Reinstate. (These names may not be the most 
appropriate, but they do at least suggest their function.)

There are many other aspects to the lifetime concept, but the conversion 
between different forms of an object is one of the basic aspects.


----------------------------------------------------------------------
-- Test out lifetime and persistence concepts in Ada.

with Ada.Streams.Stream_IO, Ada.Text_IO, Ada.Unchecked_Deallocation;
use Ada.Streams.Stream_IO, Ada.Text_IO;

procedure Persist1 is


   ------------------------------------------------------------
   package Lifetime is

      type Root_Object is abstract tagged limited private;
      type Object_Ref is access Root_Object'Class;

      type Root_Parcel is abstract tagged private;
      type Parcel_Ref is access Root_Parcel'Class;

      procedure Mothball (Object: in out Root_Object;
                          Parcel: out    Parcel_Ref) is abstract;

      procedure Reinstate (Object: out Object_Ref;
                           Parcel: in  Root_Parcel) is abstract;

   private

      type Root_Object is abstract tagged limited null record;
      type Root_Parcel is abstract tagged null record;

   end Lifetime;


   ------------------------------------------------------------
   package Banking is

      type Active_Account is new Lifetime.Root_Object with private;

      type Dead_Account is new Lifetime.Root_Parcel with private;

      function New_Account (Initial_Balance: in Integer) return 
Lifetime.Object_Ref;

      function Current_Balance (Account: in Active_Account) return Integer;

      procedure Mothball (Active: in out Active_Account;
                          Dead:   out    Lifetime.Parcel_Ref);

      procedure Reinstate (Active: out Lifetime.Object_Ref;
                           Dead:   in  Dead_Account);

   private

      type Active_Account is new Lifetime.Root_Object with
         record
            Balance: Integer;
         end record;

      type Dead_Account is new Lifetime.Root_Parcel with
         record
            Balance: Integer;
         end record;

   end Banking;


   ------------------------------------------------------------
   package body Banking is


      function New_Account (Initial_Balance: in Integer) return 
Lifetime.Object_Ref is

         Account: Lifetime.Object_Ref := new Active_Account;

      begin
         Active_Account(Account.all).Balance := Initial_Balance;
         return Account;
      end;


      function Current_Balance (Account: in Active_Account) return Integer 
is
      begin
         return Account.Balance;
      end;


      procedure Mothball (Active: in out Active_Account;
                          Dead:   out    Lifetime.Parcel_Ref) is
      begin
         -- here need to be actions to suspend the Active account
         Dead := new Dead_Account'( Lifetime.Root_Parcel with Balance => 
Active.Balance );
      end;


      procedure Reinstate (Active: out Lifetime.Object_Ref;
                           Dead:   in  Dead_Account) is
      begin
         Active := new Active_Account;
         Active_Account(Active.all).Balance := Dead.Balance;
         -- here need to be actions to reactivate Active account
      end;


   end banking;


   ------------------------------------------------------------
   type Object_Array is
      array (Positive range <>) of Lifetime.Object_Ref;


   procedure Free is
      new 
Ada.Unchecked_Deallocation(Lifetime.Root_Object'Class,Lifetime.Object_Ref);


   procedure Save (File: in out Ada.Streams.Stream_IO.File_Type;
                   Item: in out Object_Array) is

      Temp: Lifetime.Parcel_Ref;

   begin
      for i in Item'Range loop
         Lifetime.Mothball(Item(i).all,Temp);
         Free(Item(i)); -- make sure it is deallocated
         Lifetime.Root_Parcel'Class'Output(Stream(File),Temp.all);
      end loop;
   end Save;


   procedure Load (File: in out Ada.Streams.Stream_IO.File_Type;
                   Item: out    Object_Array;
                   Last: out    Natural) is

      i: Natural := Item'First-1;

   begin
      while not End_of_File(File) loop
         declare
            subtype LRPC is Lifetime.Root_Parcel'Class;
            Temp: Lifetime.Parcel_Ref := new LRPC'(LRPC'Input(Stream(File))) 
;
         begin
            i := i+1;
            Lifetime.Reinstate(Item(i),Temp.all);
         end;
      end loop;
      Last := i;
   end Load;


   Accounts: Object_Array(1..10);
   Datafile: Ada.Streams.Stream_IO.File_Type;
   Last: Natural;

begin

   Put("Creating test array ...");
   for i in Accounts'Range loop
      Accounts(i) := Banking.New_Account(i);
   end loop;
   Put(" Done.");
   New_Line;

   Put("Saving test array ...");
   Create(Datafile,Out_File,"TESTDAT1.BIN");
   Save(Datafile,Accounts);
   Close(Datafile);
   Put(" Done.");
   New_Line;

   Put("Reloading test array ...");
   Open(Datafile,In_File,"TESTDAT1.BIN");
   Load(Datafile,Accounts,Last);
   Close(Datafile);
   Put(" Done.");
   New_Line;

   Put("Checking test array ...");
   if Last /= Accounts'Last then
      Put(" *** FAILED!");
      goto Final_Stuff;
   end if;      for i in Accounts'Range loop
      if Banking.Current_Balance(Banking.Active_Account(Accounts(i).all)) 
/= i then
         Put(" *** FAILED!");
         goto Final_Stuff;
      end if;
   end loop;
   Put(" Done. Success!");

<<Final_Stuff>>
   New_Line;

end;
----------------------------------------------------------------------


Based on this idea, persistence of a live (limited) type will be done in 
two steps: the deactivation (mothballing) of the live type (derived from 
Root_Object) to get its storable equivalent (derived from Root_Parcel), and 
reactivation (reinstatement) of the stored equivalent to get back to the 
live object; the actual storage and retrieval of the storable (mothballed) 
types.

I think it is important not to confuse the two concepts of 
deactivation/reactivation of live (limited) objects and of persistence 
(which is really just the automatic, or transparent, storage and 
restoration of data).

Of course this little program is only a trivial test of the concept, but I 
think you will find it scales up nicely in practice.

Look particularly at the implementation of the Load and Save procedures, 
and how they use polymorphic (dispatching) calls both to obtain the 
appropriate input and output routines for objects of types derived from 
Root_Parcel and also to obtain the appropriate mothballing and 
reinstatement routines.

Hope this is of interest!


-- 
Nick Roberts
Jabber: debater@charente.de [ICQ: 159718630]