::
x11_mlt.ada
package Class_name_address is
type Name_address is tagged private;
procedure set( the:out Name_address; str:in String );
function deliver_line( the:in Name_address;
line:in Positive ) return String;
function lines( the:in Name_address ) return Positive;
private
MAX_CHS : CONSTANT := 200;
subtype Line_index is Natural range 0 .. MAX_CHS;
subtype Line_range is Line_index range 1 .. MAX_CHS;
type Name_address is tagged record
text : String( Line_range ); -- Details
length : Line_index := 0; -- Length of address
end record;
end Class_name_address;
package body Class_name_address is
function spaces( line:in Positive ) return String;
procedure set( the:out Name_address; str:in String ) is
begin
if str'Length > MAX_CHS then
set( the, str( str'First .. str'First+MAX_CHS-1 ) );
else
the.text( 1 .. str'Length ) := str;
the.length := str'Length;
end if;
end set;
-- The reason for the line:
-- for i in 1 .. Line_range(the.length) loop
-- is so the compiler will know that the index i can never go outside
-- the range of the array so no need to do array bound checking
function deliver_line( the:in Name_address;
line:in Positive ) return String is
line_on : Positive := 1;
begin
for i in 1 .. the.length loop
if line_on = line then
for j in i .. the.length loop
if the.text(j) = '/' then
return spaces(line_on) & the.text(i .. j-1);
end if;
end loop;
return spaces(line_on) & the.text(i..the.length);
end if;
if the.text(i) = '/' then line_on := line_on+1; end if;
end loop;
return "";
end deliver_line;
function lines( the:in Name_address ) return Positive is
no_lines : Positive := 1;
begin
for i in 1 .. the.length loop
if the.text(i) = '/' then no_lines := no_lines + 1; end if;
end loop;
return no_lines;
end lines;
function spaces( line:in Positive ) return String is
spaces_are : String( 1 .. Line ) := (others=>' ');
begin
return spaces_are;
end spaces;
end Class_name_address;
-- ---- --- --- --- --- --- --- --- --- --- --- --- --- ---
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;
-- ---- --- --- --- --- --- --- --- --- --- --- --- --- ---
with Class_account, Class_name_address;
use Class_account, Class_name_address;
package Class_named_account is
type Named_account is tagged private;
subtype PMoney is Class_account.PMoney;
subtype Money is Class_account.Money;
procedure set( the:out Named_account; str:in String );
function deliver_line( the:in Named_account;
line:in Positive ) return String;
function lines( the:in Named_account ) return Positive;
procedure statement( the:in Named_account );
procedure deposit( the:in out Named_account; amount:in PMoney );
procedure withdraw( the:in out Named_account; amount:in PMoney;
get:out PMoney );
function balance( the:in Named_account ) return PMoney;
private
type Named_account is tagged record
acc : Account; -- An account object
naa : Name_address; -- A Name and address object
end record;
end Class_named_account;
with Simple_io; use Simple_io;
package body Class_named_account is
procedure set( the:out Named_account; str:in String ) is
begin
set( the.naa, str );
end set;
function deliver_line( the:in Named_account;
line:in Positive ) return String is
begin
return deliver_line( the.naa, line );
end deliver_line;
function lines( the:in Named_account ) return Positive is
begin
return lines( the.naa );
end lines;
procedure statement( the:in Named_account ) is
begin
put("Statement for : " );
put( deliver_line( the.naa, 1 ) ); new_line;
statement( the.acc );
end statement;
procedure deposit(the:in out Named_account; amount:in PMoney) is
begin
deposit( the.acc, amount );
end deposit;
procedure withdraw( the:in out Named_account; amount:in PMoney;
get:out PMoney ) is
begin
withdraw( the.acc, amount, get );
end withdraw;
function balance ( the:in Named_account ) return PMoney is
begin
return balance( the.acc );
end balance;
end Class_named_account;
with Simple_io;
use Simple_io;
package Pack_procedures is
procedure ex1;
procedure ex2;
procedure ex3;
procedure ex4;
end Pack_procedures;
with Simple_io, Class_named_account, Class_name_address;
use Simple_io, Class_named_account;
package body Pack_procedures is
procedure ex1 is
procedure main is
mike : Named_account;
get : Money;
begin
set ( mike, "A.N.Other/Brighton/UK" );
deposit ( mike, 10.00 );
statement( mike );
withdraw ( mike, 5.00, get );
statement( mike );
end main;
begin
main;
end ex1;
procedure ex2 is
use Class_name_address;
begin
declare
name : Name_address;
address : String := "A.N.Other/Brighton/East Sussex/UK";
begin
set( name, address );
put( address ); new_line; put("There are ");
put( lines( name ) ); put(" lines"); new_line;
for i in 1 .. lines(name)+1 loop
put("Line #"); put(i); put(" ");
put( deliver_line(name, i) ); new_line;
end loop;
end;
end ex2;
procedure ex3 is
begin
null;
end ex3;
procedure ex4 is
begin
null;
end ex4;
end Pack_procedures;
with Simple_io, Pack_procedures;
use Simple_io, Pack_procedures;
procedure main is
begin
put("Example 1"); new_line; ex1;
put("Example 2"); new_line; ex2;
put("Example 3"); new_line; ex3;
put("Example 4"); new_line; ex4;
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]