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

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

release/5: Replace use by import in eggs

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