Destructor changes

core/boxes/boxes.factor

@@ -1,24 +1,26 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel ;
+USING: kernel accessors ;
 IN: boxes
 
 TUPLE: box value full? ;
 
 : <box> ( -- box ) box new ;
 
+ERROR: box-full box ;
+
 : >box ( value box -- )
-    dup box-full? [ "Box already has a value" throw ] when
-    t over set-box-full?
-    set-box-value ;
+    dup full?>>
+    [ box-full ] [ t >>full? (>>value) ] if ;
+
+ERROR: box-empty box ;
 
 : box> ( box -- value )
-    dup box-full? [ "Box empty" throw ] unless
-    dup box-value f pick set-box-value
-    f rot set-box-full? ;
+    dup full?>>
+    [ [ f ] change-value f >>full? drop ] [ box-empty ] if ;
 
 : ?box ( box -- value/f ? )
-    dup box-full? [ box> t ] [ drop f f ] if ;
+    dup full?>> [ box> t ] [ drop f f ] if ;
 
 : if-box? ( box quot -- )
     >r ?box r> [ drop ] if ; inline

extra/concurrency/distributed/distributed-tests.factor

@@ -13,7 +13,7 @@ concurrency.messaging continuations ;
 
 [ ] [ test-node dup 1array swap (start-node) ] unit-test
 
-[ ] [ yield ] unit-test
+[ ] [ 1000 sleep ] unit-test
 
 [ ] [
     [

extra/db/pooling/pooling.factor

@@ -40,4 +40,4 @@ M: return-connection dispose
     [ db>> ] [ pool>> ] bi return-connection ;
 
 : return-connection-later ( db pool -- )
-    \ return-connection boa add-always-destructor ;
+    \ return-connection boa &dispose drop ;

extra/db/postgresql/lib/lib.factor

@@ -67,12 +67,10 @@ M: postgresql-result-null summary ( obj -- str )
     in-params>> [ type>> type>oid ] map >c-uint-array ;
 
 : malloc-byte-array/length
-    [ malloc-byte-array dup free-always ] [ length ] bi ;
+    [ malloc-byte-array &free ] [ length ] bi ;
 
 : default-param-value
-    number>string* dup [
-        utf8 malloc-string dup free-always
-    ] when 0 ;
+    number>string* dup [ utf8 malloc-string &free ] when 0 ;
 
 : param-values ( statement -- seq seq2 )
     [ bind-params>> ] [ in-params>> ] bi
@@ -128,8 +126,8 @@ C: <postgresql-malloc-destructor> postgresql-malloc-destructor
 M: postgresql-malloc-destructor dispose ( obj -- )
     alien>> PQfreemem ;
 
-: postgresql-free-always ( alien -- )
-    <postgresql-malloc-destructor> add-always-destructor ;
+: &postgresql-free ( alien -- alien )
+    <postgresql-malloc-destructor> &dispose ; inline
 
 : pq-get-blob ( handle row column -- obj/f )
     [ PQgetvalue ] 3keep 3dup PQgetlength
@@ -142,7 +140,7 @@ M: postgresql-malloc-destructor dispose ( obj -- )
                 PQunescapeBytea dup zero? [
                     postgresql-result-error-message throw
                 ] [
-                    dup postgresql-free-always
+                    &postgresql-free
                 ] if
             ] keep
             *uint memory>byte-array

extra/destructors/destructors-docs.factor

@@ -1,20 +1,16 @@
 USING: help.markup help.syntax libc kernel continuations ;
 IN: destructors
 
-HELP: free-always
-{ $values { "alien" "alien returned by malloc" } }
-{ $description "Adds a destructor that will " { $link free } " the alien.  The free will happen whenever the quotation passed to " { $link with-destructors } " ends." }
-{ $see-also free-later } ;
-
-HELP: free-later
-{ $values { "alien" "alien returned by malloc" } }
-{ $description "Adds a destructor that will " { $link free } " the alien.  The free will happen whenever the quotation passed to " { $link with-destructors } " errors or else the object will persist and manual cleanup is required later." }
-{ $see-also free-always } ;
-
 HELP: with-destructors
 { $values { "quot" "a quotation" } }
-{ $description "Calls a quotation within a new dynamic scope.  This quotation may register destructors, on any object, by wrapping the object in a destructor and implementing " { $link dispose } " on that object type.  After the quotation finishes, if an error was thrown, all destructors are called and the error is then rethrown.  However, if the quotation was successful, only those destructors created with an 'always cleanup' flag will be destroyed." }
-{ $notes "Destructors are not allowed to throw exceptions.  No exceptions." }
+{ $description "Calls a quotation within a new dynamic scope. This quotation may register destructors, on any object, by wrapping the object in a destructor and implementing " { $link dispose } " on that object type.  After the quotation finishes, if an error was thrown, all destructors are called and the error is then rethrown.  However, if the quotation was successful, only those destructors created with an 'always cleanup' flag will be destroyed." }
+{ $notes
+    "Destructors generalize " { $link with-disposal } ". The following two lines are equivalent:"
+    { $code
+        "[ X ] with-disposal"
+        "[ &dispose X ] with-destructors"
+    }
+}
 { $examples
-    { $code "[ 10 malloc free-always ] with-destructors" }
+    { $code "[ 10 malloc &free ] with-destructors" }
 } ;

extra/destructors/destructors-tests.factor

@@ -13,10 +13,10 @@ M: dummy-destructor dispose ( obj -- )
     dummy-destructor-obj t swap set-dummy-obj-destroyed? ;
 
 : destroy-always
-    <dummy-destructor> add-always-destructor ;
+    <dummy-destructor> &dispose drop ;
 
 : destroy-later
-    <dummy-destructor> add-error-destructor ;
+    <dummy-destructor> |dispose drop ;
 
 [ t ] [
     [

extra/destructors/destructors.factor

@@ -4,14 +4,11 @@ USING: accessors continuations io.backend libc
 kernel namespaces sequences system vectors ;
 IN: destructors
 
-SYMBOL: error-destructors
+<PRIVATE
+
 SYMBOL: always-destructors
 
-: add-error-destructor ( obj -- )
-    error-destructors get push ;
-
-: add-always-destructor ( obj -- )
-    always-destructors get push ;
+SYMBOL: error-destructors
 
 : do-always-destructors ( -- )
     always-destructors get <reversed> dispose-each ;
@@ -19,6 +16,12 @@ SYMBOL: always-destructors
 : do-error-destructors ( -- )
     error-destructors get <reversed> dispose-each ;
 
+PRIVATE>
+
+: &dispose dup always-destructors get push ; inline
+
+: |dispose dup error-destructors get push ; inline
+
 : with-destructors ( quot -- )
     [
         V{ } clone always-destructors set
@@ -44,8 +47,8 @@ C: <memory-destructor> memory-destructor
 M: memory-destructor dispose ( obj -- )
     alien>> free ;
 
-: free-always ( alien -- )
-    <memory-destructor> <only-once> add-always-destructor ;
+: &free ( alien -- alien )
+    <memory-destructor> <only-once> &dispose ; inline
 
-: free-later ( alien -- )
-    <memory-destructor> <only-once> add-error-destructor ;
+: |free ( alien -- alien )
+    <memory-destructor> <only-once> |dispose ; inline

extra/http/server/auth/login/login.factor

@@ -58,7 +58,7 @@ M: user-saver dispose
     user>> dup changed?>> [ users update-user ] [ drop ] if ;
 
 : save-user-after ( user -- )
-    <user-saver> add-always-destructor ;
+    <user-saver> &dispose drop ;
 
 : login-template ( name -- template )
     "resource:extra/http/server/auth/login/" swap ".xml"

extra/http/server/sessions/sessions.factor

@@ -102,7 +102,7 @@ M: session-saver dispose
     ] [ drop ] if ;
 
 : save-session-after ( session -- )
-    <session-saver> add-always-destructor ;
+    <session-saver> &dispose drop ;
 
 : existing-session ( path session -- response )
     [ session set ] [ save-session-after ] bi

extra/io/launcher/launcher.factor

@@ -158,7 +158,7 @@ M: object run-pipeline-element
 : <process-reader*> ( process encoding -- process stream )
     [
         >r (pipe) {
-            [ add-error-destructor ]
+            [ |dispose drop ]
             [
                 swap >process
                     [ swap out>> or ] change-stdout
@@ -175,7 +175,7 @@ M: object run-pipeline-element
 : <process-writer*> ( process encoding -- process stream )
     [
         >r (pipe) {
-            [ add-error-destructor ]
+            [ |dispose drop ]
             [
                 swap >process
                     [ swap in>> or ] change-stdout
@@ -192,7 +192,7 @@ M: object run-pipeline-element
 : <process-stream*> ( process encoding -- process stream )
     [
         >r (pipe) (pipe) {
-            [ [ add-error-destructor ] bi@ ]
+            [ [ |dispose drop ] bi@ ]
             [
                 rot >process
                     [ swap out>> or ] change-stdout

extra/io/pipes/pipes.factor

@@ -15,18 +15,15 @@ HOOK: (pipe) io-backend ( -- pipe )
 
 : <pipe> ( encoding -- stream )
     [
-        >r (pipe)
-        [ add-error-destructor ]
-        [ in>> <input-port> ]
-        [ out>> <output-port> ]
-        tri
+        >r (pipe) |dispose
+        [ in>> <input-port> ] [ out>> <output-port> ] bi
         r> <encoder-duplex>
     ] with-destructors ;
 
 <PRIVATE
 
-: ?reader [ <input-port> dup add-always-destructor ] [ input-stream get ] if* ;
-: ?writer [ <output-port> dup add-always-destructor ] [ output-stream get ] if* ;
+: ?reader [ <input-port> &dispose ] [ input-stream get ] if* ;
+: ?writer [ <output-port> &dispose ] [ output-stream get ] if* ;
 
 GENERIC: run-pipeline-element ( input-fd output-fd obj -- quot )
 
@@ -38,7 +35,7 @@ M: callable run-pipeline-element
 
 : <pipes> ( n -- pipes )
     [
-        [ (pipe) dup add-error-destructor ] replicate
+        [ (pipe) |dispose ] replicate
         T{ pipe } [ prefix ] [ suffix ] bi
         2 <clumps>
     ] with-destructors ;

extra/io/ports/ports.factor

@@ -27,11 +27,11 @@ C: <handle-destructor> handle-destructor
 M: handle-destructor dispose ( obj -- )
     handle>> close-handle ;
 
-: close-always ( handle -- )
-    <handle-destructor> <only-once> add-always-destructor ;
+: &close-handle ( handle -- handle )
+    <handle-destructor> <only-once> &dispose ; inline
 
-: close-later ( handle -- )
-    <handle-destructor> <only-once> add-error-destructor ;
+: |close-handle ( handle -- handle )
+    <handle-destructor> <only-once> |dispose ; inline
 
 : <port> ( handle class -- port )
     new
@@ -161,6 +161,6 @@ M: port dispose
 
 : <ports> ( read-handle write-handle -- input-port output-port )
     [
-        [ <input-port> dup add-error-destructor ]
-        [ <output-port> dup add-error-destructor ] bi*
+        [ <input-port> |dispose ]
+        [ <output-port> |dispose ] bi*
     ] with-destructors ;

extra/io/sockets/sockets.factor

@@ -151,10 +151,9 @@ M: inet6 parse-sockaddr
 
 M: f parse-sockaddr nip ;
 
-GENERIC# (wait-to-connect) 1 ( client-out handle remote -- sockaddr )
+GENERIC# get-local-address 1 ( handle remote -- sockaddr )
 
-: wait-to-connect ( client-out handle remote -- local )
-    [ (wait-to-connect) ] keep parse-sockaddr ;
+GENERIC: establish-connection ( client-out remote -- )
 
 GENERIC: ((client)) ( remote -- handle )
 
@@ -164,12 +163,8 @@ M: array (client) [ (client) 3array ] attempt-all first3 ;
 
 M: object (client) ( remote -- client-in client-out local )
     [
-        [
-            ((client))
-            dup <ports>
-            2dup [ add-error-destructor ] bi@
-            dup dup handle>>
-        ] keep wait-to-connect
+        [ ((client)) dup <ports> 2dup [ |dispose drop ] bi@ ] keep
+        [ establish-connection ] [ drop ] [ get-local-address ] 2tri
     ] with-destructors ;
 
 : <client> ( remote encoding -- stream local )

extra/io/unix/files/files.factor

@@ -33,7 +33,7 @@ M: unix (file-writer) ( path -- stream )
 
 : open-append ( path -- fd )
     [
-        append-flags file-mode open-file dup close-later
+        append-flags file-mode open-file |close-handle
         dup 0 SEEK_END lseek io-error
     ] with-destructors ;
 

extra/io/unix/mmap/mmap.factor

@@ -9,7 +9,7 @@ IN: io.unix.mmap
 :: mmap-open ( length prot flags path -- alien fd )
     [
         f length prot flags
-        path open-r/w dup close-later
+        path open-r/w |close-handle
         [ 0 mmap dup MAP_FAILED = [ (io-error) ] when ] keep
     ] with-destructors ;
 

extra/io/unix/sockets/secure/secure.factor

@@ -119,8 +119,8 @@ M: ssl (accept)
     [
         addrspec>>
         (accept) >r
-        dup close-later
-        <ssl-socket> dup close-later
+        |close-handle
+        <ssl-socket> |close-handle
         dup do-ssl-accept
         r>
     ] with-destructors ;

extra/io/unix/sockets/sockets.factor

@@ -13,7 +13,7 @@ EXCLUDE: io.sockets => accept ;
 IN: io.unix.sockets
 
 : socket-fd ( domain type -- fd )
-    0 socket dup io-error <fd> [ close-later ] [ init-handle ] [ ] tri ;
+    0 socket dup io-error <fd> |close-handle dup init-handle ;
 
 : set-socket-option ( fd level opt -- )
     >r >r handle-fd r> r> 1 <int> "int" heap-size setsockopt io-error ;
@@ -22,24 +22,34 @@ M: unix addrinfo-error ( n -- )
     dup zero? [ drop ] [ gai_strerror throw ] if ;
 
 ! Client sockets - TCP and Unix domain
-: init-client-socket ( fd -- )
-    SOL_SOCKET SO_OOBINLINE set-socket-option ;
-
-: get-socket-name ( fd addrspec -- sockaddr )
+M: fd get-local-address ( handle remote -- sockaddr )
     >r handle-fd r> empty-sockaddr/size
     [ getsockname io-error ] 2keep drop ;
 
-: get-peer-name ( fd addrspec -- sockaddr )
-    >r handle-fd r> empty-sockaddr/size
-    [ getpeername io-error ] 2keep drop ;
+: init-client-socket ( fd -- )
+    SOL_SOCKET SO_OOBINLINE set-socket-option ;
 
-M: fd (wait-to-connect)
-    >r >r +output+ wait-for-port r> r> get-socket-name ;
+: wait-to-connect ( port -- )
+    dup handle>> handle-fd f 0 write
+    {
+        { [ 0 = ] [ drop f ] }
+        { [ err_no EAGAIN = ] [ dup +output+ wait-for-port wait-to-connect ] }
+        { [ err_no EINTR = ] [ wait-to-connect ] }
+        [ (io-error) ]
+    } cond ;
+
+M: object establish-connection ( client-out remote -- )
+    [ drop ] [ [ handle-fd ] [ make-sockaddr/size ] bi* connect ] 2bi
+    {
+        { [ 0 = ] [ ] }
+        { [ err_no EINPROGRESS = ] [
+            [ +output+ wait-for-port ] [ check-connection ] [ ] tri
+        ] }
+        [ (io-error) ]
+    } cond ;
 
 M: object ((client)) ( addrspec -- fd )
-    [ protocol-family SOCK_STREAM socket-fd ] [ make-sockaddr/size ] bi
-    >r >r dup handle-fd r> r> connect zero? err_no EINPROGRESS = or
-    [ dup init-client-socket ] [ (io-error) ] if ;
+    protocol-family SOCK_STREAM socket-fd dup init-client-socket ;
 
 ! Server sockets - TCP and Unix domain
 : init-server-socket ( fd -- )

extra/io/windows/windows.factor

@@ -185,7 +185,7 @@ M: socket-destructor dispose ( obj -- )
     alien>> destruct-socket ;
 
 : close-socket-later ( handle -- )
-    <socket-destructor> <only-once> add-error-destructor ;
+    <socket-destructor> <only-once> |dispose drop ;
 
 : server-fd ( addrspec type -- fd )
     >r dup protocol-family r> open-socket

extra/openssl/openssl.factor

@@ -103,8 +103,7 @@ M: openssl <ssl-context> ( config -- context )
     maybe-init-ssl
     [
         dup method>> ssl-method SSL_CTX_new
-        dup ssl-error V{ } clone openssl-context boa
-        dup add-error-destructor
+        dup ssl-error V{ } clone openssl-context boa |dispose
         {
             [ load-certificate-chain ]
             [ set-default-password ]

extra/random/windows/windows.factor

@@ -36,9 +36,8 @@ M: windows-crypto-context dispose ( tuple -- )
 M: windows-rng random-bytes* ( n tuple -- bytes )
     [
         [ provider>> ] [ type>> ] bi
-        windows-crypto-context
-        dup add-always-destructor handle>>
-        swap dup <byte-array>
+        windows-crypto-context &dispose
+        handle>> swap dup <byte-array>
         [ CryptGenRandom win32-error=0/f ] keep
     ] with-destructors ;
 

extra/smtp/smtp.factor

@@ -110,14 +110,16 @@ M: email clone
 
 : (send) ( email -- )
     [
-        helo get-ok
-        dup from>> mail-from get-ok
-        dup to>> [ rcpt-to get-ok ] each
-        data get-ok
-        dup headers>> write-headers
-        crlf
-        body>> send-body get-ok
-        quit get-ok
+        [
+            helo get-ok
+            dup from>> mail-from get-ok
+            dup to>> [ rcpt-to get-ok ] each
+            data get-ok
+            dup headers>> write-headers
+            crlf
+            body>> send-body get-ok
+            quit get-ok USING: continuations debugger ;
+        ] [ global [ error. :c ] bind ] recover
     ] with-smtp-connection ;
 
 : extract-email ( recepient -- email )