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

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

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

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