source: project/release/4/r7rs/trunk/scheme.base.scm @ 30579

Last change on this file since 30579 was 30579, checked in by evhan, 8 years ago

r7rs/base: Fix peek-u8 to correctly return eof (patch credit to Seth Alves)

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