summaryrefslogtreecommitdiffstats
path: root/hash.scm
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:25 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:25 -0800
commit8ffbc2df0fde83082610149d24e594c1cd879f4a (patch)
treea2be9aad5101c5e450ad141d15c514bc9c2a2963 /hash.scm
downloadslib-8ffbc2df0fde83082610149d24e594c1cd879f4a.tar.gz
slib-8ffbc2df0fde83082610149d24e594c1cd879f4a.zip
Import Upstream version 2a6upstream/2a6
Diffstat (limited to 'hash.scm')
-rw-r--r--hash.scm153
1 files changed, 153 insertions, 0 deletions
diff --git a/hash.scm b/hash.scm
new file mode 100644
index 0000000..ab02138
--- /dev/null
+++ b/hash.scm
@@ -0,0 +1,153 @@
+; "hash.scm", hashing functions for Scheme.
+; Copyright (c) 1992, 1993, 1995 Aubrey Jaffer
+;
+;Permission to copy this software, to redistribute it, and to use it
+;for any purpose is granted, subject to the following restrictions and
+;understandings.
+;
+;1. Any copy made of this software must include this copyright notice
+;in full.
+;
+;2. I have made no warrantee or representation that the operation of
+;this software will be error-free, and I am under no obligation to
+;provide any services, by way of maintenance, update, or otherwise.
+;
+;3. In conjunction with products arising from the use of this
+;material, there shall be no use of my name in any advertising,
+;promotional, or sales literature without prior written consent in
+;each case.
+
+(define (hash:hash-char-ci char n)
+ (modulo (char->integer (char-downcase char)) n))
+
+(define hash:hash-char hash:hash-char-ci)
+
+(define (hash:hash-symbol sym n)
+ (hash:hash-string (symbol->string sym) n))
+
+;;; This can overflow on implemenatations where inexacts have a larger
+;;; range than exact integers.
+(define hash:hash-number
+ (if (provided? 'inexact)
+ (lambda (num n)
+ (if (integer? num)
+ (modulo (if (exact? num) num (inexact->exact num)) n)
+ (hash:hash-string-ci
+ (number->string (if (exact? num) (exact->inexact num) num))
+ n)))
+ (lambda (num n)
+ (if (integer? num)
+ (modulo num n)
+ (hash:hash-string-ci (number->string num) n)))))
+
+(define (hash:hash-string-ci str n)
+ (let ((len (string-length str)))
+ (if (> len 5)
+ (let loop ((h (modulo 264 n)) (i 5))
+ (if (positive? i)
+ (loop (modulo (+ (* h 256)
+ (char->integer
+ (char-downcase
+ (string-ref str (modulo h len)))))
+ n)
+ (- i 1))
+ h))
+ (let loop ((h 0) (i (- len 1)))
+ (if (>= i 0)
+ (loop (modulo (+ (* h 256)
+ (char->integer
+ (char-downcase (string-ref str i))))
+ n)
+ (- i 1))
+ h)))))
+
+(define hash:hash-string hash:hash-string-ci)
+
+(define (hash:hash obj n)
+ (let hs ((d 10) (obj obj))
+ (cond
+ ((number? obj) (hash:hash-number obj n))
+ ((char? obj) (modulo (char->integer (char-downcase obj)) n))
+ ((symbol? obj) (hash:hash-symbol obj n))
+ ((string? obj) (hash:hash-string obj n))
+ ((vector? obj)
+ (let ((len (vector-length obj)))
+ (if (> len 5)
+ (let lp ((h 1) (i (quotient d 2)))
+ (if (positive? i)
+ (lp (modulo (+ (* h 256)
+ (hs 2 (vector-ref obj (modulo h len))))
+ n)
+ (- i 1))
+ h))
+ (let loop ((h (- n 1)) (i (- len 1)))
+ (if (>= i 0)
+ (loop (modulo (+ (* h 256) (hs (quotient d len)
+ (vector-ref obj i)))
+ n)
+ (- i 1))
+ h)))))
+ ((pair? obj)
+ (if (positive? d) (modulo (+ (hs (quotient d 2) (car obj))
+ (hs (quotient d 2) (cdr obj)))
+ n)
+ 1))
+ (else
+ (modulo
+ (cond
+ ((null? obj) 256)
+ ((boolean? obj) (if obj 257 258))
+ ((eof-object? obj) 259)
+ ((input-port? obj) 260)
+ ((output-port? obj) 261)
+ ((procedure? obj) 262)
+ ((and (provided? 'RECORD) (record? obj))
+ (let* ((rtd (record-type-descriptor obj))
+ (fns (record-type-field-names rtd))
+ (len (length fns)))
+ (if (> len 5)
+ (let lp ((h (modulo 266 n)) (i (quotient d 2)))
+ (if (positive? i)
+ (lp (modulo
+ (+ (* h 256)
+ (hs 2 ((record-accessor
+ rtd (list-ref fns (modulo h len)))
+ obj)))
+ n)
+ (- i 1))
+ h))
+ (let loop ((h (- n 1)) (i (- len 1)))
+ (if (>= i 0)
+ (loop (modulo
+ (+ (* h 256)
+ (hs (quotient d len)
+ ((record-accessor
+ rtd (list-ref fns (modulo h len)))
+ obj)))
+ n)
+ (- i 1))
+ h)))))
+ (else 263))
+ n)))))
+
+(define hash hash:hash)
+(define hashv hash:hash)
+
+;;; Object-hash is somewhat expensive on copying GC systems (like
+;;; PC-Scheme and MITScheme). We use it only on strings, pairs,
+;;; vectors, and records. This also allows us to use it for both
+;;; hashq and hashv.
+
+(if (provided? 'object-hash)
+ (set! hashv
+ (if (provided? 'record)
+ (lambda (obj k)
+ (if (or (string? obj) (pair? obj) (vector? obj) (record? obj))
+ (modulo (object-hash obj) k)
+ (hash:hash obj k)))
+ (lambda (obj k)
+ (if (or (string? obj) (pair? obj) (vector? obj))
+ (modulo (object-hash obj) k)
+ (hash:hash obj k))))))
+
+(define hashq hashv)