module/slib/hashtab.scm

   1 ; "hashtab.scm", hash tables for Scheme.
   2 ; Copyright (c) 1992, 1993 Aubrey Jaffer
   3 ;
   4 ;Permission to copy this software, to redistribute it, and to use it
   5 ;for any purpose is granted, subject to the following restrictions and
   6 ;understandings.
   7 ;
   8 ;1.  Any copy made of this software must include this copyright notice
   9 ;in full.
  10 ;
  11 ;2.  I have made no warrantee or representation that the operation of
  12 ;this software will be error-free, and I am under no obligation to
  13 ;provide any services, by way of maintenance, update, or otherwise.
  14 ;
  15 ;3.  In conjunction with products arising from the use of this
  16 ;material, there shall be no use of my name in any advertising,
  17 ;promotional, or sales literature without prior written consent in
  18 ;each case.
  19
  20 (require 'hash)
  21 (require 'alist)
  22
  23 (define (predicate->hash pred)
  24   (cond ((eq? pred eq?) hashq)
  25         ((eq? pred eqv?) hashv)
  26         ((eq? pred equal?) hash)
  27         ((eq? pred =) hashv)
  28         ((eq? pred char=?) hashv)
  29         ((eq? pred char-ci=?) hashv)
  30         ((eq? pred string=?) hash)
  31         ((eq? pred string-ci=?) hash)
  32         (else (slib:error "unknown predicate for hash" pred))))
  33
  34 (define (make-hash-table k) (make-vector k '()))
  35
  36 (define (predicate->hash-asso pred)
  37   (let ((hashfun (predicate->hash pred))
  38         (asso (predicate->asso pred)))
  39     (lambda (key hashtab)
  40       (asso key
  41             (vector-ref hashtab (hashfun key (vector-length hashtab)))))))
  42
  43 (define (hash-inquirer pred)
  44   (let ((hashfun (predicate->hash pred))
  45         (ainq (alist-inquirer pred)))
  46     (lambda (hashtab key)
  47       (ainq (vector-ref hashtab (hashfun key (vector-length hashtab)))
  48             key))))
  49
  50 (define (hash-associator pred)
  51   (let ((hashfun (predicate->hash pred))
  52         (asso (alist-associator pred)))
  53     (lambda (hashtab key val)
  54       (let* ((num (hashfun key (vector-length hashtab))))
  55         (vector-set! hashtab num
  56                      (asso (vector-ref hashtab num) key val)))
  57       hashtab)))
  58
  59 (define (hash-remover pred)
  60   (let ((hashfun (predicate->hash pred))
  61         (arem (alist-remover pred)))
  62     (lambda (hashtab key)
  63       (let* ((num (hashfun key (vector-length hashtab))))
  64         (vector-set! hashtab num
  65                      (arem (vector-ref hashtab num) key)))
  66       hashtab)))
  67
  68 (define (hash-map proc ht)
  69   (define nht (make-vector (vector-length ht)))
  70   (do ((i (+ -1 (vector-length ht)) (+ -1 i)))
  71       ((negative? i) nht)
  72     (vector-set!
  73      nht i
  74      (alist-map proc (vector-ref ht i)))))
  75
  76 (define (hash-for-each proc ht)
  77   (do ((i (+ -1 (vector-length ht)) (+ -1 i)))
  78       ((negative? i))
  79     (alist-for-each proc (vector-ref ht i))))