destructors: change check-disposed not to drop the disposable.

basis/cache/cache.factor

@@ -22,7 +22,7 @@ M: cache-assoc assoc-size assoc>> assoc-size ;
 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 ;
 

basis/io/backend/unix/unix.factor

@@ -35,7 +35,7 @@ M: fd dispose
         } cleave
     ] unless-disposed ;
 
-M: fd handle-fd dup check-disposed fd>> ;
+M: fd handle-fd check-disposed fd>> ;
 
 M: fd cancel-operation ( fd -- )
     [
@@ -103,7 +103,7 @@ M: fd refill
 
 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
@@ -123,7 +123,7 @@ M: fd drain
 
 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 -- )

basis/io/files/windows/windows.factor

@@ -165,7 +165,7 @@ M: windows handle-length ( handle -- n/f )
     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> ;

basis/io/monitors/linux/linux.factor

@@ -114,7 +114,7 @@ M: linux-monitor dispose* ( monitor -- )
     ] 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

basis/io/monitors/monitors.factor

@@ -43,7 +43,7 @@ TUPLE: file-change path changed monitor ;
 
 : queue-change ( path changes monitor -- )
     3dup and and [
-        [ check-disposed ] keep
+        check-disposed
         [ file-change boa ] keep
         queue>> mailbox-put
     ] [ 3drop ] if ;
@@ -54,11 +54,9 @@ HOOK: (monitor) io-backend ( path recursive? mailbox -- monitor )
     <mailbox> (monitor) ;
 
 : next-change ( monitor -- change )
-    [ check-disposed ]
+    check-disposed
-    [
+    [ ] [ queue>> ] [ timeout ] tri mailbox-get-timeout
-        [ ] [ queue>> ] [ timeout ] tri mailbox-get-timeout
+    dup monitor-disposed eq? [ drop already-disposed ] [ nip ] if ;
-        dup monitor-disposed eq? [ drop already-disposed ] [ nip ] if
-    ] bi ;
 
 SYMBOL: +add-file+
 SYMBOL: +remove-file+

basis/io/monitors/windows/windows.factor

@@ -77,7 +77,7 @@ TUPLE: win32-monitor < monitor port ;
     ] 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 ;

basis/io/pools/pools.factor

@@ -7,7 +7,7 @@ IN: io.pools
 TUPLE: pool connections disposed expired ;
 
 : check-pool ( pool -- )
-    dup check-disposed
+    check-disposed
     dup expired>> expired? [
         31337 <alien> >>expired
         connections>> delete-all

basis/io/ports/ports.factor

@@ -39,7 +39,7 @@ HOOK: (wait-to-read) io-backend ( port -- )
     ] [ 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 ;
@@ -58,7 +58,7 @@ 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 )
@@ -100,11 +100,15 @@ M: input-port stream-read-unsafe
 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 ;
@@ -125,16 +129,16 @@ HOOK: (wait-to-write) io-backend ( 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 ]
+    check-disposed
-    [ 1 swap wait-to-write ]
+    1 over wait-to-write
-    [ buffer>> buffer-write1 ] tri ; inline
+    buffer>> buffer-write1 ; inline
 
 <PRIVATE
 
@@ -152,7 +156,7 @@ M: output-port stream-write1
 PRIVATE>
 
 M: output-port stream-write
-    dup check-disposed [
+    check-disposed [
         binary-object
         [ check-c-ptr ] [ integer>fixnum-strict ] bi*
     ] [ port-write ] bi* ;
@@ -165,13 +169,20 @@ HOOK: can-seek-handle? os ( handle -- ? )
 
 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 ]
+    check-disposed port-tell - ;
-    [ [ handle>> tell-handle ] [ buffer>> buffer-length ] bi - ] bi ;
 
 M: output-port stream-tell
-    [ check-disposed ]
+    check-disposed port-tell + ;
-    [ [ handle>> tell-handle ] [ buffer>> buffer-length ] bi + ] bi ;
+
+<PRIVATE
 
 :: do-seek-relative ( n seek-type stream -- n seek-type stream )
     ! seek-relative needs special handling here, because of the
@@ -180,17 +191,19 @@ M: output-port stream-tell
     [ 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? ;
@@ -221,10 +234,7 @@ M: buffered-port dispose*
 M: port cancel-operation handle>> cancel-operation ;
 
 M: port dispose*
-    [
+    [ handle>> &dispose shutdown ] with-destructors ;
-        [ handle>> &dispose drop ]
-        [ handle>> shutdown ] bi
-    ] with-destructors ;
 
 GENERIC: underlying-port ( stream -- port )
 

basis/io/sockets/sockets.factor

@@ -296,10 +296,10 @@ ERROR: invalid-port object ;
     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 -- )
 

core/destructors/destructors.factor

@@ -35,8 +35,8 @@ GENERIC: dispose* ( disposable -- )
 
 ERROR: already-disposed disposable ;
 
-: check-disposed ( disposable -- )
+: check-disposed ( disposable -- disposable )
-    dup disposed>> [ already-disposed ] [ drop ] if ; inline
+    dup disposed>> [ already-disposed ] when ; inline
 
 GENERIC: dispose ( disposable -- )
 

core/io/streams/c/c.factor

@@ -19,14 +19,14 @@ INSTANCE: c-writer file-writer
 : <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
@@ -35,10 +35,10 @@ INSTANCE: c-reader file-reader
 : <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 [
@@ -49,7 +49,7 @@ M: c-reader stream-read1
     ] 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 ;