diff --git a/core/boxes/boxes.factor b/core/boxes/boxes.factor index b56a46b6b3..42b329b84b 100755 --- a/core/boxes/boxes.factor +++ b/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 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 diff --git a/extra/concurrency/distributed/distributed-tests.factor b/extra/concurrency/distributed/distributed-tests.factor index e2abd6deb9..840c5efa36 100755 --- a/extra/concurrency/distributed/distributed-tests.factor +++ b/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 [ ] [ [ diff --git a/extra/db/pooling/pooling.factor b/extra/db/pooling/pooling.factor index 83820294d6..1be05d5d72 100644 --- a/extra/db/pooling/pooling.factor +++ b/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 ; diff --git a/extra/db/postgresql/lib/lib.factor b/extra/db/postgresql/lib/lib.factor index 8b0026b6e5..cd079690e3 100755 --- a/extra/db/postgresql/lib/lib.factor +++ b/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 M: postgresql-malloc-destructor dispose ( obj -- ) alien>> PQfreemem ; -: postgresql-free-always ( alien -- ) - add-always-destructor ; +: &postgresql-free ( alien -- alien ) + &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 diff --git a/extra/destructors/destructors-docs.factor b/extra/destructors/destructors-docs.factor index e9f6002efa..28f8858597 100755 --- a/extra/destructors/destructors-docs.factor +++ b/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" } } ; diff --git a/extra/destructors/destructors-tests.factor b/extra/destructors/destructors-tests.factor index 59c325c490..18f50bf760 100755 --- a/extra/destructors/destructors-tests.factor +++ b/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 - add-always-destructor ; + &dispose drop ; : destroy-later - add-error-destructor ; + |dispose drop ; [ t ] [ [ diff --git a/extra/destructors/destructors.factor b/extra/destructors/destructors.factor index 3d5e19520f..86f8fa1f48 100755 --- a/extra/destructors/destructors.factor +++ b/extra/destructors/destructors.factor @@ -4,14 +4,11 @@ USING: accessors continuations io.backend libc kernel namespaces sequences system vectors ; IN: destructors -SYMBOL: error-destructors + dispose-each ; @@ -19,6 +16,12 @@ SYMBOL: always-destructors : do-error-destructors ( -- ) error-destructors get 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 M: memory-destructor dispose ( obj -- ) alien>> free ; -: free-always ( alien -- ) - add-always-destructor ; +: &free ( alien -- alien ) + &dispose ; inline -: free-later ( alien -- ) - add-error-destructor ; +: |free ( alien -- alien ) + |dispose ; inline diff --git a/extra/http/server/auth/login/login.factor b/extra/http/server/auth/login/login.factor index 9f1fe6fe77..bb77532a22 100755 --- a/extra/http/server/auth/login/login.factor +++ b/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 -- ) - add-always-destructor ; + &dispose drop ; : login-template ( name -- template ) "resource:extra/http/server/auth/login/" swap ".xml" diff --git a/extra/http/server/sessions/sessions.factor b/extra/http/server/sessions/sessions.factor index fe32327c24..a7e1a141c4 100755 --- a/extra/http/server/sessions/sessions.factor +++ b/extra/http/server/sessions/sessions.factor @@ -102,7 +102,7 @@ M: session-saver dispose ] [ drop ] if ; : save-session-after ( session -- ) - add-always-destructor ; + &dispose drop ; : existing-session ( path session -- response ) [ session set ] [ save-session-after ] bi diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index 54c97bdb0e..90eea091d5 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -158,7 +158,7 @@ M: object run-pipeline-element : ( 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 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 encoding -- process stream ) [ >r (pipe) (pipe) { - [ [ add-error-destructor ] bi@ ] + [ [ |dispose drop ] bi@ ] [ rot >process [ swap out>> or ] change-stdout diff --git a/extra/io/pipes/pipes.factor b/extra/io/pipes/pipes.factor index a3315d02ca..ef6b200f64 100644 --- a/extra/io/pipes/pipes.factor +++ b/extra/io/pipes/pipes.factor @@ -15,18 +15,15 @@ HOOK: (pipe) io-backend ( -- pipe ) : ( encoding -- stream ) [ - >r (pipe) - [ add-error-destructor ] - [ in>> ] - [ out>> ] - tri + >r (pipe) |dispose + [ in>> ] [ out>> ] bi r> ] with-destructors ; dup add-always-destructor ] [ input-stream get ] if* ; -: ?writer [ dup add-always-destructor ] [ output-stream get ] if* ; +: ?reader [ &dispose ] [ input-stream get ] if* ; +: ?writer [ &dispose ] [ output-stream get ] if* ; GENERIC: run-pipeline-element ( input-fd output-fd obj -- quot ) @@ -38,7 +35,7 @@ M: callable run-pipeline-element : ( n -- pipes ) [ - [ (pipe) dup add-error-destructor ] replicate + [ (pipe) |dispose ] replicate T{ pipe } [ prefix ] [ suffix ] bi 2 ] with-destructors ; diff --git a/extra/io/ports/ports.factor b/extra/io/ports/ports.factor index 16e089a4a6..2b1d62aaeb 100755 --- a/extra/io/ports/ports.factor +++ b/extra/io/ports/ports.factor @@ -27,11 +27,11 @@ C: handle-destructor M: handle-destructor dispose ( obj -- ) handle>> close-handle ; -: close-always ( handle -- ) - add-always-destructor ; +: &close-handle ( handle -- handle ) + &dispose ; inline -: close-later ( handle -- ) - add-error-destructor ; +: |close-handle ( handle -- handle ) + |dispose ; inline : ( handle class -- port ) new @@ -161,6 +161,6 @@ M: port dispose : ( read-handle write-handle -- input-port output-port ) [ - [ dup add-error-destructor ] - [ dup add-error-destructor ] bi* + [ |dispose ] + [ |dispose ] bi* ] with-destructors ; diff --git a/extra/io/sockets/sockets.factor b/extra/io/sockets/sockets.factor index 1075858346..ac58a54bb8 100755 --- a/extra/io/sockets/sockets.factor +++ b/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 - 2dup [ add-error-destructor ] bi@ - dup dup handle>> - ] keep wait-to-connect + [ ((client)) dup 2dup [ |dispose drop ] bi@ ] keep + [ establish-connection ] [ drop ] [ get-local-address ] 2tri ] with-destructors ; : ( remote encoding -- stream local ) diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor index 27dcc01889..33cc25d60c 100755 --- a/extra/io/unix/files/files.factor +++ b/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 ; diff --git a/extra/io/unix/mmap/mmap.factor b/extra/io/unix/mmap/mmap.factor index 3798f422d8..8a98e4795f 100755 --- a/extra/io/unix/mmap/mmap.factor +++ b/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 ; diff --git a/extra/io/unix/sockets/secure/secure.factor b/extra/io/unix/sockets/secure/secure.factor index 14cd9fdb6f..1d240057b0 100644 --- a/extra/io/unix/sockets/secure/secure.factor +++ b/extra/io/unix/sockets/secure/secure.factor @@ -119,8 +119,8 @@ M: ssl (accept) [ addrspec>> (accept) >r - dup close-later - dup close-later + |close-handle + |close-handle dup do-ssl-accept r> ] with-destructors ; diff --git a/extra/io/unix/sockets/sockets.factor b/extra/io/unix/sockets/sockets.factor index 127f50d1aa..7973ca5164 100755 --- a/extra/io/unix/sockets/sockets.factor +++ b/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 [ close-later ] [ init-handle ] [ ] tri ; + 0 socket dup io-error |close-handle dup init-handle ; : set-socket-option ( fd level opt -- ) >r >r handle-fd r> r> 1 "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 -- ) diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor index 5c0a1c8ecf..4f34153b31 100755 --- a/extra/io/windows/windows.factor +++ b/extra/io/windows/windows.factor @@ -185,7 +185,7 @@ M: socket-destructor dispose ( obj -- ) alien>> destruct-socket ; : close-socket-later ( handle -- ) - add-error-destructor ; + |dispose drop ; : server-fd ( addrspec type -- fd ) >r dup protocol-family r> open-socket diff --git a/extra/openssl/openssl.factor b/extra/openssl/openssl.factor index 6eb2d0dbda..1cffd24cd5 100755 --- a/extra/openssl/openssl.factor +++ b/extra/openssl/openssl.factor @@ -103,8 +103,7 @@ M: openssl ( 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 ] diff --git a/extra/random/windows/windows.factor b/extra/random/windows/windows.factor index 6f47d3e6bf..f376903ecf 100644 --- a/extra/random/windows/windows.factor +++ b/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 + windows-crypto-context &dispose + handle>> swap dup [ CryptGenRandom win32-error=0/f ] keep ] with-destructors ; diff --git a/extra/smtp/smtp.factor b/extra/smtp/smtp.factor index 8fdc0e07a4..f4f2496cc6 100755 --- a/extra/smtp/smtp.factor +++ b/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 )