Ticket #818: 0001-Ensure-outside-hash-functions-do-not-leak-into-srfi-.patch.txt

File 0001-Ensure-outside-hash-functions-do-not-leak-into-srfi-.patch.txt, 3.0 KB (added by Jim Ursetto, 10 years ago)
Line 
1From 9f2f2cb6290831460060810b7b49a0ba72073a46 Mon Sep 17 00:00:00 2001
2From: Jim Ursetto <zbigniewsz@gmail.com>
3Date: Wed, 18 Apr 2012 18:28:11 -0500
4Subject: [PATCH] Ensure outside hash functions do not leak into srfi-69
5 (fixes #818)
6
7---
8 srfi-69.scm |   49 ++++++++++++++++++++++++++++---------------------
9 1 files changed, 28 insertions(+), 21 deletions(-)
10
11diff --git a/srfi-69.scm b/srfi-69.scm
12index 99025a2..122e8cd 100644
13--- a/srfi-69.scm
14+++ b/srfi-69.scm
15@@ -410,26 +410,30 @@
16          cur
17          (loop nxt) ) ) ) )
18 
19-(define (*make-hash-function user-function)
20-  (if (memq user-function (list eq?-hash eqv?-hash equal?-hash hash
21-                               string-hash string-hash-ci number-hash))
22-      ;; Don't add unneccessary bounds checks for procedures known to be
23-      ;; well-behaved (these are not user-*created* functions)
24-      (let ((randomization (##core#inline "C_rnd_fix")))
25-        (if (memq user-function (list string-hash string-hash-ci))
26-            ;; String functions have differing signatures; treat them specially
27-            (lambda (object bound)
28-              (user-function object bound #f #f randomization))
29-            (lambda (object bound)
30-              (user-function object bound randomization))))
31-      (lambda (object bound)
32-       (let ((hash (user-function object bound)))
33-         (##sys#check-exact hash 'hash user-function)
34-         (if (and (fx< hash bound) (fx>= hash 0))
35-             hash
36-             (##sys#signal-hook
37-              #:bounds-error 'hash
38-              "Hash value out of bounds" bound hash user-function) )))))
39+(define *make-hash-function
40+  (let ((eq?-hash eq?-hash) (eqv?-hash eqv?-hash) (equal?-hash equal?-hash)
41+       (hash hash) (string-hash string-hash) (string-hash-ci string-hash-ci)
42+       (number-hash number-hash))
43+    (lambda (user-function)
44+      (if (memq user-function (list eq?-hash eqv?-hash equal?-hash hash
45+                                   string-hash string-hash-ci number-hash))
46+         ;; Don't add unnecessary bounds checks for procedures known to be
47+         ;; well-behaved (these are not user-*created* functions)
48+         (let ((randomization (##core#inline "C_rnd_fix")))
49+           (if (memq user-function (list string-hash string-hash-ci))
50+               ;; String functions have differing signatures; treat them specially
51+               (lambda (object bound)
52+                 (user-function object bound #f #f randomization))
53+               (lambda (object bound)
54+                 (user-function object bound randomization))))
55+         (lambda (object bound)
56+           (let ((hash (user-function object bound)))
57+             (##sys#check-exact hash 'hash user-function)
58+             (if (and (fx< hash bound) (fx>= hash 0))
59+                 hash
60+                 (##sys#signal-hook
61+                  #:bounds-error 'hash
62+                  "Hash value out of bounds" bound hash user-function) )))))))
63 
64 ;; "Raw" make-hash-table:
65 
66@@ -462,7 +466,10 @@
67        [core-equal? equal?]
68        [core-string=? string=?]
69        [core-string-ci=? string-ci=?]
70-       [core= =] )
71+       [core= =]
72+       (eq?-hash eq?-hash) (eqv?-hash eqv?-hash) (equal?-hash equal?-hash)
73+       (hash hash) (string-hash string-hash) (string-hash-ci string-hash-ci)
74+       (number-hash number-hash))
75     (lambda arguments0
76       (let ([arguments arguments0]
77            [test equal?]
78--
791.7.6.1
80