source: project/chicken/branches/scrutiny/srfi-69.scm @ 13965

Last change on this file since 13965 was 13965, checked in by felix winkelmann, 12 years ago

merged trunk rev. 13953

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