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
+    dup full?>>
-    t over set-box-full?
+    [ box-full ] [ t >>full? (>>value) ] if ;
-    set-box-value ;
+
+ERROR: box-empty box ;
 
 : box> ( box -- value )
-    dup box-full? [ "Box empty" throw ] unless
+    dup full?>>
-    dup box-value f pick set-box-value
+    [ [ f ] change-value f >>full? drop ] [ box-empty ] if ;
-    f rot set-box-full? ;
 
 : ?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 [
+    number>string* dup [ utf8 malloc-string &free ] when 0 ;
-        utf8 malloc-string dup free-always
-    ] 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-free ( alien -- alien )
-    <postgresql-malloc-destructor> add-always-destructor ;
+    <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." }
+{ $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." }
+{ $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 -- )
+SYMBOL: error-destructors
-    error-destructors get push ;
-
-: add-always-destructor ( obj -- )
-    always-destructors get push ;
 
 : 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 -- )
+: &free ( alien -- alien )
-    <memory-destructor> <only-once> add-always-destructor ;
+    <memory-destructor> <only-once> &dispose ; inline
 
-: free-later ( alien -- )
+: |free ( alien -- alien )
-    <memory-destructor> <only-once> add-error-destructor ;
+    <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)
+        >r (pipe) |dispose
-        [ add-error-destructor ]
+        [ in>> <input-port> ] [ out>> <output-port> ] bi
-        [ in>> <input-port> ]
-        [ out>> <output-port> ]
-        tri
         r> <encoder-duplex>
     ] with-destructors ;
 
 <PRIVATE
 
-: ?reader [ <input-port> dup add-always-destructor ] [ input-stream get ] if* ;
+: ?reader [ <input-port> &dispose ] [ input-stream get ] if* ;
-: ?writer [ <output-port> dup add-always-destructor ] [ output-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 -- )
+: &close-handle ( handle -- handle )
-    <handle-destructor> <only-once> add-always-destructor ;
+    <handle-destructor> <only-once> &dispose ; inline
 
-: close-later ( handle -- )
+: |close-handle ( handle -- handle )
-    <handle-destructor> <only-once> add-error-destructor ;
+    <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 ]
+        [ <input-port> |dispose ]
-        [ <output-port> dup add-error-destructor ] bi*
+        [ <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 )
+GENERIC: establish-connection ( client-out remote -- )
-    [ (wait-to-connect) ] keep parse-sockaddr ;
 
 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 [ |dispose drop ] bi@ ] keep
-            ((client))
+        [ establish-connection ] [ drop ] [ get-local-address ] 2tri
-            dup <ports>
-            2dup [ add-error-destructor ] bi@
-            dup dup handle>>
-        ] keep wait-to-connect
     ] 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
+        |close-handle
-        <ssl-socket> dup close-later
+        <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 -- )
+M: fd get-local-address ( handle remote -- sockaddr )
-    SOL_SOCKET SO_OOBINLINE set-socket-option ;
-
-: get-socket-name ( fd addrspec -- sockaddr )
     >r handle-fd r> empty-sockaddr/size
     [ getsockname io-error ] 2keep drop ;
 
-: get-peer-name ( fd addrspec -- sockaddr )
+: init-client-socket ( fd -- )
-    >r handle-fd r> empty-sockaddr/size
+    SOL_SOCKET SO_OOBINLINE set-socket-option ;
-    [ getpeername io-error ] 2keep drop ;
 
-M: fd (wait-to-connect)
+: wait-to-connect ( port -- )
-    >r >r +output+ wait-for-port r> r> get-socket-name ;
+    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
+    protocol-family SOCK_STREAM socket-fd dup init-client-socket ;
-    >r >r dup handle-fd r> r> connect zero? err_no EINPROGRESS = or
-    [ dup init-client-socket ] [ (io-error) ] if ;
 
 ! 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 ssl-error V{ } clone openssl-context boa |dispose
-        dup add-error-destructor
         {
             [ 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
+        windows-crypto-context &dispose
-        dup add-always-destructor handle>>
+        handle>> swap dup <byte-array>
-        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
+            helo get-ok
-        dup to>> [ rcpt-to get-ok ] each
+            dup from>> mail-from get-ok
-        data get-ok
+            dup to>> [ rcpt-to get-ok ] each
-        dup headers>> write-headers
+            data get-ok
-        crlf
+            dup headers>> write-headers
-        body>> send-body get-ok
+            crlf
-        quit get-ok
+            body>> send-body get-ok
+            quit get-ok USING: continuations debugger ;
+        ] [ global [ error. :c ] bind ] recover
     ] with-smtp-connection ;
 
 : extract-email ( recepient -- email )