::
x56_tree.ada
with Ada.Strings.Bounded; use Ada.Strings.Bounded;
package B_String is
new Generic_Bounded_Length( 80 );
-- Note I/O errors on finalize initialize passed to user
with B_string, Ada.Finalization;
use B_string, Ada.Finalization;
generic
type Index is private; -- Index for record
type Data is private; -- Data for record
with function ">"( f:in Index; s:in Index ) return Boolean;
package Class_pic is
Not_there, Exists, Per_error : exception; -- Raised Exceptions
type PIC is new Limited_controlled with private;
procedure initialize( the:in out PIC );
procedure initialize( the:in out PIC; id:in String );
procedure finalize( the:in out PIC );
procedure discard( the:in out PIC );
procedure set_name( the:in out PIC; id:in String );
function get_name( the:in PIC ) return String;
procedure add( the:in out PIC; i:in Index; d:in Data );
procedure extract( the:in out PIC; i:in Index; d:in out Data );
procedure update( the:in out PIC; i:in Index; d:in out Data );
private
type Leaf; -- Index + Data
type Subtree is access Leaf; --
type PIC is new Limited_controlled with record
tree : Subtree := null; -- Storage
obj_id : Bounded_string; -- Name of object
end record;
function find( the:in Subtree; i:in Index) return Subtree;
procedure release_storage( the:in out Subtree );
end Class_pic;
with unchecked_deallocation, sequential_io;
package body Class_pic is
type Element is record --
s_index: Index; -- The Index
s_data : Data; -- The Data
end record;
type Leaf is record --
left : Subtree; -- Possible left node
rec : Element; -- Index + data
right : Subtree; -- Possible right node;
end record;
package io is new Sequential_io( Element );
procedure initialize( the:in out PIC ) is
begin
the.tree := null; -- No storage
end initialize;
procedure initialize( the:in out PIC; id:in String ) is
per : io.File_type; -- File descriptor
cur : Element; -- Persistent data record element
begin
set_name( the, id ); -- Name object
io.open( per, io.IN_FILE, id ); -- Open saved state
while not io.end_of_file( per ) loop -- Restore saved state
io.read( per, cur );
add( the, cur.s_index, cur.s_data );
end loop;
io.close( per );
exception -- Return real exception
when others => raise Per_error; -- as sub code
end initialize;
procedure finalize( the:in out PIC ) is
per : io.File_type; -- File descriptor
procedure rec_finalize( the:in Subtree ) is -- Save state
begin
if the /= null then -- Subtree save as
io.write( per, the.rec ); -- Item
rec_finalize( the.left ); -- LHS
rec_finalize( the.right ); -- RHS
end if;
end rec_finalize;
begin
if to_string(the.obj_id) /= "" then -- If save state
io.create( per, io.out_FILE,
to_string( the.obj_id ) );
rec_finalize( the.tree );
io.close( per );
end if;
release_storage( the.tree );
exception -- Return real exception
when others => raise Per_error; -- as sub code
end finalize;
procedure discard( the:in out PIC ) is
begin
set_name( the, "" ); -- No name
release_storage( the.tree ); -- Release storage
end discard;
procedure set_name( the:in out PIC; id:in String ) is
begin
the.obj_id := to_bounded_string(id); -- Set object name
end set_name;
function get_name( the:in PIC ) return String is
begin
return to_string( the.obj_id ); -- Name of object
end get_name;
procedure add( the:in out PIC; i:in Index; d:in Data ) is
procedure add_s(the:in out Subtree; i:in Index; d:in Data) is
begin
if the = null then
the := new Leaf'( null, Element'(i,d), null );
else
if i = the.rec.s_index then -- Index all ready exists
raise Exists;
elsif i > the.rec.s_index then -- Try on RHS
add_s( the.right, i, d );
else -- LHS
add_s( the.left, i, d );
end if;
end if;
end add_s;
begin
add_s( the.tree, i, d );
end add;
procedure extract(the:in out PIC; i:in Index; d:in out Data) is
node_is : Subtree;
begin
node_is := find( the.tree, i ); -- Find node with iey
d := node_is.rec.s_data; -- return data
end extract;
procedure update(the:in out PIC; i:in Index; d:in out Data) is
node_is : Subtree;
begin
node_is := find( the.tree, i ); -- Find node with iey
node_is.rec.s_data := d; -- Update data
end update;
function find( the:in Subtree; i:in Index) return Subtree is
begin
if the = null then raise Not_there; end if;
if i = the.rec.s_index then
return the; -- Found
else
if i > the.rec.s_index
then return find( the.right, i ); -- Try RHS
else return find( the.left, i ); -- Try LHS
end if;
end if;
end find;
procedure dispose is
new unchecked_deallocation( Leaf, Subtree );
procedure release_storage( the:in out Subtree ) is
begin
if the /= null then -- Not empty
release_storage( the.left ); -- Free LHS
release_storage( the.right ); -- Free RHS
dispose( the ); -- Dispose of item
end if;
the := null; -- Subtree root null
end release_storage;
end Class_pic;
-- Subtype as get demands a String
package Pack_types is
subtype Country is String( 1 .. 12 );
subtype IDC is String( 1 .. 6 );
end Pack_types;
----[gt.adb] Procedure
--with Pack_types;
--use Pack_types;
--function gt(f:in Country; s:in Country ) return Boolean is
--begin
-- return f > s;
--end gt;
with Class_pic, Pack_types;
use Pack_types;
pragma ELABorATE_all( Class_pic );
package Class_tel_list is new
Class_pic( Country, IDC, ">" );
package Pack_procedures is
procedure ex1;
procedure ex2;
procedure ex3;
procedure ex4;
end Pack_procedures;
with Simple_io, Pack_types, Class_tel_list;
use Simple_io, Pack_types, Class_tel_list;
package body Pack_procedures is
procedure ex1 is
tel_list : PIC;
begin
put("Creating Telephone list"); new_line;
set_name( tel_list, "tel_list.per" );
add( tel_list, "Canada ", "+1 " );
add( tel_list, "USA ", "+1 " );
add( tel_list, "Netherlands ", "+31 " );
add( tel_list, "Belgium ", "+32 " );
add( tel_list, "France ", "+33 " );
add( tel_list, "Gibraltar ", "+350 " );
add( tel_list, "Ireland ", "+353 " );
add( tel_list, "Switzerland ", "+41 " );
add( tel_list, "UK ", "+44 " );
add( tel_list, "Denmark ", "+45 " );
add( tel_list, "Norway ", "+47 " );
add( tel_list, "Germany ", "+49 " );
add( tel_list, "Australia ", "+61 " );
add( tel_list, "Japan ", "+81 " );
end ex1;
procedure ex2 is
tel_list : PIC;
action : Character;
name : Country;
tel : IDC;
begin
initialize( tel_list, "tel_list.per" );
while not end_of_file loop
begin
get( action ); -- Action to perform
case action is
when '+' => -- Add
get( name ); get( tel );
add( tel_list, name, tel );
when '=' => -- Extract
get( name );
extract( tel_list, name, tel );
put( "IDC for " ); put( name );
put( " is "); put( tel ); new_line;
when '*' => -- Update
get( name ); get( tel );
update( tel_list, name, tel );
when others => -- Invalid action
null;
end case;
exception
when Not_there => -- Not there
put("Name not in directory"); new_line;
when Exists => -- Exists
put("Name already in directory"); new_line;
end;
skip_line;
end loop;
end ex2;
procedure ex3 is
tel_list : PIC;
name : Country;
tel : IDC;
begin
add( tel_list, "Canada ", "+1 " );
add( tel_list, "USA ", "+1 " );
add( tel_list, "Netherlands ", "+31 " );
add( tel_list, "Belgium ", "+32 " );
add( tel_list, "France ", "+33 " );
add( tel_list, "Gibraltar ", "+350 " );
name := "France ";
extract( tel_list, name, tel );
put( "IDC for " ); put( name ); put( " is "); put( tel ); new_line;
name := "USA ";
extract( tel_list, name, tel );
put( "IDC for " ); put( name ); put( " is "); put( tel ); new_line;
end ex3;
procedure ex4 is
tel_list : PIC;
name : Country;
tel : IDC;
begin
add( tel_list, "Canada ", "+1 " );
put("Object identity is ["); put( get_name(tel_list) ); put("]"); new_line;
set_name( tel_list, "tel_list.per" );
put("Object identity is ["); put( get_name(tel_list) ); put("]"); new_line;
discard( tel_list );
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]