M: cache-assoc at* assoc>> at* [ dup [ 0 >>age value>> ] when ] dip ;
M: cache-assoc set-at
- [ check-disposed ] keep
+ check-disposed
[ <cache-entry> ] 2dip
assoc>> set-at ;
} cleave
] unless-disposed ;
-M: fd handle-fd dup check-disposed fd>> ;
+M: fd handle-fd check-disposed fd>> ;
M: fd cancel-operation ( fd -- )
[
M: unix (wait-to-read) ( port -- )
dup
- dup handle>> dup check-disposed refill dup
+ dup handle>> check-disposed refill dup
[ dupd wait-for-port (wait-to-read) ] [ 2drop ] if ;
! Writers
M: unix (wait-to-write) ( port -- )
dup
- dup handle>> dup check-disposed drain
+ dup handle>> check-disposed drain
dup [ wait-for-port ] [ 2drop ] if ;
M: unix io-multiplex ( nanos -- )
ptr>> [ [ 32 bits >>offset ] [ -32 shift >>offset-high ] bi ] when* ;
: make-FileArgs ( port handle -- <FileArgs> )
- [ nip dup check-disposed handle>> ]
+ [ nip check-disposed handle>> ]
[
[ buffer>> dup buffer-length 0 DWORD <ref> ] dip make-overlapped
] 2bi <FileArgs> ;
] if ;
: inotify-read-loop ( port -- )
- dup check-disposed
+ check-disposed
dup wait-to-read drop
0 over buffer>> parse-file-notifications
0 over buffer>> buffer-reset
: queue-change ( path changes monitor -- )
3dup and and [
- [ check-disposed ] keep
+ check-disposed
[ file-change boa ] keep
queue>> mailbox-put
] [ 3drop ] if ;
<mailbox> (monitor) ;
: next-change ( monitor -- change )
- [ check-disposed ]
- [
- [ ] [ queue>> ] [ timeout ] tri mailbox-get-timeout
- dup monitor-disposed eq? [ drop already-disposed ] [ nip ] if
- ] bi ;
+ check-disposed
+ [ ] [ queue>> ] [ timeout ] tri mailbox-get-timeout
+ dup monitor-disposed eq? [ drop already-disposed ] [ nip ] if ;
SYMBOL: +add-file+
SYMBOL: +remove-file+
] each ;
: fill-queue ( monitor -- )
- dup port>> dup check-disposed
+ dup port>> check-disposed
[ buffer>> ptr>> ] [ read-changes zero? ] bi
[ 2dup parse-notify-records ] unless
2drop ;
TUPLE: pool connections disposed expired ;
: check-pool ( pool -- )
- dup check-disposed
+ check-disposed
dup expired>> expired? [
31337 <alien> >>expired
connections>> delete-all
] [ drop f ] if ; inline
M: input-port stream-read1
- dup check-disposed
+ check-disposed
dup wait-to-read [ drop f ] [ buffer>> buffer-pop ] if ; inline
ERROR: not-a-c-ptr object ;
{ fixnum c-ptr } declare ; inline
: prepare-read ( count port -- count' port )
- [ integer>fixnum-strict 0 max ] dip dup check-disposed ; inline
+ [ integer>fixnum-strict 0 max ] dip check-disposed ; inline
:: read-loop ( dst n-remaining port n-read -- n-total )
n-remaining port read-step :> ( n-buffered ptr )
PRIVATE>
M: input-port stream-read-until
- 2dup read-until-step dup [ [ 2drop ] 2dip ] [
+ 2dup read-until-step dup [
+ [ 2drop ] 2dip
+ ] [
over [
drop
BV{ } like [ read-until-loop ] keep B{ } like swap
- ] [ [ 2drop ] 2dip ] if
+ ] [
+ [ 2drop ] 2dip
+ ] if
] if ;
TUPLE: output-port < buffered-port ;
PRIVATE>
M: output-port stream-flush
- [ check-disposed ] [ port-flush ] bi ;
+ check-disposed port-flush ;
: wait-to-write ( len port -- )
[ nip ] [ buffer>> buffer-capacity <= ] 2bi
[ drop ] [ port-flush ] if ; inline
M: output-port stream-write1
- [ check-disposed ]
- [ 1 swap wait-to-write ]
- [ buffer>> buffer-write1 ] tri ; inline
+ check-disposed
+ 1 over wait-to-write
+ buffer>> buffer-write1 ; inline
<PRIVATE
PRIVATE>
M: output-port stream-write
- dup check-disposed [
+ check-disposed [
binary-object
[ check-c-ptr ] [ integer>fixnum-strict ] bi*
] [ port-write ] bi* ;
HOOK: handle-length os ( handle -- n/f )
+<PRIVATE
+
+: port-tell ( port -- tell-handle buffer-length )
+ [ handle>> tell-handle ] [ buffer>> buffer-length ] bi ; inline
+
+PRIVATE>
+
M: input-port stream-tell
- [ check-disposed ]
- [ [ handle>> tell-handle ] [ buffer>> buffer-length ] bi - ] bi ;
+ check-disposed port-tell - ;
M: output-port stream-tell
- [ check-disposed ]
- [ [ handle>> tell-handle ] [ buffer>> buffer-length ] bi + ] bi ;
+ check-disposed port-tell + ;
+
+<PRIVATE
:: do-seek-relative ( n seek-type stream -- n seek-type stream )
! seek-relative needs special handling here, because of the
[ n stream stream-tell + seek-absolute ] [ n seek-type ] if
stream ; inline
+PRIVATE>
+
M: input-port stream-seek
+ check-disposed
do-seek-relative
- [ check-disposed ]
[ buffer>> 0 swap buffer-reset ]
- [ handle>> seek-handle ] tri ;
+ [ handle>> seek-handle ] bi ;
M: output-port stream-seek
+ check-disposed
do-seek-relative
- [ check-disposed ]
[ stream-flush ]
- [ handle>> seek-handle ] tri ;
+ [ handle>> seek-handle ] bi ;
M: buffered-port stream-seekable?
handle>> can-seek-handle? ;
M: port cancel-operation handle>> cancel-operation ;
M: port dispose*
- [
- [ handle>> &dispose drop ]
- [ handle>> shutdown ] bi
- ] with-destructors ;
+ [ handle>> &dispose shutdown ] with-destructors ;
GENERIC: underlying-port ( stream -- port )
dup { [ datagram-port? ] [ raw-port? ] } 1|| [ invalid-port ] unless ;
: check-send ( packet addrspec port -- packet addrspec port )
- check-connectionless-port dup check-disposed check-port ;
+ check-connectionless-port check-disposed check-port ;
: check-receive ( port -- port )
- check-connectionless-port dup check-disposed ;
+ check-connectionless-port check-disposed ;
HOOK: (send) io-backend ( packet addrspec datagram -- )
ERROR: already-disposed disposable ;
-: check-disposed ( disposable -- )
- dup disposed>> [ already-disposed ] [ drop ] if ; inline
+: check-disposed ( disposable -- disposable )
+ dup disposed>> [ already-disposed ] when ; inline
GENERIC: dispose ( disposable -- )
: <c-writer> ( handle -- stream ) c-writer new-c-stream ;
M: c-writer stream-write1
- dup check-disposed handle>> fputc ;
+ check-disposed handle>> fputc ;
M: c-writer stream-write
- dup check-disposed
+ check-disposed
[ binary-object ] [ handle>> ] bi* fwrite ;
M: c-writer stream-flush
- dup check-disposed handle>> fflush ;
+ check-disposed handle>> fflush ;
TUPLE: c-reader < c-stream ;
INSTANCE: c-reader input-stream
: <c-reader> ( handle -- stream ) c-reader new-c-stream ;
M: c-reader stream-read-unsafe
- dup check-disposed handle>> fread-unsafe ;
+ check-disposed handle>> fread-unsafe ;
M: c-reader stream-read1
- dup check-disposed handle>> fgetc ;
+ check-disposed handle>> fgetc ;
: read-until-loop ( handle seps accum -- accum ch )
pick fgetc dup [
] if ; inline recursive
M: c-reader stream-read-until
- dup check-disposed handle>> swap
+ check-disposed handle>> swap
32 <byte-vector> read-until-loop [ B{ } like ] dip
over empty? over not and [ 2drop f f ] when ;