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)
(export
input-port? output-port? textual-port? binary-port?
open-file-input-port standard-input-port current-input-port
port? input-port? output-port? textual-port? binary-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-string-input-port
make-custom-binary-input-port
transcoded-port port-transcoder
close-port
close-port close-input-port close-output-port
port-eof?
get-char lookahead-char read-char peek-char
get-string-n get-string-n! get-string-all get-line
get-u8 lookahead-u8
get-bytevector-n get-bytevector-n!
get-bytevector-some get-bytevector-all
port-has-port-position? port-position
port-has-set-port-position!? set-port-position!
;port-has-port-position? port-position
;port-has-set-port-position!? set-port-position!
call-with-port
flush-output-port
)
(import
(except (ikarus)
input-port? output-port? textual-port? binary-port?
open-file-input-port standard-input-port current-input-port
port? input-port? output-port? textual-port? binary-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-string-input-port
make-custom-binary-input-port
transcoded-port port-transcoder
close-port
close-port close-input-port close-output-port
port-eof?
get-char lookahead-char read-char peek-char
get-string-n get-string-n! get-string-all get-line
get-u8 lookahead-u8
get-bytevector-n get-bytevector-n!
get-bytevector-some get-bytevector-all
port-has-port-position? port-position
port-has-set-port-position!? set-port-position!
;port-has-port-position? port-position
;port-has-set-port-position!? set-port-position!
call-with-port
flush-output-port
))
(define-syntax define-rrr
@ -50,6 +56,7 @@
(define-struct $port
(index size buffer base-index transcoder closed? attrs
id read! write! get-position set-position! close))
(define port? $port?)
(define $set-port-index! set-$port-index!)
(define $set-port-size! set-$port-size!)
(define $set-port-attrs! set-$port-attrs!)
@ -206,10 +213,25 @@
(and (transcoder? tr) tr))
(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
[(not ($port? p))
(error 'close-port "not a port" p)]
[($port-closed? p) (void)]
[else
(when ($port-write! p)
@ -219,10 +241,25 @@
(when (procedure? close)
(close)))]))
(define-rrr port-has-port-position?)
(define-rrr port-position)
(define-rrr port-has-set-port-position!?)
(define-rrr set-port-position!)
(define (close-port p)
(unless ($port? p)
(error 'close-port "not a port" p))
($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)
@ -502,7 +539,6 @@
(eof-object? (advance-bom p who '(#xEF #xBB #xBF)))]
[else (error 'slow-get-char "codec not handled")])))
(define-rrr slow-lookahead-char)
(define (lookahead-char-char-mode p who)
(let ([str ($port-buffer p)]
[read! ($port-read! p)])
@ -741,15 +777,86 @@
(lambda (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)
(fh->input-port 0 '*stdin* 256 #f #f))
(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)
(if ($port? p)
@ -763,7 +870,7 @@
(define read-char
(case-lambda
[() (get-char *the-input-port*)]
[() (get-char (*the-input-port*))]
[(p)
(if (input-port? p)
(if (textual-port? p)
@ -773,7 +880,7 @@
;;;
(define peek-char
(case-lambda
[() (lookahead-char *the-input-port*)]
[() (lookahead-char (*the-input-port*))]
[(p)
(if (input-port? p)
(if (textual-port? p)
@ -781,7 +888,6 @@
(error 'peek-char "not a textual port" p))
(error 'peek-char "not an input-port" p))]))
(define (get-bytevector-n p n)
(import (ikarus system $fx) (ikarus system $bytevectors))
(define (subbytevector s n)
@ -817,7 +923,6 @@
[($fx= n 0) '#vu8()]
[else (error 'get-bytevector-n "count is negative" n)]))
(define (get-bytevector-n! p s i c)
(import (ikarus system $fx) (ikarus system $bytevectors))
(unless (input-port? p)

56
lab/io-test.ss
View File

@ -7,7 +7,9 @@
input-port? open-string-input-port output-port?
standard-input-port current-input-port
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))
@ -368,29 +370,41 @@
(make-utf8-string-range4))))
(display "now write something on the keyboard ...\n")
(printf "you typed ~s\n"
(list->string
(let ([p (standard-input-port)])
(let f ()
(let ([x (get-u8 p)])
(define (run-interactive-tests)
(display "now write something on the keyboard ...\n")
(printf "you typed ~s\n"
(list->string
(let ([p (standard-input-port)])
(let f ()
(let ([x (get-u8 p)])
(if (eof-object? x)
'()
(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)
'()
(cons (integer->char x) (f))))))))
i
(f (+ i 1))))))))
(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))))))))
(assert (= (file-size "SRFI-1.ss") 56573))
;(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)
(export read-char peek-char write-char write-byte
put-u8 put-char put-string put-bytevector
get-char get-u8 lookahead-u8
get-string-n get-string-n!
get-bytevector-n get-bytevector-n!
newline port-name input-port-name output-port-name
close-input-port reset-input-port! close-port
flush-output-port close-output-port get-line)
(export read-char ; ok
peek-char ; ok
write-char
write-byte
put-u8
put-char
put-string
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
(ikarus system $io)
(ikarus system $fx)

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

@ -15,10 +15,17 @@
(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
$reset-input-port! $flush-output-port
$close-input-port $close-output-port)
$reset-input-port!
$flush-output-port
$close-input-port
$close-output-port
)
(import
(ikarus)
(ikarus system $ports)

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

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

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

@ -15,7 +15,7 @@
(library (ikarus io input-strings)
(export open-input-string open-string-input-port with-input-from-string)
(export open-string-input-port)
(import
(ikarus system $strings)
(ikarus system $bytevectors)
@ -23,9 +23,7 @@
(ikarus system $pairs)
(ikarus system $ports)
(ikarus system $io)
(except (ikarus)
open-input-string open-string-input-port
with-input-from-string))
(except (ikarus) open-string-input-port ))
(define-syntax message-case
(syntax-rules (else)
@ -82,11 +80,11 @@
'#vu8())])
port))
(define open-input-string
(lambda (str)
(unless (string? str)
(error 'open-input-string "not a string" str))
($open-input-string str)))
;(define open-input-string
; (lambda (str)
; (unless (string? str)
; (error 'open-input-string "not a string" str))
; ($open-input-string str)))
(define open-string-input-port
(lambda (str)
@ -94,15 +92,15 @@
(error 'open-string-input-port "not a string" str))
($open-input-string str)))
(define with-input-from-string
(lambda (str proc)
(unless (string? str)
(error 'with-input-from-string "not a string" str))
(unless (procedure? proc)
(error 'with-input-from-string "not a procedure" proc))
(let ([p (open-input-string str)])
(parameterize ([current-input-port p])
(proc)))))
;(define with-input-from-string
; (lambda (str proc)
; (unless (string? str)
; (error 'with-input-from-string "not a string" str))
; (unless (procedure? proc)
; (error 'with-input-from-string "not a procedure" proc))
; (let ([p ($open-input-string str)])
; (parameterize ([current-input-port p])
; (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]
[port-mode i]
[set-port-mode! i]
[with-input-from-string i]
;[with-input-from-string i]
[open-output-string i]
[open-output-bytevector i]
[open-input-string i]
;[open-input-string i]
[get-output-string i]
[get-output-bytevector 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
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){
return fix(fh);
} else {