1;; for a bit of better performance
2(define (hashtable-for-each proc ht)
3  (unless (procedure? proc)
4    (assertion-violation 'hashtable-for-each
5			 (wrong-type-argument-message "procedure" proc 1)))
6  (unless (hashtable? ht)
7    (assertion-violation 'hashtable-for-each
8			 (wrong-type-argument-message "hashtable" ht 2)))
9  (let ((itr (%hashtable-iter ht))
10	(eof (cons #t #t)))
11    (let loop ()
12      (let-values (((k v) (itr eof)))
13	(unless (eq? k eof)
14	  (proc k v) (loop))))))
15
16(define (hashtable-map proc ht)
17  (unless (procedure? proc)
18    (assertion-violation 'hashtable-map
19			 (wrong-type-argument-message "procedure" proc 1)))
20  (unless (hashtable? ht)
21    (assertion-violation 'hashtable-map
22			 (wrong-type-argument-message "hashtable" ht 2)))
23  (let ((itr (%hashtable-iter ht))
24	(eof (cons #t #t)))
25    (let loop ((r '()))
26      (let-values (((k v) (itr eof)))
27	(if (eq? k eof)
28	    r
29	    (loop (cons (proc k v) r)))))))
30
31(define (hashtable-fold kons ht knil)
32  (unless (procedure? kons)
33    (assertion-violation 'hashtable-fold
34			 (wrong-type-argument-message "procedure" proc 1)))
35  (unless (hashtable? ht)
36    (assertion-violation 'hashtable-fold
37			 (wrong-type-argument-message "hashtable" ht 2)))
38  (let ((itr (%hashtable-iter ht))
39	(eof (cons #t #t)))
40    (let loop ((r knil))
41      (let-values (((k v) (itr eof)))
42	(if (eq? k eof)
43	    r
44	    (loop (kons k v r)))))))
45
46(define (hashtable->alist ht)
47  (hashtable-map cons ht))
48
49(define (unique-id-list? lst)
50  (and (list? lst)
51       (not (let loop ((lst lst))
52              (and (pair? lst)
53                   (or (not (variable? (car lst)))
54                       (id-memq (car lst) (cdr lst))
55                       (loop (cdr lst))))))))
56
57#;(define (any pred ls)
58  (if (pair? ls) (if (pred (car ls)) (car ls) (any pred (cdr ls))) #f))
59
60(define (call-with-values producer consumer)
61  (receive vals (producer) (apply consumer vals)))
62
63;; print
64(define (print . args)
65  (for-each display args)
66  (newline))
67
68(define (fold proc seed lst1 . lst2)
69  (if (null? lst2)
70      (let loop ((lis lst1) (knil seed))
71	(if (null? lis)
72	    knil
73	    (loop (cdr lis) (proc (car lis) knil))))
74      (let loop ((lis (apply list-transpose* lst1 lst2)) (knil seed))
75	(if (null? lis)
76	    knil
77	    (loop (cdr lis) (apply proc (append (car lis) (list knil))))))))
78
79;; from Ypsilon
80(define (wrong-type-argument-message expect got . nth)
81  (if (null? nth)
82      (format "expected ~a, but got ~a" expect got)
83      (format "expected ~a, but got ~a, as argument ~a" expect got (car nth))))
84
85;; From Gauche
86;; we don't define SRFI-43 vector-map/vector-for-each here
87;; so make those tabulate/update! internal define for better performance.
88(define (vector-map proc vec . more)
89  (define (vector-tabulate len proc)
90    (let loop ((i 0) (r '()))
91      (if (= i len)
92	  (list->vector (reverse! r))
93	  (loop (+ i 1) (cons (proc i) r)))))
94  (if (null? more)
95      (vector-tabulate (vector-length vec)
96		       (lambda (i) (proc (vector-ref vec i))))
97      (let ((vecs (cons vec more)))
98	(vector-tabulate (apply min (map vector-length vecs))
99			 (lambda (i)
100			   (apply proc (map (lambda (v) (vector-ref v i))
101					    vecs)))))))
102(define (vector-map! proc vec . more)
103  (define (vector-update! vec len proc)
104    (let loop ((i 0))
105      (if (= i len)
106	  vec
107	  (begin
108	    (vector-set! vec i (proc i))
109	    (loop (+ i 1))))))
110  (if (null? more)
111      (vector-update! vec (vector-length vec)
112		      (lambda (i) (proc (vector-ref vec i))))
113      (let ((vecs (cons vec more)))
114	(vector-update! vec (apply min (map vector-length vecs))
115			(lambda (i)
116			  (apply proc (map (lambda (v) (vector-ref v i))
117					   vecs)))))))
118
119(define (vector-for-each proc vec . more)
120  (if (null? more)
121      (let ((len (vector-length vec)))
122	(let loop ((i 0))
123	  (unless (= i len)
124	    (proc (vector-ref vec i))
125	    (loop (+ i 1)))))
126      (let* ((vecs (cons vec more))
127	     (len  (apply min (map vector-length vecs))))
128	(let loop ((i 0))
129	  (unless (= i len)
130	    (apply proc (map (lambda (v) (vector-ref v i)) vecs))
131	    (loop (+ i 1)))))))
132
133;; same as vector-for-each
134(define (string-for-each proc str . more)
135  (if (null? more)
136      (let ((len (string-length str)))
137	(let loop ((i 0))
138	  (unless (= i len)
139	    (proc (string-ref str i))
140	    (loop (+ i 1)))))
141      (let* ((strs (cons str more))
142	     (len  (apply min (map string-length strs))))
143	(let loop ((i 0))
144	  (unless (= i len)
145	    (apply proc (map (lambda (s) (string-ref s i)) strs))
146	    (loop (+ i 1)))))))
147
148;;;;
149;; from SRFI-13
150
151;;; (string-join string-list [delimiter grammar]) => string
152;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
153;;; Paste strings together using the delimiter string.
154;;;
155;;; (join-strings '("foo" "bar" "baz") ":") => "foo:bar:baz"
156;;;
157;;; DELIMITER defaults to a single space " "
158;;; GRAMMAR is one of the symbols {prefix, infix, strict-infix, suffix}
159;;; and defaults to 'infix.
160;;;
161;;; I could rewrite this more efficiently -- precompute the length of the
162;;; answer string, then allocate & fill it in iteratively. Using
163;;; STRING-CONCATENATE is less efficient.
164
165(define (string-join strings :optional (delim " ") (grammar 'infix))
166  (define (buildit lis final)
167    (let recur ((lis lis))
168      (if (pair? lis)
169	  (cons delim (cons (car lis) (recur (cdr lis))))
170	  final)))
171  (unless (string? delim)
172    (error 'string-join "Delimiter must be a string" delim))
173  (cond ((pair? strings)
174	 (string-concatenate
175	  (case grammar
176	    ((infix strict-infix)
177	     (cons (car strings) (buildit (cdr strings) '())))
178	    ((prefix) (buildit strings '()))
179	    ((suffix)
180	     (cons (car strings) (buildit (cdr strings) (list delim))))
181	    (else (error 'string-join "Illegal join grammar"
182			 grammar string-join)))))
183	((not (null? strings))
184	 (error 'string-join "STRINGS parameter not list."
185		strings string-join))
186	((eq? grammar 'strict-infix)
187	 (error 'string-join
188		"Empty list cannot be joined with STRICT-INFIX grammar."
189		string-join))
190	(else "")))		; Special-cased for infix grammar.
191
192;;;;
193;; from Ypsilon
194
195;; from srfi-1 start
196(define (null-list? l)
197  (cond ((pair? l) #f)
198	((null? l) #t)
199	(else (assertion-violation 'null-list? "argument out of domain" l))))
200
201(define (split-at x k)
202  (or (integer? k)
203      (assertion-violation 'split-at
204                           (wrong-type-argument-message "integer" k 2)))
205  (let recur ((lis x) (k k) (r '()))
206    (cond ((zero? k) (values (reverse! r) lis))
207	  ((null? lis) (error 'split-at "given list it too short"))
208	  (else (recur (cdr lis) (- k 1) (cons (car lis) r))))))
209
210(define (find pred list)
211  (cond ((find-tail pred list) => car)
212	(else #f)))
213
214(define (find-tail pred list)
215  (or (procedure? pred)
216      (assertion-violation 'find-tail
217			   (wrong-type-argument-message "procedure" pred 2)))
218  (let lp ((list list))
219    (and (not (null? list))
220     (if (pred (car list)) list
221         (lp (cdr list))))))
222
223(define (assoc x lis . =)
224  (or (list? lis)
225      (assertion-violation 'assoc
226			   (wrong-type-argument-message "list" lis 2)))
227  (if (null? =)
228      (assoc x lis equal?)
229      (find (lambda (entry) ((car =) x (car entry))) lis)))
230
231(define (member x lis . =)
232  (if (null? =)
233      (member x lis equal?)
234      (find-tail (lambda (y) ((car =) x y)) lis)))
235
236(define (delete x lis . =)
237  (if (null? =)
238      (delete x lis equal?)
239      (filter (lambda (y) (not ((car =) x y))) lis)))
240
241(define (delete! x lis . =)
242  (if (null? =)
243      (delete x lis equal?)
244      (filter! (lambda (y) (not ((car =) x y))) lis)))
245
246(define (reduce f ridentity lis)
247  (or (procedure? f)
248      (assertion-violation 'reduce (wrong-type-argument-message "procedure" = 1)))
249  (if (null? lis) ridentity
250      (fold f (car lis) (cdr lis))))
251
252(define (lset-union = . lists)
253  (or (procedure? =)
254      (assertion-violation 'lset-union
255			   (wrong-type-argument-message "procedure" = 1)))
256  (reduce (lambda (lis ans)     ; Compute ANS + LIS.
257	    (cond ((null? lis) ans) ; Don't copy any lists
258		  ((null? ans) lis)     ; if we don't have to.
259		  ((eq? lis ans) ans)
260		  (else
261		   (fold (lambda (elt ans)
262			   (if (exists (lambda (x) (= x elt)) ans)
263			       ans
264			       (cons elt ans)))
265			 ans lis))))
266	  '() lists))
267
268(define (lset-intersection = lis1 . lists)
269  (or (procedure? =)
270      (assertion-violation 'lset-intersection
271			   (wrong-type-argument-message "procedure" = 1)))
272  (let ((lists (delete lis1 lists eq?))) ; Throw out any LIS1 vals.
273    (cond ((exists null? lists) '())      ; Short cut
274      ((null? lists)          lis1)     ; Short cut
275      (else (filter (lambda (x)
276              (for-all (lambda (lis) (member x lis =)) lists))
277            lis1)))))
278
279(define (lset-difference = lis1 . lists)
280  (or (procedure? =)
281      (assertion-violation 'lset-difference
282			   (wrong-type-argument-message "procedure" = 1)))
283  (let ((lists (filter pair? lists)))   ; Throw out empty lists.
284    (cond ((null? lists)     lis1)  ; Short cut
285      ((memq lis1 lists) '())   ; Short cut
286      (else (filter (lambda (x)
287              (for-all (lambda (lis) (not (member x lis =)))
288                 lists))
289            lis1)))))
290
291(define (take lis k)
292  (or (integer? k)
293      (assertion-violation 'take
294			   (wrong-type-argument-message "integer" k 2)))
295  (let recur ((lis lis) (k k))
296    (if (zero? k) '()
297    (cons (car lis)
298          (recur (cdr lis) (- k 1))))))
299
300(define (drop lis k)
301  (or (integer? k)
302      (assertion-violation 'drop
303			   (wrong-type-argument-message "integer" k 2)))
304  (let iter ((lis lis) (k k))
305    (if (zero? k) lis (iter (cdr lis) (- k 1)))))
306
307
308(define list-head take)
309
310;;;;
311;; standard libraries
312
313;; 1 Unicode
314;; 1.1 characters
315(define (make-ci-comparison = foldcase)
316  (lambda (e1 e2 . rest)
317    (let loop ((e1 (foldcase e1)) (e2 (foldcase e2)) (e* rest))
318      (and (= e1 e2)
319	   (or (null? e*)
320	       (loop e2 (foldcase (car e*)) (cdr e*)))))))
321
322(define char-ci=? (make-ci-comparison char=? char-foldcase))
323(define char-ci<? (make-ci-comparison char<? char-foldcase))
324(define char-ci>? (make-ci-comparison char>? char-foldcase))
325(define char-ci<=? (make-ci-comparison char<=? char-foldcase))
326(define char-ci>=? (make-ci-comparison char>=? char-foldcase))
327
328;; 1.2 strings
329(define string-ci=? (make-ci-comparison string=? string-foldcase))
330(define string-ci<? (make-ci-comparison string<? string-foldcase))
331(define string-ci>? (make-ci-comparison string>? string-foldcase))
332(define string-ci<=? (make-ci-comparison string<=? string-foldcase))
333(define string-ci>=? (make-ci-comparison string>=? string-foldcase))
334
335;; 2 Bytevectors
336;; 2.4 operations on integers of arbitary size
337;; from Ypsilon
338;; we can't use macro in this file so expand by hand!!
339;;(define-syntax div256
340;;  (syntax-rules ()
341;;    ((_ x) (bitwise-arithmetic-shift x -8))))
342;;
343;;(define-syntax mod256
344;;  (syntax-rules ()
345;;    ((_ x) (bitwise-and x 255))))
346;;
347;; This moved to (rnrs bytevectors)
348;;(define-syntax endianness
349;;  (syntax-rules (big little native)
350;;    ((_ big) 'big)
351;;    ((_ little) 'little)
352;;    ((_ native) (native-endianness))))
353
354(define (bytevector-uint-ref bv index endien size)
355  (cond ((eq? endien 'big)
356         (let ((end (+ index size)))
357           (let loop ((i index) (acc 0))
358             (if (>= i end)
359                 acc
360                 (loop (+ i 1) (+ (* 256 acc) (bytevector-u8-ref bv i)))))))
361        ((eq? endien 'little)
362         (let loop ((i (+ index size -1)) (acc 0))
363           (if (< i index)
364               acc
365               (loop (- i 1) (+ (* 256 acc) (bytevector-u8-ref bv i))))))
366        (else
367         (assertion-violation 'bytevector-uint-ref
368                              (format "expected endianness, but got ~s, as argument 3" endien)
369                              (list bv index endien size)))))
370
371(define (bytevector-sint-ref bv index endien size)
372  (cond ((eq? endien 'big)
373         (if (> (bytevector-u8-ref bv index) 127)
374             (- (bytevector-uint-ref bv index endien size) (expt 256 size))
375             (bytevector-uint-ref bv index endien size)))
376        ((eq? endien 'little)
377         (if (> (bytevector-u8-ref bv (+ index size -1)) 127)
378             (- (bytevector-uint-ref bv index endien size) (expt 256 size))
379             (bytevector-uint-ref bv index endien size)))
380        (else
381         (assertion-violation 'bytevector-uint-ref
382                              (format "expected endianness, but got ~s, as argument 3" endien)
383                              (list bv index endien size)))))
384
385(define (bytevector-uint-set! bv index val endien size)
386  (cond ((= val 0)
387         (let ((end (+ index size)))
388           (let loop ((i index))
389             (cond ((>= i end) (undefined))
390                   (else
391                    (bytevector-u8-set! bv i 0)
392                    (loop (+ i 1)))))))
393        ((< 0 val (expt 256 size))
394         (cond ((eq? endien 'big)
395                (let ((start (- (+ index size) 1)))
396                  (let loop ((i start) (acc val))
397                    (cond ((< i index) (undefined))
398                          (else
399                           ;; mod256 -> bitwise-and
400                           (bytevector-u8-set! bv i (bitwise-and acc 255))
401                           ;; div256 -> bitwise-arithmetic-shift
402                           (loop (- i 1) (bitwise-arithmetic-shift acc -8)))))))
403               ((eq? endien 'little)
404                (let ((end (+ index size)))
405                  (let loop ((i index) (acc val))
406                    (cond ((>= i end) (undefined))
407                          (else
408                           ;; mod256 -> bitwise-and
409                           (bytevector-u8-set! bv i (bitwise-and acc 255))
410                           ;; div256 -> bitwise-arithmetic-shift
411                           (loop (+ i 1) (bitwise-arithmetic-shift acc -8)))))))))
412        (else
413         (assertion-violation 'bytevector-uint-set!
414                              (format "value out of range, ~s as argument 3" val)
415                              (list bv index val endien size))))
416  (undefined))
417
418(define (bytevector-sint-set! bv index val endien size)
419  (let* ((p-bound (expt 2 (- (* size 8) 1)))
420         (n-bound (- (+ p-bound 1))))
421    (if (< n-bound val p-bound)
422        (if (>= val 0)
423            (bytevector-uint-set! bv index val endien size)
424            (bytevector-uint-set! bv index (+ val (expt 256 size)) endien size))
425        (assertion-violation 'bytevector-sint-set!
426                             (format "value out of range, ~s as argument 3" val)
427                             (list bv index val endien size))))
428  (undefined))
429
430(define (bytevector->uint-list bv endien size)
431  (let loop ((i (- (bytevector-length bv) size)) (acc '()))
432    (if (> i -1)
433        (loop (- i size) (cons (bytevector-uint-ref bv i endien size) acc))
434        (if (= i (- size))
435            acc
436            (assertion-violation 'bytevector->uint-list
437                                 (format "expected appropriate element size as argument 3, but got ~s" size)
438                                 (list bv endien size))))))
439
440(define (bytevector->sint-list bv endien size)
441  (let loop ((i (- (bytevector-length bv) size)) (acc '()))
442    (if (> i -1)
443        (loop (- i size) (cons (bytevector-sint-ref bv i endien size) acc))
444        (if (= i (- size))
445            acc
446            (assertion-violation 'bytevector->sint-list
447                                 (format "expected appropriate element size as argument 3, but got ~s" size)
448                                 (list bv endien size))))))
449
450(define (uint-list->bytevector lst endien size)
451  (let ((bv (make-bytevector (* size (length lst)))))
452    (let loop ((i 0) (lst lst))
453      (cond ((null? lst) bv)
454            (else
455             (bytevector-uint-set! bv i (car lst) endien size)
456             (loop (+ i size) (cdr lst)))))))
457
458(define (sint-list->bytevector lst endien size)
459  (let ((bv (make-bytevector (* size (length lst)))))
460    (let loop ((i 0) (lst lst))
461      (cond ((null? lst) bv)
462            (else
463             (bytevector-sint-set! bv i (car lst) endien size)
464             (loop (+ i size) (cdr lst)))))))
465
466;; 3 list utilities
467
468(define (for-all pred lst1 . lst2)
469  (define (for-all-n pred list-of-lists)
470    (let ((argc (length list-of-lists)))
471      (define (collect-cdr lst)
472        (let loop ((lst lst))
473          (cond ((null? lst) '())
474                ((null? (cdar lst)) (loop (cdr lst)))
475                (else (cons (cdar lst) (loop (cdr lst)))))))
476      (define (collect-car lst)
477        (let loop ((lst lst))
478          (cond ((null? lst) '())
479                ((pair? (car lst))
480                 (cons (caar lst) (loop (cdr lst))))
481                (else
482                 (assertion-violation 'for-all (format "traversal reached to non-pair element ~s" (car lst)) list-of-lists)))))
483
484      (let loop ((head (collect-car list-of-lists)) (rest (collect-cdr list-of-lists)))
485        (or (= (length head) argc)
486            (assertion-violation 'for-all "expected same length chains of pairs" list-of-lists))
487        (if (null? rest)
488            (apply pred head)
489            (and (apply pred head)
490                 (loop (collect-car rest) (collect-cdr rest)))))))
491
492  (define (for-all-n-quick pred lst)
493    (or (null? lst)
494        (let loop ((head (car lst)) (rest (cdr lst)))
495          (if (null? rest)
496              (apply pred head)
497              (and (apply pred head)
498                   (loop (car rest) (cdr rest)))))))
499
500  (define (for-all-1 pred lst)
501    (cond ((null? lst) #t)
502          ((pair? lst)
503           (let loop ((head (car lst)) (rest (cdr lst)))
504             (cond ((null? rest) (pred head))
505                   ((pair? rest)
506                    (and (pred head)
507                         (loop (car rest) (cdr rest))))
508                   (else
509                    (and (pred head)
510                         (assertion-violation 'for-all (format "traversal reached to non-pair element ~s" rest) (list pred lst)))))))
511          (else
512           (assertion-violation 'for-all (format "expected chain of pairs, but got ~a, as argument 2" lst) (list pred lst)))))
513
514  (cond ((null? lst2)
515         (for-all-1 pred lst1))
516        ((apply list-transpose+ lst1 lst2)
517         => (lambda (lst) (for-all-n-quick pred lst)))
518        (else
519         (for-all-n pred (cons lst1 lst2)))))
520
521(define (exists pred lst1 . lst2)
522  (define (exists-1 pred lst)
523    (cond ((null? lst) #f)
524          ((pair? lst)
525           (let loop ((head (car lst)) (rest (cdr lst)))
526             (cond ((null? rest) (pred head))
527                   ((pred head))
528                   ((pair? rest) (loop (car rest) (cdr rest)))
529                   (else
530                    (assertion-violation 'exists (format "traversal reached to non-pair element ~s" rest) (list pred lst))))))
531          (else
532           (assertion-violation 'exists (format "expected chain of pairs, but got ~a, as argument 2" lst) (list pred lst)))))
533  (define (exists-n-quick pred lst)
534    (and (pair? lst)
535         (let loop ((head (car lst)) (rest (cdr lst)))
536           (if (null? rest)
537               (apply pred head)
538               (or (apply pred head)
539                   (loop (car rest) (cdr rest)))))))
540  (define (exists-n pred list-of-lists)
541    (let ((argc (length list-of-lists)))
542      (define (collect-cdr lst)
543        (let loop ((lst lst))
544          (cond ((null? lst) '())
545                ((null? (cdar lst)) (loop (cdr lst)))
546                (else (cons (cdar lst) (loop (cdr lst)))))))
547      (define (collect-car lst)
548        (let loop ((lst lst))
549          (cond ((null? lst) '())
550                ((pair? (car lst))
551                 (cons (caar lst) (loop (cdr lst))))
552                (else
553                 (assertion-violation 'exists (format "traversal reached to non-pair element ~s" (car lst)) list-of-lists)))))
554
555      (let loop ((head (collect-car list-of-lists)) (rest (collect-cdr list-of-lists)))
556        (or (= (length head) argc)
557            (assertion-violation 'exists "expected same length chains of pairs" list-of-lists))
558        (if (null? rest)
559            (apply pred head)
560            (or (apply pred head)
561                (loop (collect-car rest) (collect-cdr rest)))))))
562  (cond ((null? lst2)
563         (exists-1 pred lst1))
564        ((apply list-transpose+ lst1 lst2)
565         => (lambda (lst) (exists-n-quick pred lst)))
566        (else
567         (exists-n pred (cons lst1 lst2)))))
568
569(define (filter pred lst)
570  (let loop ((lst lst) (acc '()))
571    (cond ((null? lst) (reverse! acc))
572	  ((pred (car lst)) (loop (cdr lst) (cons (car lst) acc)))
573	  (else (loop (cdr lst) acc)))))
574
575;; from SRFI-1, reference implementation
576(define (filter! pred lis)
577  (let lp ((ans lis))
578    (cond ((null? ans)            ans)		  ; Scan looking for
579	  ((not (pred (car ans))) (lp (cdr ans))) ; first cons of result.
580
581	  ;; ANS is the eventual answer.
582	  ;; SCAN-IN: (CDR PREV) = LIS and (CAR PREV) satisfies PRED.
583	  ;;          Scan over a contiguous segment of the list that
584	  ;;          satisfies PRED.
585	  ;; SCAN-OUT: (CAR PREV) satisfies PRED. Scan over a contiguous
586	  ;;           segment of the list that *doesn't* satisfy PRED.
587	  ;;           When the segment ends, patch in a link from PREV
588	  ;;           to the start of the next good segment, and jump to
589	  ;;           SCAN-IN.
590	  (else (letrec ((scan-in (lambda (prev lis)
591				    (if (pair? lis)
592					(if (pred (car lis))
593					    (scan-in lis (cdr lis))
594					    (scan-out prev (cdr lis))))))
595			 (scan-out (lambda (prev lis)
596				     (let lp ((lis lis))
597				       (if (pair? lis)
598					   (if (pred (car lis))
599					       (begin (set-cdr! prev lis)
600						      (scan-in lis (cdr lis)))
601					       (lp (cdr lis)))
602					   (set-cdr! prev lis))))))
603		  (scan-in ans (cdr ans))
604		  ans)))))
605
606(define (partition pred lst)
607  (let loop ((lst lst) (acc1 '()) (acc2 '()))
608    (cond ((null? lst) (values (reverse! acc1) (reverse! acc2)))
609          ((pred (car lst)) (loop (cdr lst) (cons (car lst) acc1) acc2))
610          (else (loop (cdr lst) acc1 (cons (car lst) acc2))))))
611
612(define (map proc lst1 . lst2)
613  (if (null? lst2)
614      (let loop ((xs lst1) (r '()))
615	(cond ((pair? xs) (loop (cdr xs) (cons (proc (car xs)) r)))
616	      ((null? xs) (reverse! r))
617	      (else
618	       (assertion-violation 'map
619		(wrong-type-argument-message "proper list" lst1 2)
620		(list proc lst1 lst2)))))
621      (let loop ((xs (apply list-transpose* lst1 lst2)) (r '()))
622	(cond ((pair? xs) (loop (cdr xs) (cons (apply proc (car xs)) r)))
623	      ((null? xs) (reverse! r))
624	      (else
625	       (assertion-violation 'map
626		(wrong-type-argument-message "proper list" lst1 2)
627		(list proc lst1 lst2)))))))
628
629(define (for-each proc lst1 . lst2)
630  (if (null? lst2)
631      (let loop ((xs lst1))
632	(cond ((pair? xs) (proc (car xs)) (loop (cdr xs)))
633	      ((null? xs) (undefined))
634	      (else
635	       (assertion-violation 'for-each
636		(wrong-type-argument-message "proper list" lst1 2)
637		(list proc lst1 lst2)))))
638      (let loop ((xs (apply list-transpose* lst1 lst2)))
639	(cond ((pair? xs) (apply proc (car xs)) (loop (cdr xs)))
640	      ((null? xs) (undefined))
641	      (else
642	       (assertion-violation 'for-each
643		(wrong-type-argument-message "proper list" lst1 2)
644		(list proc lst1 lst2)))))))
645
646;; it's used very often in the boot code so put it here
647(define (filter-map proc lst1 . lst2)
648  (unless (procedure? proc)
649    (assertion-violation 'filter-map
650     (wrong-type-argument-message "procedure" proc 1) (list proc lst1 lst2)))
651  (if (null? lst2)
652      (let loop ((lst lst1) (r '()))
653	(cond ((null? lst) (reverse! r))
654	      ((pair? lst)
655	       (cond ((proc (car lst)) =>
656		      (lambda (x) (loop (cdr lst) (cons x r))))
657		     (else (loop (cdr lst) r))))
658	      (else
659	       (assertion-violation 'filter-map
660		(wrong-type-argument-message "proper list" lst1 2)
661		(list proc lst1 lst2)))))
662      (let loop ((xs (apply list-transpose* lst1 lst2)) (r '()))
663	(cond ((null? xs) (reverse! r))
664	      ((pair? xs)
665	       (cond ((apply proc (car xs)) =>
666		      (lambda (x) (loop (cdr xs) (cons x r))))
667		     (else (loop (cdr xs) r))))
668	      (else
669	       (assertion-violation 'map
670		(wrong-type-argument-message "proper list" lst1 2)
671		(list proc lst1 lst2)))))))
672
673
674(define (fold-left proc seed lst1 . lst2)
675  (if (null? lst2)
676      (let loop ((lis lst1) (knil seed))
677	(if (null? lis) knil (loop (cdr lis) (proc knil (car lis)))))
678      (let loop ((lis (apply list-transpose* lst1 lst2)) (knil seed))
679	(if (null? lis)
680	    knil
681	    (loop (cdr lis) (apply proc knil (car lis)))))))
682
683;; tail recursive version
684(define (fold-right proc seed lst1 . lst2)
685  (if (null? lst2)
686      (let loop ((lis (reverse lst1))
687		 (result seed))
688	(if (null? lis)
689	    result
690	    (loop (cdr lis)
691		  (proc (car lis) result))))
692      (let loop ((lis (reverse! (apply list-transpose* lst1 lst2))) (knil seed))
693	(if (null? lis)
694	    knil
695	    (loop (cdr lis)
696		  (apply proc (append! (car lis) (list knil))))))))
697
698;;(define (fold-right proc seed lst1 . lst2)
699;;  (if (null? lst2)
700;;      (let loop ((lis lst1))
701;;	(if (null-list? lis)
702;;	    seed
703;;	    (proc (car lis) (loop (cdr lis)))))
704;;      (let loop ((lis (apply list-transpose* lst1 lst2)) (knil seed))
705;;	(if (null-list? lis)
706;;	    knil
707;;	    (apply proc (append! (car lis) (list (loop (cdr lis) knil))))))))
708
709(define (remp pred lst)
710  (let loop ((lst lst) (r '()))
711    (cond ((null? lst) (reverse! r))
712          ((pred (car lst)) (loop (cdr lst) r))
713          (else (loop (cdr lst) (cons (car lst) r))))))
714
715(define (remove obj lst)
716  (let loop ((lst lst) (r '()))
717    (cond ((null? lst) (reverse! r))
718          ((equal? (car lst) obj) (loop (cdr lst) r))
719          (else (loop (cdr lst) (cons (car lst) r))))))
720
721(define (remv obj lst)
722  (let loop ((lst lst) (r '()))
723    (cond ((null? lst) (reverse! r))
724          ((eqv? (car lst) obj) (loop (cdr lst) r))
725          (else (loop (cdr lst) (cons (car lst) r))))))
726
727(define (remq obj lst)
728  (let loop ((lst lst) (r '()))
729    (cond ((null? lst) (reverse! r))
730          ((eq? (car lst) obj) (loop (cdr lst) r))
731          (else (loop (cdr lst) (cons (car lst) r))))))
732
733(define (memp proc lst)
734  (cond ((null? lst) #f)
735	((proc (car lst)) lst)
736	(else (memp proc (cdr lst)))))
737
738(define (assp proc lst)
739  (cond ((null? lst) #f)
740	((proc (caar lst)) (car lst))
741	(else (assp proc (cdr lst)))))
742
743;;;;
744;; 4 Sorting
745;; The algorithm is from SBCL
746(define (list-sort proc lst)
747  (define (merge-list! proc head lst1 lst2 tail)
748    (let loop ()
749      (cond ((proc (car lst2) (car lst1))
750	     ;; we can't use macro so duplicate it!
751	     (set-cdr! tail lst2)
752	     (set! tail lst2)
753	     (let ((rest (cdr lst2)))
754	       (cond ((null? rest)
755		      (set-cdr! lst2 lst1)
756		      (cdr head))
757		     (else
758		      (set! lst2 rest)
759		      (loop)))))
760	    (else
761	     (set-cdr! tail lst1)
762	     (set! tail lst1)
763	     (let ((rest (cdr lst1)))
764	       (cond ((null? rest)
765		      (set-cdr! lst1 lst2)
766		      (cdr head))
767		     (else
768		      (set! lst1 rest)
769		      (loop))))))))
770  (define (fast-merge-list! proc try? head lst1 tail1 lst2 tail2 rest)
771    (if try?
772	(cond ((not (proc (car lst2) (car tail1)))
773	       (set-cdr! tail1 lst2)
774	       (values lst1 tail2 rest))
775	      ((proc (car tail2) (car lst1))
776	       (set-cdr! tail2 lst1)
777	       (values lst2 tail1 rest))
778	      (else
779	       (values (merge-list! proc head lst1 lst2 head)
780		       (if (null? (cdr tail1))
781			   tail1
782			   tail2)
783		       rest)))
784	(values (merge-list! proc head lst1 lst2 head)
785		(if (null? (cdr tail1))
786		    tail1
787		    tail2)
788		rest)))
789  (define (do-sort lst size head)
790    (define (recur lst size)
791      (cond ((= size 1)
792	     (let ((h (list (car lst))))
793	       (values h h (cdr lst))))
794	    ((= size 2)
795	     (let* ((a (car lst))
796		    (ad (cadr lst))
797		    (h (if (proc ad a)
798			   (list ad a)
799			   (list a ad))))
800	       (values h (cdr h) (cddr lst))))
801	    (else
802	     (let ((half (div size 2)))
803	       (receive (lst1 tail1 rest) (recur lst half)
804		 (receive (lst2 tail2 rest) (recur rest (- size half))
805		   (fast-merge-list! proc (>= size 8) head
806				     lst1 tail1
807				     lst2 tail2
808				     rest)))))))
809    (receive (lst tail size) (recur lst size)
810      lst))
811  (define (divide lst)
812    (let loop ((acc 1) (lst lst))
813      (cond ((null? (cdr lst)) (values acc '()))
814            (else
815	     (if (proc (car lst) (cadr lst))
816		 (loop (+ acc 1) (cdr lst))
817		 (values acc (cdr lst)))))))
818  (unless (procedure? proc)
819    (assertion-violation 'list-sort
820     (wrong-type-argument-message "procedure" proc 1)))
821  (if (null? lst)
822      lst
823      (receive (n lst2) (divide lst)
824	(if (null? lst2)
825	    lst
826	    (let* ((head (cons '() '()))
827		   (r (do-sort lst2 (length lst2) head)))
828	      (merge-list! proc head (list-head lst n) r head))))))
829
830(define (vector-sort proc vect :optional (start 0) (maybe-end #f))
831  (define len (vector-length vect))
832  (define end (or maybe-end len))
833  ;; TODO should we expose this?
834  (define (vector-copy! src src-from dst dst-from size)
835    (if (<= dst-from src-from)
836	(do ((i 0 (+ i 1)) (s src-from (+ s 1)) (d dst-from (+ d 1)))
837	    ((= i size) dst)
838	  (vector-set! dst d (vector-ref src s)))
839	(do ((i 0 (+ i 1))
840	     (s (+ src-from size) (- s 1))
841	     (d (+ dst-from size) (- d 1)))
842	    ((= i size) dst)
843	  (vector-set! dst d (vector-ref src s)))))
844
845  (when (or (negative? start) (negative? end))
846    (assertion-violation 'vector-sort! "start and end must be positive" start
847			 vect))
848  (when (or (> start len) (> end len))
849    (assertion-violation 'vector-sort! "out of range"
850			 (list (list start end) len)
851			 vect))
852  (when (> start end)
853    (assertion-violation 'vector-sort! "start is greater than end"
854			 (list start end)
855			 vect))
856
857  (let* ((lst (vector->list vect start end))
858	 (lst2 (list-sort proc lst)))
859    (cond ((eq? lst lst2) vect)
860	  ((= (- end start) len)
861	   (list->vector lst2))
862	  (else
863	   (let ((v (make-vector len)))
864	     (vector-copy! vect 0 v 0 start)
865	     (do ((i start (+ i 1)) (l lst2 (cdr l)))
866		 ((null? l))
867	       (vector-set! v i (car l)))
868	     (vector-copy! vect end v end (- len end)))))))
869
870(define (vector-sort! proc vect :optional (start 0) (maybe-end #f))
871  (define len (vector-length vect))
872  (define end (or maybe-end len))
873
874  (when (or (negative? start) (negative? end))
875    (assertion-violation 'vector-sort! "start and end must be positive" start
876			 vect))
877  (when (or (> start len) (> end len))
878    (assertion-violation 'vector-sort! "out of range"
879			 (list (list start end) len)
880			 vect))
881  (when (> start end)
882    (assertion-violation 'vector-sort! "start is greater than end"
883			 (list start end)
884			 vect))
885
886  (let* ((n (- end start))
887	 (work (make-vector (+ (div n 2) 1))))
888
889    (define (simple-sort! first last)
890      (let loop1 ((i first))
891        (cond ((< i last)
892               (let ((m (vector-ref vect i)) (k i))
893                 (let loop2 ((j (+ i 1)))
894                   (cond ((<= j last)
895                          (if (proc (vector-ref vect j) m)
896                              (begin
897                                (set! m (vector-ref vect j))
898                                (set! k j)))
899                          (loop2 (+ j 1)))
900                         (else
901                          (vector-set! vect k (vector-ref vect i))
902                          (vector-set! vect i m)
903                          (loop1 (+ i 1))))))))))
904
905    (define (sort! first last)
906      (cond ((> (- last first) 10)
907             (let ((middle (div (+ first last) 2)))
908               (sort! first middle)
909               (sort! (+ middle 1) last)
910               (let loop ((i first) (p2size 0))
911                 (cond ((> i middle)
912                        (let loop ((p1 (+ middle 1)) (p2 0) (p3 first))
913                          (cond ((and (<= p1 last) (< p2 p2size))
914                                 (cond ((proc (vector-ref work p2) (vector-ref vect p1))
915                                        (vector-set! vect p3 (vector-ref work p2))
916                                        (loop p1 (+ p2 1) (+ p3 1)))
917                                       (else
918                                        (vector-set! vect p3 (vector-ref vect p1))
919                                        (loop (+ p1 1) p2 (+ p3 1)))))
920                                (else
921                                 (let loop ((s2 p2)(d3 p3))
922                                   (cond ((< s2 p2size)
923                                          (vector-set! vect d3 (vector-ref work s2))
924                                          (loop (+ s2 1) (+ d3 1)))))))))
925                       (else
926                        (vector-set! work p2size (vector-ref vect i))
927                        (loop (+ i 1) (+ p2size 1)))))))
928            (else
929             (simple-sort! first last))))
930    ;; the end is exclusive
931    (sort! start (- end 1))))
932
933;;;;
934;; 8 I/O
935;; 8.2.6 input port and output port
936;; from Ypsilon
937(define (call-with-port port proc)
938  (receive args (proc port)
939    (close-port port)
940    (apply values args)))
941
942
943;; 8.2.10 output port
944(define (open-bytevector-output-port . maybe-transcoder)
945  (when (> (length maybe-transcoder) 1)
946      (assertion-violation
947       'open-bytevector-output-port
948       (format
949        "wrong number of argument: expected between 0 and 1, but got ~a"
950        (length maybe-transcoder))
951       maybe-transcoder))
952  (let ((transcoder (if (null? maybe-transcoder)
953                        #f
954                        (car maybe-transcoder))))
955    (let* ((port (open-output-bytevector transcoder))
956           (proc (lambda () (extract-output-bytevector port))))
957      (values port proc))))
958
959(define (open-string-output-port)
960  (let* ((port (open-output-string))
961         (proc (lambda () (extract-output-string port))))
962    (values port proc)))
963
964(define (call-with-bytevector-output-port proc . maybe-transcoder)
965  (receive (port extractor) (apply open-bytevector-output-port maybe-transcoder)
966    (proc port) (extractor)))
967
968(define (call-with-string-output-port proc)
969  (receive (port extractor) (open-string-output-port)
970    (proc port) (extractor)))
971
972;;;;;
973;; 13 hashtable
974;; 13.3 inspection
975(define (hashtable-equivalence-function ht)
976  (or (hashtable? ht)
977      (assertion-violation 'hashtable-equivalence-function
978			   (wrong-type-argument-message "hashtable" ht)))
979  (case (hashtable-type ht)
980    ((eq)     eq?)
981    ((eqv)    eqv?)
982    ((equal)  equal?)
983    ((string) string=?)
984    ((general) (hashtable-compare ht))))
985
986(define (hashtable-hash-function ht)
987  (or (hashtable? ht)
988      (assertion-violation 'hashtable-hash-function
989			   (wrong-type-argument-message "hashtable" ht)))
990  (case (hashtable-type ht)
991    ((eq)     #f)
992    ((eqv)    #f)
993    ((equal)  equal-hash)
994    ((string) string-hash)
995    ((general) (hashtable-hasher ht))))
996
997;;;; end of file
998;; Local Variables:
999;; coding: utf-8-unix
1000;; End:
1001