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

Last change on this file since 34252 was 34252, checked in by sjamaan, 2 years ago

srfi-69: Use C_s_a_u_i_flo_to_int instead of C_i_inexact_to_exact

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