conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

slightly enhanced error message for attempting to transcode a port 

using an unsupported line-style (the only supported one is "none" as
of now).
This commit is contained in:
Abdulaziz Ghuloum 2008-01-22 03:30:52 -05:00
parent 264c58c4a4
commit 313e59bc92
2 changed files with 58 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

94
scheme/ikarus.io.ss
View File

@ -328,26 +328,29 @@
(define (input-transcoder-attrs x) (define (input-transcoder-attrs x who)
(cond (cond
[(not x) ;;; binary input port [(not x) ;;; binary input port
binary-input-port-bits] binary-input-port-bits]
[(and (eq? 'latin-1-codec (transcoder-codec x)) [(not (eq? 'none (transcoder-eol-style x)))
(eq? 'none (transcoder-eol-style x))) (die who "unsupported transcoder eol-style"
(transcoder-eol-style x))]
[(eq? 'latin-1-codec (transcoder-codec x))
(fxior textual-input-port-bits fast-u8-text-tag)] (fxior textual-input-port-bits fast-u8-text-tag)]
;;; attrs for utf-8-codec are set as part of the ;;; attrs for utf-8-codec are set as part of the
;;; bom-reading dance when the first char is read. ;;; bom-reading dance when the first char is read.
[else textual-input-port-bits])) [else textual-input-port-bits]))
(define (output-transcoder-attrs x) (define (output-transcoder-attrs x who)
(cond (cond
[(not x) ;;; binary input port [(not x) ;;; binary input port
binary-output-port-bits] binary-output-port-bits]
[(and (eq? 'latin-1-codec (transcoder-codec x)) [(not (eq? 'none (transcoder-eol-style x)))
(eq? 'none (transcoder-eol-style x))) (die who "unsupported transcoder eol-style"
(transcoder-eol-style x))]
[(eq? 'latin-1-codec (transcoder-codec x))
(fxior textual-output-port-bits fast-u8-text-tag)] (fxior textual-output-port-bits fast-u8-text-tag)]
[(and (eq? 'utf-8-codec (transcoder-codec x)) [(eq? 'utf-8-codec (transcoder-codec x))
(eq? 'none (transcoder-eol-style x)))
(fxior textual-output-port-bits fast-u7-text-tag)] (fxior textual-output-port-bits fast-u7-text-tag)]
[else textual-output-port-bits])) [else textual-output-port-bits]))
@ -363,7 +366,8 @@
(die 'open-bytevector-input-port (die 'open-bytevector-input-port
"not a transcoder" maybe-transcoder)) "not a transcoder" maybe-transcoder))
($make-port ($make-port
(input-transcoder-attrs maybe-transcoder) (input-transcoder-attrs maybe-transcoder
'open-bytevector-output-port)
0 (bytevector-length bv) bv 0 (bytevector-length bv) bv
maybe-transcoder maybe-transcoder
"*bytevector-input-port*" "*bytevector-input-port*"
@ -384,7 +388,8 @@
(let ([buf* '()] [buffer-size 256]) (let ([buf* '()] [buffer-size 256])
(let ([p (let ([p
($make-port ($make-port
(output-transcoder-attrs transcoder) (output-transcoder-attrs transcoder
'open-bytevector-output-port)
0 buffer-size (make-bytevector buffer-size) 0 buffer-size (make-bytevector buffer-size)
transcoder transcoder
"*bytevector-output-port*" "*bytevector-output-port*"
@ -541,8 +546,10 @@
(guarded-port (guarded-port
($make-port ($make-port
(cond (cond
[read! (input-transcoder-attrs transcoder)] [read! (input-transcoder-attrs transcoder
[write! (output-transcoder-attrs transcoder)] 'transcoded-port)]
[write! (output-transcoder-attrs transcoder
'transcoded-port)]
[else [else
(die 'transcoded-port (die 'transcoded-port
"port is neither input nor output!")]) "port is neither input nor output!")])
@ -1200,10 +1207,10 @@
(define input-file-buffer-size (+ input-block-size 128)) (define input-file-buffer-size (+ input-block-size 128))
(define output-file-buffer-size output-block-size) (define output-file-buffer-size output-block-size)
(define (fh->input-port fd id size transcoder close) (define (fh->input-port fd id size transcoder close who)
(letrec ([port (letrec ([port
($make-port ($make-port
(input-transcoder-attrs transcoder) (input-transcoder-attrs transcoder who)
0 0 (make-bytevector size) 0 0 (make-bytevector size)
transcoder transcoder
id id
@ -1233,10 +1240,10 @@
fd)]) fd)])
(guarded-port port))) (guarded-port port)))
(define (fh->output-port fd id size transcoder close) (define (fh->output-port fd id size transcoder close who)
(letrec ([port (letrec ([port
($make-port ($make-port
(output-transcoder-attrs transcoder) (output-transcoder-attrs transcoder who)
0 size (make-bytevector size) 0 size (make-bytevector size)
transcoder transcoder
id id
@ -1319,7 +1326,8 @@
filename filename
input-file-buffer-size input-file-buffer-size
transcoder transcoder
#t)])) #t
'open-file-input-port)]))
(define open-file-output-port (define open-file-output-port
@ -1343,7 +1351,8 @@
filename filename
output-file-buffer-size output-file-buffer-size
transcoder transcoder
#t)])) #t
'open-file-output-port)]))
(define (open-output-file filename) (define (open-output-file filename)
(unless (string? filename) (unless (string? filename)
@ -1354,7 +1363,8 @@
filename filename
output-file-buffer-size output-file-buffer-size
(native-transcoder) (native-transcoder)
#t)) #t
'open-output-file))
(define (open-input-file filename) (define (open-input-file filename)
(unless (string? filename) (unless (string? filename)
@ -1364,7 +1374,8 @@
filename filename
input-file-buffer-size input-file-buffer-size
(native-transcoder) (native-transcoder)
#t)) #t
'open-input-file))
(define (with-output-to-file filename proc) (define (with-output-to-file filename proc)
@ -1379,7 +1390,8 @@
filename filename
output-file-buffer-size output-file-buffer-size
(native-transcoder) (native-transcoder)
#t) #t
'with-output-to-file)
(lambda (p) (lambda (p)
(parameterize ([*the-output-port* p]) (parameterize ([*the-output-port* p])
(proc))))) (proc)))))
@ -1396,7 +1408,8 @@
filename filename
output-file-buffer-size output-file-buffer-size
(native-transcoder) (native-transcoder)
#t) #t
'call-with-output-file)
proc)) proc))
(define (call-with-input-file filename proc) (define (call-with-input-file filename proc)
@ -1410,7 +1423,8 @@
filename filename
input-file-buffer-size input-file-buffer-size
(native-transcoder) (native-transcoder)
#t) #t
'call-with-input-file)
proc)) proc))
(define (with-input-from-file filename proc) (define (with-input-from-file filename proc)
@ -1424,7 +1438,8 @@
filename filename
input-file-buffer-size input-file-buffer-size
(native-transcoder) (native-transcoder)
#t) #t
'with-input-from-file)
(lambda (p) (lambda (p)
(parameterize ([*the-input-port* p]) (parameterize ([*the-input-port* p])
(proc))))) (proc)))))
@ -1439,30 +1454,30 @@
(proc))) (proc)))
(define (standard-input-port) (define (standard-input-port)
(fh->input-port 0 '*stdin1* 256 #f #f)) (fh->input-port 0 '*stdin* 256 #f #f 'standard-input-port))
(define (standard-output-port) (define (standard-output-port)
(fh->output-port 1 '*stdout1* 256 #f #f)) (fh->output-port 1 '*stdout* 256 #f #f 'standard-output-port))
(define (standard-error-port) (define (standard-error-port)
(fh->output-port 2 '*stderr1* 256 #f #f)) (fh->output-port 2 '*stderr* 256 #f #f 'standard-error-port))
(define *the-input-port* (define *the-input-port*
(make-parameter (make-parameter
(transcoded-port (transcoded-port
(fh->input-port 0 '*stdin2* input-file-buffer-size #f #f) (fh->input-port 0 '*stdin* input-file-buffer-size #f #f #f)
(native-transcoder)))) (native-transcoder))))
(define *the-output-port* (define *the-output-port*
(make-parameter (make-parameter
(transcoded-port (transcoded-port
(fh->output-port 1 '*stdout2* output-file-buffer-size #f #f) (fh->output-port 1 '*stdout* output-file-buffer-size #f #f #f)
(native-transcoder)))) (native-transcoder))))
(define *the-error-port* (define *the-error-port*
(make-parameter (make-parameter
(transcoded-port (transcoded-port
(fh->output-port 2 '*stderr2* output-file-buffer-size #f #f) (fh->output-port 2 '*stderr* output-file-buffer-size #f #f #f)
(native-transcoder)))) (native-transcoder))))
(define console-output-port (define console-output-port
@ -1863,7 +1878,9 @@
[else [else
(if (output-port? p) (if (output-port? p)
(if (textual-port? p) (if (textual-port? p)
(die who "port is closed" p) (if (port-closed? p)
(die who "port is closed" p)
(die who "unsupported port" p))
(die who "not a textual port" p)) (die who "not a textual port" p))
(die who "not an output port" p))])))) (die who "not an output port" p))]))))
@ -1877,7 +1894,7 @@
(die 'newline "not an output port" p)) (die 'newline "not an output port" p))
(unless (textual-port? p) (unless (textual-port? p)
(die 'newline "not a textual port" p)) (die 'newline "not a textual port" p))
(when ($port-closed? p) (when ($port-closed? p)
(die 'newline "port is closed" p)) (die 'newline "port is closed" p))
(put-char p #\newline) (put-char p #\newline)
(flush-output-port p)])) (flush-output-port p)]))
@ -1998,11 +2015,14 @@
(values (values
(vector-ref r 0) ; pid (vector-ref r 0) ; pid
(fh->output-port (vector-ref r 1) (fh->output-port (vector-ref r 1)
cmd output-file-buffer-size #f #t) cmd output-file-buffer-size #f #t
'process)
(fh->input-port (vector-ref r 2) (fh->input-port (vector-ref r 2)
cmd input-file-buffer-size #f #t) cmd input-file-buffer-size #f #t
'process)
(fh->input-port (vector-ref r 3) (fh->input-port (vector-ref r 3)
cmd input-file-buffer-size #f #t))))) cmd input-file-buffer-size #f #t
'process)))))
(define (socket->ports socket who id) (define (socket->ports socket who id)
(if (< socket 0) (if (< socket 0)
@ -2015,9 +2035,9 @@
(set! closed-once? #t))))]) (set! closed-once? #t))))])
(values (values
(fh->output-port socket (fh->output-port socket
id output-file-buffer-size #f close) id output-file-buffer-size #f close who)
(fh->input-port socket (fh->input-port socket
id input-file-buffer-size #f close))))) id input-file-buffer-size #f close who)))))
(define (tcp-connect host srvc) (define (tcp-connect host srvc)
(socket->ports (socket->ports

2
scheme/last-revision
View File

@ -1 +1 @@
1359 1360