Context Navigation

srfi-69.scm @ 12021

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

Note: See TracBrowser for help on using the repository browser.

Context Navigation

source: project/chicken/branches/hygienic/srfi-69.scm @ 12021

Download in other formats: