1 | From 9f2f2cb6290831460060810b7b49a0ba72073a46 Mon Sep 17 00:00:00 2001 |
---|
2 | From: Jim Ursetto <zbigniewsz@gmail.com> |
---|
3 | Date: Wed, 18 Apr 2012 18:28:11 -0500 |
---|
4 | Subject: [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 | |
---|
11 | diff --git a/srfi-69.scm b/srfi-69.scm |
---|
12 | index 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 | -- |
---|
79 | 1.7.6.1 |
---|
80 | |
---|