Working on converting io backends to use inheritance

db4
Slava Pestov 2008-04-11 14:09:09 -05:00
parent dc87e64387
commit 1435d1c189
12 changed files with 73 additions and 66 deletions

View File

@ -199,7 +199,7 @@ ARTICLE: "cookbook-io" "Input and output cookbook"
} }
"Convert a file of 4-byte cells from little to big endian or vice versa, by directly mapping it into memory and operating on it with sequence words:" "Convert a file of 4-byte cells from little to big endian or vice versa, by directly mapping it into memory and operating on it with sequence words:"
{ $code { $code
"\"mydata.dat\" dup file-info file-info-length [" "\"mydata.dat\" dup file-info size>> ["
" 4 <sliced-groups> [ reverse-here ] change-each" " 4 <sliced-groups> [ reverse-here ] change-each"
"] with-mapped-file" "] with-mapped-file"
} }

View File

@ -10,7 +10,7 @@ IN: http.server.static
TUPLE: file-responder root hook special ; TUPLE: file-responder root hook special ;
: file-http-date ( filename -- string ) : file-http-date ( filename -- string )
file-info file-info-modified timestamp>http-string ; file-info modified>> timestamp>http-string ;
: last-modified-matches? ( filename -- ? ) : last-modified-matches? ( filename -- ? )
file-http-date dup [ file-http-date dup [
@ -27,7 +27,7 @@ TUPLE: file-responder root hook special ;
[ [
<content> <content>
swap swap
[ file-info file-info-size "content-length" set-header ] [ file-info size>> "content-length" set-header ]
[ file-http-date "last-modified" set-header ] [ file-http-date "last-modified" set-header ]
[ '[ , binary <file-reader> stdio get stream-copy ] >>body ] [ '[ , binary <file-reader> stdio get stream-copy ] >>body ]
tri tri

View File

@ -4,7 +4,7 @@ IN: io.mmap.tests
[ "mmap-test-file.txt" resource-path delete-file ] ignore-errors [ "mmap-test-file.txt" resource-path delete-file ] ignore-errors
[ ] [ "12345" "mmap-test-file.txt" resource-path ascii set-file-contents ] unit-test [ ] [ "12345" "mmap-test-file.txt" resource-path ascii set-file-contents ] unit-test
[ ] [ "mmap-test-file.txt" resource-path dup file-info file-info-size [ CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test [ ] [ "mmap-test-file.txt" resource-path dup file-info size>> [ CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test
[ 5 ] [ "mmap-test-file.txt" resource-path dup file-info file-info-size [ length ] with-mapped-file ] unit-test [ 5 ] [ "mmap-test-file.txt" resource-path dup file-info size>> [ length ] with-mapped-file ] unit-test
[ "22345" ] [ "mmap-test-file.txt" resource-path ascii file-contents ] unit-test [ "22345" ] [ "mmap-test-file.txt" resource-path ascii file-contents ] unit-test
[ "mmap-test-file.txt" resource-path delete-file ] ignore-errors [ "mmap-test-file.txt" resource-path delete-file ] ignore-errors

View File

@ -53,8 +53,8 @@ HELP: init-handle
{ $contract "Prepares a native handle for use by the port; called by " { $link <port> } "." } ; { $contract "Prepares a native handle for use by the port; called by " { $link <port> } "." } ;
HELP: <port> HELP: <port>
{ $values { "handle" "a native handle identifying an I/O resource" } { "buffer" "a " { $link buffer } " or " { $link f } } { "type" symbol } { "port" "a new " { $link port } } } { $values { "handle" "a native handle identifying an I/O resource" } { "type" symbol } { "port" "a new " { $link port } } }
{ $description "Creates a new " { $link port } " using the specified native handle and I/O buffer." } { $description "Creates a new " { $link port } " with no buffer." }
$low-level-note ; $low-level-note ;
HELP: <buffered-port> HELP: <buffered-port>

View File

@ -12,9 +12,10 @@ SYMBOL: default-buffer-size
! Common delegate of native stream readers and writers ! Common delegate of native stream readers and writers
TUPLE: port TUPLE: port
handle handle
buffer
error error
timeout timeout
type eof? ; type eof ;
M: port timeout port-timeout ; M: port timeout port-timeout ;
@ -28,15 +29,14 @@ PREDICATE: output-port < port port-type output-port eq? ;
GENERIC: init-handle ( handle -- ) GENERIC: init-handle ( handle -- )
GENERIC: close-handle ( handle -- ) GENERIC: close-handle ( handle -- )
: <port> ( handle buffer type -- port ) : <port> ( handle type -- port )
pick init-handle { port construct-empty
set-port-handle swap >>type
set-delegate swap dup init-handle >>handle ;
set-port-type
} port construct ;
: <buffered-port> ( handle type -- port ) : <buffered-port> ( handle type -- port )
default-buffer-size get <buffer> swap <port> ; <port>
default-buffer-size get <buffer> >>buffer ;
: <reader> ( handle -- input-port ) : <reader> ( handle -- input-port )
input-port <buffered-port> ; input-port <buffered-port> ;
@ -48,7 +48,7 @@ GENERIC: close-handle ( handle -- )
swap <reader> [ swap <writer> ] [ ] [ dispose drop ] cleanup ; swap <reader> [ swap <writer> ] [ ] [ dispose drop ] cleanup ;
: pending-error ( port -- ) : pending-error ( port -- )
dup port-error f rot set-port-error [ throw ] when* ; [ f ] change-error drop [ throw ] when* ;
HOOK: cancel-io io-backend ( port -- ) HOOK: cancel-io io-backend ( port -- )
@ -59,21 +59,21 @@ M: port timed-out cancel-io ;
GENERIC: (wait-to-read) ( port -- ) GENERIC: (wait-to-read) ( port -- )
: wait-to-read ( count port -- ) : wait-to-read ( count port -- )
tuck buffer-length > [ (wait-to-read) ] [ drop ] if ; tuck buffer>> buffer-length > [ (wait-to-read) ] [ drop ] if ;
: wait-to-read1 ( port -- ) : wait-to-read1 ( port -- )
1 swap wait-to-read ; 1 swap wait-to-read ;
: unless-eof ( port quot -- value ) : unless-eof ( port quot -- value )
>r dup buffer-empty? over port-eof? and >r dup buffer>> buffer-empty? over eof>> and
[ f swap set-port-eof? f ] r> if ; inline [ f >>eof drop f ] r> if ; inline
M: input-port stream-read1 M: input-port stream-read1
dup wait-to-read1 [ buffer-pop ] unless-eof ; dup wait-to-read1 [ buffer>> buffer-pop ] unless-eof ;
: read-step ( count port -- byte-array/f ) : read-step ( count port -- byte-array/f )
[ wait-to-read ] 2keep [ wait-to-read ] 2keep
[ dupd buffer-read ] unless-eof nip ; [ dupd buffer>> buffer-read ] unless-eof nip ;
: read-loop ( count port accum -- ) : read-loop ( count port accum -- )
pick over length - dup 0 > [ pick over length - dup 0 > [
@ -94,55 +94,53 @@ M: input-port stream-read
[ push-all ] keep [ push-all ] keep
[ read-loop ] keep [ read-loop ] keep
B{ } like B{ } like
] [ ] [ 2nip ] if
2nip ] [ 2nip ] if ;
] if
] [
2nip
] if ;
M: input-port stream-read-partial ( max stream -- byte-array/f ) M: input-port stream-read-partial ( max stream -- byte-array/f )
>r 0 max >fixnum r> read-step ; >r 0 max >fixnum r> read-step ;
: can-write? ( len writer -- ? ) : can-write? ( len buffer -- ? )
[ buffer-fill + ] keep buffer-capacity <= ; [ buffer-fill + ] keep buffer-capacity <= ;
: wait-to-write ( len port -- ) : wait-to-write ( len port -- )
tuck can-write? [ drop ] [ stream-flush ] if ; tuck buffer>> can-write? [ drop ] [ stream-flush ] if ;
M: output-port stream-write1 M: output-port stream-write1
1 over wait-to-write byte>buffer ; 1 over wait-to-write
buffer>> byte>buffer ;
M: output-port stream-write M: output-port stream-write
over length over buffer-size > [ over length over buffer>> buffer-size > [
[ buffer-size <groups> ] keep [ buffer>> buffer-size <groups> ]
[ stream-write ] curry each [ [ stream-write ] curry ] bi
each
] [ ] [
over length over wait-to-write >buffer [ >r length r> wait-to-write ]
[ buffer>> >buffer ] 2bi
] if ; ] if ;
GENERIC: port-flush ( port -- ) GENERIC: port-flush ( port -- )
M: output-port stream-flush ( port -- ) M: output-port stream-flush ( port -- )
dup port-flush pending-error ; [ port-flush ] [ pending-error ] bi ;
: close-port ( port type -- ) : close-port ( port type -- )
output-port eq? [ dup port-flush ] when output-port eq? [ dup port-flush ] when
dup cancel-io dup cancel-io
dup port-handle close-handle dup handle>> close-handle
dup delegate [ buffer-free ] when* [ [ buffer-free ] when* f ] change-buffer drop ;
f swap set-delegate ;
M: port dispose M: port dispose
dup port-type closed eq? dup type>> closed eq?
[ drop ] [ drop ]
[ dup port-type >r closed over set-port-type r> close-port ] [ [ closed ] change-type swap close-port ]
if ; if ;
TUPLE: server-port addr client client-addr encoding ; TUPLE: server-port addr client client-addr encoding ;
: <server-port> ( handle addr encoding -- server ) : <server-port> ( handle addr encoding -- server )
rot f server-port <port> rot server-port <port>
{ set-server-port-addr set-server-port-encoding set-delegate } { set-server-port-addr set-server-port-encoding set-delegate }
server-port construct ; server-port construct ;
@ -152,7 +150,7 @@ TUPLE: server-port addr client client-addr encoding ;
TUPLE: datagram-port addr packet packet-addr ; TUPLE: datagram-port addr packet packet-addr ;
: <datagram-port> ( handle addr -- datagram ) : <datagram-port> ( handle addr -- datagram )
>r f datagram-port <port> r> >r datagram-port <port> r>
{ set-delegate set-datagram-port-addr } { set-delegate set-datagram-port-addr }
datagram-port construct ; datagram-port construct ;

View File

@ -119,10 +119,12 @@ M: unix cancel-io ( port -- )
! Readers ! Readers
: reader-eof ( reader -- ) : reader-eof ( reader -- )
dup buffer-empty? [ t >>eof? ] when drop ; dup buffer>> buffer-empty? [ t >>eof ] when drop ;
: (refill) ( port -- n ) : (refill) ( port -- n )
[ handle>> ] [ buffer-end ] [ buffer-capacity ] tri read ; [ handle>> ]
[ buffer>> buffer-end ]
[ buffer>> buffer-capacity ] tri read ;
: refill ( port -- ? ) : refill ( port -- ? )
#! Return f if there is a recoverable error #! Return f if there is a recoverable error
@ -151,8 +153,13 @@ M: input-port (wait-to-read)
! Writers ! Writers
: write-step ( port -- ? ) : write-step ( port -- ? )
dup [ handle>> ] [ buffer@ ] [ buffer-length ] tri write dup
dup 0 >= [ swap buffer-consume f ] [ drop defer-error ] if ; [ handle>> ]
[ buffer>> buffer@ ]
[ buffer>> buffer-length ] tri
write dup 0 >=
[ swap buffer>> buffer-consume f ]
[ drop defer-error ] if ;
TUPLE: write-task < output-task ; TUPLE: write-task < output-task ;
@ -160,11 +167,11 @@ TUPLE: write-task < output-task ;
write-task <io-task> ; write-task <io-task> ;
M: write-task do-io-task M: write-task do-io-task
io-task-port dup [ buffer-empty? ] [ port-error ] bi or io-task-port dup [ buffer>> buffer-empty? ] [ port-error ] bi or
[ 0 swap buffer-reset t ] [ write-step ] if ; [ 0 swap buffer>> buffer-reset t ] [ write-step ] if ;
: add-write-io-task ( port continuation -- ) : add-write-io-task ( port continuation -- )
over port-handle mx get-global mx-writes at* over handle>> mx get-global writes>> at*
[ io-task-callbacks push drop ] [ io-task-callbacks push drop ]
[ drop <write-task> add-io-task ] if ; [ drop <write-task> add-io-task ] if ;
@ -172,7 +179,7 @@ M: write-task do-io-task
[ add-write-io-task ] with-port-continuation drop ; [ add-write-io-task ] with-port-continuation drop ;
M: port port-flush ( port -- ) M: port port-flush ( port -- )
dup buffer-empty? [ drop ] [ (wait-to-write) ] if ; dup buffer>> buffer-empty? [ drop ] [ (wait-to-write) ] if ;
M: unix io-multiplex ( ms/f -- ) M: unix io-multiplex ( ms/f -- )
mx get-global wait-for-events ; mx get-global wait-for-events ;
@ -186,7 +193,7 @@ M: unix (init-stdio) ( -- )
TUPLE: mx-port mx ; TUPLE: mx-port mx ;
: <mx-port> ( mx -- port ) : <mx-port> ( mx -- port )
dup fd>> f mx-port <port> dup fd>> mx-port <port>
{ set-mx-port-mx set-delegate } mx-port construct ; { set-mx-port-mx set-delegate } mx-port construct ;
TUPLE: mx-task < io-task ; TUPLE: mx-task < io-task ;

View File

@ -72,7 +72,7 @@ M: unix delete-directory ( path -- )
M: unix copy-file ( from to -- ) M: unix copy-file ( from to -- )
[ normalize-path ] bi@ [ normalize-path ] bi@
[ (copy-file) ] [ (copy-file) ]
[ swap file-info file-info-permissions chmod io-error ] [ swap file-info permissions>> chmod io-error ]
2bi ; 2bi ;
: stat>type ( stat -- type ) : stat>type ( stat -- type )

View File

@ -103,8 +103,8 @@ M: linux-monitor dispose ( monitor -- )
: inotify-read-loop ( port -- ) : inotify-read-loop ( port -- )
dup wait-to-read1 dup wait-to-read1
0 over parse-file-notifications 0 over buffer>> parse-file-notifications
0 over buffer-reset 0 over buffer>> buffer-reset
inotify-read-loop ; inotify-read-loop ;
: inotify-read-thread ( port -- ) : inotify-read-thread ( port -- )

View File

@ -64,7 +64,7 @@ M: winnt FileArgs-overlapped ( port -- overlapped )
dup pending-error dup pending-error
tuck get-overlapped-result tuck get-overlapped-result
dup pick update-file-ptr dup pick update-file-ptr
swap buffer-consume ; swap buffer>> buffer-consume ;
: (flush-output) ( port -- ) : (flush-output) ( port -- )
dup make-FileArgs dup make-FileArgs
@ -73,7 +73,7 @@ M: winnt FileArgs-overlapped ( port -- overlapped )
>r FileArgs-lpOverlapped r> >r FileArgs-lpOverlapped r>
[ save-callback ] 2keep [ save-callback ] 2keep
[ finish-flush ] keep [ finish-flush ] keep
dup buffer-empty? [ drop ] [ (flush-output) ] if dup buffer>> buffer-empty? [ drop ] [ (flush-output) ] if
] [ ] [
2drop 2drop
] if ; ] if ;
@ -82,7 +82,7 @@ M: winnt FileArgs-overlapped ( port -- overlapped )
[ [ (flush-output) ] with-timeout ] with-destructors ; [ [ (flush-output) ] with-timeout ] with-destructors ;
M: port port-flush M: port port-flush
dup buffer-empty? [ dup flush-output ] unless drop ; dup buffer>> buffer-empty? [ dup flush-output ] unless drop ;
: finish-read ( overlapped port -- ) : finish-read ( overlapped port -- )
dup pending-error dup pending-error

View File

@ -37,10 +37,12 @@ M: winnt <monitor> ( path recursive? -- monitor )
] with-destructors ; ] with-destructors ;
: begin-reading-changes ( monitor -- overlapped ) : begin-reading-changes ( monitor -- overlapped )
dup port-handle win32-file-handle {
over buffer-ptr [ handle>> handle>> ]
pick buffer-size [ buffer>> buffer-ptr ]
roll win32-monitor-recursive? 1 0 ? [ buffer>> buffer-size ]
[ win32-monitor-recursive? 1 0 ? ]
} cleave
FILE_NOTIFY_CHANGE_ALL FILE_NOTIFY_CHANGE_ALL
0 <uint> 0 <uint>
(make-overlapped) (make-overlapped)
@ -82,6 +84,6 @@ M: winnt <monitor> ( path recursive? -- monitor )
[ 2drop ] [ swap <displaced-alien> (changed-files) ] if ; [ 2drop ] [ swap <displaced-alien> (changed-files) ] if ;
M: win32-monitor fill-queue ( monitor -- ) M: win32-monitor fill-queue ( monitor -- )
dup buffer-ptr over read-changes dup buffer>> buffer-ptr over read-changes
[ zero? [ drop ] [ (changed-files) ] if ] H{ } make-assoc [ zero? [ drop ] [ (changed-files) ] if ] H{ } make-assoc
swap set-monitor-queue ; swap set-monitor-queue ;

View File

@ -92,7 +92,7 @@ M: win32-file close-handle ( handle -- )
] when drop ; ] when drop ;
: open-append ( path -- handle length ) : open-append ( path -- handle length )
[ dup file-info file-info-size ] [ drop 0 ] recover [ dup file-info size>> ] [ drop 0 ] recover
>r (open-append) r> 2dup set-file-pointer ; >r (open-append) r> 2dup set-file-pointer ;
TUPLE: FileArgs TUPLE: FileArgs
@ -103,9 +103,9 @@ C: <FileArgs> FileArgs
: make-FileArgs ( port -- <FileArgs> ) : make-FileArgs ( port -- <FileArgs> )
[ port-handle win32-file-handle ] keep [ port-handle win32-file-handle ] keep
[ delegate ] keep [ buffer>> ] keep
[ [
buffer-length buffer>> buffer-length
"DWORD" <c-object> "DWORD" <c-object>
] keep FileArgs-overlapped <FileArgs> ; ] keep FileArgs-overlapped <FileArgs> ;

View File

@ -12,7 +12,7 @@ namespaces continuations layouts ;
] with-directory ; ] with-directory ;
: small-enough? ( n -- ? ) : small-enough? ( n -- ? )
>r "test.image" temp-file file-info file-info-size r> <= ; >r "test.image" temp-file file-info size>> r> <= ;
[ ] [ "hello-world" shake-and-bake ] unit-test [ ] [ "hello-world" shake-and-bake ] unit-test