::
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]