::
x60_ll5.ada
-- list -> ( first_node, last_node ) ( prev,item,next)
-- Iter -> ( cur_list_first, cur_list_last, cur_node )
with Ada.Finalization, Unchecked_deallocation;
use Ada.Finalization;
generic
type T is private; -- Any type
package Class_list is
type List is new Controlled with private;
procedure initialize( the:in out List );
procedure initialize( the:in out List; data:in T );
procedure finalize( the:in out List );
procedure adjust( the:in out List );
function "=" ( f:in List; s:in List ) return Boolean;
private
procedure release_storage( the:in out List );
type Node; -- Tentative declaration
type P_Node is access all Node; -- Pointer to Node
type Node is record
prev : P_Node; -- Previous Node
item : T; -- The physical item
next : P_Node; -- Next Node
end record;
procedure dispose_node is
new unchecked_deallocation( Node, P_Node );
type List is new Controlled with record
first_node : aliased P_Node := null; -- First item in list
last_node : aliased P_Node := null; -- First item in list
end record;
end Class_list;
--with Simple_io; use Simple_io;
package body Class_list is
procedure initialize( the:in out List ) is
begin
the.first_node := null; -- Empty list
the.last_node := null; -- Empty list
end initialize;
procedure initialize( the:in out List; data:in T ) is
begin
the.first_node := new Node'(null, data, null);
the.last_node := the.first_node;
end initialize;
procedure finalize( the:in out List ) is
begin
if the.first_node /= null then
release_storage( the );
the.first_node := null;
end if;
--xyz( the ); -- Can not do this here DEBUG TRACE
end finalize;
procedure adjust( the:in out List ) is
cur : P_Node := the.first_node; -- Original list
lst : P_Node := null; -- Last created node
prv : P_Node := null; -- Previously created node
fst : P_Node := null; -- The first node
begin
while cur /= null loop
lst := new Node'( prv, cur.item, null );
if fst = null then fst := lst; end if;
if prv /= null then prv.next := lst; end if;
prv := lst;
cur := cur.next; -- Next node
end loop;
the.first_node := fst; -- Update
the.last_node := lst;
end adjust;
function "=" ( f:in List; s:in List ) return Boolean is
f_node : P_Node := f.first_node; -- First list
s_node : P_Node := s.first_node; -- Second list
begin
while f_node /= null and s_node /= null loop
if f_node.item /= s_node.item then
return FALSE; -- Different items
end if;
f_node := f_node.next; s_node := s_node.next;
end loop;
return f_node = s_node; -- Both null if equal
end "=";
procedure release_storage( the:in out List ) is
cur : P_Node := the.first_node; -- Pointer to curr node
tmp : P_Node; -- Node to dispose
begin
while cur /= null loop -- For each item in list
tmp := cur; -- Item to dispose
cur := cur.next; -- Next node
dispose_node( tmp ); -- Dispose of item
end loop;
end release_storage;
end Class_list;
--with Ada.Finalization; use Ada.Finalization;
generic
package Class_list.Iterator is
type List_iter is limited private;
procedure initialize( the:in out List_iter );
procedure finalize( the:in out List_iter );
procedure first( the:in out List_iter; l:in out List );
procedure last( the:in out List_iter; l:in out List );
function deliver( the:in List_iter) return T;
procedure insert( the:in out List_iter; data:in T );
procedure delete( the:in out List_iter );
function is_end( the:in List_iter ) return Boolean;
procedure next( the:in out List_iter );
procedure prev( the:in out List_iter );
private
type P_P_Node is access all P_Node;
type List_iter is record
cur_list_first: P_P_Node := null; -- First in chain
cur_list_last : P_P_Node := null; -- Last in chain
cur_node : P_Node := null; -- Current item
end record;
end Class_list.Iterator;
--with Simple_io; use Simple_io;
package body Class_list.Iterator is
procedure initialize( the:in out List_iter ) is
begin
the.cur_node := null; -- Iterator not setup
the.cur_list_first := null;
the.cur_list_last := null;
end initialize;
procedure finalize( the:in out List_iter ) is
begin
null;
end finalize;
procedure first( the:in out List_iter; l:in out List ) is
begin
the.cur_node := l.first_node; -- Set to first
the.cur_list_first:= l.first_node'Unchecked_Access;
the.cur_list_last := l.last_node'Unchecked_Access;
end first;
procedure last( the:in out List_iter; l:in out List ) is
begin
the.cur_node := l.last_node; -- Set to last
the.cur_list_first:= l.first_node'Unchecked_Access;
the.cur_list_last := l.last_node'Unchecked_Access;
end last;
function deliver( the:in List_iter ) return T is
begin
return the.cur_node.item; -- The current item
end deliver;
procedure insert( the:in out List_iter; data:in T ) is
tmp : P_Node;
cur : P_Node := the.cur_node; -- Current element
first : P_P_Node := the.cur_list_first;
last : P_P_Node := the.cur_list_last;
begin
if cur = null then -- Empty or last item
if first.all = null then -- Empty list
tmp := new Node'( null, data, null );
first.all := tmp;
last.all := tmp;
the.cur_node := tmp;
else -- Last
tmp := new Node'( last.all, data, null );
last.all.next := tmp;
last.all := tmp;
the.cur_node := tmp;
end if;
else
tmp := new Node'( cur.prev, data, cur );
if cur.prev = null then -- First item
first.all := tmp;
else
cur.prev.next := tmp;
end if;
cur.prev := tmp;
end if;
end insert;
procedure delete( the:in out List_iter) is
cur : P_Node := the.cur_node; -- Current element
first : P_P_Node := the.cur_list_first;
last : P_P_Node := the.cur_list_last;
begin
if cur /= null then -- Something to delete
if cur.prev /= null then -- Fix forward pointer;
cur.prev.next := cur.next; -- Not first in chain
else
first.all := cur.next; -- First in chain
if first.all = null then
last.all := null; -- Empty list
end if;
end if;
if cur.next /= null then -- Fix backward pointer;
cur.next.prev := cur.prev; -- Not last in chain
else
last.all := cur.prev; -- Last in chain
if last.all = null then
first.all := null; -- Empty list
end if;
end if;
if cur.next /= null then -- Fix current pointer
the.cur_node := cur.next; -- next
elsif cur.prev /= null then
the.cur_node := cur.prev; -- previous
else
the.cur_node := null; -- none empty list
end if;
dispose_node( cur ); -- Release storage
end if;
end delete;
function is_end( the:in List_iter ) return Boolean is
begin
return the.cur_node = null; -- True if end
end is_end;
procedure next( the:in out List_iter ) is
begin
if the.cur_node /= null then --
the.cur_node := the.cur_node.next; -- Next
end if;
end next;
procedure prev( the:in out List_iter ) is
begin
if the.cur_node /= null then --
the.cur_node := the.cur_node.prev; -- Previous
end if;
end prev;
end Class_list.Iterator;
with Class_list;
pragma ELABorATE_all( Class_List );
package Class_list_nat is new Class_list(Natural);
with Class_list_nat, Class_list.Iterator;
pragma ELABorATE_all( Class_List_nat, Class_List.Iterator );
package Class_list_nat_iterator is new Class_list_nat.Iterator;
with Simple_io, Class_list_nat, Class_list_nat_iterator;
use Simple_io, Class_list_nat, Class_list_nat_iterator;
package Pack_procedures is
procedure ex1;
procedure ex2;
procedure ex3;
procedure ex4;
procedure ex5;
procedure ex6;
end Pack_procedures;
with Simple_io; use Simple_io;
package body Pack_procedures is
procedure ex1 is
numbers : List; -- List of Natural numbers
numbers_it : List_iter; -- Iterator for list
begin
first( numbers_it, numbers );
insert( numbers_it, 50 );
insert( numbers_it, 5 );
insert( numbers_it, 40 );
last( numbers_it, numbers );
next( numbers_it );
insert( numbers_it, 100 );
prev( numbers_it );
prev( numbers_it );
insert( numbers_it, 30 );
first( numbers_it, numbers );
while not is_end( numbers_it ) loop
put( deliver( numbers_it ) );
next( numbers_it );
end loop;
new_line;
end ex1;
procedure ex2 is
numbers : List; -- List of Natural numbers
numbers_it : List_iter; -- Iterator for list
procedure insert( pos:in Integer; num:in Integer ) is
count : Integer := pos;
begin
first( numbers_it, numbers );
while count >= 1 loop
next( numbers_it ); count := count-1;
end loop;
insert( numbers_it, num );
end insert;
procedure delete( pos:in Integer ) is
count : Integer := pos;
begin
first( numbers_it, numbers );
while count >= 1 loop
next( numbers_it ); count := count-1;
end loop;
delete( numbers_it );
end delete;
procedure print is
begin
first( numbers_it, numbers );
while not is_end(numbers_it) loop
put( deliver(numbers_it), width=>3 );
next( numbers_it );
end loop;
new_line;
end print;
begin
insert( 0, 50 ); print;
put(" 50 <Should be>"); new_line;
insert( 0, 30 ); print;
put(" 30 50 <Should be>"); new_line;
insert( 1, 40 ); print;
put(" 30 40 50 <Should be>"); new_line;
insert( 2, 45 ); print;
put(" 30 40 45 50 <Should be>"); new_line;
insert( 2, 42 ); print;
put(" 30 40 42 45 50 <Should be>"); new_line;
insert( 5, 99 ); print;
put(" 30 40 42 45 50 99<Should be>"); new_line;
delete( 5 ); print;
put(" 30 40 42 45 50 <Should be>"); new_line;
delete( 0 ); print;
put(" 40 42 45 50 <Should be>"); new_line;
delete( 1 ); print;
put(" 40 45 50 <Should be>"); new_line;
delete( 2 ); print;
put(" 40 45 <Should be>"); new_line;
delete( 1 ); print;
put(" 40 <Should be>"); new_line;
delete( 0 ); print;
put(" <Should be>"); new_line;
end ex2;
procedure ex3 is
numbers : List; -- List of Natural numbers
numbers_it : List_iter; -- Iterator for list
begin
first( numbers_it, numbers );
insert( numbers_it, 100 );
insert( numbers_it, 50 );
first( numbers_it, numbers );
while not is_end(numbers_it) loop
put( deliver(numbers_it) ); next( numbers_it );
end loop;
new_line;
end ex3;
procedure ex4 is
numbers : List; -- List of Natural numbers
numbers_it : List_iter; -- Iterator for list
begin
first( numbers_it, numbers ); -- Initialize
for number in 1 .. 10 loop
insert( numbers_it, number ); -- Insert before
next( numbers_it ); -- Next item
end loop;
first(numbers_it,numbers); -- Set to start
while not is_end( numbers_it ) loop -- Not end of list
put( deliver(numbers_it) ); put(" "); -- Print
next( numbers_it ); -- Next item
end loop;
new_line;
end ex4;
procedure ex5 is
original: List; -- List of numbers
copy : List; -- List of numbers
num_it : List_iter; -- Iterator
begin
for number in 1 .. 10 loop
last( num_it, original ); -- Set iterator last
next( num_it ); -- So can insert
insert( num_it, number ); -- after last item
end loop;
put("copy := original "); new_line;
copy := original;
put("copy = original ");
if copy = original then put("True"); else put("False"); end if;
new_line;
put("Append 99 to copy "); new_line;
last( num_it, copy ); next( num_it );
insert( num_it, 99 );
put("copy = original ");
if copy = original then put("True"); else put("False"); end if;
new_line;
first(num_it,original); -- Set to start
while not is_end( num_it ) loop -- Not end of list
put( deliver(num_it), width=>4 ); -- Print
next( num_it ); -- Next item
end loop;
new_line;
first(num_it,copy); -- Set to start
while not is_end( num_it ) loop -- Not end of list
put( deliver(num_it), width=>4 ); -- Print
next( num_it ); -- Next item
end loop;
new_line;
end ex5;
procedure ex6 is
numbers: List; -- List of numbers
num_it : List_iter; -- Iterator
num,in_list: Natural;
begin
first( num_it, numbers );
while not end_of_file loop -- Data available
while not end_of_line loop
get(num); first(num_it,numbers); -- Read number
while not is_end( num_it ) loop -- Scan through list
in_list := deliver(num_it);
exit when in_list > num; -- Exit when larger no.
next( num_it ); -- Next item
end loop;
insert( num_it, num ); -- Before larger no.
end loop;
skip_line; -- Next line
end loop;
put("Numbers sorted are: ");
first(num_it,numbers); -- Set at start
while not is_end( num_it ) loop
in_list := deliver( num_it ); -- Current number
put( in_list,width=>1 ); put(" "); -- Print
next( num_it ); -- Next number
end loop;
new_line;
end ex6;
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;
put("Example 5"); new_line; ex5;
put("Example 6"); new_line; ex6;
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]