source: project/chicken/branches/release/extras.scm @ 7276

Last change on this file since 7276 was 7276, checked in by felix winkelmann, 12 years ago

merged trunk

File size: 61.5 KB
Line 
1;;; extras.scm - Optional non-standard extensions
2;
3; Copyright (c) 2000-2007, Felix L. Winkelmann
4; All rights reserved.
5;
6; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
7; conditions are met:
8;
9;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
10;     disclaimer.
11;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
12;     disclaimer in the documentation and/or other materials provided with the distribution.
13;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
14;     products derived from this software without specific prior written permission.
15;
16; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
17; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
18; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
19; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
20; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
21; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
22; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
23; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
24; POSSIBILITY OF SUCH DAMAGE.
25;
26; Send bugs, suggestions and ideas to:
27;
28; felix@call-with-current-continuation.org
29;
30; Felix L. Winkelmann
31; Unter den Gleichen 1
32; 37130 Gleichen
33; Germany
34
35
36(declare
37 (unit extras)
38 (usual-integrations)
39 (disable-warning redef)
40 (foreign-declare #<<EOF
41#define C_hashptr(x)   C_fix(x & C_MOST_POSITIVE_FIXNUM)
42#define C_mem_compare(to, from, n)   C_fix(C_memcmp(C_c_string(to), C_c_string(from), C_unfix(n)))
43EOF
44) )
45
46(cond-expand
47 [paranoia]
48 [else
49  (declare
50    (no-bound-checks)
51    (no-procedure-checks-for-usual-bindings)
52    (bound-to-procedure
53     ##sys#hash
54     ##sys#check-char ##sys#check-exact ##sys#check-port ##sys#check-string ##sys#substring
55     ##sys#for-each ##sys#map ##sys#setslot ##sys#allocate-vector ##sys#check-pair ##sys#not-a-proper-list-error 
56     ##sys#member ##sys#assoc ##sys#error ##sys#signal-hook ##sys#read-string!
57     ##sys#check-symbol ##sys#check-vector ##sys#floor ##sys#ceiling ##sys#truncate ##sys#round 
58     ##sys#check-number ##sys#cons-flonum
59     ##sys#flonum-fraction ##sys#make-port ##sys#fetch-and-check-port-arg ##sys#print ##sys#check-structure 
60     ##sys#make-structure make-parameter hash-table-set! ##sys#hash-new-len hash-table-ref 
61     hash-table-update! floor input-port? make-vector list->vector sort! merge! open-output-string
62     get-output-string current-output-port ##sys#flush-output ##sys#write-char-0 newline
63     ##sys#number->string display write ##sys#fragments->string list->string make-string string
64     pretty-print-width ##sys#symbol->qualified-string ##extras#reverse-string-append ##sys#number?
65     ##sys#procedure->string ##sys#pointer->string port? ##sys#user-print-hook char-name 
66     read open-input-string ##sys#peek-char-0 ##sys#read-char-0 ##sys#write-char call-with-input-file
67     read-line reverse make-string ##sys#string-append random
68     ##sys#gcd ##sys#lcm ##sys#fudge ##sys#check-list ##sys#user-read-hook) ) ] )
69
70(private
71 extras
72  reverse-string-append generic-write hashtab-default-size hashtab-threshold hashtab-rehash hashtab-primes-table)
73
74(declare
75  (hide hashtab-threshold hashtab-rehash generic-write) )
76
77(cond-expand
78 [unsafe
79  (eval-when (compile)
80    (define-macro (##sys#check-structure . _) '(##core#undefined))
81    (define-macro (##sys#check-range . _) '(##core#undefined))
82    (define-macro (##sys#check-pair . _) '(##core#undefined))
83    (define-macro (##sys#check-list . _) '(##core#undefined))
84    (define-macro (##sys#check-symbol . _) '(##core#undefined))
85    (define-macro (##sys#check-string . _) '(##core#undefined))
86    (define-macro (##sys#check-char . _) '(##core#undefined))
87    (define-macro (##sys#check-exact . _) '(##core#undefined))
88    (define-macro (##sys#check-port . _) '(##core#undefined))
89    (define-macro (##sys#check-number . _) '(##core#undefined))
90    (define-macro (##sys#check-byte-vector . _) '(##core#undefined)) ) ]
91 [else
92  (declare (emit-exports "extras.exports")) ] )
93
94
95(register-feature! 'extras)
96
97
98;;; Read expressions from file:
99
100(define read-file
101  (let ([read read]
102        [reverse reverse] 
103        [call-with-input-file call-with-input-file] )
104    (lambda (#!optional (port ##sys#standard-input) (reader read) max)
105      (define (slurp port)
106        (do ((x (reader port) (reader port))
107             (i 0 (fx+ i 1))
108             (xs '() (cons x xs)) )
109            ((or (eof-object? x) (and max (fx>= i max))) (reverse xs)) ) )
110      (if (port? port)
111          (slurp port)
112          (call-with-input-file port slurp) ) ) ) )
113
114
115;;; Combinators:
116
117(define (identity x) x)
118
119(define (project n)
120  (lambda args (list-ref args n)) )
121
122(define (conjoin . preds)
123  (lambda (x)
124    (let loop ([preds preds])
125      (or (null? preds)
126          (and ((##sys#slot preds 0) x)
127               (loop (##sys#slot preds 1)) ) ) ) ) )
128
129(define (disjoin . preds)
130  (lambda (x)
131    (let loop ([preds preds])
132      (and (not (null? preds))
133           (or ((##sys#slot preds 0) x)
134               (loop (##sys#slot preds 1)) ) ) ) ) )
135
136(define (constantly . xs)
137  (if (eq? 1 (length xs))
138      (let ([x (car xs)])
139        (lambda _ x) )
140      (lambda _ (apply values xs)) ) )
141
142(define (flip proc) (lambda (x y) (proc y x)))
143
144(define complement
145  (lambda (p)
146    (lambda args (not (apply p args))) ) )
147
148(define (compose . fns)
149  (define (rec f0 . fns)
150    (if (null? fns)
151        f0
152        (lambda args
153          (call-with-values
154              (lambda () (apply (apply rec fns) args))
155            f0) ) ) )
156  (if (null? fns)
157      values
158      (apply rec fns) ) )
159
160(define (o . fns)
161  (if (null? fns)
162      identity
163      (let loop ((fns fns))
164        (let ((h (##sys#slot fns 0))
165              (t (##sys#slot fns 1)) )
166          (if (null? t)
167              h
168              (lambda (x) (h ((loop t) x))))))))
169
170(define (list-of pred)
171  (lambda (lst)
172    (let loop ([lst lst])
173      (cond [(null? lst) #t]
174            [(not-pair? lst) #f]
175            [(pred (##sys#slot lst 0)) (loop (##sys#slot lst 1))]
176            [else #f] ) ) ) )
177
178(define (noop . _) (void))
179
180(define (each . procs)
181  (cond ((null? procs) (lambda _ (void)))
182        ((null? (##sys#slot procs 1)) (##sys#slot procs 0))
183        (else
184         (lambda args
185           (let loop ((procs procs))
186             (let ((h (##sys#slot procs 0))
187                   (t (##sys#slot procs 1)) )
188               (if (null? t)
189                   (apply h args)
190                   (begin
191                     (apply h args)
192                     (loop t) ) ) ) ) ) ) ) )
193
194(define (any? x) #t)
195
196
197;;; List operators:
198
199(define (atom? x) (##core#inline "C_i_not_pair_p" x))
200
201(define (tail? x y)
202  (##sys#check-list y 'tail?)
203  (or (##core#inline "C_eqp" x '())
204      (let loop ((y y))
205        (cond ((##core#inline "C_eqp" y '()) #f)
206              ((##core#inline "C_eqp" x y) #t)
207              (else (loop (##sys#slot y 1))) ) ) ) )
208
209(define intersperse 
210  (lambda (lst x)
211    (let loop ((ns lst))
212      (if (##core#inline "C_eqp" ns '())
213          ns
214          (let ((tail (cdr ns)))
215            (if (##core#inline "C_eqp" tail '())
216                ns
217                (cons (##sys#slot ns 0) (cons x (loop tail))) ) ) ) ) ) )
218
219(define (butlast lst)
220  (##sys#check-pair lst 'butlast)
221  (let loop ((lst lst))
222    (let ((next (##sys#slot lst 1)))
223      (if (and (##core#inline "C_blockp" next) (##core#inline "C_pairp" next))
224          (cons (##sys#slot lst 0) (loop next))
225          '() ) ) ) )
226
227(define (flatten . lists0)
228  (let loop ([lists lists0] [rest '()])
229    (cond [(null? lists) rest]
230          [else
231           (let ([head (##sys#slot lists 0)]
232                 [tail (##sys#slot lists 1)] )
233             (if (list? head)
234                 (loop head (loop tail rest))
235                 (cons head (loop tail rest)) ) ) ] ) ) )
236
237(define chop
238  (let ([reverse reverse])
239    (lambda (lst n)
240      (##sys#check-exact n 'chop)
241      (cond-expand
242       [(not unsafe) (when (fx<= n 0) (##sys#error 'chop "invalid numeric argument" n))]
243       [else] )
244      (let ([len (length lst)])
245        (let loop ([lst lst] [i len])
246          (cond [(null? lst) '()]
247                [(fx< i n) (list lst)]
248                [else
249                 (do ([hd '() (cons (##sys#slot tl 0) hd)]
250                      [tl lst (##sys#slot tl 1)] 
251                      [c n (fx- c 1)] )
252                     ((fx= c 0)
253                      (cons (reverse hd) (loop tl (fx- i n))) ) ) ] ) ) ) ) ) )
254
255(define (join lsts . lst)
256  (let ([lst (if (pair? lst) (car lst) '())])
257    (##sys#check-list lst 'join)
258    (let loop ([lsts lsts])
259      (cond [(null? lsts) '()]
260            [(cond-expand [unsafe #f] [else (not (pair? lsts))])
261             (##sys#not-a-proper-list-error lsts) ]
262            [else
263             (let ([l (##sys#slot lsts 0)]
264                   [r (##sys#slot lsts 1)] )
265               (if (null? r)
266                   l
267                   (##sys#append l lst (loop r)) ) ) ] ) ) ) )
268
269(define compress
270  (lambda (blst lst)
271    (let ([msg "bad argument type - not a proper list"])
272      (##sys#check-list lst 'compress)
273      (let loop ([blst blst] [lst lst])
274        (cond [(null? blst) '()]
275              [(cond-expand [unsafe #f] [else (not (pair? blst))])
276               (##sys#signal-hook #:type-error 'compress msg blst) ]
277              [(cond-expand [unsafe #f] [else (not (pair? lst))])
278               (##sys#signal-hook #:type-error 'compress msg lst) ]
279              [(##sys#slot blst 0) (cons (##sys#slot lst 0) (loop (##sys#slot blst 1) (##sys#slot lst 1)))]
280              [else (loop (##sys#slot blst 1) (##sys#slot lst 1))] ) ) ) ) )
281
282(define shuffle
283  ;; this should really shadow SORT! and RANDOM...
284  (lambda (l)
285    (let ((len (length l)))
286      (map cdr
287           (sort! (map (lambda (x) (cons (random len) x)) l)
288                  (lambda (x y) (< (car x) (car y)))) ) ) ) )
289
290
291;;; Alists:
292
293(define (alist-update! x y lst . cmp)
294  (let* ([cmp (if (pair? cmp) (car cmp) eqv?)]
295         [aq (cond [(eq? eq? cmp) assq]
296                   [(eq? eqv? cmp) assv]
297                   [(eq? equal? cmp) assoc]
298                   [else
299                    (lambda (x lst)
300                      (let loop ([lst lst])
301                        (and (pair? lst)
302                             (let ([a (##sys#slot lst 0)])
303                               (if (and (pair? a) (cmp (##sys#slot a 0) x))
304                                   a
305                                   (loop (##sys#slot lst 1)) ) ) ) ) ) ] ) ] 
306         [item (aq x lst)] )
307    (if item
308        (begin
309          (##sys#setslot item 1 y)
310          lst)
311        (cons (cons x y) lst) ) ) )
312
313(define (alist-ref x lst #!optional (cmp eqv?) (default #f))
314  (let* ([aq (cond [(eq? eq? cmp) assq]
315                   [(eq? eqv? cmp) assv]
316                   [(eq? equal? cmp) assoc]
317                   [else
318                    (lambda (x lst)
319                      (let loop ([lst lst])
320                        (and (pair? lst)
321                             (let ([a (##sys#slot lst 0)])
322                               (if (and (pair? a) (cmp (##sys#slot a 0) x))
323                                   a
324                                   (loop (##sys#slot lst 1)) ) ) ) ) ) ] ) ] 
325         [item (aq x lst)] )
326    (if item
327        (##sys#slot item 1)
328        default) ) )
329
330(define (rassoc x lst . tst)
331  (cond-expand [(not unsafe) (##sys#check-list lst 'rassoc)][else])
332  (let ([tst (if (pair? tst) (car tst) eqv?)])
333    (let loop ([l lst])
334      (and (pair? l)
335           (let ([a (##sys#slot l 0)])
336             (cond-expand [(not unsafe) (##sys#check-pair a 'rassoc)][else])
337             (if (tst x (##sys#slot a 1))
338                 a
339                 (loop (##sys#slot l 1)) ) ) ) ) ) )
340
341
342;;; Random numbers:
343
344(define (random n)
345  (##sys#check-exact n 'random)
346  (if (eq? n 0)
347      0
348      (##core#inline "C_random_fixnum" n) ) )
349
350(define (randomize . n)
351  (##core#inline
352   "C_randomize"
353   (if (##core#inline "C_eqp" n '())
354       (##sys#fudge 2)
355       (let ((nn (##sys#slot n 0)))
356         (##sys#check-exact nn 'randomize)
357         nn) ) ) )
358
359
360;;; Line I/O:
361
362(define read-line
363  (let ([make-string make-string])
364    (define (fixup str len)
365      (##sys#substring
366       str 0
367       (if (and (fx>= len 1) (char=? #\return (##core#inline "C_subchar" str (fx- len 1))))
368           (fx- len 1)
369           len) ) )
370    (lambda args
371      (let* ([parg (pair? args)]
372             [p (if parg (car args) ##sys#standard-input)]
373             [limit (and parg (pair? (cdr args)) (cadr args))])
374        (##sys#check-port p 'read-line)
375        (cond ((##sys#slot p 8) => (lambda (rl) (rl p limit)))
376              (else
377               (let* ((buffer-len (if limit limit 256))
378                      (buffer (##sys#make-string buffer-len)))
379                 (let loop ([i 0])
380                   (if (and limit (fx>= i limit))
381                       (##sys#substring buffer 0 i)
382                       (let ([c (##sys#read-char-0 p)])
383                         (if (eof-object? c)
384                             (if (fx= i 0)
385                                 c
386                                 (##sys#substring buffer 0 i) ) 
387                             (case c
388                               [(#\newline) (##sys#substring buffer 0 i)]
389                               [(#\return)
390                                (let ([c (peek-char p)])
391                                  (if (char=? c #\newline)
392                                      (begin (##sys#read-char-0 p)
393                                             (##sys#substring buffer 0 i))
394                                      (##sys#substring buffer 0 i) ) ) ]
395                               [else
396                                (when (fx>= i buffer-len)
397                                  (set! buffer (##sys#string-append buffer (make-string buffer-len)))
398                                  (set! buffer-len (fx+ buffer-len buffer-len)) )
399                                (##core#inline "C_setsubchar" buffer i c)
400                                (loop (fx+ i 1)) ] ) ) ) ) ) ) ) ) ) ) ) )
401
402(define read-lines
403  (let ((read-line read-line)
404        (call-with-input-file call-with-input-file) 
405        (reverse reverse) )
406    (lambda port-and-max
407      (let* ((port (if (pair? port-and-max) (##sys#slot port-and-max 0) ##sys#standard-input))
408             (rest (and (pair? port-and-max) (##sys#slot port-and-max 1)))
409             (max (if (pair? rest) (##sys#slot rest 0) #f)) )
410        (define (doread port)
411          (let loop ((lns '())
412                     (n (or max 1000000)) )
413            (if (eq? n 0)
414                (reverse lns)
415                (let ((ln (read-line port)))
416                  (if (eof-object? ln)
417                      (reverse lns)
418                      (loop (cons ln lns) (fx- n 1)) ) ) ) ) )
419        (if (string? port)
420            (call-with-input-file port doread)
421            (begin
422              (##sys#check-port port 'read-lines)
423              (doread port) ) ) ) ) ) )
424
425
426;;; Extended I/O
427
428(define (##sys#read-string! n dest port start)
429  (cond ((eq? n 0) 0)
430        (else
431         (when (##sys#slot port 6)      ; peeked?
432           (##core#inline "C_setsubchar" dest start (##sys#read-char-0 port))
433           (set! start (fx+ start 1)) )
434         (let ((rdstring (##sys#slot (##sys#slot port 2) 7)))
435           (let loop ((start start) (n n) (m 0))
436             (let ((n2 (if rdstring
437                           (rdstring port n dest start) ; *** doesn't update port-position!
438                           (let ((c (##sys#read-char-0 port)))
439                             (if (eof-object? c)
440                                 0
441                                 (begin
442                                   (##core#inline "C_setsubchar" dest start c)
443                                   1) ) ) ) ) )
444               (cond ((eq? n2 0) m)
445                     ((or (not n) (fx< n2 n)) 
446                      (loop (fx+ start n2) (and n (fx- n n2)) (fx+ m n2)) )
447                     (else (fx+ n2 m))) ) ) ))))
448
449(define (read-string! n dest #!optional (port ##sys#standard-input) (start 0))
450  (##sys#check-port port 'read-string!)
451  (##sys#check-string dest 'read-string!)
452  (when n
453    (##sys#check-exact n 'read-string!)
454    (when (fx> (fx+ start n) (##sys#size dest))
455      (set! n (fx- (##sys#size dest) start))))
456  (##sys#check-exact start 'read-string!)
457  (##sys#read-string! n dest port start) )
458
459(define ##sys#read-string/port
460  (let ((open-output-string open-output-string)
461        (get-output-string get-output-string) )
462    (lambda (n p)
463      (##sys#check-port p 'read-string)
464      (cond (n (##sys#check-exact n 'read-string)
465               (let* ((str (##sys#make-string n))
466                      (n2 (##sys#read-string! n str p 0)) )
467                 (if (eq? n n2)
468                     str
469                     (##sys#substring str 0 n2))))
470            (else
471             (let ([str (open-output-string)])
472               (let loop ([n n])
473                 (or (and (eq? n 0) (get-output-string str))
474                     (let ([c (##sys#read-char-0 p)])
475                       (if (eof-object? c)
476                           (get-output-string str)
477                           (begin
478                             (##sys#write-char/port c str) 
479                             (loop (and n (fx- n 1))) ) ) ) ) ) ) ) ) ) ) )
480
481(define (read-string #!optional n (port ##sys#standard-input))
482  (##sys#read-string/port n port) )
483
484(define read-token
485  (let ([open-output-string open-output-string]
486        [get-output-string get-output-string] )
487    (lambda (pred . port)
488      (let ([port (:optional port ##sys#standard-input)])
489        (##sys#check-port port 'read-token)
490        (let ([out (open-output-string)])
491          (let loop ()
492            (let ([c (##sys#peek-char-0 port)])
493              (if (and (not (eof-object? c)) (pred c))
494                  (begin
495                    (##sys#write-char-0 (##sys#read-char-0 port) out)
496                    (loop) )
497                  (get-output-string out) ) ) ) ) ) ) ) )
498
499(define write-string 
500  (let ([display display])
501    (lambda (s . more)
502      (##sys#check-string s 'write-string)
503      (let-optionals more ([n #f] [port ##sys#standard-output])
504        (##sys#check-port port 'write-string)
505        (when n (##sys#check-exact n 'write-string))
506        (display
507         (if (and n (fx< n (##sys#size s)))
508             (##sys#substring s 0 n)
509             s)
510         port) ) ) ) )
511
512(define write-line
513  (let ((display display)
514        (newline newline) )
515    (lambda (str . port)
516      (let ((p (if (##core#inline "C_eqp" port '())
517                   ##sys#standard-output
518                   (##sys#slot port 0) ) ) )
519        (##sys#check-port p 'write-line)
520        (##sys#check-string str 'write-line)
521        (display str p)
522        (newline p) ) ) ) )
523
524
525;;; Binary I/O
526
527(define (read-byte #!optional (port ##sys#standard-input))
528  (##sys#check-port port 'read-byte)
529  (let ((x (##sys#read-char-0 port)))
530    (if (eof-object? x)
531        x
532        (char->integer x) ) ) )
533
534(define (write-byte byte #!optional (port ##sys#standard-output))
535  (##sys#check-exact byte 'write-byte)
536  (##sys#check-port port 'write-byte)
537  (##sys#write-char-0 (integer->char byte) port) )
538
539
540;;; Redirect standard ports:
541
542(define (with-input-from-port port thunk)
543  (##sys#check-port port 'with-input-from-port)
544  (fluid-let ([##sys#standard-input port])
545    (thunk) ) )
546
547(define (with-output-to-port port thunk)
548  (##sys#check-port port 'with-output-from-port)
549  (fluid-let ([##sys#standard-output port])
550    (thunk) ) )
551
552(define (with-error-output-to-port port thunk)
553  (##sys#check-port port 'with-error-output-from-port)
554  (fluid-let ([##sys#standard-error port])
555    (thunk) ) )
556
557
558;;; Extended string-port operations:
559 
560(define call-with-input-string 
561  (let ([open-input-string open-input-string])
562    (lambda (str proc)
563      (let ((in (open-input-string str)))
564        (proc in) ) ) ) )
565
566(define call-with-output-string
567  (let ((open-output-string open-output-string)
568        (get-output-string get-output-string) )
569    (lambda (proc)
570      (let ((out (open-output-string)))
571        (proc out)
572        (get-output-string out) ) ) ) )
573
574(define with-input-from-string
575  (let ((open-input-string open-input-string))
576    (lambda (str thunk)
577      (fluid-let ([##sys#standard-input (open-input-string str)])
578        (thunk) ) ) ) )
579
580(define with-output-to-string
581  (let ([open-output-string open-output-string]
582        [get-output-string get-output-string] )
583    (lambda (thunk)
584      (fluid-let ([##sys#standard-output (open-output-string)])
585        (thunk) 
586        (get-output-string ##sys#standard-output) ) ) ) )
587
588
589;;; Custom ports:
590;
591; - Port-slots:
592;
593;   10: last
594
595(define make-input-port
596  (lambda (read ready? close #!optional peek read-string read-line)
597    (let* ((class
598            (vector
599             (lambda (p)                ; read-char
600               (let ([last (##sys#slot p 10)])
601                 (cond [peek (read)]
602                       [last
603                        (##sys#setislot p 10 #f)
604                        last]
605                       [else (read)] ) ) )
606             (lambda (p)                ; peek-char
607               (let ([last (##sys#slot p 10)])
608                 (cond [peek (peek)]
609                       [last last]
610                       [else
611                        (let ([last (read)])
612                          (##sys#setslot p 10 last)
613                          last) ] ) ) )
614             #f                         ; write-char
615             #f                         ; write-string
616             (lambda (p)                ; close
617               (close)
618               (##sys#setislot p 8 #t) )
619             #f                         ; flush-output
620             (lambda (p)                ; char-ready?
621               (ready?) )
622             read-string                ; read-string
623             read-line) )               ; read-line
624           (data (vector #f))
625           (port (##sys#make-port #t class "(custom)" 'custom)) )
626      (##sys#setslot port 9 data) 
627      port) ) )
628
629(define make-output-port
630  (let ([string string])
631    (lambda (write close . flush)
632      (let* ((flush (and (pair? flush) (car flush)))
633             (class
634              (vector
635               #f                       ; read-char
636               #f                       ; peek-char
637               (lambda (p c)            ; write-char
638                 (write (string c)) )
639               (lambda (p s)            ; write-string
640                 (write s) )
641               (lambda (p)              ; close
642                 (close)
643                 (##sys#setislot p 8 #t) )
644               (lambda (p)              ; flush-output
645                 (when flush (flush)) )
646               #f                       ; char-ready?
647               #f                       ; read-string
648               #f) )                    ; read-line
649             (data (vector #f))
650             (port (##sys#make-port #f class "(custom)" 'custom)) )
651        (##sys#setslot port 9 data) 
652        port) ) ) )
653
654
655;;; Pretty print:
656;
657; Copyright (c) 1991, Marc Feeley
658; Author: Marc Feeley (feeley@iro.umontreal.ca)
659; Distribution restrictions: none
660;
661; Modified by felix for use with CHICKEN
662;
663
664(define generic-write
665  (let ([open-output-string open-output-string]
666        [get-output-string get-output-string] )
667    (lambda (obj display? width output)
668
669      (define (read-macro? l)
670        (define (length1? l) (and (pair? l) (null? (cdr l))))
671        (let ((head (car l)) (tail (cdr l)))
672          (case head
673            ((quote quasiquote unquote unquote-splicing) (length1? tail))
674            (else                                        #f))))
675
676      (define (read-macro-body l)
677        (cadr l))
678
679      (define (read-macro-prefix l)
680        (let ((head (car l)) (tail (cdr l)))
681          (case head
682            ((quote)            "'")
683            ((quasiquote)       "`")
684            ((unquote)          ",")
685            ((unquote-splicing) ",@"))))
686
687      (define (out str col)
688        (and col (output str) (+ col (string-length str))))
689
690      (define (wr obj col)
691
692        (define (wr-expr expr col)
693          (if (read-macro? expr)
694              (wr (read-macro-body expr) (out (read-macro-prefix expr) col))
695              (wr-lst expr col)))
696
697        (define (wr-lst l col)
698          (if (pair? l)
699              (let loop ((l (cdr l))
700                         (col (and col (wr (car l) (out "(" col)))))
701                (cond ((not col) col)
702                      ((pair? l)
703                       (loop (cdr l) (wr (car l) (out " " col))))
704                      ((null? l) (out ")" col))
705                      (else      (out ")" (wr l (out " . " col))))))
706              (out "()" col)))
707
708        (cond ((pair? obj)        (wr-expr obj col))
709              ((null? obj)        (wr-lst obj col))
710              ((eof-object? obj)  (out "#<eof>" col))
711              ((vector? obj)      (wr-lst (vector->list obj) (out "#" col)))
712              ((boolean? obj)     (out (if obj "#t" "#f") col))
713              ((##sys#number? obj)      (out (##sys#number->string obj) col))
714              ((symbol? obj)
715               (let ([s (open-output-string)])
716                 (##sys#print obj #t s)
717                 (out (get-output-string s) col) ) )
718              ((procedure? obj)   (out (##sys#procedure->string obj) col))
719              ((string? obj)      (if display?
720                                      (out obj col)
721                                      (let loop ((i 0) (j 0) (col (out "\"" col)))
722                                        (if (and col (< j (string-length obj)))
723                                            (let ((c (string-ref obj j)))
724                                              (if (or (char=? c #\\)
725                                                      (char=? c #\"))
726                                                  (loop j
727                                                        (+ j 1)
728                                                        (out "\\"
729                                                             (out (##sys#substring obj i j)
730                                                                  col)))
731                                                  (loop i (+ j 1) col)))
732                                            (out "\""
733                                                 (out (##sys#substring obj i j) col))))))
734              ((char? obj)        (if display?
735                                      (out (make-string 1 obj) col)
736                                      (let ([code (char->integer obj)])
737                                        (out "#\\" col)
738                                        (cond [(char-name obj) 
739                                               => (lambda (cn) 
740                                                    (out (##sys#slot cn 1) col) ) ]
741                                              [(fx< code 32)
742                                               (out "x" col)
743                                               (out (number->string code 16) col) ]
744                                              [(fx> code 255)
745                                               (out (if (fx> code #xffff) "U" "u") col)
746                                               (out (number->string code 16) col) ]
747                                              [else (out (make-string 1 obj) col)] ) ) ) )
748              ((eof-object? obj)  (out "#<eof>" col))
749              ((##core#inline "C_undefinedp" obj) (out "#<unspecified>" col))
750              ((##core#inline "C_anypointerp" obj) (out (##sys#pointer->string obj) col))
751              ((eq? obj (##sys#slot '##sys#arbitrary-unbound-symbol 0))
752               (out "#<unbound value>" col) )
753              ((##sys#generic-structure? obj)
754               (let ([o (open-output-string)])
755                 (##sys#user-print-hook obj #t o)
756                 (out (get-output-string o) col) ) )
757              ((port? obj) (out (string-append "#<port " (##sys#slot obj 3) ">") col))
758              ((##core#inline "C_bytevectorp" obj)
759               (if (##core#inline "C_permanentp" obj)
760                   (out "#<static blob of size" col)
761                   (out "#<blob of size " col) )
762               (out (number->string (##core#inline "C_block_size" obj)) col)
763               (out ">" col) )
764              ((##core#inline "C_lambdainfop" obj)
765               (out "#<lambda info " col)
766               (out (##sys#lambda-info->string obj) col)
767               (out "#>" col) )
768              (else               (out "#<unprintable object>" col)) ) )
769
770      (define (pp obj col)
771
772        (define (spaces n col)
773          (if (> n 0)
774              (if (> n 7)
775                  (spaces (- n 8) (out "        " col))
776                  (out (##sys#substring "        " 0 n) col))
777              col))
778
779        (define (indent to col)
780          (and col
781               (if (< to col)
782                   (and (out (make-string 1 #\newline) col) (spaces to 0))
783                   (spaces (- to col) col))))
784
785        (define (pr obj col extra pp-pair)
786          (if (or (pair? obj) (vector? obj)) ; may have to split on multiple lines
787              (let ((result '())
788                    (left (max (+ (- (- width col) extra) 1) max-expr-width)))
789                (generic-write obj display? #f
790                               (lambda (str)
791                                 (set! result (cons str result))
792                                 (set! left (- left (string-length str)))
793                                 (> left 0)))
794                (if (> left 0)          ; all can be printed on one line
795                    (out (reverse-string-append result) col)
796                    (if (pair? obj)
797                        (pp-pair obj col extra)
798                        (pp-list (vector->list obj) (out "#" col) extra pp-expr))))
799              (wr obj col)))
800
801        (define (pp-expr expr col extra)
802          (if (read-macro? expr)
803              (pr (read-macro-body expr)
804                  (out (read-macro-prefix expr) col)
805                  extra
806                  pp-expr)
807              (let ((head (car expr)))
808                (if (symbol? head)
809                    (let ((proc (style head)))
810                      (if proc
811                          (proc expr col extra)
812                          (if (> (string-length (##sys#symbol->qualified-string head))
813                                 max-call-head-width)
814                              (pp-general expr col extra #f #f #f pp-expr)
815                              (pp-call expr col extra pp-expr))))
816                    (pp-list expr col extra pp-expr)))))
817
818                                        ; (head item1
819                                        ;       item2
820                                        ;       item3)
821        (define (pp-call expr col extra pp-item)
822          (let ((col* (wr (car expr) (out "(" col))))
823            (and col
824                 (pp-down (cdr expr) col* (+ col* 1) extra pp-item))))
825
826                                        ; (item1
827                                        ;  item2
828                                        ;  item3)
829        (define (pp-list l col extra pp-item)
830          (let ((col (out "(" col)))
831            (pp-down l col col extra pp-item)))
832
833        (define (pp-down l col1 col2 extra pp-item)
834          (let loop ((l l) (col col1))
835            (and col
836                 (cond ((pair? l)
837                        (let ((rest (cdr l)))
838                          (let ((extra (if (null? rest) (+ extra 1) 0)))
839                            (loop rest
840                                  (pr (car l) (indent col2 col) extra pp-item)))))
841                       ((null? l)
842                        (out ")" col))
843                       (else
844                        (out ")"
845                             (pr l
846                                 (indent col2 (out "." (indent col2 col)))
847                                 (+ extra 1)
848                                 pp-item)))))))
849
850        (define (pp-general expr col extra named? pp-1 pp-2 pp-3)
851
852          (define (tail1 rest col1 col2 col3)
853            (if (and pp-1 (pair? rest))
854                (let* ((val1 (car rest))
855                       (rest (cdr rest))
856                       (extra (if (null? rest) (+ extra 1) 0)))
857                  (tail2 rest col1 (pr val1 (indent col3 col2) extra pp-1) col3))
858                (tail2 rest col1 col2 col3)))
859
860          (define (tail2 rest col1 col2 col3)
861            (if (and pp-2 (pair? rest))
862                (let* ((val1 (car rest))
863                       (rest (cdr rest))
864                       (extra (if (null? rest) (+ extra 1) 0)))
865                  (tail3 rest col1 (pr val1 (indent col3 col2) extra pp-2)))
866                (tail3 rest col1 col2)))
867
868          (define (tail3 rest col1 col2)
869            (pp-down rest col2 col1 extra pp-3))
870
871          (let* ((head (car expr))
872                 (rest (cdr expr))
873                 (col* (wr head (out "(" col))))
874            (if (and named? (pair? rest))
875                (let* ((name (car rest))
876                       (rest (cdr rest))
877                       (col** (wr name (out " " col*))))
878                  (tail1 rest (+ col indent-general) col** (+ col** 1)))
879                (tail1 rest (+ col indent-general) col* (+ col* 1)))))
880
881        (define (pp-expr-list l col extra)
882          (pp-list l col extra pp-expr))
883
884        (define (pp-lambda expr col extra)
885          (pp-general expr col extra #f pp-expr-list #f pp-expr))
886
887        (define (pp-if expr col extra)
888          (pp-general expr col extra #f pp-expr #f pp-expr))
889
890        (define (pp-cond expr col extra)
891          (pp-call expr col extra pp-expr-list))
892
893        (define (pp-case expr col extra)
894          (pp-general expr col extra #f pp-expr #f pp-expr-list))
895
896        (define (pp-and expr col extra)
897          (pp-call expr col extra pp-expr))
898
899        (define (pp-let expr col extra)
900          (let* ((rest (cdr expr))
901                 (named? (and (pair? rest) (symbol? (car rest)))))
902            (pp-general expr col extra named? pp-expr-list #f pp-expr)))
903
904        (define (pp-begin expr col extra)
905          (pp-general expr col extra #f #f #f pp-expr))
906
907        (define (pp-do expr col extra)
908          (pp-general expr col extra #f pp-expr-list pp-expr-list pp-expr))
909
910                                        ; define formatting style (change these to suit your style)
911
912        (define indent-general 2)
913
914        (define max-call-head-width 5)
915
916        (define max-expr-width 50)
917
918        (define (style head)
919          (case head
920            ((lambda let* letrec define) pp-lambda)
921            ((if set!)                   pp-if)
922            ((cond)                      pp-cond)
923            ((case)                      pp-case)
924            ((and or)                    pp-and)
925            ((let)                       pp-let)
926            ((begin)                     pp-begin)
927            ((do)                        pp-do)
928            (else                        #f)))
929
930        (pr obj col 0 pp-expr))
931
932      (if width
933          (out (make-string 1 #\newline) (pp obj 0))
934          (wr obj 0)))) )
935
936; (reverse-string-append l) = (apply string-append (reverse l))
937
938(define (reverse-string-append l)
939
940  (define (rev-string-append l i)
941    (if (pair? l)
942      (let* ((str (car l))
943             (len (string-length str))
944             (result (rev-string-append (cdr l) (+ i len))))
945        (let loop ((j 0) (k (- (- (string-length result) i) len)))
946          (if (< j len)
947            (begin
948              (string-set! result k (string-ref str j))
949              (loop (+ j 1) (+ k 1)))
950            result)))
951      (make-string i)))
952
953  (rev-string-append l 0))
954
955; (pretty-print obj port) pretty prints 'obj' on 'port'.  The current
956; output port is used if 'port' is not specified.
957
958(define pretty-print-width (make-parameter 79))
959
960(define (pretty-print obj . opt)
961  (let ((port (if (pair? opt) (car opt) (current-output-port))))
962    (generic-write obj #f (pretty-print-width) (lambda (s) (display s port) #t))
963    (##core#undefined) ) )
964
965(define pp pretty-print)
966
967
968;;; Anything->string conversion:
969
970(define ->string 
971  (let ([open-output-string open-output-string]
972        [display display]
973        [string string]
974        [get-output-string get-output-string] )
975    (lambda (x)
976      (cond [(string? x) x]
977            [(symbol? x) (symbol->string x)]
978            [(char? x) (string x)]
979            [(number? x) (##sys#number->string x)]
980            [else
981             (let ([o (open-output-string)])
982               (display x o)
983               (get-output-string o) ) ] ) ) ) )
984
985(define conc
986  (let ([string-append string-append])
987    (lambda args
988      (apply string-append (map ->string args)) ) ) )
989
990
991;;; Search one string inside another:
992
993(let ()
994  (define (traverse which where start test loc)
995    (##sys#check-string which loc)
996    (##sys#check-string where loc)
997    (let ([wherelen (##sys#size where)]
998          [whichlen (##sys#size which)] )
999      (##sys#check-exact start loc)
1000      (let loop ([istart start] [iend whichlen])
1001        (cond [(fx> iend wherelen) #f]
1002              [(test istart whichlen) istart]
1003              [else
1004               (loop (fx+ istart 1)
1005                     (fx+ iend 1) ) ] ) ) ) )
1006  (set! ##sys#substring-index 
1007    (lambda (which where start)
1008      (traverse 
1009       which where start
1010       (lambda (i l) (##core#inline "C_substring_compare" which where 0 i l))
1011       'substring-index) ) )
1012  (set! ##sys#substring-index-ci 
1013    (lambda (which where start)
1014      (traverse
1015       which where start
1016       (lambda (i l) (##core#inline "C_substring_compare_case_insensitive" which where 0 i l)) 
1017       'substring-index-ci) ) ) )
1018
1019(define (substring-index which where #!optional (start 0))
1020  (##sys#substring-index which where start) )
1021
1022(define (substring-index-ci which where #!optional (start 0))
1023  (##sys#substring-index-ci which where start) )
1024
1025
1026;;; 3-Way string comparison:
1027
1028(define (string-compare3 s1 s2)
1029  (##sys#check-string s1 'string-compare3)
1030  (##sys#check-string s2 'string-compare3)
1031  (let ((len1 (##sys#size s1))
1032        (len2 (##sys#size s2)) )
1033    (let* ((len-diff (fx- len1 len2)) 
1034           (cmp (##core#inline "C_mem_compare" s1 s2 (if (fx< len-diff 0) len1 len2))))
1035      (if (fx= cmp 0) 
1036          len-diff 
1037          cmp))))
1038
1039(define (string-compare3-ci s1 s2)
1040  (##sys#check-string s1 'string-compare3-ci)
1041  (##sys#check-string s2 'string-compare3-ci)
1042  (let ((len1 (##sys#size s1))
1043        (len2 (##sys#size s2)) )
1044    (let* ((len-diff (fx- len1 len2)) 
1045           (cmp (##core#inline "C_string_compare_case_insensitive" s1 s2 (if (fx< len-diff 0) len1 len2))))
1046      (if (fx= cmp 0) 
1047          len-diff 
1048          cmp))))
1049
1050
1051;;; Substring comparison:
1052
1053(define (##sys#substring=? s1 s2 start1 start2 n)
1054  (##sys#check-string s1 'substring=?)
1055  (##sys#check-string s2 'substring=?)
1056  (let ((len (or n
1057                 (fxmin (fx- (##sys#size s1) start1)
1058                        (fx- (##sys#size s2) start2) ) ) ) )
1059    (##sys#check-exact start1 'substring=?)
1060    (##sys#check-exact start2 'substring=?)
1061    (##core#inline "C_substring_compare" s1 s2 start1 start2 len) ) )
1062
1063(define (substring=? s1 s2 #!optional (start1 0) (start2 0) len)
1064  (##sys#substring=? s1 s2 start1 start2 len) )
1065
1066(define (##sys#substring-ci=? s1 s2 start1 start2 n)
1067  (##sys#check-string s1 'substring-ci=?)
1068  (##sys#check-string s2 'substring-ci=?)
1069  (let ((len (or n
1070                 (fxmin (fx- (##sys#size s1) start1)
1071                        (fx- (##sys#size s2) start2) ) ) ) )
1072    (##sys#check-exact start1 'substring-ci=?)
1073    (##sys#check-exact start2 'substring-ci=?)
1074    (##core#inline "C_substring_compare_case_insensitive"
1075                   s1 s2 start1 start2 len) ) )
1076
1077(define (substring-ci=? s1 s2 #!optional (start1 0) (start2 0) len)
1078  (##sys#substring-ci=? s1 s2 start1 start2 len) )
1079
1080
1081;;; Split string into substrings:
1082
1083(define string-split
1084  (lambda (str . delstr-and-flag)
1085    (##sys#check-string str 'string-split)
1086    (let* ([del (if (null? delstr-and-flag) "\t\n " (car delstr-and-flag))]
1087           [flag (if (fx= (length delstr-and-flag) 2) (cadr delstr-and-flag) #f)]
1088           [strlen (##sys#size str)] )
1089      (##sys#check-string del 'string-split)
1090      (let ([dellen (##sys#size del)] 
1091            [first #f] )
1092        (define (add from to last)
1093          (let ([node (cons (##sys#substring str from to) '())])
1094            (if first
1095                (##sys#setslot last 1 node)
1096                (set! first node) ) 
1097            node) )
1098        (let loop ([i 0] [last #f] [from 0])
1099          (cond [(fx>= i strlen)
1100                 (when (or (fx> i from) flag) (add from i last))
1101                 (or first '()) ]
1102                [else
1103                 (let ([c (##core#inline "C_subchar" str i)])
1104                   (let scan ([j 0])
1105                     (cond [(fx>= j dellen) (loop (fx+ i 1) last from)]
1106                           [(eq? c (##core#inline "C_subchar" del j))
1107                            (let ([i2 (fx+ i 1)])
1108                              (if (or (fx> i from) flag)
1109                                  (loop i2 (add from i last) i2)
1110                                  (loop i2 last i2) ) ) ]
1111                           [else (scan (fx+ j 1))] ) ) ) ] ) ) ) ) ) )
1112
1113
1114;;; Concatenate list of strings:
1115
1116(define (string-intersperse strs #!optional (ds " "))
1117  (##sys#check-list strs 'string-intersperse)
1118  (##sys#check-string ds 'string-intersperse)
1119  (let ((dslen (##sys#size ds)))
1120    (let loop1 ((ss strs) (n 0))
1121      (cond ((##core#inline "C_eqp" ss '())
1122             (if (##core#inline "C_eqp" strs '())
1123                 ""
1124                 (let ((str2 (##sys#allocate-vector (fx- n dslen) #t #\space #f)))
1125                   (let loop2 ((ss2 strs) (n2 0))
1126                     (let* ((stri (##sys#slot ss2 0))
1127                            (next (##sys#slot ss2 1)) 
1128                            (strilen (##sys#size stri)) )
1129                       (##core#inline "C_substring_copy" stri str2 0 strilen n2)
1130                       (let ((n3 (fx+ n2 strilen)))
1131                         (if (##core#inline "C_eqp" next '())
1132                             str2
1133                             (begin
1134                               (##core#inline "C_substring_copy" ds str2 0 dslen n3)
1135                               (loop2 next (fx+ n3 dslen)) ) ) ) ) ) ) ) )
1136            ((and (##core#inline "C_blockp" ss) (##core#inline "C_pairp" ss))
1137             (let ((stri (##sys#slot ss 0)))
1138               (##sys#check-string stri 'string-intersperse)
1139               (loop1 (##sys#slot ss 1)
1140                      (fx+ (##sys#size stri) (fx+ dslen n)) ) ) )
1141            (else (##sys#not-a-proper-list-error strs)) ) ) ) )
1142
1143
1144;;; Translate elements of a string:
1145
1146(define string-translate 
1147  (let ([make-string make-string]
1148        [list->string list->string] )
1149    (lambda (str from . to)
1150
1151      (define (instring s)
1152        (let ([len (##sys#size s)])
1153          (lambda (c)
1154            (let loop ([i 0])
1155              (cond [(fx>= i len) #f]
1156                    [(eq? c (##core#inline "C_subchar" s i)) i]
1157                    [else (loop (fx+ i 1))] ) ) ) ) )
1158
1159      (let* ([from
1160              (cond [(char? from) (lambda (c) (eq? c from))]
1161                    [(pair? from) (instring (list->string from))]
1162                    [else
1163                     (##sys#check-string from 'string-translate)
1164                     (instring from) ] ) ]
1165             [to
1166              (and (pair? to)
1167                   (let ([tx (##sys#slot to 0)])
1168                     (cond [(char? tx) tx]
1169                           [(pair? tx) (list->string tx)]
1170                           [else
1171                            (##sys#check-string tx 'string-translate)
1172                            tx] ) ) ) ] 
1173             [tlen (and (string? to) (##sys#size to))] )
1174        (##sys#check-string str 'string-translate)
1175        (let* ([slen (##sys#size str)]
1176               [str2 (make-string slen)] )
1177          (let loop ([i 0] [j 0])
1178            (if (fx>= i slen)
1179                (if (fx< j i)
1180                    (##sys#substring str2 0 j)
1181                    str2)
1182                (let* ([ci (##core#inline "C_subchar" str i)]
1183                       [found (from ci)] )
1184                  (cond [(not found)
1185                         (##core#inline "C_setsubchar" str2 j ci)
1186                         (loop (fx+ i 1) (fx+ j 1)) ]
1187                        [(not to) (loop (fx+ i 1) j)]
1188                        [(char? to)
1189                         (##core#inline "C_setsubchar" str2 j to)
1190                         (loop (fx+ i 1) (fx+ j 1)) ]
1191                        [(cond-expand [unsafe #f] [else (fx>= found tlen)])
1192                         (##sys#error 'string-translate "invalid translation destination" i to) ]
1193                        [else
1194                         (##core#inline "C_setsubchar" str2 j (##core#inline "C_subchar" to found))
1195                         (loop (fx+ i 1) (fx+ j 1)) ] ) ) ) ) ) ) ) ) )
1196
1197(define (string-translate* str smap)
1198  (##sys#check-string str 'string-translate*)
1199  (##sys#check-list smap 'string-translate*)
1200  (let ([len (##sys#size str)])
1201    (define (collect i from total fs)
1202      (if (fx>= i len)
1203          (##sys#fragments->string
1204           total
1205           (reverse
1206            (if (fx> i from) 
1207                (cons (##sys#substring str from i) fs)
1208                fs) ) )
1209          (let loop ([smap smap])
1210            (if (null? smap) 
1211                (collect (fx+ i 1) from (fx+ total 1) fs)
1212                (let* ([p (car smap)]
1213                       [sm (car p)]
1214                       [smlen (string-length sm)]
1215                       [st (cdr p)] )
1216                  (if (##core#inline "C_substring_compare" str sm i 0 smlen)
1217                      (let ([i2 (fx+ i smlen)])
1218                        (when (fx> i from)
1219                          (set! fs (cons (##sys#substring str from i) fs)) )
1220                        (collect 
1221                         i2 i2
1222                         (fx+ total (string-length st))
1223                         (cons st fs) ) ) 
1224                      (loop (cdr smap)) ) ) ) ) ) )
1225    (collect 0 0 0 '()) ) )
1226
1227
1228;;; Chop string into substrings:
1229
1230(define (string-chop str len)
1231  (##sys#check-string str 'string-chop)
1232  (##sys#check-exact len 'string-chop)
1233  (let ([total (##sys#size str)])
1234    (let loop ([total total] [pos 0])
1235      (cond [(fx<= total 0) '()]
1236            [(fx<= total len) (list (##sys#substring str pos (fx+ pos total)))]
1237            [else (cons (##sys#substring str pos (fx+ pos len)) (loop (fx- total len) (fx+ pos len)))] ) ) ) )
1238           
1239
1240;;; Remove suffix
1241
1242(define (string-chomp str #!optional (suffix "\n"))
1243  (##sys#check-string str 'string-chomp)
1244  (##sys#check-string suffix 'string-chomp)
1245  (let* ((len (##sys#size str))
1246         (slen (##sys#size suffix)) 
1247         (diff (fx- len slen)) )
1248    (if (and (fx>= len slen)
1249             (##core#inline "C_substring_compare" str suffix diff 0 slen) )
1250        (##sys#substring str 0 diff)
1251        str) ) )
1252
1253
1254;;; Write simple formatted output:
1255
1256(define fprintf
1257  (let ([write write]
1258        [newline newline]
1259        [display display] )
1260    (lambda (port msg . args)
1261      (let rec ([msg msg] [args args])
1262        (##sys#check-string msg 'fprintf)
1263        (##sys#check-port port 'fprintf)
1264        (let ((index 0)
1265              (len (##sys#size msg)) )
1266          (define (fetch)
1267            (let ((c (##core#inline "C_subchar" msg index)))
1268              (set! index (fx+ index 1))
1269              c) )
1270          (define (next)
1271            (if (cond-expand [unsafe #f] [else (##core#inline "C_eqp" args '())])
1272                (##sys#error 'fprintf "too few arguments to formatted output procedure")
1273                (let ((x (##sys#slot args 0)))
1274                  (set! args (##sys#slot args 1)) 
1275                  x) ) )
1276          (let loop ()
1277            (unless (fx>= index len)
1278              (let ((c (fetch)))
1279                (if (and (eq? c #\~) (fx< index len))
1280                    (let ((dchar (fetch)))
1281                      (case (char-upcase dchar)
1282                        ((#\S) (write (next) port))
1283                        ((#\A) (display (next) port))
1284                        ((#\C) (##sys#write-char-0 (next) port))
1285                        ((#\B) (display (##sys#number->string (next) 2) port))
1286                        ((#\O) (display (##sys#number->string (next) 8) port))
1287                        ((#\X) (display (##sys#number->string (next) 16) port))
1288                        ((#\!) (##sys#flush-output port))
1289                        ((#\?)
1290                         (let* ([fstr (next)]
1291                                [lst (next)] )
1292                           (##sys#check-list lst 'fprintf)
1293                           (rec fstr lst) ) )
1294                        ((#\~) (##sys#write-char-0 #\~ port))
1295                        ((#\%) (newline port))
1296                        ((#\% #\N) (newline port))
1297                        (else
1298                         (if (char-whitespace? dchar)
1299                             (let skip ((c (fetch)))
1300                               (if (char-whitespace? c)
1301                                   (skip (fetch))
1302                                   (set! index (fx- index 1)) ) )
1303                             (##sys#error 'fprintf "illegal format-string character" dchar) ) ) ) )
1304                    (##sys#write-char-0 c port) )
1305                (loop) ) ) ) ) ) ) ) )
1306
1307
1308(define printf
1309  (let ((fprintf fprintf)
1310        (current-output-port current-output-port) )
1311    (lambda (msg . args)
1312      (apply fprintf (current-output-port) msg args) ) ) )
1313
1314
1315(define sprintf
1316  (let ((open-output-string open-output-string)
1317        (get-output-string get-output-string)
1318        (fprintf fprintf) )
1319    (lambda (fstr . args)
1320      (let ((out (open-output-string)))
1321        (apply fprintf out fstr args)
1322        (get-output-string out) ) ) ) )
1323
1324
1325(define format
1326  (let ((fprintf fprintf) (sprintf sprintf) (printf printf))
1327    (lambda (fmt-or-dst . args)
1328      (apply
1329        (cond
1330          [(not fmt-or-dst)          sprintf]
1331          [(boolean? fmt-or-dst)     printf]
1332          [(string? fmt-or-dst)      (set! args (cons fmt-or-dst args)) sprintf]
1333          [(output-port? fmt-or-dst) (set! args (cons fmt-or-dst args)) fprintf]
1334          [else (##sys#error 'format "illegal destination" fmt-or-dst args)])
1335        args) ) ) )
1336
1337(register-feature! 'srfi-28)
1338
1339
1340;;; Defines: sorted?, merge, merge!, sort, sort!
1341;;; Author : Richard A. O'Keefe (based on Prolog code by D.H.D.Warren)
1342;;;
1343;;; This code is in the public domain.
1344
1345;;; Updated: 11 June 1991
1346;;; Modified for scheme library: Aubrey Jaffer 19 Sept. 1991
1347;;; Updated: 19 June 1995
1348
1349;;; (sorted? sequence less?)
1350;;; is true when sequence is a list (x0 x1 ... xm) or a vector #(x0 ... xm)
1351;;; such that for all 1 <= i <= m,
1352;;;     (not (less? (list-ref list i) (list-ref list (- i 1)))).
1353
1354; Modified by flw for use with CHICKEN:
1355;
1356
1357
1358(define (sorted? seq less?)
1359    (cond
1360        ((null? seq)
1361            #t)
1362        ((vector? seq)
1363            (let ((n (vector-length seq)))
1364                (if (<= n 1)
1365                    #t
1366                    (do ((i 1 (+ i 1)))
1367                        ((or (= i n)
1368                             (less? (vector-ref seq i)
1369                                    (vector-ref seq (- i 1))))
1370                            (= i n)) )) ))
1371        (else
1372            (let loop ((last (car seq)) (next (cdr seq)))
1373                (or (null? next)
1374                    (and (not (less? (car next) last))
1375                         (loop (car next) (cdr next)) )) )) ))
1376
1377
1378;;; (merge a b less?)
1379;;; takes two lists a and b such that (sorted? a less?) and (sorted? b less?)
1380;;; and returns a new list in which the elements of a and b have been stably
1381;;; interleaved so that (sorted? (merge a b less?) less?).
1382;;; Note:  this does _not_ accept vectors.  See below.
1383
1384(define (merge a b less?)
1385    (cond
1386        ((null? a) b)
1387        ((null? b) a)
1388        (else (let loop ((x (car a)) (a (cdr a)) (y (car b)) (b (cdr b)))
1389            ;; The loop handles the merging of non-empty lists.  It has
1390            ;; been written this way to save testing and car/cdring.
1391            (if (less? y x)
1392                (if (null? b)
1393                    (cons y (cons x a))
1394                    (cons y (loop x a (car b) (cdr b)) ))
1395                ;; x <= y
1396                (if (null? a)
1397                    (cons x (cons y b))
1398                    (cons x (loop (car a) (cdr a) y b)) )) )) ))
1399
1400
1401;;; (merge! a b less?)
1402;;; takes two sorted lists a and b and smashes their cdr fields to form a
1403;;; single sorted list including the elements of both.
1404;;; Note:  this does _not_ accept vectors.
1405
1406(define (merge! a b less?)
1407    (define (loop r a b)
1408        (if (less? (car b) (car a))
1409            (begin
1410                (set-cdr! r b)
1411                (if (null? (cdr b))
1412                    (set-cdr! b a)
1413                    (loop b a (cdr b)) ))
1414            ;; (car a) <= (car b)
1415            (begin
1416                (set-cdr! r a)
1417                (if (null? (cdr a))
1418                    (set-cdr! a b)
1419                    (loop a (cdr a) b)) )) )
1420    (cond
1421        ((null? a) b)
1422        ((null? b) a)
1423        ((less? (car b) (car a))
1424            (if (null? (cdr b))
1425                (set-cdr! b a)
1426                (loop b a (cdr b)))
1427            b)
1428        (else ; (car a) <= (car b)
1429            (if (null? (cdr a))
1430                (set-cdr! a b)
1431                (loop a (cdr a) b))
1432            a)))
1433
1434
1435;;; (sort! sequence less?)
1436;;; sorts the list or vector sequence destructively.  It uses a version
1437;;; of merge-sort invented, to the best of my knowledge, by David H. D.
1438;;; Warren, and first used in the DEC-10 Prolog system.  R. A. O'Keefe
1439;;; adapted it to work destructively in Scheme.
1440
1441(define (sort! seq less?)
1442    (define (step n)
1443        (cond
1444            ((> n 2)
1445                (let* ((j (quotient n 2))
1446                       (a (step j))
1447                       (k (- n j))
1448                       (b (step k)))
1449                    (merge! a b less?)))
1450            ((= n 2)
1451                (let ((x (car seq))
1452                      (y (cadr seq))
1453                      (p seq))
1454                    (set! seq (cddr seq))
1455                    (if (less? y x) (begin
1456                        (set-car! p y)
1457                        (set-car! (cdr p) x)))
1458                    (set-cdr! (cdr p) '())
1459                    p))
1460            ((= n 1)
1461                (let ((p seq))
1462                    (set! seq (cdr seq))
1463                    (set-cdr! p '())
1464                    p))
1465            (else
1466                '()) ))
1467    (if (vector? seq)
1468        (let ((n (vector-length seq))
1469              (vec seq))
1470          (set! seq (vector->list seq))
1471          (do ((p (step n) (cdr p))
1472               (i 0 (+ i 1)))
1473              ((null? p) vec)
1474            (vector-set! vec i (car p)) ))
1475        ;; otherwise, assume it is a list
1476        (step (length seq)) ))
1477
1478;;; (sort sequence less?)
1479;;; sorts a vector or list non-destructively.  It does this by sorting a
1480;;; copy of the sequence.  My understanding is that the Standard says
1481;;; that the result of append is always "newly allocated" except for
1482;;; sharing structure with "the last argument", so (append x '()) ought
1483;;; to be a standard way of copying a list x.
1484
1485(define (sort seq less?)
1486    (if (vector? seq)
1487        (list->vector (sort! (vector->list seq) less?))
1488        (sort! (append seq '()) less?)))
1489
1490
1491;;; Binary search:
1492
1493(define binary-search
1494  (let ([list->vector list->vector])
1495    (lambda (vec proc)
1496      (if (pair? vec)
1497          (set! vec (list->vector vec))
1498          (##sys#check-vector vec 'binary-search) )
1499      (let ([len (##sys#size vec)])
1500        (and (fx> len 0)
1501             (let loop ([ps 0]
1502                        [pe len] )
1503               (let ([p (fx+ ps (##core#inline "C_fixnum_divide" (fx- pe ps) 2))])
1504                 (let* ([x (##sys#slot vec p)]
1505                        [r (proc x)] )
1506                   (cond [(fx= r 0) p]
1507                         [(fx< r 0) (and (not (fx= pe p)) (loop ps p))]
1508                         [else (and (not (fx= ps p)) (loop p pe))] ) ) ) ) ) ) ) ) )
1509
1510
1511;;; Hashtables:
1512
1513;;; Utility definitions:
1514
1515(define-constant hashtab-default-size 307)
1516(define-constant hashtab-threshold 0.5)
1517
1518; Predefined sizes for the hash tables:
1519;
1520; Start in 307; each element is the smallest prime that is at least twice as
1521; bigger as the previous element in the list.  The last number is an
1522; exception: it is the largest fixnum we can repressent.
1523
1524(define-constant hashtab-primes-table
1525  '(307 617 1237 2477 4957 9923 19853 39709 79423 158849 317701 635413 1270849
1526        2541701 5083423 10166857 20333759 40667527 81335063 162670129 325340273 
1527        650680571 1073741823))
1528
1529(define-constant hashtab-max-size 1073741823)
1530
1531(define (hash-table? x) (##sys#structure? x 'hash-table))
1532
1533
1534;;; Creation and erasure:
1535
1536(define make-hash-table
1537  (let ([make-vector make-vector])
1538    (lambda test-and-size
1539      (let-optionals test-and-size ([test equal?] 
1540                                    [hashf ##sys#hash] 
1541                                    [len hashtab-default-size])
1542        (##sys#check-exact len 'make-hash-table)
1543        (##sys#make-structure 'hash-table (make-vector len '()) 0 test hashf) ) ) ) )
1544
1545(define hash-table-copy 
1546  (let ((make-vector make-vector))
1547    (lambda (ht)
1548      (##sys#check-structure ht 'hash-table 'hash-table-copy)
1549      (let* ((vec1 (##sys#slot ht 1))
1550             (len (##sys#size vec1))
1551             (vec2 (make-vector len '())) )
1552        (do ((i 0 (fx+ i 1)))
1553            ((fx>= i len)
1554             (##sys#make-structure
1555              'hash-table vec2 (##sys#slot ht 2) (##sys#slot ht 3) (##sys#slot ht 4)) )
1556          (##sys#setslot 
1557           vec2 i
1558           (let copy ((lst (##sys#slot vec1 i)))
1559             (if (null? lst)
1560                 '()
1561                 (let ((b (##sys#slot lst 0)))
1562                   (cons (cons (##sys#slot b 0) (##sys#slot b 1))
1563                         (copy (##sys#slot lst 1))))))))))) )
1564
1565
1566;;; Hash-table property-accessors
1567
1568(define (hash-table-equivalence-function ht)
1569  (##sys#check-structure ht 'hash-table 'hash-table-equivalence-function) 
1570  (##sys#slot ht 3) )
1571
1572(define (hash-table-hash-function ht)
1573  (##sys#check-structure ht 'hash-table 'hash-table-hash-function) 
1574  (##sys#slot ht 4) )
1575
1576
1577;;; Generation of hash-values:
1578
1579(define-constant hash-depth-limit 4)
1580(define-constant default-hash-bound 536870912)
1581
1582(define ##sys#hash
1583  (lambda (x limit)
1584    (define (hash-with-test x d)
1585      (if (or (not (##core#inline "C_blockp" x)) (##core#inline "C_byteblockp" x) (symbol? x))
1586          (rechash x (fx+ d 1))
1587          99) )
1588    (define (rechash x d)
1589      (cond ((fx>= d hash-depth-limit) 0)
1590            ((##core#inline "C_fixnump" x) x)
1591            ((##core#inline "C_charp" x) (char->integer x))
1592            ((eq? x #t) 256)
1593            ((eq? x #f) 257)
1594            ((eq? x '()) 258)
1595            ((##core#inline "C_eofp" x) 259)
1596            ((not (##core#inline "C_blockp" x)) 262)
1597            ((##core#inline "C_symbolp" x) (##core#inline "C_hash_string" (##sys#slot x 1)))
1598            ((list? x) (fx+ (length x) (hash-with-test (##sys#slot x 0) d)))
1599            ((pair? x) 
1600             (fx+ (fxshl (hash-with-test (##sys#slot x 0) d) 16)
1601                  (hash-with-test (##sys#slot x 1) d) ) )
1602            ((##core#inline "C_portp" x) (if (input-port? x) 260 261))
1603            ((##core#inline "C_byteblockp" x) (##core#inline "C_hash_string" x))
1604            (else
1605             (let ([len (##sys#size x)]
1606                   [start (if (##core#inline "C_specialp" x) 1 0)] )
1607               (let loop ([k (fx+ len (if (##core#inline "C_specialp" x) (##core#inline "C_peek_fixnum" x 0) 0))]
1608                          [i start]
1609                          [len (fx- (if (fx> len 4) 4 len) start)] )
1610                 (if (fx= len 0)
1611                     k
1612                     (loop (fx+ k (fx+ (fx* k 16) (##core#inline "C_fix" (rechash (##sys#slot x i) (fx+ d 1)))))
1613                           (fx+ i 1)
1614                           (fx- len 1) ) ) ) ) ) ) )
1615    (##sys#check-exact limit 'hash)
1616    (##core#inline "C_fixnum_modulo" (fxand (foreign-value "C_MOST_POSITIVE_FIXNUM" int) (rechash x 0)) limit) ) )
1617
1618(define (hash x #!optional (bound default-hash-bound))
1619  (##sys#check-exact bound 'hash)
1620  (##sys#hash x bound) )
1621
1622(define hash-by-identity hash)
1623
1624(define (string-hash s #!optional (bound default-hash-bound))
1625  (##sys#check-string s 'string-hash)
1626  (##core#inline 
1627   "C_fixnum_modulo"
1628   (##core#inline "C_hash_string" s)
1629   bound) )
1630
1631(define (string-ci-hash s #!optional (bound default-hash-bound))
1632  (##sys#check-string s 'string-ci-hash)
1633  (##core#inline 
1634   "C_fixnum_modulo"
1635   (##core#inline "C_hash_string_ci" s)
1636   bound) )
1637
1638
1639;;; Access:
1640
1641(define (hash-table-size ht)
1642  (##sys#check-structure ht 'hash-table 'hash-table-size)
1643  (##sys#slot ht 2) )
1644
1645(define hash-table-update! 
1646  ;; This one was suggested by Sven Hartrumpf (and subsequently added in SRFI-69)
1647  (let ([eq0 eq?]
1648        [floor floor] )
1649    (lambda (ht key proc #!optional
1650           (init (lambda () (##sys#signal-hook #:access-error 'hash-table-update!
1651                            "hash-table does not contain key" key ht))))
1652      (##sys#check-structure ht 'hash-table 'hash-table-update!)
1653      (let restart ()
1654        (let* ((vec (##sys#slot ht 1))
1655               (hashf (##sys#slot ht 4))
1656               (len (##sys#size vec))
1657               (test (##sys#slot ht 3))
1658               (k (hashf key len))
1659               (c (fx+ (##sys#slot ht 2) 1)) )
1660          (if (and (fx>= c (inexact->exact (floor (* len hashtab-threshold))))
1661                   (fx< len hashtab-max-size))
1662              (let ((vec2 (make-vector
1663                            (##sys#hash-new-len hashtab-primes-table
1664                                                (fxmin hashtab-max-size (fx* len 2)))
1665                            '())))
1666                (hashtab-rehash vec vec2 hashf)
1667                (##sys#setslot ht 1 vec2)
1668                (restart) ) 
1669              (let ((bucket0 (##sys#slot vec k)))
1670                (if (eq? eq0 test)
1671                    ;; Fast path (eq? test):
1672                    (let loop ((bucket bucket0))
1673                      (cond ((eq? bucket '())
1674                             (let ((val (proc (init))))
1675                               (##sys#setslot vec k (cons (cons key val) bucket0))
1676                               (##sys#setslot ht 2 c) 
1677                               val) )
1678                            (else
1679                             (let ((b (##sys#slot bucket 0)))
1680                               (if (eq? key (##sys#slot b 0))
1681                                   (let ((val (proc (##sys#slot b 1))))
1682                                     (##sys#setslot b 1 val)
1683                                     val)
1684                                   (loop (##sys#slot bucket 1)) ) ) ) ) )
1685                    (let loop ((bucket bucket0))
1686                      (cond ((eq? bucket '())
1687                             (let ((val (proc (init))))
1688                               (##sys#setslot vec k (cons (cons key val) bucket0))
1689                               (##sys#setslot ht 2 c) 
1690                               val) )
1691                            (else
1692                             (let ((b (##sys#slot bucket 0)))
1693                               (if (test key (##sys#slot b 0))
1694                                   (let ((val (proc (##sys#slot b 1))))
1695                                     (##sys#setslot b 1 val)
1696                                     val) 
1697                                   (loop (##sys#slot bucket 1)) ) ) ) ) ) ) ) ) ) ) ) ) )
1698
1699(define hash-table-update!/default 
1700  (let ((hash-table-update! hash-table-update!))
1701    (lambda (ht key func def)
1702      (hash-table-update! ht key func (lambda () def)) ) ) )
1703
1704(define hash-table-set! 
1705  (let ([hash-table-update! hash-table-update!])
1706    (lambda (ht key val)
1707      (hash-table-update! ht key (lambda (x) val) (lambda () val)) ) ) )
1708
1709(define hash-table-ref
1710  (let ([eq0 eq?])
1711    (getter-with-setter
1712     (lambda (ht key . default)
1713       (##sys#check-structure ht 'hash-table 'hash-table-ref)
1714       (let* ([vec (##sys#slot ht 1)]
1715              [hashf (##sys#slot ht 4)]
1716              [k (hashf key (##sys#size vec))] 
1717              [def (if (pair? default) 
1718                       (car default)
1719                       (cut ##sys#signal-hook #:access-error 'hash-table-ref "hash-table does not contain key" key ht) ) ]
1720              [test (##sys#slot ht 3)] )
1721         (if (eq? eq0 test)
1722             ;; Fast path (eq? test):
1723             (let loop ((bucket (##sys#slot vec k)))
1724               (if (eq? bucket '())
1725                   (def)
1726                   (let ((b (##sys#slot bucket 0)))
1727                     (if (eq? key (##sys#slot b 0))
1728                         (##sys#slot b 1)
1729                         (loop (##sys#slot bucket 1)) ) ) ) )
1730             (let loop ((bucket (##sys#slot vec k)))
1731               (if (eq? bucket '())
1732                   (def)
1733                   (let ((b (##sys#slot bucket 0)))
1734                     (if (test key (##sys#slot b 0))
1735                         (##sys#slot b 1)
1736                         (loop (##sys#slot bucket 1)) ) ) ) ) ) ) )
1737     hash-table-set!) ) )
1738
1739(define hash-table-ref/default
1740  (let ((hash-table-ref hash-table-ref))
1741    (lambda (ht key def)
1742      (hash-table-ref ht key (lambda () def)) ) ) )
1743
1744(define hash-table-exists?
1745  (let ((unique (vector 42))
1746        (ref hash-table-ref/default) )
1747    (lambda (ht key)
1748      (##sys#check-structure ht 'hash-table 'hash-table-exists?)
1749      (not (eq? unique (ref ht key unique))) ) ) )
1750
1751(define (##sys#hash-new-len tab req)
1752  (if (or (fx>= (##sys#slot tab 0) req)
1753          (eq? (##sys#slot tab 1) '()))
1754      (##sys#slot tab 0)
1755      (##sys#hash-new-len (##sys#slot tab 1) req)))
1756
1757(define hash-table-delete!
1758  (let ([eq0 eq?])
1759    (lambda (ht key)
1760      (##sys#check-structure ht 'hash-table 'hash-table-delete!)
1761      (let* ((vec (##sys#slot ht 1))
1762             (hashf (##sys#slot ht 4))
1763             (len (##sys#size vec))
1764             (test (##sys#slot ht 3))
1765             (k (hashf key len))
1766             (c (fx- (##sys#slot ht 2) 1)))
1767        (let ((bucket0 (##sys#slot vec k)))
1768          (if (eq? eq0 test)
1769              ;; Fast path (eq? test):
1770              (let loop ((prev #f)
1771                         (bucket bucket0))
1772                (if (null? bucket)
1773                    #f
1774                    (let ((b (##sys#slot bucket 0)))
1775                      (if (eq? key (##sys#slot b 0))
1776                          (begin
1777                            (if (not prev)
1778                                (##sys#setslot vec k (##sys#slot bucket 1))
1779                                (##sys#setslot prev 1 (##sys#slot bucket 1)))
1780                            (##sys#setslot ht 2 c)
1781                            #t)
1782                          (loop bucket (##sys#slot bucket 1))))))
1783              (let loop ((prev #f)
1784                         (bucket bucket0))
1785                (if (null? bucket)
1786                    #f
1787                    (let ((b (##sys#slot bucket 0)))
1788                      (if (test key (##sys#slot b 0))
1789                          (begin
1790                            (if (not prev)
1791                                (##sys#setslot vec k (##sys#slot bucket 1))
1792                                (##sys#setslot prev 1 (##sys#slot bucket 1)))
1793                            (##sys#setslot ht 2 c)
1794                            #t)
1795                          (loop bucket (##sys#slot bucket 1))))))))))))
1796
1797(define (hash-table-remove! ht proc)
1798  (##sys#check-structure ht 'hash-table 'hash-table-remove!)
1799  (let* ((vec (##sys#slot ht 1))
1800         (len (##sys#size vec))
1801         (c (##sys#slot ht 2)) )
1802    (do ((i 0 (fx+ i 1)))
1803        ((fx>= i len) (##sys#setislot ht 2 c))
1804      (let loop ((prev #f)
1805                 (bucket (##sys#slot vec i)) )
1806        (unless (null? bucket)
1807          (let ((b (##sys#slot bucket 0)))
1808            (when (proc (##sys#slot b 0) (##sys#slot b 1))
1809              (if prev
1810                  (##sys#setslot prev 1 (##sys#slot bucket 1))
1811                  (##sys#setslot vec i (##sys#slot bucket 1)) )
1812              (set! c (fx- c 1)) )
1813            (loop bucket (##sys#slot bucket 1) ) ) ) ) ) ) )
1814
1815(define hashtab-rehash
1816  (lambda (vec1 vec2 hashf)
1817    (let ([len1 (##sys#size vec1)]
1818          [len2 (##sys#size vec2)] )
1819      (do ([i 0 (fx+ i 1)])
1820          ((fx>= i len1))
1821        (let loop ([bucket (##sys#slot vec1 i)])
1822          (unless (null? bucket)
1823            (let* ([b (##sys#slot bucket 0)]
1824                   [x (##sys#slot b 0)] 
1825                   [k (hashf x len2)] )
1826              (##sys#setslot vec2 k (cons (cons x (##sys#slot b 1)) (##sys#slot vec2 k)))
1827              (loop (##sys#slot bucket 1)) ) ) ) ) ) ) )
1828
1829(define hash-table-merge!
1830  (let ((hash-table-set! hash-table-set!))
1831    (lambda (ht1 ht2)
1832      (##sys#check-structure ht1 'hash-table 'hash-table-merge!)
1833      (##sys#check-structure ht2 'hash-table 'hash-table-merge!)
1834      (let* ((vec (##sys#slot ht2 1))
1835             (len (##sys#size vec)) )
1836        (do ((i 0 (fx+ i 1)))
1837            ((fx>= i len) ht1)
1838          (do ((lst (##sys#slot vec i) (##sys#slot lst 1)))
1839              ((null? lst))
1840            (let ((b (##sys#slot lst 0)))
1841              (hash-table-set! ht1 (##sys#slot b 0) (##sys#slot b 1)) ) ) ) ) ) ) )
1842
1843
1844;;; Conversion to and from lists:
1845
1846(define (hash-table->alist ht)
1847  (##sys#check-structure ht 'hash-table 'hash-table->alist)
1848  (let* ([vec (##sys#slot ht 1)]
1849         [len (##sys#size vec)] )
1850    (let loop ([i 0] [lst '()])
1851      (if (fx>= i len)
1852          lst
1853          (let loop2 ([bucket (##sys#slot vec i)] [lst lst])
1854            (if (null? bucket)
1855                (loop (fx+ i 1) lst)
1856                (loop2 (##sys#slot bucket 1)
1857                       (let ([x (##sys#slot bucket 0)])
1858                         (cons (cons (##sys#slot x 0) (##sys#slot x 1)) lst) ) ) ) ) ) ) ) )
1859
1860(define alist->hash-table
1861  (let ((make-hash-table make-hash-table)
1862        (hash-table-set! hash-table-set!) )
1863    (lambda (alist . rest)
1864      (let ((hash (apply make-hash-table rest)))
1865        (for-each (lambda (x) (hash-table-set! hash (car x) (cdr x))) alist)
1866        hash))))
1867
1868(define (hash-table-keys ht)
1869  (##sys#check-structure ht 'hash-table 'hash-table-keys)
1870  (let* ([vec (##sys#slot ht 1)]
1871         [len (##sys#size vec)] )
1872    (let loop ([i 0] [lst '()])
1873      (if (fx>= i len)
1874          lst
1875          (let loop2 ([bucket (##sys#slot vec i)] [lst lst])
1876            (if (null? bucket)
1877                (loop (fx+ i 1) lst)
1878                (loop2 (##sys#slot bucket 1)
1879                       (let ([x (##sys#slot bucket 0)])
1880                         (cons (##sys#slot x 0) lst) ) ) ) ) ) ) ) )
1881
1882(define (hash-table-values ht)
1883  (##sys#check-structure ht 'hash-table 'hash-table-values)
1884  (let* ([vec (##sys#slot ht 1)]
1885         [len (##sys#size vec)] )
1886    (let loop ([i 0] [lst '()])
1887      (if (fx>= i len)
1888          lst
1889          (let loop2 ([bucket (##sys#slot vec i)] [lst lst])
1890            (if (null? bucket)
1891                (loop (fx+ i 1) lst)
1892                (loop2 (##sys#slot bucket 1)
1893                       (let ([x (##sys#slot bucket 0)])
1894                         (cons (##sys#slot x 1) lst) ) ) ) ) ) ) ) )
1895
1896(register-feature! 'srfi-69)
1897
1898
1899;;; Mapping over keys and elements:
1900
1901(define hash-table-walk
1902  (lambda (ht p)
1903    (##sys#check-structure ht 'hash-table 'hash-table-walk)
1904    (let* ((vec (##sys#slot ht 1))
1905           (len (##sys#size vec)))
1906      (do ((i 0 (fx+ i 1)))
1907          ((fx>= i len))
1908        (##sys#for-each (lambda (bucket) 
1909                      (p (##sys#slot bucket 0)
1910                         (##sys#slot bucket 1) ) )
1911                    (##sys#slot vec i) ) ) ) ) )
1912
1913(define hash-table-fold
1914  (lambda (ht p init)
1915    (##sys#check-structure ht 'hash-table 'hash-table-fold)
1916    (let* ((vec (##sys#slot ht 1))
1917           (len (##sys#size vec)))
1918      (let loop ((i 0) (acc init))
1919        (if (fx>= i len)
1920            acc
1921            (let fold2 ((buckets (##sys#slot vec i)) (acc acc))
1922              (if (null? buckets)
1923                  (loop (fx+ i 1) acc)
1924                  (let ((b (##sys#slot buckets 0)))
1925                    (fold2 (##sys#slot buckets 1)
1926                           (p (##sys#slot b 0)
1927                              (##sys#slot b 1) 
1928                              acc) ) ) ) ) ) ) ) ) )
1929
1930
1931; Support for queues
1932;
1933; Written by Andrew Wilcox (awilcox@astro.psu.edu) on April 1, 1992.
1934;
1935; This code is in the public domain.
1936;
1937; (heavily adapated for use with CHICKEN by felix)
1938;
1939
1940
1941; Elements in a queue are stored in a list.  The last pair in the list
1942; is stored in the queue type so that datums can be added in constant
1943; time.
1944
1945(define (make-queue) (##sys#make-structure 'queue '() '()))
1946(define (queue? x) (##sys#structure? x 'queue))
1947
1948(define (queue-empty? q)
1949  (##sys#check-structure q 'queue 'queue-empty?)
1950  (eq? '() (##sys#slot q 1)) )
1951
1952(define queue-first
1953  (lambda (q)
1954    (##sys#check-structure q 'queue 'queue-first)
1955    (let ((first-pair (##sys#slot q 1)))
1956      (cond-expand 
1957       [(not unsafe)
1958        (when (eq? '() first-pair)
1959          (##sys#error 'queue-first "queue is empty" q)) ]
1960       [else] )
1961      (##sys#slot first-pair 0) ) ) )
1962
1963(define queue-last
1964  (lambda (q)
1965    (##sys#check-structure q 'queue 'queue-last)
1966    (let ((last-pair (##sys#slot q 2)))
1967      (cond-expand
1968       [(not unsafe)
1969        (when (eq? '() last-pair)
1970          (##sys#error 'queue-last "queue is empty" q)) ]
1971       [else] )
1972      (##sys#slot last-pair 0) ) ) )
1973
1974(define (queue-add! q datum)
1975  (##sys#check-structure q 'queue 'queue-add!)
1976  (let ((new-pair (cons datum '())))
1977    (cond ((eq? '() (##sys#slot q 1)) (##sys#setslot q 1 new-pair))
1978          (else (##sys#setslot (##sys#slot q 2) 1 new-pair)) )
1979    (##sys#setslot q 2 new-pair) 
1980    (##core#undefined) ) )
1981
1982(define queue-remove!
1983  (lambda (q)
1984    (##sys#check-structure q 'queue 'queue-remove!)
1985    (let ((first-pair (##sys#slot q 1)))
1986      (cond-expand
1987       [(not unsafe)
1988        (when (eq? '() first-pair)
1989          (##sys#error 'queue-remove! "queue is empty" q) ) ]
1990       [else] )
1991      (let ((first-cdr (##sys#slot first-pair 1)))
1992        (##sys#setslot q 1 first-cdr)
1993        (if (eq? '() first-cdr)
1994            (##sys#setslot q 2 '()) )
1995        (##sys#slot first-pair 0) ) ) ) )
1996
1997(define (queue->list q)
1998  (##sys#check-structure q 'queue 'queue->list)
1999  (##sys#slot q 1) )
2000
2001(define (list->queue lst0)
2002  (##sys#check-list lst0 'list->queue)
2003  (##sys#make-structure 
2004   'queue lst0
2005   (if (eq? lst0 '())
2006       '()
2007       (do ((lst lst0 (##sys#slot lst 1)))
2008           ((eq? (##sys#slot lst 1) '()) lst)
2009         (if (or (not (##core#inline "C_blockp" lst))
2010                 (not (##core#inline "C_pairp" lst)) )
2011             (##sys#not-a-proper-list-error lst0 'list->queue) ) ) ) ) )
2012
2013
2014; (queue-push-back! queue item)
2015; Pushes an item into the first position of a queue.
2016
2017(define (queue-push-back! q item)
2018  (##sys#check-structure q 'queue 'queue-push-back!)
2019  (let ((newlist (cons item (##sys#slot q 1))))
2020    (##sys#setslot q 1 newlist)
2021    (if (eq? '() (##sys#slot q 2))
2022        (##sys#setslot q 2 newlist))))
2023
2024; (queue-push-back-list! queue item-list)
2025; Pushes the items in item-list back onto the queue,
2026; so that (car item-list) becomes the next removable item.
2027
2028(define-macro (last-pair lst0)
2029  `(do ((lst ,lst0 (##sys#slot lst 1)))
2030       ((eq? (##sys#slot lst 1) '()) lst)))
2031
2032(define (queue-push-back-list! q itemlist)
2033  (##sys#check-structure q 'queue 'queue-push-back-list!)
2034  (##sys#check-list itemlist 'queue-push-back-list!)
2035  (let* ((newlist (append itemlist (##sys#slot q 1)))
2036         (newtail (if (eq? newlist '())
2037                       '()
2038                       (last-pair newlist))))
2039    (##sys#setslot q 1 newlist)
2040    (##sys#setslot q 2 newtail)))
Note: See TracBrowser for help on using the repository browser.