source: project/chicken/branches/beyond-hope/extras.scm @ 10439

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

painfully slowly debugging compiler

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