Turbo Toolbox/Turbo_Toolbox.iso/1988/10_11/symbol.mod

Modula Implementation | 1988-06-30 | 6.0 KB | 195 lines

(*-------------------------------------------------------*)
(*                      SYMBOL.MOD                       *)
(*       (C) 1988 Frank F. Wachtmeister & TOOLBOX        *)

IMPLEMENTATION MODULE Symbol;

FROM Streams IMPORT Stream;
FROM Strings IMPORT Assign, Concat, Compare,
                    CompareResults;
FROM Storage IMPORT ALLOCATE, DEALLOCATE;
FROM SYSTEM  IMPORT ADDRESS;
FROM TextIO  IMPORT WRiteString, WRiteLn, WRiteCard,
                    REadString;

(* TreeOperation ermöglicht eine Operation Op, angewandt
   auf jedes Blatt des BAUMes. Siehe PASCAL 3/88, S.62
   Die Durchlaufrichtung des Binärbaumes kann von der
   übergebenen Prozedur her modifiziert werden. Laufzeit !
   ==> Zwei Modi: All-Modus --> Lexikalische Suche.
       Kontrollierte Modus: Die Wurzel wird über die
       Prozedur Op analysiert, danach Entscheidung, ob nur
       der rechte oder  linke Teilbaum abgearbeitet wird.
   Der Zustand Stop beendet die Rekursion.               *)

TYPE DirectionType = ( Stop, All, Left, Right);
     (* Suchrichtung *)
     TreeOp = PROCEDURE(VAR SymbolTable,
                        VAR DirectionType);

PROCEDURE TreeOperation (    Baum: SymbolTable; Op: TreeOp;
                         VAR dir: DirectionType );
BEGIN
  IF (Baum<>NIL) AND (dir>Stop) THEN
    WITH Baum^ DO
      IF dir < Left THEN
        TreeOperation (links, Op, dir);
        IF dir<>Stop THEN Op (Baum, dir) END;
        IF dir<>Stop THEN TreeOperation(rechts,Op,dir) END;
      ELSE
        Op (Baum, dir);
        IF    dir=Left  THEN TreeOperation(links,Op,dir)
        ELSIF dir=Right THEN TreeOperation(rechts,Op,dir)
        ELSE  (* dir=Stop *) ;
        END
      END
    END (* WITH *)
  END (* IF *)
END TreeOperation;

PROCEDURE Terminate;
VAR s: ARRAY[1..80] OF CHAR;
BEGIN
   WRiteLn(main); WRiteString(main,'Program terminated.');
   WRiteLn(main); WRiteString(main,'Press <RETURN>');
   REadString(main,s); HALT;
END Terminate;

PROCEDURE HeapCheck (a: ADDRESS);
BEGIN
  IF a=NIL THEN
    WRiteString(main,'HEAP zu klein.'); WRiteLn(main);
    Terminate;
  END;
END HeapCheck;

MODULE PRINT;
IMPORT WRiteString, WRiteCard,WRiteLn, main, TreeOperation,
       DirectionType, SymbolTable, String, HeapCheck;
EXPORT PrintTree;
(* PrintTree druckt den Inhalt eines BAUMes in alpha-
   betischer Reihenfolge. MASTER: PrintTree.
   SLAVE : PrintLeave.                                  *)
PROCEDURE PrintLeave(VAR b: SymbolTable;
                     VAR dir:DirectionType);
BEGIN
  WITH b^ DO
    WRiteCard(main,rc,4); WRiteString (main,': ');
    WRiteString(main,tx); WRiteLn(main);
  END;
END PrintLeave;

PROCEDURE PrintTree ( Baum: SymbolTable );
VAR dir: DirectionType;
BEGIN
  dir:=All;TreeOperation(Baum,PrintLeave,dir);
END PrintTree;
END PRINT;


MODULE SEARCH;
(* SEARCH umfaßt Prozeduren zur Suche in Binärbäumen.
   Search und SearchRC dienen zur Parameterübergabe
   zwischen "MASTER"- und "SLAVE"-Prozedurpaaren.        *)

IMPORT Compare, CompareResults, Assign, SymbolTable,
       DirectionType, String, RCTyp, TreeOperation,
       NotFound, HeapCheck, ALLOCATE, DEALLOCATE;
EXPORT SearchRC, SearchTxt, AddSymbol;
VAR search: String;
    searchRC: CARDINAL;

(* SearchRC sucht nach TXT in einer Symboltabelle s und
   gibt den zugehörigen Relativcode zurück.
   Die SLAVE-Prozedur steuert die Suche im Baum.        *)

PROCEDURE FindRC(VAR b:SymbolTable; VAR dir:DirectionType);
VAR c: CompareResults;
BEGIN
  c:=Compare (search, b^.tx);
  CASE c OF
    Less   : dir:=Left; (* Durchsuche linken Teilbaum *)
  | Equal  :
      dir     := Stop;  (* Beendet Suche *)
      searchRC:=b^.rc;
  | Greater: dir:=Right;(* Durchsuche rechten Teilbaum*)
  END;
END FindRC;

PROCEDURE SearchRC ( VAR s: SymbolTable;
                     VAR txt: ARRAY OF CHAR ): RCTyp;
VAR dir: DirectionType;
BEGIN
   searchRC:=NotFound; dir:=Left; Assign (search,txt);
   TreeOperation (s, FindRC, dir);
   RETURN (searchRC);
END SearchRC;

(* SearchTxt sucht nach Relativcode rc in Symboltabelle s
   und gibt den zugehörigen Textstring txt zurück.       *)

PROCEDURE FindTxt (VAR b: SymbolTable;
                   VAR dir: DirectionType);
BEGIN
  IF b^.rc=searchRC THEN
    Assign (search, b^.tx); dir:=Stop;
  END;
END FindTxt;

PROCEDURE SearchTxt( VAR s: SymbolTable;
                     VAR rc:RCTyp; VAR txt: ARRAY OF CHAR);
VAR dir: DirectionType;
BEGIN
   Assign (search,''); dir:=All; searchRC:=rc;
   TreeOperation (s, FindTxt, dir); Assign (txt, search);
END SearchTxt;

(* AddSymbol fügt einen NAMEn mit Relativcode rc in
   Symboltabelle s ein.                               *)
PROCEDURE CompareAndAdd (VAR b: SymbolTable;
                         VAR dir: DirectionType);
VAR c: CompareResults;
BEGIN
  c:=Compare (search, b^.tx);
  CASE c OF
    Less :
      IF b^.links=NIL THEN (* Erzeuge "linken" Sohn *)
        NEW (b^.links); HeapCheck (b^.links); dir:=Stop;
        WITH b^.links^ DO
          rc:=searchRC; Assign (tx,search);
          links:=NIL; rechts:=NIL;
        END
      ELSE dir:=Left END; (* Durchsuche linken Teilbaum *)
    | Equal  :
      dir  := Stop;      (* Beendet Suche *)
      b^.rc:= searchRC;  (* Überschreibe Relativcode *)
    | Greater:
      IF b^.rechts=NIL THEN (* Erzeuge "rechten" Sohn *)
        NEW (b^.rechts); HeapCheck(b^.rechts); dir:=Stop;
        WITH b^.rechts^ DO
          rc:=searchRC; Assign(tx,search);
          links:=NIL; rechts:=NIL;
        END
      ELSE dir:=Right END; (* Suche im rechten Teilbaum *)
   END;
END CompareAndAdd;

PROCEDURE AddSymbol(VAR s: SymbolTable;
                    VAR name: ARRAY OF CHAR; r:RCTyp);
VAR dir: DirectionType;
BEGIN
  IF s=NIL THEN
    NEW (s); HeapCheck (s);
    WITH s^ DO
      rc:=r; Assign (tx,name); links:=NIL; rechts:=NIL;
    END
  ELSE
    Assign (search, name); dir:=Left; searchRC:=r;
    TreeOperation (s, CompareAndAdd, dir);
  END;
END AddSymbol;

END SEARCH;

END Symbol.