source: project/chicken/branches/prerelease/srfi-69.scm @ 11043

Last change on this file since 11043 was 11043, checked in by Ivan Raikov, 12 years ago

Synchronized trunk with prerelease and set version number to 3.3.0.

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