source: project/chicken/trunk/srfi-69.scm @ 14527

Last change on this file since 14527 was 14527, checked in by Jim Ursetto, 11 years ago

Fix silly number-hash bug which hashed all fixnums to 23 --
any self-respecting nerd would know they should hash to 42

File size: 35.5 KB
Line 
1;;; srfi-69.scm - Optional non-standard extensions
2;
3; Copyright (c) 2000-2007, Felix L. Winkelmann
4; Copyright (c) 2008-2009, The Chicken Team
5; All rights reserved.
6;
7; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
8; conditions are met:
9;
10;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
11;     disclaimer.
12;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
13;     disclaimer in the documentation and/or other materials provided with the distribution.
14;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
15;     products derived from this software without specific prior written permission.
16;
17; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
18; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
19; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
20; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
21; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
22; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
23; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
24; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
25; POSSIBILITY OF SUCH DAMAGE.
26
27
28(declare
29 (unit srfi-69)
30 (usual-integrations)
31 (disable-warning redef) ) ; hash-table-ref is an extended binding!
32
33(cond-expand
34 [paranoia]
35 [else
36  (declare
37    (no-bound-checks)
38    (no-procedure-checks-for-usual-bindings) ) ] )
39
40(declare
41  (bound-to-procedure
42    ##sys#signal-hook
43    ##sys#peek-fixnum
44    ##sys#make-structure
45    ##sys#size
46    ##sys#slot ##sys#setslot
47    *equal?-hash )
48  (hide
49    *eq?-hash *eqv?-hash *equal?-hash
50    *make-hash-table
51    *hash-table-copy *hash-table-merge! *hash-table-update!/default
52    *hash-table-for-each *hash-table-fold
53    hash-table-canonical-length hash-table-rehash! hash-table-check-resize! ) )
54
55(cond-expand
56 [unsafe]
57 [else
58   (declare
59     (bound-to-procedure
60       ##sys#check-string ##sys#check-symbol
61       ##sys#check-exact ##sy#check-inexact
62       ##sys#check-closure ##sys#check-structure ) ) ] )
63
64(include "unsafe-declarations.scm")
65
66(register-feature! 'srfi-69)
67
68
69;;; Naming Conventions:
70
71;; %foo - inline primitive
72;; %%foo - local inline (no such thing but at least it looks different)
73;; $foo - local macro
74;; *foo - local unchecked variant of a checked procedure
75;; ##sys#foo - public, but undocumented, un-checked procedure
76;; foo - public checked procedure
77;;
78
79
80;;; Core Inlines:
81
82(define-inline (%fix wrd)
83  (##core#inline "C_fix" wrd) )
84
85(define-inline (%block? obj)
86  (##core#inline "C_blockp" obj) )
87
88(define-inline (%immediate? obj)
89  (not (##core#inline "C_blockp" obj)) )
90
91(define-inline (%special? obj)
92  (##core#inline "C_specialp" obj) )
93
94(define-inline (%port? obj)
95  (##core#inline "C_portp" obj) )
96
97(define-inline (%byte-block? obj)
98  (##core#inline "C_byteblockp" obj) )
99
100(define-inline (%string-hash str)
101  (##core#inline "C_hash_string" str) )
102
103(define-inline (%string-ci-hash str)
104  (##core#inline "C_hash_string_ci" str) )
105
106(define-inline (%subbyte bytvec i)
107  (##core#inline "C_subbyte" bytvec i) )
108
109
110;;; Generation of hash-values:
111
112;; All '%foo-hash' return a fixnum, not necessarily positive. The "overflow" of
113;; a, supposedly, unsigned hash value into negative is not checked during
114;; intermediate computation.
115;;
116;; The body of '*eq?-hash' is duplicated in '*eqv?-hash' and the body of '*eqv?-hash'
117;; is duplicated in '*equal?-hash' to save on procedure calls.
118
119;; Fixed hash-values:
120
121(define-constant other-hash-value 99)
122(define-constant true-hash-value 256)
123(define-constant false-hash-value 257)
124(define-constant null-hash-value 258)
125(define-constant eof-hash-value 259)
126(define-constant input-port-hash-value 260)
127(define-constant output-port-hash-value 261)
128(define-constant unknown-immediate-hash-value 262)
129
130(define-constant hash-default-bound 536870912)
131
132;; Force Hash to Bounded Fixnum:
133
134(define-inline (%fxabs fxn)
135  (if (fx< fxn 0) (fxneg fxn) fxn ) )
136
137(define-inline (%hash/limit hsh lim)
138  (fxmod (fxand (foreign-value "C_MOST_POSITIVE_FIXNUM" int)
139                (%fxabs hsh))
140         lim) )
141
142;; Number Hash:
143
144(define-constant flonum-magic 331804471)
145
146(define-syntax $flonum-hash
147  ;;XXX use er-macro-transformer
148  (lambda (form r c)
149    (let ( (flo (cadr form))
150           (%%subbyte (r '%subbyte))
151           (%flonum-magic (r 'flonum-magic))
152           (%fx+ (r 'fx+))
153           (%fx* (r 'fx*))
154           (%fxshl (r 'fxshl)) )
155    `(,%fx* ,%flonum-magic
156            ,(let loop ( (idx (fx- (##sys#size 1.0) 1)) )
157               (if (fx= 0 idx)
158                   `(,%%subbyte ,flo 0)
159                   `(,%fx+ (,%%subbyte ,flo ,idx)
160                           (,%fxshl ,(loop (fx- idx 1)) 1)) ) ) ) ) ) )
161
162(define (##sys#number-hash-hook obj)
163  (*equal?-hash obj) )
164
165(define-inline (%non-fixnum-number-hash obj)
166  (cond [(flonum? obj)  ($flonum-hash obj)]
167        [else           (%fix (##sys#number-hash-hook obj))] ) )
168
169(define-inline (%number-hash obj)
170  (cond [(fixnum? obj)  obj]
171        [else           (%non-fixnum-number-hash obj)] ) )
172
173(define (number-hash obj #!optional (bound hash-default-bound))
174  (unless (number? obj)
175    (##sys#signal-hook #:type 'number-hash "invalid number" obj) )
176  (##sys#check-exact bound 'number-hash)
177  (%hash/limit (%number-hash obj) bound) )
178
179;; Object UID Hash:
180
181#; ;NOT YET (no weak-reference)
182(define-inline (%object-uid-hash obj)
183  (%uid-hash (##sys#object->uid obj)) )
184
185(define-inline (%object-uid-hash obj)
186  (*equal?-hash obj) )
187
188(define (object-uid-hash obj #!optional (bound hash-default-bound))
189  (##sys#check-exact bound 'object-uid-hash)
190  (%hash/limit (%object-uid-hash obj) bound) )
191
192;; Symbol Hash:
193
194#; ;NOT YET (no unique-symbol-hash)
195(define-inline (%symbol-hash obj)
196  (##sys#slot obj INDEX-OF-UNIQUE-HASH-VALUE-COMPUTED-DURING-SYMBOL-CREATION) )
197
198(define-inline (%symbol-hash obj)
199  (%string-hash (##sys#slot obj 1)) )
200
201(define (symbol-hash obj #!optional (bound hash-default-bound))
202  (##sys#check-symbol obj 'symbol-hash)
203  (##sys#check-exact bound 'symbol-hash)
204  (%hash/limit (%symbol-hash obj) bound) )
205
206;; Keyword Hash:
207
208(define (##sys#check-keyword x . y)
209  (unless (keyword? x)
210    (##sys#signal-hook #:type-error
211                       (and (not (null? y)) (car y))
212                       "bad argument type - not a keyword" x) ) )
213
214#; ;NOT YET (no unique-keyword-hash)
215(define-inline (%keyword-hash obj)
216  (##sys#slot obj INDEX-OF-UNIQUE-HASH-VALUE-COMPUTED-DURING-KEYWORD-CREATION) )
217
218(define-inline (%keyword-hash obj)
219  (%string-hash (##sys#slot obj 1)) )
220
221(define (keyword-hash obj #!optional (bound hash-default-bound))
222  (##sys#check-keyword obj 'keyword-hash)
223  (##sys#check-exact bound 'keyword-hash)
224  (%hash/limit (%keyword-hash obj) bound) )
225
226;; Eq Hash:
227
228(define-inline (%eq?-hash-object? obj)
229  (or (%immediate? obj)
230       (symbol? obj)
231       #; ;NOT YET (no keyword vs. symbol issue)
232       (keyword? obj) ) )
233
234(define (*eq?-hash obj)
235  (cond [(fixnum? obj)          obj]
236        [(char? obj)            (char->integer obj)]
237        [(eq? obj #t)           true-hash-value]
238        [(eq? obj #f)           false-hash-value]
239        [(null? obj)            null-hash-value]
240        [(eof-object? obj)      eof-hash-value]
241        [(symbol? obj)          (%symbol-hash obj)]
242        #; ;NOT YET (no keyword vs. symbol issue)
243        [(keyword? obj)         (%keyword-hash obj)]
244        [(%immediate? obj)      unknown-immediate-hash-value]
245        [else                   (%object-uid-hash obj) ] ) )
246
247(define (eq?-hash obj #!optional (bound hash-default-bound))
248  (##sys#check-exact bound 'eq?-hash)
249  (%hash/limit (*eq?-hash obj) bound) )
250
251(define hash-by-identity eq?-hash)
252
253;; Eqv Hash:
254
255(define-inline (%eqv?-hash-object? obj)
256  (or (%eq?-hash-object? obj)
257      (number? obj) ) )
258
259(define (*eqv?-hash obj)
260  (cond [(fixnum? obj)          obj]
261        [(char? obj)            (char->integer obj)]
262        [(eq? obj #t)           true-hash-value]
263        [(eq? obj #f)           false-hash-value]
264        [(null? obj)            null-hash-value]
265        [(eof-object? obj)      eof-hash-value]
266        [(symbol? obj)          (%symbol-hash obj)]
267        #; ;NOT YET (no keyword vs. symbol issue)
268        [(keyword? obj)         (%keyword-hash obj)]
269        [(number? obj)          (%non-fixnum-number-hash obj)]
270        [(%immediate? obj)      unknown-immediate-hash-value]
271        [else                   (%object-uid-hash obj) ] ) )
272
273(define (eqv?-hash obj #!optional (bound hash-default-bound))
274  (##sys#check-exact bound 'eqv?-hash)
275  (%hash/limit (*eqv?-hash obj) bound) )
276
277;; Equal Hash:
278
279;XXX Be nice if these were parameters
280(define-constant recursive-hash-max-depth 4)
281(define-constant recursive-hash-max-length 4)
282
283;; NOTE - These refer to identifiers available only within the body of '*equal?-hash'.
284
285(define-inline (%%list-hash obj)
286  (fx+ (length obj)
287       (recursive-atomic-hash (##sys#slot obj 0) depth)) )
288
289(define-inline (%%pair-hash obj)
290  (fx+ (fxshl (recursive-atomic-hash (##sys#slot obj 0) depth) 16)
291        (recursive-atomic-hash (##sys#slot obj 1) depth)) )
292
293(define-inline (%%port-hash obj)
294  (fx+ (fxshl (##sys#peek-fixnum obj 0) 4) ; Little extra "identity"
295        (if (input-port? obj)
296            input-port-hash-value
297            output-port-hash-value)) )
298
299(define-inline (%%special-vector-hash obj)
300  (vector-hash obj (##sys#peek-fixnum obj 0) depth 1) )
301
302(define-inline (%%regular-vector-hash obj)
303  (vector-hash obj 0 depth 0) )
304
305(define (*equal?-hash obj)
306
307  ; Recurse into some portion of the vector's slots
308  (define (vector-hash obj seed depth start)
309    (let ([len (##sys#size obj)])
310      (let loop ([hsh (fx+ len seed)]
311                 [i start]
312                 [len (fx- (fxmin recursive-hash-max-length len) start)] )
313        (if (fx= len 0)
314            hsh
315            (loop (fx+ hsh
316                       (fx+ (fxshl hsh 4)
317                            (recursive-hash (##sys#slot obj i) (fx+ depth 1))))
318                  (fx+ i 1)
319                  (fx- len 1) ) ) ) ) )
320
321  ; Don't recurse into structured objects
322  (define (recursive-atomic-hash obj depth)
323    (if (or (%eqv?-hash-object? obj)
324            (%byte-block? obj))
325        (recursive-hash obj (fx+ depth 1))
326        other-hash-value ) )
327
328  ; Recurse into structured objects
329  (define (recursive-hash obj depth)
330    (cond [(fx>= depth recursive-hash-max-depth)
331                                  other-hash-value]
332          [(fixnum? obj)          obj]
333          [(char? obj)            (char->integer obj)]
334          [(eq? obj #t)           true-hash-value]
335          [(eq? obj #f)           false-hash-value]
336          [(null? obj)            null-hash-value]
337          [(eof-object? obj)      eof-hash-value]
338          [(symbol? obj)          (%symbol-hash obj)]
339          #; ;NOT YET (no keyword vs. symbol issue)
340          [(keyword? obj)         (%keyword-hash obj)]
341          [(number? obj)          (%non-fixnum-number-hash obj)]
342          [(%immediate? obj)      unknown-immediate-hash-value]
343          [(%byte-block? obj)     (%string-hash obj)]
344          [(list? obj)            (%%list-hash obj)]
345          [(pair? obj)            (%%pair-hash obj)]
346          [(%port? obj)           (%%port-hash obj)]
347          [(%special? obj)        (%%special-vector-hash obj)]
348          [else                   (%%regular-vector-hash obj)] ) )
349
350  ;
351  (recursive-hash obj 0) )
352
353(define (equal?-hash obj #!optional (bound hash-default-bound))
354  (##sys#check-exact bound 'hash)
355  (%hash/limit (*equal?-hash obj) bound) )
356
357(define hash equal?-hash)
358
359;; String Hash:
360
361(define (string-hash str #!optional (bound hash-default-bound))
362  (##sys#check-string str 'string-hash)
363  (##sys#check-exact bound 'string-hash)
364  (%hash/limit (%string-hash str) bound) )
365
366(define (string-ci-hash str #!optional (bound hash-default-bound))
367  (##sys#check-string str 'string-ci-hash)
368  (##sys#check-exact bound 'string-ci-hash)
369  (%hash/limit (%string-ci-hash str) bound) )
370
371
372;;; Hash-Tables:
373
374; Predefined sizes for the hash tables:
375;
376; Starts with 307; each element is the smallest prime that is at least twice in
377; magnitude as the previous element in the list.
378;
379; The last number is an exception: it is the largest 32-bit fixnum we can represent.
380
381(define-constant hash-table-prime-lengths
382  '(307 617
383    1237 2477 4957 9923
384    19853 39709 79423
385    158849 317701 635413
386    1270849 2541701 5083423
387    10166857 20333759 40667527 81335063 162670129
388    325340273 650680571
389    ;
390    1073741823))
391
392(define-constant hash-table-default-length 307)
393(define-constant hash-table-max-length 1073741823)
394(define-constant hash-table-new-length-factor 2)
395
396(define-constant hash-table-default-min-load 0.5)
397(define-constant hash-table-default-max-load 0.8)
398
399;; Restrict hash-table length to tabled lengths:
400
401(define (hash-table-canonical-length tab req)
402  (let loop ([tab tab])
403    (let ([cur (##sys#slot tab 0)]
404          [nxt (##sys#slot tab 1)])
405      (if (or (fx>= cur req)
406              (null? nxt))
407          cur
408          (loop nxt) ) ) ) )
409
410;; "Raw" make-hash-table:
411
412(define *make-hash-table
413  (let ([make-vector make-vector])
414    (lambda (test hash len min-load max-load weak-keys weak-values initial
415             #!optional (vec (make-vector len '())))
416      (##sys#make-structure 'hash-table
417       vec 0 test hash min-load max-load #f #f initial) ) ) )
418
419;; SRFI-69 & SRFI-90'ish.
420;;
421;; Argument list is the pattern
422;;
423;; (make-hash-table #!optional test hash size
424;;                  #!key test hash size initial min-load max-load weak-keys weak-values)
425;;
426;; where a keyword argument takes precedence over the corresponding optional
427;; argument. Keyword arguments MUST come after optional & required
428;; arugments.
429;;
430;; Wish DSSSL (extended) argument list processing Did-What-I-Want (DWIW).
431
432(define make-hash-table
433  (let ([core-eq? eq?]
434        [core-eqv? eqv?]
435        [core-equal? equal?]
436        [core-string=? string=?]
437        [core-string-ci=? string-ci=?]
438        [core= =] )
439    (lambda arguments0
440      (let ([arguments arguments0]
441            [test equal?]
442            [hash #f]
443            [size hash-table-default-length]
444            [initial #f]
445            [min-load hash-table-default-min-load]
446            [max-load hash-table-default-max-load]
447            [weak-keys #f]
448            [weak-values #f])
449        (let ([hash-for-test
450                (lambda ()
451                  (cond [(or (eq? core-eq? test)
452                             (eq? eq? test))              eq?-hash]
453                        [(or (eq? core-eqv? test)
454                             (eq? eqv? test))             eqv?-hash]
455                        [(or (eq? core-equal? test)
456                             (eq? equal? test))           equal?-hash]
457                        [(or (eq? core-string=? test)
458                             (eq? string=? test))         string-hash]
459                        [(or (eq? core-string-ci=? test)
460                             (eq? string-ci=? test))      string-ci-hash]
461                        [(or (eq? core= test)
462                             (eq? = test))                number-hash]
463                        [else                             #f] ) ) ] )
464          ; Process optional arguments
465          (unless (null? arguments)
466            (let ([arg (car arguments)])
467              (unless (keyword? arg)
468                (##sys#check-closure arg 'make-hash-table)
469                (set! test arg)
470                (set! arguments (cdr arguments)) ) ) )
471          (unless (null? arguments)
472            (let ([arg (car arguments)])
473              (unless (keyword? arg)
474                (##sys#check-closure arg 'make-hash-table)
475                (set! hash arg)
476                (set! arguments (cdr arguments)) ) ) )
477          (unless (null? arguments)
478            (let ([arg (car arguments)])
479              (unless (keyword? arg)
480                (##sys#check-exact arg 'make-hash-table)
481                (unless (fx< 0 arg)
482                  (error 'make-hash-table "invalid size" arg) )
483                (set! size (fxmin hash-table-max-size arg))
484                (set! arguments (cdr arguments)) ) ) )
485          ; Process keyword arguments
486          (let loop ([args arguments])
487            (unless (null? args)
488              (let ([arg (car args)])
489                (let ([invarg-err
490                        (lambda (msg)
491                          (error 'make-hash-table msg arg arguments0))])
492                  (if (keyword? arg)
493                      (let* ([nxt (cdr args)]
494                             [val (if (pair? nxt)
495                                      (car nxt)
496                                      (invarg-err "missing keyword value"))])
497                        (case arg
498                          [(#:test)
499                            (##sys#check-closure val 'make-hash-table)
500                            (set! test val)]
501                          [(#:hash)
502                            (##sys#check-closure val 'make-hash-table)
503                            (set! hash val)]
504                          [(#:size)
505                            (##sys#check-exact val 'make-hash-table)
506                            (unless (fx< 0 val)
507                              (error 'make-hash-table "invalid size" val) )
508                            (set! size (fxmin hash-table-max-size val))]
509                          [(#:initial)
510                            (set! initial (lambda () val))]
511                          [(#:min-load)
512                            (##sys#check-inexact val 'make-hash-table)
513                            (unless (and (fp< 0.0 val) (fp< val 1.0))
514                              (error 'make-hash-table "invalid min-load" val) )
515                            (set! min-load val)]
516                          [(#:max-load)
517                            (##sys#check-inexact val 'make-hash-table)
518                            (unless (and (fp< 0.0 val) (fp< val 1.0))
519                              (error 'make-hash-table "invalid max-load" val) )
520                            (set! max-load val)]
521                          [(#:weak-keys)
522                            (set! weak-keys (and val #t))]
523                          [(#:weak-values)
524                            (set! weak-values (and val #t))]
525                          [else
526                            (invarg-err "unknown keyword")])
527                        (loop (cdr nxt)) )
528                      (invarg-err "missing keyword") ) ) ) ) )
529          ; Load must be a proper interval
530          (when (fp< max-load min-load)
531            (error 'make-hash-table "min-load greater than max-load" min-load max-load) )
532          ; Force canonical hash-table vector length
533          (set! size (hash-table-canonical-length hash-table-prime-lengths size))
534          ; Decide on a hash function when not supplied
535          (unless hash
536            (let ([func (hash-for-test)])
537              (if func
538                  (set! hash func)
539                  (begin
540                    (warning 'make-hash-table "user test without user hash")
541                    (set! hash equal?-hash) ) ) ) )
542          ; Done
543          (*make-hash-table test hash size min-load max-load weak-keys weak-values initial) ) ) ) ) )
544
545;; Hash-Table Predicate:
546
547(define (hash-table? obj)
548  (##sys#structure? obj 'hash-table) )
549
550;; Hash-Table Properties:
551
552(define (hash-table-size ht)
553  (##sys#check-structure ht 'hash-table 'hash-table-size)
554  (##sys#slot ht 2) )
555
556(define (hash-table-equivalence-function ht)
557  (##sys#check-structure ht 'hash-table 'hash-table-equivalence-function)
558  (##sys#slot ht 3) )
559
560(define (hash-table-hash-function ht)
561  (##sys#check-structure ht 'hash-table 'hash-table-hash-function)
562  (##sys#slot ht 4) )
563
564(define (hash-table-min-load ht)
565  (##sys#check-structure ht 'hash-table 'hash-table-min-load)
566  (##sys#slot ht 5) )
567
568(define (hash-table-max-load ht)
569  (##sys#check-structure ht 'hash-table 'hash-table-max-load)
570  (##sys#slot ht 6) )
571
572(define (hash-table-weak-keys ht)
573  (##sys#check-structure ht 'hash-table 'hash-table-weak-keys)
574  (##sys#slot ht 7) )
575
576(define (hash-table-weak-values ht)
577  (##sys#check-structure ht 'hash-table 'hash-table-weak-values)
578  (##sys#slot ht 8) )
579
580(define (hash-table-has-initial? ht)
581  (##sys#check-structure ht 'hash-table 'hash-table-has-initial?)
582  (and (##sys#slot ht 9)
583       #t ) )
584
585(define (hash-table-initial ht)
586  (##sys#check-structure ht 'hash-table 'hash-table-initial)
587  (and-let* ([thunk (##sys#slot ht 9)])
588    (thunk) ) )
589
590;; hash-table-rehash!:
591
592(define (hash-table-rehash! vec1 vec2 hash)
593  (let ([len1 (##sys#size vec1)]
594        [len2 (##sys#size vec2)] )
595    (do ([i 0 (fx+ i 1)])
596        [(fx>= i len1)]
597      (let loop ([bucket (##sys#slot vec1 i)])
598        (unless (null? bucket)
599          (let* ([pare (##sys#slot bucket 0)]
600                 [key (##sys#slot pare 0)]
601                 [hshidx (hash key len2)] )
602            (##sys#setslot vec2 hshidx
603                           (cons (cons key (##sys#slot pare 1)) (##sys#slot vec2 hshidx)))
604            (loop (##sys#slot bucket 1)) ) ) ) ) ) )
605
606;; hash-table-resize!:
607
608(define (hash-table-resize! ht vec len)
609  (let* ([deslen (fxmin hash-table-max-length (fx* len hash-table-new-length-factor))]
610         [newlen (hash-table-canonical-length hash-table-prime-lengths deslen)]
611         [vec2 (make-vector newlen '())] )
612    (hash-table-rehash! vec vec2 (##sys#slot ht 4))
613    (##sys#setslot ht 1 vec2) ) )
614
615;; hash-table-check-resize!:
616
617(define-inline (hash-table-check-resize! ht newsiz)
618  (let ([vec (##sys#slot ht 1)]
619        [min-load (##sys#slot ht 5)]
620        [max-load (##sys#slot ht 6)] )
621    (let ([len (##sys#size vec)] )
622      (let ([min-load-len (inexact->exact (floor (* len min-load)))]
623            [max-load-len (inexact->exact (floor (* len max-load)))] )
624        (if (and (fx< len hash-table-max-length)
625                 (fx<= min-load-len newsiz) (fx<= newsiz max-load-len))
626          (hash-table-resize! ht vec len) ) ) ) ) )
627
628;; hash-table-copy:
629
630(define *hash-table-copy
631  (let ([make-vector make-vector])
632    (lambda (ht)
633      (let* ([vec1 (##sys#slot ht 1)]
634             [len (##sys#size vec1)]
635             [vec2 (make-vector len '())] )
636        (do ([i 0 (fx+ i 1)])
637            [(fx>= i len)
638             (*make-hash-table
639              (##sys#slot ht 3) (##sys#slot ht 4)
640              (##sys#slot ht 2)
641              (##sys#slot ht 5) (##sys#slot ht 6)
642              (##sys#slot ht 7) (##sys#slot ht 8)
643              (##sys#slot ht 9)
644              vec2)]
645          (##sys#setslot vec2 i
646           (let copy-loop ([bucket (##sys#slot vec1 i)])
647             (if (null? bucket)
648                 '()
649                 (let ([pare (##sys#slot bucket 0)])
650                   (cons (cons (##sys#slot pare 0) (##sys#slot pare 1))
651                         (copy-loop (##sys#slot bucket 1))))))) ) ) ) ) )
652
653(define (hash-table-copy ht)
654  (##sys#check-structure ht 'hash-table 'hash-table-copy)
655  (*hash-table-copy ht) )
656
657;; hash-table-update!:
658;;
659;; This one was suggested by Sven Hartrumpf (and subsequently added in SRFI-69).
660;; Modified for ht props min & max load.
661
662(define hash-table-update!
663  (let ([core-eq? eq?] )
664    (lambda (ht key
665             #!optional (func identity)
666                        (thunk
667                         (let ([thunk (##sys#slot ht 9)])
668                           (or thunk
669                               (lambda ()
670                                 (##sys#signal-hook #:access-error
671                                  'hash-table-update!
672                                  "hash-table does not contain key" key ht))))))
673      (##sys#check-structure ht 'hash-table 'hash-table-update!)
674      (##sys#check-closure func 'hash-table-update!)
675      (##sys#check-closure thunk 'hash-table-update!)
676      (let ([newsiz (fx+ (##sys#slot ht 2) 1)] )
677        (hash-table-check-resize! ht newsiz)
678        (let ([hash (##sys#slot ht 4)]
679              [test (##sys#slot ht 3)]
680              [vec (##sys#slot ht 1)] )
681          (let* ([len (##sys#size vec)]
682                 [hshidx (hash key len)]
683                 [bucket0 (##sys#slot vec hshidx)] )
684            (if (eq? core-eq? test)
685                ; Fast path (eq? is rewritten by the compiler):
686                (let loop ([bucket bucket0])
687                  (if (null? bucket)
688                      (let ([val (func (thunk))])
689                        (##sys#setslot vec hshidx (cons (cons key val) bucket0))
690                        (##sys#setislot ht 2 newsiz)
691                        val )
692                      (let ([pare (##sys#slot bucket 0)])
693                         (if (eq? key (##sys#slot pare 0))
694                             (let ([val (func (##sys#slot pare 1))])
695                               (##sys#setslot pare 1 val)
696                               val)
697                             (loop (##sys#slot bucket 1)) ) ) ) )
698                ; Slow path
699                (let loop ([bucket bucket0])
700                  (if (null? bucket)
701                      (let ([val (func (thunk))])
702                        (##sys#setslot vec hshidx (cons (cons key val) bucket0))
703                        (##sys#setislot ht 2 newsiz)
704                        val )
705                      (let ([pare (##sys#slot bucket 0)])
706                         (if (test key (##sys#slot pare 0))
707                             (let ([val (func (##sys#slot pare 1))])
708                               (##sys#setslot pare 1 val)
709                               val )
710                             (loop (##sys#slot bucket 1)) ) ) ) ) ) ) ) ) ) ) )
711
712(define *hash-table-update!/default
713  (let ([core-eq? eq?] )
714    (lambda (ht key func def)
715      (let ([newsiz (fx+ (##sys#slot ht 2) 1)] )
716        (hash-table-check-resize! ht newsiz)
717        (let ([hash (##sys#slot ht 4)]
718              [test (##sys#slot ht 3)]
719              [vec (##sys#slot ht 1)] )
720          (let* ([len (##sys#size vec)]
721                 [hshidx (hash key len)]
722                 [bucket0 (##sys#slot vec hshidx)] )
723            (if (eq? core-eq? test)
724                ; Fast path (eq? is rewritten by the compiler):
725                (let loop ([bucket bucket0])
726                  (if (null? bucket)
727                      (let ([val (func def)])
728                        (##sys#setslot vec hshidx (cons (cons key val) bucket0))
729                        (##sys#setislot ht 2 newsiz)
730                        val )
731                      (let ([pare (##sys#slot bucket 0)])
732                         (if (eq? key (##sys#slot pare 0))
733                             (let ([val (func (##sys#slot pare 1))])
734                               (##sys#setslot pare 1 val)
735                               val)
736                             (loop (##sys#slot bucket 1)) ) ) ) )
737                ; Slow path
738                (let loop ([bucket bucket0])
739                  (if (null? bucket)
740                      (let ([val (func def)])
741                        (##sys#setslot vec hshidx (cons (cons key val) bucket0))
742                        (##sys#setislot ht 2 newsiz)
743                        val )
744                      (let ([pare (##sys#slot bucket 0)])
745                         (if (test key (##sys#slot pare 0))
746                             (let ([val (func (##sys#slot pare 1))])
747                               (##sys#setslot pare 1 val)
748                               val )
749                             (loop (##sys#slot bucket 1)) ) ) ) ) ) ) ) ) ) ) )
750
751(define (hash-table-update!/default ht key func def)
752  (##sys#check-structure ht 'hash-table 'hash-table-update!/default)
753  (##sys#check-closure func 'hash-table-update!/default)
754  (*hash-table-update!/default ht key func def) )
755
756(define hash-table-set!
757  (let ([core-eq? eq?] )
758    (lambda (ht key val)
759      (##sys#check-structure ht 'hash-table 'hash-table-set!)
760      (let ([newsiz (fx+ (##sys#slot ht 2) 1)] )
761        (hash-table-check-resize! ht newsiz)
762        (let ([hash (##sys#slot ht 4)]
763              [test (##sys#slot ht 3)]
764              [vec (##sys#slot ht 1)] )
765          (let* ([len (##sys#size vec)]
766                 [hshidx (hash key len)]
767                 [bucket0 (##sys#slot vec hshidx)] )
768            (if (eq? core-eq? test)
769                ; Fast path (eq? is rewritten by the compiler):
770                (let loop ([bucket bucket0])
771                  (if (null? bucket)
772                      (begin
773                        (##sys#setslot vec hshidx (cons (cons key val) bucket0))
774                        (##sys#setislot ht 2 newsiz) )
775                      (let ([pare (##sys#slot bucket 0)])
776                         (if (eq? key (##sys#slot pare 0))
777                             (##sys#setslot pare 1 val)
778                             (loop (##sys#slot bucket 1)) ) ) ) )
779                ; Slow path
780                (let loop ([bucket bucket0])
781                  (if (null? bucket)
782                      (begin
783                        (##sys#setslot vec hshidx (cons (cons key val) bucket0))
784                        (##sys#setislot ht 2 newsiz) )
785                      (let ([pare (##sys#slot bucket 0)])
786                         (if (test key (##sys#slot pare 0))
787                             (##sys#setslot pare 1 val)
788                             (loop (##sys#slot bucket 1)) ) ) ) ) )
789            (void) ) ) ) ) ) )
790
791;; Hash-Table Reference:
792
793(define hash-table-ref
794  (getter-with-setter
795    (let ([core-eq? eq?])
796      (lambda (ht key #!optional (def (lambda ()
797                                        (##sys#signal-hook #:access-error
798                                         'hash-table-ref
799                                         "hash-table does not contain key" key ht))))
800        (##sys#check-structure ht 'hash-table 'hash-table-ref)
801        (##sys#check-closure def 'hash-table-ref)
802        (let  ([vec (##sys#slot ht 1)]
803               [test (##sys#slot ht 3)] )
804          (let* ([hash (##sys#slot ht 4)]
805                 [hshidx (hash key (##sys#size vec))] )
806            (if (eq? core-eq? test)
807                ; Fast path (eq? is rewritten by the compiler):
808                (let loop ([bucket (##sys#slot vec hshidx)])
809                  (if (null? bucket)
810                      (def)
811                      (let ([pare (##sys#slot bucket 0)])
812                        (if (eq? key (##sys#slot pare 0))
813                            (##sys#slot pare 1)
814                            (loop (##sys#slot bucket 1)) ) ) ) )
815                ; Slow path
816                (let loop ([bucket (##sys#slot vec hshidx)])
817                  (if (null? bucket)
818                      (def)
819                      (let ([pare (##sys#slot bucket 0)])
820                        (if (test key (##sys#slot pare 0))
821                            (##sys#slot pare 1)
822                            (loop (##sys#slot bucket 1)) ) ) ) ) ) ) ) ) )
823   hash-table-set!) )
824
825(define hash-table-ref/default
826  (let ([core-eq? eq?])
827    (lambda (ht key def)
828      (##sys#check-structure ht 'hash-table 'hash-table-ref/default)
829      (let  ([vec (##sys#slot ht 1)]
830             [test (##sys#slot ht 3)] )
831        (let* ([hash (##sys#slot ht 4)]
832               [hshidx (hash key (##sys#size vec))] )
833           (if (eq? core-eq? test)
834               ; Fast path (eq? is rewritten by the compiler):
835               (let loop ([bucket (##sys#slot vec hshidx)])
836                 (if (null? bucket)
837                     def
838                     (let ([pare (##sys#slot bucket 0)])
839                       (if (eq? key (##sys#slot pare 0))
840                           (##sys#slot pare 1)
841                           (loop (##sys#slot bucket 1)) ) ) ) )
842               ; Slow path
843               (let loop ([bucket (##sys#slot vec hshidx)])
844                 (if (null? bucket)
845                     def
846                     (let ([pare (##sys#slot bucket 0)])
847                       (if (test key (##sys#slot pare 0))
848                           (##sys#slot pare 1)
849                           (loop (##sys#slot bucket 1)) ) ) ) ) ) ) ) ) ) )
850
851(define hash-table-exists?
852  (let ([core-eq? eq?])
853    (lambda (ht key)
854      (##sys#check-structure ht 'hash-table 'hash-table-exists?)
855      (let  ([vec (##sys#slot ht 1)]
856             [test (##sys#slot ht 3)] )
857        (let* ([hash (##sys#slot ht 4)]
858               [hshidx (hash key (##sys#size vec))] )
859          (if (eq? core-eq? test)
860               ; Fast path (eq? is rewritten by the compiler):
861               (let loop ([bucket (##sys#slot vec hshidx)])
862                 (and (not (null? bucket))
863                      (let ([pare (##sys#slot bucket 0)])
864                        (or (eq? key (##sys#slot pare 0))
865                            (loop (##sys#slot bucket 1)) ) ) ) )
866               ; Slow path
867               (let loop ([bucket (##sys#slot vec hshidx)])
868                 (and (not (null? bucket))
869                      (let ([pare (##sys#slot bucket 0)])
870                        (or (test key (##sys#slot pare 0))
871                            (loop (##sys#slot bucket 1)) ) ) ) ) ) ) ) ) ) )
872
873;; hash-table-delete!:
874
875(define hash-table-delete!
876  (let ([core-eq? eq?])
877    (lambda (ht key)
878      (##sys#check-structure ht 'hash-table 'hash-table-delete!)
879      (let* ([vec (##sys#slot ht 1)]
880             [len (##sys#size vec)]
881             [hash (##sys#slot ht 4)]
882             [hshidx (hash key len)] )
883        (let ([test (##sys#slot ht 3)]
884              [newsiz (fx- (##sys#slot ht 2) 1)]
885              [bucket0 (##sys#slot vec hshidx)] )
886          (if (eq? core-eq? test)
887              ; Fast path (eq? is rewritten by the compiler):
888              (let loop ([prev #f] [bucket bucket0])
889                (and (not (null? bucket))
890                     (let ([pare (##sys#slot bucket 0)]
891                           [nxt (##sys#slot bucket 1)])
892                       (if (eq? key (##sys#slot pare 0))
893                           (begin
894                             (if prev
895                                 (##sys#setslot prev 1 nxt)
896                                 (##sys#setslot vec hshidx nxt) )
897                             (##sys#setislot ht 2 newsiz)
898                             #t )
899                           (loop bucket nxt) ) ) ) )
900              ; Slow path
901              (let loop ([prev #f] [bucket bucket0])
902                (and (not (null? bucket))
903                     (let ([pare (##sys#slot bucket 0)]
904                           [nxt (##sys#slot bucket 1)])
905                       (if (test key (##sys#slot pare 0))
906                           (begin
907                             (if prev
908                                 (##sys#setslot prev 1 nxt)
909                                 (##sys#setslot vec hshidx nxt) )
910                             (##sys#setislot ht 2 newsiz)
911                             #t )
912                           (loop bucket nxt) ) ) ) ) ) ) ) ) ) )
913
914;; hash-table-remove!:
915
916(define (hash-table-remove! ht func)
917  (##sys#check-structure ht 'hash-table 'hash-table-remove!)
918  (##sys#check-closure func 'hash-table-remove!)
919  (let* ([vec (##sys#slot ht 1)]
920         [len (##sys#size vec)] )
921    (let ([siz (##sys#slot ht 2)])
922      (do ([i 0 (fx+ i 1)])
923          [(fx>= i len) (##sys#setislot ht 2 siz)]
924        (let loop ([prev #f] [bucket (##sys#slot vec i)])
925          (and (not (null? bucket))
926               (let ([pare (##sys#slot bucket 0)]
927                     [nxt (##sys#slot bucket 1)])
928                 (if (func (##sys#slot pare 0) (##sys#slot pare 1))
929                     (begin
930                       (if prev
931                           (##sys#setslot prev 1 nxt)
932                           (##sys#setslot vec i nxt) )
933                       (set! siz (fx- siz 1))
934                       #t )
935                     (loop bucket nxt ) ) ) ) ) ) ) ) )
936
937;; hash-table-clear!:
938
939(define (hash-table-clear! ht)
940  (##sys#check-structure ht 'hash-table 'hash-table-clear!)
941  (vector-fill! (##sys#slot ht 1) '())
942  (##sys#setislot ht 2 0) )
943
944;; Hash Table Merge:
945
946(define (*hash-table-merge! ht1 ht2)
947  (let* ([vec (##sys#slot ht2 1)]
948         [len (##sys#size vec)] )
949    (do ([i 0 (fx+ i 1)])
950        [(fx>= i len) ht1]
951      (do ([lst (##sys#slot vec i) (##sys#slot lst 1)])
952          [(null? lst)]
953        (let ([b (##sys#slot lst 0)])
954          (*hash-table-update!/default ht1 (##sys#slot b 0) identity (##sys#slot b 1)) ) ) ) ) )
955
956(define (hash-table-merge! ht1 ht2)
957  (##sys#check-structure ht1 'hash-table 'hash-table-merge!)
958  (##sys#check-structure ht2 'hash-table 'hash-table-merge!)
959  (*hash-table-merge! ht1 ht2) )
960
961(define (hash-table-merge ht1 ht2)
962  (##sys#check-structure ht1 'hash-table 'hash-table-merge)
963  (##sys#check-structure ht2 'hash-table 'hash-table-merge)
964  (*hash-table-merge! (*hash-table-copy ht1) ht2) )
965
966;; Hash-Table <-> Association-List:
967
968(define (hash-table->alist ht)
969  (##sys#check-structure ht 'hash-table 'hash-table->alist)
970  (let* ([vec (##sys#slot ht 1)]
971         [len (##sys#size vec)] )
972    (let loop ([i 0] [lst '()])
973      (if (fx>= i len)
974          lst
975          (let loop2 ([bucket (##sys#slot vec i)]
976                      [lst lst])
977            (if (null? bucket)
978                (loop (fx+ i 1) lst)
979                (loop2 (##sys#slot bucket 1)
980                       (let ([x (##sys#slot bucket 0)])
981                         (cons (cons (##sys#slot x 0) (##sys#slot x 1)) lst) ) ) ) ) ) ) ) )
982
983(define alist->hash-table
984  (let ([make-hash-table make-hash-table])
985    (lambda (alist . rest)
986      (##sys#check-list alist 'alist->hash-table)
987      (let ([ht (apply make-hash-table rest)])
988        (for-each
989         (lambda (x)
990           (##sys#check-pair x 'alist->hash-table)
991           (*hash-table-update!/default  ht (##sys#slot x 0) identity (##sys#slot x 1)) )
992         alist)
993        ht ) ) ) )
994
995;; Hash-Table Keys & Values:
996
997(define (hash-table-keys ht)
998  (##sys#check-structure ht 'hash-table 'hash-table-keys)
999  (let* ([vec (##sys#slot ht 1)]
1000         [len (##sys#size vec)] )
1001    (let loop ([i 0] [lst '()])
1002      (if (fx>= i len)
1003          lst
1004          (let loop2 ([bucket (##sys#slot vec i)]
1005                      [lst lst])
1006            (if (null? bucket)
1007                (loop (fx+ i 1) lst)
1008                (loop2 (##sys#slot bucket 1)
1009                       (let ([x (##sys#slot bucket 0)])
1010                         (cons (##sys#slot x 0) lst) ) ) ) ) ) ) ) )
1011
1012(define (hash-table-values ht)
1013  (##sys#check-structure ht 'hash-table 'hash-table-values)
1014  (let* ([vec (##sys#slot ht 1)]
1015         [len (##sys#size vec)] )
1016    (let loop ([i 0] [lst '()])
1017      (if (fx>= i len)
1018          lst
1019          (let loop2 ([bucket (##sys#slot vec i)]
1020                      [lst lst])
1021            (if (null? bucket)
1022                (loop (fx+ i 1) lst)
1023                (loop2 (##sys#slot bucket 1)
1024                       (let ([x (##sys#slot bucket 0)])
1025                         (cons (##sys#slot x 1) lst) ) ) ) ) ) ) ) )
1026
1027;; Mapping Over Hash-Table Keys & Values:
1028;;
1029;; hash-table-for-each:
1030;; hash-table-walk:
1031;; hash-table-fold:
1032;; hash-table-map:
1033
1034(define (*hash-table-for-each ht proc)
1035  (let* ([vec (##sys#slot ht 1)]
1036         [len (##sys#size vec)] )
1037    (do ([i 0 (fx+ i 1)] )
1038        [(fx>= i len)]
1039      (##sys#for-each (lambda (bucket)
1040                        (proc (##sys#slot bucket 0) (##sys#slot bucket 1)) )
1041                      (##sys#slot vec i)) ) ) )
1042
1043(define (*hash-table-fold ht func init)
1044  (let* ([vec (##sys#slot ht 1)]
1045         [len (##sys#size vec)] )
1046    (let loop ([i 0] [acc init])
1047      (if (fx>= i len)
1048          acc
1049          (let fold2 ([bucket (##sys#slot vec i)]
1050                      [acc acc])
1051            (if (null? bucket)
1052                (loop (fx+ i 1) acc)
1053                (let ([pare (##sys#slot bucket 0)])
1054                  (fold2 (##sys#slot bucket 1)
1055                         (func (##sys#slot pare 0) (##sys#slot pare 1) acc) ) ) ) ) ) ) ) )
1056
1057(define (hash-table-fold ht func init)
1058  (##sys#check-structure ht 'hash-table 'hash-table-fold)
1059  (##sys#check-closure func 'hash-table-fold)
1060  (*hash-table-fold ht func init) )
1061
1062(define (hash-table-for-each ht proc)
1063  (##sys#check-structure ht 'hash-table 'hash-table-for-each)
1064  (##sys#check-closure proc 'hash-table-for-each)
1065  (*hash-table-for-each ht proc) )
1066
1067(define (hash-table-walk ht proc)
1068  (##sys#check-structure ht 'hash-table 'hash-table-walk)
1069  (##sys#check-closure proc 'hash-table-walk)
1070  (*hash-table-for-each ht proc) )
1071
1072(define (hash-table-map ht func)
1073  (##sys#check-structure ht 'hash-table 'hash-table-map)
1074  (##sys#check-closure func 'hash-table-map)
1075  (*hash-table-fold ht (lambda (k v a) (cons (func k v) a)) '()) )
Note: See TracBrowser for help on using the repository browser.