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:"
{ $code
"\"mydata.dat\" dup file-info file-info-length ["
"\"mydata.dat\" dup file-info size>> ["
" 4 <sliced-groups> [ reverse-here ] change-each"
"] with-mapped-file"
}

View File

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

View File

@ -4,7 +4,7 @@ IN: io.mmap.tests
[ "mmap-test-file.txt" resource-path delete-file ] ignore-errors
[ ] [ "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
[ 5 ] [ "mmap-test-file.txt" resource-path dup file-info file-info-size [ length ] 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 size>> [ length ] with-mapped-file ] unit-test
[ "22345" ] [ "mmap-test-file.txt" resource-path ascii file-contents ] unit-test
[ "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> } "." } ;
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 } } }
{ $description "Creates a new " { $link port } " using the specified native handle and I/O buffer." }
{ $values { "handle" "a native handle identifying an I/O resource" } { "type" symbol } { "port" "a new " { $link port } } }
{ $description "Creates a new " { $link port } " with no buffer." }
$low-level-note ;
HELP: <buffered-port>

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

@ -92,7 +92,7 @@ M: win32-file close-handle ( handle -- )
] when drop ;
: 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 ;
TUPLE: FileArgs
@ -103,9 +103,9 @@ C: <FileArgs> FileArgs
: make-FileArgs ( port -- <FileArgs> )
[ port-handle win32-file-handle ] keep
[ delegate ] keep
[ buffer>> ] keep
[
buffer-length
buffer>> buffer-length
"DWORD" <c-object>
] keep FileArgs-overlapped <FileArgs> ;

View File

@ -12,7 +12,7 @@ namespaces continuations layouts ;
] with-directory ;
: 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