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

Last change on this file since 14801 was 14801, checked in by felix winkelmann, 11 years ago

string-hash[-ci] redundancy slightly improved

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