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

Last change on this file since 8155 was 8155, checked in by felix winkelmann, 13 years ago

refactored [sf]printf, non-tty port is buffered first (ticket #418)

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