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

reimplemented open-output-file.

This commit is contained in:
Abdulaziz Ghuloum 2007-12-10 10:18:52 -05:00
parent 921999a3a2
commit 2ac39cfad0
4 changed files with 68 additions and 52 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

106
scheme/ikarus.io.ss
View File

@ -45,7 +45,7 @@
call-with-string-output-port
standard-output-port standard-error-port
current-output-port current-error-port
open-file-output-port
open-file-output-port open-output-file
console-output-port
console-error-port
console-input-port
@ -54,6 +54,7 @@
output-port-name
port-mode set-port-mode!
reset-input-port!
port-id
)
@ -87,7 +88,7 @@
call-with-string-output-port
standard-output-port standard-error-port
current-output-port current-error-port
open-file-output-port
open-file-output-port open-output-file
console-output-port
console-input-port
console-error-port
@ -96,6 +97,7 @@
output-port-name
port-mode set-port-mode!
reset-input-port!
port-id
))
(define-syntax define-rrr
@ -114,6 +116,52 @@
(define $set-port-closed?! set-$port-closed?!)
(define $make-port make-$port)
(define ($port-get-mode x)
(and ($port? x) (fxand ($port-attrs x) fast-get-mask)))
(define ($port-put-mode x)
(and ($port? x) (fxand ($port-attrs x) fast-put-mask)))
(define (u8? x)
(and (fixnum? x) (fx>= x 0) (fx< x 256)))
(define (textual-port? p)
(and ($port? p)
($port-transcoder p)
#t))
(define (binary-port? p)
(and ($port? p)
(not ($port-transcoder p))))
(define (output-port? p)
(and ($port? p)
($port-write! p)
#t))
(define (input-port? p)
(and ($port? p)
($port-read! p)
#t))
(define (input-port-name p)
(if (input-port? p)
($port-id p)
(error 'input-port-name "not an input port" p)))
(define (output-port-name p)
(if (output-port? p)
($port-id p)
(error 'output-port-name "not an output port" p)))
(define (port-id p)
(if (port? p)
($port-id p)
(error 'port-id "not a port" p)))
;;; everything above this line will turn into primitive
;;; ----------------------------------------------------------
(define fast-get-tag #x0001)
(define fast-put-tag #x0002)
(define fast-get-position-tag #x0004)
@ -132,20 +180,6 @@
(define r6rs-mode-tag #x1000)
(define ($port-get-mode x)
(and ($port? x) (fxand ($port-attrs x) fast-get-mask)))
(define ($port-put-mode x)
(and ($port? x) (fxand ($port-attrs x) fast-put-mask)))
(define (u8? x)
(and (fixnum? x) (fx>= x 0) (fx< x 256)))
;;; everything above this line will turn into primitive
;;; ----------------------------------------------------------
(define ($make-custom-binary-input-port id
read! get-position set-position! close buffer-size)
(let ([bv (make-bytevector buffer-size)])
@ -360,40 +394,11 @@
($port-set-position! p)
($port-close p))))
(define (output-port? p)
(and ($port? p)
($port-write! p)
#t))
(define (input-port? p)
(and ($port? p)
($port-read! p)
#t))
(define (reset-input-port! p)
(if (input-port? p)
($set-port-index! p ($port-size p))
(error 'reset-input-port! "not an input port" p)))
(define (input-port-name p)
(if (input-port? p)
($port-id p)
(error 'input-port-name "not an input port" p)))
(define (output-port-name p)
(if (output-port? p)
($port-id p)
(error 'output-port-name "not an output port" p)))
(define (textual-port? p)
(and ($port? p)
($port-transcoder p)
#t))
(define (binary-port? p)
(and ($port? p)
(not ($port-transcoder p))))
(define (port-transcoder p)
(if ($port? p)
(let ([tr ($port-transcoder p)])
@ -1086,6 +1091,17 @@
transcoder
#t)]))
(define (open-output-file filename)
(unless (string? filename)
(error 'open-output-file "invalid filename" filename))
(fh->output-port
(open-output-file-handle filename (file-options)
'open-input-file)
filename
file-buffer-size
(native-transcoder)
#t))
(define (open-input-file filename)
(unless (string? filename)
(error 'open-input-file "invalid filename" filename))

2
scheme/last-revision
View File

@ -1 +1 @@
1207
1208

2
scheme/makefile.ss
View File

@ -1175,7 +1175,7 @@
[display i r is se]
[newline i r is se]
[open-input-file i r is se]
;[open-output-file i r is se]
[open-output-file i r is se]
[peek-char i r is se]
[read i r is se]
[read-char i r is se]

10
scheme/todo-r6rs.ss
View File

@ -510,13 +510,13 @@
[with-exception-handler C ex]
[guard C ex]
;;;
[binary-port? S ip]
[binary-port? C ip]
[buffer-mode C ip]
[buffer-mode? C ip]
[bytevector->string S ip]
[call-with-bytevector-output-port S ip]
[call-with-port S ip]
[call-with-string-output-port S ip]
[call-with-bytevector-output-port C ip]
[call-with-port C ip]
[call-with-string-output-port C ip]
;;;
[assoc C ls se]
[assp C ls]
@ -634,7 +634,7 @@
[open-string-input-port C ip]
[open-string-output-port C ip]
[output-port-buffer-mode S ip]
[port-eof? S ip]
[port-eof? C ip]
[port-has-port-position? S ip]
[port-has-set-port-position!? S ip]
[port-position S ip]