From a190375c0256803188febc2e14d5e4cd1295bd1f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 14 May 2008 06:08:57 -0500 Subject: [PATCH 01/10] Fixes --- extra/bootstrap/image/upload/upload.factor | 2 +- extra/http/http-tests.factor | 2 ++ extra/http/http.factor | 4 ++-- extra/http/server/server-tests.factor | 1 + extra/io/unix/files/unique/unique.factor | 2 +- 5 files changed, 7 insertions(+), 4 deletions(-) diff --git a/extra/bootstrap/image/upload/upload.factor b/extra/bootstrap/image/upload/upload.factor index e78c3541d4..29c9d5b072 100755 --- a/extra/bootstrap/image/upload/upload.factor +++ b/extra/bootstrap/image/upload/upload.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: http.client checksums checksums.openssl splitting assocs +USING: checksums checksums.openssl splitting assocs kernel io.files bootstrap.image sequences io namespaces io.launcher math io.encodings.ascii ; IN: bootstrap.image.upload diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor index a3b9676aac..daac4d6dd9 100755 --- a/extra/http/http-tests.factor +++ b/extra/http/http-tests.factor @@ -45,6 +45,7 @@ blah [ TUPLE{ request + protocol: http port: 80 method: "GET" path: "/bar" @@ -84,6 +85,7 @@ Host: www.sex.com [ TUPLE{ request + protocol: http port: 80 method: "HEAD" path: "/bar" diff --git a/extra/http/http.factor b/extra/http/http.factor index bbbebda53a..6efbd42fd2 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -265,7 +265,7 @@ cookies ; pick query>> set-at ; : chop-hostname ( str -- str' ) - ":" split1 nip + ":" split1 "//" ?head drop nip CHAR: / over index over length or tail dup empty? [ drop "/" ] when ; @@ -440,7 +440,7 @@ M: https protocol-addr dup host>> [ [ protocol>> protocol>string write "://" write ] [ host>> url-encode write ":" write ] - [ port>> number>string write ] + [ [ port>> ] [ protocol>> http-port or ] bi number>string write ] tri ] [ drop ] if ] diff --git a/extra/http/server/server-tests.factor b/extra/http/server/server-tests.factor index a5dffbc58b..af27eda527 100755 --- a/extra/http/server/server-tests.factor +++ b/extra/http/server/server-tests.factor @@ -6,6 +6,7 @@ IN: http.server.tests [ + http >>protocol "www.apple.com" >>host "/xxx/bar" >>path { { "a" "b" } } >>query diff --git a/extra/io/unix/files/unique/unique.factor b/extra/io/unix/files/unique/unique.factor index 54ced6e5ce..dca2f51958 100644 --- a/extra/io/unix/files/unique/unique.factor +++ b/extra/io/unix/files/unique/unique.factor @@ -6,6 +6,6 @@ IN: io.unix.files.unique { O_RDWR O_CREAT O_EXCL } flags ; M: unix (make-unique-file) ( path -- ) - open-unique-flags file-mode open dup io-error close ; + open-unique-flags file-mode open-file close-file ; M: unix temporary-path ( -- path ) "/tmp" ; From ab070a6839e8735c38e0caa0f5a9b8f0b3632b32 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 14 May 2008 07:54:13 -0500 Subject: [PATCH 02/10] intermediate work on ftp, gotta pull.. --- extra/ftp/client/client.factor | 11 +-- extra/ftp/ftp.factor | 37 ++++++++++- extra/ftp/server/server.factor | 118 ++++++++++++++++++++++++--------- 3 files changed, 123 insertions(+), 43 deletions(-) diff --git a/extra/ftp/client/client.factor b/extra/ftp/client/client.factor index 44ff488a93..8ec7366266 100644 --- a/extra/ftp/client/client.factor +++ b/extra/ftp/client/client.factor @@ -27,7 +27,6 @@ IN: ftp.client : ftp-command ( string -- ftp-response ) ftp-send read-response ; - : ftp-user ( ftp-client -- ftp-response ) user>> "USER " prepend ftp-command ; @@ -56,21 +55,13 @@ IN: ftp.client strings>> first "|" split 2 tail* first string>number ; -: ch>attribute ( ch -- symbol ) - { - { CHAR: d [ +directory+ ] } - { CHAR: l [ +symbolic-link+ ] } - { CHAR: - [ +regular-file+ ] } - [ drop +unknown+ ] - } case ; - TUPLE: remote-file type permissions links owner group size month day time year name ; : ( -- remote-file ) remote-file new ; : parse-permissions ( remote-file str -- remote-file ) - [ first ch>attribute >>type ] [ rest >>permissions ] bi ; + [ first ch>type >>type ] [ rest >>permissions ] bi ; : parse-list-9 ( lines -- seq ) [ diff --git a/extra/ftp/ftp.factor b/extra/ftp/ftp.factor index 05291d3d5f..ccdbcd76ea 100644 --- a/extra/ftp/ftp.factor +++ b/extra/ftp/ftp.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors io kernel math.parser sequences ; +USING: accessors arrays assocs combinators io io.files kernel +math.parser sequences strings ; IN: ftp SINGLETON: active @@ -15,6 +16,11 @@ TUPLE: ftp-client host port user password mode state ; "anonymous" >>user "ftp@my.org" >>password ; +: reset-ftp-client ( ftp-client -- ) + f >>user + f >>password + drop ; + TUPLE: ftp-response n strings parsed ; : ( -- ftp-response ) @@ -25,3 +31,32 @@ TUPLE: ftp-response n strings parsed ; over strings>> push ; : ftp-send ( string -- ) write "\r\n" write flush ; + +: ftp-ipv4 1 ; inline +: ftp-ipv6 2 ; inline + + +: ch>type ( ch -- type ) + { + { CHAR: d [ +directory+ ] } + { CHAR: l [ +symbolic-link+ ] } + { CHAR: - [ +regular-file+ ] } + [ drop +unknown+ ] + } case ; + +: type>ch ( type -- string ) + { + { +directory+ [ CHAR: d ] } + { +symbolic-link+ [ CHAR: l ] } + { +regular-file+ [ CHAR: - ] } + [ drop CHAR: - ] + } case ; + +: file-info>string ( file-info name -- string ) + >r [ [ type>> type>ch 1string ] [ drop "rwx------" append ] bi ] + [ size>> number>string 15 CHAR: \s pad-left ] bi r> + 3array " " join ; + +: directory-list ( -- seq ) + "" directory keys + [ [ link-info ] keep file-info>string ] map ; diff --git a/extra/ftp/server/server.factor b/extra/ftp/server/server.factor index 1b9201fb7b..37c806f1b9 100644 --- a/extra/ftp/server/server.factor +++ b/extra/ftp/server/server.factor @@ -1,27 +1,30 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. USING: accessors combinators io io.encodings.8-bit io.files io.server io.sockets kernel math.parser namespaces sequences ftp io.unix.launcher.parser -unicode.case ; +unicode.case splitting assocs ; IN: ftp.server SYMBOL: client +SYMBOL: stream -TUPLE: ftp-client-command string tokenized ; +TUPLE: ftp-command raw tokenized ; -: ( -- obj ) - ftp-client-command new ; +: ( -- obj ) + ftp-command new ; -: read-client-command ( -- ftp-client-command ) - readln - [ >>string ] [ tokenize-command >>tokenized ] bi ; +: read-command ( -- ftp-command ) + readln + [ >>raw ] [ tokenize-command >>tokenized ] bi ; + +: (send-response) ( n string separator -- ) + rot number>string write write ftp-send ; : send-response ( ftp-response -- ) [ n>> ] [ strings>> ] bi - 2dup - but-last-slice [ - [ number>string write "-" write ] [ ftp-send ] bi* - ] with each - first [ number>string write bl ] [ ftp-send ] bi* ; + [ but-last-slice [ "-" (send-response) ] with each ] + [ first " " (send-response) ] 2bi ; : server-response ( n string -- ) @@ -35,72 +38,123 @@ TUPLE: ftp-client-command string tokenized ; : send-PASS-request ( -- ) 331 "Please specify the password." server-response ; -: parse-USER ( ftp-client-command -- ) +: anonymous-only ( -- ) + 530 "This FTP server is anonymous only." server-response ; + +: parse-USER ( ftp-command -- ) tokenized>> second client get swap >>user drop ; : send-login-response ( -- ) ! client get 230 "Login successful" server-response ; -: parse-PASS ( ftp-client-command -- ) +: parse-PASS ( ftp-command -- ) tokenized>> second client get swap >>password drop ; -: send-quit-response ( ftp-client-command -- ) +: send-quit-response ( ftp-command -- ) drop 221 "Goodbye." server-response ; -: unimplemented-command ( ftp-client-command -- ) - 500 "Unimplemented command: " rot string>> append server-response ; +: ftp-error ( string -- ) + 500 "Unrecognized command: " rot append server-response ; + +: send-type-error ( -- ) + "TYPE is binary only" ftp-error ; + +: send-type-success ( string -- ) + 200 "Switching to " rot " mode" 3append server-response ; + +: parse-TYPE ( obj -- ) + tokenized>> second >upper { + { "IMAGE" [ "Binary" send-type-success ] } + { "I" [ "Binary" send-type-success ] } + [ drop send-type-error ] + } case ; + +: pwd-response ( -- ) + 257 current-directory get "\"" swap "\"" 3append server-response ; + +! : random-local-inet ( -- spec ) + ! remote-address get class new 0 >>port ; + +! : handle-LIST ( -- ) + ! random-local-inet ascii ; + +: handle-STOR ( obj -- ) + ; + +! EPRT |2|::1|62138| +! : handle-EPRT ( obj -- ) + ! tokenized>> second "|" split harvest ; + +! : handle-EPSV ( obj -- ) + ! 229 "Entering Extended Passive Mode (|||" + ! random-local-inet ! get port number>string + ! "|)" 3append server-response ; + +! LPRT 6,16,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,2,242,186 +: handle-LPRT ( obj -- ) + tokenized>> "," split ; + +: start-directory ( -- ) + 150 "Here comes the directory listing." server-response ; + +: finish-directory ( -- ) + 226 "Directory send OK." server-response ; + +: send-directory-list ( stream -- ) + [ directory-list write ] with-output-stream ; + +: unrecognized-command ( obj -- ) raw>> ftp-error ; : handle-client-loop ( -- ) - readln - [ >>string ] + readln + [ >>raw ] [ tokenize-command >>tokenized ] bi dup tokenized>> first >upper { { "USER" [ parse-USER send-PASS-request t ] } { "PASS" [ parse-PASS send-login-response t ] } - ! { "ACCT" [ ] } + { "ACCT" [ drop "ACCT unimplemented" ftp-error t ] } ! { "CWD" [ ] } ! { "CDUP" [ ] } ! { "SMNT" [ ] } - ! { "REIN" [ ] } + ! { "REIN" [ drop client get reset-ftp-client t ] } { "QUIT" [ send-quit-response f ] } ! { "PORT" [ ] } ! { "PASV" [ ] } ! { "MODE" [ ] } - ! { "TYPE" [ ] } + { "TYPE" [ parse-TYPE t ] } ! { "STRU" [ ] } ! { "ALLO" [ ] } ! { "REST" [ ] } - ! { "STOR" [ ] } + ! { "STOR" [ handle-STOR t ] } ! { "STOU" [ ] } ! { "RETR" [ ] } - ! { "LIST" [ ] } + ! { "LIST" [ drop handle-LIST t ] } ! { "NLST" [ ] } - ! { "LIST" [ ] } ! { "APPE" [ ] } ! { "RNFR" [ ] } ! { "RNTO" [ ] } ! { "DELE" [ ] } ! { "RMD" [ ] } ! { "MKD" [ ] } - ! { "PWD" [ ] } + { "PWD" [ drop pwd-response t ] } ! { "ABOR" [ ] } - ! { "SYST" [ ] } + ! { "SYST" [ drop ] } ! { "STAT" [ ] } ! { "HELP" [ ] } ! { "SITE" [ ] } ! { "NOOP" [ ] } - ! { "EPRT" [ ] } - ! { "LPRT" [ ] } - ! { "EPSV" [ ] } - ! { "LPSV" [ ] } - [ drop unimplemented-command t ] + ! { "EPRT" [ handle-eprt ] } + ! { "LPRT" [ handle-lprt ] } + ! { "EPSV" [ drop handle-epsv t ] } + ! { "LPSV" [ drop handle-lpsv t ] } + [ drop unrecognized-command t ] } case [ handle-client-loop ] when ; : handle-client ( -- ) From dd9e8a2245ae7d04e28eb0bd699cbf5229de932c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 14 May 2008 07:54:40 -0500 Subject: [PATCH 03/10] expose some more fields from windows file info --- extra/io/windows/files/files.factor | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/extra/io/windows/files/files.factor b/extra/io/windows/files/files.factor index 8a15a57f83..1fd60fe1a5 100755 --- a/extra/io/windows/files/files.factor +++ b/extra/io/windows/files/files.factor @@ -68,6 +68,11 @@ SYMBOLS: +read-only+ +hidden+ +system+ ! [ BY_HANDLE_FILE_INFORMATION-ftCreationTime FILETIME>timestamp ] [ BY_HANDLE_FILE_INFORMATION-ftLastWriteTime FILETIME>timestamp ] ! [ BY_HANDLE_FILE_INFORMATION-ftLastAccessTime FILETIME>timestamp ] + ! [ BY_HANDLE_FILE_INFORMATION-nNumberOfLinks ] + ! [ + ! [ BY_HANDLE_FILE_INFORMATION-nFileIndexLow ] + ! [ BY_HANDLE_FILE_INFORMATION-nFileIndexHigh ] bi >64bit + ! ] } cleave \ file-info boa ; From c6ab75e3f53338fd513b0374683dcd4458ebe036 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 14 May 2008 15:43:34 -0500 Subject: [PATCH 04/10] move remote-address to public --- extra/io/server/server.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/io/server/server.factor b/extra/io/server/server.factor index 23066114e4..e15e8c0039 100755 --- a/extra/io/server/server.factor +++ b/extra/io/server/server.factor @@ -8,12 +8,12 @@ IN: io.server SYMBOL: servers +SYMBOL: remote-address + Date: Wed, 14 May 2008 19:03:07 -0500 Subject: [PATCH 05/10] Destructor changes --- core/boxes/boxes.factor | 18 +++++----- .../distributed/distributed-tests.factor | 2 +- extra/db/pooling/pooling.factor | 2 +- extra/db/postgresql/lib/lib.factor | 12 +++---- extra/destructors/destructors-docs.factor | 22 +++++------- extra/destructors/destructors-tests.factor | 4 +-- extra/destructors/destructors.factor | 23 ++++++------ extra/http/server/auth/login/login.factor | 2 +- extra/http/server/sessions/sessions.factor | 2 +- extra/io/launcher/launcher.factor | 6 ++-- extra/io/pipes/pipes.factor | 13 +++---- extra/io/ports/ports.factor | 12 +++---- extra/io/sockets/sockets.factor | 13 +++---- extra/io/unix/files/files.factor | 2 +- extra/io/unix/mmap/mmap.factor | 2 +- extra/io/unix/sockets/secure/secure.factor | 4 +-- extra/io/unix/sockets/sockets.factor | 36 ++++++++++++------- extra/io/windows/windows.factor | 2 +- extra/openssl/openssl.factor | 3 +- extra/random/windows/windows.factor | 5 ++- extra/smtp/smtp.factor | 18 +++++----- 21 files changed, 102 insertions(+), 101 deletions(-) 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 ) From 45da8d6c33cbac7c7d6acb02a9f484457d174ff1 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Wed, 14 May 2008 19:22:41 -0500 Subject: [PATCH 06/10] io.unix.sockets: Clean up setup-receive --- extra/io/unix/sockets/sockets.factor | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/extra/io/unix/sockets/sockets.factor b/extra/io/unix/sockets/sockets.factor index 51b198bdc0..273b3f6c11 100755 --- a/extra/io/unix/sockets/sockets.factor +++ b/extra/io/unix/sockets/sockets.factor @@ -107,9 +107,8 @@ SYMBOL: receive-buffer packet-size receive-buffer set-global : setup-receive ( port -- s buffer len flags from fromlen ) - dup port-handle - swap datagram-port-addr sockaddr-type - dup swap heap-size + [ handle>> ] [ addr>> sockaddr-type ] bi + [ ] [ heap-size ] bi >r >r receive-buffer get-global packet-size 0 r> r> ; : do-receive ( s buffer len flags from fromlen -- sockaddr data ) From a2617cb1d6c36b5e53910d07252867b2eee62ca6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 14 May 2008 19:41:39 -0500 Subject: [PATCH 07/10] Sockets fixes --- .../distributed/distributed-tests.factor | 3 +- extra/db/postgresql/lib/lib.factor | 2 +- extra/io/ports/ports.factor | 4 +- extra/io/sockets/sockets.factor | 38 +++++++++++-------- extra/io/unix/sockets/secure/secure.factor | 16 +++----- extra/io/unix/sockets/sockets.factor | 33 +++++++--------- extra/smtp/smtp.factor | 18 ++++----- 7 files changed, 56 insertions(+), 58 deletions(-) diff --git a/extra/concurrency/distributed/distributed-tests.factor b/extra/concurrency/distributed/distributed-tests.factor index 840c5efa36..645728780d 100755 --- a/extra/concurrency/distributed/distributed-tests.factor +++ b/extra/concurrency/distributed/distributed-tests.factor @@ -13,7 +13,8 @@ concurrency.messaging continuations ; [ ] [ test-node dup 1array swap (start-node) ] unit-test -[ ] [ 1000 sleep ] unit-test +[ ] [ yield ] unit-test +[ ] [ yield ] unit-test [ ] [ [ diff --git a/extra/db/postgresql/lib/lib.factor b/extra/db/postgresql/lib/lib.factor index cd079690e3..ebcc67374b 100755 --- a/extra/db/postgresql/lib/lib.factor +++ b/extra/db/postgresql/lib/lib.factor @@ -127,7 +127,7 @@ M: postgresql-malloc-destructor dispose ( obj -- ) alien>> PQfreemem ; : &postgresql-free ( alien -- alien ) - &dispose ; inline + dup &dispose drop ; inline : pq-get-blob ( handle row column -- obj/f ) [ PQgetvalue ] 3keep 3dup PQgetlength diff --git a/extra/io/ports/ports.factor b/extra/io/ports/ports.factor index 2b1d62aaeb..f1f4ca9cf2 100755 --- a/extra/io/ports/ports.factor +++ b/extra/io/ports/ports.factor @@ -28,10 +28,10 @@ M: handle-destructor dispose ( obj -- ) handle>> close-handle ; : &close-handle ( handle -- handle ) - &dispose ; inline + dup &dispose drop ; inline : |close-handle ( handle -- handle ) - |dispose ; inline + dup |dispose drop ; inline : ( handle class -- port ) new diff --git a/extra/io/sockets/sockets.factor b/extra/io/sockets/sockets.factor index ac58a54bb8..ba6d16a364 100755 --- a/extra/io/sockets/sockets.factor +++ b/extra/io/sockets/sockets.factor @@ -151,7 +151,10 @@ M: inet6 parse-sockaddr M: f parse-sockaddr nip ; -GENERIC# get-local-address 1 ( handle remote -- sockaddr ) +GENERIC: (get-local-address) ( handle remote -- sockaddr ) + +: get-local-address ( handle remote -- local ) + [ (get-local-address) ] keep parse-sockaddr ; GENERIC: establish-connection ( client-out remote -- ) @@ -163,8 +166,13 @@ M: array (client) [ (client) 3array ] attempt-all first3 ; M: object (client) ( remote -- client-in client-out local ) [ - [ ((client)) dup 2dup [ |dispose drop ] bi@ ] keep - [ establish-connection ] [ drop ] [ get-local-address ] 2tri + [ ((client)) ] keep + [ + >r dup [ |dispose ] bi@ dup r> + establish-connection + ] + [ get-local-address ] + 2bi ] with-destructors ; : ( remote encoding -- stream local ) @@ -182,23 +190,23 @@ TUPLE: server-port < port addr encoding ; check-closed dup server-port? [ "Not a server port" throw ] unless ; inline -GENERIC: (server) ( addrspec -- handle sockaddr ) +GENERIC: (server) ( addrspec -- handle ) : ( addrspec encoding -- server ) - >r [ (server) ] keep parse-sockaddr - swap server-port - swap >>addr - r> >>encoding ; + >r + [ (server) ] keep + [ drop server-port ] [ get-local-address ] 2bi + >>addr r> >>encoding ; -GENERIC: (accept) ( server addrspec -- handle remote ) +GENERIC: (accept) ( server addrspec -- handle ) : accept ( server -- client remote ) - check-server-port - [ dup addr>> (accept) ] keep - tuck - [ [ dup ] [ encoding>> ] bi* ] - [ addr>> parse-sockaddr ] - 2bi* ; + [ + dup addr>> + [ (accept) ] keep + [ drop dup ] [ get-local-address ] 2bi + -rot + ] keep encoding>> swap ; TUPLE: datagram-port < port addr ; diff --git a/extra/io/unix/sockets/secure/secure.factor b/extra/io/unix/sockets/secure/secure.factor index 1d240057b0..05164aca34 100644 --- a/extra/io/unix/sockets/secure/secure.factor +++ b/extra/io/unix/sockets/secure/secure.factor @@ -92,12 +92,12 @@ M: ssl parse-sockaddr addrspec>> parse-sockaddr ; 2dup SSL_connect check-connect-response dup [ >r over r> wait-for-port do-ssl-connect ] [ 3drop ] if ; -M: ssl-handle (wait-to-connect) +M: ssl establish-connection ( client-out remote -- ) addrspec>> - [ >r file>> r> (wait-to-connect) ] - [ drop handle>> do-ssl-connect ] - [ drop t >>connected 2drop ] - 3tri ; + [ establish-connection ] + [ drop dup handle>> do-ssl-connect ] + [ drop t >>connected drop ] + 2tri ; M: ssl (server) addrspec>> (server) ; @@ -117,12 +117,8 @@ M: ssl (server) addrspec>> (server) ; M: ssl (accept) [ - addrspec>> - (accept) >r - |close-handle - |close-handle + addrspec>> (accept) |close-handle |close-handle dup do-ssl-accept - r> ] with-destructors ; : check-shutdown-response ( handle r -- event ) diff --git a/extra/io/unix/sockets/sockets.factor b/extra/io/unix/sockets/sockets.factor index 7973ca5164..83aa01d79a 100755 --- a/extra/io/unix/sockets/sockets.factor +++ b/extra/io/unix/sockets/sockets.factor @@ -22,7 +22,7 @@ M: unix addrinfo-error ( n -- ) dup zero? [ drop ] [ gai_strerror throw ] if ; ! Client sockets - TCP and Unix domain -M: fd get-local-address ( handle remote -- sockaddr ) +M: object (get-local-address) ( handle remote -- sockaddr ) >r handle-fd r> empty-sockaddr/size [ getsockname io-error ] 2keep drop ; @@ -32,18 +32,18 @@ M: fd get-local-address ( handle remote -- sockaddr ) : wait-to-connect ( port -- ) dup handle>> handle-fd f 0 write { - { [ 0 = ] [ drop f ] } + { [ 0 = ] [ drop ] } { [ 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 + [ drop ] [ [ handle>> handle-fd ] [ make-sockaddr/size ] bi* connect ] 2bi { - { [ 0 = ] [ ] } + { [ 0 = ] [ drop ] } { [ err_no EINPROGRESS = ] [ - [ +output+ wait-for-port ] [ check-connection ] [ ] tri + [ +output+ wait-for-port ] [ wait-to-connect ] bi ] } [ (io-error) ] } cond ; @@ -60,27 +60,22 @@ M: object ((client)) ( addrspec -- fd ) dup init-server-socket dup handle-fd rot make-sockaddr/size bind io-error ; -M: object (server) ( addrspec -- handle sockaddr ) +M: object (server) ( addrspec -- handle ) [ - [ - SOCK_STREAM server-socket-fd - dup handle-fd 10 listen io-error - dup - ] keep - get-socket-name + SOCK_STREAM server-socket-fd + dup handle-fd 10 listen io-error ] with-destructors ; -: do-accept ( server addrspec -- fd remote ) - [ handle>> handle-fd ] [ empty-sockaddr/size ] bi* - [ accept ] 2keep drop ; inline +: do-accept ( server addrspec -- fd ) + [ handle>> handle-fd ] [ empty-sockaddr/size ] bi* accept ; inline -M: object (accept) ( server addrspec -- fd remote ) +M: object (accept) ( server addrspec -- fd ) 2dup do-accept { - { [ over 0 >= ] [ { [ drop ] [ drop ] [ ] [ ] } spread ] } - { [ err_no EINTR = ] [ 2drop (accept) ] } + { [ dup 0 >= ] [ 2nip ] } + { [ err_no EINTR = ] [ drop (accept) ] } { [ err_no EAGAIN = ] [ - 2drop + drop [ drop +input+ wait-for-port ] [ (accept) ] 2bi diff --git a/extra/smtp/smtp.factor b/extra/smtp/smtp.factor index f4f2496cc6..8fdc0e07a4 100755 --- a/extra/smtp/smtp.factor +++ b/extra/smtp/smtp.factor @@ -110,16 +110,14 @@ 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 USING: continuations debugger ; - ] [ global [ error. :c ] bind ] recover + 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 ] with-smtp-connection ; : extract-email ( recepient -- email ) From c7500a09908b4463f5c29c17afc7a17a118ff2b2 Mon Sep 17 00:00:00 2001 From: James Cash Date: Wed, 14 May 2008 20:46:22 -0400 Subject: [PATCH 08/10] error checks for look up an undefined function --- extra/lisp/lisp.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor index 8582021d6d..3e4cdca41f 100644 --- a/extra/lisp/lisp.factor +++ b/extra/lisp/lisp.factor @@ -76,6 +76,7 @@ PRIVATE> ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! SYMBOL: lisp-env +ERROR: no-such-var var ; : init-env ( -- ) H{ } clone lisp-env set ; @@ -84,7 +85,7 @@ SYMBOL: lisp-env swap lisp-env get set-at ; : lisp-get ( name -- word ) - lisp-env get at ; + dup lisp-env get at [ ] [ no-such-var ] ?if ; : funcall ( quot sym -- * ) dup lisp-symbol? [ name>> lisp-get ] when call ; inline \ No newline at end of file From 2cbfa9c2d753997078f5142288d19b5d1f8e9c74 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 14 May 2008 23:23:12 -0500 Subject: [PATCH 09/10] Move destructors to core --- core/alien/c-types/c-types-docs.factor | 5 +- core/continuations/continuations-docs.factor | 23 +----- core/continuations/continuations.factor | 10 --- {extra => core}/destructors/authors.txt | 0 core/destructors/destructors-docs.factor | 71 +++++++++++++++++++ .../destructors/destructors-tests.factor | 0 core/destructors/destructors.factor | 56 +++++++++++++++ {extra => core}/destructors/summary.txt | 0 core/io/encodings/encodings.factor | 6 +- core/io/files/files-docs.factor | 4 +- core/io/files/files-tests.factor | 4 +- core/io/files/files.factor | 12 ++-- core/io/io-docs.factor | 2 +- core/io/io.factor | 2 +- core/io/streams/c/c.factor | 28 ++++---- core/io/streams/nested/nested.factor | 2 +- core/io/streams/string/string.factor | 4 +- core/libc/libc-docs.factor | 10 ++- core/libc/libc.factor | 22 +++++- extra/benchmark/sockets/sockets.factor | 3 +- extra/bunny/bunny.factor | 2 +- extra/bunny/cel-shaded/cel-shaded.factor | 5 +- .../fixed-pipeline/fixed-pipeline.factor | 2 +- extra/bunny/model/model.factor | 3 +- extra/bunny/outlined/outlined.factor | 8 +-- extra/cairo/cairo.factor | 2 +- extra/checksums/openssl/openssl.factor | 2 +- extra/combinators/lib/lib-tests.factor | 7 ++ extra/combinators/lib/lib.factor | 16 ++--- extra/concurrency/mailboxes/mailboxes.factor | 14 ++-- .../core-foundation/fsevents/fsevents.factor | 21 +++--- extra/db/db.factor | 4 +- extra/db/mysql/mysql.factor | 4 +- extra/db/postgresql/postgresql.factor | 2 +- extra/db/sqlite/sqlite.factor | 2 +- extra/db/tuples/tuples.factor | 2 +- extra/destructors/destructors-docs.factor | 16 ----- extra/destructors/destructors.factor | 54 -------------- extra/help/handbook/handbook.factor | 4 +- extra/html/html.factor | 2 +- extra/http/server/static/static.factor | 2 +- extra/io/launcher/launcher.factor | 8 +-- extra/io/mmap/mmap-docs.factor | 3 +- extra/io/mmap/mmap.factor | 23 +++--- extra/io/monitors/monitors-docs.factor | 2 +- extra/io/monitors/monitors-tests.factor | 2 +- extra/io/monitors/monitors.factor | 6 +- extra/io/monitors/recursive/recursive.factor | 20 +++--- extra/io/pipes/pipes-docs.factor | 2 +- extra/io/pipes/pipes-tests.factor | 2 +- extra/io/pipes/pipes.factor | 2 +- extra/io/ports/ports-docs.factor | 3 +- extra/io/ports/ports.factor | 49 +++---------- extra/io/server/server.factor | 6 +- extra/io/sockets/secure/secure.factor | 2 +- extra/io/sockets/sockets-docs.factor | 2 +- extra/io/sockets/sockets.factor | 4 +- extra/io/streams/duplex/duplex-docs.factor | 3 - extra/io/streams/duplex/duplex-tests.factor | 15 ++-- extra/io/streams/duplex/duplex.factor | 43 ++++------- extra/io/streams/null/null.factor | 2 +- extra/io/unix/backend/backend.factor | 10 +-- extra/io/unix/files/files.factor | 2 +- extra/io/unix/launcher/launcher-tests.factor | 2 +- extra/io/unix/linux/monitors/monitors.factor | 16 ++--- extra/io/unix/macosx/macosx.factor | 2 +- extra/io/unix/mmap/mmap.factor | 2 +- extra/io/unix/sockets/secure/secure.factor | 2 +- extra/io/unix/sockets/sockets.factor | 2 +- extra/io/unix/unix-tests.factor | 2 +- extra/irc/irc.factor | 4 +- extra/logging/server/server.factor | 8 +-- extra/openssl/openssl.factor | 13 ++-- extra/random/windows/windows.factor | 1 - extra/semantic-db/semantic-db.factor | 2 +- extra/shuffle/shuffle.factor | 4 +- extra/smtp/server/server.factor | 2 +- extra/tools/deploy/backend/backend.factor | 2 +- extra/ui/gadgets/panes/panes.factor | 3 +- 79 files changed, 351 insertions(+), 365 deletions(-) rename {extra => core}/destructors/authors.txt (100%) create mode 100755 core/destructors/destructors-docs.factor rename {extra => core}/destructors/destructors-tests.factor (100%) create mode 100755 core/destructors/destructors.factor rename {extra => core}/destructors/summary.txt (100%) delete mode 100755 extra/destructors/destructors-docs.factor delete mode 100755 extra/destructors/destructors.factor diff --git a/core/alien/c-types/c-types-docs.factor b/core/alien/c-types/c-types-docs.factor index 3cd5afef33..8da030c7d1 100755 --- a/core/alien/c-types/c-types-docs.factor +++ b/core/alien/c-types/c-types-docs.factor @@ -1,7 +1,7 @@ IN: alien.c-types USING: alien help.syntax help.markup libc kernel.private byte-arrays math strings hashtables alien.syntax -bit-arrays float-arrays debugger ; +bit-arrays float-arrays debugger destructors ; HELP: { $values { "type" hashtable } } @@ -222,6 +222,9 @@ $nl { $subsection realloc } "You must always free pointers returned by any of the above words when the block of memory is no longer in use:" { $subsection free } +"Utilities for automatically freeing memory in conjunction with " { $link with-destructors } ":" +{ $subsection &free } +{ $subsection |free } "You can unsafely copy a range of bytes from one memory location to another:" { $subsection memcpy } "You can copy a range of bytes from memory into a byte array:" diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor index 472136da8e..3cb7d8a71e 100755 --- a/core/continuations/continuations-docs.factor +++ b/core/continuations/continuations-docs.factor @@ -1,6 +1,6 @@ USING: help.markup help.syntax kernel kernel.private continuations.private parser vectors arrays namespaces -assocs words quotations io ; +assocs words quotations ; IN: continuations ARTICLE: "errors-restartable" "Restartable errors" @@ -28,13 +28,7 @@ $nl { $heading "Anti-pattern #3: Dropping and rethrowing" } "Do not use " { $link recover } " to handle an error by dropping it and throwing a new error. By losing the original error message, you signal to the user that something failed without leaving any indication of what actually went wrong. Either wrap the error in a new error containing additional information, or rethrow the original error. A more subtle form of this is using " { $link throw } " instead of " { $link rethrow } ". The " { $link throw } " word should only be used when throwing new errors, and never when rethrowing errors that have been caught." { $heading "Anti-pattern #4: Logging and rethrowing" } -"If you are going to rethrow an error, do not log a message. If you do so, the user will see two log messages for the same error, which will clutter logs without adding any useful information." -{ $heading "Anti-pattern #5: Leaking external resources" } -"Words which create objects corresponding to external resources should always be used with " { $link with-disposal } ". The following code is wrong:" -{ $code - " ... do stuff ... dispose" -} -"The reason being that if " { $snippet "do stuff" } " throws an error, the resource will not be disposed of. The most important case where this can occur is with I/O streams, and the correct solution is to always use " { $link with-input-stream } " and " { $link with-output-stream } "; see " { $link "stdio" } " for details." ; +"If you are going to rethrow an error, do not log a message. If you do so, the user will see two log messages for the same error, which will clutter logs without adding any useful information." ; ARTICLE: "errors" "Error handling" "Support for handling exceptional situations such as bad user input, implementation bugs, and input/output errors is provided by a set of words built using continuations." @@ -88,19 +82,6 @@ $nl ABOUT: "continuations" -HELP: dispose -{ $values { "object" "a disposable object" } } -{ $contract "Releases operating system resources associated with a disposable object. Disposable objects include streams, memory mapped files, and so on." -$nl -"No further operations can be performed on a disposable object after this call." -$nl -"Disposing an object which has already been disposed should have no effect, and in particular it should not fail with an error." } -{ $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." } ; diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor index 8b6cd1ce3a..76f2cdef7a 100755 --- a/core/continuations/continuations.factor +++ b/core/continuations/continuations.factor @@ -150,16 +150,6 @@ ERROR: attempt-all-error ; ] { } make peek swap [ rethrow ] when ] if ; inline -GENERIC: dispose ( object -- ) - -: dispose-each ( seq -- ) - [ - [ [ dispose ] curry [ , ] recover ] each - ] { } make dup empty? [ drop ] [ peek rethrow ] if ; - -: with-disposal ( object quot -- ) - over [ dispose ] curry [ ] cleanup ; inline - TUPLE: condition error restarts continuation ; C: condition ( error restarts cc -- condition ) diff --git a/extra/destructors/authors.txt b/core/destructors/authors.txt similarity index 100% rename from extra/destructors/authors.txt rename to core/destructors/authors.txt diff --git a/core/destructors/destructors-docs.factor b/core/destructors/destructors-docs.factor new file mode 100755 index 0000000000..b611b8ec19 --- /dev/null +++ b/core/destructors/destructors-docs.factor @@ -0,0 +1,71 @@ +USING: help.markup help.syntax libc kernel continuations io ; +IN: destructors + +HELP: dispose +{ $values { "disposable" "a disposable object" } } +{ $contract "Releases operating system resources associated with a disposable object. Disposable objects include streams, memory mapped files, and so on." +$nl +"No further operations can be performed on a disposable object after this call." +$nl +"Disposing an object which has already been disposed should have no effect, and in particular it should not fail with an error. To help implement this pattern, add a " { $snippet "disposed" } " slot to your object and implement the " { $link dispose* } " method instead." } +{ $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." +$nl +"The default implementation assumes the object has a " { $snippet "disposable" } " slot. If the slot is set to " { $link f } ", it calls " { $link dispose* } " and sets the slot to " { $link f } "." } ; + +HELP: dispose* +{ $values { "disposable" "a disposable object" } } +{ $contract "Releases operating system resources associated with a disposable object. Disposable objects include streams, memory mapped files, and so on." } +{ $notes + "This word should not be called directly. It can be implemented on objects with a " { $snippet "disposable" } " slot to ensure that the object is only disposed once." +} ; + +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: 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 generalize " { $link with-disposal } ". The following two lines are equivalent, except that the second line establishes a new dynamic scope:" + { $code + "[ X ] with-disposal" + "[ &dispose X ] with-destructors" + } +} +{ $examples + { $code "[ 10 malloc &free ] with-destructors" } +} ; + +HELP: &dispose +{ $values { "disposable" "a disposable object" } } +{ $description "Marks the object for unconditional disposal at the end of the current " { $link with-destructors } " scope." } ; + +HELP: |dispose +{ $values { "disposable" "a disposable object" } } +{ $description "Marks the object for disposal in the event of an error at the end of the current " { $link with-destructors } " scope." } ; + +ARTICLE: "destructors-anti-patterns" "Resource disposal anti-patterns" +"Words which create objects corresponding to external resources should always be used with " { $link with-disposal } ". The following code is wrong:" +{ $code + " ... do stuff ... dispose" +} +"The reason being that if " { $snippet "do stuff" } " throws an error, the resource will not be disposed of. The most important case where this can occur is with I/O streams, and the correct solution is to always use " { $link with-input-stream } " and " { $link with-output-stream } "; see " { $link "stdio" } " for details." ; + +ARTICLE: "destructors" "Deterministic resource disposal" +"Operating system resources such as streams, memory mapped files, and so on are not managed by Factor's garbage collector and must be released when you are done with them. Failing to release a resource can lead to reduced performance and instability." +$nl +"Disposable object protocol:" +{ $subsection dispose } +{ $subsection dispose* } +"Utility word for scoped disposal:" +{ $subsection with-disposal } +"Utility word for disposing multiple objects:" +{ $subsection dispose-each } +"Utility words for more complex disposal patterns:" +{ $subsection with-destructors } +{ $subsection &dispose } +{ $subsection |dispose } +{ $subsection "destructors-anti-patterns" } ; + +ABOUT: "destructors" diff --git a/extra/destructors/destructors-tests.factor b/core/destructors/destructors-tests.factor similarity index 100% rename from extra/destructors/destructors-tests.factor rename to core/destructors/destructors-tests.factor diff --git a/core/destructors/destructors.factor b/core/destructors/destructors.factor new file mode 100755 index 0000000000..bed1c16bcf --- /dev/null +++ b/core/destructors/destructors.factor @@ -0,0 +1,56 @@ +! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors continuations kernel namespaces +sequences vectors ; +IN: destructors + +TUPLE: disposable disposed ; + +GENERIC: dispose* ( disposable -- ) + +ERROR: already-disposed disposable ; + +: check-disposed ( disposable -- ) + dup disposed>> [ already-disposed ] [ drop ] if ; inline + +GENERIC: dispose ( disposable -- ) + +M: object dispose + dup disposed>> [ drop ] [ t >>disposed dispose* ] if ; + +: dispose-each ( seq -- ) + [ + [ [ dispose ] curry [ , ] recover ] each + ] { } make dup empty? [ drop ] [ peek rethrow ] if ; + +: with-disposal ( object quot -- ) + over [ dispose ] curry [ ] cleanup ; inline + + dispose-each ; + +: do-error-destructors ( -- ) + error-destructors get dispose-each ; + +PRIVATE> + +: &dispose ( disposable -- disposable ) + dup always-destructors get push ; inline + +: |dispose ( disposable -- disposable ) + dup error-destructors get push ; inline + +: with-destructors ( quot -- ) + [ + V{ } clone always-destructors set + V{ } clone error-destructors set + [ do-always-destructors ] + [ do-error-destructors ] + cleanup + ] with-scope ; inline diff --git a/extra/destructors/summary.txt b/core/destructors/summary.txt similarity index 100% rename from extra/destructors/summary.txt rename to core/destructors/summary.txt diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor index daaf1c129d..3fe6f9d6aa 100755 --- a/core/io/encodings/encodings.factor +++ b/core/io/encodings/encodings.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2008 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: math kernel sequences sbufs vectors namespaces growable -strings io classes continuations combinators io.styles -io.streams.plain splitting byte-arrays sequences.private -accessors ; +strings io classes continuations destructors combinators +io.styles io.streams.plain splitting byte-arrays +sequences.private accessors ; IN: io.encodings ! The encoding descriptor protocol diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor index ec74bb001e..e5034d6103 100755 --- a/core/io/files/files-docs.factor +++ b/core/io/files/files-docs.factor @@ -300,8 +300,8 @@ HELP: exists? { $description "Tests if the file named by " { $snippet "path" } " exists." } ; HELP: directory? -{ $values { "path" "a pathname string" } { "?" "a boolean" } } -{ $description "Tests if " { $snippet "path" } " names a directory." } ; +{ $values { "file-info" file-info } { "?" "a boolean" } } +{ $description "Tests if " { $snippet "file-info" } " is a directory." } ; HELP: (directory) { $values { "path" "a pathname string" } { "seq" "a sequence of " { $snippet "{ name dir? }" } " pairs" } } diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index 20eb662fc7..14bc5fe2a2 100755 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -1,14 +1,14 @@ IN: io.files.tests USING: tools.test io.files io.files.private io threads kernel continuations io.encodings.ascii io.files.unique sequences -strings accessors io.encodings.utf8 math ; +strings accessors io.encodings.utf8 math destructors ; \ exists? must-infer \ (exists?) must-infer [ ] [ "blahblah" temp-file dup exists? [ delete-directory ] [ drop ] if ] unit-test [ ] [ "blahblah" temp-file make-directory ] unit-test -[ t ] [ "blahblah" temp-file directory? ] unit-test +[ t ] [ "blahblah" temp-file file-info directory? ] unit-test [ t ] [ [ temp-directory "loldir" append-path delete-directory ] ignore-errors diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 2b4bb170ea..87e927304b 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: io.backend io.files.private io hashtables kernel math memory namespaces sequences strings assocs arrays definitions -system combinators splitting sbufs continuations io.encodings -io.encodings.binary init accessors math.order ; +system combinators splitting sbufs continuations destructors +io.encodings io.encodings.binary init accessors math.order ; IN: io.files HOOK: (file-reader) io-backend ( path -- stream ) @@ -172,11 +172,9 @@ SYMBOL: +socket+ SYMBOL: +unknown+ ! File metadata -: exists? ( path -- ? ) - normalize-path (exists?) ; +: exists? ( path -- ? ) normalize-path (exists?) ; -: directory? ( path -- ? ) - file-info file-info-type +directory+ = ; +: directory? ( file-info -- ? ) type>> +directory+ = ; c-writer +: ( handle -- stream ) f c-writer boa ; M: c-writer stream-write1 - c-writer-handle fputc ; + handle>> fputc ; M: c-writer stream-write - c-writer-handle fwrite ; + handle>> fwrite ; M: c-writer stream-flush - c-writer-handle fflush ; + handle>> fflush ; -M: c-writer dispose - c-writer-handle fclose ; +M: c-writer dispose* + handle>> fclose ; -TUPLE: c-reader handle ; +TUPLE: c-reader handle disposed ; -C: c-reader +: ( handle -- stream ) f c-reader boa ; M: c-reader stream-read - c-reader-handle fread ; + handle>> fread ; M: c-reader stream-read-partial stream-read ; M: c-reader stream-read1 - c-reader-handle fgetc ; + handle>> fgetc ; : read-until-loop ( stream delim -- ch ) over stream-read1 dup [ @@ -45,8 +45,8 @@ M: c-reader stream-read-until [ swap read-until-loop ] B{ } make swap over empty? over not and [ 2drop f f ] when ; -M: c-reader dispose - c-reader-handle fclose ; +M: c-reader dispose* + handle>> fclose ; M: object init-io ; diff --git a/core/io/streams/nested/nested.factor b/core/io/streams/nested/nested.factor index fd67910b6f..bb6a7a9111 100755 --- a/core/io/streams/nested/nested.factor +++ b/core/io/streams/nested/nested.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays generic assocs kernel namespaces strings -quotations io continuations accessors sequences ; +quotations io continuations destructors accessors sequences ; IN: io.streams.nested TUPLE: filter-writer stream ; diff --git a/core/io/streams/string/string.factor b/core/io/streams/string/string.factor index c0b37dbce7..355e913b14 100755 --- a/core/io/streams/string/string.factor +++ b/core/io/streams/string/string.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2003, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: io kernel math namespaces sequences sbufs strings -generic splitting growable continuations io.streams.plain -io.encodings math.order ; +generic splitting growable continuations destructors +io.streams.plain io.encodings math.order ; IN: io.streams.string M: growable dispose drop ; diff --git a/core/libc/libc-docs.factor b/core/libc/libc-docs.factor index 45d6b94326..5e285bf26d 100644 --- a/core/libc/libc-docs.factor +++ b/core/libc/libc-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax alien ; +USING: help.markup help.syntax alien destructors ; IN: libc HELP: malloc @@ -36,5 +36,13 @@ HELP: with-malloc { $values { "size" "a positive integer" } { "quot" "a quotation with stack effect " { $snippet "( c-ptr -- )" } } } { $description "Allocates a zeroed block of " { $snippet "n" } " bytes and passes it to the quotation. When the quotation returns, the block is freed." } ; +HELP: &free +{ $values { "alien" c-ptr } } +{ $description "Marks the block of memory for unconditional deallocation at the end of the current " { $link with-destructors } " scope." } ; + +HELP: |free +{ $values { "alien" c-ptr } } +{ $description "Marks the object for deallocation in the event of an error at the end of the current " { $link with-destructors } " scope." } ; + ! Defined in alien-docs.factor ABOUT: "malloc" diff --git a/core/libc/libc.factor b/core/libc/libc.factor index 70850a2894..cba0b9253f 100755 --- a/core/libc/libc.factor +++ b/core/libc/libc.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2004, 2005 Mackenzie Straight -! Copyright (C) 2007 Slava Pestov -! Copyright (C) 2007 Doug Coleman +! Copyright (C) 2007, 2008 Slava Pestov +! Copyright (C) 2007, 2008 Doug Coleman ! See http://factorcode.org/license.txt for BSD license. -USING: alien assocs continuations init kernel namespaces ; +USING: alien assocs continuations destructors init kernel +namespaces accessors ; IN: libc : strlen ( alien -- len ) "size_t" "libc" "strlen" { "char*" } alien-invoke ; + +> free ; + +PRIVATE> + +: &free ( alien -- alien ) + dup memory-destructor boa &dispose drop ; inline + +: |free ( alien -- alien ) + dup memory-destructor boa |dispose drop ; inline diff --git a/extra/benchmark/sockets/sockets.factor b/extra/benchmark/sockets/sockets.factor index 6defd94290..673a67d93f 100755 --- a/extra/benchmark/sockets/sockets.factor +++ b/extra/benchmark/sockets/sockets.factor @@ -1,6 +1,7 @@ USING: io.sockets io kernel math threads io.encodings.ascii io.streams.duplex debugger tools.time prettyprint -concurrency.count-downs namespaces arrays continuations ; +concurrency.count-downs namespaces arrays continuations +destructors ; IN: benchmark.sockets SYMBOL: counter diff --git a/extra/bunny/bunny.factor b/extra/bunny/bunny.factor index 6ebd598dc6..b315e4ca5a 100755 --- a/extra/bunny/bunny.factor +++ b/extra/bunny/bunny.factor @@ -4,7 +4,7 @@ opengl.glu shuffle http.client vectors namespaces ui.gadgets ui.gadgets.canvas ui.render ui splitting combinators tools.time system combinators.lib float-arrays continuations opengl.demo-support multiline ui.gestures bunny.fixed-pipeline -bunny.cel-shaded bunny.outlined bunny.model accessors ; +bunny.cel-shaded bunny.outlined bunny.model accessors destructors ; IN: bunny TUPLE: bunny-gadget model geom draw-seq draw-n ; diff --git a/extra/bunny/cel-shaded/cel-shaded.factor b/extra/bunny/cel-shaded/cel-shaded.factor index 08bea0515b..8285cd776f 100644 --- a/extra/bunny/cel-shaded/cel-shaded.factor +++ b/extra/bunny/cel-shaded/cel-shaded.factor @@ -1,5 +1,6 @@ -USING: arrays bunny.model continuations kernel multiline opengl opengl.shaders - opengl.capabilities opengl.gl sequences sequences.lib accessors ; +USING: arrays bunny.model continuations destructors kernel +multiline opengl opengl.shaders opengl.capabilities opengl.gl +sequences sequences.lib accessors ; IN: bunny.cel-shaded STRING: vertex-shader-source diff --git a/extra/bunny/fixed-pipeline/fixed-pipeline.factor b/extra/bunny/fixed-pipeline/fixed-pipeline.factor index bf0fc45f0f..0bad9cc943 100644 --- a/extra/bunny/fixed-pipeline/fixed-pipeline.factor +++ b/extra/bunny/fixed-pipeline/fixed-pipeline.factor @@ -1,4 +1,4 @@ -USING: alien.c-types continuations kernel +USING: alien.c-types continuations destructors kernel opengl opengl.gl bunny.model ; IN: bunny.fixed-pipeline diff --git a/extra/bunny/model/model.factor b/extra/bunny/model/model.factor index 95b5fe401d..2dac9eb688 100755 --- a/extra/bunny/model/model.factor +++ b/extra/bunny/model/model.factor @@ -2,7 +2,8 @@ USING: alien alien.c-types arrays sequences math math.vectors math.matrices math.parser io io.files kernel opengl opengl.gl opengl.glu io.encodings.ascii opengl.capabilities shuffle http.client vectors splitting tools.time system combinators -float-arrays continuations namespaces sequences.lib accessors ; +float-arrays continuations destructors namespaces sequences.lib +accessors ; IN: bunny.model : numbers ( str -- seq ) diff --git a/extra/bunny/outlined/outlined.factor b/extra/bunny/outlined/outlined.factor index fef57d95d2..f3ee4594c7 100755 --- a/extra/bunny/outlined/outlined.factor +++ b/extra/bunny/outlined/outlined.factor @@ -1,7 +1,7 @@ -USING: arrays bunny.model bunny.cel-shaded continuations kernel -math multiline opengl opengl.shaders opengl.framebuffers -opengl.gl opengl.capabilities sequences ui.gadgets combinators -accessors ; +USING: arrays bunny.model bunny.cel-shaded continuations +destructors kernel math multiline opengl opengl.shaders +opengl.framebuffers opengl.gl opengl.capabilities sequences +ui.gadgets combinators accessors ; IN: bunny.outlined STRING: outlined-pass1-fragment-shader-main-source diff --git a/extra/cairo/cairo.factor b/extra/cairo/cairo.factor index 077152a3c2..46d3e42c2b 100755 --- a/extra/cairo/cairo.factor +++ b/extra/cairo/cairo.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: cairo.ffi kernel accessors sequences -namespaces fry continuations ; +namespaces fry continuations destructors ; IN: cairo TUPLE: cairo-t alien ; diff --git a/extra/checksums/openssl/openssl.factor b/extra/checksums/openssl/openssl.factor index fe96a52277..d42febb541 100644 --- a/extra/checksums/openssl/openssl.factor +++ b/extra/checksums/openssl/openssl.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: accessors byte-arrays alien.c-types kernel continuations -sequences io openssl openssl.libcrypto checksums ; +destructors sequences io openssl openssl.libcrypto checksums ; IN: checksums.openssl ERROR: unknown-digest name ; diff --git a/extra/combinators/lib/lib-tests.factor b/extra/combinators/lib/lib-tests.factor index ed481f72e6..54847dc8b3 100755 --- a/extra/combinators/lib/lib-tests.factor +++ b/extra/combinators/lib/lib-tests.factor @@ -19,6 +19,13 @@ IN: combinators.lib.tests [ { 1 2 } { 2 4 } { 3 8 } { 4 16 } { 5 32 } ] [ 1 2 3 4 5 [ dup 2^ 2array ] 5 napply ] unit-test [ [ dup 2^ 2array ] 5 napply ] must-infer +[ { "xyc" "xyd" } ] [ "x" "y" { "c" "d" } [ 3append ] 2 nwith map ] unit-test + +[ { "foo" "xbarx" } ] +[ + { "oof" "bar" } { [ reverse ] [ "x" swap "x" 3append ] } parallel-call +] unit-test + ! && [ t ] [ diff --git a/extra/combinators/lib/lib.factor b/extra/combinators/lib/lib.factor index 5dfe8527c1..d4a9386649 100755 --- a/extra/combinators/lib/lib.factor +++ b/extra/combinators/lib/lib.factor @@ -4,7 +4,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel combinators fry namespaces quotations hashtables sequences assocs arrays inference effects math math.ranges -arrays.lib shuffle macros bake continuations ; +arrays.lib shuffle macros continuations locals ; IN: combinators.lib @@ -20,17 +20,15 @@ MACRO: nslip ( n -- ) dup saver [ call ] rot restorer 3append ; MACRO: nkeep ( n -- ) [ ] [ 1+ ] [ ] tri - [ [ , ndup ] dip , -nrot , nslip ] - bake ; + '[ [ , ndup ] dip , -nrot , nslip ] ; : 4keep ( w x y z quot -- w x y z ) 4 nkeep ; inline MACRO: ncurry ( n -- ) [ curry ] n*quot ; -MACRO: nwith ( quot n -- ) - tuck 1+ dup - [ , -nrot [ , nrot , call ] , ncurry ] - bake ; +MACRO:: nwith ( quot n -- ) + [let | n' [ n 1+ ] | + [ n' -nrot [ n' nrot quot call ] n ncurry ] ] ; MACRO: napply ( n -- ) 2 [a,b] @@ -110,8 +108,8 @@ MACRO: switch ( quot -- ) ! : pcall ( seq quots -- seq ) [ call ] 2map ; MACRO: parallel-call ( quots -- ) - [ [ unclip % r> dup >r push ] bake ] map concat - [ V{ } clone >r % drop r> >array ] bake ; + [ '[ [ unclip @ ] dip [ push ] keep ] ] map concat + '[ V{ } clone @ nip >array ] ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! map-call and friends diff --git a/extra/concurrency/mailboxes/mailboxes.factor b/extra/concurrency/mailboxes/mailboxes.factor index aa4dc2df3d..25541ce717 100755 --- a/extra/concurrency/mailboxes/mailboxes.factor +++ b/extra/concurrency/mailboxes/mailboxes.factor @@ -1,17 +1,13 @@ ! Copyright (C) 2005, 2008 Chris Double, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: concurrency.mailboxes -USING: dlists threads sequences continuations +USING: dlists threads sequences continuations destructors namespaces random math quotations words kernel arrays assocs init system concurrency.conditions accessors debugger ; -TUPLE: mailbox threads data closed ; +TUPLE: mailbox threads data disposed ; -: check-closed ( mailbox -- ) - closed>> [ "Mailbox closed" throw ] when ; inline - -M: mailbox dispose - t >>closed threads>> notify-all ; +M: mailbox dispose* threads>> notify-all ; : ( -- mailbox ) f mailbox boa ; @@ -27,7 +23,7 @@ M: mailbox dispose >r threads>> r> "mailbox" wait ; : block-unless-pred ( mailbox timeout pred -- ) - pick check-closed + pick check-disposed pick data>> over dlist-contains? [ 3drop ] [ @@ -35,7 +31,7 @@ M: mailbox dispose ] if ; inline : block-if-empty ( mailbox timeout -- mailbox ) - over check-closed + over check-disposed over mailbox-empty? [ 2dup wait-for-mailbox block-if-empty ] [ diff --git a/extra/core-foundation/fsevents/fsevents.factor b/extra/core-foundation/fsevents/fsevents.factor index 4698aa45ae..261e1d045a 100644 --- a/extra/core-foundation/fsevents/fsevents.factor +++ b/extra/core-foundation/fsevents/fsevents.factor @@ -3,7 +3,7 @@ USING: alien alien.c-types alien.strings alien.syntax kernel math sequences namespaces assocs init accessors continuations combinators core-foundation core-foundation.run-loop -io.encodings.utf8 ; +io.encodings.utf8 destructors ; IN: core-foundation.fsevents ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! @@ -187,7 +187,7 @@ SYMBOL: event-stream-callbacks dup [ call drop ] [ 3drop ] if ] alien-callback ; -TUPLE: event-stream info handle closed ; +TUPLE: event-stream info handle disposed ; : ( quot paths latency flags -- event-stream ) >r >r >r @@ -197,13 +197,10 @@ TUPLE: event-stream info handle closed ; dup enable-event-stream f event-stream boa ; -M: event-stream dispose - dup closed>> [ drop ] [ - t >>closed - { - [ info>> remove-event-source-callback ] - [ handle>> disable-event-stream ] - [ handle>> FSEventStreamInvalidate ] - [ handle>> FSEventStreamRelease ] - } cleave - ] if ; +M: event-stream dispose* + { + [ info>> remove-event-source-callback ] + [ handle>> disable-event-stream ] + [ handle>> FSEventStreamInvalidate ] + [ handle>> FSEventStreamRelease ] + } cleave ; diff --git a/extra/db/db.factor b/extra/db/db.factor index 237d8698a6..9514f62cf0 100755 --- a/extra/db/db.factor +++ b/extra/db/db.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays assocs classes continuations kernel math +USING: arrays assocs classes continuations destructors kernel math namespaces sequences sequences.lib classes.tuple words strings tools.walker accessors combinators.lib ; IN: db @@ -25,7 +25,7 @@ GENERIC: make-db* ( seq class -- db ) GENERIC: db-open ( db -- db ) HOOK: db-close db ( handle -- ) -: dispose-statements ( seq -- ) [ dispose drop ] assoc-each ; +: dispose-statements ( assoc -- ) values dispose-each ; : dispose-db ( db -- ) dup db [ diff --git a/extra/db/mysql/mysql.factor b/extra/db/mysql/mysql.factor index f8700debaa..1767bf3d50 100755 --- a/extra/db/mysql/mysql.factor +++ b/extra/db/mysql/mysql.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for license. -USING: alien continuations io kernel prettyprint sequences -db db.mysql.ffi ; +USING: alien continuations destructors io kernel prettyprint +sequences db db.mysql.ffi ; IN: db.mysql TUPLE: mysql-db handle host user password db port ; diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor index 9f747082c6..3e81b264d6 100755 --- a/extra/db/postgresql/postgresql.factor +++ b/extra/db/postgresql/postgresql.factor @@ -5,7 +5,7 @@ kernel math math.parser namespaces prettyprint quotations sequences debugger db db.postgresql.lib db.postgresql.ffi db.tuples db.types tools.annotations math.ranges combinators sequences.lib classes locals words tools.walker -namespaces.lib accessors random db.queries ; +namespaces.lib accessors random db.queries destructors ; USE: tools.walker IN: db.postgresql diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index 4aaa9668f0..c10775f1c9 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -6,7 +6,7 @@ prettyprint sequences strings classes.tuple alien.c-types continuations db.sqlite.lib db.sqlite.ffi db.tuples words combinators.lib db.types combinators math.intervals io namespaces.lib accessors vectors math.ranges random -math.bitfields.lib db.queries ; +math.bitfields.lib db.queries destructors ; USE: tools.walker IN: db.sqlite diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index 5747fa7de7..c940d121bb 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -3,7 +3,7 @@ USING: arrays assocs classes db kernel namespaces classes.tuple words sequences slots math accessors math.parser io prettyprint db.types continuations -mirrors sequences.lib combinators.lib ; +destructors mirrors sequences.lib combinators.lib ; IN: db.tuples : define-persistent ( class table columns -- ) diff --git a/extra/destructors/destructors-docs.factor b/extra/destructors/destructors-docs.factor deleted file mode 100755 index 28f8858597..0000000000 --- a/extra/destructors/destructors-docs.factor +++ /dev/null @@ -1,16 +0,0 @@ -USING: help.markup help.syntax libc kernel continuations ; -IN: destructors - -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 generalize " { $link with-disposal } ". The following two lines are equivalent:" - { $code - "[ X ] with-disposal" - "[ &dispose X ] with-destructors" - } -} -{ $examples - { $code "[ 10 malloc &free ] with-destructors" } -} ; diff --git a/extra/destructors/destructors.factor b/extra/destructors/destructors.factor deleted file mode 100755 index 86f8fa1f48..0000000000 --- a/extra/destructors/destructors.factor +++ /dev/null @@ -1,54 +0,0 @@ -! Copyright (C) 2007 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors continuations io.backend libc -kernel namespaces sequences system vectors ; -IN: destructors - - dispose-each ; - -: 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 - V{ } clone error-destructors set - [ do-always-destructors ] - [ do-error-destructors ] cleanup - ] with-scope ; inline - -TUPLE: only-once object destroyed ; - -M: only-once dispose - dup destroyed>> [ drop ] [ - [ object>> dispose ] [ t >>destroyed drop ] bi - ] if ; - -: f only-once boa ; - -! Memory allocations -TUPLE: memory-destructor alien ; - -C: memory-destructor - -M: memory-destructor dispose ( obj -- ) - alien>> free ; - -: &free ( alien -- alien ) - &dispose ; inline - -: |free ( alien -- alien ) - |dispose ; inline diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor index dd4106239d..863a538b47 100755 --- a/extra/help/handbook/handbook.factor +++ b/extra/help/handbook/handbook.factor @@ -105,6 +105,7 @@ ARTICLE: "objects" "Objects" "An " { $emphasis "object" } " is any datum which may be identified. All values are objects in Factor. Each object carries type information, and types are checked at runtime; Factor is dynamically typed." { $subsection "equality" } { $subsection "math.order" } +{ $subsection "destructors" } { $subsection "classes" } { $subsection "tuples" } { $subsection "generic" } @@ -207,7 +208,8 @@ ARTICLE: "io" "Input and output" { $subsection "io.pipes" } { $heading "Other features" } { $subsection "io.timeouts" } -{ $subsection "checksums" } ; +{ $subsection "checksums" } +{ $see-also "destructors" } ; ARTICLE: "tools" "Developer tools" { $subsection "tools.vocabs" } diff --git a/extra/html/html.factor b/extra/html/html.factor index c154c35223..71862b0d01 100755 --- a/extra/html/html.factor +++ b/extra/html/html.factor @@ -3,7 +3,7 @@ USING: generic assocs help http io io.styles io.files continuations io.streams.string kernel math math.order math.parser namespaces quotations assocs sequences strings words html.elements -xml.entities sbufs continuations ; +xml.entities sbufs continuations destructors ; IN: html GENERIC: browser-link-href ( presented -- href ) diff --git a/extra/http/server/static/static.factor b/extra/http/server/static/static.factor index b9a8e9d46e..2f7a6eb221 100755 --- a/extra/http/server/static/static.factor +++ b/extra/http/server/static/static.factor @@ -91,7 +91,7 @@ TUPLE: file-responder root hook special allow-listings ; : serve-object ( filename -- response ) serving-path dup exists? - [ dup directory? [ serve-directory ] [ serve-file ] if ] + [ dup file-info directory? [ serve-directory ] [ serve-file ] if ] [ drop <404> ] if ; diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index 90eea091d5..54715e23da 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -151,7 +151,7 @@ M: process timed-out kill-process ; M: object run-pipeline-element [ >process swap >>stdout swap >>stdin run-detached ] - [ drop [ [ close-handle ] when* ] bi@ ] + [ drop [ [ dispose ] when* ] bi@ ] 3bi wait-for-process ; @@ -164,7 +164,7 @@ M: object run-pipeline-element [ swap out>> or ] change-stdout run-detached ] - [ out>> close-handle ] + [ out>> dispose ] [ in>> ] } cleave r> ] with-destructors ; @@ -181,7 +181,7 @@ M: object run-pipeline-element [ swap in>> or ] change-stdout run-detached ] - [ in>> close-handle ] + [ in>> dispose ] [ out>> ] } cleave r> ] with-destructors ; @@ -199,7 +199,7 @@ M: object run-pipeline-element [ swap in>> or ] change-stdin run-detached ] - [ [ out>> close-handle ] [ in>> close-handle ] bi* ] + [ [ out>> dispose ] [ in>> dispose ] bi* ] [ [ in>> ] [ out>> ] bi* ] } 2cleave r> ] with-destructors ; diff --git a/extra/io/mmap/mmap-docs.factor b/extra/io/mmap/mmap-docs.factor index cb51088e58..0c8148d6b0 100755 --- a/extra/io/mmap/mmap-docs.factor +++ b/extra/io/mmap/mmap-docs.factor @@ -1,4 +1,5 @@ -USING: help.markup help.syntax alien math continuations ; +USING: help.markup help.syntax alien math continuations +destructors ; IN: io.mmap HELP: mapped-file diff --git a/extra/io/mmap/mmap.factor b/extra/io/mmap/mmap.factor index 2f637a4f81..dde5210995 100755 --- a/extra/io/mmap/mmap.factor +++ b/extra/io/mmap/mmap.factor @@ -1,23 +1,19 @@ ! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: continuations io.backend kernel quotations sequences -system alien alien.accessors accessors sequences.private ; +USING: continuations destructors io.backend kernel quotations +sequences system alien alien.accessors accessors +sequences.private ; IN: io.mmap -TUPLE: mapped-file address handle length closed ; +TUPLE: mapped-file address handle length disposed ; -: check-closed ( mapped-file -- mapped-file ) - dup closed>> [ - "Mapped file is closed" throw - ] when ; inline - -M: mapped-file length check-closed length>> ; +M: mapped-file length dup check-disposed length>> ; M: mapped-file nth-unsafe - check-closed address>> swap alien-unsigned-1 ; + dup check-disposed address>> swap alien-unsigned-1 ; M: mapped-file set-nth-unsafe - check-closed address>> swap set-alien-unsigned-1 ; + dup check-disposed address>> swap set-alien-unsigned-1 ; INSTANCE: mapped-file sequence @@ -29,10 +25,7 @@ HOOK: (mapped-file) io-backend ( path length -- address handle ) HOOK: close-mapped-file io-backend ( mmap -- ) -M: mapped-file dispose ( mmap -- ) - dup closed>> [ drop ] [ - t >>closed close-mapped-file - ] if ; +M: mapped-file dispose* ( mmap -- ) close-mapped-file ; : with-mapped-file ( path length quot -- ) >r r> with-disposal ; inline diff --git a/extra/io/monitors/monitors-docs.factor b/extra/io/monitors/monitors-docs.factor index cd6a06a8e9..b81bd1d303 100755 --- a/extra/io/monitors/monitors-docs.factor +++ b/extra/io/monitors/monitors-docs.factor @@ -1,5 +1,5 @@ IN: io.monitors -USING: help.markup help.syntax continuations +USING: help.markup help.syntax continuations destructors concurrency.mailboxes quotations ; HELP: with-monitors diff --git a/extra/io/monitors/monitors-tests.factor b/extra/io/monitors/monitors-tests.factor index 77d539259e..3a4328a7b8 100644 --- a/extra/io/monitors/monitors-tests.factor +++ b/extra/io/monitors/monitors-tests.factor @@ -1,7 +1,7 @@ IN: io.monitors.tests USING: io.monitors tools.test io.files system sequences continuations namespaces concurrency.count-downs kernel io -threads calendar prettyprint ; +threads calendar prettyprint destructors ; os { winnt linux macosx } member? [ [ diff --git a/extra/io/monitors/monitors.factor b/extra/io/monitors/monitors.factor index 863c8fc95c..65c1eb7e82 100755 --- a/extra/io/monitors/monitors.factor +++ b/extra/io/monitors/monitors.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: io.backend kernel continuations namespaces sequences -assocs hashtables sorting arrays threads boxes io.timeouts -accessors concurrency.mailboxes ; +USING: io.backend kernel continuations destructors namespaces +sequences assocs hashtables sorting arrays threads boxes +io.timeouts accessors concurrency.mailboxes ; IN: io.monitors HOOK: init-monitors io-backend ( -- ) diff --git a/extra/io/monitors/recursive/recursive.factor b/extra/io/monitors/recursive/recursive.factor index 04d491edbe..383e166214 100644 --- a/extra/io/monitors/recursive/recursive.factor +++ b/extra/io/monitors/recursive/recursive.factor @@ -1,13 +1,14 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors sequences assocs arrays continuations combinators kernel -threads concurrency.messaging concurrency.mailboxes concurrency.promises -io.files io.monitors debugger ; +USING: accessors sequences assocs arrays continuations +destructors combinators kernel threads concurrency.messaging +concurrency.mailboxes concurrency.promises io.files io.monitors +debugger ; IN: io.monitors.recursive ! Simulate recursive monitors on platforms that don't have them -TUPLE: recursive-monitor < monitor children thread ready ; +TUPLE: recursive-monitor < monitor children thread ready disposed ; : notify? ( -- ? ) monitor tget ready>> promise-fulfilled? ; @@ -35,13 +36,10 @@ DEFER: add-child-monitor : remove-child-monitor ( monitor -- ) monitor tget children>> delete-at* [ dispose ] [ drop ] if ; -M: recursive-monitor dispose - dup queue>> closed>> [ - drop - ] [ - [ "stop" swap thread>> send-synchronous drop ] - [ queue>> dispose ] bi - ] if ; +M: recursive-monitor dispose* + [ "stop" swap thread>> send-synchronous drop ] + [ queue>> dispose ] + bi ; : stop-pump ( -- ) monitor tget children>> [ nip dispose ] assoc-each ; diff --git a/extra/io/pipes/pipes-docs.factor b/extra/io/pipes/pipes-docs.factor index d51ae94bc7..221cce1dbe 100644 --- a/extra/io/pipes/pipes-docs.factor +++ b/extra/io/pipes/pipes-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax continuations io ; +USING: help.markup help.syntax continuations destructors io ; IN: io.pipes HELP: pipe diff --git a/extra/io/pipes/pipes-tests.factor b/extra/io/pipes/pipes-tests.factor index 4fb9d57748..d1c2e54bb0 100755 --- a/extra/io/pipes/pipes-tests.factor +++ b/extra/io/pipes/pipes-tests.factor @@ -1,6 +1,6 @@ USING: io io.pipes io.streams.string io.encodings.utf8 io.streams.duplex io.encodings io.timeouts namespaces -continuations tools.test kernel calendar ; +continuations tools.test kernel calendar destructors ; IN: io.pipes.tests [ "Hello" ] [ diff --git a/extra/io/pipes/pipes.factor b/extra/io/pipes/pipes.factor index ef6b200f64..f98fa4b0d4 100644 --- a/extra/io/pipes/pipes.factor +++ b/extra/io/pipes/pipes.factor @@ -9,7 +9,7 @@ IN: io.pipes TUPLE: pipe in out ; M: pipe dispose ( pipe -- ) - [ in>> close-handle ] [ out>> close-handle ] bi ; + [ in>> dispose ] [ out>> dispose ] bi ; HOOK: (pipe) io-backend ( -- pipe ) diff --git a/extra/io/ports/ports-docs.factor b/extra/io/ports/ports-docs.factor index 265b74e87a..0db8b01df5 100755 --- a/extra/io/ports/ports-docs.factor +++ b/extra/io/ports/ports-docs.factor @@ -1,5 +1,6 @@ USING: io io.buffers io.backend help.markup help.syntax kernel -byte-arrays sbufs words continuations byte-vectors classes ; +byte-arrays sbufs words continuations destructors +byte-vectors classes ; IN: io.ports ARTICLE: "io.ports" "Non-blocking I/O implementation" diff --git a/extra/io/ports/ports.factor b/extra/io/ports/ports.factor index f1f4ca9cf2..56455d7711 100755 --- a/extra/io/ports/ports.factor +++ b/extra/io/ports/ports.factor @@ -10,7 +10,7 @@ IN: io.ports SYMBOL: default-buffer-size 64 1024 * default-buffer-size set-global -TUPLE: port handle error timeout closed ; +TUPLE: port handle error timeout disposed ; M: port timeout timeout>> ; @@ -18,21 +18,6 @@ M: port set-timeout (>>timeout) ; GENERIC: init-handle ( handle -- ) -GENERIC: close-handle ( handle -- ) - -TUPLE: handle-destructor handle ; - -C: handle-destructor - -M: handle-destructor dispose ( obj -- ) - handle>> close-handle ; - -: &close-handle ( handle -- handle ) - dup &dispose drop ; inline - -: |close-handle ( handle -- handle ) - dup |dispose drop ; inline - : ( handle class -- port ) new swap dup init-handle >>handle ; inline @@ -40,14 +25,6 @@ M: handle-destructor dispose ( obj -- ) : pending-error ( port -- ) [ f ] change-error drop [ throw ] when* ; -ERROR: port-closed-error port ; - -M: port-closed-error summary - drop "Port has been closed" ; - -: check-closed ( port -- port ) - dup closed>> [ port-closed-error ] when ; - TUPLE: buffered-port < port buffer ; : ( handle class -- port ) @@ -69,7 +46,7 @@ HOOK: (wait-to-read) io-backend ( port -- ) [ f >>eof drop f ] r> if ; inline M: input-port stream-read1 - check-closed + dup check-disposed dup wait-to-read [ buffer>> buffer-pop ] unless-eof ; : read-step ( count port -- byte-array/f ) @@ -77,7 +54,7 @@ M: input-port stream-read1 [ dupd buffer>> buffer-read ] unless-eof nip ; M: input-port stream-read-partial ( max stream -- byte-array/f ) - check-closed + dup check-disposed >r 0 max >integer r> read-step ; : read-loop ( count port accum -- ) @@ -92,7 +69,7 @@ M: input-port stream-read-partial ( max stream -- byte-array/f ) ] if ; M: input-port stream-read - check-closed + dup check-disposed >r 0 max >fixnum r> 2dup read-step dup [ pick over length > [ @@ -115,12 +92,12 @@ TUPLE: output-port < buffered-port ; tuck buffer>> can-write? [ drop ] [ stream-flush ] if ; M: output-port stream-write1 - check-closed + dup check-disposed 1 over wait-to-write buffer>> byte>buffer ; M: output-port stream-write - check-closed + dup check-disposed over length over buffer>> buffer-size > [ [ buffer>> buffer-size ] [ [ stream-write ] curry ] bi @@ -136,15 +113,13 @@ HOOK: (wait-to-write) io-backend ( port -- ) dup buffer>> buffer-empty? [ drop ] [ (wait-to-write) ] if ; M: output-port stream-flush ( port -- ) - check-closed + dup check-disposed [ flush-port ] [ pending-error ] bi ; -GENERIC: close-port ( port -- ) - -M: output-port close-port +M: output-port dispose* [ flush-port ] [ call-next-method ] bi ; -M: buffered-port close-port +M: buffered-port dispose* [ call-next-method ] [ [ [ buffer-free ] when* f ] change-buffer drop ] bi ; @@ -153,11 +128,7 @@ HOOK: cancel-io io-backend ( port -- ) M: port timed-out cancel-io ; -M: port close-port - [ cancel-io ] [ handle>> close-handle ] bi ; - -M: port dispose - dup closed>> [ drop ] [ t >>closed close-port ] if ; +M: port dispose* [ cancel-io ] [ handle>> dispose ] bi ; : ( read-handle write-handle -- input-port output-port ) [ diff --git a/extra/io/server/server.factor b/extra/io/server/server.factor index e15e8c0039..221a3301ce 100755 --- a/extra/io/server/server.factor +++ b/extra/io/server/server.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: io io.sockets io.files io.streams.duplex logging -continuations kernel math math.parser namespaces parser -sequences strings prettyprint debugger quotations calendar -threads concurrency.combinators assocs fry ; +continuations destructors kernel math math.parser namespaces +parser sequences strings prettyprint debugger quotations +calendar threads concurrency.combinators assocs fry ; IN: io.server SYMBOL: servers diff --git a/extra/io/sockets/secure/secure.factor b/extra/io/sockets/secure/secure.factor index 6cd711da81..d9ca85ddd6 100644 --- a/extra/io/sockets/secure/secure.factor +++ b/extra/io/sockets/secure/secure.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel symbols namespaces continuations -io.sockets sequences ; +destructors io.sockets sequences ; IN: io.sockets.secure SYMBOL: ssl-backend diff --git a/extra/io/sockets/sockets-docs.factor b/extra/io/sockets/sockets-docs.factor index db07caa330..7ef08575c0 100755 --- a/extra/io/sockets/sockets-docs.factor +++ b/extra/io/sockets/sockets-docs.factor @@ -1,5 +1,5 @@ USING: help.markup help.syntax io io.backend threads -strings byte-arrays continuations quotations ; +strings byte-arrays continuations destructors quotations ; IN: io.sockets ARTICLE: "network-addressing" "Address specifiers" diff --git a/extra/io/sockets/sockets.factor b/extra/io/sockets/sockets.factor index ba6d16a364..40f6c22b82 100755 --- a/extra/io/sockets/sockets.factor +++ b/extra/io/sockets/sockets.factor @@ -187,7 +187,7 @@ SYMBOL: local-address TUPLE: server-port < port addr encoding ; : check-server-port ( port -- port ) - check-closed + dup check-disposed dup server-port? [ "Not a server port" throw ] unless ; inline GENERIC: (server) ( addrspec -- handle ) @@ -216,7 +216,7 @@ HOOK: (datagram) io-backend ( addr -- datagram ) dup (datagram) datagram-port swap >>addr ; : check-datagram-port ( port -- port ) - check-closed + dup check-disposed dup datagram-port? [ "Not a datagram port" throw ] unless ; inline HOOK: (receive) io-backend ( datagram -- packet addrspec ) diff --git a/extra/io/streams/duplex/duplex-docs.factor b/extra/io/streams/duplex/duplex-docs.factor index 15d401ad68..ca4f424fb6 100755 --- a/extra/io/streams/duplex/duplex-docs.factor +++ b/extra/io/streams/duplex/duplex-docs.factor @@ -18,9 +18,6 @@ HELP: { $values { "in" "an input stream" } { "out" "an output stream" } { "stream" " a duplex stream" } } { $description "Creates a duplex stream. Writing to a duplex stream will write to " { $snippet "out" } ", and reading from a duplex stream will read from " { $snippet "in" } ". Closing a duplex stream closes both the input and output streams." } ; -HELP: stream-closed-twice -{ $error-description "This error is thrown when performing an I/O operation on a " { $link duplex-stream } " which has been closed with " { $link dispose } "." } ; - HELP: with-stream { $values { "stream" duplex-stream } { "quot" quotation } } { $description "Calls the quotation in a new dynamic scope, with both " { $link input-stream } " and " { $link output-stream } " rebound to " { $snippet "stream" } ". The stream is closed if the quotation returns or throws an error." } ; diff --git a/extra/io/streams/duplex/duplex-tests.factor b/extra/io/streams/duplex/duplex-tests.factor index 9377256c0d..860702c563 100755 --- a/extra/io/streams/duplex/duplex-tests.factor +++ b/extra/io/streams/duplex/duplex-tests.factor @@ -1,18 +1,13 @@ USING: io.streams.duplex io io.streams.string -kernel continuations tools.test ; +kernel continuations tools.test destructors accessors ; IN: io.streams.duplex.tests ! Test duplex stream close behavior -TUPLE: closing-stream closed? ; +TUPLE: closing-stream < disposable ; : closing-stream new ; -M: closing-stream dispose - dup closing-stream-closed? [ - "Closing twice!" throw - ] [ - t swap set-closing-stream-closed? - ] if ; +M: closing-stream dispose* drop ; TUPLE: unclosable-stream ; @@ -30,14 +25,14 @@ M: unclosable-stream dispose [ [ dup dispose ] [ 2drop ] recover - ] keep closing-stream-closed? + ] keep disposed>> ] unit-test [ t ] [ [ [ dup dispose ] [ 2drop ] recover - ] keep closing-stream-closed? + ] keep disposed>> ] unit-test [ "Hey" ] [ diff --git a/extra/io/streams/duplex/duplex.factor b/extra/io/streams/duplex/duplex.factor index 6ac663f9f2..86b9f90ff5 100755 --- a/extra/io/streams/duplex/duplex.factor +++ b/extra/io/streams/duplex/duplex.factor @@ -1,50 +1,33 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel continuations io io.encodings io.encodings.private -io.timeouts debugger inspector listener accessors delegate -delegate.protocols ; +USING: kernel continuations destructors io io.encodings +io.encodings.private io.timeouts debugger inspector listener +accessors delegate delegate.protocols ; IN: io.streams.duplex ! We ensure that the stream can only be closed once, to preserve ! integrity of duplex I/O ports. -TUPLE: duplex-stream in out closed ; +TUPLE: duplex-stream in out ; -: ( in out -- stream ) - f duplex-stream boa ; +C: duplex-stream -ERROR: stream-closed-twice ; +CONSULT: input-stream-protocol duplex-stream in>> ; -M: stream-closed-twice summary - drop "Attempt to perform I/O on closed stream" ; - -> [ stream-closed-twice ] when ; inline - -: in ( duplex -- stream ) check-closed in>> ; - -: out ( duplex -- stream ) check-closed out>> ; - -PRIVATE> - -CONSULT: input-stream-protocol duplex-stream in ; - -CONSULT: output-stream-protocol duplex-stream out ; +CONSULT: output-stream-protocol duplex-stream out>> ; M: duplex-stream set-timeout - [ in set-timeout ] [ out set-timeout ] 2bi ; + [ in>> set-timeout ] [ out>> set-timeout ] 2bi ; 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 closed>> [ - t >>closed - [ dup out>> dispose ] - [ dup in>> dispose ] [ ] cleanup - ] unless drop ; + [ + [ out>> &dispose drop ] + [ in>> &dispose drop ] + bi + ] with-destructors ; : ( stream-in stream-out encoding -- duplex ) tuck re-encode >r re-decode r> ; diff --git a/extra/io/streams/null/null.factor b/extra/io/streams/null/null.factor index 384a3806b8..191c8dce91 100755 --- a/extra/io/streams/null/null.factor +++ b/extra/io/streams/null/null.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: io.streams.null -USING: kernel io io.timeouts io.streams.duplex continuations ; +USING: kernel io io.timeouts io.streams.duplex destructors ; TUPLE: null-stream ; diff --git a/extra/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor index 207fdc3cbc..df5669d9aa 100644 --- a/extra/io/unix/backend/backend.factor +++ b/extra/io/unix/backend/backend.factor @@ -4,20 +4,18 @@ USING: alien generic assocs kernel kernel.private math io.ports sequences strings structs sbufs threads unix vectors io.buffers io.backend io.encodings math.parser continuations system libc qualified namespaces io.timeouts -io.encodings.utf8 accessors inspector combinators ; +io.encodings.utf8 destructors accessors inspector combinators ; QUALIFIED: io IN: io.unix.backend ! I/O tasks GENERIC: handle-fd ( handle -- fd ) -TUPLE: fd fd closed ; +TUPLE: fd fd disposed ; : ( n -- fd ) f fd boa ; -M: fd dispose - dup closed>> - [ drop ] [ t >>closed fd>> close-file ] if ; +M: fd dispose* fd>> close-file ; M: fd handle-fd fd>> ; @@ -112,8 +110,6 @@ M: fd init-handle ( fd -- ) [ F_SETFL O_NONBLOCK fcntl drop ] [ F_SETFD FD_CLOEXEC fcntl drop ] bi ; -M: fd close-handle ( fd -- ) dispose ; - ! Readers : eof ( reader -- ) dup buffer>> buffer-empty? [ t >>eof ] when drop ; diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor index 33cc25d60c..9f554a044b 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 |close-handle + append-flags file-mode open-file |dispose dup 0 SEEK_END lseek io-error ] with-destructors ; diff --git a/extra/io/unix/launcher/launcher-tests.factor b/extra/io/unix/launcher/launcher-tests.factor index 49bfc34164..6d1f7f1796 100755 --- a/extra/io/unix/launcher/launcher-tests.factor +++ b/extra/io/unix/launcher/launcher-tests.factor @@ -1,7 +1,7 @@ IN: io.unix.launcher.tests USING: io.files tools.test io.launcher arrays io namespaces continuations math io.encodings.binary io.encodings.ascii -accessors kernel sequences io.encodings.utf8 ; +accessors kernel sequences io.encodings.utf8 destructors ; [ ] [ [ "launcher-test-1" temp-file delete-file ] ignore-errors diff --git a/extra/io/unix/linux/monitors/monitors.factor b/extra/io/unix/linux/monitors/monitors.factor index 43733e8481..17d3041aaf 100644 --- a/extra/io/unix/linux/monitors/monitors.factor +++ b/extra/io/unix/linux/monitors/monitors.factor @@ -12,7 +12,7 @@ SYMBOL: watches SYMBOL: inotify -TUPLE: linux-monitor < monitor wd inotify watches ; +TUPLE: linux-monitor < monitor wd inotify watches disposed ; : ( wd path mailbox -- monitor ) linux-monitor new-monitor @@ -54,14 +54,12 @@ M: linux (monitor) ( path recursive? mailbox -- monitor ) IN_CHANGE_EVENTS swap add-watch ] if ; -M: linux-monitor dispose ( monitor -- ) - dup inotify>> closed>> [ drop ] [ - [ [ wd>> ] [ watches>> ] bi delete-at ] - [ - [ inotify>> handle>> ] [ wd>> ] bi - inotify_rm_watch io-error - ] bi - ] if ; +M: linux-monitor dispose* ( monitor -- ) + [ [ wd>> ] [ watches>> ] bi delete-at ] + [ + [ inotify>> handle>> ] [ wd>> ] bi + inotify_rm_watch io-error + ] bi ; : ignore-flags? ( mask -- ? ) { diff --git a/extra/io/unix/macosx/macosx.factor b/extra/io/unix/macosx/macosx.factor index 8a5d0c490f..3471dc856a 100644 --- a/extra/io/unix/macosx/macosx.factor +++ b/extra/io/unix/macosx/macosx.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: io.unix.bsd io.backend io.monitors core-foundation.fsevents continuations kernel sequences namespaces arrays system locals -accessors ; +accessors destructors ; IN: io.unix.macosx TUPLE: macosx-monitor < monitor handle ; diff --git a/extra/io/unix/mmap/mmap.factor b/extra/io/unix/mmap/mmap.factor index 8a98e4795f..14ad49a89a 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 |close-handle + path open-r/w |dispose [ 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 05164aca34..bc328a146f 100644 --- a/extra/io/unix/sockets/secure/secure.factor +++ b/extra/io/unix/sockets/secure/secure.factor @@ -117,7 +117,7 @@ M: ssl (server) addrspec>> (server) ; M: ssl (accept) [ - addrspec>> (accept) |close-handle |close-handle + addrspec>> (accept) |dispose |dispose dup do-ssl-accept ] with-destructors ; diff --git a/extra/io/unix/sockets/sockets.factor b/extra/io/unix/sockets/sockets.factor index 83aa01d79a..910f87a163 100644 --- 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-handle dup init-handle ; + 0 socket dup io-error |dispose dup init-handle ; : set-socket-option ( fd level opt -- ) >r >r handle-fd r> r> 1 "int" heap-size setsockopt io-error ; diff --git a/extra/io/unix/unix-tests.factor b/extra/io/unix/unix-tests.factor index 61a667b70f..3147d7144b 100755 --- a/extra/io/unix/unix-tests.factor +++ b/extra/io/unix/unix-tests.factor @@ -1,7 +1,7 @@ USING: io.files io.sockets io kernel threads namespaces tools.test continuations strings byte-arrays sequences prettyprint system io.encodings.binary io.encodings.ascii -io.streams.duplex ; +io.streams.duplex destructors ; IN: io.unix.tests ! Unix domain stream sockets diff --git a/extra/irc/irc.factor b/extra/irc/irc.factor index 1db17278ad..9a278fb67f 100755 --- a/extra/irc/irc.factor +++ b/extra/irc/irc.factor @@ -3,7 +3,7 @@ USING: arrays calendar combinators channels concurrency.messaging fry io io.encodings.8-bit io.sockets kernel math namespaces sequences sequences.lib splitting strings threads - continuations classes.tuple ascii accessors ; + continuations destructors classes.tuple ascii accessors ; IN: irc ! utils @@ -143,7 +143,7 @@ SYMBOL: irc-client " hostname servername :irc.factor" irc-print ; : CONNECT ( server port -- stream ) - latin1 ; + latin1 drop ; : JOIN ( channel password -- ) "JOIN " irc-write diff --git a/extra/logging/server/server.factor b/extra/logging/server/server.factor index a832b10a18..2a4e34e015 100755 --- a/extra/logging/server/server.factor +++ b/extra/logging/server/server.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: namespaces kernel io calendar sequences io.files -io.sockets continuations prettyprint assocs math.parser -words debugger math combinators concurrency.messaging -threads arrays init math.ranges strings calendar.format -io.encodings.utf8 ; +io.sockets continuations destructors prettyprint assocs +math.parser words debugger math combinators +concurrency.messaging threads arrays init math.ranges strings +calendar.format io.encodings.utf8 ; IN: logging.server : log-root ( -- string ) diff --git a/extra/openssl/openssl.factor b/extra/openssl/openssl.factor index 1cffd24cd5..014592dbcc 100755 --- a/extra/openssl/openssl.factor +++ b/extra/openssl/openssl.factor @@ -137,14 +137,11 @@ M: ssl-handle init-handle file>> init-handle ; HOOK: ssl-shutdown io-backend ( handle -- ) -M: ssl-handle close-handle - dup disposed>> [ drop ] [ - t >>disposed - [ ssl-shutdown ] - [ handle>> SSL_free ] - [ file>> close-handle ] - tri - ] if ; +M: ssl-handle dispose* + [ ssl-shutdown ] + [ handle>> SSL_free ] + [ file>> dispose ] + tri ; ERROR: certificate-verify-error result ; diff --git a/extra/random/windows/windows.factor b/extra/random/windows/windows.factor index f376903ecf..a4cf74e1df 100644 --- a/extra/random/windows/windows.factor +++ b/extra/random/windows/windows.factor @@ -1,7 +1,6 @@ USING: accessors alien.c-types byte-arrays continuations kernel windows windows.advapi32 init namespaces random destructors locals ; -USE: tools.walker IN: random.windows TUPLE: windows-rng provider type ; diff --git a/extra/semantic-db/semantic-db.factor b/extra/semantic-db/semantic-db.factor index 3044c8872f..7d50d384e2 100755 --- a/extra/semantic-db/semantic-db.factor +++ b/extra/semantic-db/semantic-db.factor @@ -3,7 +3,7 @@ USING: accessors arrays combinators combinators.cleave combinators.lib continuations db db.tuples db.types db.sqlite kernel math math.parser namespaces parser sets sequences sequences.deep -sequences.lib strings words ; +sequences.lib strings words destructors ; IN: semantic-db TUPLE: node id content ; diff --git a/extra/shuffle/shuffle.factor b/extra/shuffle/shuffle.factor index 89522d1f76..3d8a390d13 100644 --- a/extra/shuffle/shuffle.factor +++ b/extra/shuffle/shuffle.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Chris Double, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences namespaces math inference.transforms - combinators macros quotations math.ranges bake ; + combinators macros quotations math.ranges fry ; IN: shuffle @@ -19,7 +19,7 @@ MACRO: ndrop ( n -- ) [ drop ] n*quot ; : nnip ( n -- ) swap >r ndrop r> ; inline -MACRO: ntuck ( n -- ) 2 + [ dup , -nrot ] bake ; +MACRO: ntuck ( n -- ) 2 + '[ dup , -nrot ] ; : 2swap ( x y z t -- z t x y ) rot >r rot r> ; inline diff --git a/extra/smtp/server/server.factor b/extra/smtp/server/server.factor index f23ee138d5..824651030d 100755 --- a/extra/smtp/server/server.factor +++ b/extra/smtp/server/server.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: combinators kernel prettyprint io io.timeouts io.server sequences namespaces io.sockets continuations calendar -io.encodings.ascii io.streams.duplex ; +io.encodings.ascii io.streams.duplex destructors ; IN: smtp.server ! Mock SMTP server for testing purposes. diff --git a/extra/tools/deploy/backend/backend.factor b/extra/tools/deploy/backend/backend.factor index 59dbe9b753..6c5f7e7775 100755 --- a/extra/tools/deploy/backend/backend.factor +++ b/extra/tools/deploy/backend/backend.factor @@ -6,7 +6,7 @@ continuations math definitions mirrors splitting parser classes inspector layouts vocabs.loader prettyprint.config prettyprint debugger io.streams.c io.files io.backend quotations io.launcher words.private tools.deploy.config -bootstrap.image io.encodings.utf8 accessors ; +bootstrap.image io.encodings.utf8 destructors accessors ; IN: tools.deploy.backend : copy-vm ( executable bundle-name extension -- vm ) diff --git a/extra/ui/gadgets/panes/panes.factor b/extra/ui/gadgets/panes/panes.factor index 533a6c42b7..960c34118a 100755 --- a/extra/ui/gadgets/panes/panes.factor +++ b/extra/ui/gadgets/panes/panes.factor @@ -8,7 +8,8 @@ hashtables io kernel namespaces sequences io.styles strings quotations math opengl combinators math.vectors sorting splitting io.streams.nested assocs ui.gadgets.presentations ui.gadgets.slots ui.gadgets.grids -ui.gadgets.grid-lines classes.tuple models continuations ; +ui.gadgets.grid-lines classes.tuple models continuations +destructors ; IN: ui.gadgets.panes TUPLE: pane output current prototype scrolls? From 46c76b8b1ba535660a8369b75a55c5a7fece1565 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 15 May 2008 00:03:21 -0500 Subject: [PATCH 10/10] Fix unit tests --- core/boxes/boxes-docs.factor | 7 +++---- core/boxes/boxes-tests.factor | 8 ++++---- core/boxes/boxes.factor | 12 ++++++------ core/continuations/continuations-tests.factor | 17 ----------------- core/destructors/destructors-tests.factor | 17 +++++++++++++++++ core/inference/inference-tests.factor | 2 +- .../distributed/distributed-tests.factor | 3 +-- extra/concurrency/exchangers/exchangers.factor | 12 ++++++------ .../mailboxes/mailboxes-tests.factor | 2 +- extra/concurrency/mailboxes/mailboxes.factor | 2 +- .../monitors/recursive/recursive-tests.factor | 3 +-- 11 files changed, 41 insertions(+), 44 deletions(-) diff --git a/core/boxes/boxes-docs.factor b/core/boxes/boxes-docs.factor index 3b8caaca1b..df1abe992b 100755 --- a/core/boxes/boxes-docs.factor +++ b/core/boxes/boxes-docs.factor @@ -2,7 +2,7 @@ USING: help.markup help.syntax kernel ; IN: boxes HELP: box -{ $class-description "A data type holding a single value in the " { $link box-value } " slot. The " { $link box-full? } " slot indicates if the value is set." } ; +{ $class-description "A data type holding a single value in the " { $snippet "value" } " slot. The " { $snippet "occupied" } " slot indicates if the value is set." } ; HELP: { $values { "box" box } } @@ -27,12 +27,11 @@ ARTICLE: "boxes" "Boxes" { $subsection box } "Creating an empty box:" { $subsection } -"Testing if a box is full:" -{ $subsection box-full? } "Storing a value and removing a value from a box:" { $subsection >box } { $subsection box> } "Safely removing a value:" -{ $subsection ?box } ; +{ $subsection ?box } +"Testing if a box is full can be done by reading the " { $snippet "occupied" } " slot." ; ABOUT: "boxes" diff --git a/core/boxes/boxes-tests.factor b/core/boxes/boxes-tests.factor index 76a6cfd8b1..71fc1c9a7b 100755 --- a/core/boxes/boxes-tests.factor +++ b/core/boxes/boxes-tests.factor @@ -1,17 +1,17 @@ IN: boxes.tests -USING: boxes namespaces tools.test ; +USING: boxes namespaces tools.test accessors ; [ ] [ "b" set ] unit-test [ ] [ 3 "b" get >box ] unit-test -[ t ] [ "b" get box-full? ] unit-test +[ t ] [ "b" get occupied>> ] unit-test [ 4 "b" >box ] must-fail [ 3 ] [ "b" get box> ] unit-test -[ f ] [ "b" get box-full? ] unit-test +[ f ] [ "b" get occupied>> ] unit-test [ "b" get box> ] must-fail @@ -21,4 +21,4 @@ USING: boxes namespaces tools.test ; [ 12 t ] [ "b" get ?box ] unit-test -[ f ] [ "b" get box-full? ] unit-test +[ f ] [ "b" get occupied>> ] unit-test diff --git a/core/boxes/boxes.factor b/core/boxes/boxes.factor index 42b329b84b..9e2e8a4673 100755 --- a/core/boxes/boxes.factor +++ b/core/boxes/boxes.factor @@ -3,24 +3,24 @@ USING: kernel accessors ; IN: boxes -TUPLE: box value full? ; +TUPLE: box value occupied ; : ( -- box ) box new ; ERROR: box-full box ; : >box ( value box -- ) - dup full?>> - [ box-full ] [ t >>full? (>>value) ] if ; + dup occupied>> + [ box-full ] [ t >>occupied (>>value) ] if ; ERROR: box-empty box ; : box> ( box -- value ) - dup full?>> - [ [ f ] change-value f >>full? drop ] [ box-empty ] if ; + dup occupied>> + [ [ f ] change-value f >>occupied drop ] [ box-empty ] if ; : ?box ( box -- value/f ? ) - dup full?>> [ box> t ] [ drop f f ] if ; + dup occupied>> [ box> t ] [ drop f f ] if ; : if-box? ( box quot -- ) >r ?box r> [ drop ] if ; inline diff --git a/core/continuations/continuations-tests.factor b/core/continuations/continuations-tests.factor index a9adcce82f..27e1f02b91 100755 --- a/core/continuations/continuations-tests.factor +++ b/core/continuations/continuations-tests.factor @@ -101,23 +101,6 @@ SYMBOL: error-counter [ 1 ] [ error-counter get ] unit-test ] with-scope -TUPLE: dispose-error ; - -M: dispose-error dispose 3 throw ; - -TUPLE: dispose-dummy disposed? ; - -M: dispose-dummy dispose t >>disposed? drop ; - -T{ dispose-error } "a" set -T{ dispose-dummy } "b" set - -[ f ] [ "b" get disposed?>> ] unit-test - -[ { "a" "b" } [ get ] map dispose-each ] [ 3 = ] must-fail-with - -[ t ] [ "b" get disposed?>> ] unit-test - [ ] [ [ return ] with-return ] unit-test [ { } [ ] attempt-all ] [ attempt-all-error? ] must-fail-with diff --git a/core/destructors/destructors-tests.factor b/core/destructors/destructors-tests.factor index 18f50bf760..5c66b51fb5 100755 --- a/core/destructors/destructors-tests.factor +++ b/core/destructors/destructors-tests.factor @@ -1,6 +1,23 @@ USING: destructors kernel tools.test continuations ; IN: destructors.tests +TUPLE: dispose-error ; + +M: dispose-error dispose 3 throw ; + +TUPLE: dispose-dummy disposed? ; + +M: dispose-dummy dispose t >>disposed? drop ; + +T{ dispose-error } "a" set +T{ dispose-dummy } "b" set + +[ f ] [ "b" get disposed?>> ] unit-test + +[ { "a" "b" } [ get ] map dispose-each ] [ 3 = ] must-fail-with + +[ t ] [ "b" get disposed?>> ] unit-test + TUPLE: dummy-obj destroyed? ; : dummy-obj new ; diff --git a/core/inference/inference-tests.factor b/core/inference/inference-tests.factor index f688f60e56..46d1049a11 100755 --- a/core/inference/inference-tests.factor +++ b/core/inference/inference-tests.factor @@ -5,7 +5,7 @@ sequences strings vectors words quotations effects tools.test continuations generic.standard sorting assocs definitions prettyprint io inspector classes.tuple classes.union classes.predicate debugger threads.private io.streams.string -io.timeouts io.thread sequences.private ; +io.timeouts io.thread sequences.private destructors ; IN: inference.tests [ ] [ [ 1 ] dataflow [ ] transform-nodes drop ] unit-test diff --git a/extra/concurrency/distributed/distributed-tests.factor b/extra/concurrency/distributed/distributed-tests.factor index 645728780d..ca1da0deaa 100755 --- a/extra/concurrency/distributed/distributed-tests.factor +++ b/extra/concurrency/distributed/distributed-tests.factor @@ -13,8 +13,7 @@ concurrency.messaging continuations ; [ ] [ test-node dup 1array swap (start-node) ] unit-test -[ ] [ yield ] unit-test -[ ] [ yield ] unit-test +[ ] [ 100 sleep ] unit-test [ ] [ [ diff --git a/extra/concurrency/exchangers/exchangers.factor b/extra/concurrency/exchangers/exchangers.factor index d9d6809602..6b44886eda 100755 --- a/extra/concurrency/exchangers/exchangers.factor +++ b/extra/concurrency/exchangers/exchangers.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel threads boxes ; +USING: kernel threads boxes accessors ; IN: concurrency.exchangers ! Motivated by @@ -12,10 +12,10 @@ TUPLE: exchanger thread object ; exchanger boa ; : exchange ( obj exchanger -- newobj ) - dup exchanger-thread box-full? [ - dup exchanger-object box> - >r exchanger-thread box> resume-with r> + dup thread>> occupied>> [ + dup object>> box> + >r thread>> box> resume-with r> ] [ - [ exchanger-object >box ] keep - [ exchanger-thread >box ] curry "exchange" suspend + [ object>> >box ] keep + [ thread>> >box ] curry "exchange" suspend ] if ; diff --git a/extra/concurrency/mailboxes/mailboxes-tests.factor b/extra/concurrency/mailboxes/mailboxes-tests.factor index 7fe09cdcf5..61c57bb9e9 100755 --- a/extra/concurrency/mailboxes/mailboxes-tests.factor +++ b/extra/concurrency/mailboxes/mailboxes-tests.factor @@ -1,7 +1,7 @@ IN: concurrency.mailboxes.tests USING: concurrency.mailboxes concurrency.count-downs vectors sequences threads tools.test math kernel strings namespaces -continuations calendar ; +continuations calendar destructors ; [ V{ 1 2 3 } ] [ 0 diff --git a/extra/concurrency/mailboxes/mailboxes.factor b/extra/concurrency/mailboxes/mailboxes.factor index 25541ce717..faa3a29610 100755 --- a/extra/concurrency/mailboxes/mailboxes.factor +++ b/extra/concurrency/mailboxes/mailboxes.factor @@ -71,7 +71,7 @@ M: mailbox dispose* threads>> notify-all ; f swap mailbox-get-timeout? ; inline : wait-for-close-timeout ( mailbox timeout -- ) - over closed>> + over disposed>> [ 2drop ] [ 2dup wait-for-mailbox wait-for-close-timeout ] if ; : wait-for-close ( mailbox -- ) diff --git a/extra/io/monitors/recursive/recursive-tests.factor b/extra/io/monitors/recursive/recursive-tests.factor index 44baadf39a..fba879a6d2 100644 --- a/extra/io/monitors/recursive/recursive-tests.factor +++ b/extra/io/monitors/recursive/recursive-tests.factor @@ -1,7 +1,6 @@ USING: accessors math kernel namespaces continuations io.files io.monitors io.monitors.recursive io.backend -concurrency.mailboxes -tools.test ; +concurrency.mailboxes tools.test destructors ; IN: io.monitors.recursive.tests \ pump-thread must-infer