Unit StackUnit;

Interface

Const
 stackOk = 0;
 stackOverflow = 1;
 stackUnderflow = 2;

Var
 StackError : Byte;

Type
 NodePtr = ^Node;
 Node =
   Record
     Info : Pointer;
     Next : NodePtr;
   End;

 Stack =
   Record
     Head : NodePtr;
     Size : Word;
   End;


Procedure InitStack( Var S : Stack; size : Word );
Procedure ClearStack( Var S : Stack );

Procedure Push( Var S : Stack; Var E );
Procedure Pop( Var S : Stack; Var E );

Function Empty( Var S : Stack ) : Boolean;


Implementation

Var
 SaveHeapError : Pointer;

{$F+}
Function HeapFunc( Size : Word ) : Integer;
 Begin
   HeapFunc := 1;
 End;
{$F-}

Procedure InitStack( Var S : Stack; size : Word );
 Begin
   SaveHeapError := HeapError;
   S.Head := nil;
   S.Size := size;
   StackError := stackOk;
 End;

Procedure ClearStack( Var S : Stack );
 Var T : NodePtr;
 Begin
   StackError := stackOk;
   While S.Head <> nil Do
     Begin
       T := S.Head;
       S.Head := T^.Next;
       FreeMem( T^.Info, S.Size );
       Dispose( T )
     End
 End;

Procedure Push( Var S : Stack; Var E );
 Label Quit;
 Var T : NodePtr;
 Begin
   HeapError := @HeapFunc;
   StackError := stackOverflow;
   T := New( NodePtr );
   If T = nil Then Goto Quit;

   T^.Next := S.Head;
   S.Head := T;
   GetMem( T^.Info, S.Size );
   If T^.Info = nil Then Goto Quit;

   Move( E, T^.Info^, S.Size );
   StackError := stackOk;

 Quit:
   HeapError := SaveHeapError

 End;

Procedure Pop( Var S : Stack; Var E );
 Var T : NodePtr;
 Begin
   StackError := stackUnderflow;
   If S.Head = nil Then Exit;

   T := S.Head;
   S.Head := T^.Next;
   Move( T^.Info^, E, S.Size );
   FreeMem( T^.Info, S.Size );
   Dispose( T );
   StackError := stackOk
 End;


Procedure Top( Var S : Stack; Var E );
 Begin
   StackError := stackUnderflow;
   If S.Head = nil Then Exit;
   Move( S.Head^.Info^, E, S.Size );
   StackError := stackOk
 End;

Function Empty( Var S : Stack ) : Boolean;
 Begin
   Empty := (S.Head = nil)
 End;

END.

uses stackunit;

var
 si: stack;
 i, x: integer;

begin
 initstack(si, sizeof(integer));
 for i := 1 to 20 do
   push(si, i);

 while not empty(si) do
   begin
     pop(si, x);
     write(x:3);
   end;

 writeln;
end.