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

Last change on this file since 31586 was 31586, checked in by evhan, 6 years ago

r7rs/base: types fix for error-object-{message,irritants} (results may be false)

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