~ chicken-r7rs (master) /scheme.base.scm

  1(module scheme.base ()
  2
  3(import chicken.fixnum
  4        chicken.module
  5        chicken.syntax
  6        chicken.type
  7        (except chicken.condition with-exception-handler)
  8        (rename chicken.platform (features feature-keywords))
  9        (only chicken.base call/cc case-lambda current-error-port
 10              define-values exact-integer? exact-integer-sqrt letrec*
 11              let-values let*-values make-parameter open-input-string
 12              parameterize quotient&remainder error foldl cut optional
 13              when unless receive)
 14        (except scheme syntax-rules assoc list-tail member string-copy
 15                string->list vector->list vector-fill! char=? char<? char>?
 16                char<=? char>=? string=? string<? string>? string<=? string>=?))
 17
 18;; For syntax definition helpers.
 19(import-for-syntax r7rs-support)
 20(import-for-syntax r7rs-compile-time)
 21(import r7rs-support)
 22
 23;; Export all of scheme.base from this module.
 24(import (prefix (only chicken.base include) %))
 25(%include "scheme.base-interface.scm")
 26
 27;; Numerical operations.
 28(import (rename (only scheme exact->inexact inexact->exact)
 29                (exact->inexact inexact)
 30                (inexact->exact exact)))
 31
 32;; read/write-string/line/byte
 33(import (prefix (only chicken.io write-string) %))
 34(import (rename (only chicken.io read-line read-string read-byte write-byte)
 35                (read-byte read-u8)
 36                (write-byte write-u8)))
 37
 38;; flush-output
 39(import (rename (only chicken.base flush-output)
 40                (flush-output flush-output-port)))
 41
 42;; Bytevectors.
 43(import (rename (only srfi-4 make-u8vector subu8vector u8vector
 44                      u8vector? u8vector-length u8vector-ref
 45                      u8vector-set! read-u8vector read-u8vector!
 46                      write-u8vector)
 47                (u8vector bytevector)
 48                (u8vector-length bytevector-length)
 49                (u8vector-ref bytevector-u8-ref)
 50                (u8vector-set! bytevector-u8-set!)
 51                (u8vector? bytevector?)
 52                (make-u8vector make-bytevector)
 53                (read-u8vector read-bytevector)
 54                (write-u8vector write-bytevector)))
 55
 56;; u8-ready?
 57(import (rename (only scheme char-ready?)
 58                (char-ready? u8-ready?)))
 59
 60;; Non-R5RS string and char procedures.
 61(import (prefix (only scheme char=? char<? char>? char<=? char>=?) %))
 62(import (prefix (only scheme string=? string<? string>? string<=? string>=?) %))
 63(import (prefix (only srfi-13 string-for-each string-map) %))
 64(import (only srfi-13 string-copy string-copy! string-fill! string->list))
 65
 66;; For d-r-t redefinition.
 67(import-for-syntax (only chicken.base define-record-type))
 68
 69;;;
 70;;; 4.1.7. Inclusion
 71;;;
 72
 73(define-syntax include r7rs-include)
 74(define-syntax include-ci r7rs-include-ci)
 75
 76;;;
 77;;; 4.2.1. Conditionals
 78;;;
 79
 80(define-syntax cond-expand r7rs-cond-expand)
 81
 82;;;
 83;;; 4.2.7. Exception handling
 84;;;
 85
 86;; guard & guard-aux copied verbatim from the draft.
 87;; guard-aux put in a letrec-syntax due to import/export issues...
 88(define-syntax guard
 89  (syntax-rules ()
 90    ((guard (var clause ...) e1 e2 ...)
 91     (letrec-syntax ((guard-aux 
 92                      (syntax-rules ___ (else =>)
 93                        ((guard-aux reraise (else result1 result2 ___))
 94                         (begin result1 result2 ___))
 95                        ((guard-aux reraise (test => result))
 96                         (let ((temp test))
 97                           (if temp
 98                               (result temp)
 99                               reraise)))
100                        ((guard-aux reraise (test => result)
101                                    clause1 clause2 ___)
102                         (let ((temp test))
103                           (if temp
104                               (result temp)
105                               (guard-aux reraise clause1 clause2 ___))))
106                        ((guard-aux reraise (test))
107                         (or test reraise))
108                        ((guard-aux reraise (test) clause1 clause2 ___)
109                         (let ((temp test))
110                           (if temp
111                               temp
112                               (guard-aux reraise clause1 clause2 ___))))
113                        ((guard-aux reraise (test result1 result2 ___))
114                         (if test
115                             (begin result1 result2 ___)
116                             reraise))
117                        ((guard-aux reraise
118                                    (test result1 result2 ___)
119                                    clause1 clause2 ___)
120                         (if test
121                             (begin result1 result2 ___)
122                             (guard-aux reraise clause1 clause2 ___))))))
123      ((call/cc
124        (lambda (guard-k)
125          (with-exception-handler
126           (lambda (condition)
127             ((call/cc
128               (lambda (handler-k)
129                 (guard-k
130                  (lambda ()
131                    (let ((var condition))
132                      (guard-aux
133                       (handler-k
134                        (lambda ()
135                          (raise-continuable condition)))
136                       clause ...))))))))
137           (lambda ()
138             (call-with-values
139                 (lambda () e1 e2 ...)
140               (lambda args
141                 (guard-k
142                  (lambda ()
143                    (apply values args))))))))))))))
144
145;;;
146;;; 5.5 Record-type definitions
147;;;
148
149(define ##sys#make-symbol
150  (##core#primitive "C_make_symbol"))
151
152;; Rewrite the standard d-r-t expansion so that each newly-defined
153;; record type has a unique type tag. This is every kind of hacky.
154(define-syntax define-record-type
155  (wrap-er-macro-transformer
156   'define-record-type
157   (lambda (e r c define-record-type)
158     (let ((name (cadr e))
159           (tag  (gensym "\x04r7rsrecord-type-tag")))
160       `(##core#begin
161         (##core#set! ,(r tag)
162          (##sys#make-symbol ,(symbol->string name)))
163         ,(let lp ((x (define-record-type e)))
164            (cond ((equal? x `(##core#quote ,name)) (r tag))
165                  ((pair? x) (cons (lp (car x)) (lp (cdr x))))
166                  (else x))))))))
167
168;;;
169;;; 6.2.6 Numerical operations
170;;;
171
172;; TODO: Copy the specializations from types.db
173(: truncate/ ((or integer float) (or integer float) -> (or integer float) (or integer float)))
174
175(define truncate/ quotient&remainder)
176
177(: truncate-remainder ((or integer float) (or integer float) -> (or integer float)))
178
179(define truncate-remainder remainder)
180
181(: truncate-quotient ((or integer float) (or integer float) -> (or integer float)))
182
183(define truncate-quotient quotient)
184
185;; XXX These are bad bad bad definitions; very inefficient.
186;; But to improve it we would need to provide another implementation
187;; of the quotient procedure which floors instead of truncates.
188
189(: floor-remainder ((or fixnum bignum float ratnum) (or fixnum bignum float ratnum) -> (or fixnum bignum float ratnum) (or fixnum bignum float ratnum)))
190
191(define (floor-remainder x y)
192  (receive (div rem) (floor/ x y) rem))
193
194(: floor-quotient ((or fixnum bignum float ratnum) (or fixnum bignum float ratnum) -> (or fixnum bignum float ratnum) (or fixnum bignum float ratnum)))
195
196(define (floor-quotient x y)
197  (receive (div rem) (floor/ x y) div))
198
199(: floor/ ((or fixnum bignum float ratnum) (or fixnum bignum float ratnum) -> (or fixnum bignum float ratnum) (or fixnum bignum float ratnum)))
200
201;; Same as quotient&remainder, but quotient gets adjusted along with
202;; the remainder.
203(define (floor/ x y)
204  (receive (div rem) (quotient&remainder x y)
205    (if (positive? y)
206        (if (negative? rem)
207            (values (- div 1) (+ rem y))
208            (values div rem))
209        (if (positive? rem)
210            (values (- div 1) (+ rem y))
211            (values div rem)))))
212
213
214(: square (number -> number))
215(: floor/ (number number -> number number))
216(: floor-quotient (number number -> number))
217
218(define (square n) (* n n))
219
220;; `floor/` and `floor-quotient` taken from the numbers egg.
221
222(define (floor/ x y)
223  (receive (div rem) (quotient&remainder x y)
224    (if (positive? y)
225        (if (negative? rem)
226            (values (- div 1) (+ rem y))
227            (values div rem))
228        (if (positive? rem)
229            (values (- div 1) (+ rem y))
230            (values div rem)))))
231
232(define (floor-quotient x y)
233  (receive (div rem) (floor/ x y) div))
234
235;;;
236;;; 6.3 Booleans
237;;;
238
239(: boolean=? (boolean boolean #!rest boolean -> boolean))
240
241(define-extended-arity-comparator boolean=? eq? ##sys#check-boolean)
242
243
244;;;
245;;; 6.4 pairs and lists
246;;;
247
248(: make-list (forall (x) (fixnum #!optional x -> (list-of x))))
249
250(define make-list
251  (case-lambda
252   ((n) (make-list n #f))
253   ((n fill)
254    (##sys#check-integer n 'make-list)
255    (unless (fx>= n 0)
256      (error 'make-list "not a positive integer" n))
257    (do ((i n (fx- i 1))
258         (result '() (cons fill result)))
259        ((fx= i 0) result)))))
260
261
262(: list-tail (forall (x) ((list-of x) fixnum -> (list-of x))))
263
264(define (list-tail l n)
265  (##sys#check-integer n 'list-tail)
266  (unless (fx>= n 0)
267    (error 'list-tail "not a positive integer" n))
268  (do ((i n (fx- i 1))
269       (result l (cdr result)))
270      ((fx= i 0) result)
271    (when (null? result)
272      (error 'list-tail "out of range"))))
273
274
275(: list-set! (list fixnum * -> undefined))
276
277(define (list-set! l n obj)
278  (##sys#check-integer n 'list-set!)
279  (unless (fx>= n 0)
280    (error 'list-set! "not a positive integer" n))
281  (do ((i n (fx- i 1))
282       (l l (cdr l)))
283      ((fx= i 0) (set-car! l obj))
284    (when (null? l)
285      (error 'list-set! "out of range"))))
286
287(: member (forall (a b) (a (list-of b) #!optional (procedure (b a) *) ; sic
288                         -> (or false (list-of b)))))
289
290;; XXX These aren't exported to the types file!?
291(define-specialization (member (x (or symbol procedure immediate)) (lst list))
292  (##core#inline "C_u_i_memq" x lst))
293(define-specialization (member x (lst (list-of (or symbol procedure immediate))))
294  (##core#inline "C_u_i_memq" x lst))
295(define-specialization (member x lst)
296  (##core#inline "C_i_member" x lst))
297
298(define member
299  (case-lambda
300   ((x lst) (##core#inline "C_i_member" x lst))
301   ((x lst eq?)
302    (let lp ((lst lst))
303      (cond ((null? lst) #f)
304            ((eq? (car lst) x) lst)
305            (else (lp (cdr lst))))))))
306
307
308(: assoc (forall (a b c) (a (list-of (pair b c)) #!optional (procedure (b a) *) ; sic
309                            -> (or false (list-of (pair b c))))))
310
311;; XXX These aren't exported to the types file!?
312(define-specialization (assoc (x (or symbol procedure immediate)) (lst (list-of pair)))
313  (##core#inline "C_u_i_assq" x lst))
314(define-specialization (assoc x (lst (list-of (pair (or symbol procedure immediate) *))))
315  (##core#inline "C_u_i_assq" x lst))
316(define-specialization (assoc x lst)
317  (##core#inline "C_i_assoc" x lst))
318
319(define assoc
320  (case-lambda
321   ((x lst) (##core#inline "C_i_assoc" x lst))
322   ((x lst eq?)
323    (let lp ((lst lst))
324      (cond ((null? lst) #f)
325            ((not (pair? (car lst)))
326             (error 'assoc "unexpected non-pair in list" (car lst)))
327            ((eq? (caar lst) x) (car lst))
328            (else (lp (cdr lst))))))))
329
330
331(: list-copy (forall (a) (a -> a)))
332
333;; TODO: Test if this is the quickest way to do this, or whether we
334;; should just cons recursively like our SRFI-1 implementation does.
335(define (list-copy lst)
336  (cond ((pair? lst)
337         (let lp ((res '())
338                  (lst lst))
339           (if (pair? lst)
340               (lp (cons (car lst) res) (cdr lst))
341               (append (##sys#fast-reverse res) lst))))
342        (else lst)))
343
344;;;
345;;; 6.5 Symbols
346;;;
347
348(: symbol=? (symbol symbol #!rest symbol -> boolean))
349
350(define-extended-arity-comparator symbol=? eqv? ##sys#check-symbol)
351
352;;;
353;;; 6.6 Characters
354;;;
355
356(: char=? (char char #!rest char -> boolean))
357(: char<? (char char #!rest char -> boolean))
358(: char>? (char char #!rest char -> boolean))
359(: char<=? (char char #!rest char -> boolean))
360(: char>=? (char char #!rest char -> boolean))
361
362(define-extended-arity-comparator char=? %char=? ##sys#check-char)
363(define-extended-arity-comparator char>? %char>? ##sys#check-char)
364(define-extended-arity-comparator char<? %char<? ##sys#check-char)
365(define-extended-arity-comparator char<=? %char<=? ##sys#check-char)
366(define-extended-arity-comparator char>=? %char>=? ##sys#check-char)
367
368;;;
369;;; 6.7 Strings
370;;;
371
372(: string=? (string string #!rest string -> boolean))
373(: string<? (string string #!rest string -> boolean))
374(: string>? (string string #!rest string -> boolean))
375(: string<=? (string string #!rest string -> boolean))
376(: string>=? (string string #!rest string -> boolean))
377
378(define-extended-arity-comparator string=? %string=? ##sys#check-string)
379(define-extended-arity-comparator string<? %string<? ##sys#check-string)
380(define-extended-arity-comparator string>? %string>? ##sys#check-string)
381(define-extended-arity-comparator string<=? %string<=? ##sys#check-string)
382(define-extended-arity-comparator string>=? %string>=? ##sys#check-string)
383
384(: string->vector (string #!optional fixnum fixnum -> (vector-of char)))
385(: vector->string ((vector-of char) #!optional fixnum fixnum -> string))
386
387(define string->vector
388  (let ((s->v (lambda (s start . end)
389                (##sys#check-string s 'string->vector)
390                (let* ((len (##sys#size s))
391                       (end (optional end len)))
392                  (##sys#check-range start 0 (fx+ end 1) 'string->vector)
393                  (##sys#check-range end start (fx+ len 1) 'string->vector)
394                  (let ((v (##sys#make-vector (fx- end start))))
395                    (do ((ti 0 (fx+ ti 1))
396                         (fi start (fx+ fi 1)))
397                        ((fx= fi end) v)
398                      (##sys#setslot v ti (##core#inline "C_subchar" s fi))))))))
399    (case-lambda
400      ((s) (s->v s 0))
401      ((s start) (s->v s start))
402      ((s start end) (s->v s start end)))))
403
404(define vector->string
405  (let ((v->s (lambda (v start . end)
406                (##sys#check-vector v 'vector->string)
407                (let* ((len (##sys#size v))
408                       (end (optional end len)))
409                  (##sys#check-range start 0 (fx+ end 1) 'vector->string)
410                  (##sys#check-range end start (fx+ len 1) 'vector->string)
411                  (let ((s (##sys#make-string (fx- end start))))
412                    (do ((ti 0 (fx+ ti 1))
413                         (fi start (fx+ fi 1)))
414                        ((fx= fi end) s)
415                      (let ((c (##sys#slot v fi)))
416                        (##sys#check-char c 'vector->string)
417                        (##core#inline "C_setsubchar" s ti c))))))))
418    (case-lambda
419      ((v) (v->s v 0))
420      ((v start) (v->s v start))
421      ((v start end) (v->s v start end)))))
422
423;;;
424;;; 6.8. Vectors
425;;;
426
427(: vector-append (#!rest vector -> vector))
428(: vector-copy (forall (a) ((vector-of a) #!optional fixnum fixnum -> (vector-of a))))
429(: vector-copy! (vector fixnum vector #!optional fixnum fixnum -> undefined))
430(: vector-fill! (vector * #!optional fixnum fixnum -> undefined))
431(: vector->list (forall (a) ((vector-of a) #!optional fixnum fixnum -> (list-of a))))
432
433(define vector-copy
434  (let ((copy (lambda (v start . end)
435                (##sys#check-vector v 'vector-copy)
436                (let* ((len (##sys#size v))
437                       (end (optional end len)))
438                  (##sys#check-range start 0 (fx+ end 1) 'vector-copy)
439                  (##sys#check-range end start (fx+ len 1) 'vector-copy)
440                  (let ((vec (##sys#make-vector (fx- end start))))
441                    (do ((ti 0 (fx+ ti 1))
442                         (fi start (fx+ fi 1)))
443                        ((fx>= fi end) vec)
444                      (##sys#setslot vec ti (##sys#slot v fi))))))))
445    (case-lambda
446      ((v) (copy v 0))
447      ((v start) (copy v start))
448      ((v start end) (copy v start end)))))
449
450(define vector-copy!
451  (let ((copy! (lambda (to at from start . end)
452                 (##sys#check-vector to 'vector-copy!)
453                 (##sys#check-vector from 'vector-copy!)
454                 (let* ((tlen (##sys#size to))
455                        (flen (##sys#size from))
456                        (end  (optional end flen)))
457                   (##sys#check-range at 0 (fx+ tlen 1) 'vector-copy!)
458                   (##sys#check-range start 0 (fx+ end 1) 'vector-copy!)
459                   (##sys#check-range end start (fx+ flen 1) 'vector-copy!)
460                   (##sys#check-range (fx- end start) 0 (fx+ (fx- tlen at) 1) 'vector-copy!)
461                   (do ((fi start (fx+ fi 1))
462                        (ti at (fx+ ti 1)))
463                       ((fx= fi end))
464                     (##sys#setslot to ti (##sys#slot from fi)))))))
465    (case-lambda
466      ((to at from) (copy! to at from 0))
467      ((to at from start) (copy! to at from start))
468      ((to at from start end) (copy! to at from start end)))))
469
470(define vector-fill!
471  (let ((fill! (lambda (v f start . end)
472                 (##sys#check-vector v 'vector-fill!)
473                 (let* ((len (##sys#size v))
474                        (end (optional end len)))
475                   (##sys#check-range start 0 (fx+ end 1) 'vector-fill!)
476                   (##sys#check-range end start (fx+ len 1) 'vector-fill!)
477                   (do ((i start (fx+ i 1)))
478                       ((fx= i end))
479                     (##sys#setslot v i f))))))
480    (case-lambda
481      ((v f) (fill! v f 0))
482      ((v f start) (fill! v f start))
483      ((v f start end) (fill! v f start end)))))
484
485(define vector->list
486  (let ((v->l (lambda (v start . end)
487                (##sys#check-vector v 'vector->list)
488                (let* ((len (##sys#size v))
489                       (end (optional end len)))
490                  (##sys#check-range start 0 (fx+ end 1) 'vector->list)
491                  (##sys#check-range end start (fx+ len 1) 'vector->list)
492                  (do ((i start (fx+ i 1))
493                       (l '() (cons (##sys#slot v i) l)))
494                      ((fx= i end) (##sys#fast-reverse l)))))))
495    (case-lambda
496      ((v) (v->l v 0))
497      ((v start) (v->l v start))
498      ((v start end) (v->l v start end)))))
499
500(define (vector-append . vs)
501  (##sys#for-each (cut ##sys#check-vector <> 'vector-append) vs)
502  (let* ((lens (map ##sys#size vs))
503         (vec  (##sys#make-vector (foldl fx+ 0 lens))))
504    (do ((vs vs (cdr vs))
505         (lens lens (cdr lens))
506         (i 0 (fx+ i (car lens))))
507        ((null? vs) vec)
508      (vector-copy! vec i (car vs) 0 (car lens)))))
509
510;;;
511;;; 6.9. Bytevectors
512;;;
513
514(define-type bytevector u8vector)
515
516(: bytevector (#!rest fixnum -> bytevector))
517(: bytevector-append (#!rest bytevector -> bytevector))
518(: bytevector-copy (bytevector #!optional fixnum fixnum -> bytevector))
519(: bytevector-copy! (bytevector fixnum bytevector #!optional fixnum fixnum -> undefined))
520(: bytevector-length (bytevector -> fixnum))
521(: bytevector-u8-ref (bytevector fixnum -> fixnum))
522(: bytevector-u8-set! (bytevector fixnum fixnum -> void))
523(: bytevector? (* -> boolean : bytevector))
524(: make-bytevector (fixnum #!optional fixnum -> bytevector))
525(: string->utf8 (string #!optional fixnum fixnum -> bytevector))
526(: utf8->string (bytevector #!optional fixnum fixnum -> string))
527(: write-bytevector (bytevector #!optional output-port fixnum fixnum -> void))
528
529(define bytevector-copy
530  (case-lambda
531    ((bv)
532     (##sys#check-structure bv 'u8vector 'bytevector-copy)
533     (subu8vector bv 0 (bytevector-length bv)))
534    ((bv start)
535     (##sys#check-structure bv 'u8vector 'bytevector-copy)
536     (subu8vector bv start (bytevector-length bv)))
537    ((bv start end)
538     (subu8vector bv start end))))
539
540(define bytevector-copy!
541  (let ((copy! (lambda (to at from start . end)
542                 (##sys#check-structure to 'u8vector 'bytevector-copy!)
543                 (##sys#check-structure from 'u8vector 'bytevector-copy!)
544                 (let* ((tlen (bytevector-length to))
545                        (flen (bytevector-length from))
546                        (end  (optional end flen)))
547                   (##sys#check-range at 0 (fx+ tlen 1) 'bytevector-copy!)
548                   (##sys#check-range start 0 (fx+ end 1) 'bytevector-copy!)
549                   (##sys#check-range end start (fx+ flen 1) 'bytevector-copy!)
550                   (##sys#check-range (fx- end start) 0 (fx+ (fx- tlen at) 1) 'bytevector-copy!)
551                   (do ((fi start (fx+ fi 1))
552                        (ti at (fx+ ti 1)))
553                       ((fx= fi end))
554                     (bytevector-u8-set! to ti (bytevector-u8-ref from fi)))))))
555    (case-lambda
556      ((to at from) (copy! to at from 0))
557      ((to at from start) (copy! to at from start))
558      ((to at from start end) (copy! to at from start end)))))
559
560(define (bytevector-append . bvs)
561  (##sys#for-each (cut ##sys#check-structure <> 'u8vector 'bytevector-append) bvs)
562  (let* ((lens (map bytevector-length bvs))
563         (bv   (make-bytevector (foldl fx+ 0 lens))))
564    (do ((bvs bvs (cdr bvs))
565         (lens lens (cdr lens))
566         (i 0 (fx+ i (car lens))))
567        ((null? bvs) bv)
568      (bytevector-copy! bv i (car bvs) 0 (car lens)))))
569
570(define utf8->string
571  (let ((bv->s (lambda (bv start . end)
572                (##sys#check-structure bv 'u8vector 'utf8->string)
573                (let* ((len (bytevector-length bv))
574                       (end (optional end len)))
575                  (##sys#check-range start 0 (fx+ end 1) 'utf8->string)
576                  (##sys#check-range end start (fx+ len 1) 'utf8->string)
577                  (let ((s (##sys#make-string (fx- end start))))
578                    (do ((si 0 (fx+ si 1))
579                         (vi start (fx+ vi 1)))
580                        ((fx= vi end) s)
581                      (##sys#setbyte s si (bytevector-u8-ref bv vi))))))))
582    (case-lambda
583      ((bv) (bv->s bv 0))
584      ((bv start) (bv->s bv start))
585      ((bv start end) (bv->s bv start end)))))
586
587(define string->utf8
588  (let ((s->bv (lambda (s start . end)
589                (##sys#check-string s 'string->utf8)
590                (let* ((len (##sys#size s))
591                       (end (optional end len)))
592                  (##sys#check-range start 0 (fx+ end 1) 'string->utf8)
593                  (##sys#check-range end start (fx+ len 1) 'string->utf8)
594                  (let ((bv (make-bytevector (fx- end start))))
595                    (do ((vi 0 (fx+ vi 1))
596                         (si start (fx+ si 1)))
597                        ((fx= si end) bv)
598                      (bytevector-u8-set! bv vi (##sys#byte s si))))))))
599    (case-lambda
600      ((s) (s->bv s 0))
601      ((s start) (s->bv s start))
602      ((s start end) (s->bv s start end)))))
603
604;;;
605;;; 6.10. Control features
606;;;
607
608(: string-for-each ((char #!rest char -> *) string #!rest string -> void))
609(: string-map ((char #!rest char -> char) string #!rest string -> string))
610(: vector-for-each ((* #!rest * -> *) vector #!rest vector -> void))
611(: vector-map ((* #!rest * -> *) vector #!rest vector -> vector))
612
613(define string-map
614  (case-lambda
615    ((proc str)
616     (%string-map proc str))
617    ((proc . strs)
618     (##sys#check-closure proc 'string-map)
619     (##sys#for-each (cut ##sys#check-string <> 'string-map) strs)
620     (let* ((len (foldl fxmin most-positive-fixnum (map ##sys#size strs)))
621            (str (##sys#make-string len)))
622       (do ((i 0 (fx+ i 1)))
623           ((fx= i len) str)
624         (string-set! str i (apply proc (map (cut string-ref <> i) strs))))))))
625
626(define string-for-each
627  (case-lambda
628    ((proc str)
629     (%string-for-each proc str))
630    ((proc . strs)
631     (##sys#check-closure proc 'string-for-each)
632     (##sys#for-each (cut ##sys#check-string <> 'string-for-each) strs)
633     (let* ((len (foldl fxmin most-positive-fixnum (map ##sys#size strs)))
634            (str (##sys#make-string len)))
635       (do ((i 0 (fx+ i 1)))
636           ((fx= i len) str)
637         (apply proc (map (cut string-ref <> i) strs)))))))
638
639(define vector-map
640  (case-lambda
641    ((proc v)
642     (##sys#check-closure proc 'vector-map)
643     (##sys#check-vector v 'vector-map)
644     (let* ((len (##sys#size v))
645            (vec (##sys#make-vector len)))
646       (do ((i 0 (fx+ i 1)))
647           ((fx= i len) vec)
648        (##sys#setslot vec i (proc (##sys#slot v i))))))
649    ((proc . vs)
650     (##sys#check-closure proc 'vector-map)
651     (##sys#for-each (cut ##sys#check-vector <> 'vector-map) vs)
652     (let* ((len (foldl fxmin most-positive-fixnum (map ##sys#size vs)))
653            (vec (##sys#make-vector len)))
654       (do ((i 0 (fx+ i 1)))
655           ((fx= i len) vec)
656         (##sys#setslot vec i (apply proc (map (cut vector-ref <> i) vs))))))))
657
658(define vector-for-each
659  (case-lambda
660    ((proc v)
661     (##sys#check-closure proc 'vector-for-each)
662     (##sys#check-vector v 'vector-for-each)
663     (let ((len (##sys#size v)))
664       (do ((i 0 (fx+ i 1)))
665           ((fx= i len))
666         (proc (##sys#slot v i)))))
667    ((proc . vs)
668     (##sys#check-closure proc 'vector-for-each)
669     (##sys#for-each (cut ##sys#check-vector <> 'vector-for-each) vs)
670     (let* ((len (foldl fxmin most-positive-fixnum (map ##sys#size vs)))
671            (vec (##sys#make-vector len)))
672       (do ((i 0 (fx+ i 1)))
673           ((fx= i len) vec)
674         (apply proc (map (cut vector-ref <> i) vs)))))))
675
676;;;
677;;; 6.11. Exceptions
678;;;
679
680(: with-exception-handler ((* -> . *) (-> . *) -> . *))
681(: raise (* -> noreturn))
682(: raise-continuable (* -> . *))
683
684(define with-exception-handler)
685(define raise)
686(define raise-continuable)
687
688;; XXX TODO: This is not threadsafe!
689(let ((exception-handlers
690       (let ((lst (list ##sys#current-exception-handler)))
691         (set-cdr! lst lst)
692         lst)))
693  (set! with-exception-handler
694    (lambda (handler thunk)
695      (dynamic-wind
696       (lambda ()
697         ;; We might be interoperating with srfi-12 handlers set by intermediate
698         ;; non-R7RS code, so check if a new handler was set in the meanwhile.
699         (unless (eq? (car exception-handlers) ##sys#current-exception-handler)
700           (set! exception-handlers
701             (cons ##sys#current-exception-handler exception-handlers)))
702         (set! exception-handlers (cons handler exception-handlers))
703         (set! ##sys#current-exception-handler handler))
704       thunk
705       (lambda ()
706         (set! exception-handlers (cdr exception-handlers))
707         (set! ##sys#current-exception-handler (car exception-handlers))))))
708   (set! raise
709     (lambda (obj)
710       (with-exception-handler
711        (cadr exception-handlers)
712        (lambda ()
713          ((cadr exception-handlers) obj)
714          ((car exception-handlers)
715           (make-property-condition
716            'exn
717            'message "exception handler returned"
718            'arguments '()
719            'location #f))))))
720   (set! raise-continuable
721     (lambda (obj)
722       (with-exception-handler
723        (cadr exception-handlers)
724        (lambda ()
725          ((cadr exception-handlers) obj))))))
726
727(: error-object? (* -> boolean : (struct condition)))
728(: error-object-message ((struct condition) -> (or string false)))
729(: error-object-irritants ((struct condition) -> (or list false)))
730
731(define (error-object? o) (condition? o))
732(define error-object-message (condition-property-accessor 'exn 'message))
733(define error-object-irritants (condition-property-accessor 'exn 'arguments))
734
735(: read-error? (* --> boolean))
736(: file-error? (* --> boolean))
737
738(define read-error?)
739(define file-error?)
740
741(let ((exn?    (condition-predicate 'exn))
742      (i/o?    (condition-predicate 'i/o))
743      (file?   (condition-predicate 'file))
744      (syntax? (condition-predicate 'syntax)))
745  (set! read-error?
746    (lambda (obj)
747      (and (exn? obj)
748           (or (i/o? obj) ; XXX Not fine-grained enough.
749               (syntax? obj)))))
750  (set! file-error?
751    (lambda (obj)
752      (and (exn? obj)
753           (file? obj)))))
754
755;;;
756;;; 6.13. Input and Output
757;;;
758
759(import (only chicken.base get-output-string open-output-string
760              port-closed? receive port?))
761
762(: binary-port? (* --> boolean : port?))
763(: call-with-port (port (port -> . *) -> . *))
764(: close-port (port -> void))
765(: eof-object (--> eof))
766(: input-port-open? (input-port -> boolean))
767(: output-port-open? (output-port -> boolean))
768(: peek-u8 (#!optional input-port -> fixnum))
769(: read-bytevector! (bytevector #!optional input-port number number -> fixnum))
770(: read-u8 (#!optional input-port -> fixnum))
771(: textual-port? (* --> boolean : port?))
772(: u8-ready? (#!optional input-port -> boolean))
773(: write-string (string #!optional output-port fixnum fixnum -> void))
774(: write-u8 (fixnum #!optional output-port -> void))
775
776;; CHICKEN's ports can handle both.
777(define (binary-port? port) (port? port))
778(define (textual-port? port) (port? port))
779
780(define (call-with-port port proc)
781  (receive ret
782      (proc port)
783    (close-port port)
784    (apply values ret)))
785
786(define (close-port port)
787  (cond ((input-port? port)
788         (close-input-port port))
789        ((output-port? port)
790         (close-output-port port))
791        (else
792         (error 'close-port "not a port" port))))
793
794(define (output-port-open? port)
795  (##sys#check-output-port port #f 'output-port-open?)
796  (not (port-closed? port)))
797
798(define (input-port-open? port)
799  (##sys#check-input-port port #f 'input-port-open?)
800  (not (port-closed? port)))
801
802(define (eof-object) #!eof)
803
804(define peek-u8
805  (case-lambda
806    (()
807     (##sys#check-input-port ##sys#standard-input #t 'peek-u8)
808     (let ((c (peek-char ##sys#standard-input)))
809       (if (eof-object? c) c
810           (char->integer c))))
811    ((port)
812     (##sys#check-input-port port #t 'peek-u8)
813     (let ((c (peek-char port)))
814       (if (eof-object? c) c
815           (char->integer c))))))
816
817(define write-string
818  (case-lambda
819    ((s)
820     (%write-string s #f ##sys#standard-output))
821    ((s port)
822     (%write-string s #f port))
823    ((s port start)
824     (##sys#check-string s 'write-string)
825     (let ((len (##sys#size s)))
826       (##sys#check-range start 0 (fx+ len 1) 'write-string)
827       (%write-string (##sys#substring s start len) #f port)))
828    ((s port start end)
829     (##sys#check-string s 'write-string)
830     (##sys#check-range start 0 (fx+ end 1) 'write-string)
831     (##sys#check-range end start (fx+ (##sys#size s) 1) 'write-string)
832     (%write-string (##sys#substring s start end) #f port))))
833
834(define read-bytevector!
835  (let ((read-u8vector!/eof
836         (lambda (k bv port . args)
837           (let ((r (apply read-u8vector! k bv port args)))
838             (if (fx= r 0) #!eof r)))))
839    (case-lambda
840      ((bv)
841       (read-u8vector!/eof #f bv ##sys#standard-input))
842      ((bv port)
843       (read-u8vector!/eof #f bv port))
844      ((bv port start)
845       (read-u8vector!/eof #f bv port start))
846      ((bv port start end)
847       (read-u8vector!/eof (fx- end start) bv port start)))))
848
849(define (open-input-bytevector bv)
850  (let ((port (##sys#make-port 1 #f "(bytevector)" 'custom)))
851    (##sys#setslot
852     port
853     2
854     (let ((index 0)
855           (bv-len (bytevector-length bv)))
856       (vector (lambda (_) ; read-char
857                 (if (fx= index bv-len)
858                     (eof-object)
859                     (let ((c (bytevector-u8-ref bv index)))
860                       (set! index (fx+ index 1))
861                       (integer->char c))))
862               (lambda (_) ; peek-char
863                 (if (fx= index bv-len)
864                     (eof-object)
865                     (bytevector-u8-ref bv index)))
866               #f    ; write-char
867               #f    ; write-string
868               (lambda (_) ; close
869                 (##sys#setislot port 8 #t))
870               #f    ; flush-output
871               (lambda (_) ; char-ready?
872                 (not (fx= index bv-len)))
873               #f    ; read-string!
874               #f    ; read-line
875               #f))) ; read-buffered
876     port))
877
878(define (open-output-bytevector) (open-output-string))
879
880(define (get-output-bytevector p)
881  (string->utf8 (get-output-string p)))
882
883;;;
884;;; 6.14. System interface
885;;;
886
887(: features (--> (list-of symbol)))
888
889(define (features)
890  (map (lambda (s)
891         (##sys#string->symbol (##sys#symbol->string s)))
892       (feature-keywords))))