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

file-based ports are now guarded and their file handles are closed 

if the port is dropped and collected.
This commit is contained in:
Abdulaziz Ghuloum 2007-12-12 01:32:55 -05:00
parent af020f909b
commit 3512b4d112
3 changed files with 87 additions and 65 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
scheme/ikarus.boot.prebuilt
View File

Binary file not shown.

150
scheme/ikarus.io.ss
View File

@ -114,7 +114,7 @@
(define-struct $port (define-struct $port
(index size buffer base-index transcoder closed? attrs (index size buffer base-index transcoder closed? attrs
id read! write! get-position set-position! close)) id read! write! get-position set-position! close cookie))
(define port? $port?) (define port? $port?)
(define $set-port-index! set-$port-index!) (define $set-port-index! set-$port-index!)
(define $set-port-size! set-$port-size!) (define $set-port-size! set-$port-size!)
@ -186,17 +186,31 @@
(define r6rs-mode-tag #x1000) (define r6rs-mode-tag #x1000)
(define guarded-port
(let ([G (make-guardian)])
(define (clean-up)
(cond
[(G) =>
(lambda (p)
(close-port p)
(clean-up))]))
(lambda (p)
(clean-up)
(when (fixnum? ($port-cookie p))
(G p))
p)))
(define ($make-custom-binary-port attrs init-size id (define ($make-custom-binary-port attrs init-size id
read! write! get-position set-position! close buffer-size) read! write! get-position set-position! close buffer-size)
(let ([bv (make-bytevector buffer-size)]) (let ([bv (make-bytevector buffer-size)])
($make-port 0 init-size bv 0 #f #f attrs id read! write! get-position ($make-port 0 init-size bv 0 #f #f attrs id read! write! get-position
set-position! close))) set-position! close #f)))
(define ($make-custom-textual-port attrs init-size id (define ($make-custom-textual-port attrs init-size id
read! write! get-position set-position! close buffer-size) read! write! get-position set-position! close buffer-size)
(let ([bv (make-string buffer-size)]) (let ([bv (make-string buffer-size)])
($make-port 0 init-size bv 0 #t #f attrs id read! write! get-position ($make-port 0 init-size bv 0 #t #f attrs id read! write! get-position
set-position! close))) set-position! close #f)))
(define (make-custom-binary-input-port id (define (make-custom-binary-input-port id
read! get-position set-position! close) read! get-position set-position! close)
@ -306,7 +320,7 @@
#f ;;; FIXME: get-position #f ;;; FIXME: get-position
#f ;;; FIXME: set-position! #f ;;; FIXME: set-position!
#f ;;; close #f ;;; close
)])) #f)]))
(define open-bytevector-output-port (define open-bytevector-output-port
(case-lambda (case-lambda
@ -331,6 +345,7 @@
c) c)
#f ;;; FIXME: get-position #f ;;; FIXME: get-position
#f ;;; FIXME: set-position! #f ;;; FIXME: set-position!
#f
#f)]) #f)])
(values (values
p p
@ -392,6 +407,7 @@
c) c)
#f ;;; FIXME: get-position #f ;;; FIXME: get-position
#f ;;; FIXME: set-position! #f ;;; FIXME: set-position!
#f
#f)]) #f)])
(values (values
p p
@ -426,7 +442,7 @@
#f ;;; FIXME: get-position #f ;;; FIXME: get-position
#f ;;; FIXME: set-position! #f ;;; FIXME: set-position!
#f ;;; close #f ;;; close
)) #f))
(define (transcoded-port p transcoder) (define (transcoded-port p transcoder)
@ -439,25 +455,27 @@
[write! ($port-write! p)] [write! ($port-write! p)]
[closed? ($port-closed? p)]) [closed? ($port-closed? p)])
($set-port-closed?! p #t) ($set-port-closed?! p #t)
($make-port (guarded-port
($port-index p) ($make-port
($port-size p) ($port-index p)
($port-buffer p) ($port-size p)
($port-base-index p) ($port-buffer p)
transcoder ($port-base-index p)
closed? transcoder
(cond closed?
[read! (input-transcoder-attrs transcoder)] (cond
[write! (output-transcoder-attrs transcoder)] [read! (input-transcoder-attrs transcoder)]
[else [write! (output-transcoder-attrs transcoder)]
(error 'transcoded-port [else
"port is neither input nor output!")]) (error 'transcoded-port
($port-id p) "port is neither input nor output!")])
read! ($port-id p)
write! read!
($port-get-position p) write!
($port-set-position! p) ($port-get-position p)
($port-close p)))) ($port-set-position! p)
($port-close p)
($port-cookie p)))))
(define (reset-input-port! p) (define (reset-input-port! p)
(if (input-port? p) (if (input-port? p)
@ -1042,48 +1060,52 @@
(define file-buffer-size (+ read-size 128)) (define file-buffer-size (+ read-size 128))
(define (fh->input-port fd id size transcoder close?) (define (fh->input-port fd id size transcoder close?)
($make-port 0 0 (make-bytevector size) 0 (guarded-port
transcoder ($make-port 0 0 (make-bytevector size) 0
#f ;;; closed? transcoder
(input-transcoder-attrs transcoder) #f ;;; closed?
id (input-transcoder-attrs transcoder)
(lambda (bv idx cnt) id
(let ([bytes (lambda (bv idx cnt)
(foreign-call "ikrt_read_fd" fd bv idx (let ([bytes
(fxmin read-size cnt))]) (foreign-call "ikrt_read_fd" fd bv idx
(when (fx< bytes 0) (io-error 'read id bytes)) (fxmin read-size cnt))])
bytes)) (when (fx< bytes 0) (io-error 'read id bytes))
#f ;;; write! bytes))
#f ;;; get-position #f ;;; write!
#f ;;; set-position! #f ;;; get-position
(and close? #f ;;; set-position!
(lambda () (and close?
(cond (lambda ()
[(foreign-call "ikrt_close_fd" fd) => (cond
(lambda (err) [(foreign-call "ikrt_close_fd" fd) =>
(io-error 'close id err))]))))) (lambda (err)
(io-error 'close id err))])))
fd)))
(define (fh->output-port fd id size transcoder close?) (define (fh->output-port fd id size transcoder close?)
($make-port 0 size (make-bytevector size) 0 (guarded-port
transcoder ($make-port 0 size (make-bytevector size) 0
#f ;;; closed? transcoder
(output-transcoder-attrs transcoder) #f ;;; closed?
id (output-transcoder-attrs transcoder)
#f id
(lambda (bv idx cnt) #f
(let ([bytes (lambda (bv idx cnt)
(foreign-call "ikrt_write_fd" fd bv idx (let ([bytes
(fxmin read-size cnt))]) (foreign-call "ikrt_write_fd" fd bv idx
(when (fx< bytes 0) (io-error 'write id bytes)) (fxmin read-size cnt))])
bytes)) (when (fx< bytes 0) (io-error 'write id bytes))
#f ;;; get-position bytes))
#f ;;; set-position! #f ;;; get-position
(and close? #f ;;; set-position!
(lambda () (and close?
(cond (lambda ()
[(foreign-call "ikrt_close_fd" fd) => (cond
(lambda (err) [(foreign-call "ikrt_close_fd" fd) =>
(io-error 'close id err))]))))) (lambda (err)
(io-error 'close id err))])))
fd)))
(define (open-input-file-handle filename who) (define (open-input-file-handle filename who)
(let ([fh (foreign-call "ikrt_open_input_fd" (let ([fh (foreign-call "ikrt_open_input_fd"

2
scheme/last-revision
View File

@ -1 +1 @@
1223 1225