Jan 11 15:42 1996 linked_lists.ads Page 1 -- Generic Package Specification for Linked_Lists -- -- Requires: -- Instantiated with any private type and -- a "=" function for that type -- Types defined: -- Position private type -- List limited private type -- Exceptions defined: -- Item_Not_Found raised when searches, deletions, -- or access fails -- Advanced_Past_End raised by Advance if position is already null -- Operations defined: -- (* throws Item_Not_Found; ** throws Advanced_Past_End): -- Initialize and Finalize are defined for List -- Advance ** changes position to next position -- Delete * removes first occurrance of item from list -- Find * returns Position of item in list -- Find_Previous * returns Position prior to item in list -- First returns Position of first item in list -- In_List returns true if item is in list, false otherwise -- Insert * insert after a given position in a list -- Insert_As_First_Element -- insert as new first element in a list -- Is_Empty returns true if list is empty -- Is_Last returns true if position is last in list -- Make_Empty make a list empty -- Retrieve * returns item in position passed as parameter -- two forms: one requires list, other does not with Ada.Finalization; generic type Element_Type is private; with function "="( Left, Right: Element_Type ) return Boolean; package Linked_Lists is type Position is private; type List is new Ada.Finalization.Limited_Controlled with private; procedure Initialize( L: in out List ); procedure Finalize( L: in out List ); procedure Advance( P: in out Position; L: List ); procedure Delete( X: Element_Type; L: List ); function Find( X: Element_Type; L: List ) return Position; function Find_Previous( X: Element_Type; L: List ) return Position; function First( L: List ) return Position; function In_List( X: Element_Type; L: List ) return Boolean; procedure Insert( X: Element_Type; L: List; P: Position ); procedure Insert_As_First_Element( X: Element_Type; L: List ); function Is_Empty( L: List ) return Boolean; function Is_Last( P: Position; L: List ) return Boolean; procedure Make_Empty( L: in out List ); function Retrieve( P: Position; L: List ) return Element_Type; function Retrieve( P: Position ) return Element_Type; Jan 11 15:42 1996 linked_lists.ads Page 2 Item_Not_Found : exception; Advanced_Past_End : exception; private type Node is record Element : Element_Type; Next : Position; end record; type Position is access Node; type List is new Ada.Finalization.Limited_Controlled with record Header : Position; end record; procedure Delete_List( L: in out List ); end Linked_Lists; Jan 11 15:44 1996 linked_lists.adb Page 1 with Unchecked_Deallocation; -- This implementation uses a header node -- Thus Initialize and Finalize must be defined package body Linked_Lists is procedure Dispose is new Unchecked_Deallocation( Node, Position ); procedure Initialize( L: in out List ) is begin L.Header := null; Make_Empty( L ); end Initialize; procedure Finalize( L: in out List ) is begin Delete_List( L ); Dispose( L.Header ); end Finalize; -- Advance P to the next node -- Note that L is unused in this implementation procedure Advance( P: in out Position; L: List ) is begin if P = null then raise Advanced_Past_End; else P := P.Next; end if; end Advance; -- Delete from a list -- Cell pointed to by P.Next is removed -- Find_Previous raises Item_Not_Found if necessary -- so exception is automatically propagated procedure Delete( X: Element_Type; L: List ) is Prev_Cell : Position := Find_Previous( X, L ); Del_Cell : Position := Prev_Cell.Next; begin Prev_Cell.Next := Del_Cell.Next; -- Bypass cell to be deleted Dispose( Del_Cell ); -- Free the space end Delete; -- Return position of X in L -- Raise Item_Not_Found if appropriate function Find( X: Element_Type; L: List ) return Position is P: Position := L.Header.Next; begin while P /= null and then P.Element /= X loop P := P.Next; end loop; if P = null then raise Item_Not_Found; end if; Jan 11 15:44 1996 linked_lists.adb Page 2 return P; end Find; -- Return position prior to X in L -- Raise Item_Not_Found if appropriate -- Here we use a trick: we don't test for -- a null pointer, but instead catch the -- constraint_error that results from -- dereferencing it function Find_Previous( X: Element_Type; L: List ) return Position is P: Position := L.Header; begin while P.Next.Element /= X loop P := P.Next; end loop; return P; exception when Constraint_Error => raise Item_Not_Found; end Find_Previous; -- Return first position in list L function First( L: List ) return Position is begin return L.Header.Next; end First; -- Return true if X is in list L; false otherwise -- The algorithm is to perform a Find, and if the -- Find fails, an exception will be raised. function In_List( X: Element_Type; L: List ) return Boolean is P : Position; begin P := Find( X, L ); return True; exception when Item_Not_Found => return False; end In_List; -- Insert after Position P -- Note that L is unused procedure Insert( X: Element_Type; L: List; P: Position ) is begin if P = null then raise Item_Not_Found; else P.Next := new Node'( X, P.Next ); end if; end Insert; -- Insert X as the first element in list L procedure Insert_As_First_Element( X: Element_Type; L: List ) is Jan 11 15:44 1996 linked_lists.adb Page 3 begin Insert( X, L, L.Header ); end Insert_As_First_Element; -- Return true if L is empty; false otherwise function Is_Empty( L: List ) return Boolean is begin return L.Header.Next = null; end Is_Empty; -- Checks if P is last cell in the list function Is_Last( P: Position; L: List ) return Boolean is begin return P /= null and then P.Next = null; end Is_Last; -- If the List has not been initialized, -- allocate the header node -- Otherwise, call Delete_List procedure Make_Empty( L: in out List ) is begin if L.Header = null then L.Header := new Node; L.Header.Next := null; else Delete_List( L ); end if; end Make_Empty; -- Return item in Position P -- Note that L is unused in this implementation function Retrieve( P: Position; L: List ) return Element_Type is begin if P = null then raise Item_Not_Found; else return P.Element; end if; end Retrieve; -- Return item in Position P function Retrieve( P: Position ) return Element_Type is begin if P = null then raise Item_Not_Found; else return P.Element; end if; end Retrieve; -- Private routine to delete a list -- This is the routine that Make_Empty calls procedure Delete_List( L: in out List ) is P : Position := L.Header.Next; Temp: Position; begin Jan 11 15:44 1996 linked_lists.adb Page 4 L.Header.Next := null; while P /= null loop Temp := P.Next; Dispose( P ); P := Temp; end loop; end Delete_List; end Linked_Lists; Jan 11 15:45 1996 linked_lists_test.adb Page 1 -- Test program for both Cursor_Lists and Linked_Lists -- Choose the implementation you want with Linked_Lists; with Ada.Text_IO; use Ada.Text_IO; with Ada.Integer_Text_IO; use Ada.Integer_Text_IO; procedure Linked_Lists_Test is package Int_List is new Linked_Lists( Integer, "=" ); use Int_List; P_Main : Position; L_Main : List; -- Print out a list -- Because this is not part of the package, and -- the list and position are private types, -- this must use ADT operations only procedure Print_List( L: List ) is P : Position; begin if Is_Empty( L ) then Put_Line( "Empty list." ); else P := First( L ); Put( "List: " ); New_Line; loop Put( Retrieve( P, L ) ); New_Line; exit when Is_Last( P, L ); Advance( P, L ); end loop; end if; end Print_List; begin -- Make an empty list, print it out, do some inserts, -- print the list again, do some successful and -- unsuccessful finds, do an illegal deletion -- Make_Empty is not necessary in Ada95 -- Make_Empty( L_Main ); Print_List( L_Main ); for I in 1..5 loop Insert_As_First_Element( I, L_Main ); end loop; Print_List( L_Main ); for I in 4..6 loop begin P_Main := Find( I, L_Main ); Put( "Found " ); Put( I ); New_Line; exception when Item_Not_Found => Put( "Element not found" ); New_Line; Jan 11 15:45 1996 linked_lists_test.adb Page 2 end; end loop; Delete( 7, L_Main ); -- This should raise an exception exception when Item_Not_Found => Put( "Illegal deletion!" ); New_Line; end Linked_Lists_Test; Dec 7 15:34 1995 polynomials.ads Page 1 -- Simple polynomial package -- Doesn't do much with Ada.Text_IO; use Ada.Text_IO; with Ada.Integer_Text_IO; use Ada.Integer_Text_IO; with Ada.Float_Text_IO; use Ada.Float_Text_IO; package Polynomials is type Polynomial is private; Max_Degree : constant := 100; procedure Read_Polynomial( Poly: out Polynomial ); procedure Print_Polynomial( Poly: Polynomial ); function Zero_Polynomial return Polynomial; function "+"( Poly1, Poly2: Polynomial ) return Polynomial; function "*"( Poly1, Poly2: Polynomial ) return Polynomial; Polynomial_Error : exception; private type Array_Of_Float is array ( Natural range <> ) of Float; type Polynomial is record Coeff_Array : Array_Of_Float( 0..Max_Degree ) := ( others => 0.0 ); High_Power : Natural := 0; end record; end Polynomials; Jan 11 15:47 1996 polynomials.adb Page 1 -- Implementation of Polynomial package -- Does not do much package body Polynomials is function Max( A, B: Integer ) return Integer is begin if A > B then return A; else return B; end if; end Max; procedure Print_Polynomial( Poly: Polynomial ) is begin for I in reverse 0..Poly.High_Power loop if Poly.Coeff_Array( I ) /= 0.0 then Put( Poly.Coeff_Array( I ) ); Put( "X^" ); Put( I ); Put( "+" ); end if; end loop; New_Line; end Print_Polynomial; function Zero_Polynomial return Polynomial is begin return ( ( others => 0.0 ), 0 ); end Zero_Polynomial; function "+"( Poly1, Poly2: Polynomial ) return Polynomial is Poly_Sum : Polynomial := Zero_Polynomial; begin Poly_Sum.High_Power := Max( Poly1.High_Power, Poly2.High_Power ); if Poly_Sum.High_Power > Max_Degree then raise Polynomial_Error; end if; for I in 0..Poly_Sum.High_Power loop Poly_Sum.Coeff_Array( I ) := Poly1.Coeff_Array( I ) + Poly2.Coeff_Array( I ); end loop; return Poly_Sum; end "+"; function "*"( Poly1, Poly2: Polynomial ) return Polynomial is Poly_Prod : Polynomial := Zero_Polynomial; begin Poly_Prod.High_Power := Poly1.High_Power + Poly2.High_Power; if Poly_Prod.High_Power > Max_Degree then raise Polynomial_Error; end if; for I in 0..Poly1.High_Power loop for J in 0..Poly2.High_Power loop Poly_Prod.Coeff_Array( I+J ) := Poly_Prod.Coeff_Array( I+J ) Jan 11 15:47 1996 polynomials.adb Page 2 + Poly1.Coeff_Array( I )*Poly2.Coeff_Array( J ); end loop; end loop; return Poly_Prod; end "*"; procedure Read_Polynomial( Poly: out Polynomial ) is begin Poly.High_Power := 1; Poly.Coeff_Array( 1 ) := 1.0; Poly.Coeff_Array( 0 ) := 2.0; end Read_Polynomial; end Polynomials; Dec 7 15:34 1995 polynomials_test.adb Page 1 -- Simple test program for Polynomials package with Polynomials; use Polynomials; procedure Polynomials_Test is P1, P2, P3, P4: Polynomial; begin Read_Polynomial( P1 ); Read_Polynomial( P2 ); P3 := P1 * P2; P4 := P1 + P2; Print_Polynomial( P1 ); Print_Polynomial( P2 ); Print_Polynomial( P3 ); Print_Polynomial( P4 ); end Polynomials_Test; Jan 11 15:47 1996 cursor_lists.ads Page 1 -- Generic Package Specification for Cursor_Lists -- Same interface as Linked_Lists -- -- Requires: -- Instantiated with any private type and -- a "=" function for that type -- Types defined: -- Position private type -- List limited private type -- Exceptions defined: -- Item_Not_Found raised when searches, deletions, -- or access fails -- Out_Of_Space raised if Cursor_New fails -- List_Error raised for illegal Insert -- Advanced_Past_End raised by Advance if position is already null -- Operations defined: -- (* throws Item_Not_Found; ** throws Advanced_Past_End) -- (+ throws Out_Of_Space; ++ throws List_Error) -- Initialize and Finalize are not defined because -- we retain an Ada83 - type implementation -- An Ada95 implementation is left as an exercise -- Advance ** changes position to next position -- Delete * removes first occurrance of item from list -- Find * returns Position of item in list -- Find_Previous * returns Position prior to item in list -- First returns Position of first item in list -- In_List returns true if item is in list, false otherwise -- Insert + ++ insert after a given position in a list -- Insert_As_First_Element + ++ -- insert as new first element in a list -- Is_Empty returns true if list is empty -- Is_Last returns true if position is last in list -- Make_Empty make a list empty -- Retrieve * returns item in position passed as parameter -- two forms: one requires list, other does not generic type Element_Type is private; with function "="( Left, Right: Element_Type ) return Boolean; package Cursor_Lists is type List is limited private; type Position is private; procedure Advance( P: in out Position; L: List ); procedure Delete( X: Element_Type; L: List ); function Find( X: Element_Type; L: List ) return Position; function Find_Previous( X: Element_Type; L: List ) return Position; function First( L: List ) return Position; procedure Insert( X: Element_Type; L: List; P: Position ); procedure Insert_As_First_Element( X: Element_Type; L: List ); function Is_After_End( P: Position; L: List ) return Boolean; function Is_Empty( L: List ) return Boolean; function Is_Last( P: Position; L: List ) return Boolean; procedure Make_Empty( L: in out List ); function Retrieve( P: Position; L: List ) return Element_Type; Jan 11 15:47 1996 cursor_lists.ads Page 2 Item_Not_Found : exception; Out_Of_Space : exception; List_Error : exception; Advanced_Past_End : exception; private Space_Size : constant := 100; subtype Cursor_Index is Natural range 0..Space_Size; type Position is new Cursor_Index; type List is new Cursor_Index; type Node is record Element : Element_Type; Next : Position := 0; end record; end Cursor_Lists; Jan 11 15:48 1996 cursor_lists.adb Page 1 package body Cursor_Lists is type Cursor_Array is array( Position range <> )of Node; function Cursor_New return Position; procedure Cursor_Dispose( P: in out Position ); procedure Init_Mem; -- Called once to initialize cursor_space; Cursor_Space : Cursor_Array( Position'First..Position'Last ); Memory_Is_Initialized : Boolean := False; -- New and Dispose equivalents for Cursor nodes function Cursor_New return Position is P : Position := Cursor_Space( 0 ).Next; begin if P = 0 then raise Out_Of_Space; end if; Cursor_Space( 0 ).Next := Cursor_Space( P ).Next; return P; end Cursor_New; procedure Cursor_Dispose( P: in out Position ) is begin Cursor_Space( P ).Next := Cursor_Space( 0 ).Next; Cursor_Space( 0 ).Next := P; P := 0; end Cursor_Dispose; -- Cursor implementation of linked lists -- Lists are implemented with header node -- This routine initializes the freelist procedure Init_Mem is begin for I in Cursor_Space'First .. Cursor_Space'Last-1 loop Cursor_Space( I ).Next := I+1; end loop; Cursor_Space( Cursor_Space'Last ).Next := 0; end Init_Mem; -- BASIC LINKED LIST ROUTINES -- Set P equal to the next position -- Raise an exception if necessary -- Note that L is ignored procedure Advance( P: in out Position; L: List ) is begin if P = 0 then raise Advanced_Past_End; else P := Cursor_Space( P ).Next; end if; end Advance; Jan 11 15:48 1996 cursor_lists.adb Page 2 -- Delete from a list -- Raise Item_Not_Found if necessary procedure Delete( X: Element_Type; L: List ) is Prev_Cell : Position := Find_Previous( X, L ); Del_Cell : Position := Cursor_Space( Prev_Cell ).Next; begin Cursor_Space( Prev_Cell ).Next := Cursor_Space( Del_Cell ).Next; Cursor_Dispose( Del_Cell ); -- Free the space end Delete; -- Return position of X in L; raise exception if not found function Find( X: Element_Type; L: List ) return Position is P : Position := Cursor_Space( Position ( L ) ).Next; begin loop if P = 0 then raise Item_Not_Found; elsif Cursor_Space( P ).Element = X then return P; else P := Cursor_Space( P ).Next; end if; end loop; end Find; -- Return position prior to X in L; -- Raise exception if not found function Find_Previous( X: Element_Type; L: List ) return Position is P: Position := Position( L ); begin while Cursor_Space( P ).Next /= 0 and then Cursor_Space( Cursor_Space( P ).Next ).Element /= X loop P := Cursor_Space( P ).Next; end loop; if Cursor_Space( P ).Next = 0 then raise Item_Not_Found; end if; return P; end Find_Previous; -- Return first position in list L function First( L: List ) return Position is begin return Cursor_Space( Position( L ) ).Next; end First; -- Insert X after Position P -- Note that List L is ignored procedure Insert( X: Element_Type; L: List; P: Position ) is Tmp_Cell : Position; begin if P = 0 then raise List_Error; end if; Jan 11 15:48 1996 cursor_lists.adb Page 3 Tmp_Cell := Cursor_New; -- Get a new cell Cursor_Space( Tmp_Cell ).Element := X; Cursor_Space( Tmp_Cell ).Next := Cursor_Space( P ).Next; Cursor_Space( P ).Next := Tmp_Cell; end Insert; -- Insert X as new first element in list L procedure Insert_As_First_Element( X: Element_Type; L: List ) is begin Insert( X, L, Position( L ) ); end Insert_As_First_Element; -- Return true if P is past the end of the list -- Note that L is ignored function Is_After_End( P: Position; L: List ) return Boolean is begin return P = 0; end Is_After_End; -- Return true if L is empty, false otherwise function Is_Empty( L: List ) return Boolean is begin return Cursor_Space( Position( L ) ).Next = 0; end Is_Empty; -- Return true if P is the last element in the list -- Note that L is ignored function Is_Last( P: Position; L: List ) return Boolean is begin return Cursor_Space( P ).Next = 0; end Is_Last; -- Make L empty -- This implementation does not recycle list nodes -- Exercise: if L is non-empty, place list cells on freelist procedure Make_Empty( L: in out List ) is New_L : Position; begin if not Memory_Is_Initialized then Init_Mem; Memory_Is_Initialized := True; end if; New_L := Cursor_New; Cursor_Space( New_L ).Next := 0; L := List( New_L ); end Make_Empty; -- Return item in position P -- Raise an exception if necessary -- Note that L is ignored function Retrieve( P: Position; L: List ) return Element_Type is begin if P = 0 then raise Item_Not_Found; Jan 11 15:48 1996 cursor_lists.adb Page 4 else return Cursor_Space( P ).Element; end if; end Retrieve; end Cursor_Lists; Jan 11 15:49 1996 stack_array.ads Page 1 -- Generic Package Specification for Stack_Array -- Uses an array implementation -- Requires: -- Instantiated with any private type -- Types defined: -- Stack( Integer ) limited private type -- Exceptions defined: -- Overflow raised for Push on a full Stack -- Underflow raised for Pop or Top on empty Stack -- Operations defined: -- Is_Empty returns true if stack is empty -- Is_Full returns true if stack is full -- Make_Empty make a stack empty -- Pop delete top element from stack -- two forms are provided -- Push add a new top element to stack -- Top return top element of stack generic type Element_Type is private; package Stack_Array is type Stack( Stack_Size: Positive ) is limited private; function Is_Empty( S: Stack ) return Boolean; function Is_Full( S: Stack ) return Boolean; procedure Make_Empty( S: in out Stack ); procedure Pop ( S: in out Stack; Top_Element: out Element_Type ); procedure Pop ( S: in out Stack ); procedure Push ( X: Element_Type; S: in out Stack ); function Top ( S: Stack ) return Element_Type; Overflow : exception; Underflow: exception; private -- Stack implementation is array-based. type Array_Of_Element_Type is array( Positive range <> ) of Element_Type; type Stack( Stack_Size: Positive ) is record Top_Of_Stack : Natural := 0; Stack_Array : Array_Of_Element_Type( 1..Stack_Size ); end record; end Stack_Array; Dec 7 17:08 1995 stack_array.adb Page 1 package body Stack_Array is -- Return true if Stack S is empty, false otherwise function Is_Empty( S: Stack ) return Boolean is begin return S.Top_Of_Stack = S.Stack_Array'First - 1; end Is_Empty; -- Return true if Stack S is full, false otherwise function Is_Full( S: Stack ) return Boolean is begin return S.Top_Of_Stack = S.Stack_Array'Last; end Is_Full; -- Make Stack S empty procedure Make_Empty( S: in out Stack ) is begin S.Top_Of_Stack := S.Stack_Array'First - 1; end Make_Empty; -- Delete top item from Stack S -- Raise Underflow if S is empty procedure Pop( S: in out Stack ) is begin if Is_Empty( S ) then raise Underflow; end if; S.Top_Of_Stack := S.Top_Of_Stack - 1; end Pop; -- Delete top item from S, store it in Top_Element -- Raise Underflow if S is empty procedure Pop( S: in out Stack; Top_Element: out Element_Type ) is begin if Is_Empty( S ) then raise Underflow; end if; Top_Element := S.Stack_Array( S.Top_Of_Stack ); S.Top_Of_Stack := S.Top_Of_Stack - 1; end Pop; -- Insert X as new top of Stack S -- Raise Overflow if S is full procedure Push( X: Element_Type; S: in out Stack ) is begin if Is_Full( S ) then raise Overflow; end if; S.Top_Of_Stack := S.Top_Of_Stack + 1; S.Stack_Array( S.Top_Of_Stack ) := X; end Push; -- Return top item in Stack S Dec 7 17:08 1995 stack_array.adb Page 2 -- Raise Underflow if S is empty function Top( S: Stack ) return Element_Type is begin if Is_Empty( S ) then raise Underflow; end if; return S.Stack_Array( S.Top_Of_Stack ); end Top; end Stack_Array; Jan 11 15:49 1996 stack_list.ads Page 1 -- Generic Package Specification for Stack_List -- Uses a linked list implementation -- Requires: -- Instantiated with any private type -- Types defined: -- Stack limited private type -- Exceptions defined: -- Overflow raised for Push on a full Stack -- Underflow raised for Pop or Top on empty Stack -- Operations defined: -- Initialize and Finalize are defined -- Is_Empty returns true if stack is empty -- Make_Empty make a stack empty -- Pop delete top element from stack -- Push add a new top element to stack -- Top return top element of stack with Ada.Finalization; generic type Element_Type is private; package Stack_List is type Stack is new Ada.Finalization.Limited_Controlled with private; procedure Initialize( S: in out Stack ); procedure Finalize( S: in out Stack ); function Is_Empty( S: Stack ) return Boolean; procedure Make_Empty( S: in out Stack ); procedure Pop ( S: in out Stack ); procedure Push ( X: Element_Type; S: in out Stack ); function Top ( S: Stack ) return Element_Type; Overflow : exception; Underflow: exception; private -- Stack implementation is a linked list with no header type Node; type Node_Ptr is access Node; type Node is record Element : Element_Type; Next : Node_Ptr; end record; type Stack is new Ada.Finalization.Limited_Controlled with record TopOfStack : Node_Ptr; end record; end Stack_List; Dec 7 17:21 1995 stack_list.adb Page 1 with Unchecked_Deallocation; package body Stack_List is procedure Dispose is new Unchecked_Deallocation( Node, Node_Ptr ); -- Initialize and Finalize routines procedure Initialize( S: in out Stack ) is begin null; end Initialize; procedure Finalize( S: in out Stack ) is begin Make_Empty( S ); end Finalize; -- Return true if Stack S is empty, false otherwise function Is_Empty( S: Stack ) return Boolean is begin return S.TopOfStack = null; end Is_Empty; -- Make Stack S empty procedure Make_Empty( S: in out Stack ) is begin while not Is_Empty( S ) loop Pop( S ); end loop; end Make_Empty; -- Remove top item from Stack S -- Raise Underflow if S is empty procedure Pop( S: in out Stack ) is First_Cell : Node_Ptr; begin if Is_Empty( S ) then raise Underflow; end if; First_Cell := S.TopOfStack; S.TopOfStack := S.TopOfStack.Next; Dispose( First_Cell ); end Pop; -- Insert X as new top item in Stack S -- Raise Overflow if out of memory procedure Push( X: Element_Type; S: in out Stack ) is begin S.TopOfStack := new Node'( X, S.TopOfStack ); exception when Storage_Error => raise Overflow; end Push; -- Return top item in Stack S Dec 7 17:21 1995 stack_list.adb Page 2 -- Raise Underflow if S is empty function Top( S: Stack ) return Element_Type is begin if Is_Empty( S ) then raise Underflow; end if; return S.TopOfStack.Element; end Top; end Stack_List; Dec 7 21:17 1995 stack_test.adb Page 1 -------------------------------------------------------------------------- -- Main procedure which uses instantiated Stack package -------------------------------------------------------------------------- -- Choose either Stack_List or Stack_Array with Stack_List; with Ada.Text_IO, Ada.Integer_Text_IO; use Ada.Text_IO, Ada.Integer_Text_IO; procedure Stack_test is package Integer_Stacks is new Stack_List( Integer ); use Integer_Stacks; Stack_Of_Integers: Stack; begin for Loop_Counter in 1..10 loop Push( Loop_Counter, Stack_Of_Integers ); end loop; while not Is_Empty( Stack_Of_Integers ) loop Put( Top( Stack_Of_Integers ) ); New_Line; Pop( Stack_Of_Integers ); end loop; exception when Overflow => Put_Line( "Overflow" ); when Underflow => Put_Line( "Underflow" ); end Stack_test; Jan 11 15:49 1996 queue_array.ads Page 1 -- Generic Package Specification for Queue_Array -- Uses an array implementation -- Requires: -- Instantiated with any private type -- Types defined: -- Queue( Integer ) limited private type -- Exceptions defined: -- Overflow raised for Push on a full Queue -- Underflow raised for Pop or Top on empty Queue -- Operations defined: -- Dequeue delete and show front element from queue -- Enqueue add a new element to back of queue -- Is_Empty returns true if queue is empty -- Is_Full returns true if queue is full -- Make_Empty make a queue empty generic type Element_Type is private; package Queue_Array is type Queue( Max_Elements: Positive ) is limited private; procedure Enqueue ( X: Element_Type; Q: in out Queue ); procedure Dequeue ( X: out Element_Type; Q: in out Queue ); function Is_Empty( Q: Queue ) return Boolean; function Is_Full ( Q: Queue ) return Boolean; procedure Make_Empty( Q: in out Queue ); Overflow : exception; Underflow: exception; private type Array_Of_Element_Type is array( Positive range <> ) of Element_Type; type Queue( Max_Elements: Positive ) is record Q_Front : Natural := 1; Q_Rear : Natural := 0; Q_Size : Natural := 0; Q_Array : Array_Of_Element_Type( 1..Max_Elements ); end record; end Queue_Array; Dec 7 21:15 1995 queue_array.adb Page 1 -- Implementation of Queue_Array package body Queue_Array is -- Internal routine Increment is used for wraparound procedure Increment( X: in out Integer; Q : Queue ) is begin if X = Q.Q_Array'Last then X := Q.Q_Array'First; else X := X + 1; end if; end Increment; -- Remove front item from Queue Q and place it in X -- Exception is raised if Q is empty procedure Dequeue( X: out Element_Type; Q: in out Queue ) is begin if Is_Empty( Q ) then raise Underflow; end if; Q.Q_Size := Q.Q_Size-1; X := Q.Q_Array( Q.Q_Front ); Increment( Q.Q_Front, Q ); end Dequeue; -- Add item X to rear of Queue Q -- Exception is raised if Q is full procedure Enqueue( X: Element_Type; Q: in out Queue ) is begin if Is_Full( Q ) then raise Overflow; end if; Q.Q_Size := Q.Q_Size + 1; Increment( Q.Q_Rear, Q ); Q.Q_Array( Q.Q_Rear ) := X; end Enqueue; -- Return true if Queue Q is empty, false otherwise function Is_Empty( Q : Queue ) return Boolean is begin return Q.Q_Size = 0; end Is_Empty; -- Return true if Queue Q is full, false otherwise function Is_Full( Q : Queue ) return Boolean is begin return Q.Q_Size = Q.Q_Array'Length; end Is_Full; -- Make Queue Q empty procedure Make_Empty( Q : in out Queue ) is begin Q.Q_Front := Q.Q_Array'First; Dec 7 21:15 1995 queue_array.adb Page 2 Q.Q_Rear := Q.Q_Array'First - 1; Q.Q_Size := 0; end Make_Empty; end Queue_Array; Dec 7 21:17 1995 queue_test.adb Page 1 -------------------------------------------------------------------------- -- Main procedure which uses instantiated Queue package -------------------------------------------------------------------------- with Queue_Array; with Ada.Text_IO, Ada.Integer_Text_IO; use Ada.Text_IO, Ada.Integer_Text_IO; procedure Queue_Test is package Integer_Queues is new Queue_Array( Integer ); use Integer_Queues; Queue_Of_Integers: Queue( 10 ); Top_E : Integer; begin Make_Empty( Queue_Of_Integers ); for Loop_Counter in 1..10 loop Enqueue( Loop_Counter, Queue_Of_Integers ); end loop; while not Is_Empty( Queue_Of_Integers ) loop Dequeue( Top_E, Queue_Of_Integers ); Put( Top_E ); New_Line; end loop; Dequeue( Top_E, Queue_Of_Integers ); exception when Overflow => Put_Line( "Overflow" ); when Underflow => Put_Line( "Underflow" ); end Queue_Test;