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