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

stage 1 of new input IO is almost complete.

This commit is contained in:
Abdulaziz Ghuloum 2007-12-09 17:13:09 -05:00
parent 3562a736c5
commit ea96ab85db
9 changed files with 229 additions and 82 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

155
lab/io-spec.ss
View File

@ -2,43 +2,49 @@
(library (io-spec) (library (io-spec)
(export (export
input-port? output-port? textual-port? binary-port? port? input-port? output-port? textual-port? binary-port?
open-file-input-port standard-input-port current-input-port open-file-input-port open-input-file
call-with-input-file with-input-from-file
standard-input-port current-input-port
open-bytevector-input-port open-bytevector-input-port
open-string-input-port open-string-input-port
make-custom-binary-input-port make-custom-binary-input-port
transcoded-port port-transcoder transcoded-port port-transcoder
close-port close-port close-input-port close-output-port
port-eof? port-eof?
get-char lookahead-char read-char peek-char get-char lookahead-char read-char peek-char
get-string-n get-string-n! get-string-all get-line get-string-n get-string-n! get-string-all get-line
get-u8 lookahead-u8 get-u8 lookahead-u8
get-bytevector-n get-bytevector-n! get-bytevector-n get-bytevector-n!
get-bytevector-some get-bytevector-all get-bytevector-some get-bytevector-all
port-has-port-position? port-position ;port-has-port-position? port-position
port-has-set-port-position!? set-port-position! ;port-has-set-port-position!? set-port-position!
call-with-port call-with-port
flush-output-port
) )
(import (import
(except (ikarus) (except (ikarus)
input-port? output-port? textual-port? binary-port? port? input-port? output-port? textual-port? binary-port?
open-file-input-port standard-input-port current-input-port open-file-input-port open-input-file
call-with-input-file with-input-from-file
standard-input-port current-input-port
open-bytevector-input-port open-bytevector-input-port
open-string-input-port open-string-input-port
make-custom-binary-input-port make-custom-binary-input-port
transcoded-port port-transcoder transcoded-port port-transcoder
close-port close-port close-input-port close-output-port
port-eof? port-eof?
get-char lookahead-char read-char peek-char get-char lookahead-char read-char peek-char
get-string-n get-string-n! get-string-all get-line get-string-n get-string-n! get-string-all get-line
get-u8 lookahead-u8 get-u8 lookahead-u8
get-bytevector-n get-bytevector-n! get-bytevector-n get-bytevector-n!
get-bytevector-some get-bytevector-all get-bytevector-some get-bytevector-all
port-has-port-position? port-position ;port-has-port-position? port-position
port-has-set-port-position!? set-port-position! ;port-has-set-port-position!? set-port-position!
call-with-port call-with-port
flush-output-port
)) ))
(define-syntax define-rrr (define-syntax define-rrr
@ -50,6 +56,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))
(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!)
@ -206,10 +213,25 @@
(and (transcoder? tr) tr)) (and (transcoder? tr) tr))
(error 'port-transcoder "not a port" p))) (error 'port-transcoder "not a port" p)))
(define (close-port p) (define (flush-output-port p)
(unless (output-port? p)
(error 'flush-output-port "not an output port" p))
(when ($port-closed? p)
(error 'flush-output-port "port is closed" p))
(let ([idx ($port-index p)] [size ($port-size p)])
(unless (fx= idx size)
(let ([cnt (fx- size idx)])
(let ([bytes (($port-write! p) ($port-buffer p) idx cnt)])
(unless (and (fixnum? bytes) (fx>= bytes 0) (fx<= bytes cnt))
(error 'flush-output-port
"write! returned an invalid value"
bytes))
($set-port-index! p (fx+ idx bytes))
(unless (fx= bytes cnt)
(flush-output-port p)))))))
(define ($close-port p)
(cond (cond
[(not ($port? p))
(error 'close-port "not a port" p)]
[($port-closed? p) (void)] [($port-closed? p) (void)]
[else [else
(when ($port-write! p) (when ($port-write! p)
@ -219,10 +241,25 @@
(when (procedure? close) (when (procedure? close)
(close)))])) (close)))]))
(define-rrr port-has-port-position?) (define (close-port p)
(define-rrr port-position) (unless ($port? p)
(define-rrr port-has-set-port-position!?) (error 'close-port "not a port" p))
(define-rrr set-port-position!) ($close-port p))
(define (close-input-port p)
(unless (input-port? p)
(error 'close-input-port "not an input port" p))
($close-port p))
(define (close-output-port p)
(unless (output-port? p)
(error 'close-output-port "not an output port" p))
($close-port p))
;(define-rrr port-has-port-position?)
;(define-rrr port-position)
;(define-rrr port-has-set-port-position!?)
;(define-rrr set-port-position!)
;;; ---------------------------------------------------------- ;;; ----------------------------------------------------------
(module (get-char lookahead-char) (module (get-char lookahead-char)
@ -502,7 +539,6 @@
(eof-object? (advance-bom p who '(#xEF #xBB #xBF)))] (eof-object? (advance-bom p who '(#xEF #xBB #xBF)))]
[else (error 'slow-get-char "codec not handled")]))) [else (error 'slow-get-char "codec not handled")])))
(define-rrr slow-lookahead-char)
(define (lookahead-char-char-mode p who) (define (lookahead-char-char-mode p who)
(let ([str ($port-buffer p)] (let ([str ($port-buffer p)]
[read! ($port-read! p)]) [read! ($port-read! p)])
@ -741,15 +777,86 @@
(lambda (err) (lambda (err)
(io-error 'close id err))]))))) (io-error 'close id err))])))))
(define-rrr open-file-input-port) (define (open-file-handle filename who)
(let ([fh (foreign-call "ikrt_open_input_fd"
(string->utf8 filename))])
(cond
[(fx< fh 0) (io-error who filename fh)]
[else fh])))
(define open-file-input-port
(case-lambda
[(filename)
(open-file-input-port filename (file-options) 'block #f)]
[(filename file-options)
(open-file-input-port filename file-options 'block #f)]
[(filename file-options buffer-mode)
(open-file-input-port filename file-options buffer-mode #f)]
[(filename file-options buffer-mode transcoder)
(unless (string? filename)
(error 'open-file-input-port "invalid filename" filename))
; FIXME: file-options ignored
; FIXME: buffer-mode ignored
(fh->input-port
(open-file-handle filename 'open-file-input-port)
filename
file-buffer-size
(cond
[(or (not transcoder) (transcoder? transcoder))
transcoder]
[else (error 'open-file-input-port
"invalid transcoder"
transcoder)])
#t)]))
(define (open-input-file filename)
(unless (string? filename)
(error 'open-input-file "invalid filename" filename))
(fh->input-port
(open-file-handle filename 'open-input-file)
filename
file-buffer-size
(native-transcoder)
#t))
(define (call-with-input-file filename proc)
(unless (string? filename)
(error 'call-with-input-file "invalid filename" filename))
(unless (procedure? proc)
(error 'call-with-input-file "not a procedure" proc))
(call-with-port
(fh->input-port
(open-file-handle filename 'call-with-input-file)
filename
file-buffer-size
(native-transcoder)
#t)
proc))
(define (with-input-from-file filename proc)
(unless (string? filename)
(error 'with-input-from-file "invalid filename" filename))
(unless (procedure? proc)
(error 'with-input-from-file "not a procedure" proc))
(let ([p
(fh->input-port
(open-file-handle filename 'with-input-from-file)
filename
file-buffer-size
(native-transcoder)
#t)])
(parameterize ([*the-input-port* p])
(proc))))
(define (standard-input-port) (define (standard-input-port)
(fh->input-port 0 '*stdin* 256 #f #f)) (fh->input-port 0 '*stdin* 256 #f #f))
(define *the-input-port* (define *the-input-port*
(transcoded-port (standard-input-port) (native-transcoder))) (make-parameter
(transcoded-port (standard-input-port) (native-transcoder))))
(define (current-input-port) *the-input-port*) (define (current-input-port) (*the-input-port*))
(define (call-with-port p proc) (define (call-with-port p proc)
(if ($port? p) (if ($port? p)
@ -763,7 +870,7 @@
(define read-char (define read-char
(case-lambda (case-lambda
[() (get-char *the-input-port*)] [() (get-char (*the-input-port*))]
[(p) [(p)
(if (input-port? p) (if (input-port? p)
(if (textual-port? p) (if (textual-port? p)
@ -773,14 +880,13 @@
;;; ;;;
(define peek-char (define peek-char
(case-lambda (case-lambda
[() (lookahead-char *the-input-port*)] [() (lookahead-char (*the-input-port*))]
[(p) [(p)
(if (input-port? p) (if (input-port? p)
(if (textual-port? p) (if (textual-port? p)
(lookahead-char p) (lookahead-char p)
(error 'peek-char "not a textual port" p)) (error 'peek-char "not a textual port" p))
(error 'peek-char "not an input-port" p))])) (error 'peek-char "not an input-port" p))]))
(define (get-bytevector-n p n) (define (get-bytevector-n p n)
(import (ikarus system $fx) (ikarus system $bytevectors)) (import (ikarus system $fx) (ikarus system $bytevectors))
@ -817,7 +923,6 @@
[($fx= n 0) '#vu8()] [($fx= n 0) '#vu8()]
[else (error 'get-bytevector-n "count is negative" n)])) [else (error 'get-bytevector-n "count is negative" n)]))
(define (get-bytevector-n! p s i c) (define (get-bytevector-n! p s i c)
(import (ikarus system $fx) (ikarus system $bytevectors)) (import (ikarus system $fx) (ikarus system $bytevectors))
(unless (input-port? p) (unless (input-port? p)

58
lab/io-test.ss
View File

@ -7,7 +7,9 @@
input-port? open-string-input-port output-port? input-port? open-string-input-port output-port?
standard-input-port current-input-port standard-input-port current-input-port
get-bytevector-n get-bytevector-n! get-bytevector-n get-bytevector-n!
get-string-n get-string-n! get-line) get-string-n get-string-n! get-line port?
close-input-port close-output-port flush-output-port
open-input-file call-with-input-file with-input-from-file)
(io-spec)) (io-spec))
@ -368,29 +370,41 @@
(make-utf8-string-range4)))) (make-utf8-string-range4))))
(display "now write something on the keyboard ...\n") (define (run-interactive-tests)
(printf "you typed ~s\n" (display "now write something on the keyboard ...\n")
(list->string (printf "you typed ~s\n"
(let ([p (standard-input-port)]) (list->string
(let f () (let ([p (standard-input-port)])
(let ([x (get-u8 p)]) (let f ()
(if (eof-object? x) (let ([x (get-u8 p)])
'() (if (eof-object? x)
(cons (integer->char x) (f)))))))) '()
(cons (integer->char x) (f))))))))
(display "let's do it again ...\n")
(printf "you typed ~s\n"
(list->string
(let ([p (transcoded-port (standard-input-port)
(make-transcoder (utf-8-codec)))])
(let f ()
(let ([x (get-char p)])
(if (eof-object? x)
'()
(cons x (f)))))))))
(define (file-size filename)
(with-input-from-file filename
(lambda ()
(let f ([i 0])
(let ([x (get-char (current-input-port))])
(if (eof-object? x)
i
(f (+ i 1))))))))
(display "let's do it again ...\n") (assert (= (file-size "SRFI-1.ss") 56573))
(printf "you typed ~s\n"
(list->string
(let ([p (transcoded-port (standard-input-port)
(make-transcoder (utf-8-codec)))])
(let f ()
(let ([x (get-char p)])
(if (eof-object? x)
'()
(cons x (f))))))))
;(run-exhaustive-tests)
;(run-interactive-tests)
(run-exhaustive-tests)

34
scheme/ikarus.io-primitives.ss
View File

@ -15,14 +15,32 @@
(library (ikarus io-primitives) (library (ikarus io-primitives)
(export read-char peek-char write-char write-byte (export read-char ; ok
put-u8 put-char put-string put-bytevector peek-char ; ok
get-char get-u8 lookahead-u8 write-char
get-string-n get-string-n! write-byte
get-bytevector-n get-bytevector-n! put-u8
newline port-name input-port-name output-port-name put-char
close-input-port reset-input-port! close-port put-string
flush-output-port close-output-port get-line) put-bytevector
get-char ; ok
get-u8 ; ok
lookahead-u8 ; ok
get-string-n ; ok
get-string-n! ; ok
get-bytevector-n ; ok
get-bytevector-n! ; ok
newline ; ok
port-name
input-port-name
output-port-name
close-input-port
reset-input-port!
close-port
flush-output-port
close-output-port
get-line ; ok
)
(import (import
(ikarus system $io) (ikarus system $io)
(ikarus system $fx) (ikarus system $fx)

13
scheme/ikarus.io-primitives.unsafe.ss
View File

@ -15,10 +15,17 @@
(library (ikarus io-primitives unsafe) (library (ikarus io-primitives unsafe)
(export $write-char $write-byte $read-char $get-u8 $lookahead-u8 (export $write-char
$write-byte
$read-char
$get-u8
$lookahead-u8
$peek-char $peek-char
$reset-input-port! $flush-output-port $reset-input-port!
$close-input-port $close-output-port) $flush-output-port
$close-input-port
$close-output-port
)
(import (import
(ikarus) (ikarus)
(ikarus system $ports) (ikarus system $ports)

9
scheme/ikarus.io.input-files.ss
View File

@ -15,8 +15,13 @@
(library (ikarus io input-files) (library (ikarus io input-files)
(export open-input-file current-input-port console-input-port (export open-input-file
standard-input-port with-input-from-file call-with-input-file) current-input-port ; ok?
console-input-port
standard-input-port ; ok
with-input-from-file
call-with-input-file
)
(import (import
(ikarus system $ports) (ikarus system $ports)
(ikarus system $io) (ikarus system $io)

34
scheme/ikarus.io.input-strings.ss
View File

@ -15,7 +15,7 @@
(library (ikarus io input-strings) (library (ikarus io input-strings)
(export open-input-string open-string-input-port with-input-from-string) (export open-string-input-port)
(import (import
(ikarus system $strings) (ikarus system $strings)
(ikarus system $bytevectors) (ikarus system $bytevectors)
@ -23,9 +23,7 @@
(ikarus system $pairs) (ikarus system $pairs)
(ikarus system $ports) (ikarus system $ports)
(ikarus system $io) (ikarus system $io)
(except (ikarus) (except (ikarus) open-string-input-port ))
open-input-string open-string-input-port
with-input-from-string))
(define-syntax message-case (define-syntax message-case
(syntax-rules (else) (syntax-rules (else)
@ -82,11 +80,11 @@
'#vu8())]) '#vu8())])
port)) port))
(define open-input-string ;(define open-input-string
(lambda (str) ; (lambda (str)
(unless (string? str) ; (unless (string? str)
(error 'open-input-string "not a string" str)) ; (error 'open-input-string "not a string" str))
($open-input-string str))) ; ($open-input-string str)))
(define open-string-input-port (define open-string-input-port
(lambda (str) (lambda (str)
@ -94,15 +92,15 @@
(error 'open-string-input-port "not a string" str)) (error 'open-string-input-port "not a string" str))
($open-input-string str))) ($open-input-string str)))
(define with-input-from-string ;(define with-input-from-string
(lambda (str proc) ; (lambda (str proc)
(unless (string? str) ; (unless (string? str)
(error 'with-input-from-string "not a string" str)) ; (error 'with-input-from-string "not a string" str))
(unless (procedure? proc) ; (unless (procedure? proc)
(error 'with-input-from-string "not a procedure" proc)) ; (error 'with-input-from-string "not a procedure" proc))
(let ([p (open-input-string str)]) ; (let ([p ($open-input-string str)])
(parameterize ([current-input-port p]) ; (parameterize ([current-input-port p])
(proc))))) ; (proc)))))
) )

2
scheme/last-revision
View File

@ -1 +1 @@
1201 1202

4
scheme/makefile.ss
View File

@ -342,10 +342,10 @@
[output-port-name i] [output-port-name i]
[port-mode i] [port-mode i]
[set-port-mode! i] [set-port-mode! i]
[with-input-from-string i] ;[with-input-from-string i]
[open-output-string i] [open-output-string i]
[open-output-bytevector i] [open-output-bytevector i]
[open-input-string i] ;[open-input-string i]
[get-output-string i] [get-output-string i]
[get-output-bytevector i] [get-output-bytevector i]
[with-output-to-string i] [with-output-to-string i]

2
src/ikarus-io.c
View File

@ -47,7 +47,7 @@ ikrt_close_fd(ikp fd, ikpcb* pcb){
ikp ikp
ikrt_open_input_fd(ikp fn, ikpcb* pcb){ ikrt_open_input_fd(ikp fn, ikpcb* pcb){
int fh = open((char*)(fn+off_bytevector_data, O_RDONLY), 0); int fh = open((char*)(fn+off_bytevector_data), O_RDONLY, 0);
if(fh > 0){ if(fh > 0){
return fix(fh); return fix(fh);
} else { } else {