lang/m2/test/Wirth/TableHandl.mod

   1 IMPLEMENTATION MODULE TableHandler;
   2
   3   FROM InOut    IMPORT  Write, WriteLn, WriteInt;
   4   FROM Storage  IMPORT  Allocate;
   5
   6   CONST TableLength = 3000;
   7
   8   TYPE
   9         TreePtr = POINTER TO Word;
  10         ListPtr = POINTER TO Item;
  11         Item = RECORD
  12                 num: INTEGER;
  13                 next: ListPtr
  14                END;
  15         Word = RECORD
  16                 key: CARDINAL;  (* table index *)
  17                 first: ListPtr; (* list head *)
  18                 left, right: TreePtr
  19                END;
  20         Table = TreePtr;
  21
  22   VAR
  23         id: ARRAY [0..WordLength] OF CHAR;
  24         ascinx: CARDINAL;
  25         asc: ARRAY [0..TableLength-1] OF CHAR;
  26
  27   PROCEDURE InitTable(VAR t: Table);
  28   BEGIN
  29         Allocate(t, SIZE(Word));
  30         t^.right := NIL
  31   END InitTable;
  32
  33   PROCEDURE Search(p: TreePtr): TreePtr;
  34   (* search node with name equal to id
  35   *)
  36     TYPE        Relation = (less, equal, greater);
  37     VAR         q: TreePtr;
  38                 r: Relation;
  39                 i: CARDINAL;
  40
  41     PROCEDURE rel(k: CARDINAL): Relation;
  42     (* compare id with asc[k]
  43     *)
  44       VAR       i: CARDINAL;
  45                 R: Relation;
  46                 x,y: CHAR;
  47     BEGIN
  48         i := 0;
  49         R := equal;
  50         LOOP
  51             x := id[i];
  52             y := asc[k];
  53             IF CAP(x) # CAP(y) THEN EXIT END;
  54             IF x <= " " THEN RETURN R END;
  55             IF x < y THEN R := less ELSIF x > y THEN R := greater END;
  56             i := i+1;
  57             k := k+1;
  58         END;
  59         IF CAP(x) > CAP(y) THEN RETURN greater ELSE RETURN less END
  60     END rel;
  61
  62   BEGIN (* Search *)
  63         q := p^.right;
  64         r := greater;
  65         WHILE q # NIL DO
  66             p := q;
  67             r := rel(p^.key);
  68             IF r = equal THEN RETURN p
  69             ELSIF r = less THEN q := p^.left
  70             ELSE q := p^.right
  71             END
  72         END;
  73         Allocate(q, SIZE(Word));        (* not found, hence insert *)
  74         IF q # NIL THEN
  75             WITH q^ DO
  76                 key := ascinx;
  77                 first := NIL;
  78                 left := NIL;
  79                 right := NIL
  80             END;
  81             IF r = less THEN p^.left := q ELSE p^.right := q END;
  82             i := 0;     (* copy identifier into asc table *)
  83             WHILE id[i] > " " DO
  84                 IF ascinx = TableLength THEN
  85                     asc[ascinx] := " ";
  86                     id[i] := " ";
  87                     overflow := 1
  88                 ELSE
  89                     asc[ascinx] := id[i];
  90                     ascinx := ascinx + 1;
  91                     i := i + 1
  92                 END
  93             END;
  94             asc[ascinx] := " ";
  95             ascinx := ascinx + 1;
  96         END;
  97         RETURN q;
  98   END Search;
  99
 100   PROCEDURE Record(t: Table; VAR x: ARRAY OF CHAR; n: INTEGER);
 101     VAR p: TreePtr;
 102         q: ListPtr;
 103         i: CARDINAL;
 104   BEGIN
 105         i := 0;
 106         REPEAT
 107             id[i] := x[i];
 108             i := i + 1
 109         UNTIL (id[i-1] = " ") OR (i = WordLength);
 110         p := Search(t);
 111         IF p = NIL THEN
 112             overflow := 2
 113         ELSE
 114             Allocate(q, SIZE(Item));
 115             IF q = NIL THEN
 116                 overflow := 3;
 117             ELSE
 118                 q^.num := n;
 119                 q^.next := p^.first;
 120                 p^.first := q
 121             END
 122         END
 123   END Record;
 124
 125   PROCEDURE Tabulate(t: Table);
 126
 127     PROCEDURE PrintItem(p: TreePtr);
 128       CONST     L = 6;
 129                 N = (LineWidth - WordLength) DIV L;
 130       VAR       ch: CHAR;
 131                 i, k: CARDINAL;
 132                 q: ListPtr;
 133     BEGIN
 134         i := WordLength + 1;
 135         k := p^.key;
 136         REPEAT
 137             ch := asc[k];
 138             i := i - 1;
 139             k := k + 1;
 140             Write(ch)
 141         UNTIL ch <= " ";
 142         WHILE i > 0 DO
 143             Write(" ");
 144             i := i-1
 145         END;
 146         q := p^.first;
 147         i := N;
 148         WHILE q # NIL DO
 149             IF i = 0 THEN
 150                 WriteLn;
 151                 i := WordLength+1;
 152                 REPEAT
 153                     Write(" ");
 154                     i := i-1
 155                 UNTIL i = 0;
 156                 i := N
 157             END;
 158             WriteInt(q^.num, L);
 159             q := q^.next;
 160             i := i - 1
 161         END;
 162         WriteLn
 163     END PrintItem;
 164
 165     PROCEDURE TraverseTree(p: TreePtr);
 166     BEGIN
 167         IF p # NIL THEN
 168             TraverseTree(p^.left);
 169             PrintItem(p);
 170             TraverseTree(p^.right)
 171         END
 172     END TraverseTree;
 173
 174   BEGIN (* Tabulate *)
 175         WriteLn;
 176         TraverseTree(t^.right)
 177   END Tabulate;
 178
 179 BEGIN
 180         ascinx := 0;
 181         id[WordLength] := " ";
 182         overflow := 0
 183 END TableHandler.