source: project/chicken/branches/prerelease/extras.scm @ 9599

Last change on this file since 9599 was 9599, checked in by Ivan Raikov, 12 years ago

Merged trunk with prerelease branch.

File size: 77.0 KB
Line 
1;;; extras.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 extras)
30 (usual-integrations)
31 (disable-warning redef)
32 (foreign-declare #<<EOF
33#define C_hashptr(x)   C_fix(x & C_MOST_POSITIVE_FIXNUM)
34#define C_mem_compare(to, from, n)   C_fix(C_memcmp(C_c_string(to), C_c_string(from), C_unfix(n)))
35EOF
36) )
37
38(cond-expand
39 [paranoia]
40 [else
41  (declare
42    (no-bound-checks)
43    (no-procedure-checks-for-usual-bindings)
44    (bound-to-procedure
45      ##sys#check-char ##sys#check-exact ##sys#check-port ##sys#check-string
46      ##sys#substring ##sys#for-each ##sys#map ##sys#setslot
47      ##sys#allocate-vector ##sys#check-pair ##sys#not-a-proper-list-error
48      ##sys#member ##sys#assoc ##sys#error ##sys#signal-hook ##sys#read-string!
49      ##sys#check-symbol ##sys#check-vector ##sys#floor ##sys#ceiling
50      ##sys#truncate ##sys#round ##sys#check-number ##sys#cons-flonum
51      ##sys#flonum-fraction ##sys#make-port ##sys#fetch-and-check-port-arg
52      ##sys#print ##sys#check-structure ##sys#make-structure make-parameter
53      ##sys#flush-output ##sys#write-char-0 ##sys#number->string
54      ##sys#fragments->string ##sys#symbol->qualified-string
55      ##extras#reverse-string-append ##sys#number? ##sys#procedure->string
56      ##sys#pointer->string ##sys#user-print-hook ##sys#peek-char-0
57      ##sys#read-char-0 ##sys#write-char ##sys#string-append ##sys#gcd ##sys#lcm
58      ##sys#fudge ##sys#check-list ##sys#user-read-hook ##sys#check-closure ##sys#check-inexact
59      ##extras#%equal?-hash
60      input-port? make-vector list->vector sort! merge! open-output-string floor
61      get-output-string current-output-port display write port? list->string
62      make-string string pretty-print-width newline char-name read random
63      open-input-string make-string call-with-input-file read-line reverse ) ) ] )
64
65(private extras
66  reverse-string-append
67  fprintf0 generic-write
68  unbound-value-thunk
69  %object-uid-hash %eq?-hash %eqv?-hash %equal?-hash
70  %hash-table-copy %hash-table-ref %hash-table-update! %hash-table-merge!
71  %hash-table-for-each %hash-table-fold
72  hash-table-canonical-length hash-table-rehash )
73
74(declare
75  (hide
76    fprintf0 generic-write
77    unbound-value-thunk
78    %object-uid-hash %eq?-hash %eqv?-hash %equal?-hash
79    %hash-table-copy %hash-table-ref %hash-table-update! %hash-table-merge!
80    %hash-table-for-each %hash-table-fold
81    hash-table-canonical-length hash-table-rehash) )
82
83(cond-expand
84 [unsafe
85  (eval-when (compile)
86    (define-macro (##sys#check-closure . _) '(##core#undefined))
87    (define-macro (##sys#check-inexact . _) '(##core#undefined))
88    (define-macro (##sys#check-structure . _) '(##core#undefined))
89    (define-macro (##sys#check-range . _) '(##core#undefined))
90    (define-macro (##sys#check-pair . _) '(##core#undefined))
91    (define-macro (##sys#check-list . _) '(##core#undefined))
92    (define-macro (##sys#check-symbol . _) '(##core#undefined))
93    (define-macro (##sys#check-string . _) '(##core#undefined))
94    (define-macro (##sys#check-char . _) '(##core#undefined))
95    (define-macro (##sys#check-exact . _) '(##core#undefined))
96    (define-macro (##sys#check-port . _) '(##core#undefined))
97    (define-macro (##sys#check-number . _) '(##core#undefined))
98    (define-macro (##sys#check-byte-vector . _) '(##core#undefined)) ) ]
99 [else
100  (declare (emit-exports "extras.exports")) ] )
101
102(register-feature! 'extras)
103
104
105;;; Unbound Value:
106
107;; This only works because of '(no-bound-checks)'
108
109(define-macro ($unbound-value)
110 '(##sys#slot '##sys#arbitrary-unbound-symbol 0) )
111
112(define unbound-value-thunk (lambda () ($unbound-value)))
113
114(define-macro ($unbound? ?val)
115  `(eq? ($unbound-value) ,?val) )
116
117
118;;; Core Inlines:
119
120(define-macro ($quick-flonum-truncate ?flo)
121  `(##core#inline "C_quickflonumtruncate" ,?flo) )
122
123(define-macro ($fix ?wrd)
124  `(##core#inline "C_fix" ,?wrd) )
125
126(define-macro ($block? ?obj)
127  `(##core#inline "C_blockp" ,?obj) )
128
129(define-macro ($special? ?obj)
130  `(##core#inline "C_specialp" ,?obj) )
131
132(define-macro ($port? ?obj)
133  `(##core#inline "C_portp" ,?obj) )
134
135(define-macro ($byte-block? ?obj)
136  `(##core#inline "C_byteblockp" ,?obj) )
137
138(define-macro ($hash-string ?str)
139  `(##core#inline "C_hash_string" ,?str) )
140
141(define-macro ($hash-string-ci ?str)
142  `(##core#inline "C_hash_string_ci" ,?str) )
143
144
145;;;
146
147(define-macro ($immediate? ?obj)
148  `(not ($block? ,?obj)) )
149
150
151;;; Read expressions from file:
152
153(define read-file
154  (let ([read read]
155        [reverse reverse] 
156        [call-with-input-file call-with-input-file] )
157    (lambda (#!optional (port ##sys#standard-input) (reader read) max)
158      (define (slurp port)
159        (do ((x (reader port) (reader port))
160             (i 0 (fx+ i 1))
161             (xs '() (cons x xs)) )
162            ((or (eof-object? x) (and max (fx>= i max))) (reverse xs)) ) )
163      (if (port? port)
164          (slurp port)
165          (call-with-input-file port slurp) ) ) ) )
166
167
168;;; Combinators:
169
170(define (identity x) x)
171
172(define (project n)
173  (lambda args (list-ref args n)) )
174
175(define (conjoin . preds)
176  (lambda (x)
177    (let loop ([preds preds])
178      (or (null? preds)
179          (and ((##sys#slot preds 0) x)
180               (loop (##sys#slot preds 1)) ) ) ) ) )
181
182(define (disjoin . preds)
183  (lambda (x)
184    (let loop ([preds preds])
185      (and (not (null? preds))
186           (or ((##sys#slot preds 0) x)
187               (loop (##sys#slot preds 1)) ) ) ) ) )
188
189(define (constantly . xs)
190  (if (eq? 1 (length xs))
191      (let ([x (car xs)])
192        (lambda _ x) )
193      (lambda _ (apply values xs)) ) )
194
195(define (flip proc) (lambda (x y) (proc y x)))
196
197(define complement
198  (lambda (p)
199    (lambda args (not (apply p args))) ) )
200
201(define (compose . fns)
202  (define (rec f0 . fns)
203    (if (null? fns)
204        f0
205        (lambda args
206          (call-with-values
207              (lambda () (apply (apply rec fns) args))
208            f0) ) ) )
209  (if (null? fns)
210      values
211      (apply rec fns) ) )
212
213(define (o . fns)
214  (if (null? fns)
215      identity
216      (let loop ((fns fns))
217        (let ((h (##sys#slot fns 0))
218              (t (##sys#slot fns 1)) )
219          (if (null? t)
220              h
221              (lambda (x) (h ((loop t) x))))))))
222
223(define (list-of pred)
224  (lambda (lst)
225    (let loop ([lst lst])
226      (cond [(null? lst) #t]
227            [(not-pair? lst) #f]
228            [(pred (##sys#slot lst 0)) (loop (##sys#slot lst 1))]
229            [else #f] ) ) ) )
230
231(define (noop . _) (void))
232
233(define (each . procs)
234  (cond ((null? procs) (lambda _ (void)))
235        ((null? (##sys#slot procs 1)) (##sys#slot procs 0))
236        (else
237         (lambda args
238           (let loop ((procs procs))
239             (let ((h (##sys#slot procs 0))
240                   (t (##sys#slot procs 1)) )
241               (if (null? t)
242                   (apply h args)
243                   (begin
244                     (apply h args)
245                     (loop t) ) ) ) ) ) ) ) )
246
247(define (any? x) #t)
248
249(define (none? x) #f)
250
251(define (always? . _) #t)
252
253(define (never? . _) #f)
254
255(define (left-section proc . args)
256  (##sys#check-closure proc 'left-section)
257  (lambda xs
258    (##sys#apply proc (##sys#append args xs)) ) )
259
260(define right-section
261  (let ([##sys#reverse reverse])
262    (lambda (proc . args)
263      (##sys#check-closure proc 'right-section)
264      (let ([revdargs (##sys#reverse args)])
265        (lambda xs
266          (##sys#apply proc (##sys#reverse (##sys#append revdargs (##sys#reverse xs)))) ) ) ) ) )
267
268
269;;; List operators:
270
271(define (atom? x) (##core#inline "C_i_not_pair_p" x))
272
273(define (tail? x y)
274  (##sys#check-list y 'tail?)
275  (or (##core#inline "C_eqp" x '())
276      (let loop ((y y))
277        (cond ((##core#inline "C_eqp" y '()) #f)
278              ((##core#inline "C_eqp" x y) #t)
279              (else (loop (##sys#slot y 1))) ) ) ) )
280
281(define intersperse 
282  (lambda (lst x)
283    (let loop ((ns lst))
284      (if (##core#inline "C_eqp" ns '())
285          ns
286          (let ((tail (cdr ns)))
287            (if (##core#inline "C_eqp" tail '())
288                ns
289                (cons (##sys#slot ns 0) (cons x (loop tail))) ) ) ) ) ) )
290
291(define (butlast lst)
292  (##sys#check-pair lst 'butlast)
293  (let loop ((lst lst))
294    (let ((next (##sys#slot lst 1)))
295      (if (and (##core#inline "C_blockp" next) (##core#inline "C_pairp" next))
296          (cons (##sys#slot lst 0) (loop next))
297          '() ) ) ) )
298
299(define (flatten . lists0)
300  (let loop ([lists lists0] [rest '()])
301    (cond [(null? lists) rest]
302          [else
303           (let ([head (##sys#slot lists 0)]
304                 [tail (##sys#slot lists 1)] )
305             (if (list? head)
306                 (loop head (loop tail rest))
307                 (cons head (loop tail rest)) ) ) ] ) ) )
308
309(define chop
310  (let ([reverse reverse])
311    (lambda (lst n)
312      (##sys#check-exact n 'chop)
313      (cond-expand
314       [(not unsafe) (when (fx<= n 0) (##sys#error 'chop "invalid numeric argument" n))]
315       [else] )
316      (let ([len (length lst)])
317        (let loop ([lst lst] [i len])
318          (cond [(null? lst) '()]
319                [(fx< i n) (list lst)]
320                [else
321                 (do ([hd '() (cons (##sys#slot tl 0) hd)]
322                      [tl lst (##sys#slot tl 1)] 
323                      [c n (fx- c 1)] )
324                     ((fx= c 0)
325                      (cons (reverse hd) (loop tl (fx- i n))) ) ) ] ) ) ) ) ) )
326
327(define (join lsts . lst)
328  (let ([lst (if (pair? lst) (car lst) '())])
329    (##sys#check-list lst 'join)
330    (let loop ([lsts lsts])
331      (cond [(null? lsts) '()]
332            [(cond-expand [unsafe #f] [else (not (pair? lsts))])
333             (##sys#not-a-proper-list-error lsts) ]
334            [else
335             (let ([l (##sys#slot lsts 0)]
336                   [r (##sys#slot lsts 1)] )
337               (if (null? r)
338                   l
339                   (##sys#append l lst (loop r)) ) ) ] ) ) ) )
340
341(define compress
342  (lambda (blst lst)
343    (let ([msg "bad argument type - not a proper list"])
344      (##sys#check-list lst 'compress)
345      (let loop ([blst blst] [lst lst])
346        (cond [(null? blst) '()]
347              [(cond-expand [unsafe #f] [else (not (pair? blst))])
348               (##sys#signal-hook #:type-error 'compress msg blst) ]
349              [(cond-expand [unsafe #f] [else (not (pair? lst))])
350               (##sys#signal-hook #:type-error 'compress msg lst) ]
351              [(##sys#slot blst 0) (cons (##sys#slot lst 0) (loop (##sys#slot blst 1) (##sys#slot lst 1)))]
352              [else (loop (##sys#slot blst 1) (##sys#slot lst 1))] ) ) ) ) )
353
354(define shuffle
355  ;; this should really shadow SORT! and RANDOM...
356  (lambda (l)
357    (let ((len (length l)))
358      (map cdr
359           (sort! (map (lambda (x) (cons (random len) x)) l)
360                  (lambda (x y) (< (car x) (car y)))) ) ) ) )
361
362
363;;; Alists:
364
365(define (alist-update! x y lst . cmp)
366  (let* ([cmp (if (pair? cmp) (car cmp) eqv?)]
367         [aq (cond [(eq? eq? cmp) assq]
368                   [(eq? eqv? cmp) assv]
369                   [(eq? equal? cmp) assoc]
370                   [else
371                    (lambda (x lst)
372                      (let loop ([lst lst])
373                        (and (pair? lst)
374                             (let ([a (##sys#slot lst 0)])
375                               (if (and (pair? a) (cmp (##sys#slot a 0) x))
376                                   a
377                                   (loop (##sys#slot lst 1)) ) ) ) ) ) ] ) ] 
378         [item (aq x lst)] )
379    (if item
380        (begin
381          (##sys#setslot item 1 y)
382          lst)
383        (cons (cons x y) lst) ) ) )
384
385(define (alist-ref x lst #!optional (cmp eqv?) (default #f))
386  (let* ([aq (cond [(eq? eq? cmp) assq]
387                   [(eq? eqv? cmp) assv]
388                   [(eq? equal? cmp) assoc]
389                   [else
390                    (lambda (x lst)
391                      (let loop ([lst lst])
392                        (and (pair? lst)
393                             (let ([a (##sys#slot lst 0)])
394                               (if (and (pair? a) (cmp (##sys#slot a 0) x))
395                                   a
396                                   (loop (##sys#slot lst 1)) ) ) ) ) ) ] ) ] 
397         [item (aq x lst)] )
398    (if item
399        (##sys#slot item 1)
400        default) ) )
401
402(define (rassoc x lst . tst)
403  (cond-expand [(not unsafe) (##sys#check-list lst 'rassoc)][else])
404  (let ([tst (if (pair? tst) (car tst) eqv?)])
405    (let loop ([l lst])
406      (and (pair? l)
407           (let ([a (##sys#slot l 0)])
408             (cond-expand [(not unsafe) (##sys#check-pair a 'rassoc)][else])
409             (if (tst x (##sys#slot a 1))
410                 a
411                 (loop (##sys#slot l 1)) ) ) ) ) ) )
412
413
414;;; Random numbers:
415
416(define random-seed
417    (let ((srand   (foreign-lambda void "srand" unsigned-integer)))
418        (lambda n
419            (and (> (length n) 1)
420                 (##sys#error 'random-seed "too many arguments" (length n) 1))
421            (let ((t   (if (null? n)
422                           (current-seconds)
423                           (car n))))
424                (##sys#check-integer t 'random-seed)
425                (srand t)))))
426
427(define (random n)
428  (##sys#check-exact n 'random)
429  (if (eq? n 0)
430      0
431      (##core#inline "C_random_fixnum" n) ) )
432
433(define (randomize . n)
434  (##core#inline
435   "C_randomize"
436   (if (##core#inline "C_eqp" n '())
437       (##sys#fudge 2)
438       (let ((nn (##sys#slot n 0)))
439         (##sys#check-exact nn 'randomize)
440         nn) ) ) )
441
442
443;;; Line I/O:
444
445(define read-line
446  (let ([make-string make-string])
447    (define (fixup str len)
448      (##sys#substring
449       str 0
450       (if (and (fx>= len 1) (char=? #\return (##core#inline "C_subchar" str (fx- len 1))))
451           (fx- len 1)
452           len) ) )
453    (lambda args
454      (let* ([parg (pair? args)]
455             [p (if parg (car args) ##sys#standard-input)]
456             [limit (and parg (pair? (cdr args)) (cadr args))])
457        (##sys#check-port p 'read-line)
458        (cond ((##sys#slot (##sys#slot p 2) 8) => (lambda (rl) (rl p limit)))
459              (else
460               (let* ((buffer-len (if limit limit 256))
461                      (buffer (##sys#make-string buffer-len)))
462                 (let loop ([i 0])
463                   (if (and limit (fx>= i limit))
464                       (##sys#substring buffer 0 i)
465                       (let ([c (##sys#read-char-0 p)])
466                         (if (eof-object? c)
467                             (if (fx= i 0)
468                                 c
469                                 (##sys#substring buffer 0 i) ) 
470                             (case c
471                               [(#\newline) (##sys#substring buffer 0 i)]
472                               [(#\return)
473                                (let ([c (peek-char p)])
474                                  (if (char=? c #\newline)
475                                      (begin (##sys#read-char-0 p)
476                                             (##sys#substring buffer 0 i))
477                                      (##sys#substring buffer 0 i) ) ) ]
478                               [else
479                                (when (fx>= i buffer-len)
480                                  (set! buffer (##sys#string-append buffer (make-string buffer-len)))
481                                  (set! buffer-len (fx+ buffer-len buffer-len)) )
482                                (##core#inline "C_setsubchar" buffer i c)
483                                (loop (fx+ i 1)) ] ) ) ) ) ) ) ) ) ) ) ) )
484
485(define read-lines
486  (let ((read-line read-line)
487        (call-with-input-file call-with-input-file) 
488        (reverse reverse) )
489    (lambda port-and-max
490      (let* ((port (if (pair? port-and-max) (##sys#slot port-and-max 0) ##sys#standard-input))
491             (rest (and (pair? port-and-max) (##sys#slot port-and-max 1)))
492             (max (if (pair? rest) (##sys#slot rest 0) #f)) )
493        (define (doread port)
494          (let loop ((lns '())
495                     (n (or max 1000000000)) ) ; this is silly
496            (if (eq? n 0)
497                (reverse lns)
498                (let ((ln (read-line port)))
499                  (if (eof-object? ln)
500                      (reverse lns)
501                      (loop (cons ln lns) (fx- n 1)) ) ) ) ) )
502        (if (string? port)
503            (call-with-input-file port doread)
504            (begin
505              (##sys#check-port port 'read-lines)
506              (doread port) ) ) ) ) ) )
507
508
509;;; Extended I/O
510
511(define (##sys#read-string! n dest port start)
512  (cond ((eq? n 0) 0)
513        (else
514         (when (##sys#slot port 6)      ; peeked?
515           (##core#inline "C_setsubchar" dest start (##sys#read-char-0 port))
516           (set! start (fx+ start 1)) )
517         (let ((rdstring (##sys#slot (##sys#slot port 2) 7)))
518           (let loop ((start start) (n n) (m 0))
519             (let ((n2 (if rdstring
520                           (rdstring port n dest start) ; *** doesn't update port-position!
521                           (let ((c (##sys#read-char-0 port)))
522                             (if (eof-object? c)
523                                 0
524                                 (begin
525                                   (##core#inline "C_setsubchar" dest start c)
526                                   1) ) ) ) ) )
527               (cond ((eq? n2 0) m)
528                     ((or (not n) (fx< n2 n)) 
529                      (loop (fx+ start n2) (and n (fx- n n2)) (fx+ m n2)) )
530                     (else (fx+ n2 m))) ) ) ))))
531
532(define (read-string! n dest #!optional (port ##sys#standard-input) (start 0))
533  (##sys#check-port port 'read-string!)
534  (##sys#check-string dest 'read-string!)
535  (when n
536    (##sys#check-exact n 'read-string!)
537    (when (fx> (fx+ start n) (##sys#size dest))
538      (set! n (fx- (##sys#size dest) start))))
539  (##sys#check-exact start 'read-string!)
540  (##sys#read-string! n dest port start) )
541
542(define ##sys#read-string/port
543  (let ((open-output-string open-output-string)
544        (get-output-string get-output-string) )
545    (lambda (n p)
546      (##sys#check-port p 'read-string)
547      (cond (n (##sys#check-exact n 'read-string)
548               (let* ((str (##sys#make-string n))
549                      (n2 (##sys#read-string! n str p 0)) )
550                 (if (eq? n n2)
551                     str
552                     (##sys#substring str 0 n2))))
553            (else
554             (let ([str (open-output-string)])
555               (let loop ([n n])
556                 (or (and (eq? n 0) (get-output-string str))
557                     (let ([c (##sys#read-char-0 p)])
558                       (if (eof-object? c)
559                           (get-output-string str)
560                           (begin
561                             (##sys#write-char/port c str) 
562                             (loop (and n (fx- n 1))) ) ) ) ) ) ) ) ) ) ) )
563
564(define (read-string #!optional n (port ##sys#standard-input))
565  (##sys#read-string/port n port) )
566
567(define read-token
568  (let ([open-output-string open-output-string]
569        [get-output-string get-output-string] )
570    (lambda (pred . port)
571      (let ([port (:optional port ##sys#standard-input)])
572        (##sys#check-port port 'read-token)
573        (let ([out (open-output-string)])
574          (let loop ()
575            (let ([c (##sys#peek-char-0 port)])
576              (if (and (not (eof-object? c)) (pred c))
577                  (begin
578                    (##sys#write-char-0 (##sys#read-char-0 port) out)
579                    (loop) )
580                  (get-output-string out) ) ) ) ) ) ) ) )
581
582(define write-string 
583  (let ([display display])
584    (lambda (s . more)
585      (##sys#check-string s 'write-string)
586      (let-optionals more ([n #f] [port ##sys#standard-output])
587        (##sys#check-port port 'write-string)
588        (when n (##sys#check-exact n 'write-string))
589        (display
590         (if (and n (fx< n (##sys#size s)))
591             (##sys#substring s 0 n)
592             s)
593         port) ) ) ) )
594
595(define write-line
596  (let ((display display)
597        (newline newline) )
598    (lambda (str . port)
599      (let ((p (if (##core#inline "C_eqp" port '())
600                   ##sys#standard-output
601                   (##sys#slot port 0) ) ) )
602        (##sys#check-port p 'write-line)
603        (##sys#check-string str 'write-line)
604        (display str p)
605        (newline p) ) ) ) )
606
607
608;;; Binary I/O
609
610(define (read-byte #!optional (port ##sys#standard-input))
611  (##sys#check-port port 'read-byte)
612  (let ((x (##sys#read-char-0 port)))
613    (if (eof-object? x)
614        x
615        (char->integer x) ) ) )
616
617(define (write-byte byte #!optional (port ##sys#standard-output))
618  (##sys#check-exact byte 'write-byte)
619  (##sys#check-port port 'write-byte)
620  (##sys#write-char-0 (integer->char byte) port) )
621
622
623;;; Redirect standard ports:
624
625(define (with-input-from-port port thunk)
626  (##sys#check-port port 'with-input-from-port)
627  (fluid-let ([##sys#standard-input port])
628    (thunk) ) )
629
630(define (with-output-to-port port thunk)
631  (##sys#check-port port 'with-output-from-port)
632  (fluid-let ([##sys#standard-output port])
633    (thunk) ) )
634
635(define (with-error-output-to-port port thunk)
636  (##sys#check-port port 'with-error-output-from-port)
637  (fluid-let ([##sys#standard-error port])
638    (thunk) ) )
639
640
641;;; Extended string-port operations:
642 
643(define call-with-input-string 
644  (let ([open-input-string open-input-string])
645    (lambda (str proc)
646      (let ((in (open-input-string str)))
647        (proc in) ) ) ) )
648
649(define call-with-output-string
650  (let ((open-output-string open-output-string)
651        (get-output-string get-output-string) )
652    (lambda (proc)
653      (let ((out (open-output-string)))
654        (proc out)
655        (get-output-string out) ) ) ) )
656
657(define with-input-from-string
658  (let ((open-input-string open-input-string))
659    (lambda (str thunk)
660      (fluid-let ([##sys#standard-input (open-input-string str)])
661        (thunk) ) ) ) )
662
663(define with-output-to-string
664  (let ([open-output-string open-output-string]
665        [get-output-string get-output-string] )
666    (lambda (thunk)
667      (fluid-let ([##sys#standard-output (open-output-string)])
668        (thunk) 
669        (get-output-string ##sys#standard-output) ) ) ) )
670
671
672;;; Custom ports:
673;
674; - Port-slots:
675;
676;   10: last
677
678(define make-input-port
679  (lambda (read ready? close #!optional peek read-string read-line)
680    (let* ((class
681            (vector
682             (lambda (p)                ; read-char
683               (let ([last (##sys#slot p 10)])
684                 (cond [peek (read)]
685                       [last
686                        (##sys#setislot p 10 #f)
687                        last]
688                       [else (read)] ) ) )
689             (lambda (p)                ; peek-char
690               (let ([last (##sys#slot p 10)])
691                 (cond [peek (peek)]
692                       [last last]
693                       [else
694                        (let ([last (read)])
695                          (##sys#setslot p 10 last)
696                          last) ] ) ) )
697             #f                         ; write-char
698             #f                         ; write-string
699             (lambda (p)                ; close
700               (close)
701               (##sys#setislot p 8 #t) )
702             #f                         ; flush-output
703             (lambda (p)                ; char-ready?
704               (ready?) )
705             read-string                ; read-string!
706             read-line) )               ; read-line
707           (data (vector #f))
708           (port (##sys#make-port #t class "(custom)" 'custom)) )
709      (##sys#setslot port 9 data) 
710      port) ) )
711
712(define make-output-port
713  (let ([string string])
714    (lambda (write close #!optional flush)
715      (let* ((class
716              (vector
717               #f                       ; read-char
718               #f                       ; peek-char
719               (lambda (p c)            ; write-char
720                 (write (string c)) )
721               (lambda (p s)            ; write-string
722                 (write s) )
723               (lambda (p)              ; close
724                 (close)
725                 (##sys#setislot p 8 #t) )
726               (lambda (p)              ; flush-output
727                 (when flush (flush)) )
728               #f                       ; char-ready?
729               #f                       ; read-string!
730               #f) )                    ; read-line
731             (data (vector #f))
732             (port (##sys#make-port #f class "(custom)" 'custom)) )
733        (##sys#setslot port 9 data) 
734        port) ) ) )
735
736
737;;; Pretty print:
738;
739; Copyright (c) 1991, Marc Feeley
740; Author: Marc Feeley (feeley@iro.umontreal.ca)
741; Distribution restrictions: none
742;
743; Modified by felix for use with CHICKEN
744;
745
746(define generic-write
747  (let ([open-output-string open-output-string]
748        [get-output-string get-output-string] )
749    (lambda (obj display? width output)
750
751      (define (read-macro? l)
752        (define (length1? l) (and (pair? l) (null? (cdr l))))
753        (let ((head (car l)) (tail (cdr l)))
754          (case head
755            ((quote quasiquote unquote unquote-splicing) (length1? tail))
756            (else                                        #f))))
757
758      (define (read-macro-body l)
759        (cadr l))
760
761      (define (read-macro-prefix l)
762        (let ((head (car l)) (tail (cdr l)))
763          (case head
764            ((quote)            "'")
765            ((quasiquote)       "`")
766            ((unquote)          ",")
767            ((unquote-splicing) ",@"))))
768
769      (define (out str col)
770        (and col (output str) (+ col (string-length str))))
771
772      (define (wr obj col)
773
774        (define (wr-expr expr col)
775          (if (read-macro? expr)
776              (wr (read-macro-body expr) (out (read-macro-prefix expr) col))
777              (wr-lst expr col)))
778
779        (define (wr-lst l col)
780          (if (pair? l)
781              (let loop ((l (cdr l))
782                         (col (and col (wr (car l) (out "(" col)))))
783                (cond ((not col) col)
784                      ((pair? l)
785                       (loop (cdr l) (wr (car l) (out " " col))))
786                      ((null? l) (out ")" col))
787                      (else      (out ")" (wr l (out " . " col))))))
788              (out "()" col)))
789
790        (cond ((pair? obj)        (wr-expr obj col))
791              ((null? obj)        (wr-lst obj col))
792              ((eof-object? obj)  (out "#<eof>" col))
793              ((vector? obj)      (wr-lst (vector->list obj) (out "#" col)))
794              ((boolean? obj)     (out (if obj "#t" "#f") col))
795              ((##sys#number? obj)      (out (##sys#number->string obj) col))
796              ((symbol? obj)
797               (let ([s (open-output-string)])
798                 (##sys#print obj #t s)
799                 (out (get-output-string s) col) ) )
800              ((procedure? obj)   (out (##sys#procedure->string obj) col))
801              ((string? obj)      (if display?
802                                      (out obj col)
803                                      (let loop ((i 0) (j 0) (col (out "\"" col)))
804                                        (if (and col (< j (string-length obj)))
805                                            (let ((c (string-ref obj j)))
806                                              (if (or (char=? c #\\)
807                                                      (char=? c #\"))
808                                                  (loop j
809                                                        (+ j 1)
810                                                        (out "\\"
811                                                             (out (##sys#substring obj i j)
812                                                                  col)))
813                                                  (loop i (+ j 1) col)))
814                                            (out "\""
815                                                 (out (##sys#substring obj i j) col))))))
816              ((char? obj)        (if display?
817                                      (out (make-string 1 obj) col)
818                                      (let ([code (char->integer obj)])
819                                        (out "#\\" col)
820                                        (cond [(char-name obj) 
821                                               => (lambda (cn) 
822                                                    (out (##sys#slot cn 1) col) ) ]
823                                              [(fx< code 32)
824                                               (out "x" col)
825                                               (out (number->string code 16) col) ]
826                                              [(fx> code 255)
827                                               (out (if (fx> code #xffff) "U" "u") col)
828                                               (out (number->string code 16) col) ]
829                                              [else (out (make-string 1 obj) col)] ) ) ) )
830              ((eof-object? obj)  (out "#<eof>" col))
831              ((##core#inline "C_undefinedp" obj) (out "#<unspecified>" col))
832              ((##core#inline "C_anypointerp" obj) (out (##sys#pointer->string obj) col))
833              ((eq? obj (##sys#slot '##sys#arbitrary-unbound-symbol 0))
834               (out "#<unbound value>" col) )
835              ((##sys#generic-structure? obj)
836               (let ([o (open-output-string)])
837                 (##sys#user-print-hook obj #t o)
838                 (out (get-output-string o) col) ) )
839              ((port? obj) (out (string-append "#<port " (##sys#slot obj 3) ">") col))
840              ((##core#inline "C_bytevectorp" obj)
841               (if (##core#inline "C_permanentp" obj)
842                   (out "#<static blob of size" col)
843                   (out "#<blob of size " col) )
844               (out (number->string (##core#inline "C_block_size" obj)) col)
845               (out ">" col) )
846              ((##core#inline "C_lambdainfop" obj)
847               (out "#<lambda info " col)
848               (out (##sys#lambda-info->string obj) col)
849               (out "#>" col) )
850              (else (out "#<unprintable object>" col)) ) )
851
852      (define (pp obj col)
853
854        (define (spaces n col)
855          (if (> n 0)
856              (if (> n 7)
857                  (spaces (- n 8) (out "        " col))
858                  (out (##sys#substring "        " 0 n) col))
859              col))
860
861        (define (indent to col)
862          (and col
863               (if (< to col)
864                   (and (out (make-string 1 #\newline) col) (spaces to 0))
865                   (spaces (- to col) col))))
866
867        (define (pr obj col extra pp-pair)
868          (if (or (pair? obj) (vector? obj)) ; may have to split on multiple lines
869              (let ((result '())
870                    (left (max (+ (- (- width col) extra) 1) max-expr-width)))
871                (generic-write obj display? #f
872                               (lambda (str)
873                                 (set! result (cons str result))
874                                 (set! left (- left (string-length str)))
875                                 (> left 0)))
876                (if (> left 0)          ; all can be printed on one line
877                    (out (reverse-string-append result) col)
878                    (if (pair? obj)
879                        (pp-pair obj col extra)
880                        (pp-list (vector->list obj) (out "#" col) extra pp-expr))))
881              (wr obj col)))
882
883        (define (pp-expr expr col extra)
884          (if (read-macro? expr)
885              (pr (read-macro-body expr)
886                  (out (read-macro-prefix expr) col)
887                  extra
888                  pp-expr)
889              (let ((head (car expr)))
890                (if (symbol? head)
891                    (let ((proc (style head)))
892                      (if proc
893                          (proc expr col extra)
894                          (if (> (string-length (##sys#symbol->qualified-string head))
895                                 max-call-head-width)
896                              (pp-general expr col extra #f #f #f pp-expr)
897                              (pp-call expr col extra pp-expr))))
898                    (pp-list expr col extra pp-expr)))))
899
900                                        ; (head item1
901                                        ;       item2
902                                        ;       item3)
903        (define (pp-call expr col extra pp-item)
904          (let ((col* (wr (car expr) (out "(" col))))
905            (and col
906                 (pp-down (cdr expr) col* (+ col* 1) extra pp-item))))
907
908                                        ; (item1
909                                        ;  item2
910                                        ;  item3)
911        (define (pp-list l col extra pp-item)
912          (let ((col (out "(" col)))
913            (pp-down l col col extra pp-item)))
914
915        (define (pp-down l col1 col2 extra pp-item)
916          (let loop ((l l) (col col1))
917            (and col
918                 (cond ((pair? l)
919                        (let ((rest (cdr l)))
920                          (let ((extra (if (null? rest) (+ extra 1) 0)))
921                            (loop rest
922                                  (pr (car l) (indent col2 col) extra pp-item)))))
923                       ((null? l)
924                        (out ")" col))
925                       (else
926                        (out ")"
927                             (pr l
928                                 (indent col2 (out "." (indent col2 col)))
929                                 (+ extra 1)
930                                 pp-item)))))))
931
932        (define (pp-general expr col extra named? pp-1 pp-2 pp-3)
933
934          (define (tail1 rest col1 col2 col3)
935            (if (and pp-1 (pair? rest))
936                (let* ((val1 (car rest))
937                       (rest (cdr rest))
938                       (extra (if (null? rest) (+ extra 1) 0)))
939                  (tail2 rest col1 (pr val1 (indent col3 col2) extra pp-1) col3))
940                (tail2 rest col1 col2 col3)))
941
942          (define (tail2 rest col1 col2 col3)
943            (if (and pp-2 (pair? rest))
944                (let* ((val1 (car rest))
945                       (rest (cdr rest))
946                       (extra (if (null? rest) (+ extra 1) 0)))
947                  (tail3 rest col1 (pr val1 (indent col3 col2) extra pp-2)))
948                (tail3 rest col1 col2)))
949
950          (define (tail3 rest col1 col2)
951            (pp-down rest col2 col1 extra pp-3))
952
953          (let* ((head (car expr))
954                 (rest (cdr expr))
955                 (col* (wr head (out "(" col))))
956            (if (and named? (pair? rest))
957                (let* ((name (car rest))
958                       (rest (cdr rest))
959                       (col** (wr name (out " " col*))))
960                  (tail1 rest (+ col indent-general) col** (+ col** 1)))
961                (tail1 rest (+ col indent-general) col* (+ col* 1)))))
962
963        (define (pp-expr-list l col extra)
964          (pp-list l col extra pp-expr))
965
966        (define (pp-lambda expr col extra)
967          (pp-general expr col extra #f pp-expr-list #f pp-expr))
968
969        (define (pp-if expr col extra)
970          (pp-general expr col extra #f pp-expr #f pp-expr))
971
972        (define (pp-cond expr col extra)
973          (pp-call expr col extra pp-expr-list))
974
975        (define (pp-case expr col extra)
976          (pp-general expr col extra #f pp-expr #f pp-expr-list))
977
978        (define (pp-and expr col extra)
979          (pp-call expr col extra pp-expr))
980
981        (define (pp-let expr col extra)
982          (let* ((rest (cdr expr))
983                 (named? (and (pair? rest) (symbol? (car rest)))))
984            (pp-general expr col extra named? pp-expr-list #f pp-expr)))
985
986        (define (pp-begin expr col extra)
987          (pp-general expr col extra #f #f #f pp-expr))
988
989        (define (pp-do expr col extra)
990          (pp-general expr col extra #f pp-expr-list pp-expr-list pp-expr))
991
992                                        ; define formatting style (change these to suit your style)
993
994        (define indent-general 2)
995
996        (define max-call-head-width 5)
997
998        (define max-expr-width 50)
999
1000        (define (style head)
1001          (case head
1002            ((lambda let* letrec define) pp-lambda)
1003            ((if set!)                   pp-if)
1004            ((cond)                      pp-cond)
1005            ((case)                      pp-case)
1006            ((and or)                    pp-and)
1007            ((let)                       pp-let)
1008            ((begin)                     pp-begin)
1009            ((do)                        pp-do)
1010            (else                        #f)))
1011
1012        (pr obj col 0 pp-expr))
1013
1014      (if width
1015          (out (make-string 1 #\newline) (pp obj 0))
1016          (wr obj 0)))) )
1017
1018; (reverse-string-append l) = (apply string-append (reverse l))
1019
1020(define (reverse-string-append l)
1021
1022  (define (rev-string-append l i)
1023    (if (pair? l)
1024      (let* ((str (car l))
1025             (len (string-length str))
1026             (result (rev-string-append (cdr l) (+ i len))))
1027        (let loop ((j 0) (k (- (- (string-length result) i) len)))
1028          (if (< j len)
1029            (begin
1030              (string-set! result k (string-ref str j))
1031              (loop (+ j 1) (+ k 1)))
1032            result)))
1033      (make-string i)))
1034
1035  (rev-string-append l 0))
1036
1037; (pretty-print obj port) pretty prints 'obj' on 'port'.  The current
1038; output port is used if 'port' is not specified.
1039
1040(define pretty-print-width (make-parameter 79))
1041
1042(define (pretty-print obj . opt)
1043  (let ((port (if (pair? opt) (car opt) (current-output-port))))
1044    (generic-write obj #f (pretty-print-width) (lambda (s) (display s port) #t))
1045    (##core#undefined) ) )
1046
1047(define pp pretty-print)
1048
1049
1050;;; Anything->string conversion:
1051
1052(define ->string 
1053  (let ([open-output-string open-output-string]
1054        [display display]
1055        [string string]
1056        [get-output-string get-output-string] )
1057    (lambda (x)
1058      (cond [(string? x) x]
1059            [(symbol? x) (symbol->string x)]
1060            [(char? x) (string x)]
1061            [(number? x) (##sys#number->string x)]
1062            [else
1063             (let ([o (open-output-string)])
1064               (display x o)
1065               (get-output-string o) ) ] ) ) ) )
1066
1067(define conc
1068  (let ([string-append string-append])
1069    (lambda args
1070      (apply string-append (map ->string args)) ) ) )
1071
1072
1073;;; Search one string inside another:
1074
1075(let ()
1076  (define (traverse which where start test loc)
1077    (##sys#check-string which loc)
1078    (##sys#check-string where loc)
1079    (let ([wherelen (##sys#size where)]
1080          [whichlen (##sys#size which)] )
1081      (##sys#check-exact start loc)
1082      (let loop ([istart start] [iend whichlen])
1083        (cond [(fx> iend wherelen) #f]
1084              [(test istart whichlen) istart]
1085              [else
1086               (loop (fx+ istart 1)
1087                     (fx+ iend 1) ) ] ) ) ) )
1088  (set! ##sys#substring-index 
1089    (lambda (which where start)
1090      (traverse 
1091       which where start
1092       (lambda (i l) (##core#inline "C_substring_compare" which where 0 i l))
1093       'substring-index) ) )
1094  (set! ##sys#substring-index-ci 
1095    (lambda (which where start)
1096      (traverse
1097       which where start
1098       (lambda (i l) (##core#inline "C_substring_compare_case_insensitive" which where 0 i l)) 
1099       'substring-index-ci) ) ) )
1100
1101(define (substring-index which where #!optional (start 0))
1102  (##sys#substring-index which where start) )
1103
1104(define (substring-index-ci which where #!optional (start 0))
1105  (##sys#substring-index-ci which where start) )
1106
1107
1108;;; 3-Way string comparison:
1109
1110(define (string-compare3 s1 s2)
1111  (##sys#check-string s1 'string-compare3)
1112  (##sys#check-string s2 'string-compare3)
1113  (let ((len1 (##sys#size s1))
1114        (len2 (##sys#size s2)) )
1115    (let* ((len-diff (fx- len1 len2)) 
1116           (cmp (##core#inline "C_mem_compare" s1 s2 (if (fx< len-diff 0) len1 len2))))
1117      (if (fx= cmp 0) 
1118          len-diff 
1119          cmp))))
1120
1121(define (string-compare3-ci s1 s2)
1122  (##sys#check-string s1 'string-compare3-ci)
1123  (##sys#check-string s2 'string-compare3-ci)
1124  (let ((len1 (##sys#size s1))
1125        (len2 (##sys#size s2)) )
1126    (let* ((len-diff (fx- len1 len2)) 
1127           (cmp (##core#inline "C_string_compare_case_insensitive" s1 s2 (if (fx< len-diff 0) len1 len2))))
1128      (if (fx= cmp 0) 
1129          len-diff 
1130          cmp))))
1131
1132
1133;;; Substring comparison:
1134
1135(define (##sys#substring=? s1 s2 start1 start2 n)
1136  (##sys#check-string s1 'substring=?)
1137  (##sys#check-string s2 'substring=?)
1138  (let ((len (or n
1139                 (fxmin (fx- (##sys#size s1) start1)
1140                        (fx- (##sys#size s2) start2) ) ) ) )
1141    (##sys#check-exact start1 'substring=?)
1142    (##sys#check-exact start2 'substring=?)
1143    (##core#inline "C_substring_compare" s1 s2 start1 start2 len) ) )
1144
1145(define (substring=? s1 s2 #!optional (start1 0) (start2 0) len)
1146  (##sys#substring=? s1 s2 start1 start2 len) )
1147
1148(define (##sys#substring-ci=? s1 s2 start1 start2 n)
1149  (##sys#check-string s1 'substring-ci=?)
1150  (##sys#check-string s2 'substring-ci=?)
1151  (let ((len (or n
1152                 (fxmin (fx- (##sys#size s1) start1)
1153                        (fx- (##sys#size s2) start2) ) ) ) )
1154    (##sys#check-exact start1 'substring-ci=?)
1155    (##sys#check-exact start2 'substring-ci=?)
1156    (##core#inline "C_substring_compare_case_insensitive"
1157                   s1 s2 start1 start2 len) ) )
1158
1159(define (substring-ci=? s1 s2 #!optional (start1 0) (start2 0) len)
1160  (##sys#substring-ci=? s1 s2 start1 start2 len) )
1161
1162
1163;;; Split string into substrings:
1164
1165(define string-split
1166  (lambda (str . delstr-and-flag)
1167    (##sys#check-string str 'string-split)
1168    (let* ([del (if (null? delstr-and-flag) "\t\n " (car delstr-and-flag))]
1169           [flag (if (fx= (length delstr-and-flag) 2) (cadr delstr-and-flag) #f)]
1170           [strlen (##sys#size str)] )
1171      (##sys#check-string del 'string-split)
1172      (let ([dellen (##sys#size del)] 
1173            [first #f] )
1174        (define (add from to last)
1175          (let ([node (cons (##sys#substring str from to) '())])
1176            (if first
1177                (##sys#setslot last 1 node)
1178                (set! first node) ) 
1179            node) )
1180        (let loop ([i 0] [last #f] [from 0])
1181          (cond [(fx>= i strlen)
1182                 (when (or (fx> i from) flag) (add from i last))
1183                 (or first '()) ]
1184                [else
1185                 (let ([c (##core#inline "C_subchar" str i)])
1186                   (let scan ([j 0])
1187                     (cond [(fx>= j dellen) (loop (fx+ i 1) last from)]
1188                           [(eq? c (##core#inline "C_subchar" del j))
1189                            (let ([i2 (fx+ i 1)])
1190                              (if (or (fx> i from) flag)
1191                                  (loop i2 (add from i last) i2)
1192                                  (loop i2 last i2) ) ) ]
1193                           [else (scan (fx+ j 1))] ) ) ) ] ) ) ) ) ) )
1194
1195
1196;;; Concatenate list of strings:
1197
1198(define (string-intersperse strs #!optional (ds " "))
1199  (##sys#check-list strs 'string-intersperse)
1200  (##sys#check-string ds 'string-intersperse)
1201  (let ((dslen (##sys#size ds)))
1202    (let loop1 ((ss strs) (n 0))
1203      (cond ((##core#inline "C_eqp" ss '())
1204             (if (##core#inline "C_eqp" strs '())
1205                 ""
1206                 (let ((str2 (##sys#allocate-vector (fx- n dslen) #t #\space #f)))
1207                   (let loop2 ((ss2 strs) (n2 0))
1208                     (let* ((stri (##sys#slot ss2 0))
1209                            (next (##sys#slot ss2 1)) 
1210                            (strilen (##sys#size stri)) )
1211                       (##core#inline "C_substring_copy" stri str2 0 strilen n2)
1212                       (let ((n3 (fx+ n2 strilen)))
1213                         (if (##core#inline "C_eqp" next '())
1214                             str2
1215                             (begin
1216                               (##core#inline "C_substring_copy" ds str2 0 dslen n3)
1217                               (loop2 next (fx+ n3 dslen)) ) ) ) ) ) ) ) )
1218            ((and (##core#inline "C_blockp" ss) (##core#inline "C_pairp" ss))
1219             (let ((stri (##sys#slot ss 0)))
1220               (##sys#check-string stri 'string-intersperse)
1221               (loop1 (##sys#slot ss 1)
1222                      (fx+ (##sys#size stri) (fx+ dslen n)) ) ) )
1223            (else (##sys#not-a-proper-list-error strs)) ) ) ) )
1224
1225
1226;;; Translate elements of a string:
1227
1228(define string-translate 
1229  (let ([make-string make-string]
1230        [list->string list->string] )
1231    (lambda (str from . to)
1232
1233      (define (instring s)
1234        (let ([len (##sys#size s)])
1235          (lambda (c)
1236            (let loop ([i 0])
1237              (cond [(fx>= i len) #f]
1238                    [(eq? c (##core#inline "C_subchar" s i)) i]
1239                    [else (loop (fx+ i 1))] ) ) ) ) )
1240
1241      (let* ([from
1242              (cond [(char? from) (lambda (c) (eq? c from))]
1243                    [(pair? from) (instring (list->string from))]
1244                    [else
1245                     (##sys#check-string from 'string-translate)
1246                     (instring from) ] ) ]
1247             [to
1248              (and (pair? to)
1249                   (let ([tx (##sys#slot to 0)])
1250                     (cond [(char? tx) tx]
1251                           [(pair? tx) (list->string tx)]
1252                           [else
1253                            (##sys#check-string tx 'string-translate)
1254                            tx] ) ) ) ] 
1255             [tlen (and (string? to) (##sys#size to))] )
1256        (##sys#check-string str 'string-translate)
1257        (let* ([slen (##sys#size str)]
1258               [str2 (make-string slen)] )
1259          (let loop ([i 0] [j 0])
1260            (if (fx>= i slen)
1261                (if (fx< j i)
1262                    (##sys#substring str2 0 j)
1263                    str2)
1264                (let* ([ci (##core#inline "C_subchar" str i)]
1265                       [found (from ci)] )
1266                  (cond [(not found)
1267                         (##core#inline "C_setsubchar" str2 j ci)
1268                         (loop (fx+ i 1) (fx+ j 1)) ]
1269                        [(not to) (loop (fx+ i 1) j)]
1270                        [(char? to)
1271                         (##core#inline "C_setsubchar" str2 j to)
1272                         (loop (fx+ i 1) (fx+ j 1)) ]
1273                        [(cond-expand [unsafe #f] [else (fx>= found tlen)])
1274                         (##sys#error 'string-translate "invalid translation destination" i to) ]
1275                        [else
1276                         (##core#inline "C_setsubchar" str2 j (##core#inline "C_subchar" to found))
1277                         (loop (fx+ i 1) (fx+ j 1)) ] ) ) ) ) ) ) ) ) )
1278
1279(define (string-translate* str smap)
1280  (##sys#check-string str 'string-translate*)
1281  (##sys#check-list smap 'string-translate*)
1282  (let ([len (##sys#size str)])
1283    (define (collect i from total fs)
1284      (if (fx>= i len)
1285          (##sys#fragments->string
1286           total
1287           (reverse
1288            (if (fx> i from) 
1289                (cons (##sys#substring str from i) fs)
1290                fs) ) )
1291          (let loop ([smap smap])
1292            (if (null? smap) 
1293                (collect (fx+ i 1) from (fx+ total 1) fs)
1294                (let* ([p (car smap)]
1295                       [sm (car p)]
1296                       [smlen (string-length sm)]
1297                       [st (cdr p)] )
1298                  (if (##core#inline "C_substring_compare" str sm i 0 smlen)
1299                      (let ([i2 (fx+ i smlen)])
1300                        (when (fx> i from)
1301                          (set! fs (cons (##sys#substring str from i) fs)) )
1302                        (collect 
1303                         i2 i2
1304                         (fx+ total (string-length st))
1305                         (cons st fs) ) ) 
1306                      (loop (cdr smap)) ) ) ) ) ) )
1307    (collect 0 0 0 '()) ) )
1308
1309
1310;;; Chop string into substrings:
1311
1312(define (string-chop str len)
1313  (##sys#check-string str 'string-chop)
1314  (##sys#check-exact len 'string-chop)
1315  (let ([total (##sys#size str)])
1316    (let loop ([total total] [pos 0])
1317      (cond [(fx<= total 0) '()]
1318            [(fx<= total len) (list (##sys#substring str pos (fx+ pos total)))]
1319            [else (cons (##sys#substring str pos (fx+ pos len)) (loop (fx- total len) (fx+ pos len)))] ) ) ) )
1320           
1321
1322;;; Remove suffix
1323
1324(define (string-chomp str #!optional (suffix "\n"))
1325  (##sys#check-string str 'string-chomp)
1326  (##sys#check-string suffix 'string-chomp)
1327  (let* ((len (##sys#size str))
1328         (slen (##sys#size suffix)) 
1329         (diff (fx- len slen)) )
1330    (if (and (fx>= len slen)
1331             (##core#inline "C_substring_compare" str suffix diff 0 slen) )
1332        (##sys#substring str 0 diff)
1333        str) ) )
1334
1335
1336;;; Write simple formatted output:
1337
1338(define fprintf0
1339  (let ((write write)
1340        (newline newline)
1341        (display display) 
1342        (open-output-string open-output-string)
1343        (get-output-string get-output-string))
1344    (lambda (loc port msg args)
1345      (let rec ([msg msg] [args args])
1346        (##sys#check-string msg loc)
1347        (when port (##sys#check-port port loc))
1348        (let ((index 0)
1349              (len (##sys#size msg)) 
1350              (out (if (and port (##sys#tty-port? port))
1351                       port
1352                       (open-output-string))))
1353          (define (fetch)
1354            (let ((c (##core#inline "C_subchar" msg index)))
1355              (set! index (fx+ index 1))
1356              c) )
1357          (define (next)
1358            (if (cond-expand [unsafe #f] [else (##core#inline "C_eqp" args '())])
1359                (##sys#error loc "too few arguments to formatted output procedure")
1360                (let ((x (##sys#slot args 0)))
1361                  (set! args (##sys#slot args 1)) 
1362                  x) ) )
1363          (let loop ()
1364            (unless (fx>= index len)
1365              (let ((c (fetch)))
1366                (if (and (eq? c #\~) (fx< index len))
1367                    (let ((dchar (fetch)))
1368                      (case (char-upcase dchar)
1369                        ((#\S) (write (next) out))
1370                        ((#\A) (display (next) out))
1371                        ((#\C) (##sys#write-char-0 (next) out))
1372                        ((#\B) (display (##sys#number->string (next) 2) out))
1373                        ((#\O) (display (##sys#number->string (next) 8) out))
1374                        ((#\X) (display (##sys#number->string (next) 16) out))
1375                        ((#\!) (##sys#flush-output out))
1376                        ((#\?)
1377                         (let* ([fstr (next)]
1378                                [lst (next)] )
1379                           (##sys#check-list lst loc)
1380                           (display (rec fstr lst) out) ) )
1381                        ((#\~) (##sys#write-char-0 #\~ out))
1382                        ((#\% #\N) (newline out))
1383                        (else
1384                         (if (char-whitespace? dchar)
1385                             (let skip ((c (fetch)))
1386                               (if (char-whitespace? c)
1387                                   (skip (fetch))
1388                                   (set! index (fx- index 1)) ) )
1389                             (##sys#error loc "illegal format-string character" dchar) ) ) ) )
1390                    (##sys#write-char-0 c out) )
1391                (loop) ) ) )
1392          (cond ((not port) (get-output-string out))
1393                ((not (eq? out port))
1394                 (##sys#print (get-output-string out) #f port) ) ) ) ) ) ) )
1395
1396(define (fprintf port fstr . args)
1397  (fprintf0 'fprintf port fstr args) )
1398
1399(define (printf fstr . args)
1400  (fprintf0 'printf ##sys#standard-output fstr args) )
1401
1402(define (sprintf fstr . args)
1403  (fprintf0 'sprintf #f fstr args) )
1404
1405(define format
1406  (let ([fprintf fprintf]
1407        [sprintf sprintf]
1408        [printf printf] )
1409    (lambda (fmt-or-dst . args)
1410      (apply (cond [(not fmt-or-dst)             sprintf]
1411                   [(boolean? fmt-or-dst)        printf]
1412                   [(string? fmt-or-dst)         (set! args (cons fmt-or-dst args)) sprintf]
1413                   [(output-port? fmt-or-dst)    (set! args (cons fmt-or-dst args)) fprintf]
1414                   [else
1415                    (##sys#error 'format "illegal destination" fmt-or-dst args)])
1416             args) ) ) )
1417
1418(register-feature! 'srfi-28)
1419
1420
1421;;; Defines: sorted?, merge, merge!, sort, sort!
1422;;; Author : Richard A. O'Keefe (based on Prolog code by D.H.D.Warren)
1423;;;
1424;;; This code is in the public domain.
1425
1426;;; Updated: 11 June 1991
1427;;; Modified for scheme library: Aubrey Jaffer 19 Sept. 1991
1428;;; Updated: 19 June 1995
1429
1430;;; (sorted? sequence less?)
1431;;; is true when sequence is a list (x0 x1 ... xm) or a vector #(x0 ... xm)
1432;;; such that for all 1 <= i <= m,
1433;;;     (not (less? (list-ref list i) (list-ref list (- i 1)))).
1434
1435; Modified by flw for use with CHICKEN:
1436;
1437
1438
1439(define (sorted? seq less?)
1440    (cond
1441        ((null? seq)
1442            #t)
1443        ((vector? seq)
1444            (let ((n (vector-length seq)))
1445                (if (<= n 1)
1446                    #t
1447                    (do ((i 1 (+ i 1)))
1448                        ((or (= i n)
1449                             (less? (vector-ref seq i)
1450                                    (vector-ref seq (- i 1))))
1451                            (= i n)) )) ))
1452        (else
1453            (let loop ((last (car seq)) (next (cdr seq)))
1454                (or (null? next)
1455                    (and (not (less? (car next) last))
1456                         (loop (car next) (cdr next)) )) )) ))
1457
1458
1459;;; (merge a b less?)
1460;;; takes two lists a and b such that (sorted? a less?) and (sorted? b less?)
1461;;; and returns a new list in which the elements of a and b have been stably
1462;;; interleaved so that (sorted? (merge a b less?) less?).
1463;;; Note:  this does _not_ accept vectors.  See below.
1464
1465(define (merge a b less?)
1466    (cond
1467        ((null? a) b)
1468        ((null? b) a)
1469        (else (let loop ((x (car a)) (a (cdr a)) (y (car b)) (b (cdr b)))
1470            ;; The loop handles the merging of non-empty lists.  It has
1471            ;; been written this way to save testing and car/cdring.
1472            (if (less? y x)
1473                (if (null? b)
1474                    (cons y (cons x a))
1475                    (cons y (loop x a (car b) (cdr b)) ))
1476                ;; x <= y
1477                (if (null? a)
1478                    (cons x (cons y b))
1479                    (cons x (loop (car a) (cdr a) y b)) )) )) ))
1480
1481
1482;;; (merge! a b less?)
1483;;; takes two sorted lists a and b and smashes their cdr fields to form a
1484;;; single sorted list including the elements of both.
1485;;; Note:  this does _not_ accept vectors.
1486
1487(define (merge! a b less?)
1488    (define (loop r a b)
1489        (if (less? (car b) (car a))
1490            (begin
1491                (set-cdr! r b)
1492                (if (null? (cdr b))
1493                    (set-cdr! b a)
1494                    (loop b a (cdr b)) ))
1495            ;; (car a) <= (car b)
1496            (begin
1497                (set-cdr! r a)
1498                (if (null? (cdr a))
1499                    (set-cdr! a b)
1500                    (loop a (cdr a) b)) )) )
1501    (cond
1502        ((null? a) b)
1503        ((null? b) a)
1504        ((less? (car b) (car a))
1505            (if (null? (cdr b))
1506                (set-cdr! b a)
1507                (loop b a (cdr b)))
1508            b)
1509        (else ; (car a) <= (car b)
1510            (if (null? (cdr a))
1511                (set-cdr! a b)
1512                (loop a (cdr a) b))
1513            a)))
1514
1515
1516;;; (sort! sequence less?)
1517;;; sorts the list or vector sequence destructively.  It uses a version
1518;;; of merge-sort invented, to the best of my knowledge, by David H. D.
1519;;; Warren, and first used in the DEC-10 Prolog system.  R. A. O'Keefe
1520;;; adapted it to work destructively in Scheme.
1521
1522(define (sort! seq less?)
1523    (define (step n)
1524        (cond
1525            ((> n 2)
1526                (let* ((j (quotient n 2))
1527                       (a (step j))
1528                       (k (- n j))
1529                       (b (step k)))
1530                    (merge! a b less?)))
1531            ((= n 2)
1532                (let ((x (car seq))
1533                      (y (cadr seq))
1534                      (p seq))
1535                    (set! seq (cddr seq))
1536                    (if (less? y x) (begin
1537                        (set-car! p y)
1538                        (set-car! (cdr p) x)))
1539                    (set-cdr! (cdr p) '())
1540                    p))
1541            ((= n 1)
1542                (let ((p seq))
1543                    (set! seq (cdr seq))
1544                    (set-cdr! p '())
1545                    p))
1546            (else
1547                '()) ))
1548    (if (vector? seq)
1549        (let ((n (vector-length seq))
1550              (vec seq))
1551          (set! seq (vector->list seq))
1552          (do ((p (step n) (cdr p))
1553               (i 0 (+ i 1)))
1554              ((null? p) vec)
1555            (vector-set! vec i (car p)) ))
1556        ;; otherwise, assume it is a list
1557        (step (length seq)) ))
1558
1559;;; (sort sequence less?)
1560;;; sorts a vector or list non-destructively.  It does this by sorting a
1561;;; copy of the sequence.  My understanding is that the Standard says
1562;;; that the result of append is always "newly allocated" except for
1563;;; sharing structure with "the last argument", so (append x '()) ought
1564;;; to be a standard way of copying a list x.
1565
1566(define (sort seq less?)
1567    (if (vector? seq)
1568        (list->vector (sort! (vector->list seq) less?))
1569        (sort! (append seq '()) less?)))
1570
1571
1572;;; Binary search:
1573
1574(define binary-search
1575  (let ([list->vector list->vector])
1576    (lambda (vec proc)
1577      (if (pair? vec)
1578          (set! vec (list->vector vec))
1579          (##sys#check-vector vec 'binary-search) )
1580      (let ([len (##sys#size vec)])
1581        (and (fx> len 0)
1582             (let loop ([ps 0]
1583                        [pe len] )
1584               (let ([p (fx+ ps (##core#inline "C_fixnum_divide" (fx- pe ps) 2))])
1585                 (let* ([x (##sys#slot vec p)]
1586                        [r (proc x)] )
1587                   (cond [(fx= r 0) p]
1588                         [(fx< r 0) (and (not (fx= pe p)) (loop ps p))]
1589                         [else (and (not (fx= ps p)) (loop p pe))] ) ) ) ) ) ) ) ) )
1590
1591
1592;;; Generation of hash-values:
1593
1594;; Naming Conventions:
1595;; $foo - macro
1596;; $*foo - local macro (no such thing but at least it looks different)
1597;; %foo - private, usually unchecked, procedure
1598;; ##sys#foo - public, but undocumented, un-checked procedure
1599;; foo - public checked procedure
1600;;
1601;; All '%foo-hash' return a fixnum, not necessarily positive. The "overflow" of
1602;; a, supposedly, unsigned hash value into negative is not checked during
1603;; intermediate computation.
1604;;
1605;; The body of '%eq?-hash' is duplicated in 'eqv?-hash' and the body of '%eqv?-hash'
1606;; is duplicated in '%equal?-hash' to save on procedure calls.
1607
1608;; Fixed hash-values:
1609
1610(define-constant other-hash-value 99)
1611(define-constant true-hash-value 256)
1612(define-constant false-hash-value 257)
1613(define-constant null-hash-value 258)
1614(define-constant eof-hash-value 259)
1615(define-constant input-port-hash-value 260)
1616(define-constant output-port-hash-value 261)
1617(define-constant unknown-immediate-hash-value 262)
1618
1619(define-constant hash-default-bound 536870912)
1620
1621;; Force Hash to Bounded Fixnum:
1622
1623(define-macro ($fxabs ?fxn)
1624  `(let ([_fxn ,?fxn]) (if (fx< _fxn 0) (fxneg _fxn) _fxn ) ) )
1625
1626(define-macro ($hash/limit ?hsh ?lim)
1627  `(fxmod (fxand (foreign-value "C_MOST_POSITIVE_FIXNUM" int)
1628                 ($fxabs ,?hsh))
1629          ,?lim) )
1630
1631;; Number Hash:
1632
1633(define-constant flonum-magic 331804471)
1634
1635#| Not sure which is "better"; went with speed
1636(define-macro ($subbyte ?bytvec ?i)
1637  `(##core#inline "C_subbyte" ,?bytvec ,?i) )
1638
1639(define-macro ($hash-flonum ?flo)
1640  `(fx* flonum-magic
1641        ,(let loop ([idx (fx- (##sys#size 1.0) 1)])
1642            (if (fx= 0 idx)
1643                `($subbyte ,?flo 0)
1644                `(fx+ ($subbyte ,?flo ,idx)
1645                      (fxshl ,(loop (fx- idx 1)) 1))))) )
1646|#
1647
1648(define-macro ($hash-flonum ?flo)
1649  `(fx* flonum-magic ($quick-flonum-truncate ,?flo)) )
1650
1651(define (##sys#number-hash-hook obj)
1652  (%equal?-hash obj) )
1653
1654(define-macro ($non-fixnum-number-hash ?obj)
1655  `(cond [(flonum? obj) ($hash-flonum ,?obj)]
1656         [else          ($fix (##sys#number-hash-hook ,?obj))] ) )
1657
1658(define-macro ($number-hash ?obj)
1659  `(cond [(fixnum? obj) ,?obj]
1660         [else          ($non-fixnum-number-hash ?obj)] ) )
1661
1662(define (number-hash obj #!optional (bound hash-default-bound))
1663  (unless (number? obj)
1664    (##sys#signal-hook #:type 'number-hash "invalid number" obj) )
1665  (##sys#check-exact bound 'number-hash)
1666  ($hash/limit ($number-hash obj) bound) )
1667
1668;; Object UID Hash:
1669
1670#; ;NOT YET (no weak-reference)
1671(define (%object-uid-hash obj)
1672  (%uid-hash (##sys#object->uid obj)) )
1673
1674(define (%object-uid-hash obj)
1675  (%equal?-hash obj) )
1676
1677(define (object-uid-hash obj #!optional (bound hash-default-bound))
1678  (##sys#check-exact bound 'object-uid-hash)
1679  ($hash/limit (%object-uid-hash obj) bound) )
1680
1681;; Symbol Hash:
1682
1683#; ;NOT YET (no unique-symbol-hash)
1684(define-macro ($symbol-hash ?obj)
1685  `(##sys#slot ,?obj INDEX-OF-UNIQUE-HASH-VALUE-COMPUTED-DURING-SYMBOL-CREATION) )
1686
1687(define-macro ($symbol-hash ?obj)
1688  `($hash-string (##sys#slot ,?obj 1)) )
1689
1690(define (symbol-hash obj #!optional (bound hash-default-bound))
1691  (##sys#check-symbol obj 'symbol-hash)
1692  (##sys#check-exact bound 'string-hash)
1693  ($hash/limit ($symbol-hash obj) bound) )
1694
1695;; Keyword Hash:
1696
1697(define (##sys#check-keyword x . y)
1698  (unless (keyword? x)
1699    (##sys#signal-hook #:type-error
1700                       (and (not (null? y)) (car y))
1701                       "bad argument type - not a keyword" x) ) )
1702
1703#; ;NOT YET (no unique-keyword-hash)
1704(define-macro ($keyword-hash ?obj)
1705  `(##sys#slot ,?obj INDEX-OF-UNIQUE-HASH-VALUE-COMPUTED-DURING-KEYWORD-CREATION) )
1706
1707(define-macro ($keyword-hash ?obj)
1708  `($hash-string (##sys#slot ,?obj 1)) )
1709
1710(define (keyword-hash obj #!optional (bound hash-default-bound))
1711  (##sys#check-keyword obj 'keyword-hash)
1712  (##sys#check-exact bound 'keyword-hash)
1713  ($hash/limit ($keyword-hash obj) bound) )
1714
1715;; Eq Hash:
1716
1717(define-macro ($eq?-hash-object? ?obj)
1718  `(or ($immediate? ,?obj)
1719       (symbol? ,?obj)
1720       #; ;NOT YET (no keyword vs. symbol issue)
1721       (keyword? ,?obj) ) )
1722
1723(define (%eq?-hash obj)
1724  (cond [(fixnum? obj)          obj]
1725        [(char? obj)            (char->integer obj)]
1726        [(eq? obj #t)           true-hash-value]
1727        [(eq? obj #f)           false-hash-value]
1728        [(null? obj)            null-hash-value]
1729        [(eof-object? obj)      eof-hash-value]
1730        [(symbol? obj)          ($symbol-hash obj)]
1731        #; ;NOT YET (no keyword vs. symbol issue)
1732        [(keyword? obj)         ($keyword-hash obj)]
1733        [($immediate? obj)      unknown-immediate-hash-value]
1734        [else                   (%object-uid-hash obj) ] ) )
1735
1736(define (eq?-hash obj #!optional (bound hash-default-bound))
1737  (##sys#check-exact bound 'eq?-hash)
1738  ($hash/limit (%eq?-hash obj) bound) )
1739
1740(define hash-by-identity eq?-hash)
1741
1742;; Eqv Hash:
1743
1744(define-macro ($eqv?-hash-object? ?obj)
1745  `(or ($eq?-hash-object? ,?obj)
1746       (number? ,?obj)) )
1747
1748(define (%eqv?-hash obj)
1749  (cond [(fixnum? obj)          obj]
1750        [(char? obj)            (char->integer obj)]
1751        [(eq? obj #t)           true-hash-value]
1752        [(eq? obj #f)           false-hash-value]
1753        [(null? obj)            null-hash-value]
1754        [(eof-object? obj)      eof-hash-value]
1755        [(symbol? obj)          ($symbol-hash obj)]
1756        #; ;NOT YET (no keyword vs. symbol issue)
1757        [(keyword? obj)         ($keyword-hash obj)]
1758        [(number? obj)          ($non-fixnum-number-hash obj)]
1759        [($immediate? obj)      unknown-immediate-hash-value]
1760        [else                   (%object-uid-hash obj) ] ) )
1761
1762(define (eqv?-hash obj #!optional (bound hash-default-bound))
1763  (##sys#check-exact bound 'eqv?-hash)
1764  ($hash/limit (%eqv?-hash obj) bound) )
1765
1766;; Equal Hash:
1767
1768;XXX Be nice if these were parameters
1769(define-constant recursive-hash-max-depth 4)
1770(define-constant recursive-hash-max-length 4)
1771
1772(define-macro ($*list-hash ?obj)
1773  `(fx+ (length ,?obj)
1774        (recursive-atomic-hash (##sys#slot ,?obj 0) depth)) )
1775
1776(define-macro ($*pair-hash ?obj)
1777  `(fx+ (fxshl (recursive-atomic-hash (##sys#slot ,?obj 0) depth) 16)
1778        (recursive-atomic-hash (##sys#slot ,?obj 1) depth)) )
1779
1780(define-macro ($*port-hash ?obj)
1781  `(fx+ (fxshl (##sys#peek-fixnum ,?obj 0) 4) ; Little extra "identity"
1782        (if (input-port? ,?obj)
1783            input-port-hash-value
1784            output-port-hash-value)) )
1785
1786(define-macro ($*special-vector-hash ?obj)
1787  `(vector-hash ,?obj (##sys#peek-fixnum ,?obj 0) depth 1) )
1788
1789(define-macro ($*regular-vector-hash ?obj)
1790  `(vector-hash ,?obj 0 depth 0) )
1791
1792(define (%equal?-hash obj)
1793
1794  ; Recurse into some portion of the vector's slots
1795  (define (vector-hash obj seed depth start)
1796    (let ([len (##sys#size obj)])
1797      (let loop ([hsh (fx+ len seed)]
1798                 [i start]
1799                 [len (fx- (fxmin recursive-hash-max-length len) start)] )
1800        (if (fx= len 0)
1801            hsh
1802            (loop (fx+ hsh
1803                       (fx+ (fxshl hsh 4)
1804                            (recursive-hash (##sys#slot obj i) (fx+ depth 1))))
1805                  (fx+ i 1)
1806                  (fx- len 1) ) ) ) ) )
1807
1808  ; Don't recurse into structured objects
1809  (define (recursive-atomic-hash obj depth)
1810    (if (or ($eqv?-hash-object? obj)
1811            ($byte-block? obj))
1812        (recursive-hash obj (fx+ depth 1))
1813        other-hash-value ) )
1814
1815  ; Recurse into structured objects
1816  (define (recursive-hash obj depth)
1817    (cond [(fx>= depth recursive-hash-max-depth)
1818                                  other-hash-value]
1819          [(fixnum? obj)          obj]
1820          [(char? obj)            (char->integer obj)]
1821          [(eq? obj #t)           true-hash-value]
1822          [(eq? obj #f)           false-hash-value]
1823          [(null? obj)            null-hash-value]
1824          [(eof-object? obj)      eof-hash-value]
1825          [(symbol? obj)          ($symbol-hash obj)]
1826          #; ;NOT YET (no keyword vs. symbol issue)
1827          [(keyword? obj)         ($keyword-hash obj)]
1828          [(number? obj)          ($non-fixnum-number-hash obj)]
1829          [($immediate? obj)      unknown-immediate-hash-value]
1830          [($byte-block? obj)     ($hash-string obj)]
1831          [(list? obj)            ($*list-hash obj)]
1832          [(pair? obj)            ($*pair-hash obj)]
1833          [($port? obj)           ($*port-hash obj)]
1834          [($special? obj)        ($*special-vector-hash obj)]
1835          [else                   ($*regular-vector-hash obj)] ) )
1836
1837  ;
1838  (recursive-hash obj 0) )
1839
1840(define (equal?-hash obj #!optional (bound hash-default-bound))
1841  (##sys#check-exact bound 'hash)
1842  ($hash/limit (%equal?-hash obj) bound) )
1843
1844(define hash equal?-hash)
1845
1846;; String Hash:
1847
1848(define (string-hash str #!optional (bound hash-default-bound))
1849  (##sys#check-string str 'string-hash)
1850  (##sys#check-exact bound 'string-hash)
1851  ($hash/limit ($hash-string str) bound) )
1852
1853(define (string-ci-hash str #!optional (bound hash-default-bound))
1854  (##sys#check-string str 'string-ci-hash)
1855  (##sys#check-exact bound 'string-ci-hash)
1856  ($hash/limit ($hash-string-ci str) bound) )
1857
1858
1859;;; Hash-Tables:
1860
1861; Predefined sizes for the hash tables:
1862;
1863; Starts with 307; each element is the smallest prime that is at least twice in
1864; magnitude as the previous element in the list.
1865;
1866; The last number is an exception: it is the largest 32-bit fixnum we can represent.
1867
1868(define-constant hash-table-prime-lengths
1869  '(307 617
1870    1237 2477 4957 9923
1871    19853 39709 79423
1872    158849 317701 635413
1873    1270849 2541701 5083423
1874    10166857 20333759 40667527 81335063 162670129
1875    325340273 650680571
1876    ;
1877    1073741823))
1878
1879(define-constant hash-table-default-length 307)
1880(define-constant hash-table-max-length 1073741823)
1881(define-constant hash-table-new-length-factor 2)
1882
1883(define-constant hash-table-default-min-load 0.5)
1884(define-constant hash-table-default-max-load 0.8)
1885
1886;; Restrict hash-table length to tabled lengths:
1887
1888(define (hash-table-canonical-length tab req)
1889  (let loop ([tab tab])
1890    (let ([cur (##sys#slot tab 0)]
1891          [nxt (##sys#slot tab 1)])
1892      (if (or (fx>= cur req)
1893              (null? nxt))
1894          cur
1895          (loop nxt) ) ) ) )
1896
1897;; "Raw" make-hash-table:
1898
1899(define %make-hash-table
1900  (let ([make-vector make-vector])
1901    (lambda (test hash len min-load max-load weak-keys weak-values initial
1902             #!optional (vec (make-vector len '())))
1903      (##sys#make-structure 'hash-table
1904       vec 0 test hash min-load max-load #f #f initial) ) ) )
1905
1906;; SRFI-69 & SRFI-90'ish.
1907;;
1908;; Argument list is the pattern
1909;;
1910;; (make-hash-table #!optional test hash size
1911;;                  #!key test hash size initial min-load max-load weak-keys weak-values)
1912;;
1913;; where a keyword argument takes precedence over the corresponding optional
1914;; argument. Keyword arguments MUST come after optional & required
1915;; arugments.
1916;;
1917;; Wish DSSSL (extended) argument list processing Did-What-I-Want (DWIW).
1918
1919(define make-hash-table
1920  (let ([core-eq? eq?]
1921        [core-eqv? eqv?]
1922        [core-equal? equal?]
1923        [core-string=? string=?]
1924        [core-string-ci=? string-ci=?]
1925        [core= =] )
1926    (lambda arguments0
1927      (let ([arguments arguments0]
1928            [test equal?]
1929            [hash #f]
1930            [size hash-table-default-length]
1931            [initial #f]
1932            [min-load hash-table-default-min-load]
1933            [max-load hash-table-default-max-load]
1934            [weak-keys #f]
1935            [weak-values #f])
1936        (let ([hash-for-test
1937                (lambda ()
1938                  (cond [(or (eq? core-eq? test)
1939                             (eq? eq? test))              eq?-hash]
1940                        [(or (eq? core-eqv? test)
1941                             (eq? eqv? test))             eqv?-hash]
1942                        [(or (eq? core-equal? test)
1943                             (eq? equal? test))           equal?-hash]
1944                        [(or (eq? core-string=? test)
1945                             (eq? string=? test))         string-hash]
1946                        [(or (eq? core-string-ci=? test)
1947                             (eq? string-ci=? test))      string-ci-hash]
1948                        [(or (eq? core= test)
1949                             (eq? = test))                number-hash]
1950                        [else                             #f] ) ) ] )
1951          ; Process optional arguments
1952          (unless (null? arguments)
1953            (let ([arg (car arguments)])
1954              (unless (keyword? arg)
1955                (##sys#check-closure arg 'make-hash-table)
1956                (set! test arg)
1957                (set! arguments (cdr arguments)) ) ) )
1958          (unless (null? arguments)
1959            (let ([arg (car arguments)])
1960              (unless (keyword? arg)
1961                (##sys#check-closure arg 'make-hash-table)
1962                (set! hash arg)
1963                (set! arguments (cdr arguments)) ) ) )
1964          (unless (null? arguments)
1965            (let ([arg (car arguments)])
1966              (unless (keyword? arg)
1967                (##sys#check-exact arg 'make-hash-table)
1968                (unless (fx< 0 arg)
1969                  (error 'make-hash-table "invalid size" arg) )
1970                (set! size (fxmin hash-table-max-size arg))
1971                (set! arguments (cdr arguments)) ) ) )
1972          ; Process keyword arguments
1973          (let loop ([args arguments])
1974            (unless (null? args)
1975              (let ([arg (car args)])
1976                (let ([invarg-err
1977                        (lambda (msg)
1978                          (error 'make-hash-table msg arg arguments0))])
1979                  (if (keyword? arg)
1980                      (let* ([nxt (cdr args)]
1981                             [val (if (pair? nxt)
1982                                      (car nxt)
1983                                      (invarg-err "missing keyword value"))])
1984                        (case arg
1985                          [(#:test)
1986                            (##sys#check-closure val 'make-hash-table)
1987                            (set! test val)]
1988                          [(#:hash)
1989                            (##sys#check-closure val 'make-hash-table)
1990                            (set! hash val)]
1991                          [(#:size)
1992                            (##sys#check-exact val 'make-hash-table)
1993                            (unless (fx< 0 val)
1994                              (error 'make-hash-table "invalid size" val) )
1995                            (set! size (fxmin hash-table-max-size val))]
1996                          [(#:initial)
1997                            (set! initial (lambda () val))]
1998                          [(#:min-load)
1999                            (##sys#check-inexact val 'make-hash-table)
2000                            (unless (and (fp< 0.0 val) (fp< val 1.0))
2001                              (error 'make-hash-table "invalid min-load" val) )
2002                            (set! min-load val)]
2003                          [(#:max-load)
2004                            (##sys#check-inexact val 'make-hash-table)
2005                            (unless (and (fp< 0.0 val) (fp< val 1.0))
2006                              (error 'make-hash-table "invalid max-load" val) )
2007                            (set! max-load val)]
2008                          [(#:weak-keys)
2009                            (set! weak-keys (and val #t))]
2010                          [(#:weak-values)
2011                            (set! weak-values (and val #t))]
2012                          [else
2013                            (invarg-err "unknown keyword")])
2014                        (loop (cdr nxt)) )
2015                      (invarg-err "missing keyword") ) ) ) ) )
2016          ; Load must be a proper interval
2017          (when (fp< max-load min-load)
2018            (error 'make-hash-table "min-load greater than max-load" min-load max-load) )
2019          ; Force canonical hash-table vector length
2020          (set! size (hash-table-canonical-length hash-table-prime-lengths size))
2021          ; Decide on a hash function when not supplied
2022          (unless hash
2023            (let ([func (hash-for-test)])
2024              (if func
2025                  (set! hash func)
2026                  (begin
2027                    (warning 'make-hash-table "user test without user hash")
2028                    (set! hash equal?-hash) ) ) ) )
2029          ; Done
2030          (%make-hash-table test hash size min-load max-load weak-keys weak-values initial) ) ) ) ) )
2031
2032;; Hash-Table Predicate:
2033
2034(define (hash-table? obj)
2035  (##sys#structure? obj 'hash-table) )
2036
2037;; Hash-Table Properties:
2038
2039(define (hash-table-size ht)
2040  (##sys#check-structure ht 'hash-table 'hash-table-size)
2041  (##sys#slot ht 2) )
2042
2043(define (hash-table-equivalence-function ht)
2044  (##sys#check-structure ht 'hash-table 'hash-table-equivalence-function)
2045  (##sys#slot ht 3) )
2046
2047(define (hash-table-hash-function ht)
2048  (##sys#check-structure ht 'hash-table 'hash-table-hash-function)
2049  (##sys#slot ht 4) )
2050
2051(define (hash-table-min-load ht)
2052  (##sys#check-structure ht 'hash-table 'hash-table-min-load)
2053  (##sys#slot ht 5) )
2054
2055(define (hash-table-max-load ht)
2056  (##sys#check-structure ht 'hash-table 'hash-table-max-load)
2057  (##sys#slot ht 6) )
2058
2059(define (hash-table-weak-keys ht)
2060  (##sys#check-structure ht 'hash-table 'hash-table-weak-keys)
2061  (##sys#slot ht 7) )
2062
2063(define (hash-table-weak-values ht)
2064  (##sys#check-structure ht 'hash-table 'hash-table-weak-values)
2065  (##sys#slot ht 8) )
2066
2067(define (hash-table-has-initial? ht)
2068  (##sys#check-structure ht 'hash-table 'hash-table-has-initial?)
2069  (and (##sys#slot ht 9)
2070       #t ) )
2071
2072(define (hash-table-initial ht)
2073  (##sys#check-structure ht 'hash-table 'hash-table-initial)
2074  (and-let* ([thunk (##sys#slot ht 9)])
2075    (thunk) ) )
2076
2077;; hash-table-copy:
2078
2079(define %hash-table-copy
2080  (let ([make-vector make-vector])
2081    (lambda (ht)
2082      (let* ([vec1 (##sys#slot ht 1)]
2083             [len (##sys#size vec1)]
2084             [vec2 (make-vector len '())] )
2085        (do ([i 0 (fx+ i 1)])
2086            [(fx>= i len)
2087             (%make-hash-table
2088              (##sys#slot ht 3) (##sys#slot ht 4)
2089              (##sys#slot ht 2)
2090              (##sys#slot ht 5) (##sys#slot ht 6)
2091              (##sys#slot ht 7) (##sys#slot ht 8)
2092              (##sys#slot ht 9)
2093              vec2)]
2094          (##sys#setslot vec2 i
2095           (let copy-loop ([bucket (##sys#slot vec1 i)])
2096             (if (null? bucket)
2097                 '()
2098                 (let ([pare (##sys#slot bucket 0)])
2099                   (cons (cons (##sys#slot pare 0) (##sys#slot pare 1))
2100                         (copy-loop (##sys#slot bucket 1))))))) ) ) ) ) )
2101
2102(define (hash-table-copy ht)
2103  (##sys#check-structure ht 'hash-table 'hash-table-copy)
2104  (%hash-table-copy ht) )
2105
2106;; hash-table-update!:
2107;;
2108;; This one was suggested by Sven Hartrumpf (and subsequently added in SRFI-69).
2109;; Modified for ht props min & max load.
2110
2111(define (hash-table-rehash vec1 vec2 hash)
2112  (let ([len1 (##sys#size vec1)]
2113        [len2 (##sys#size vec2)] )
2114    (do ([i 0 (fx+ i 1)])
2115        [(fx>= i len1)]
2116      (let loop ([bucket (##sys#slot vec1 i)])
2117        (unless (null? bucket)
2118          (let* ([pare (##sys#slot bucket 0)]
2119                 [key (##sys#slot pare 0)]
2120                 [hshidx (hash key len2)] )
2121            (##sys#setslot vec2 hshidx
2122                           (cons (cons key (##sys#slot pare 1))
2123                                 (##sys#slot vec2 hshidx)))
2124            (loop (##sys#slot bucket 1)) ) ) ) ) ) )
2125
2126(define %hash-table-update!
2127  (let ([core-eq? eq?]
2128        [floor floor] )
2129    (lambda (ht key func thunk)
2130      (let ([hash (##sys#slot ht 4)]
2131            [test (##sys#slot ht 3)]
2132            [newsiz (fx+ (##sys#slot ht 2) 1)]
2133            [min-load (##sys#slot ht 5)]
2134            [max-load (##sys#slot ht 6)] )
2135        (let re-enter ()
2136          (let* ([vec (##sys#slot ht 1)]
2137                 [len (##sys#size vec)] )
2138            (let ([min-load-len (inexact->exact (floor (* len min-load)))]
2139                  [max-load-len (inexact->exact (floor (* len max-load)))]
2140                  [hshidx (hash key len)] )
2141              ; Need to resize table?
2142              (if (and (fx< len hash-table-max-length)
2143                       (fx<= min-load-len newsiz) (fx<= newsiz max-load-len))
2144                  ; then resize the table:
2145                  (let ([vec2 (make-vector
2146                               (hash-table-canonical-length
2147                                hash-table-prime-lengths
2148                                (fxmin hash-table-max-length
2149                                       (fx* len hash-table-new-length-factor)))
2150                               '())])
2151                    (hash-table-rehash vec vec2 hash)
2152                    (##sys#setslot ht 1 vec2)
2153                    (re-enter) )
2154                  ; else update the table:
2155                  (let ([bucket0 (##sys#slot vec hshidx)])
2156                    (if (eq? core-eq? test)
2157                        ; Fast path (eq? is rewritten by the compiler):
2158                        (let loop ([bucket bucket0])
2159                          (cond [(null? bucket)
2160                                 (let ([val (func (thunk))])
2161                                   (##sys#setslot vec hshidx (cons (cons key val) bucket0))
2162                                   (##sys#setslot ht 2 newsiz)
2163                                   val) ]
2164                                [else
2165                                 (let ([pare (##sys#slot bucket 0)])
2166                                   (if (eq? key (##sys#slot pare 0))
2167                                       (let ([val (func (##sys#slot pare 1))])
2168                                         (##sys#setslot pare 1 val)
2169                                         val)
2170                                       (loop (##sys#slot bucket 1)) ) ) ] ) )
2171                        ; Slow path
2172                        (let loop ([bucket bucket0])
2173                          (cond [(null? bucket)
2174                                 (let ([val (func (thunk))])
2175                                   (##sys#setslot vec hshidx (cons (cons key val) bucket0))
2176                                   (##sys#setslot ht 2 newsiz)
2177                                   val) ]
2178                                [else
2179                                 (let ([pare (##sys#slot bucket 0)])
2180                                   (if (test key (##sys#slot pare 0))
2181                                       (let ([val (func (##sys#slot pare 1))])
2182                                         (##sys#setslot pare 1 val)
2183                                         val)
2184                                       (loop (##sys#slot bucket 1)) ) ) ] ) ) ) ) ) ) ) ) ) ) ) )
2185
2186(define (hash-table-update!
2187         ht key
2188         #!optional (func identity)
2189                    (thunk
2190                     (let ([thunk (##sys#slot ht 9)])
2191                       (or thunk
2192                           (lambda ()
2193                             (##sys#signal-hook #:access-error
2194                              'hash-table-update!
2195                              "hash-table does not contain key" key ht))))))
2196  (##sys#check-structure ht 'hash-table 'hash-table-update!)
2197  (##sys#check-closure func 'hash-table-update!)
2198  (##sys#check-closure thunk 'hash-table-update!)
2199  (%hash-table-update! ht key func thunk) )
2200
2201(define (hash-table-update!/default ht key func def)
2202  (##sys#check-structure ht 'hash-table 'hash-table-update!/default)
2203  (##sys#check-closure func 'hash-table-update!/default)
2204  (%hash-table-update! ht key func (lambda () def)) )
2205
2206(define (hash-table-set! ht key val)
2207  (##sys#check-structure ht 'hash-table 'hash-table-set!)
2208  (let ([thunk (lambda _ val)])
2209    (%hash-table-update! ht key thunk thunk) )
2210  (void) )
2211
2212;; Hash-Table Reference:
2213
2214(define %hash-table-ref
2215  (let ([core-eq? eq?])
2216    (lambda (ht key def)
2217       (let  ([vec (##sys#slot ht 1)]
2218              [test (##sys#slot ht 3)] )
2219         (let* ([hash (##sys#slot ht 4)]
2220                [hshidx (hash key (##sys#size vec))] )
2221           (if (eq? core-eq? test)
2222               ; Fast path (eq? is rewritten by the compiler):
2223               (let loop ([bucket (##sys#slot vec hshidx)])
2224                 (if (null? bucket)
2225                     (def)
2226                     (let ([pare (##sys#slot bucket 0)])
2227                       (if (eq? key (##sys#slot pare 0))
2228                           (##sys#slot pare 1)
2229                           (loop (##sys#slot bucket 1)) ) ) ) )
2230               ; Slow path
2231               (let loop ([bucket (##sys#slot vec hshidx)])
2232                 (if (null? bucket)
2233                     (def)
2234                     (let ([pare (##sys#slot bucket 0)])
2235                       (if (test key (##sys#slot pare 0))
2236                           (##sys#slot pare 1)
2237                           (loop (##sys#slot bucket 1)) ) ) ) ) ) ) ) ) ) )
2238
2239(define hash-table-ref
2240  (getter-with-setter
2241   (lambda (ht key #!optional (def (lambda ()
2242                                     (##sys#signal-hook #:access-error
2243                                      'hash-table-ref
2244                                      "hash-table does not contain key" key ht))))
2245     (##sys#check-structure ht 'hash-table 'hash-table-ref)
2246     (##sys#check-closure def 'hash-table-ref)
2247     (%hash-table-ref ht key def) )
2248   hash-table-set!))
2249
2250(define (hash-table-ref/default ht key default)
2251  (##sys#check-structure ht 'hash-table 'hash-table-ref/default)
2252  (%hash-table-ref ht key (lambda () default)) )
2253
2254(define (hash-table-exists? ht key)
2255  (##sys#check-structure ht 'hash-table 'hash-table-exists?)
2256  (not ($unbound? (%hash-table-ref ht key unbound-value-thunk))) )
2257
2258;; hash-table-delete!:
2259
2260(define hash-table-delete!
2261  (let ([core-eq? eq?])
2262    (lambda (ht key)
2263      (##sys#check-structure ht 'hash-table 'hash-table-delete!)
2264      (let* ([vec (##sys#slot ht 1)]
2265             [len (##sys#size vec)] )
2266        (let* ([hash (##sys#slot ht 4)]
2267               [hshidx (hash key len)] )
2268          (let ([test (##sys#slot ht 3)]
2269                [newsiz (fx- (##sys#slot ht 2) 1)]
2270                [bucket0 (##sys#slot vec hshidx)] )
2271            (if (eq? core-eq? test)
2272                ; Fast path (eq? is rewritten by the compiler):
2273                (let loop ([prev #f] [bucket bucket0])
2274                  (and (not (null? bucket))
2275                       (let ([pare (##sys#slot bucket 0)]
2276                             [nxt (##sys#slot bucket 1)])
2277                         (if (eq? key (##sys#slot pare 0))
2278                             (begin
2279                               (if prev
2280                                   (##sys#setslot prev 1 nxt)
2281                                   (##sys#setslot vec hshidx nxt) )
2282                               (##sys#setslot ht 2 newsiz)
2283                               #t )
2284                             (loop bucket nxt) ) ) ) )
2285                ; Slow path
2286                (let loop ([prev #f] [bucket bucket0])
2287                  (and (not (null? bucket))
2288                       (let ([pare (##sys#slot bucket 0)]
2289                             [nxt (##sys#slot bucket 1)])
2290                         (if (test key (##sys#slot pare 0))
2291                             (begin
2292                               (if prev
2293                                   (##sys#setslot prev 1 nxt)
2294                                   (##sys#setslot vec hshidx nxt) )
2295                               (##sys#setslot ht 2 newsiz)
2296                               #t )
2297                             (loop bucket nxt) ) ) ) ) ) ) ) ) ) ) )
2298
2299;; hash-table-remove!:
2300
2301(define (hash-table-remove! ht func)
2302  (##sys#check-structure ht 'hash-table 'hash-table-remove!)
2303  (##sys#check-closure func 'hash-table-remove!)
2304  (let* ([vec (##sys#slot ht 1)]
2305         [len (##sys#size vec)] )
2306    (let ([siz (##sys#slot ht 2)])
2307      (do ([i 0 (fx+ i 1)])
2308          [(fx>= i len) (##sys#setislot ht 2 siz)]
2309        (let loop ([prev #f] [bucket (##sys#slot vec i)])
2310          (and (not (null? bucket))
2311               (let ([pare (##sys#slot bucket 0)]
2312                     [nxt (##sys#slot bucket 1)])
2313                 (if (func (##sys#slot pare 0) (##sys#slot pare 1))
2314                     (begin
2315                       (if prev
2316                           (##sys#setslot prev 1 nxt)
2317                           (##sys#setslot vec i nxt) )
2318                       (set! siz (fx- siz 1))
2319                       #t )
2320                     (loop bucket nxt ) ) ) ) ) ) ) ) )
2321
2322;; Hash Table Merge:
2323
2324(define (%hash-table-merge! ht1 ht2)
2325  (let* ([vec (##sys#slot ht2 1)]
2326         [len (##sys#size vec)] )
2327    (do ([i 0 (fx+ i 1)])
2328        [(fx>= i len) ht1]
2329      (do ([lst (##sys#slot vec i) (##sys#slot lst 1)])
2330          [(null? lst)]
2331        (let ([b (##sys#slot lst 0)])
2332          (%hash-table-update! ht1 (##sys#slot b 0)
2333                                   identity (lambda () (##sys#slot b 1))) ) ) ) ) )
2334
2335(define (hash-table-merge! ht1 ht2)
2336  (##sys#check-structure ht1 'hash-table 'hash-table-merge!)
2337  (##sys#check-structure ht2 'hash-table 'hash-table-merge!)
2338  (%hash-table-merge! ht1 ht2) )
2339
2340(define (hash-table-merge ht1 ht2)
2341  (##sys#check-structure ht1 'hash-table 'hash-table-merge)
2342  (##sys#check-structure ht2 'hash-table 'hash-table-merge)
2343  (%hash-table-merge! (%hash-table-copy ht1) ht2) )
2344
2345;; Hash-Table <-> Association-List:
2346
2347(define (hash-table->alist ht)
2348  (##sys#check-structure ht 'hash-table 'hash-table->alist)
2349  (let* ([vec (##sys#slot ht 1)]
2350         [len (##sys#size vec)] )
2351    (let loop ([i 0] [lst '()])
2352      (if (fx>= i len)
2353          lst
2354          (let loop2 ([bucket (##sys#slot vec i)]
2355                      [lst lst])
2356            (if (null? bucket)
2357                (loop (fx+ i 1) lst)
2358                (loop2 (##sys#slot bucket 1)
2359                       (let ([x (##sys#slot bucket 0)])
2360                         (cons (cons (##sys#slot x 0) (##sys#slot x 1)) lst) ) ) ) ) ) ) ) )
2361
2362(define alist->hash-table
2363  (let ([make-hash-table make-hash-table])
2364    (lambda (alist . rest)
2365      (##sys#check-list alist 'alist->hash-table)
2366      (let ([ht (apply make-hash-table rest)])
2367        (for-each (lambda (x)
2368                    (%hash-table-update! ht (##sys#slot x 0)
2369                                            identity (lambda () (##sys#slot x 1))) )
2370                  alist)
2371        ht ) ) ) )
2372
2373;; Hash-Table Keys & Values:
2374
2375(define (hash-table-keys ht)
2376  (##sys#check-structure ht 'hash-table 'hash-table-keys)
2377  (let* ([vec (##sys#slot ht 1)]
2378         [len (##sys#size vec)] )
2379    (let loop ([i 0] [lst '()])
2380      (if (fx>= i len)
2381          lst
2382          (let loop2 ([bucket (##sys#slot vec i)]
2383                      [lst lst])
2384            (if (null? bucket)
2385                (loop (fx+ i 1) lst)
2386                (loop2 (##sys#slot bucket 1)
2387                       (let ([x (##sys#slot bucket 0)])
2388                         (cons (##sys#slot x 0) lst) ) ) ) ) ) ) ) )
2389
2390(define (hash-table-values ht)
2391  (##sys#check-structure ht 'hash-table 'hash-table-values)
2392  (let* ([vec (##sys#slot ht 1)]
2393         [len (##sys#size vec)] )
2394    (let loop ([i 0] [lst '()])
2395      (if (fx>= i len)
2396          lst
2397          (let loop2 ([bucket (##sys#slot vec i)]
2398                      [lst lst])
2399            (if (null? bucket)
2400                (loop (fx+ i 1) lst)
2401                (loop2 (##sys#slot bucket 1)
2402                       (let ([x (##sys#slot bucket 0)])
2403                         (cons (##sys#slot x 1) lst) ) ) ) ) ) ) ) )
2404
2405;; Mapping Over Hash-Table Keys & Values:
2406;;
2407;; hash-table-for-each:
2408;; hash-table-walk:
2409;; hash-table-fold:
2410;; hash-table-map:
2411
2412(define (%hash-table-for-each ht proc)
2413  (let* ([vec (##sys#slot ht 1)]
2414         [len (##sys#size vec)] )
2415    (do ([i 0 (fx+ i 1)] )
2416        [(fx>= i len)]
2417      (##sys#for-each (lambda (bucket)
2418                        (proc (##sys#slot bucket 0) (##sys#slot bucket 1)) )
2419                      (##sys#slot vec i)) ) ) )
2420
2421(define (%hash-table-fold ht func init)
2422  (let* ([vec (##sys#slot ht 1)]
2423         [len (##sys#size vec)] )
2424    (let loop ([i 0] [acc init])
2425      (if (fx>= i len)
2426          acc
2427          (let fold2 ([bucket (##sys#slot vec i)]
2428                      [acc acc])
2429            (if (null? bucket)
2430                (loop (fx+ i 1) acc)
2431                (let ([pare (##sys#slot bucket 0)])
2432                  (fold2 (##sys#slot bucket 1)
2433                         (func (##sys#slot pare 0) (##sys#slot pare 1) acc) ) ) ) ) ) ) ) )
2434
2435(define (hash-table-fold ht func init)
2436  (##sys#check-structure ht 'hash-table 'hash-table-fold)
2437  (##sys#check-closure func 'hash-table-fold)
2438  (%hash-table-fold ht func init) )
2439
2440(define (hash-table-for-each ht proc)
2441  (##sys#check-structure ht 'hash-table 'hash-table-for-each)
2442  (##sys#check-closure proc 'hash-table-for-each)
2443  (%hash-table-for-each ht proc) )
2444
2445(define (hash-table-walk ht proc)
2446  (##sys#check-structure ht 'hash-table 'hash-table-walk)
2447  (##sys#check-closure proc 'hash-table-walk)
2448  (%hash-table-for-each ht proc) )
2449
2450(define (hash-table-map ht func)
2451  (##sys#check-structure ht 'hash-table 'hash-table-map)
2452  (##sys#check-closure func 'hash-table-map)
2453  (%hash-table-fold ht (lambda (k v a) (cons (func k v) a)) '()) )
2454
2455;; Done with Hash-Tables:
2456
2457(register-feature! 'srfi-69)
2458
2459
2460; Support for queues
2461;
2462; Written by Andrew Wilcox (awilcox@astro.psu.edu) on April 1, 1992.
2463;
2464; This code is in the public domain.
2465;
2466; (heavily adapated for use with CHICKEN by felix)
2467;
2468
2469
2470; Elements in a queue are stored in a list.  The last pair in the list
2471; is stored in the queue type so that datums can be added in constant
2472; time.
2473
2474(define (make-queue) (##sys#make-structure 'queue '() '()))
2475(define (queue? x) (##sys#structure? x 'queue))
2476
2477(define (queue-empty? q)
2478  (##sys#check-structure q 'queue 'queue-empty?)
2479  (eq? '() (##sys#slot q 1)) )
2480
2481(define queue-first
2482  (lambda (q)
2483    (##sys#check-structure q 'queue 'queue-first)
2484    (let ((first-pair (##sys#slot q 1)))
2485      (cond-expand 
2486       [(not unsafe)
2487        (when (eq? '() first-pair)
2488          (##sys#error 'queue-first "queue is empty" q)) ]
2489       [else] )
2490      (##sys#slot first-pair 0) ) ) )
2491
2492(define queue-last
2493  (lambda (q)
2494    (##sys#check-structure q 'queue 'queue-last)
2495    (let ((last-pair (##sys#slot q 2)))
2496      (cond-expand
2497       [(not unsafe)
2498        (when (eq? '() last-pair)
2499          (##sys#error 'queue-last "queue is empty" q)) ]
2500       [else] )
2501      (##sys#slot last-pair 0) ) ) )
2502
2503(define (queue-add! q datum)
2504  (##sys#check-structure q 'queue 'queue-add!)
2505  (let ((new-pair (cons datum '())))
2506    (cond ((eq? '() (##sys#slot q 1)) (##sys#setslot q 1 new-pair))
2507          (else (##sys#setslot (##sys#slot q 2) 1 new-pair)) )
2508    (##sys#setslot q 2 new-pair) 
2509    (##core#undefined) ) )
2510
2511(define queue-remove!
2512  (lambda (q)
2513    (##sys#check-structure q 'queue 'queue-remove!)
2514    (let ((first-pair (##sys#slot q 1)))
2515      (cond-expand
2516       [(not unsafe)
2517        (when (eq? '() first-pair)
2518          (##sys#error 'queue-remove! "queue is empty" q) ) ]
2519       [else] )
2520      (let ((first-cdr (##sys#slot first-pair 1)))
2521        (##sys#setslot q 1 first-cdr)
2522        (if (eq? '() first-cdr)
2523            (##sys#setslot q 2 '()) )
2524        (##sys#slot first-pair 0) ) ) ) )
2525
2526(define (queue->list q)
2527  (##sys#check-structure q 'queue 'queue->list)
2528  (##sys#slot q 1) )
2529
2530(define (list->queue lst0)
2531  (##sys#check-list lst0 'list->queue)
2532  (##sys#make-structure 
2533   'queue lst0
2534   (if (eq? lst0 '())
2535       '()
2536       (do ((lst lst0 (##sys#slot lst 1)))
2537           ((eq? (##sys#slot lst 1) '()) lst)
2538         (if (or (not (##core#inline "C_blockp" lst))
2539                 (not (##core#inline "C_pairp" lst)) )
2540             (##sys#not-a-proper-list-error lst0 'list->queue) ) ) ) ) )
2541
2542
2543; (queue-push-back! queue item)
2544; Pushes an item into the first position of a queue.
2545
2546(define (queue-push-back! q item)
2547  (##sys#check-structure q 'queue 'queue-push-back!)
2548  (let ((newlist (cons item (##sys#slot q 1))))
2549    (##sys#setslot q 1 newlist)
2550    (if (eq? '() (##sys#slot q 2))
2551        (##sys#setslot q 2 newlist))))
2552
2553; (queue-push-back-list! queue item-list)
2554; Pushes the items in item-list back onto the queue,
2555; so that (car item-list) becomes the next removable item.
2556
2557(define-macro (last-pair lst0)
2558  `(do ((lst ,lst0 (##sys#slot lst 1)))
2559       ((eq? (##sys#slot lst 1) '()) lst)))
2560
2561(define (queue-push-back-list! q itemlist)
2562  (##sys#check-structure q 'queue 'queue-push-back-list!)
2563  (##sys#check-list itemlist 'queue-push-back-list!)
2564  (let* ((newlist (append itemlist (##sys#slot q 1)))
2565         (newtail (if (eq? newlist '())
2566                       '()
2567                       (last-pair newlist))))
2568    (##sys#setslot q 1 newlist)
2569    (##sys#setslot q 2 newtail)))
Note: See TracBrowser for help on using the repository browser.