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

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

merged trunk changes until 14826 into scrutiny branch

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