source: project/release/5/srfi-69/trunk/srfi-69.scm @ 37833

Last change on this file since 37833 was 37833, checked in by sjamaan, 21 months ago

srfi-69: Use ##sys#check-fixnum instead of ##sys#check-exact on bounds

In CHICKEN 4, ##sys#check-exact was what we now call ##sys#check-fixnum
but the SRFI-69 code hasn't been updated to match it.

Fixes #1631

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