New dispose word and with-dispose combinator, docs for io.monitor, working on O(1) stream timeouts

core/continuations/continuations-docs.factor

@@ -68,6 +68,15 @@ $nl
 
 ABOUT: "continuations"
 
+HELP: dispose
+{ $values { "object" "a disposable object" } }
+{ $contract "Releases operating system resources associated with a disposable object. No further operations can be performed on a disposable object after this call. Disposable objects include streams, memory mapped files, and so on." }
+{ $notes "You must close disposable objects after you are finished working with them, to avoid leaking operating system resources. A convenient way to automate this is by using the " { $link with-disposal } " word." } ;
+
+HELP: with-disposal
+{ $values { "object" "a disposable object" } { "quot" "a quotation with stack effect " { $snippet "( object -- )" } } }
+{ $description "Calls the quotation, disposing the object with " { $link dispose } " after the quotation returns or if it throws an error." } ;
+
 HELP: catchstack*
 { $values { "catchstack" "a vector of continuations" } }
 { $description "Outputs the current catchstack." } ;

core/continuations/continuations.factor

@@ -135,6 +135,11 @@ PRIVATE>
         [ [ , f ] compose [ , drop t ] recover ] curry all?
     ] { } make peek swap [ rethrow ] when ; inline
 
+GENERIC: dispose ( object -- )
+
+: with-disposal ( object quot -- )
+    over [ dispose ] curry [ ] cleanup ; inline
+
 TUPLE: condition restarts continuation ;
 
 : <condition> ( error restarts cc -- condition )

core/dlists/dlists-docs.factor

@@ -1,4 +1,4 @@
-USING: help.markup help.syntax kernel ;
+USING: help.markup help.syntax kernel quotations ;
 IN: dlists
 
 ARTICLE: "dlists" "Doubly-linked lists"
@@ -13,23 +13,31 @@ $nl
 { $subsection dlist? }
 "Constructing a dlist:"
 { $subsection <dlist> }
-"Double-ended queue protocol:"
+"Working with the front of the list:"
-{ $subsection dlist-empty? }
 { $subsection push-front }
+{ $subsection push-front* }
+{ $subsection peek-front }
 { $subsection pop-front }
 { $subsection pop-front* }
+"Working with the back of the list:"
 { $subsection push-back }
+{ $subsection push-back* }
+{ $subsection peek-back }
 { $subsection pop-back }
 { $subsection pop-back* }
 "Finding out the length:"
+{ $subsection dlist-empty? }
 { $subsection dlist-length }
 "Iterating over elements:"
 { $subsection dlist-each }
 { $subsection dlist-find }
 { $subsection dlist-contains? }
-"Deleting a node matching a predicate:"
+"Deleting a node:"
-{ $subsection delete-node* }
 { $subsection delete-node }
+{ $subsection dlist-delete }
+"Deleting a node matching a predicate:"
+{ $subsection delete-node-if* }
+{ $subsection delete-node-if }
 "Consuming all nodes:"
 { $subsection dlist-slurp } ;
 
@@ -77,7 +85,7 @@ HELP: pop-back*
 { $see-also push-front push-back pop-front pop-front* pop-back } ;
 
 HELP: dlist-find
-{ $values { "quot" "a quotation" } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } }
+{ $values { "quot" quotation } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } }
 { $description "Applies the quotation to each element of the " { $link dlist } " in turn, until it outputs a true value or the end of the " { $link dlist } " is reached.  Outputs either the object it found or " { $link f } ", and a boolean which is true if an object is found." }
 { $notes "Returns a boolean to allow dlists to store " { $link f } "."
     $nl
@@ -85,20 +93,20 @@ HELP: dlist-find
 } ;
 
 HELP: dlist-contains?
-{ $values { "quot" "a quotation" } { "dlist" { $link dlist } } { "?" "a boolean" } }
+{ $values { "quot" quotation } { "dlist" { $link dlist } } { "?" "a boolean" } }
 { $description "Just like " { $link dlist-find } " except it doesn't return the object." }
 { $notes "This operation is O(n)." } ;
 
-HELP: delete-node*
+HELP: delete-node-if*
-{ $values { "quot" "a quotation" } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } }
+{ $values { "quot" quotation } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } }
 { $description "Calls " { $link dlist-find } " on the " { $link dlist } " and deletes the node returned, if any.  Returns the value of the deleted node and a boolean to allow the deleted value to distinguished from " { $link f } ", for nothing deleted." }
 { $notes "This operation is O(n)." } ;
 
-HELP: delete-node
+HELP: delete-node-if
-{ $values { "quot" "a quotation" } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } }
+{ $values { "quot" quotation } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } }
-{ $description "Like " { $link delete-node* } " but cannot distinguish from deleting a node whose value is " { $link f } " or not deleting an element." }
+{ $description "Like " { $link delete-node-if* } " but cannot distinguish from deleting a node whose value is " { $link f } " or not deleting an element." }
 { $notes "This operation is O(n)." } ;
 
 HELP: dlist-each
-{ $values { "quot" "a quotation" } { "dlist" { $link dlist } } }
+{ $values { "quot" quotation } { "dlist" { $link dlist } } }
 { $description "Iterate a " { $link dlist } ", calling quot on each element." } ;

core/dlists/dlists-tests.factor

@@ -49,14 +49,14 @@ IN: temporary
 [ f ] [ <dlist> 1 over push-back [ 2 = ] swap dlist-contains? ] unit-test
 [ t ] [ <dlist> 1 over push-back [ 1 = ] swap dlist-contains? ] unit-test
 
-[ 1 ] [ <dlist> 1 over push-back [ 1 = ] swap delete-node ] unit-test
+[ 1 ] [ <dlist> 1 over push-back [ 1 = ] swap delete-node-if ] unit-test
-[ t ] [ <dlist> 1 over push-back [ 1 = ] over delete-node drop dlist-empty? ] unit-test
+[ t ] [ <dlist> 1 over push-back [ 1 = ] over delete-node-if drop dlist-empty? ] unit-test
-[ t ] [ <dlist> 1 over push-back [ 1 = ] over delete-node drop dlist-empty? ] unit-test
+[ t ] [ <dlist> 1 over push-back [ 1 = ] over delete-node-if drop dlist-empty? ] unit-test
-[ 0 ] [ <dlist> 1 over push-back [ 1 = ] over delete-node drop dlist-length ] unit-test
+[ 0 ] [ <dlist> 1 over push-back [ 1 = ] over delete-node-if drop dlist-length ] unit-test
-[ 1 ] [ <dlist> 1 over push-back 2 over push-back [ 1 = ] over delete-node drop dlist-length ] unit-test
+[ 1 ] [ <dlist> 1 over push-back 2 over push-back [ 1 = ] over delete-node-if drop dlist-length ] unit-test
-[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back [ 1 = ] over delete-node drop dlist-length ] unit-test
+[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back [ 1 = ] over delete-node-if drop dlist-length ] unit-test
-[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back [ 2 = ] over delete-node drop dlist-length ] unit-test
+[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back [ 2 = ] over delete-node-if drop dlist-length ] unit-test
-[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back [ 3 = ] over delete-node drop dlist-length ] unit-test
+[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back [ 3 = ] over delete-node-if drop dlist-length ] unit-test
 
 [ 0 ] [ <dlist> dlist-length ] unit-test
 [ 1 ] [ <dlist> 1 over push-front dlist-length ] unit-test

core/dlists/dlists.factor

@@ -63,12 +63,22 @@ C: <dlist-node> dlist-node
     >r dlist-front r> (dlist-each-node) ; inline
 PRIVATE>
 
-: push-front ( obj dlist -- )
+: push-front* ( obj dlist -- dlist-node )
-    [ dlist-front f swap <dlist-node> dup set-next-prev ] keep
+    [ dlist-front f swap <dlist-node> dup dup set-next-prev ] keep
     [ set-dlist-front ] keep
     [ set-back-to-front ] keep
     inc-length ;
 
+: push-front ( obj dlist -- )
+    push-front* drop ;
+
+: push-back* ( obj dlist -- dlist-node )
+    [ dlist-back f <dlist-node> ] keep
+    [ dlist-back set-next-when ] 2keep
+    [ set-dlist-back ] 2keep
+    [ set-front-to-back ] keep
+    inc-length ;
+
 : push-back ( obj dlist -- )
     [ dlist-back f <dlist-node> ] keep
     [ dlist-back set-next-when ] 2keep
@@ -76,6 +86,9 @@ PRIVATE>
     [ set-front-to-back ] keep
     inc-length ;
 
+: peek-front ( dlist -- obj )
+    dlist-front dlist-node-obj ;
+
 : pop-front ( dlist -- obj )
     dup dlist-front [
         dup dlist-node-next
@@ -87,6 +100,9 @@ PRIVATE>
 
 : pop-front* ( dlist -- ) pop-front drop ;
 
+: peek-back ( dlist -- obj )
+    dlist-back dlist-node-obj ;
+
 : pop-back ( dlist -- obj )
     dup dlist-back [
         dup dlist-node-prev
@@ -108,25 +124,25 @@ PRIVATE>
     dup dlist-node-prev over dlist-node-next set-prev-when
     dup dlist-node-next swap dlist-node-prev set-next-when ;
 
-: (delete-node) ( dlist dlist-node -- )
+: delete-node ( dlist dlist-node -- )
     {
         { [ over dlist-front over eq? ] [ drop pop-front* ] }
         { [ over dlist-back over eq? ] [ drop pop-back* ] }
         { [ t ] [ unlink-node dec-length ] }
     } cond ;
 
-: delete-node* ( quot dlist -- obj/f ? )
+: delete-node-if* ( quot dlist -- obj/f ? )
     tuck dlist-find-node [
-        [ (delete-node) ] keep [ dlist-node-obj t ] [ f f ] if*
+        [ delete-node ] keep [ dlist-node-obj t ] [ f f ] if*
     ] [
         2drop f f
     ] if ; inline
 
-: delete-node ( quot dlist -- obj/f )
+: delete-node-if ( quot dlist -- obj/f )
-    delete-node* drop ; inline
+    delete-node-if* drop ; inline
 
 : dlist-delete ( obj dlist -- obj/f )
-    >r [ eq? ] curry r> delete-node ;
+    >r [ eq? ] curry r> delete-node-if ;
 
 : dlist-each ( dlist quot -- )
     [ dlist-node-obj ] swap compose dlist-each-node ; inline

core/inference/inference-tests.factor

@@ -421,6 +421,8 @@ DEFER: bar
 { 2 1 } [ [ + ] [ ] [ ] cleanup ] unit-test-effect
 { 2 1 } [ [ + ] [ 3drop 0 ] recover ] unit-test-effect
 
+\ dispose must-infer
+
 ! Test stream protocol
 \ set-timeout must-infer
 \ stream-read must-infer
@@ -430,7 +432,6 @@ DEFER: bar
 \ stream-write must-infer
 \ stream-write1 must-infer
 \ stream-nl must-infer
-\ stream-close must-infer
 \ stream-format must-infer
 \ stream-write-table must-infer
 \ stream-flush must-infer

core/io/files/files-tests.factor

@@ -1,5 +1,5 @@
 IN: temporary
-USING: tools.test io.files io threads kernel ;
+USING: tools.test io.files io threads kernel continuations ;
 
 [ "passwd" ] [ "/etc/passwd" file-name ] unit-test
 [ "awk/" ] [ "/usr/libexec/awk/" file-name ] unit-test
@@ -41,7 +41,7 @@ USING: tools.test io.files io threads kernel ;
 [ ] [ "test-blah" resource-path make-directory ] unit-test
 
 [ ] [
-    "test-blah/fooz" resource-path <file-writer> stream-close
+    "test-blah/fooz" resource-path <file-writer> dispose
 ] unit-test
 
 [ t ] [

core/io/io-docs.factor

@@ -1,12 +1,12 @@
 USING: help.markup help.syntax quotations hashtables kernel
-classes strings ;
+classes strings continuations ;
 IN: io
 
 ARTICLE: "stream-protocol" "Stream protocol"
 "The stream protocol consists of a large number of generic words, many of which are optional."
 $nl
-"A word required to be implemented for all streams:"
+"All streams must implement the " { $link dispose } " word in addition to the stream protocol."
-{ $subsection stream-close }
+$nl
 "Three words are required for input streams:"
 { $subsection stream-read1 }
 { $subsection stream-read }
@@ -73,12 +73,6 @@ ARTICLE: "streams" "Streams"
 
 ABOUT: "streams"
 
-HELP: stream-close
-{ $values { "stream" "a stream" } }
-{ $contract "Closes the stream. This releases any external resources associated with the stream, such as file handles and network connections. No further operations can be performed on the stream after this call." }
-{ $notes "You must close streams after you are finished working with them. A convenient way to automate this is by using the " { $link with-stream } " word." }
-$io-error ;
-
 HELP: set-timeout
 { $values { "n" "an integer" } { "stream" "a stream" } }
 { $contract "Sets a timeout, in milliseconds, for closing the stream if there is no activity. Not all streams support timeouts." } 

core/io/io.factor

@@ -4,7 +4,6 @@ USING: hashtables generic kernel math namespaces sequences strings
     continuations assocs io.styles sbufs ;
 IN: io
 
-GENERIC: stream-close ( stream -- )
 GENERIC: set-timeout ( n stream -- )
 GENERIC: stream-readln ( stream -- str )
 GENERIC: stream-read1 ( stream -- ch/f )
@@ -29,7 +28,7 @@ GENERIC: stream-write-table ( table-cells style stream -- )
     [ over stream-write (stream-copy) ] [ 2drop ] if* ;
 
 : stream-copy ( in out -- )
-    [ 2dup (stream-copy) ] [ stream-close stream-close ] [ ]
+    [ 2dup (stream-copy) ] [ dispose dispose ] [ ]
     cleanup ;
 
 ! Default stream
@@ -54,9 +53,7 @@ SYMBOL: stderr
     stdio swap with-variable ; inline
 
 : with-stream ( stream quot -- )
-    swap [
+    [ with-stream* ] curry with-disposal ; inline
-        [ stdio get stream-close ] [ ] cleanup
-    ] with-stream* ; inline
 
 : tabular-output ( style quot -- )
     swap >r { } make r> stdio get stream-write-table ; inline

core/io/streams/c/c.factor

@@ -1,9 +1,9 @@
-! Copyright (C) 2004, 2007 Slava Pestov.
+! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel kernel.private namespaces io
 strings sequences math generic threads.private classes
 io.backend io.streams.lines io.streams.plain io.streams.duplex
-io.files ;
+io.files continuations ;
 IN: io.streams.c
 
 TUPLE: c-writer handle ;
@@ -19,7 +19,7 @@ M: c-writer stream-write
 M: c-writer stream-flush
     c-writer-handle fflush ;
 
-M: c-writer stream-close
+M: c-writer dispose
     c-writer-handle fclose ;
 
 TUPLE: c-reader handle ;
@@ -46,7 +46,7 @@ M: c-reader stream-read-until
     [ swap read-until-loop ] "" make swap
     over empty? over not and [ 2drop f f ] when ;
 
-M: c-reader stream-close
+M: c-reader dispose
     c-reader-handle fclose ;
 
 : <duplex-c-stream> ( in out -- stream )

core/io/streams/duplex/duplex-docs.factor

@@ -1,4 +1,4 @@
-USING: help.markup help.syntax io ;
+USING: help.markup help.syntax io continuations ;
 IN: io.streams.duplex
 
 ARTICLE: "io.streams.duplex" "Duplex streams"
@@ -19,4 +19,4 @@ HELP: <duplex-stream>
 HELP: check-closed
 { $values { "stream" "a duplex stream" } }
 { $description "Throws a " { $link check-closed } " error if the stream has already been closed." }
-{ $error-description "This error is thrown when performing an I/O operation on a " { $link duplex-stream } " which has been closed with " { $link stream-close } "." } ;
+{ $error-description "This error is thrown when performing an I/O operation on a " { $link duplex-stream } " which has been closed with " { $link dispose } "." } ;

core/io/streams/duplex/duplex-tests.factor

@@ -6,7 +6,7 @@ TUPLE: closing-stream closed? ;
 
 : <closing-stream> closing-stream construct-empty ;
 
-M: closing-stream stream-close
+M: closing-stream dispose
     dup closing-stream-closed? [
         "Closing twice!" throw
     ] [
@@ -17,24 +17,24 @@ TUPLE: unclosable-stream ;
 
 : <unclosable-stream> unclosable-stream construct-empty ;
 
-M: unclosable-stream stream-close
+M: unclosable-stream dispose
     "Can't close me!" throw ;
 
 [ ] [
     <closing-stream> <closing-stream> <duplex-stream>
-    dup stream-close stream-close
+    dup dispose dispose
 ] unit-test
 
 [ t ] [
     <unclosable-stream> <closing-stream> [
         <duplex-stream>
-        [ dup stream-close ] catch 2drop
+        [ dup dispose ] catch 2drop
     ] keep closing-stream-closed?
 ] unit-test
 
 [ t ] [
     <closing-stream> [ <unclosable-stream>
         <duplex-stream>
-        [ dup stream-close ] catch 2drop
+        [ dup dispose ] catch 2drop
     ] keep closing-stream-closed?
 ] unit-test

core/io/streams/duplex/duplex.factor

@@ -65,14 +65,14 @@ M: duplex-stream make-cell-stream
 M: duplex-stream stream-write-table
     duplex-stream-out+ stream-write-table ;
 
-M: duplex-stream stream-close
+M: duplex-stream dispose
     #! The output stream is closed first, in case both streams
     #! are attached to the same file descriptor, the output
     #! buffer needs to be flushed before we close the fd.
     dup duplex-stream-closed? [
         t over set-duplex-stream-closed?
-        [ dup duplex-stream-out stream-close ]
+        [ dup duplex-stream-out dispose ]
-        [ dup duplex-stream-in stream-close ] [ ] cleanup
+        [ dup duplex-stream-in dispose ] [ ] cleanup
     ] unless drop ;
 
 M: duplex-stream set-timeout

core/io/streams/nested/nested.factor

@@ -1,14 +1,14 @@
-! Copyright (C) 2006, 2007 Slava Pestov.
+! Copyright (C) 2006, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: io.streams.nested
 USING: arrays generic assocs kernel namespaces strings
-quotations io ;
+quotations io continuations ;
 
 TUPLE: ignore-close-stream ;
 
 : <ignore-close-stream> ignore-close-stream construct-delegate ;
 
-M: ignore-close-stream stream-close drop ;
+M: ignore-close-stream dispose drop ;
 
 TUPLE: style-stream style ;
 
@@ -44,4 +44,4 @@ TUPLE: block-stream ;
 
 : <block-stream> block-stream construct-delegate ;
 
-M: block-stream stream-close drop ;
+M: block-stream dispose drop ;

core/io/streams/string/string.factor

@@ -2,11 +2,13 @@
 ! See http://factorcode.org/license.txt for BSD license.
 IN: io.streams.string
 USING: io kernel math namespaces sequences sbufs strings
-generic splitting io.streams.plain io.streams.lines ;
+generic splitting io.streams.plain io.streams.lines
+continuations ;
+
+M: sbuf dispose drop ;
 
 M: sbuf stream-write1 push ;
 M: sbuf stream-write push-all ;
-M: sbuf stream-close drop ;
 M: sbuf stream-flush drop ;
 
 : <string-writer> ( -- stream )

extra/cabal/cabal.factor

@@ -41,7 +41,7 @@ VARS: input user ;
 : ((send-input)) ( other -- ) [ input> print flush ] with-stream* ;
 
 : (send-input) ( other -- )
-[ ((send-input)) ] catch [ print dup stream-close users> delete ] when ;
+[ ((send-input)) ] catch [ print dup dispose users> delete ] when ;
 
 : send-input ( other -- )
 dup duplex-stream-closed? [ users> delete ] [ (send-input) ] if ;

extra/cryptlib/streams/streams.factor

@@ -84,7 +84,7 @@ M: crypt-stream stream-write1 ( ch stream -- )
 : check-close ( err -- )
     dup CRYPT_ERROR_PARAM1 = [ drop ] [ check-result ] if ;
     
-M: crypt-stream stream-close ( stream -- )
+M: crypt-stream dispose ( stream -- )
     crypt-stream-handle cryptDestroySession check-close ;
 
 : create-session ( format -- session )
@@ -115,7 +115,7 @@ M: crypt-stream stream-close ( stream -- )
     
     dup stream-readln print
     
-    stream-close 
+    dispose 
     end 
     ;
     
@@ -130,7 +130,7 @@ M: crypt-stream stream-close ( stream -- )
     "Thanks!" over stream-print
     dup stream-flush
     
-    stream-close
+    dispose
     end 
     ;
     
@@ -152,6 +152,6 @@ M: crypt-stream stream-close ( stream -- )
     
     (rpl)
     
-    stream-close 
+    dispose 
     end 
     ;

extra/delegate/protocols/protocols.factor

@@ -15,7 +15,7 @@ PROTOCOL: assoc-protocol
     ! everything should work, just slower (with >alist)
 
 PROTOCOL: stream-protocol
-    stream-close stream-read1 stream-read stream-read-until
+    stream-read1 stream-read stream-read-until
     stream-flush stream-write1 stream-write stream-format
     stream-nl make-span-stream make-block-stream stream-readln
     make-cell-stream stream-write-table set-timeout ;

extra/help/handbook/handbook.factor

@@ -137,22 +137,25 @@ ARTICLE: "collections" "Collections"
 { $subsection "graphs" }
 { $subsection "buffers" } ;
 
-USING: io.sockets io.launcher io.mmap ;
+USING: io.sockets io.launcher io.mmap io.monitor ;
 
 ARTICLE: "io" "Input and output" 
 { $subsection "streams" }
-"Stream implementations:"
+"External streams:"
 { $subsection "file-streams" }
+{ $subsection "network-streams" }
+"Wrapper streams:"
 { $subsection "io.streams.duplex" }
 { $subsection "io.streams.lines" }
 { $subsection "io.streams.plain" }
 { $subsection "io.streams.string" }
-"Advanced features:"
+"Stream utilities:"
 { $subsection "stream-binary" }
 { $subsection "styles" }
-{ $subsection "network-streams" }
+"Advanced features:"
 { $subsection "io.launcher" }
-{ $subsection "io.mmap" } ;
+{ $subsection "io.mmap" }
+{ $subsection "io.monitor" } ;
 
 ARTICLE: "tools" "Developer tools"
 { $subsection "tools.annotations" }

extra/help/tutorial/tutorial.factor

@@ -23,7 +23,7 @@ $nl
 $nl
 "Now, we tell Factor that all definitions in this source file should go into the " { $snippet "palindrome" } " vocabulary using the " { $link POSTPONE: IN: } " word:"
 { $code "IN: palindrome" }
-"You are now ready to go on to the next section." ;
+"You are now ready to go on to the next section: " { $link "first-program-logic" } "." ;
 
 ARTICLE: "first-program-logic" "Writing some logic in your first program"
 "Your " { $snippet "palindrome.factor" } " file should look like the following after the previous section:"
@@ -56,7 +56,7 @@ $nl
 { $code "\\ = see" }
 "It's in the " { $vocab-link "kernel" } " vocabulary, which we've already added to the search path."
 
-"Now press " { $command workspace "workflow" refresh-all } " again, and the source file should reload without any errors." ;
+"Now press " { $command workspace "workflow" refresh-all } " again, and the source file should reload without any errors. You can now go on and learn about " { $link "first-program-test" } "." ;
 
 ARTICLE: "first-program-test" "Testing your first program"
 "Your " { $snippet "palindrome.factor" } " file should look like the following after the previous section:"
@@ -92,7 +92,7 @@ $nl
 }
 "Now, you can run unit tests:"
 { $code "\"palindrome\" test" }
-"It should report that all tests have passed." ;
+"It should report that all tests have passed. Now you can read about " { $link "first-program-extend" } "." ;
 
 ARTICLE: "first-program-extend" "Extending your first program"
 "Our palindrome program works well, however we'd like to extend it to ignore spaces and non-alphabetical characters in the input."

extra/html/html.factor

@@ -105,7 +105,7 @@ TUPLE: html-sub-stream style stream ;
 
 TUPLE: html-span-stream ;
 
-M: html-span-stream stream-close
+M: html-span-stream dispose
     end-sub-stream not-a-div format-html-span ;
 
 : border-css, ( border -- )
@@ -138,7 +138,7 @@ M: html-span-stream stream-close
 
 TUPLE: html-block-stream ;
 
-M: html-block-stream stream-close ( quot style stream -- )
+M: html-block-stream dispose ( quot style stream -- )
     end-sub-stream a-div format-html-div ;
 
 : border-spacing-css,

extra/http/client/client.factor

@@ -44,14 +44,14 @@ DEFER: http-get-stream
     #! Should this support Location: headers that are
     #! relative URLs?
     pick 100 /i 3 = [
-        stream-close "Location" swap at nip http-get-stream
+        dispose "Location" swap at nip http-get-stream
     ] when ;
 
 : http-get-stream ( url -- code headers stream )
     #! Opens a stream for reading from an HTTP URL.
     parse-url over parse-host <inet> <client> [
         [ [ get-request read-response ] with-stream* ] keep
-    ] [ >r stream-close r> rethrow ] recover do-redirect ;
+    ] [ ] [ dispose ] cleanup do-redirect ;
 
 : http-get ( url -- code headers string )
     #! Opens a stream for reading from an HTTP URL.

extra/io/mmap/mmap-docs.factor

@@ -1,4 +1,4 @@
-USING: help.markup help.syntax alien math ;
+USING: help.markup help.syntax alien math continuations ;
 IN: io.mmap
 
 HELP: mapped-file
@@ -15,21 +15,17 @@ HELP: <mapped-file>
 { $notes "You must call " { $link close-mapped-file } " when you are finished working with the returned object, to reclaim resources. The " { $link with-mapped-file } " provides an abstraction which can close the mapped file for you." }
 { $errors "Throws an error if a memory mapping could not be established." } ;
 
-HELP: (close-mapped-file)
-{ $values { "mmap" mapped-file } }
-{ $contract "Releases system resources associated with the mapped file. This word should not be called by user code; use " { $link close-mapped-file } " instead." }
-{ $errors "Throws an error if a memory mapping could not be established." } ;
-
 HELP: close-mapped-file
 { $values { "mmap" mapped-file } }
-{ $description "Releases system resources associated with the mapped file." }
+{ $contract "Releases system resources associated with the mapped file. This word should not be called by user code; use " { $link dispose } " instead." }
 { $errors "Throws an error if a memory mapping could not be established." } ;
 
 ARTICLE: "io.mmap" "Memory-mapped files"
 "The " { $vocab-link "io.mmap" } " vocabulary implements support for memory-mapped files."
 { $subsection <mapped-file> }
-{ $subsection close-mapped-file }
+"Memory-mapped files are disposable and can be closed with " { $link dispose } " or " { $link with-disposal } "."
-"A combinator which wraps the above two words:"
+$nl
+"A utility combinator which wraps the above:"
 { $subsection with-mapped-file }
 "Memory mapped files implement the " { $link "sequence-protocol" } " and present themselves as a sequence of bytes. The underlying memory area can also be accessed directly:"
 { $subsection mapped-file-address }

extra/io/mmap/mmap.factor

@@ -23,14 +23,12 @@ INSTANCE: mapped-file sequence
 
 HOOK: <mapped-file> io-backend ( path length -- mmap )
 
-HOOK: (close-mapped-file) io-backend ( mmap -- )
+HOOK: close-mapped-file io-backend ( mmap -- )
 
-: close-mapped-file ( mmap -- )
+M: mapped-file dispose ( mmap -- )
     check-closed
     t over set-mapped-file-closed?
-    (close-mapped-file) ;
+    close-mapped-file ;
 
 : with-mapped-file ( path length quot -- )
-    >r <mapped-file> r>
+    >r <mapped-file> r> with-disposal ; inline
-    [ keep ] curry
-    [ close-mapped-file ] [ ] cleanup ; inline

extra/io/monitor/monitor-docs.factor

@@ -0,0 +1,61 @@
+IN: io.monitor
+USING: help.markup help.syntax continuations ;
+
+HELP: <monitor>
+{ $values { "path" "a pathname string" } { "recursive?" "a boolean" } }
+{ $description "Opens a file system change monitor which listens for changes on " { $snippet "path" } ". The boolean indicates whether changes in subdirectories should be reported."
+$nl
+"Not all operating systems support recursive monitors; if recursive monitoring is not available, an error is thrown and the caller must implement alternative logic for monitoring subdirectories." } ;
+
+HELP: next-change
+{ $values { "monitor" "a monitor" } { "path" "a pathname string" } { "changes" "a sequence of change descriptors" } }
+{ $description "Waits for file system changes and outputs the pathname of the first changed file. The change descriptor is a sequence containing at least one change descriptor; see " { $link "io.monitor.descriptors" } "." } ;
+
+HELP: with-monitor
+{ $values { "path" "a pathname string" } { "recursive?" "a boolean" } { "quot" "a quotation with stack effect " { $snippet "( monitor -- )" } } }
+{ $description "Opens a file system change monitor and passes it to the quotation. Closes the monitor after the quotation returns or throws an error." } ;
+
+HELP: +change-file+
+{ $description "Indicates that the contents of the file have changed." } ;
+
+HELP: +change-name+
+{ $description "Indicates that the file name has changed." } ;
+
+HELP: +change-size+
+{ $description "Indicates that the file size has changed." } ;
+
+HELP: +change-attributes+
+{ $description "Indicates that file attributes has changed. Attributes are operating system-specific but may include the creation time and permissions." } ;
+
+HELP: +change-modified+
+{ $description "Indicates that the last modification time of the file has changed." } ;
+
+ARTICLE: "io.monitor.descriptors" "File system change descriptors"
+"Change descriptors output by " { $link next-change } ":"
+{ $subsection +change-file+ }
+{ $subsection +change-name+ }
+{ $subsection +change-size+ }
+{ $subsection +change-attributes+ }
+{ $subsection +change-modified+ } ;
+
+ARTICLE: "io.monitor" "File system change monitors"
+"File system change monitors listen for changes to file names, attributes and contents under a specified directory. They can optionally be recursive, in which case subdirectories are also monitored."
+$nl
+"Creating a file system change monitor and listening for changes:"
+{ $subsection <monitor> }
+{ $subsection next-change }
+{ $subsection "io.monitor.descriptors" }
+"Monitors are closed by calling " { $link dispose } " or " { $link with-disposal } "."
+$nl
+"A utility combinator which opens a monitor and cleans it up after:"
+{ $subsection with-monitor }
+"An example which watches the Factor directory for changes:"
+{ $code
+    "USE: io.monitor"
+    ": watch-loop ( monitor -- )"
+    "    dup next-change . . nl nl flush watch-loop ;"
+    ""
+    "\"\" resource-path f [ watch-loop ] with-monitor"
+} ;
+
+ABOUT: "io.monitor"

extra/io/monitor/monitor.factor

@@ -5,8 +5,6 @@ IN: io.monitor
 
 HOOK: <monitor> io-backend ( path recursive? -- monitor )
 
-HOOK: close-monitor io-backend ( monitor -- )
-
 HOOK: next-change io-backend ( monitor -- path changes )
 
 SYMBOL: +change-file+
@@ -16,4 +14,4 @@ SYMBOL: +change-attributes+
 SYMBOL: +change-modified+
 
 : with-monitor ( path recursive? quot -- )
-    >r <monitor> r> over [ close-monitor ] curry [ ] cleanup ;
+    >r <monitor> r> with-disposal ; inline

extra/io/nonblocking/nonblocking-docs.factor

@@ -1,5 +1,5 @@
 USING: io io.buffers io.backend help.markup help.syntax kernel
-strings sbufs words ;
+strings sbufs words continuations ;
 IN: io.nonblocking
 
 ARTICLE: "io.nonblocking" "Non-blocking I/O implementation"
@@ -23,7 +23,7 @@ $nl
 "Per-port native I/O protocol:"
 { $subsection init-handle }
 { $subsection (wait-to-read) }
-"Additionally, the I/O backend must provide an implementation of the " { $link stream-flush } " and " { $link stream-close } " generic words."
+"Additionally, the I/O backend must provide an implementation of the " { $link stream-flush } " and " { $link dispose } " generic words."
 $nl
 "Dummy ports which should be used to implement networking:"
 { $subsection server-port }

extra/io/nonblocking/nonblocking.factor

@@ -1,16 +1,20 @@
-! Copyright (C) 2005, 2007 Slava Pestov, Doug Coleman
+! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman
 ! See http://factorcode.org/license.txt for BSD license.
 IN: io.nonblocking
-USING: math kernel io sequences io.buffers generic sbufs
+USING: math kernel io sequences io.buffers generic sbufs system
-system io.streams.lines io.streams.plain io.streams.duplex
+io.streams.lines io.streams.plain io.streams.duplex io.backend
-continuations debugger classes byte-arrays namespaces
+continuations debugger classes byte-arrays namespaces splitting
-splitting ;
+dlists ;
 
 SYMBOL: default-buffer-size
 64 1024 * default-buffer-size set-global
 
 ! Common delegate of native stream readers and writers
-TUPLE: port handle error timeout cutoff type eof? ;
+TUPLE: port
+handle
+error
+timeout-entry timeout cutoff
+type eof? ;
 
 SYMBOL: closed
 
@@ -41,19 +45,46 @@ GENERIC: close-handle ( handle -- )
 
 : handle>duplex-stream ( in-handle out-handle -- stream )
     <writer>
-    [ >r <reader> r> <duplex-stream> ] [ ] [ stream-close ]
+    [ >r <reader> r> <duplex-stream> ] [ ] [ dispose ]
     cleanup ;
 
-: touch-port ( port -- )
-    dup port-timeout dup zero?
-    [ 2drop ] [ millis + swap set-port-cutoff ] if ;
-
 : timeout? ( port -- ? )
     port-cutoff dup zero? not swap millis < and ;
 
 : pending-error ( port -- )
     dup port-error f rot set-port-error [ throw ] when* ;
 
+SYMBOL: timeout-queue
+
+<dlist> timeout-queue set-global
+
+: unqueue-timeout ( port -- )
+    port-timeout-entry [
+        timeout-queue get-global swap delete-node
+    ] when* ;
+
+: queue-timeout ( port -- )
+    dup timeout-queue get-global push-front*
+    swap set-port-timeout-entry ;
+
+HOOK: expire-port io-backend ( port -- )
+
+M: object expire-port drop ;
+
+: expire-timeouts ( -- )
+    timeout-queue get-global dup dlist-empty? [ drop ] [
+        dup peek-back timeout?
+        [ pop-back expire-port expire-timeouts ] [ drop ] if
+    ] if ;
+
+: touch-port ( port -- )
+    dup port-timeout dup zero? [
+        2drop
+    ] [
+        millis + over set-port-cutoff
+        dup unqueue-timeout queue-timeout
+    ] if ;
+
 M: port set-timeout
     [ set-port-timeout ] keep touch-port ;
 
@@ -157,7 +188,7 @@ GENERIC: port-flush ( port -- )
 M: output-port stream-flush ( port -- )
     dup port-flush pending-error ;
 
-M: port stream-close
+M: port dispose
     dup port-type closed eq? [
         dup port-type >r closed over set-port-type r>
         output-port eq? [ dup port-flush ] when

extra/io/server/server.factor

@@ -29,8 +29,7 @@ SYMBOL: log-stream
 
 : with-log-file ( file quot -- )
     >r <file-appender> r>
-    [ [ with-log-stream ] 2keep ]
+    [ with-log-stream ] with-disposal ; inline
-    [ drop stream-close ] [ ] cleanup ; inline
 
 : with-log-stdio ( quot -- )
     stdio get swap with-log-stream ;
@@ -52,7 +51,7 @@ SYMBOL: log-stream
     [ swap accept with-client ] 2keep accept-loop ; inline
 
 : server-loop ( server quot -- )
-    [ accept-loop ] [ drop stream-close ] [ ] cleanup ; inline
+    [ accept-loop ] compose with-disposal ; inline
 
 : spawn-server ( addrspec quot -- )
     "Waiting for connections on " pick unparse append
@@ -87,8 +86,7 @@ SYMBOL: log-stream
 
 : spawn-datagrams ( quot addrspec -- )
     "Waiting for datagrams on " over unparse append log-message
-    <datagram> [ datagram-loop ] [ stream-close ] [ ] cleanup ;
+    <datagram> [ datagram-loop ] with-disposal ; inline
-    inline
 
 : with-datagrams ( seq service quot -- )
     [

extra/io/sockets/sockets-docs.factor

@@ -1,5 +1,5 @@
 USING: help.markup help.syntax io io.backend threads
-strings byte-arrays ;
+strings byte-arrays continuations ;
 IN: io.sockets
 
 ARTICLE: "network-addressing" "Address specifiers"
@@ -19,7 +19,7 @@ ARTICLE: "network-connection" "Connection-oriented networking"
 { $subsection accept }
 "The stream returned by " { $link accept } " holds the address specifier of the remote client:"
 { $subsection client-stream-addr }
-"Server sockets are closed by calling " { $link stream-close } ", but they do not respond to the rest of the stream protocol."
+"Server sockets are closed by calling " { $link dispose } "."
 $nl
 "Address specifiers have the following interpretation with connection-oriented networking words:"
 { $list
@@ -36,7 +36,7 @@ ARTICLE: "network-packet" "Packet-oriented networking"
 "Packets can be sent and received with a pair of words:"
 { $subsection send }
 { $subsection receive }
-"Packet-oriented sockets are closed by calling " { $link stream-close } ", but they do not respond to the rest of the stream protocol."
+"Packet-oriented sockets are closed by calling " { $link dispose } "."
 $nl
 "Address specifiers have the following interpretation with connection-oriented networking words:"
 { $list
@@ -104,7 +104,7 @@ HELP: <server>
 { $description
     "Begins listening for network connections to a local address. Server objects responds to two words:"
     { $list
-        { { $link stream-close } " - stops listening on the port and frees all associated resources" }
+        { { $link dispose } " - stops listening on the port and frees all associated resources" }
         { { $link accept } " - blocks until there is a connection" }
     }
 }
@@ -128,7 +128,7 @@ HELP: <datagram>
 { $values { "addrspec" "an address specifier" } { "datagram" "a handle" } }
 { $description "Creates a datagram socket bound to a local address. Datagram socket objects responds to three words:"
     { $list
-        { { $link stream-close } " - stops listening on the port and frees all associated resources" }
+        { { $link dispose } " - stops listening on the port and frees all associated resources" }
         { { $link receive } " - waits for a packet" }
         { { $link send } " - sends a packet" }
     }

extra/io/streams/null/null.factor

@@ -5,7 +5,7 @@ USING: kernel io ;
 
 TUPLE: null-stream ;
 
-M: null-stream stream-close drop ;
+M: null-stream dispose drop ;
 M: null-stream set-timeout 2drop ;
 M: null-stream stream-readln drop f ;
 M: null-stream stream-read1 drop f ;

extra/io/unix/mmap/mmap.factor

@@ -15,7 +15,7 @@ M: unix-io <mapped-file> ( path length -- obj )
     dup PROT_READ PROT_WRITE bitor MAP_FILE MAP_SHARED bitor
     r> mmap-open f mapped-file construct-boa ;
 
-M: unix-io (close-mapped-file) ( mmap -- )
+M: unix-io close-mapped-file ( mmap -- )
     [ mapped-file-address ] keep
     [ mapped-file-length munmap ] keep
     mapped-file-handle close

extra/io/unix/sockets/sockets.factor

@@ -15,8 +15,7 @@ libc combinators ;
     #! <client> don't set up error handlers until after <client>
     #! returns (and if they did before, they wouldn't have
     #! anything to close!)
-    dup port-error dup
+    dup port-error dup [ swap dispose throw ] [ 2drop ] if ;
-    [ swap stream-close throw ] [ 2drop ] if ;
 
 : socket-fd ( domain type -- socket )
     0 socket dup io-error dup init-handle ;

extra/io/unix/unix-tests.factor

@@ -63,7 +63,7 @@ yield
 
          "d" get send
 
-        "d" get stream-close
+        "d" get dispose
 
         "Done" print
 
@@ -104,7 +104,7 @@ client-addr <datagram>
     >r >string r>
 ] unit-test
 
-[ ] [ "d" get stream-close ] unit-test
+[ ] [ "d" get dispose ] unit-test
 
 ! Test error behavior
 
@@ -120,7 +120,7 @@ client-addr <datagram>
     B{ 1 2 3 } "unix-domain-datagram-test-3" <local> "d" get send
 ] unit-test-fails
 
-[ ] [ "d" get stream-close ] unit-test
+[ ] [ "d" get dispose ] unit-test
 
 ! See what happens on send/receive after close
 

extra/io/windows/mmap/mmap.factor

@@ -81,7 +81,7 @@ M: windows-io <mapped-file> ( path length -- mmap )
         f \ mapped-file construct-boa
     ] with-destructors ;
 
-M: windows-io (close-mapped-file) ( mapped-file -- )
+M: windows-io close-mapped-file ( mapped-file -- )
     [
         dup mapped-file-handle [ close-always ] each
         mapped-file-address UnmapViewOfFile win32-error=0/f

extra/io/windows/nt/backend/backend.factor

@@ -1,8 +1,8 @@
 USING: alien alien.c-types arrays assocs combinators
 continuations destructors io io.backend io.nonblocking
-io.windows libc kernel math namespaces sequences threads
+io.windows libc kernel math namespaces sequences
-tuples.lib windows windows.errors windows.kernel32 strings
+threads tuples.lib windows windows.errors windows.kernel32
-splitting io.files qualified ;
+strings splitting io.files qualified ;
 QUALIFIED: windows.winsock
 IN: io.windows.nt.backend
 
@@ -122,19 +122,11 @@ M: windows-nt-io add-completion ( handle -- )
 : drain-overlapped ( timeout -- )
     handle-overlapped [ 0 drain-overlapped ] unless ;
 
-: maybe-expire ( io-callbck -- )
+M: windows-nt-io expire-port
-    io-callback-port
+    port-handle win32-file-handle CancelIo drop ;
-    dup timeout? [
-        port-handle win32-file-handle CancelIo drop
-    ] [
-        drop
-    ] if ;
-
-: cancel-timeout ( -- )
-    io-hash get-global [ nip maybe-expire ] assoc-each ;
 
 M: windows-nt-io io-multiplex ( ms -- )
-    cancel-timeout drain-overlapped ;
+    expire-timeouts drain-overlapped ;
 
 M: windows-nt-io init-io ( -- )
     <master-completion-port> master-completion-port set-global

extra/io/windows/nt/monitor/monitor.factor

@@ -34,8 +34,6 @@ M: windows-nt-io <monitor> ( path recursive? -- monitor )
 : check-closed ( monitor -- )
     port-type closed eq? [ "Monitor closed" throw ] when ;
 
-M: windows-nt-io close-monitor ( monitor -- ) stream-close ;
-
 : begin-reading-changes ( monitor -- overlapped )
     dup port-handle win32-file-handle
     over buffer-ptr

extra/io/windows/windows.factor

@@ -1,10 +1,11 @@
-! Copyright (C) 2004, 2007 Mackenzie Straight, Doug Coleman.
+! Copyright (C) 2004, 2008 Mackenzie Straight, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types arrays destructors io io.backend
 io.buffers io.files io.nonblocking io.sockets io.binary
 io.sockets.impl windows.errors strings io.streams.duplex kernel
 math namespaces sequences windows windows.kernel32
-windows.shell32 windows.types windows.winsock splitting ;
+windows.shell32 windows.types windows.winsock splitting
+continuations ;
 IN: io.windows
 
 TUPLE: windows-nt-io ;
@@ -174,7 +175,7 @@ USE: namespaces
 : listen-on-socket ( socket -- )
     listen-backlog listen winsock-return-check ;
 
-M: win32-socket stream-close ( stream -- )
+M: win32-socket dispose ( stream -- )
     win32-file-handle closesocket drop ;
 
 M: windows-io addrinfo-error ( n -- )

extra/irc/irc.factor

@@ -185,7 +185,7 @@ SYMBOL: line
     dup irc-client-profile profile-server
     over irc-client-profile profile-port connect*
     dup irc-client-profile profile-nickname login
-    [ irc-loop ] [ irc-stream> stream-close ] [ ] cleanup ;
+    [ irc-loop ] [ irc-stream> dispose ] [ ] cleanup ;
 
 : with-infinite-loop ( quot timeout -- quot timeout )
     "looping" print flush

extra/tar/tar.factor

@@ -95,7 +95,7 @@ TUPLE: unimplemented-typeflag header ;
 ! Normal file
 : typeflag-0
   tar-header-name tar-path+ <file-writer>
-  [ read-data-blocks ] keep stream-close ;
+  [ read-data-blocks ] keep dispose ;
 
 ! Hard link
 : typeflag-1 ( header -- )
@@ -221,7 +221,7 @@ TUPLE: unimplemented-typeflag header ;
             [ <unknown-typeflag> throw ]
         } case
         ! dup tar-header-size zero? [
-            ! out-stream get [ stream-close ] when
+            ! out-stream get [ dispose ] when
             ! out-stream off
             ! drop
         ! ] [

extra/tools/deploy/backend/backend.factor

@@ -9,15 +9,16 @@ quotations io.launcher words.private tools.deploy.config
 bootstrap.image ;
 IN: tools.deploy.backend
 
-: (copy-lines) ( stream -- stream )
+: (copy-lines) ( stream -- )
-    dup stream-readln [ print flush (copy-lines) ] when* ;
+    dup stream-readln dup
+    [ print flush (copy-lines) ] [ 2drop ] if ;
 
 : copy-lines ( stream -- )
-    [ (copy-lines) ] [ stream-close ] [ ] cleanup ;
+    [ (copy-lines) ] with-disposal ;
 
 : run-with-output ( descriptor -- )
     <process-stream>
-    dup duplex-stream-out stream-close
+    dup duplex-stream-out dispose
     copy-lines ;
 
 : boot-image-name ( -- string )

extra/ui/gadgets/panes/panes.factor

@@ -8,7 +8,7 @@ hashtables io kernel namespaces sequences io.styles strings
 quotations math opengl combinators math.vectors
 io.streams.duplex sorting splitting io.streams.nested assocs
 ui.gadgets.presentations ui.gadgets.slots ui.gadgets.grids
-ui.gadgets.grid-lines tuples models ;
+ui.gadgets.grid-lines tuples models continuations ;
 IN: ui.gadgets.panes
 
 TUPLE: pane output current prototype scrolls?
@@ -161,7 +161,7 @@ M: pane-stream stream-write
 M: pane-stream stream-format
     [ rot string-lines pane-format ] do-pane-stream ;
 
-M: pane-stream stream-close drop ;
+M: pane-stream dispose drop ;
 
 M: pane-stream stream-flush drop ;
 
@@ -249,7 +249,7 @@ TUPLE: nested-pane-stream style parent ;
 
 TUPLE: pane-block-stream ;
 
-M: pane-block-stream stream-close
+M: pane-block-stream dispose
     unnest-pane-stream write-gadget ;
 
 M: pane-stream make-block-stream
@@ -272,7 +272,7 @@ M: pane-stream make-block-stream
 
 TUPLE: pane-cell-stream ;
 
-M: pane-cell-stream stream-close ?nl ;
+M: pane-cell-stream dispose ?nl ;
 
 M: pane-stream make-cell-stream
     <nested-pane-stream> pane-cell-stream construct-delegate ;
@@ -284,9 +284,9 @@ M: pane-stream stream-write-table
     r> print-gadget ;
 
 ! Stream utilities
-M: pack stream-close drop ;
+M: pack dispose drop ;
 
-M: paragraph stream-close drop ;
+M: paragraph dispose drop ;
 
 : gadget-write ( string gadget -- )
     over empty? [