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

removed "closed?" field from port struct.

This commit is contained in:
Abdulaziz Ghuloum 2007-12-12 19:34:28 -05:00
parent c659cd3ed6
commit cef06e3121
2 changed files with 39 additions and 37 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

74
scheme/ikarus.io.ss
View File

@ -15,20 +15,19 @@
(library (ikarus system $io) (library (ikarus system $io)
(export $make-port $port-tag $port-id $port-cookie (export $make-port $port-tag $port-id $port-cookie
port? $port-closed? $port-transcoder $set-port-closed?! port? $port-transcoder
$port-index $port-size $port-buffer $port-base-index $port-index $port-size $port-buffer $port-base-index
$port-get-position $port-set-position! $port-close $port-get-position $port-set-position! $port-close
$port-read! $port-write! $set-port-index! $set-port-size! $port-read! $port-write! $set-port-index! $set-port-size!
$port-attrs $set-port-attrs! $port-fast-attrs) $port-attrs $set-port-attrs! $port-fast-attrs)
(import (except (ikarus) port?)) (import (except (ikarus) port?))
(define-struct $port (define-struct $port
(attrs index size buffer base-index transcoder closed? (attrs index size buffer base-index transcoder
id read! write! get-position set-position! close cookie)) 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!)
(define $set-port-attrs! set-$port-attrs!) (define $set-port-attrs! set-$port-attrs!)
(define $set-port-closed?! set-$port-closed?!)
(define $make-port make-$port) (define $make-port make-$port)
(define fast-attrs-mask #b01111111) (define fast-attrs-mask #b01111111)
(define ($port-tag x) (if ($port? x) ($port-attrs x) 0)) (define ($port-tag x) (if ($port? x) ($port-attrs x) 0))
@ -151,29 +150,31 @@
;;; everything above this line will turn into primitive ;;; everything above this line will turn into primitive
;;; ---------------------------------------------------------- ;;; ----------------------------------------------------------
(define input-port-tag #b00000001) (define input-port-tag #b000000001)
(define output-port-tag #b00000010) (define output-port-tag #b000000010)
(define textual-port-tag #b00000100) (define textual-port-tag #b000000100)
(define binary-port-tag #b00001000) (define binary-port-tag #b000001000)
(define fast-char-text-tag #b00010000) (define fast-char-text-tag #b000010000)
(define fast-u7-text-tag #b00100000) (define fast-u7-text-tag #b000100000)
(define fast-u8-text-tag #b01100000) (define fast-u8-text-tag #b001100000)
(define r6rs-mode-tag #b10000000) (define r6rs-mode-tag #b010000000)
(define closed-port-tag #b100000000)
(define binary-input-port-bits #b00001001) (define port-type-mask #b000001111)
(define binary-output-port-bits #b00001010) (define binary-input-port-bits #b000001001)
(define textual-input-port-bits #b00000101) (define binary-output-port-bits #b000001010)
(define textual-output-port-bits #b00000110) (define textual-input-port-bits #b000000101)
(define textual-output-port-bits #b000000110)
(define fast-get-byte-tag #b00001001) (define fast-get-byte-tag #b000001001)
(define fast-get-char-tag #b00010101) (define fast-get-char-tag #b000010101)
(define fast-get-utf8-tag #b00100101) (define fast-get-utf8-tag #b000100101)
(define fast-get-latin-tag #b01100101) (define fast-get-latin-tag #b001100101)
(define fast-put-byte-tag #b00001010) (define fast-put-byte-tag #b000001010)
(define fast-put-char-tag #b00010110) (define fast-put-char-tag #b000010110)
(define fast-put-utf8-tag #b00100110) (define fast-put-utf8-tag #b000100110)
(define fast-put-latin-tag #b01100110) (define fast-put-latin-tag #b001100110)
(define (input-port-name p) (define (input-port-name p)
(if (input-port? p) (if (input-port? p)
@ -207,13 +208,13 @@
(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 attrs 0 init-size bv 0 #f #f id read! write! get-position ($make-port attrs 0 init-size bv 0 #f id read! write! get-position
set-position! close #f))) 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 attrs 0 init-size bv 0 #t #f id read! write! get-position ($make-port attrs 0 init-size bv 0 #t id read! write! get-position
set-position! close #f))) set-position! close #f)))
(define (make-custom-binary-input-port id (define (make-custom-binary-input-port id
@ -318,7 +319,6 @@
(input-transcoder-attrs maybe-transcoder) (input-transcoder-attrs maybe-transcoder)
0 (bytevector-length bv) bv 0 0 (bytevector-length bv) bv 0
maybe-transcoder maybe-transcoder
#f ;;; closed?
"*bytevector-input-port*" "*bytevector-input-port*"
(lambda (bv i c) 0) ;;; read! (lambda (bv i c) 0) ;;; read!
#f ;;; write! #f ;;; write!
@ -340,7 +340,6 @@
(output-transcoder-attrs transcoder) (output-transcoder-attrs transcoder)
0 buffer-size (make-bytevector buffer-size) 0 0 buffer-size (make-bytevector buffer-size) 0
transcoder transcoder
#f
"*bytevector-output-port*" "*bytevector-output-port*"
#f #f
(lambda (bv i c) (lambda (bv i c)
@ -403,7 +402,6 @@
(fxior textual-output-port-bits fast-char-text-tag) (fxior textual-output-port-bits fast-char-text-tag)
0 buffer-size (make-string buffer-size) 0 0 buffer-size (make-string buffer-size) 0
#t ;;; transcoder #t ;;; transcoder
#f
"*string-output-port*" "*string-output-port*"
#f #f
(lambda (str i c) (lambda (str i c)
@ -443,7 +441,6 @@
(fxior textual-input-port-bits fast-char-text-tag) (fxior textual-input-port-bits fast-char-text-tag)
0 (string-length str) str 0 0 (string-length str) str 0
#t ;;; transcoder #t ;;; transcoder
#f ;;; closed?
"*string-input-port*" "*string-input-port*"
(lambda (str i c) 0) ;;; read! (lambda (str i c) 0) ;;; read!
#f ;;; write! #f ;;; write!
@ -459,10 +456,10 @@
(error who "not a transcoder" transcoder)) (error who "not a transcoder" transcoder))
(unless (port? p) (error who "not a port" p)) (unless (port? p) (error who "not a port" p))
(when ($port-transcoder p) (error who "not a binary port" p)) (when ($port-transcoder p) (error who "not a binary port" p))
(when ($port-closed? p) (error who "cannot transcode closed port" p))
(let ([read! ($port-read! p)] (let ([read! ($port-read! p)]
[write! ($port-write! p)] [write! ($port-write! p)])
[closed? ($port-closed? p)]) ($mark-port-closed! p)
($set-port-closed?! p #t)
(guarded-port (guarded-port
($make-port ($make-port
(cond (cond
@ -476,7 +473,6 @@
($port-buffer p) ($port-buffer p)
($port-base-index p) ($port-base-index p)
transcoder transcoder
closed?
($port-id p) ($port-id p)
read! read!
write! write!
@ -496,6 +492,14 @@
(and (transcoder? tr) tr)) (and (transcoder? tr) tr))
(error 'port-transcoder "not a port" p))) (error 'port-transcoder "not a port" p)))
(define ($port-closed? p)
(not (fxzero? (fxand ($port-attrs p) closed-port-tag))))
(define ($mark-port-closed! p)
($set-port-attrs! p
(fxior closed-port-tag
(fxand ($port-attrs p) port-type-mask))))
(define (port-mode p) (define (port-mode p)
(if (port? p) (if (port? p)
(if (fxzero? (fxand ($port-attrs p) r6rs-mode-tag)) (if (fxzero? (fxand ($port-attrs p) r6rs-mode-tag))
@ -548,7 +552,7 @@
[else [else
(when ($port-write! p) (when ($port-write! p)
(flush-output-port p)) (flush-output-port p))
($set-port-closed?! p #t) ($mark-port-closed! p)
(let ([close ($port-close p)]) (let ([close ($port-close p)])
(when (procedure? close) (when (procedure? close)
(close)))])) (close)))]))
@ -1073,7 +1077,6 @@
(input-transcoder-attrs transcoder) (input-transcoder-attrs transcoder)
0 0 (make-bytevector size) 0 0 0 (make-bytevector size) 0
transcoder transcoder
#f ;;; closed?
id id
(lambda (bv idx cnt) (lambda (bv idx cnt)
(let ([bytes (let ([bytes
@ -1098,7 +1101,6 @@
(output-transcoder-attrs transcoder) (output-transcoder-attrs transcoder)
0 size (make-bytevector size) 0 0 size (make-bytevector size) 0
transcoder transcoder
#f ;;; closed?
id id
#f #f
(lambda (bv idx cnt) (lambda (bv idx cnt)

2
scheme/last-revision
View File

@ -1 +1 @@
1228 1229