gcc/m2/mc/symbolKey.mod

   1 (* symbolKey.mod provides binary tree operations for storing symbols.
   2
   3 Copyright (C) 2015-2023 Free Software Foundation, Inc.
   4 Contributed by Gaius Mulley <gaius@glam.ac.uk>.
   5
   6 This file is part of GNU Modula-2.
   7
   8 GNU Modula-2 is free software; you can redistribute it and/or modify
   9 it under the terms of the GNU General Public License as published by
  10 the Free Software Foundation; either version 3, or (at your option)
  11 any later version.
  12
  13 GNU Modula-2 is distributed in the hope that it will be useful, but
  14 WITHOUT ANY WARRANTY; without even the implied warranty of
  15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  16 General Public License for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with GNU Modula-2; see the file COPYING3.  If not see
  20 <http://www.gnu.org/licenses/>.  *)
  21
  22 IMPLEMENTATION MODULE symbolKey ;
  23
  24
  25 FROM Storage IMPORT ALLOCATE, DEALLOCATE ;
  26 FROM StrIO IMPORT WriteString, WriteLn ;
  27 FROM NumberIO IMPORT WriteCard ;
  28 FROM Debug IMPORT Halt ;
  29
  30 FROM nameKey IMPORT writeKey ;
  31
  32
  33 TYPE
  34    symbolTree = POINTER TO RECORD
  35                    name : Name ;   (* The sorted entity *)
  36                    key  : ADDRESS ;   (* The value entity  *)
  37                    left,
  38                    right: symbolTree ;
  39                 END ;
  40
  41
  42 PROCEDURE initTree () : symbolTree ;
  43 VAR
  44    t: symbolTree ;
  45 BEGIN
  46    NEW (t) ;
  47    WITH t^ DO
  48       left := NIL ;
  49       right := NIL
  50    END ;
  51    RETURN t
  52 END initTree ;
  53
  54
  55 PROCEDURE killTree (VAR t: symbolTree) ;
  56 BEGIN
  57    IF t#NIL
  58    THEN
  59       killTree (t^.left) ;
  60       killTree (t^.right) ;
  61       DISPOSE (t) ;
  62       t := NIL
  63    END
  64 END killTree ;
  65
  66
  67 PROCEDURE getSymKey (t: symbolTree; name: Name) : ADDRESS ;
  68 VAR
  69    father,
  70    child : symbolTree ;
  71 BEGIN
  72    IF t=NIL
  73    THEN
  74       RETURN NulKey
  75    ELSE
  76       findNodeAndParentInTree (t, name, child, father) ;
  77       IF child=NIL
  78       THEN
  79          RETURN NulKey
  80       ELSE
  81          RETURN child^.key
  82       END
  83    END
  84 END getSymKey ;
  85
  86
  87 PROCEDURE putSymKey (t: symbolTree; name: Name; key: ADDRESS) ;
  88 VAR
  89    father,
  90    child : symbolTree ;
  91 BEGIN
  92    findNodeAndParentInTree (t, name, child, father) ;
  93    IF child=NIL
  94    THEN
  95       (* no child found, now is name less than father or greater? *)
  96       IF father=t
  97       THEN
  98          (* empty tree, add it to the left branch of t *)
  99          NEW(child) ;
 100          father^.left := child
 101       ELSE
 102          IF name<father^.name
 103          THEN
 104             NEW (child) ;
 105             father^.left := child
 106          ELSIF name>father^.name
 107          THEN
 108             NEW (child) ;
 109             father^.right := child
 110          END
 111       END ;
 112       WITH child^ DO
 113          right   := NIL ;
 114          left    := NIL
 115       END ;
 116       child^.key  := key ;
 117       child^.name := name
 118    ELSE
 119       Halt ('symbol already stored', __LINE__, __FILE__)
 120    END
 121 END putSymKey ;
 122
 123
 124 (*
 125    delSymKey - deletes an entry in the binary tree.
 126
 127                NB in order for this to work we must ensure that the InitTree sets
 128                both left and right to NIL.
 129 *)
 130
 131 PROCEDURE delSymKey (t: symbolTree; name: Name) ;
 132 VAR
 133    i, child, father: symbolTree ;
 134 BEGIN
 135    findNodeAndParentInTree (t, name, child, father) ;  (* find father and child of the node *)
 136    IF (child#NIL) AND (child^.name=name)
 137    THEN
 138       (* Have found the node to be deleted *)
 139       IF father^.right=child
 140       THEN
 141          (* Node is child and this is greater than the father. *)
 142          (* Greater being on the right.                        *)
 143          (* Connect child^.left onto the father^.right.        *)
 144          (* Connect child^.right onto the end of the right     *)
 145          (* most branch of child^.left.                        *)
 146          IF child^.left#NIL
 147          THEN
 148             (* Scan for right most node of child^.left *)
 149             i := child^.left ;
 150             WHILE i^.right#NIL DO
 151                i := i^.right
 152             END ;
 153             i^.right      := child^.right ;
 154             father^.right := child^.left
 155          ELSE
 156             (* No child^.left node therefore link over child   *)
 157             (* (as in a single linked list) to child^.right    *)
 158             father^.right := child^.right
 159          END ;
 160          DISPOSE (child)
 161       ELSE
 162          (* Assert that father^.left=child will always be true *)
 163          (* Perform exactly the mirror image of the above code *)
 164
 165          (* Connect child^.right onto the father^.left.        *)
 166          (* Connect child^.left onto the end of the left most  *)
 167          (* branch of child^.right                             *)
 168          IF child^.right#NIL
 169          THEN
 170             (* Scan for left most node of child^.right *)
 171             i := child^.right ;
 172             WHILE i^.left#NIL DO
 173                i := i^.left
 174             END ;
 175             i^.left      := child^.left ;
 176             father^.left := child^.right
 177          ELSE
 178             (* No child^.right node therefore link over c      *)
 179             (* (as in a single linked list) to child^.left.    *)
 180             father^.left := child^.left
 181          END ;
 182          DISPOSE (child)
 183       END
 184    ELSE
 185       Halt ('trying to delete a symbol that is not in the tree - the compiler never expects this to occur',
 186             __LINE__, __FILE__)
 187    END
 188 END delSymKey ;
 189
 190
 191 (*
 192    findNodeAndParentInTree - find a node, child, in a binary tree, t, with name equal to n.
 193                              if an entry is found, father is set to the node above child.
 194 *)
 195
 196 PROCEDURE findNodeAndParentInTree (t: symbolTree; n: Name;
 197                                    VAR child, father: symbolTree) ;
 198 BEGIN
 199    (* remember to skip the sentinal value and assign father and child *)
 200    father := t ;
 201    IF t=NIL
 202    THEN
 203       Halt ('parameter t should never be NIL', __LINE__, __FILE__)
 204    END ;
 205    child := t^.left ;
 206    IF child#NIL
 207    THEN
 208       REPEAT
 209          IF n<child^.name
 210          THEN
 211             father := child ;
 212             child := child^.left
 213          ELSIF n>child^.name
 214          THEN
 215             father := child ;
 216             child := child^.right
 217          END
 218       UNTIL (child=NIL) OR (n=child^.name)
 219    END
 220 END findNodeAndParentInTree ;
 221
 222
 223 (*
 224    isEmptyTree - returns true if symbolTree, t, is empty.
 225 *)
 226
 227 PROCEDURE isEmptyTree (t: symbolTree) : BOOLEAN ;
 228 BEGIN
 229    RETURN t^.left=NIL
 230 END isEmptyTree ;
 231
 232
 233 (*
 234    doesTreeContainAny - returns true if symbolTree, t, contains any
 235                         symbols which in turn return true when procedure,
 236                         p, is called with a symbol as its parameter.
 237                         The symbolTree root is empty apart from the field,
 238                         left, hence we need two procedures.
 239 *)
 240
 241 PROCEDURE doesTreeContainAny (t: symbolTree; p: isSymbol) : BOOLEAN ;
 242 BEGIN
 243    RETURN searchForAny (t^.left, p)
 244 END doesTreeContainAny ;
 245
 246
 247 (*
 248    searchForAny - performs the search required for doesTreeContainAny.
 249                   The root node always contains a nul data value,
 250                   therefore we must skip over it.
 251 *)
 252
 253 PROCEDURE searchForAny (t: symbolTree; p: isSymbol) : BOOLEAN ;
 254 BEGIN
 255    IF t=NIL
 256    THEN
 257       RETURN FALSE
 258    ELSE
 259       RETURN p (t^.key) OR
 260              searchForAny (t^.left, p) OR
 261              searchForAny (t^.right, p)
 262    END
 263 END searchForAny ;
 264
 265
 266 (*
 267    foreachNodeDo - for each node in symbolTree, t, a procedure, p,
 268                    is called with the node symbol as its parameter.
 269                    The tree root node only contains a legal left pointer,
 270                    therefore we need two procedures to examine this tree.
 271 *)
 272
 273 PROCEDURE foreachNodeDo (t: symbolTree; p: performOperation) ;
 274 BEGIN
 275    searchAndDo (t^.left, p)
 276 END foreachNodeDo ;
 277
 278
 279 (*
 280    searchAndDo - searches all the nodes in symbolTree, t, and
 281                  calls procedure, p, with a node as its parameter.
 282                  It traverse the tree in order.
 283 *)
 284
 285 PROCEDURE searchAndDo (t: symbolTree; p: performOperation) ;
 286 BEGIN
 287    IF t#NIL
 288    THEN
 289       WITH t^ DO
 290          searchAndDo (right, p) ;
 291          p (key) ;
 292          searchAndDo (left, p)
 293       END
 294    END
 295 END searchAndDo ;
 296
 297
 298 END symbolKey.