gcc/m2/mc/nameKey.mod

   1 (* nameKey.mod provides a dynamic binary tree name to key.
   2
   3 Copyright (C) 2015-2022 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 nameKey ;
  23
  24
  25 FROM SYSTEM IMPORT ADR ;
  26 FROM Storage IMPORT ALLOCATE, DEALLOCATE ;
  27 FROM Indexing IMPORT Index, InitIndex, GetIndice, PutIndice, InBounds ;
  28 FROM StrIO IMPORT WriteString, WriteLn ;
  29 FROM StdIO IMPORT Write ;
  30 FROM NumberIO IMPORT WriteCard ;
  31 FROM StrLib IMPORT StrLen ;
  32 FROM libc IMPORT strlen ;
  33 FROM ASCII IMPORT nul ;
  34
  35
  36 TYPE
  37    ptrToChar  = POINTER TO CHAR ;
  38
  39    nameNode   = POINTER TO RECORD
  40                    data : ptrToChar ;
  41                    key  : Name ;
  42                    left,
  43                    right: nameNode ;
  44                 END ;
  45
  46    comparison = (less, equal, greater) ;
  47
  48 VAR
  49    binaryTree: nameNode ;
  50    keyIndex  : Index ;
  51    lastIndice: CARDINAL ;
  52
  53
  54 (*
  55    getKey - returns the name, a, of the key, Key.
  56 *)
  57
  58 PROCEDURE getKey (key: Name; VAR a: ARRAY OF CHAR) ;
  59 VAR
  60    p       : ptrToChar ;
  61    i, higha: CARDINAL ;
  62 BEGIN
  63    p := keyToCharStar (key) ;
  64    i := 0 ;
  65    higha := HIGH (a) ;
  66    WHILE (p#NIL) AND (i<=higha) AND (p^#nul) DO
  67       a[i] := p^ ;
  68       INC (p) ;
  69       INC (i)
  70    END ;
  71    IF i<=higha
  72    THEN
  73       a[i] := nul
  74    END
  75 END getKey ;
  76
  77
  78 (*
  79    isKey - returns TRUE if string, a, is currently a key.
  80            We dont use the Compare function, we inline it and avoid
  81            converting, a, into a String, for speed.
  82 *)
  83
  84 PROCEDURE isKey (a: ARRAY OF CHAR) : BOOLEAN ;
  85 VAR
  86    child : nameNode ;
  87    p     : ptrToChar ;
  88    i,
  89    higha : CARDINAL ;
  90 BEGIN
  91    (* firstly set up the initial values of child, using sentinal node *)
  92    child := binaryTree^.left ;
  93    IF child#NIL
  94    THEN
  95       REPEAT
  96          i := 0 ;
  97          higha := HIGH (a) ;
  98          p := keyToCharStar (child^.key) ;
  99          WHILE (i<=higha) AND (a[i]#nul) DO
 100             IF a[i]<p^
 101             THEN
 102                child := child^.left ;
 103                i := higha
 104             ELSIF a[i]>p^
 105             THEN
 106                child := child^.right ;
 107                i := higha
 108             ELSE
 109                IF (a[i]=nul) OR (i=higha)
 110                THEN
 111                   IF p^=nul
 112                   THEN
 113                      RETURN TRUE
 114                   ELSE
 115                      child := child^.left
 116                   END
 117                END ;
 118                INC (p)
 119             END ;
 120             INC (i)
 121          END ;
 122       UNTIL child=NIL
 123    END ;
 124    RETURN FALSE
 125 END isKey ;
 126
 127
 128 (*
 129    doMakeKey - finds the name, n, in the tree or else create a name.
 130                If a name is found then the string, n, is deallocated.
 131 *)
 132
 133 PROCEDURE doMakeKey (n: ptrToChar; higha: CARDINAL) : Name ;
 134 VAR
 135    result: comparison ;
 136    father,
 137    child : nameNode ;
 138    k     : Name ;
 139 BEGIN
 140    result := findNodeAndParentInTree (n, child, father) ;
 141    IF child=NIL
 142    THEN
 143       IF result=less
 144       THEN
 145          NEW (child) ;
 146          father^.left := child
 147       ELSIF result=greater
 148       THEN
 149          NEW (child) ;
 150          father^.right := child
 151       END ;
 152       WITH child^ DO
 153          right := NIL ;
 154          left := NIL ;
 155          INC (lastIndice) ;
 156          key := lastIndice ;
 157          data := n ;
 158          PutIndice (keyIndex, key, n)
 159       END ;
 160       k := lastIndice
 161    ELSE
 162       DEALLOCATE (n, higha+1) ;
 163       k := child^.key
 164    END ;
 165    RETURN k
 166 END doMakeKey ;
 167
 168
 169 (*
 170    makeKey - returns the Key of the symbol, a. If a is not in the
 171              name table then it is added, otherwise the Key of a is returned
 172              directly. Note that the name table has no scope - it merely
 173              presents a more convienient way of expressing strings. By a Key.
 174 *)
 175
 176 PROCEDURE makeKey (a: ARRAY OF CHAR) : Name ;
 177 VAR
 178    n, p  : ptrToChar ;
 179    i,
 180    higha : CARDINAL ;
 181 BEGIN
 182    higha := StrLen(a) ;
 183    ALLOCATE (p, higha+1) ;
 184    IF p=NIL
 185    THEN
 186       HALT      (* out of memory error *)
 187    ELSE
 188       n := p ;
 189       i := 0 ;
 190       WHILE i<higha DO
 191          p^ := a[i] ;
 192          INC(i) ;
 193          INC(p)
 194       END ;
 195       p^ := nul ;
 196
 197       RETURN doMakeKey (n, higha)
 198    END
 199 END makeKey ;
 200
 201
 202 (*
 203    makekey - returns the Key of the symbol, a. If a is not in the
 204              name table then it is added, otherwise the Key of a is returned
 205              directly. Note that the name table has no scope - it merely
 206              presents a more convienient way of expressing strings. By a Key.
 207              These keys last for the duration of compilation.
 208 *)
 209
 210 PROCEDURE makekey (a: ADDRESS) : Name ;
 211 VAR
 212    n,
 213    p, pa : ptrToChar ;
 214    i,
 215    higha : CARDINAL ;
 216 BEGIN
 217    IF a=NIL
 218    THEN
 219       RETURN NulName
 220    ELSE
 221       higha := strlen (a) ;
 222       ALLOCATE (p, higha+1) ;
 223       IF p=NIL
 224       THEN
 225          HALT      (* out of memory error *)
 226       ELSE
 227          n  := p ;
 228          pa := a ;
 229          i  := 0 ;
 230          WHILE i<higha DO
 231             p^ := pa^ ;
 232             INC (i) ;
 233             INC (p) ;
 234             INC (pa)
 235          END ;
 236          p^ := nul ;
 237
 238          RETURN doMakeKey (n, higha)
 239       END
 240    END
 241 END makekey ;
 242
 243
 244 (*
 245    lengthKey - returns the StrLen of Key.
 246 *)
 247
 248 PROCEDURE lengthKey (key: Name) : CARDINAL ;
 249 VAR
 250    i: CARDINAL ;
 251    p: ptrToChar ;
 252 BEGIN
 253    p := keyToCharStar (key) ;
 254    i := 0 ;
 255    WHILE p^#nul DO
 256       INC (i) ;
 257       INC (p)
 258    END ;
 259    RETURN i
 260 END lengthKey ;
 261
 262
 263 (*
 264    compare - return the result of Names[i] with Names[j]
 265 *)
 266
 267 PROCEDURE compare (pi: ptrToChar; j: Name) : comparison ;
 268 VAR
 269    pj: ptrToChar ;
 270    c1, c2: CHAR ;
 271 BEGIN
 272    pj := keyToCharStar(j) ;
 273    c1 := pi^ ;
 274    c2 := pj^ ;
 275    WHILE (c1#nul) OR (c2#nul) DO
 276       IF c1<c2
 277       THEN
 278          RETURN less
 279       ELSIF c1>c2
 280       THEN
 281          RETURN greater
 282       ELSE
 283          INC (pi) ;
 284          INC (pj) ;
 285          c1 := pi^ ;
 286          c2 := pj^
 287       END
 288    END ;
 289    RETURN equal
 290 END compare ;
 291
 292
 293 (*
 294    findNodeAndParentInTree - search BinaryTree for a name.
 295                              If this name is found in the BinaryTree then
 296                              child is set to this name and father is set to the node above.
 297                              A comparison is returned to assist adding entries into this tree.
 298 *)
 299
 300 PROCEDURE findNodeAndParentInTree (n: ptrToChar; VAR child, father: nameNode) : comparison ;
 301 VAR
 302    result: comparison ;
 303 BEGIN
 304    (* firstly set up the initial values of child and father, using sentinal node *)
 305    father := binaryTree ;
 306    child := binaryTree^.left ;
 307    IF child=NIL
 308    THEN
 309       RETURN less
 310    ELSE
 311       REPEAT
 312          result := compare (n, child^.key) ;
 313          IF result=less
 314          THEN
 315             father := child ;
 316             child := child^.left
 317          ELSIF result=greater
 318          THEN
 319             father := child ;
 320             child := child^.right
 321          END
 322       UNTIL (child=NIL) OR (result=equal) ;
 323       RETURN result
 324    END
 325 END findNodeAndParentInTree ;
 326
 327
 328 (*
 329    isSameExcludingCase - returns TRUE if key1 and key2 are
 330                          the same. It is case insensitive.
 331                          This function deliberately inlines CAP for speed.
 332 *)
 333
 334 PROCEDURE isSameExcludingCase (key1, key2: Name) : BOOLEAN ;
 335 VAR
 336    pi, pj: ptrToChar ;
 337    c1, c2: CHAR ;
 338 BEGIN
 339    IF key1=key2
 340    THEN
 341       RETURN TRUE
 342    ELSE
 343       pi := keyToCharStar(key1) ;
 344       pj := keyToCharStar(key2) ;
 345       c1 := pi^ ;
 346       c2 := pj^ ;
 347       WHILE (c1#nul) AND (c2#nul) DO
 348          IF (c1=c2) OR
 349             (((c1>='A') AND (c1<='Z')) AND (c2=CHR(ORD(c1)-ORD('A')+ORD('a')))) OR
 350             (((c2>='A') AND (c2<='Z')) AND (c1=CHR(ORD(c2)-ORD('A')+ORD('a'))))
 351          THEN
 352             INC (pi) ;
 353             INC (pj) ;
 354             c1 := pi^ ;
 355             c2 := pj^
 356          ELSE
 357             (* difference found *)
 358             RETURN FALSE
 359          END
 360       END ;
 361       RETURN c1=c2
 362    END
 363 END isSameExcludingCase ;
 364
 365
 366 (*
 367    keyToCharStar - returns the C char * string equivalent for, key.
 368 *)
 369
 370 PROCEDURE keyToCharStar (key: Name) : ADDRESS ;
 371 BEGIN
 372    IF (key=NulName) OR (NOT InBounds (keyIndex, key))
 373    THEN
 374       RETURN NIL
 375    ELSE
 376       RETURN GetIndice (keyIndex, key)
 377    END
 378 END keyToCharStar ;
 379
 380
 381 PROCEDURE writeKey (key: Name) ;
 382 VAR
 383    s: ptrToChar ;
 384 BEGIN
 385    s := keyToCharStar (key) ;
 386    WHILE (s#NIL) AND (s^#nul) DO
 387       Write (s^) ;
 388       INC (s)
 389    END
 390 END writeKey ;
 391
 392
 393 BEGIN
 394    lastIndice := 0 ;
 395    keyIndex := InitIndex(1) ;
 396    NEW (binaryTree) ;
 397    binaryTree^.left := NIL
 398 END nameKey.