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

Last change on this file since 11988 was 11988, checked in by Kon Lovett, 13 years ago

Specialized source for ref & update operations. An attempt to compensate for the closure heavy SRFI 69 API.

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