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

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

Merged trunk into prerelease

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