home *** CD-ROM | disk | FTP | other *** search
/ Dream 44 / Amiga_Dream_44.iso / RiscPc / programmation / scm4e2.arc / !Scm / slib / hashtab < prev    next >
Text File  |  1994-05-23  |  2KB  |  80 lines
  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))))
  80.