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

Last change on this file since 39748 was 39748, checked in by Mario Domenech Goulart, 8 weeks ago

release/5/srfi-69/trunk: cache current min and max length based on load and *actually resize*

This is a patch by Peter Bex submitted to chicken-hackers. See
https://lists.nongnu.org/archive/html/chicken-hackers/2021-03/msg00010.html

File size: 40.8 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* ((min-load-len (inexact->exact (floor (* len min-load)))) ;; Cached values to speed up hash-table-check-resize!
500             (max-load-len (inexact->exact (floor (* len max-load))))
501             (ht (##sys#make-structure 'hash-table
502                                       vec 0 test hash min-load max-load #f #f initial #f min-load-len max-load-len)))
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-fixnum 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-fixnum 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         (min-load (##sys#slot ht 5))
703         (new-min-load-len (inexact->exact (floor (* len min-load))))
704         (max-load (##sys#slot ht 6))
705         (new-max-load-len (inexact->exact (floor (* len max-load))))
706         (vec2 (make-vector newlen '())) )
707    (hash-table-rehash! vec vec2 (##sys#slot ht 10))
708    (##sys#setslot ht 1 vec2)
709    (##sys#setslot ht 11 new-min-load-len)
710    (##sys#setslot ht 12 new-max-load-len)) )
711
712;; hash-table-check-resize!:
713
714(define-inline (hash-table-check-resize! ht newsiz)
715  (let* ((vec (##sys#slot ht 1))
716         (min-load-len (##sys#slot ht 11))
717         (max-load-len (##sys#slot ht 12))
718         (len (##sys#size vec)))
719    (if (and (fx< len hash-table-max-length)
720             (fx<= min-load-len newsiz) (fx<= newsiz max-load-len))
721        (hash-table-resize! ht vec len) )   ) )
722
723;; hash-table-copy:
724
725(define *hash-table-copy
726  (let ((make-vector make-vector))
727    (lambda (ht)
728      (let* ((vec1 (##sys#slot ht 1))
729             (len (##sys#size vec1))
730             (vec2 (make-vector len '()))
731             (ht2 (do ((i 0 (fx+ i 1)))
732                      ((fx>= i len)
733                       (*make-hash-table
734                        (##sys#slot ht 3) (##sys#slot ht 4)
735                        (##sys#slot ht 2)
736                        (##sys#slot ht 5) (##sys#slot ht 6)
737                        (##sys#slot ht 7) (##sys#slot ht 8)
738                        (##sys#slot ht 9) vec2))
739                    (##sys#setslot vec2 i
740                                   (let copy-loop ((bucket (##sys#slot vec1 i)))
741                                     (if (null? bucket)
742                                         '()
743                                         (let ((pare (##sys#slot bucket 0)))
744                                           (cons (cons (##sys#slot pare 0) (##sys#slot pare 1))
745                                                 (copy-loop (##sys#slot bucket 1))))))) )))
746        ;; Size and randomized hashing function are reset by *make-hash-table,
747        ;; so we copy over the ones from the original hash table.
748        (##sys#setslot ht2 2 (##sys#slot ht 2))
749        (##sys#setslot ht2 10 (##sys#slot ht 10))
750        ht2 ) ) ) )
751
752(define (hash-table-copy ht)
753  (##sys#check-structure ht 'hash-table 'hash-table-copy)
754  (*hash-table-copy ht) )
755
756;; hash-table-update!:
757;;
758;; This one was suggested by Sven Hartrumpf (and subsequently added in SRFI-69).
759;; Modified for ht props min & max load.
760
761(define hash-table-update!
762  (let ([core-eq? eq?] )
763    (lambda (ht key func
764                #!optional
765                (thunk
766                 (let ([thunk (##sys#slot ht 9)])
767                   (or thunk
768                       (lambda ()
769                         (##sys#signal-hook
770                          #:access-error
771                          'hash-table-update!
772                          "hash-table does not contain key" key ht))))))
773      (##sys#check-structure ht 'hash-table 'hash-table-update!)
774      (##sys#check-closure func 'hash-table-update!)
775      (##sys#check-closure thunk 'hash-table-update!)
776      (let ([newsiz (fx+ (##sys#slot ht 2) 1)] )
777        (hash-table-check-resize! ht newsiz)
778        (let ([hash (##sys#slot ht 10)]
779              [test (##sys#slot ht 3)]
780              [vec (##sys#slot ht 1)])
781          (let* ([len (##sys#size vec)]
782                 [hshidx (hash key len)]
783                 [bucket0 (##sys#slot vec hshidx)] )
784            (if (eq? core-eq? test)
785                ; Fast path (eq? is rewritten by the compiler):
786                (let loop ([bucket bucket0])
787                  (if (null? bucket)
788                      (let ([val (func (thunk))])
789                        (##sys#setslot vec hshidx (cons (cons key val) bucket0))
790                        (##sys#setislot ht 2 newsiz)
791                        val )
792                      (let ([pare (##sys#slot bucket 0)])
793                         (if (eq? key (##sys#slot pare 0))
794                             (let ([val (func (##sys#slot pare 1))])
795                               (##sys#setslot pare 1 val)
796                               val)
797                             (loop (##sys#slot bucket 1)) ) ) ) )
798                ; Slow path
799                (let loop ([bucket bucket0])
800                  (if (null? bucket)
801                      (let ([val (func (thunk))])
802                        (##sys#setslot vec hshidx (cons (cons key val) bucket0))
803                        (##sys#setislot ht 2 newsiz)
804                        val )
805                      (let ([pare (##sys#slot bucket 0)])
806                         (if (test key (##sys#slot pare 0))
807                             (let ([val (func (##sys#slot pare 1))])
808                               (##sys#setslot pare 1 val)
809                               val )
810                             (loop (##sys#slot bucket 1)) ) ) ) ) ) ) ) ) ) ) )
811
812(define *hash-table-update!/default
813  (let ([core-eq? eq?] )
814    (lambda (ht key func def)
815      (let ([newsiz (fx+ (##sys#slot ht 2) 1)] )
816        (hash-table-check-resize! ht newsiz)
817        (let ([hash (##sys#slot ht 10)]
818              [test (##sys#slot ht 3)]
819              [vec (##sys#slot ht 1)])
820          (let* ([len (##sys#size vec)]
821                 [hshidx (hash key len)]
822                 [bucket0 (##sys#slot vec hshidx)] )
823            (if (eq? core-eq? test)
824                ; Fast path (eq? is rewritten by the compiler):
825                (let loop ([bucket bucket0])
826                  (if (null? bucket)
827                      (let ([val (func def)])
828                        (##sys#setslot vec hshidx (cons (cons key val) bucket0))
829                        (##sys#setislot ht 2 newsiz)
830                        val )
831                      (let ([pare (##sys#slot bucket 0)])
832                         (if (eq? key (##sys#slot pare 0))
833                             (let ([val (func (##sys#slot pare 1))])
834                               (##sys#setslot pare 1 val)
835                               val)
836                             (loop (##sys#slot bucket 1)) ) ) ) )
837                ; Slow path
838                (let loop ([bucket bucket0])
839                  (if (null? bucket)
840                      (let ([val (func def)])
841                        (##sys#setslot vec hshidx (cons (cons key val) bucket0))
842                        (##sys#setislot ht 2 newsiz)
843                        val )
844                      (let ([pare (##sys#slot bucket 0)])
845                         (if (test key (##sys#slot pare 0))
846                             (let ([val (func (##sys#slot pare 1))])
847                               (##sys#setslot pare 1 val)
848                               val )
849                             (loop (##sys#slot bucket 1)) ) ) ) ) ) ) ) ) ) ) )
850
851(define (hash-table-update!/default ht key func def)
852  (##sys#check-structure ht 'hash-table 'hash-table-update!/default)
853  (##sys#check-closure func 'hash-table-update!/default)
854  (*hash-table-update!/default ht key func def) )
855
856(define hash-table-set!
857  (let ([core-eq? eq?] )
858    (lambda (ht key val)
859      (##sys#check-structure ht 'hash-table 'hash-table-set!)
860      (let ([newsiz (fx+ (##sys#slot ht 2) 1)] )
861        (hash-table-check-resize! ht newsiz)
862        (let ([hash (##sys#slot ht 10)]
863              [test (##sys#slot ht 3)]
864              [vec (##sys#slot ht 1)])
865          (let* ([len (##sys#size vec)]
866                 [hshidx (hash key len)]
867                 [bucket0 (##sys#slot vec hshidx)] )
868            (if (eq? core-eq? test)
869                ; Fast path (eq? is rewritten by the compiler):
870                (let loop ([bucket bucket0])
871                  (if (null? bucket)
872                      (begin
873                        (##sys#setslot vec hshidx (cons (cons key val) bucket0))
874                        (##sys#setislot ht 2 newsiz) )
875                      (let ([pare (##sys#slot bucket 0)])
876                         (if (eq? key (##sys#slot pare 0))
877                             (##sys#setslot pare 1 val)
878                             (loop (##sys#slot bucket 1)) ) ) ) )
879                ; Slow path
880                (let loop ([bucket bucket0])
881                  (if (null? bucket)
882                      (begin
883                        (##sys#setslot vec hshidx (cons (cons key val) bucket0))
884                        (##sys#setislot ht 2 newsiz) )
885                      (let ([pare (##sys#slot bucket 0)])
886                         (if (test key (##sys#slot pare 0))
887                             (##sys#setslot pare 1 val)
888                             (loop (##sys#slot bucket 1)) ) ) ) ) )
889            (void) ) ) ) ) ) )
890
891;; Hash-Table Reference:
892
893(define hash-table-ref
894  (getter-with-setter
895    (let ([core-eq? eq?])
896      (lambda (ht key #!optional (def (lambda ()
897                                        (##sys#signal-hook #:access-error
898                                         'hash-table-ref
899                                         "hash-table does not contain key" key ht))))
900        (##sys#check-structure ht 'hash-table 'hash-table-ref)
901        (##sys#check-closure def 'hash-table-ref)
902        (let  ([vec (##sys#slot ht 1)]
903               [test (##sys#slot ht 3)])
904          (let* ([hash (##sys#slot ht 10)]
905                 [hshidx (hash key (##sys#size vec))] )
906            (if (eq? core-eq? test)
907                ; Fast path (eq? is rewritten by the compiler):
908                (let loop ([bucket (##sys#slot vec hshidx)])
909                  (if (null? bucket)
910                      (def)
911                      (let ([pare (##sys#slot bucket 0)])
912                        (if (eq? key (##sys#slot pare 0))
913                            (##sys#slot pare 1)
914                            (loop (##sys#slot bucket 1)) ) ) ) )
915                ; Slow path
916                (let loop ([bucket (##sys#slot vec hshidx)])
917                  (if (null? bucket)
918                      (def)
919                      (let ([pare (##sys#slot bucket 0)])
920                        (if (test key (##sys#slot pare 0))
921                            (##sys#slot pare 1)
922                            (loop (##sys#slot bucket 1)) ) ) ) ) ) ) ) ) )
923   hash-table-set!
924   "(hash-table-ref ht key . def)") )
925
926(define hash-table-ref/default
927  (let ([core-eq? eq?])
928    (lambda (ht key def)
929      (##sys#check-structure ht 'hash-table 'hash-table-ref/default)
930      (let  ([vec (##sys#slot ht 1)]
931             [test (##sys#slot ht 3)])
932        (let* ([hash (##sys#slot ht 10)]
933               [hshidx (hash key (##sys#size vec))] )
934           (if (eq? core-eq? test)
935               ; Fast path (eq? is rewritten by the compiler):
936               (let loop ([bucket (##sys#slot vec hshidx)])
937                 (if (null? bucket)
938                     def
939                     (let ([pare (##sys#slot bucket 0)])
940                       (if (eq? key (##sys#slot pare 0))
941                           (##sys#slot pare 1)
942                           (loop (##sys#slot bucket 1)) ) ) ) )
943               ; Slow path
944               (let loop ([bucket (##sys#slot vec hshidx)])
945                 (if (null? bucket)
946                     def
947                     (let ([pare (##sys#slot bucket 0)])
948                       (if (test key (##sys#slot pare 0))
949                           (##sys#slot pare 1)
950                           (loop (##sys#slot bucket 1)) ) ) ) ) ) ) ) ) ) )
951
952(define hash-table-exists?
953  (let ([core-eq? eq?])
954    (lambda (ht key)
955      (##sys#check-structure ht 'hash-table 'hash-table-exists?)
956      (let  ([vec (##sys#slot ht 1)]
957             [test (##sys#slot ht 3)])
958        (let* ([hash (##sys#slot ht 10)]
959               [hshidx (hash key (##sys#size vec))] )
960          (if (eq? core-eq? test)
961               ; Fast path (eq? is rewritten by the compiler):
962               (let loop ([bucket (##sys#slot vec hshidx)])
963                 (and (not (null? bucket))
964                      (let ([pare (##sys#slot bucket 0)])
965                        (or (eq? key (##sys#slot pare 0))
966                            (loop (##sys#slot bucket 1)) ) ) ) )
967               ; Slow path
968               (let loop ([bucket (##sys#slot vec hshidx)])
969                 (and (not (null? bucket))
970                      (let ([pare (##sys#slot bucket 0)])
971                        (or (test key (##sys#slot pare 0))
972                            (loop (##sys#slot bucket 1)) ) ) ) ) ) ) ) ) ) )
973
974;; hash-table-delete!:
975
976(define hash-table-delete!
977  (let ([core-eq? eq?])
978    (lambda (ht key)
979      (##sys#check-structure ht 'hash-table 'hash-table-delete!)
980      (let* ([vec (##sys#slot ht 1)]
981             [len (##sys#size vec)]
982             [hash (##sys#slot ht 10)]
983             [hshidx (hash key len)] )
984        (let ([test (##sys#slot ht 3)]
985              [newsiz (fx- (##sys#slot ht 2) 1)]
986              [bucket0 (##sys#slot vec hshidx)] )
987          (if (eq? core-eq? test)
988              ; Fast path (eq? is rewritten by the compiler):
989              (let loop ([prev #f] [bucket bucket0])
990                (and (not (null? bucket))
991                     (let ([pare (##sys#slot bucket 0)]
992                           [nxt (##sys#slot bucket 1)])
993                       (if (eq? key (##sys#slot pare 0))
994                           (begin
995                             (if prev
996                                 (##sys#setslot prev 1 nxt)
997                                 (##sys#setslot vec hshidx nxt) )
998                             (##sys#setislot ht 2 newsiz)
999                             #t )
1000                           (loop bucket nxt) ) ) ) )
1001              ; Slow path
1002              (let loop ([prev #f] [bucket bucket0])
1003                (and (not (null? bucket))
1004                     (let ([pare (##sys#slot bucket 0)]
1005                           [nxt (##sys#slot bucket 1)])
1006                       (if (test key (##sys#slot pare 0))
1007                           (begin
1008                             (if prev
1009                                 (##sys#setslot prev 1 nxt)
1010                                 (##sys#setslot vec hshidx nxt) )
1011                             (##sys#setislot ht 2 newsiz)
1012                             #t )
1013                           (loop bucket nxt) ) ) ) ) ) ) ) ) ) )
1014
1015;; hash-table-remove!:
1016
1017(define (hash-table-remove! ht func)
1018  (##sys#check-structure ht 'hash-table 'hash-table-remove!)
1019  (##sys#check-closure func 'hash-table-remove!)
1020  (let* ([vec (##sys#slot ht 1)]
1021         [len (##sys#size vec)] )
1022    (let ([siz (##sys#slot ht 2)])
1023      (do ([i 0 (fx+ i 1)])
1024          [(fx>= i len) (##sys#setislot ht 2 siz)]
1025        (let loop ([prev #f] [bucket (##sys#slot vec i)])
1026          (and (not (null? bucket))
1027               (let ([pare (##sys#slot bucket 0)]
1028                     [nxt (##sys#slot bucket 1)])
1029                 (if (func (##sys#slot pare 0) (##sys#slot pare 1))
1030                     (begin
1031                       (if prev
1032                           (##sys#setslot prev 1 nxt)
1033                           (##sys#setslot vec i nxt) )
1034                       (set! siz (fx- siz 1))
1035                       #t )
1036                     (loop bucket nxt ) ) ) ) ) ) ) ) )
1037
1038;; hash-table-clear!:
1039
1040(define (hash-table-clear! ht)
1041  (##sys#check-structure ht 'hash-table 'hash-table-clear!)
1042  (vector-fill! (##sys#slot ht 1) '())
1043  (##sys#setislot ht 2 0) )
1044
1045;; Hash Table Merge:
1046
1047(define (*hash-table-merge! ht1 ht2)
1048  (let* ([vec (##sys#slot ht2 1)]
1049         [len (##sys#size vec)] )
1050    (do ([i 0 (fx+ i 1)])
1051        [(fx>= i len) ht1]
1052      (do ([lst (##sys#slot vec i) (##sys#slot lst 1)])
1053          [(null? lst)]
1054        (let ([b (##sys#slot lst 0)])
1055          (*hash-table-update!/default ht1 (##sys#slot b 0) (lambda (x) x) (##sys#slot b 1)) ) ) ) ) )
1056
1057(define (hash-table-merge! ht1 ht2)
1058  (##sys#check-structure ht1 'hash-table 'hash-table-merge!)
1059  (##sys#check-structure ht2 'hash-table 'hash-table-merge!)
1060  (*hash-table-merge! ht1 ht2) )
1061
1062(define (hash-table-merge ht1 ht2)
1063  (##sys#check-structure ht1 'hash-table 'hash-table-merge)
1064  (##sys#check-structure ht2 'hash-table 'hash-table-merge)
1065  (*hash-table-merge! (*hash-table-copy ht1) ht2) )
1066
1067;; Hash-Table <-> Association-List:
1068
1069(define (hash-table->alist ht)
1070  (##sys#check-structure ht 'hash-table 'hash-table->alist)
1071  (let* ([vec (##sys#slot ht 1)]
1072         [len (##sys#size vec)] )
1073    (let loop ([i 0] [lst '()])
1074      (if (fx>= i len)
1075          lst
1076          (let loop2 ([bucket (##sys#slot vec i)]
1077                      [lst lst])
1078            (if (null? bucket)
1079                (loop (fx+ i 1) lst)
1080                (loop2 (##sys#slot bucket 1)
1081                       (let ([x (##sys#slot bucket 0)])
1082                         (cons (cons (##sys#slot x 0) (##sys#slot x 1)) lst) ) ) ) ) ) ) ) )
1083
1084(define alist->hash-table
1085  (lambda (alist . rest)
1086    (##sys#check-list alist 'alist->hash-table)
1087    (let ([ht (apply make-hash-table rest)])
1088      (for-each
1089       (lambda (x)
1090         (##sys#check-pair x 'alist->hash-table)
1091         (*hash-table-update!/default  ht (##sys#slot x 0) (lambda (x) x) (##sys#slot x 1)) )
1092       alist)
1093      ht ) ) )
1094
1095;; Hash-Table Keys & Values:
1096
1097(define (hash-table-keys ht)
1098  (##sys#check-structure ht 'hash-table 'hash-table-keys)
1099  (let* ([vec (##sys#slot ht 1)]
1100         [len (##sys#size vec)] )
1101    (let loop ([i 0] [lst '()])
1102      (if (fx>= i len)
1103          lst
1104          (let loop2 ([bucket (##sys#slot vec i)]
1105                      [lst lst])
1106            (if (null? bucket)
1107                (loop (fx+ i 1) lst)
1108                (loop2 (##sys#slot bucket 1)
1109                       (let ([x (##sys#slot bucket 0)])
1110                         (cons (##sys#slot x 0) lst) ) ) ) ) ) ) ) )
1111
1112(define (hash-table-values ht)
1113  (##sys#check-structure ht 'hash-table 'hash-table-values)
1114  (let* ([vec (##sys#slot ht 1)]
1115         [len (##sys#size vec)] )
1116    (let loop ([i 0] [lst '()])
1117      (if (fx>= i len)
1118          lst
1119          (let loop2 ([bucket (##sys#slot vec i)]
1120                      [lst lst])
1121            (if (null? bucket)
1122                (loop (fx+ i 1) lst)
1123                (loop2 (##sys#slot bucket 1)
1124                       (let ([x (##sys#slot bucket 0)])
1125                         (cons (##sys#slot x 1) lst) ) ) ) ) ) ) ) )
1126
1127;; Mapping Over Hash-Table Keys & Values:
1128;;
1129;; hash-table-for-each:
1130;; hash-table-walk:
1131;; hash-table-fold:
1132;; hash-table-map:
1133
1134(define (*hash-table-for-each ht proc)
1135  (let* ([vec (##sys#slot ht 1)]
1136         [len (##sys#size vec)] )
1137    (do ([i 0 (fx+ i 1)] )
1138        [(fx>= i len)]
1139      (##sys#for-each (lambda (bucket)
1140                        (proc (##sys#slot bucket 0) (##sys#slot bucket 1)) )
1141                      (##sys#slot vec i)) ) ) )
1142
1143(define (*hash-table-fold ht func init)
1144  (let* ([vec (##sys#slot ht 1)]
1145         [len (##sys#size vec)] )
1146    (let loop ([i 0] [acc init])
1147      (if (fx>= i len)
1148          acc
1149          (let fold2 ([bucket (##sys#slot vec i)]
1150                      [acc acc])
1151            (if (null? bucket)
1152                (loop (fx+ i 1) acc)
1153                (let ([pare (##sys#slot bucket 0)])
1154                  (fold2 (##sys#slot bucket 1)
1155                         (func (##sys#slot pare 0) (##sys#slot pare 1) acc) ) ) ) ) ) ) ) )
1156
1157(define (hash-table-fold ht func init)
1158  (##sys#check-structure ht 'hash-table 'hash-table-fold)
1159  (##sys#check-closure func 'hash-table-fold)
1160  (*hash-table-fold ht func init) )
1161
1162(define (hash-table-for-each ht proc)
1163  (##sys#check-structure ht 'hash-table 'hash-table-for-each)
1164  (##sys#check-closure proc 'hash-table-for-each)
1165  (*hash-table-for-each ht proc) )
1166
1167(define (hash-table-walk ht proc)
1168  (##sys#check-structure ht 'hash-table 'hash-table-walk)
1169  (##sys#check-closure proc 'hash-table-walk)
1170  (*hash-table-for-each ht proc) )
1171
1172(define (hash-table-map ht func)
1173  (##sys#check-structure ht 'hash-table 'hash-table-map)
1174  (##sys#check-closure func 'hash-table-map)
1175  (*hash-table-fold ht (lambda (k v a) (cons (func k v) a)) '()) )
1176
1177
1178;;; printing
1179
1180(##sys#register-record-printer
1181 'hash-table
1182 (lambda (ht port)
1183   (##sys#print "#<hash-table (" #f port)
1184   (##sys#print (##sys#slot ht 2) #f port)
1185   (##sys#print ")>" #f port) ) )
1186
1187)
Note: See TracBrowser for help on using the repository browser.