Turbo Toolbox/Turbo_Toolbox.iso/1988/08_09/stack/stackhan.mod

Modula Implementation | 1988-01-10 | 6.9 KB | 214 lines

IMPLEMENTATION MODULE StackHandler;
(*----------------------------------------------------------------------*
 * Dieses Modul verwaltet Stacks mit beliebigen Datenelementen bis zu   *
 * 255 Bytes pro Element.                                               *
 * Copyright 1987: Dipl.-Inform. Frank F. Wachtmeister                  *
 *----------------------------------------------------------------------*
 * System  :  ATARI 520 ST+, SM 124, PADERCOMP DL-2, EPSON FX-105       *
 * Compiler:  TDI MODULA-2/ST 0272-742796(UK)                           *
 *----------------------------------------------------------------------*
 * Verwendete Module, die nicht zum Grundpaket gehören:                 *
 *    Debugger: erhältlich über PASCAL Intern. 4/88                     *
 *----------------------------------------------------------------------*
 * Folgende Fehlermeldungen sind über den Debugger implementiert:       *
 * 101: Stack Overflow                                                  *
 * 102: Stack not initialized                                           *
 * 103: Stack Element too large. Max. 255 Bytes                         *
 * 104: Stack Underflow                                                 *
 * 105: Stack element inkompatible with given variable (Pop)            *
 *                                                                      *
 * Vergleiche Datei ERRORS.TXT                                          *
 *----------------------------------------------------------------------*)

(*$Q+,T-,$S- *)

FROM SYSTEM   IMPORT ADDRESS, BYTE, WORD;
FROM Storage  IMPORT ALLOCATE, DEALLOCATE;
FROM Debugger IMPORT Into, Leaving, Message, InitDebugger,
                     Activate, Error;

TYPE
   Stack       = POINTER TO StackDescription;
   SegmentList = POINTER TO StackSegment;

   StackDescription = RECORD
      top : SegmentList;   (* Zeiger auf letztes Segment des Stacks      *)
      anz : CARDINAL;      (* Anzahl der Elemente des Stacks             *)
   END;

   StackSegment = RECORD
      info  : ARRAY[0..255] OF BYTE;
      free  : [0..255];
      before: SegmentList;
   END;

CONST DEBUG = FALSE;

PROCEDURE Dummy (VAR name: ARRAY OF CHAR; word: WORD);
VAR w: WORD;

BEGIN w:=word;
END Dummy;


PROCEDURE InitStack (VAR s: Stack);
(*----------------------------------------------------------------------*
 * InitStack initialisiert einen leeren Stack.                          *
 *----------------------------------------------------------------------*)
BEGIN
IF DEBUG THEN Into ('InitStack             ') END;
   NEW (s);
   WITH s^ DO
      top := NIL;  anz:=0;
   END;
   IF DEBUG THEN Leaving ('InitStack                ') END;
END InitStack;


PROCEDURE StackSize (VAR s: Stack): CARDINAL;
(*----------------------------------------------------------------------*
 * StackSize liefert die Anzahl der Elemente eines Stacks.              *
 * Leerer oder nicht initialisierter Stack: StackSize = 0               *
 *----------------------------------------------------------------------*)
BEGIN
   IF DEBUG THEN Into ('StackSize') END;
   IF s<>NIL THEN
      RETURN (s^.anz)
   ELSE
      RETURN (0)
   END;
   IF DEBUG THEN Leaving ('StackSize') END;
END StackSize;


PROCEDURE AssByte (VAR b: BYTE; c: CARDINAL);
VAR
   m: RECORD
      CASE : BOOLEAN OF
         TRUE : high,low: BYTE;
      |  FALSE: card    : CARDINAL;
      END;
   END;

BEGIN
   m.card:=c;
   b     :=m.low;
END AssByte;


PROCEDURE AssCard (VAR c: CARDINAL; b: BYTE);
VAR
   m: RECORD
      CASE : BOOLEAN OF
         TRUE : high,low: BYTE;
      |  FALSE: card    : CARDINAL;
      END;
   END;

BEGIN
   m.low:=b;
   c    :=m.card;
END AssCard;


PROCEDURE Push (VAR s: Stack; elem: ARRAY OF BYTE);
(*----------------------------------------------------------------------*
 * Push legt ein Element beliebigen Typs auf einen Stack s.             *
 *----------------------------------------------------------------------*)
VAR i,
    ende: CARDINAL;
    seg:  SegmentList;

BEGIN
   IF DEBUG THEN Into ('Push                     ') END;
   IF s<>NIL THEN
      IF HIGH(elem)>255 THEN
         Error (103)
      ELSE
         IF s^.top=NIL THEN
            ende:=256
         ELSE
            ende:=s^.top^.free+SIZE(elem)+1
         END;
         IF ende>255 THEN (* AddSegment *)
            NEW (seg);
            WITH seg^ DO
               free  :=0;
               before:=s^.top;
            END;
            s^.top:=seg;
         END;
         WITH s^.top^ DO (* Add Element *)
            FOR i:=0 TO HIGH (elem) DO
               info [free+i]:=elem[i];
            END;
            free:=free+SIZE(elem);
            AssByte (info[free], SIZE(elem)); INC (free);
         END;
         INC (s^.anz);
      END;
   ELSE
      Error (102)
   END;
   IF DEBUG THEN Leaving ('Push                     ') END;
END Push;

PROCEDURE Pop (VAR s: Stack; VAR elem: ARRAY OF BYTE);
(*----------------------------------------------------------------------*
 * Pop holt ein Element von einem Stack und verkleinert den Stack.      *
 * Falls Grö₧e des Stackelements ungleich des übergebenen element's,    *
 * wird die Fehlerroutine aufgerufen.                                   *
 *----------------------------------------------------------------------*)
VAR i,
    length : CARDINAL;
    p      : SegmentList;

BEGIN
   IF DEBUG THEN Into ('Pop                      ') END;
   IF s<>NIL THEN (* Confuse the customer        *)
   (* Schöne Grü₧e vom Compiler:                 *)
   (* Pop läuft nur so fehlerfrei, andernfalls   *)
   (* hat der Record s falsche Werte.  (!??!)    *)
      Dummy ('Anzahl', s^.anz);
   END;
   IF s=NIL THEN Error (102)
   ELSIF s^.anz=0 THEN Error (104)
   ELSE
      AssCard (length, s^.top^.info[s^.top^.free-1] );
      IF (length <> SIZE(elem)) THEN Error (105)
      ELSE
         WITH s^.top^ DO
            free  :=free-length-1;
            FOR i:=0 TO HIGH (elem) DO
               elem[i]:=info[free+i]
            END;
            DEC (s^.anz);
            IF free=0 THEN
               p     :=s^.top;
               s^.top:=before;
               DISPOSE (p);
            END;
         END;
      END;
   END;
   IF DEBUG THEN Leaving ('Pop                      ') END;
END Pop;


PROCEDURE TopOfStack (VAR s: Stack; VAR elem: ARRAY OF BYTE);
(*----------------------------------------------------------------------*
 * PopOfStack holt ein Element vom Stack, ohne diesen zu verkleinern.   *
 * Typenkompatibilität wird wie bei Pop geprüft.                        *
 *----------------------------------------------------------------------*)
BEGIN
   IF DEBUG THEN Into ('TopOfStack') END;
   Pop (s,elem);
   Push(s,elem);
   IF DEBUG THEN Leaving ('TopOfStack') END;
END TopOfStack;


BEGIN
END StackHandler.