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

Last change on this file since 30653 was 30653, checked in by evhan, 7 years ago

r7rs/base: Bytevector ports (credit to Seth Alves)

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