Ada 95 :: x61_rc_g.ada

with Simple_io; use Simple_io;
package Class_account is
  type Account is tagged private;
  subtype Money  is Float;
  subtype PMoney is Float range 0.0 .. Float'Last;

  procedure statement( the:in Account );
  procedure deposit( the:in out Account; amount:in PMoney );
  procedure withdraw( the:in out Account;
                      amount:in PMoney; get:out PMoney );
  function  balance( the:in Account ) return Money;
private
  type Account is tagged record
     balance_of : Money := 0.00;           -- Amount on deposit
  end record;
end Class_account;


package body Class_account is

  procedure statement( the:in Account ) is
  begin
    put("Mini statement: The amount on deposit is $" );
    put( the.balance_of, aft=>2, exp=>0 );
    new_line(2);
  end statement;

  procedure deposit( the:in out Account; amount:in PMoney ) is
  begin
    the.balance_of := the.balance_of + amount;
  end deposit;

  procedure withdraw( the:in out Account;
                      amount:in PMoney; get:out PMoney ) is
  begin
    if the.balance_of >= amount then
      the.balance_of := the.balance_of - amount;
      get := amount;
    else
      get := 0.00;
    end if;
  end withdraw;

  function  balance( the:in Account ) return Money is
  begin
    return the.balance_of;
  end balance;

end Class_account;

-- Generic in        constant
--         in out    Renaming

with Ada.Finalization; use Ada.Finalization;
generic
  type T is private;                    -- The type
  null_VALUE:in T;                      -- Identity element
package Class_object_rc is
  type Object is new Controlled with private;
  type P_T is access all T;

  procedure initialize( the:in out Object );
  procedure initialize( the:in out Object; data:in T );
  procedure finalize( the:in out Object );
  procedure adjust( the:in out Object );
  function  deliver( the:in Object) return T;
  function  deliver_ref( the:in Object) return P_T;
  procedure unique( the:in out Object);
private
  procedure build_storage ( the:in out Object; value:in T );
  procedure release_storage( the:in out Object );

  type Descriptor;
  type P_Descriptor is access all Descriptor;

  type Descriptor is record
    refs   : Natural;       -- References to this data
    object : aliased T;     -- The physical data
  end record;

  type Object is new Controlled with record
     p_desc : P_Descriptor:= null; -- Descriptor for a number
  end record;

end Class_object_rc;


with Simple_io; use Simple_io;
with unchecked_deallocation;
package body Class_object_rc is

  procedure initialize( the:in out Object ) is
  begin
    build_storage( the, null_VALUE );
  end initialize;

  procedure initialize( the:in out Object; data:in T ) is
  begin
    build_storage( the, data );
  end initialize;

  procedure build_storage ( the:in out Object; value:in T ) is
  begin
    the.p_desc := new Descriptor'(1,value);
  end build_storage;

  procedure finalize( the:in out Object ) is
  begin
    if the.p_desc /= null then
      release_storage( the );
      the.p_desc := null;
    end if;
  end finalize;

  procedure dispose is
    new unchecked_deallocation( Descriptor, P_Descriptor );

  procedure release_storage( the:in out Object ) is
  begin
    the.p_desc.refs := the.p_desc.refs-1;
    if the.p_desc.refs = 0 then
      dispose( the.p_desc );
    else
      null;
    end if;
  end release_storage;

  procedure adjust( the:in out Object ) is
  begin
    the.p_desc.refs := the.p_desc.refs+1;
  end adjust;

  function  deliver( the:in Object) return T is
  begin
    return the.p_desc.object;
  end deliver;

  function  deliver_ref( the:in Object) return P_T is
  begin
    return the.p_desc.object'Access;
  end deliver_ref;

  procedure unique( the:in out Object) is
    tmp : P_Descriptor;
  begin
    if the.p_desc.refs > 1 then
      the.p_desc.refs := the.p_desc.refs-1;
      tmp := new Descriptor'(1,the.p_desc.object);
      the.p_desc := tmp;
    end if;
  end unique;
end Class_object_rc;

----[class_object_rc_int.ADS] Specification Instantiation
--with Class_object_rc;
--  package Class_rc_integer is
--    new Class_object_rc( Integer, 0 );

----[class_ref_integer.ads] Specification
--with Class_rc_integer; use Class_rc_integer;
--package Class_ref_integer is
--  type Ref_integer is new Object with null record;
--  function  number_const( value:in Integer ) return Ref_integer;
--  function "+" ( l,r:in Ref_integer ) return Ref_integer;
--  function "=" ( l,r:in Ref_integer ) return Boolean;
--end Class_ref_integer;
--
----[class_ref_integer.adb] Implementation
--package body Class_ref_integer is
--  function  number_const( value:in Integer ) return Ref_integer is
--    res: Ref_integer;
--  begin
--    initialize( res, value );
--    return res;
--  end number_const;
--
--  function "+" ( l,r:in Ref_integer ) return Ref_integer is
--    res : Ref_integer;
--  begin
--    initialize( res, deliver(l) + deliver(r) );
--    return res;
--  end "+";
--
--  function "=" ( l,r:in Ref_integer ) return Boolean is
--  begin
--    return deliver(l) = deliver(r);
--  end "=";
--end Class_ref_integer;

with Class_object_rc;
pragma ELABorATE_all( Class_object_rc );
package Class_rc_integer is
  new Class_object_rc(Integer, 0);

with Simple_io, Class_rc_integer;
use  Simple_io, Class_rc_integer;
procedure main1 is
  a,b,c : Class_rc_integer.Object;
begin
  initialize( b, 10 );
  initialize( c, 20 );

  put("a := b; "); new_line;
  a := b;

  put("b := c; "); new_line;
  b := c;

  put("c := a; "); new_line;
  c := a;

  put("a = "); put( deliver( a ) ); new_line;
  put("b = "); put( deliver( b ) ); new_line;
  put("c = "); put( deliver( c ) ); new_line;

end main1;

package Pack_types is
  type P_Integer is access all Integer;
end Pack_types;

with Pack_types, Class_object_rc;
package Class_object_rc_p_int is
  new Class_object_rc(Pack_types.P_Integer, null);

with Simple_io, Class_object_rc_p_int;
use  Simple_io, Class_object_rc_p_int;
procedure main2 is
  a,b,c  : Object;
begin
  initialize( a, new Integer'(10) );
  initialize( b, new Integer'(20) );

  put("a := b; "); new_line;
  a := b;
  put("a = "); put( deliver( a ).all ); new_line;
  put("b = "); put( deliver( b ).all ); new_line;
end main2;

procedure main3 is
begin
  null;
end main3;

--with Class_account;
--package Pack_consts is
--  null_account: Class_account.Account;
--end Pack_consts;
--
--with Pack_consts, Class_object_rc, Class_account;
--package Class_rc_account is
--  new Class_object_rc(Class_account.Account, Pack_consts.null_account);
--
procedure main4 is
--  original,copy : Class_rc_account.Object;
--begin
--  deposit( deliver_ref(original).all, 100.00 );
--  put("copy := original; (Shallow copy)"); new_line;
--  copy := original;                       -- Shallow copy
--  statement( deliver_ref(original).all ); -- The same object
--  statement( deliver_ref(copy).all );     --  "  "
--  put("Make copy unique (Deep copy if necessary)"); new_line;
--  unique( copy );                         -- Deep copy
--  deposit( deliver_ref(copy).all, 20.00 );-- copy only
--  statement( deliver_ref(original).all ); -- Unique object
--  statement( deliver_ref(copy).all );     --   "   "
begin
  null;
end main4;

with Simple_io, Class_rc_integer;
use  Simple_io, Class_rc_integer;
procedure main5 is
  a : Class_rc_integer.Object;
begin
  initialize( a, 20 );
  put("a = "); put( deliver( a ) ); new_line;

  put("a := a; "); new_line;
  -- a := a; -- FIXED GNAT / Object Ada NO

  put("a = "); put( deliver( a ) ); new_line;

end main5;

with Simple_io, main1, main2, main3, main4, main5;
use  Simple_io;
procedure main is
begin
  put("Example 1"); new_line; main1;
  put("Example 2"); new_line; main2;
  put("Example 3"); new_line; main3;
  put("Example 4"); new_line; main4;
  put("Example 5"); new_line; main5;
end main;


© M.A.Smith University of Brighton. Created September 1995 last modified May 1997.
Comments, suggestions, etc. M.A.Smith@brighton.ac.uk * [Home page]