source: project/chicken/branches/chicken-3/srfi-69.scm @ 12117

Last change on this file since 12117 was 12117, checked in by Kon Lovett, 12 years ago

PCRE 7.8, use of "full" flonum-hash, new scheme-complete by Alex Shinn.

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