home *** CD-ROM | disk | FTP | other *** search
/ Dream 44 / Amiga_Dream_44.iso / RiscPc / programmation / scm4e2.arc / !Scm / slib / hash < prev    next >
Text File  |  1994-05-23  |  4KB  |  152 lines
  1. ; "hash.scm", hashing functions 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. (define (hash:hash-char-ci char n)
  21.   (modulo (char->integer (char-downcase char)) n))
  22.  
  23. (define hash:hash-char hash:hash-char-ci)
  24.  
  25. (define (hash:hash-symbol sym n)
  26.   (hash:hash-string (symbol->string sym) n))
  27.  
  28. ;;; This can overflow on implemenatations where inexacts have a larger
  29. ;;; range than exact integers.
  30. (define hash:hash-number
  31.   (if (provided? 'inexact)
  32.       (lambda (num n)
  33.     (if (integer? num)
  34.         (modulo (inexact->exact num) n)
  35.         (hash:hash-string-ci (number->string (exact->inexact num)) n)))
  36.       (lambda (num n)
  37.     (if (integer? num)
  38.         (modulo num n)
  39.         (hash:hash-string-ci (number->string num) n)))))
  40.  
  41. (define (hash:hash-string-ci str n)
  42.   (let ((len (string-length str)))
  43.     (if (> len 5)
  44.     (let loop ((h (modulo 264 n)) (i 5))
  45.       (if (positive? i)
  46.           (loop (modulo (+ (* h 256)
  47.                    (char->integer
  48.                 (char-downcase
  49.                  (string-ref str (modulo h len)))))
  50.                 n)
  51.             (- i 1))
  52.           h))
  53.     (let loop ((h 0) (i (- len 1)))
  54.       (if (>= i 0)
  55.           (loop (modulo (+ (* h 256)
  56.                    (char->integer
  57.                 (char-downcase (string-ref str i))))
  58.                 n)
  59.             (- i 1))
  60.           h)))))
  61.  
  62. (define hash:hash-string hash:hash-string-ci)
  63.  
  64. (define (hash:hash obj n)
  65.   (let hs ((d 10) (obj obj))
  66.     (cond
  67.      ((number? obj)      (hash:hash-number obj n))
  68.      ((char? obj)        (modulo (char->integer (char-downcase obj)) n))
  69.      ((symbol? obj)      (hash:hash-symbol obj n))
  70.      ((string? obj)      (hash:hash-string obj n))
  71.      ((vector? obj)
  72.       (let ((len (vector-length obj)))
  73.     (if (> len 5)
  74.         (let lp ((h 1) (i (quotient d 2)))
  75.           (if (positive? i)
  76.           (lp (modulo (+ (* h 256)
  77.                  (hs 2 (vector-ref obj (modulo h len))))
  78.                   n)
  79.               (- i 1))
  80.           h))
  81.         (let loop ((h (- n 1)) (i (- len 1)))
  82.           (if (>= i 0)
  83.           (loop (modulo (+ (* h 256) (hs (quotient d len)
  84.                          (vector-ref obj i)))
  85.                 n)
  86.             (- i 1))
  87.           h)))))
  88.      ((pair? obj)
  89.       (if (positive? d) (modulo (+ (hs (quotient d 2) (car obj))
  90.                    (hs (quotient d 2) (cdr obj)))
  91.                 n)
  92.       1))
  93.      (else
  94.       (modulo
  95.        (cond
  96.     ((null? obj)        256)
  97.     ((boolean? obj)     (if obj 257 258))
  98.     ((eof-object? obj)  259)
  99.     ((input-port? obj)  260)
  100.     ((output-port? obj) 261)
  101.     ((procedure? obj)   262)
  102.     ((and (provided? 'RECORD) (record? obj))
  103.      (let* ((rtd (record-type-descriptor obj))
  104.         (fns (record-type-field-names rtd))
  105.         (len (length fns)))
  106.        (if (> len 5)
  107.            (let lp ((h (modulo 266 n)) (i (quotient d 2)))
  108.          (if (positive? i)
  109.              (lp (modulo
  110.               (+ (* h 256)
  111.                  (hs 2 ((record-accessor
  112.                      rtd (list-ref fns (modulo h len)))
  113.                     obj)))
  114.               n)
  115.              (- i 1))
  116.              h))
  117.            (let loop ((h (- n 1)) (i (- len 1)))
  118.          (if (>= i 0)
  119.              (loop (modulo
  120.                 (+ (* h 256)
  121.                    (hs (quotient d len)
  122.                    ((record-accessor
  123.                      rtd (list-ref fns (modulo h len)))
  124.                     obj)))
  125.                 n)
  126.                (- i 1))
  127.              h)))))
  128.     (else               263))
  129.        n)))))
  130.  
  131. (define hash hash:hash)
  132. (define hashv hash:hash)
  133.  
  134. ;;; Object-hash is somewhat expensive on copying GC systems (like
  135. ;;; PC-Scheme and MITScheme).  We use it only on strings, pairs,
  136. ;;; vectors, and records.  This also allows us to use it for both
  137. ;;; hashq and hashv.
  138.  
  139. (if (provided? 'object-hash)
  140.     (set! hashv
  141.       (if (provided? 'record)
  142.           (lambda (obj k)
  143.         (if (or (string? obj) (pair? obj) (vector? obj) (record? obj))
  144.             (modulo (object-hash obj) k)
  145.             (hash:hash obj k)))
  146.           (lambda (obj k)
  147.         (if (or (string? obj) (pair? obj) (vector? obj))
  148.             (modulo (object-hash obj) k)
  149.             (hash:hash obj k))))))
  150.  
  151. (define hashq hashv)
  152.