source: project/chicken/trunk/extras.scm @ 8275

Last change on this file since 8275 was 8275, checked in by Kon Lovett, 12 years ago

Use of tabs+spaces.

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