~ chicken-core (chicken-5) 799b4b27a557232e6455791bdfd532f950f0fbdb
commit 799b4b27a557232e6455791bdfd532f950f0fbdb
Author: Kon Lovett <konlovett@gmail.com>
AuthorDate: Thu Dec 13 20:45:27 2012 -0800
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Fri Dec 14 22:16:38 2012 +0100
Add recursive hash depth & length parameters. Make pair hash truely recursive.
Signed-off-by: felix <felix@call-with-current-continuation.org>
diff --git a/manual/Parameters b/manual/Parameters
index 738ef1d2..bf0e7d76 100644
--- a/manual/Parameters
+++ b/manual/Parameters
@@ -161,8 +161,8 @@ The name of the currently executing program. This is equivalent to
<parameter>(repl-prompt)</parameter>
-A procedure that should evaluate to a string that will be printed before reading
-interactive input from the user in a read-eval-print loop. Defaults to
+A procedure that should evaluate to a string that will be printed before reading
+interactive input from the user in a read-eval-print loop. Defaults to
{{(lambda () "#;N> ")}}.
@@ -175,5 +175,19 @@ default behavior in compiled code is to invoke the value of
{{(exit-handler)}}. The default behavior in the interpreter is to
abort the current computation and to restart the read-eval-print loop.
+
+=== recursive-hash-max-depth
+
+<parameter>(recursive-hash-max-depth)</parameter>
+
+The maximum structure depth to follow when computing a hash value. The default is {{4}}.
+
+
+=== recursive-hash-max-length
+
+<parameter>(recursive-hash-max-depth)</parameter>
+
+The maximum vector length to follow when computing a hash value. The default is {{4}}.
+
----
Previous: [[Declarations]] Next: [[Exceptions]]
diff --git a/manual/Unit srfi-69 b/manual/Unit srfi-69
index c4b909ef..e6c812a1 100644
--- a/manual/Unit srfi-69
+++ b/manual/Unit srfi-69
@@ -376,6 +376,20 @@ Synonym for {{equal?-hash}}.
Synonym for {{eq?-hash}}.
+
+=== recursive-hash-max-depth
+
+<parameter>(recursive-hash-max-depth)</parameter>
+
+The maximum structure depth to follow when computing a hash value. The default is {{4}}.
+
+
+=== recursive-hash-max-length
+
+<parameter>(recursive-hash-max-depth)</parameter>
+
+The maximum vector length to follow when computing a hash value. The default is {{4}}.
+
Previous: [[Unit srfi-18]]
Next: [[Unit posix]]
diff --git a/srfi-69.scm b/srfi-69.scm
index a36ec891..dada394f 100644
--- a/srfi-69.scm
+++ b/srfi-69.scm
@@ -263,19 +263,32 @@
;; Equal Hash:
-;XXX Be nice if these were parameters
-(define-constant recursive-hash-max-depth 4)
-(define-constant recursive-hash-max-length 4)
+(define-constant default-recursive-hash-max-depth 4)
+(define-constant default-recursive-hash-max-length 4)
+
+(define *recursive-hash-max-depth* default-recursive-hash-max-depth)
+(define recursive-hash-max-depth (make-parameter default-recursive-hash-max-depth
+ (lambda (x)
+ (if (and (fixnum? x) (positive? x))
+ (begin
+ (set! *recursive-hash-max-depth* x)
+ x )
+ *recursive-hash-max-depth*))))
+
+(define *recursive-hash-max-length* default-recursive-hash-max-length)
+(define recursive-hash-max-length (make-parameter default-recursive-hash-max-length
+ (lambda (x)
+ (if (and (fixnum? x) (positive? x))
+ (begin
+ (set! *recursive-hash-max-length* x)
+ x )
+ *recursive-hash-max-length*))))
;; NOTE - These refer to identifiers available only within the body of '*equal?-hash'.
-(define-inline (%%list-hash obj rnd)
- (fx+ (length obj)
- (recursive-atomic-hash (##sys#slot obj 0) depth rnd)) )
-
(define-inline (%%pair-hash obj rnd)
- (fx+ (fxshl (recursive-atomic-hash (##sys#slot obj 0) depth rnd) 16)
- (recursive-atomic-hash (##sys#slot obj 1) depth rnd)) )
+ (fx+ (fxshl (recursive-hash (##sys#slot obj 0) (fx+ depth 1) rnd) 16)
+ (recursive-hash (##sys#slot obj 1) (fx+ depth 1) rnd)) )
(define-inline (%%port-hash obj rnd)
(fx+ (fxxor (fxshl (##sys#peek-fixnum obj 0) 4) rnd) ; Little extra "identity"
@@ -296,7 +309,7 @@
(let ([len (##sys#size obj)])
(let loop ([hsh (fx+ len (fxxor seed rnd))]
[i start]
- [len (fx- (fxmin recursive-hash-max-length len) start)] )
+ [len (fx- (fxmax start (fxmin *recursive-hash-max-length* len)) start)] )
(if (fx= len 0)
hsh
(loop (fx+ hsh
@@ -305,16 +318,9 @@
(fx+ i 1)
(fx- len 1) ) ) ) ) )
- ; Don't recurse into structured objects
- (define (recursive-atomic-hash obj depth rnd)
- (if (or (%eqv?-hash-object? obj)
- (%byte-block? obj))
- (recursive-hash obj (fx+ depth 1) rnd)
- (fxxor other-hash-value rnd) ) )
-
; Recurse into structured objects
(define (recursive-hash obj depth rnd)
- (cond [(fx>= depth recursive-hash-max-depth)
+ (cond [(fx>= depth *recursive-hash-max-depth*)
(fxxor other-hash-value rnd)]
[(fixnum? obj) (fxxor obj rnd)]
[(char? obj) (fxxor (char->integer obj) rnd)]
@@ -328,7 +334,6 @@
[(number? obj) (%non-fixnum-number-hash obj rnd)]
[(%immediate? obj) (fxxor unknown-immediate-hash-value rnd)]
[(%byte-block? obj) (%string-hash obj rnd)]
- [(list? obj) (%%list-hash obj rnd)]
[(pair? obj) (%%pair-hash obj rnd)]
[(%port? obj) (%%port-hash obj rnd)]
[(%special? obj) (%%special-vector-hash obj rnd)]
@@ -352,8 +357,8 @@
(##sys#check-exact bound 'string-hash)
(let ((str (if start
(let ((end (or end (##sys#size str))))
- (##sys#check-range start 0 (##sys#size str) 'string-hash)
- (##sys#check-range end 0 (##sys#size str) 'string-hash)
+ (##sys#check-range start 0 (##sys#size str) 'string-hash)
+ (##sys#check-range end 0 (##sys#size str) 'string-hash)
(##sys#substring str start end))
str)) )
(%hash/limit (%string-hash str randomization) bound) ) )
@@ -364,8 +369,8 @@
(##sys#check-exact bound 'string-ci-hash)
(let ((str (if start
(let ((end (or end (##sys#size str))))
- (##sys#check-range start 0 (##sys#size str) 'string-hash)
- (##sys#check-range end 0 (##sys#size str) 'string-hash)
+ (##sys#check-range start 0 (##sys#size str) 'string-hash)
+ (##sys#check-range end 0 (##sys#size str) 'string-hash)
(##sys#substring str start end))
str)) )
(%hash/limit (%string-ci-hash str randomization) bound) ) )
@@ -434,7 +439,7 @@
(##sys#check-exact hash 'hash user-function)
(if (and (fx< hash bound) (fx>= hash 0))
hash
- (##sys#signal-hook
+ (##sys#signal-hook
#:bounds-error 'hash
"Hash value out of bounds" bound hash user-function) )))))))
diff --git a/tests/hash-table-tests.scm b/tests/hash-table-tests.scm
index cd22df07..469f50b2 100644
--- a/tests/hash-table-tests.scm
+++ b/tests/hash-table-tests.scm
@@ -180,7 +180,7 @@
(make-string 1000000 #\c)
(make-string 1000000 #\a)) 10 1))))
;; differing number of nul bytes should not be identical
-(assert (not (= (hash (make-string 1 #\nul) 10 1)
+(assert (not (= (hash (make-string 1 #\nul) 10 1)
(hash (make-string 2 #\nul) 10 1))))
;; ensure very long NUL strings don't cause the random value to get pushed out
(assert (not (= (hash (make-string 1000000 #\nul) 10 1)
@@ -214,3 +214,29 @@
(lambda (e1 e2) (< (car e1) (car e2))))))
;; Ensure that lookup still works (#905, randomization value was reset)
(assert (equal? '(a) (hash-table-ref ht2 1)))
+
+(print "HT - recursive depth/length")
+(assert (fixnum? (recursive-hash-max-depth)))
+(assert (positive? (recursive-hash-max-depth)))
+(assert (fixnum? (recursive-hash-max-length)))
+(assert (positive? (recursive-hash-max-length)))
+
+(let ((dd (recursive-hash-max-depth))
+ (tls (list (random 100000) (random 100000) (list (random 100000) (list (random 100000) (list (random 100000) (list (random 100000) (list (random 100000) (list (random 100000) (list (random 100000) (list (random 100000) (list (random 100000) (list (random 100000) (list (random 100000) (list (random 100000))))))))))))))))
+ (let ((hsh1 (equal?-hash tls 536870912 0)))
+ (recursive-hash-max-depth 10)
+ (assert (fx= 10 (recursive-hash-max-depth)))
+ (let ((hsh2 (equal?-hash tls 536870912 0)))
+ (recursive-hash-max-depth dd)
+ (print hsh1 " <?> " hsh2)
+ (assert (not (= hsh1 hsh2))) ) ) )
+
+(let ((dl (recursive-hash-max-length))
+ (tv (vector (random 100000) (random 100000) (random 100000) (random 100000) (random 100000) (random 100000) (random 100000) (random 100000) (random 100000) (random 100000) (random 100000) (random 100000))))
+ (let ((hsh1 (equal?-hash tv 536870912 0)))
+ (recursive-hash-max-length 10)
+ (assert (fx= 10 (recursive-hash-max-length)))
+ (let ((hsh2 (equal?-hash tv 536870912 0)))
+ (recursive-hash-max-length dl)
+ (print hsh1 " <?> " hsh2)
+ (assert (not (= hsh1 hsh2))) ) ) )
Trap