diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 4aebef3e0d..6fc8ca7685 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -160,11 +160,6 @@ bootstrapping? on "tuple-layout" "classes.tuple.private" create register-builtin ! Catch-all class for providing a default method. -! "object" "kernel" create -! [ f builtins get [ ] filter f union-class define-class ] -! [ [ drop t ] "predicate" set-word-prop ] -! bi - "object" "kernel" create [ f f { } intersection-class define-class ] [ [ drop t ] "predicate" set-word-prop ] diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index 2e087ff5bd..f94cc0ed37 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -23,7 +23,7 @@ SYMBOL: bootstrap-time : load-components ( -- ) "include" "exclude" - [ get-global " " split [ empty? not ] filter ] bi@ + [ get-global " " split harvest ] bi@ diff [ "bootstrap." prepend require ] each ; diff --git a/core/cpu/x86/64/64.factor b/core/cpu/x86/64/64.factor index 9c44a6a656..ebaa6056ff 100755 --- a/core/cpu/x86/64/64.factor +++ b/core/cpu/x86/64/64.factor @@ -184,7 +184,7 @@ stack-params "__stack_value" c-type set-c-type-reg-class >> : split-struct ( pairs -- seq ) [ [ 8 mod zero? [ t , ] when , ] assoc-each - ] { } make { t } split [ empty? not ] filter ; + ] { } make { t } split harvest ; : flatten-large-struct ( type -- ) heap-size cell align diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor index 5896429ccf..c49e7fda8a 100755 --- a/core/inference/backend/backend.factor +++ b/core/inference/backend/backend.factor @@ -261,7 +261,7 @@ TUPLE: cannot-unify-specials ; : balanced? ( in out -- ? ) [ dup [ length - ] [ 2drop f ] if ] 2map - [ ] filter all-equal? ; + sift all-equal? ; TUPLE: unbalanced-branches-error quots in out ; @@ -281,7 +281,7 @@ TUPLE: unbalanced-branches-error quots in out ; 2dup balanced? [ over supremum -rot [ >r dupd r> unify-inputs ] 2map - [ ] filter unify-stacks + sift unify-stacks rot drop ] [ unbalanced-branches-error diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index d142255535..e4100557e1 100755 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -718,17 +718,21 @@ $nl HELP: unless* { $values { "cond" "a generalized boolean" } { "false" "a quotation " } } -{ $description "Variant of " { $link if* } " with no true quotation." -$nl +{ $description "Variant of " { $link if* } " with no true quotation." } +{ $notes "The following two lines are equivalent:" -{ $code "X [ Y ] unless*" "X dup [ ] [ drop Y ] if" } } ; +{ $code "X [ Y ] unless*" "X dup [ ] [ drop Y ] if" } +"The following two lines are equivalent, where " { $snippet "L" } " is a literal:" +{ $code "[ L ] unless*" "L or" } } ; HELP: ?if { $values { "default" object } { "cond" "a generalized boolean" } { "true" "a quotation with stack effect " { $snippet "( cond -- )" } } { "false" "a quotation with stack effect " { $snippet "( default -- )" } } } -{ $description "If the condition is " { $link f } ", the " { $snippet "false" } " quotation is called with the " { $snippet "default" } " value on the stack. Otherwise, the " { $snippet "true" } " quotation is called with the condition on the stack." -$nl +{ $description "If the condition is " { $link f } ", the " { $snippet "false" } " quotation is called with the " { $snippet "default" } " value on the stack. Otherwise, the " { $snippet "true" } " quotation is called with the condition on the stack." } +{ $notes "The following two lines are equivalent:" -{ $code "[ X ] [ Y ] ?if" "dup [ nip X ] [ drop Y ] if" } } ; +{ $code "[ X ] [ Y ] ?if" "dup [ nip X ] [ drop Y ] if" } +"The following two lines are equivalent:" +{ $code "[ ] [ ] ?if" "swap or" } } ; HELP: die { $description "Starts the front-end processor (FEP), which is a low-level debugger which can inspect memory addresses and the like. The FEP is also entered when a critical error occurs." } diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 76c831cf13..f08ba8fbc2 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -207,7 +207,7 @@ SYMBOL: in : add-use ( seq -- ) [ use+ ] each ; : set-use ( seq -- ) - [ vocab-words ] map [ ] filter >vector use set ; + [ vocab-words ] V{ } map-as sift use set ; : check-vocab-string ( name -- name ) dup string? @@ -278,7 +278,7 @@ M: no-word-error summary dup forward-reference? [ drop use get - [ at ] with map [ ] filter + [ at ] with map sift [ forward-reference? not ] find nip ] [ nip diff --git a/core/prettyprint/sections/sections.factor b/core/prettyprint/sections/sections.factor index 11fa4da28e..73d3620107 100644 --- a/core/prettyprint/sections/sections.factor +++ b/core/prettyprint/sections/sections.factor @@ -309,7 +309,7 @@ M: f section-end-group? drop f ; 2dup 1+ swap ?nth next set swap nth dup split-before dup , split-after ] with each - ] { } make { t } split [ empty? not ] filter ; + ] { } make { t } split harvest ; : break-group? ( seq -- ? ) [ first section-fits? ] [ peek section-fits? not ] bi and ; diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 8d0e3eec18..cbddfa7d28 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -445,6 +445,12 @@ PRIVATE> : remove ( obj seq -- newseq ) [ = not ] with filter ; +: sift ( seq -- newseq ) + [ ] filter ; + +: harvest ( seq -- newseq ) + [ empty? not ] filter ; + : cache-nth ( i seq quot -- elt ) 2over ?nth dup [ >r 3drop r> diff --git a/core/slots/deprecated/deprecated.factor b/core/slots/deprecated/deprecated.factor index 90f468a185..3e2f899774 100755 --- a/core/slots/deprecated/deprecated.factor +++ b/core/slots/deprecated/deprecated.factor @@ -86,7 +86,7 @@ PREDICATE: slot-writer < word "writing" word-prop >boolean ; { [ over string? ] [ >r dupd r> short-slot ] } { [ over array? ] [ long-slot ] } } cond - ] 2map [ ] filter nip ; + ] 2map sift nip ; : slot-of-reader ( reader specs -- spec/f ) [ slot-spec-reader eq? ] with find nip ; diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor index edd82b2596..57951e8642 100755 --- a/core/vocabs/vocabs.factor +++ b/core/vocabs/vocabs.factor @@ -76,7 +76,7 @@ SYMBOL: load-vocab-hook ! ( name -- ) : words-named ( str -- seq ) dictionary get values [ vocab-words at ] with map - [ ] filter ; + sift ; : child-vocab? ( prefix name -- ? ) 2dup = pick empty? or 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/bunny/bunny.factor b/extra/bunny/bunny.factor index d546f9ea41..6ebd598dc6 100755 --- a/extra/bunny/bunny.factor +++ b/extra/bunny/bunny.factor @@ -33,7 +33,7 @@ M: bunny-gadget graft* ( gadget -- ) [ ] [ ] [ ] tri 3array - [ ] filter >>draw-seq + sift >>draw-seq 0 >>draw-n drop ; diff --git a/extra/bunny/model/model.factor b/extra/bunny/model/model.factor index 239603755d..95b5fe401d 100755 --- a/extra/bunny/model/model.factor +++ b/extra/bunny/model/model.factor @@ -6,7 +6,7 @@ float-arrays continuations namespaces sequences.lib accessors ; IN: bunny.model : numbers ( str -- seq ) - " " split [ string>number ] map [ ] filter ; + " " split [ string>number ] map sift ; : (parse-model) ( vs is -- vs is ) readln [ diff --git a/extra/ftp/client/client.factor b/extra/ftp/client/client.factor index 8ec7366266..8cefbcbb43 100644 --- a/extra/ftp/client/client.factor +++ b/extra/ftp/client/client.factor @@ -103,7 +103,7 @@ TUPLE: remote-file : parse-list ( ftp-response -- ftp-response ) dup strings>> - [ " " split [ empty? not ] filter ] map + [ " " split harvest ] map dup length { { 9 [ parse-list-9 ] } { 8 [ parse-list-8 ] } diff --git a/extra/hardware-info/linux/linux.factor b/extra/hardware-info/linux/linux.factor index 5d9ca6eaa7..89f42b4384 100644 --- a/extra/hardware-info/linux/linux.factor +++ b/extra/hardware-info/linux/linux.factor @@ -7,7 +7,7 @@ IN: hardware-info.linux : uname ( -- seq ) 65536 "char" [ (uname) io-error ] keep - "\0" split [ empty? not ] filter [ >string ] map + "\0" split harvest [ >string ] map 6 "" pad-right ; : sysname ( -- string ) uname first ; @@ -18,4 +18,4 @@ IN: hardware-info.linux : domainname ( -- string ) uname 5 swap nth ; : kernel-version ( -- seq ) - release ".-" split [ ] filter 5 "" pad-right ; + release ".-" split harvest 5 "" pad-right ; diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor index a8271a0e3b..dd4106239d 100755 --- a/extra/help/handbook/handbook.factor +++ b/extra/help/handbook/handbook.factor @@ -238,7 +238,7 @@ ARTICLE: "error-index" "Error index" { $index [ all-errors ] } ; ARTICLE: "type-index" "Type index" -{ $index [ builtins get [ ] filter ] } ; +{ $index [ builtins get sift ] } ; ARTICLE: "class-index" "Class index" { $index [ classes ] } ; diff --git a/extra/help/help.factor b/extra/help/help.factor index 2d56251392..75a14e645b 100755 --- a/extra/help/help.factor +++ b/extra/help/help.factor @@ -135,7 +135,7 @@ M: word set-article-parent swap "help-parent" set-word-prop ; ":vars - list all variables at error time" print ; : :help ( -- ) - error get delegates [ error-help ] map [ ] filter + error get delegates [ error-help ] map sift { { [ dup empty? ] [ (:help-none) ] } { [ dup length 1 = ] [ first help ] } diff --git a/extra/html/parser/analyzer/analyzer.factor b/extra/html/parser/analyzer/analyzer.factor index e9906f3f2a..9a3ff8c7a7 100755 --- a/extra/html/parser/analyzer/analyzer.factor +++ b/extra/html/parser/analyzer/analyzer.factor @@ -77,12 +77,12 @@ IN: html.parser.analyzer : find-by-attribute-key ( key vector -- vector ) >r >lower r> [ tag-attributes at ] with filter - [ ] filter ; + sift ; : find-by-attribute-key-value ( value key vector -- vector ) >r >lower r> [ tag-attributes at over = ] with filter nip - [ ] filter ; + sift ; : find-first-attribute-key-value ( value key vector -- i/f tag/f ) >r >lower r> diff --git a/extra/http/client/client-tests.factor b/extra/http/client/client-tests.factor index 1d947b99e5..9ad805b81b 100755 --- a/extra/http/client/client-tests.factor +++ b/extra/http/client/client-tests.factor @@ -1,9 +1,7 @@ USING: http.client http.client.private http tools.test tuple-syntax namespaces ; -[ "localhost" 80 ] [ "localhost" parse-host ] unit-test +[ "localhost" f ] [ "localhost" parse-host ] unit-test [ "localhost" 8888 ] [ "localhost:8888" parse-host ] unit-test -[ "/foo" "localhost" 8888 ] [ "http://localhost:8888/foo" parse-url ] unit-test -[ "/" "localhost" 8888 ] [ "http://localhost:8888" parse-url ] unit-test [ "foo.txt" ] [ "http://www.paulgraham.com/foo.txt" download-name ] unit-test [ "foo.txt" ] [ "http://www.arc.com/foo.txt?xxx" download-name ] unit-test @@ -12,10 +10,11 @@ tuple-syntax namespaces ; [ TUPLE{ request + protocol: http method: "GET" host: "www.apple.com" - path: "/index.html" port: 80 + path: "/index.html" version: "1.1" cookies: V{ } header: H{ { "connection" "close" } } @@ -26,3 +25,21 @@ tuple-syntax namespaces ; ] with-scope ] unit-test + +[ + TUPLE{ request + protocol: https + method: "GET" + host: "www.amazon.com" + port: 443 + path: "/index.html" + version: "1.1" + cookies: V{ } + header: H{ { "connection" "close" } } + } +] [ + [ + "https://www.amazon.com/index.html" + + ] with-scope +] unit-test diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor index 17882277a3..cec1bb931a 100755 --- a/extra/http/client/client.factor +++ b/extra/http/client/client.factor @@ -19,22 +19,8 @@ DEFER: http-request r >>path r> dup [ query>assoc ] when >>query ; - -: request-with-url ( request url -- request ) - parse-url >r >r store-path r> >>host r> >>port ; - SYMBOL: redirects -: absolute-url? ( url -- ? ) - [ "http://" head? ] [ "https://" head? ] bi or ; - : do-redirect ( response data -- response data ) over code>> 300 399 between? [ drop @@ -42,7 +28,7 @@ SYMBOL: redirects redirects get max-redirects < [ request get swap "location" header dup absolute-url? - [ request-with-url ] [ store-path ] if + [ request-with-url ] [ request-with-path ] if "GET" >>method http-request ] [ too-many-redirects diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor index 21eb241b84..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" @@ -174,6 +176,8 @@ test-db [ main-responder set [ 1237 httpd ] "HTTPD test" spawn drop + + yield ] with-scope ] unit-test diff --git a/extra/http/http.factor b/extra/http/http.factor index 968d4d88ca..6efbd42fd2 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -7,7 +7,7 @@ strings vectors hashtables quotations arrays byte-arrays math.parser calendar calendar.format io io.streams.string io.encodings.utf8 io.encodings.string -io.sockets +io.sockets io.sockets.secure unicode.case unicode.categories qualified ; @@ -15,9 +15,31 @@ EXCLUDE: fry => , ; IN: http -: http-port 80 ; inline +SINGLETON: http -: https-port 443 ; inline +SINGLETON: https + +GENERIC: http-port ( protocol -- port ) + +M: http http-port drop 80 ; + +M: https http-port drop 443 ; + +GENERIC: protocol>string ( protocol -- string ) + +M: http protocol>string drop "http" ; + +M: https protocol>string drop "https" ; + +: string>protocol ( string -- protocol ) + { + { "http" [ http ] } + { "https" [ https ] } + [ "Unknown protocol: " swap append throw ] + } case ; + +: absolute-url? ( url -- ? ) + [ "http://" head? ] [ "https://" head? ] bi or ; : url-quotable? ( ch -- ? ) #! In a URL, can this character be used without @@ -212,6 +234,7 @@ TUPLE: cookie name value path domain expires max-age http-only ; [ unparse-cookie ] map concat "; " join ; TUPLE: request +protocol host port method @@ -229,7 +252,7 @@ cookies ; : request new "1.1" >>version - http-port >>port + http >>protocol H{ } clone >>header H{ } clone >>query V{ } clone >>cookies @@ -242,6 +265,7 @@ cookies ; pick query>> set-at ; : chop-hostname ( str -- str' ) + ":" split1 "//" ?head drop nip CHAR: / over index over length or tail dup empty? [ drop "/" ] when ; @@ -249,7 +273,9 @@ cookies ; #! Technically, only proxies are meant to support hostnames #! in HTTP requests, but IE sends these sometimes so we #! just chop the hostname part. - url-decode "http://" ?head [ chop-hostname ] when ; + url-decode + dup { "http://" "https://" } [ head? ] with contains? + [ chop-hostname ] when ; : read-method ( request -- request ) " " read-until [ "Bad request: method" throw ] unless @@ -298,10 +324,11 @@ SYMBOL: max-post-request : parse-host ( string -- host port ) "." ?tail drop ":" split1 - [ string>number ] [ http-port ] if* ; + dup [ string>number ] when ; : extract-host ( request -- request ) - dup "host" header parse-host >r >>host r> >>port ; + dup [ "host" header parse-host ] keep protocol>> http-port or + [ >>host ] [ >>port ] bi* ; : extract-post-data-type ( request -- request ) dup "content-type" header >>post-data-type ; @@ -314,7 +341,7 @@ SYMBOL: max-post-request dup "cookie" header [ parse-cookies >>cookies ] when* ; : parse-content-type-attributes ( string -- attributes ) - " " split [ empty? not ] filter [ "=" split1 >r >lower r> ] { } map>assoc ; + " " split harvest [ "=" split1 >r >lower r> ] { } map>assoc ; : parse-content-type ( content-type -- type encoding ) ";" split1 parse-content-type-attributes "charset" swap at ; @@ -353,12 +380,20 @@ SYMBOL: max-post-request "application/x-www-form-urlencoded" >>post-data-type ] if ; +GENERIC: protocol-addr ( request protocol -- addr ) + +M: object protocol-addr + drop [ host>> ] [ port>> ] bi ; + +M: https protocol-addr + call-next-method ; + : request-addr ( request -- addr ) - [ host>> ] [ port>> ] bi ; + dup protocol>> protocol-addr ; : request-host ( request -- string ) - [ host>> ] [ port>> ] bi - dup 80 = [ drop ] [ ":" swap number>string 3append ] if ; + [ host>> ] [ port>> ] bi dup http http-port = + [ drop ] [ ":" swap number>string 3append ] if ; : write-request-header ( request -- request ) dup header>> >hashtable @@ -381,13 +416,32 @@ SYMBOL: max-post-request flush drop ; +: request-with-path ( request path -- request ) + [ "/" prepend ] [ "/" ] if* + "?" split1 [ >>path ] [ dup [ query>assoc ] when >>query ] bi* ; + +: request-with-url ( request url -- request ) + ":" split1 + [ string>protocol >>protocol ] + [ + "//" ?head [ "Invalid URL" throw ] unless + "/" split1 + [ + parse-host [ >>host ] [ >>port ] bi* + dup protocol>> http-port '[ , or ] change-port + ] + [ request-with-path ] + bi* + ] bi* ; + : request-url ( request -- url ) [ [ dup host>> [ - [ "http://" write host>> url-encode write ] - [ ":" write port>> number>string write ] - bi + [ protocol>> protocol>string write "://" write ] + [ host>> url-encode write ":" write ] + [ [ port>> ] [ protocol>> http-port or ] bi number>string write ] + tri ] [ drop ] if ] [ path>> "/" head? [ "/" write ] unless ] 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/http/server/server.factor b/extra/http/server/server.factor index 70c1e9a1f5..4e561220f9 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -240,7 +240,7 @@ SYMBOL: exit-continuation '[ exit-continuation set @ ] callcc1 exit-continuation off ; : split-path ( string -- path ) - "/" split [ empty? not ] filter ; + "/" split harvest ; : init-request ( -- ) H{ } clone base-paths set diff --git a/extra/io/encodings/8-bit/8-bit.factor b/extra/io/encodings/8-bit/8-bit.factor index 88414efd16..a8cd1fea91 100755 --- a/extra/io/encodings/8-bit/8-bit.factor +++ b/extra/io/encodings/8-bit/8-bit.factor @@ -37,8 +37,7 @@ IN: io.encodings.8-bit 2dup swap length <= [ tail ] [ drop ] if ; : process-contents ( lines -- assoc ) - [ "#" split1 drop ] map - [ empty? not ] filter + [ "#" split1 drop ] map harvest [ "\t" split 2 head [ 2 tail-if hex> ] map ] map ; : byte>ch ( assoc -- array ) diff --git a/extra/io/files/unique/unique-docs.factor b/extra/io/files/unique/unique-docs.factor index 01b8e131cc..bb4e9ef01f 100644 --- a/extra/io/files/unique/unique-docs.factor +++ b/extra/io/files/unique/unique-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax io io.nonblocking kernel math +USING: help.markup help.syntax io io.ports kernel math io.files.unique.private math.parser io.files ; IN: io.files.unique diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index e28742537d..54c97bdb0e 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -4,7 +4,7 @@ USING: system kernel namespaces strings hashtables sequences assocs combinators vocabs.loader init threads continuations math accessors concurrency.flags destructors io io.backend io.timeouts io.pipes io.pipes.private io.encodings -io.streams.duplex io.nonblocking ; +io.streams.duplex io.ports ; IN: io.launcher TUPLE: process < identity-tuple @@ -199,7 +199,7 @@ M: object run-pipeline-element [ swap in>> or ] change-stdin run-detached ] - [ [ in>> close-handle ] [ out>> close-handle ] bi* ] + [ [ out>> close-handle ] [ in>> close-handle ] bi* ] [ [ in>> ] [ out>> ] bi* ] } 2cleave r> ] with-destructors ; diff --git a/extra/io/mmap/mmap.factor b/extra/io/mmap/mmap.factor index a07443783c..2f637a4f81 100755 --- a/extra/io/mmap/mmap.factor +++ b/extra/io/mmap/mmap.factor @@ -1,37 +1,38 @@ ! 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 sequences.private ; +system alien alien.accessors accessors sequences.private ; IN: io.mmap -TUPLE: mapped-file length address handle closed? ; +TUPLE: mapped-file address handle length closed ; : check-closed ( mapped-file -- mapped-file ) - dup mapped-file-closed? [ + dup closed>> [ "Mapped file is closed" throw ] when ; inline -M: mapped-file length check-closed mapped-file-length ; +M: mapped-file length check-closed length>> ; M: mapped-file nth-unsafe - check-closed mapped-file-address swap alien-unsigned-1 ; + check-closed address>> swap alien-unsigned-1 ; M: mapped-file set-nth-unsafe - check-closed mapped-file-address swap set-alien-unsigned-1 ; + check-closed address>> swap set-alien-unsigned-1 ; INSTANCE: mapped-file sequence -HOOK: (mapped-file) io-backend ( path length -- mmap ) +HOOK: (mapped-file) io-backend ( path length -- address handle ) : ( path length -- mmap ) - >r normalize-path r> (mapped-file) ; + [ >r normalize-path r> (mapped-file) ] keep + f mapped-file boa ; HOOK: close-mapped-file io-backend ( mmap -- ) M: mapped-file dispose ( mmap -- ) - check-closed - t over set-mapped-file-closed? - close-mapped-file ; + dup closed>> [ drop ] [ + t >>closed close-mapped-file + ] if ; : with-mapped-file ( path length quot -- ) >r r> with-disposal ; inline diff --git a/extra/io/pipes/pipes-tests.factor b/extra/io/pipes/pipes-tests.factor index c1b37f6efc..4fb9d57748 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 namespaces continuations -tools.test kernel ; +io.streams.duplex io.encodings io.timeouts namespaces +continuations tools.test kernel calendar ; IN: io.pipes.tests [ "Hello" ] [ @@ -24,3 +24,10 @@ IN: io.pipes.tests [ input-stream [ utf8 ] change readln ] } run-pipeline ] unit-test + +[ + utf8 [ + 5 seconds over set-timeout + stream-readln + ] with-disposal +] must-fail diff --git a/extra/io/pipes/pipes.factor b/extra/io/pipes/pipes.factor index cae7ef8158..a3315d02ca 100644 --- a/extra/io/pipes/pipes.factor +++ b/extra/io/pipes/pipes.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: io.encodings io.backend io.nonblocking io.streams.duplex +USING: io.encodings io.backend io.ports io.streams.duplex io splitting sequences sequences.lib namespaces kernel destructors math concurrency.combinators accessors arrays continuations quotations ; diff --git a/extra/io/nonblocking/authors.txt b/extra/io/ports/authors.txt similarity index 100% rename from extra/io/nonblocking/authors.txt rename to extra/io/ports/authors.txt diff --git a/extra/io/nonblocking/nonblocking-docs.factor b/extra/io/ports/ports-docs.factor similarity index 86% rename from extra/io/nonblocking/nonblocking-docs.factor rename to extra/io/ports/ports-docs.factor index 7a489d8606..265b74e87a 100755 --- a/extra/io/nonblocking/nonblocking-docs.factor +++ b/extra/io/ports/ports-docs.factor @@ -1,9 +1,9 @@ USING: io io.buffers io.backend help.markup help.syntax kernel byte-arrays sbufs words continuations byte-vectors classes ; -IN: io.nonblocking +IN: io.ports -ARTICLE: "io.nonblocking" "Non-blocking I/O implementation" -"On Windows and Unix, Factor implements blocking file and network streams on top of a non-blocking I/O substrate, ensuring that Factor threads will yield when performing I/O. This substrate is implemented in the " { $vocab-link "io.nonblocking" } " vocabulary." +ARTICLE: "io.ports" "Non-blocking I/O implementation" +"On Windows and Unix, Factor implements blocking file and network streams on top of a non-blocking I/O substrate, ensuring that Factor threads will yield when performing I/O. This substrate is implemented in the " { $vocab-link "io.ports" } " vocabulary." $nl "A " { $emphasis "port" } " is a stream using non-blocking I/O substrate:" { $subsection port } @@ -23,13 +23,10 @@ $nl "Per-port native I/O protocol:" { $subsection init-handle } { $subsection (wait-to-read) } -"Additionally, the I/O backend must provide an implementation of the " { $link stream-flush } " and " { $link dispose } " generic words." -$nl -"Dummy ports which should be used to implement networking:" -{ $subsection server-port } -{ $subsection datagram-port } ; +{ $subsection (wait-to-write) } +"Additionally, the I/O backend must provide an implementation of the " { $link dispose } " generic word." ; -ABOUT: "io.nonblocking" +ABOUT: "io.ports" HELP: port { $class-description "Instances of this class present a blocking stream interface on top of an underlying non-blocking I/O system, giving the illusion of blocking by yielding the thread which is waiting for input or output." @@ -81,10 +78,6 @@ HELP: (wait-to-read) { $contract "Suspends the current thread until the port's buffer has data available for reading." } ; HELP: wait-to-read -{ $values { "count" "a non-negative integer" } { "port" input-port } } -{ $description "If the port's buffer has at least " { $snippet "count" } " unread bytes, returns immediately, otherwise suspends the current thread until some data is available for reading." } ; - -HELP: wait-to-read1 { $values { "port" input-port } } { $description "If the port's buffer has unread data, returns immediately, otherwise suspends the current thread until some data is available for reading." } ; diff --git a/extra/io/nonblocking/nonblocking.factor b/extra/io/ports/ports.factor similarity index 72% rename from extra/io/nonblocking/nonblocking.factor rename to extra/io/ports/ports.factor index 74133e5abb..16e089a4a6 100755 --- a/extra/io/nonblocking/nonblocking.factor +++ b/extra/io/ports/ports.factor @@ -5,12 +5,12 @@ byte-vectors system io.encodings math.order io.backend continuations debugger classes byte-arrays namespaces splitting dlists assocs io.encodings.binary inspector accessors destructors ; -IN: io.nonblocking +IN: io.ports SYMBOL: default-buffer-size 64 1024 * default-buffer-size set-global -TUPLE: port handle buffer error timeout closed eof ; +TUPLE: port handle error timeout closed ; M: port timeout timeout>> ; @@ -37,26 +37,6 @@ M: handle-destructor dispose ( obj -- ) new swap dup init-handle >>handle ; inline -: ( handle class -- port ) - - default-buffer-size get >>buffer ; inline - -TUPLE: input-port < port ; - -: ( handle -- input-port ) - input-port ; - -TUPLE: output-port < port ; - -: ( handle -- output-port ) - output-port ; - -: ( read-handle write-handle -- input-port output-port ) - [ - [ dup add-error-destructor ] - [ dup add-error-destructor ] bi* - ] with-destructors ; - : pending-error ( port -- ) [ f ] change-error drop [ throw ] when* ; @@ -68,19 +48,21 @@ M: port-closed-error summary : check-closed ( port -- port ) dup closed>> [ port-closed-error ] when ; -HOOK: cancel-io io-backend ( port -- ) +TUPLE: buffered-port < port buffer ; -M: object cancel-io drop ; +: ( handle class -- port ) + + default-buffer-size get >>buffer ; inline -M: port timed-out cancel-io ; +TUPLE: input-port < buffered-port eof ; + +: ( handle -- input-port ) + input-port ; HOOK: (wait-to-read) io-backend ( port -- ) -: wait-to-read ( count port -- ) - tuck buffer>> buffer-length > [ (wait-to-read) ] [ drop ] if ; - -: wait-to-read1 ( port -- ) - 1 swap wait-to-read ; +: wait-to-read ( port -- ) + dup buffer>> buffer-empty? [ (wait-to-read) ] [ drop ] if ; : unless-eof ( port quot -- value ) >r dup buffer>> buffer-empty? over eof>> and @@ -88,12 +70,16 @@ HOOK: (wait-to-read) io-backend ( port -- ) M: input-port stream-read1 check-closed - dup wait-to-read1 [ buffer>> buffer-pop ] unless-eof ; + dup wait-to-read [ buffer>> buffer-pop ] unless-eof ; : read-step ( count port -- byte-array/f ) - [ wait-to-read ] 2keep + [ wait-to-read ] keep [ dupd buffer>> buffer-read ] unless-eof nip ; +M: input-port stream-read-partial ( max stream -- byte-array/f ) + check-closed + >r 0 max >integer r> read-step ; + : read-loop ( count port accum -- ) pick over length - dup 0 > [ pick read-step dup [ @@ -117,9 +103,10 @@ M: input-port stream-read ] [ 2nip ] if ] [ 2nip ] if ; -M: input-port stream-read-partial ( max stream -- byte-array/f ) - check-closed - >r 0 max >fixnum r> read-step ; +TUPLE: output-port < buffered-port ; + +: ( handle -- output-port ) + output-port ; : can-write? ( len buffer -- ? ) [ buffer-fill + ] keep buffer-capacity <= ; @@ -143,7 +130,10 @@ M: output-port stream-write [ buffer>> >buffer ] 2bi ] if ; -HOOK: flush-port io-backend ( port -- ) +HOOK: (wait-to-write) io-backend ( port -- ) + +: flush-port ( port -- ) + dup buffer>> buffer-empty? [ drop ] [ (wait-to-write) ] if ; M: output-port stream-flush ( port -- ) check-closed @@ -154,35 +144,23 @@ GENERIC: close-port ( port -- ) M: output-port close-port [ flush-port ] [ call-next-method ] bi ; +M: buffered-port close-port + [ call-next-method ] + [ [ [ buffer-free ] when* f ] change-buffer drop ] + bi ; + +HOOK: cancel-io io-backend ( port -- ) + +M: port timed-out cancel-io ; + M: port close-port - dup cancel-io - dup handle>> close-handle - [ [ buffer-free ] when* f ] change-buffer drop ; + [ cancel-io ] [ handle>> close-handle ] bi ; M: port dispose dup closed>> [ drop ] [ t >>closed close-port ] if ; -TUPLE: server-port < port addr client client-addr encoding ; - -: ( handle addr encoding -- server ) - rot server-port - swap >>encoding - swap >>addr ; - -: check-server-port ( port -- port ) - dup server-port? [ "Not a server port" throw ] unless ; inline - -TUPLE: datagram-port < port addr packet packet-addr ; - -: ( handle addr -- datagram ) - swap datagram-port - swap >>addr ; - -: check-datagram-port ( port -- port ) - check-closed - dup datagram-port? [ "Not a datagram port" throw ] unless ; inline - -: check-datagram-send ( packet addrspec port -- packet addrspec port ) - check-datagram-port - 2dup addr>> [ class ] bi@ assert= - pick class byte-array assert= ; +: ( read-handle write-handle -- input-port output-port ) + [ + [ dup add-error-destructor ] + [ dup add-error-destructor ] bi* + ] with-destructors ; diff --git a/extra/io/nonblocking/summary.txt b/extra/io/ports/summary.txt similarity index 100% rename from extra/io/nonblocking/summary.txt rename to extra/io/ports/summary.txt diff --git a/extra/io/server/server-tests.factor b/extra/io/server/server-tests.factor index e1297a9839..86cfe35bc1 100755 --- a/extra/io/server/server-tests.factor +++ b/extra/io/server/server-tests.factor @@ -1,4 +1,7 @@ IN: io.server.tests -USING: tools.test io.server io.server.private ; +USING: tools.test io.server io.server.private kernel ; { 2 0 } [ [ ] server-loop ] must-infer-as +{ 2 0 } [ [ ] with-connection ] must-infer-as +{ 1 0 } [ [ ] swap datagram-loop ] must-infer-as +{ 2 0 } [ [ ] with-datagrams ] must-infer-as diff --git a/extra/io/server/server.factor b/extra/io/server/server.factor index 1d626a9e15..23066114e4 100755 --- a/extra/io/server/server.factor +++ b/extra/io/server/server.factor @@ -3,7 +3,7 @@ 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 ; +threads concurrency.combinators assocs fry ; IN: io.server SYMBOL: servers @@ -12,22 +12,24 @@ SYMBOL: servers LOG: accepted-connection NOTICE -: with-client ( client addrspec quot -- ) - [ - swap accepted-connection - with-stream* - ] 2curry with-disposal ; inline +SYMBOL: remote-address -\ with-client DEBUG add-error-logging +: with-connection ( client remote quot -- ) + '[ + , [ remote-address set ] [ accepted-connection ] bi + @ + ] with-stream ; inline + +\ with-connection DEBUG add-error-logging : accept-loop ( server quot -- ) [ - >r accept r> [ with-client ] 3curry "Client" spawn drop + >r accept r> '[ , , , with-connection ] "Client" spawn drop ] 2keep accept-loop ; inline : server-loop ( addrspec encoding quot -- ) >r dup servers get push r> - [ accept-loop ] curry with-disposal ; inline + '[ , accept-loop ] with-disposal ; inline \ server-loop NOTICE add-error-logging @@ -41,9 +43,7 @@ PRIVATE> : with-server ( seq service encoding quot -- ) V{ } clone servers [ - [ - [ server-loop ] 2curry with-logging - ] 3curry parallel-each + '[ , [ , , server-loop ] with-logging ] parallel-each ] with-variable ; inline : stop-server ( -- ) @@ -56,7 +56,7 @@ LOG: received-datagram NOTICE : datagram-loop ( quot datagram -- ) [ [ receive dup received-datagram >r swap call r> ] keep - pick [ send ] [ 3drop ] keep + pick [ send ] [ 3drop ] if ] 2keep datagram-loop ; inline : spawn-datagrams ( quot addrspec -- ) @@ -67,6 +67,4 @@ LOG: received-datagram NOTICE PRIVATE> : with-datagrams ( seq service quot -- ) - [ - [ swap spawn-datagrams ] curry parallel-each - ] curry with-logging ; inline + '[ [ , _ spawn-datagrams ] parallel-each ] with-logging ; inline diff --git a/extra/io/sockets/headers/headers.factor b/extra/io/sockets/headers/headers.factor index 2547fee5ae..7ae9265220 100755 --- a/extra/io/sockets/headers/headers.factor +++ b/extra/io/sockets/headers/headers.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.syntax byte-arrays io -io.sockets.impl kernel structs math math.parser +io.sockets kernel structs math math.parser prettyprint sequences ; IN: io.sockets.headers diff --git a/extra/io/sockets/impl/authors.txt b/extra/io/sockets/impl/authors.txt deleted file mode 100755 index 1901f27a24..0000000000 --- a/extra/io/sockets/impl/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/extra/io/sockets/impl/impl-tests.factor b/extra/io/sockets/impl/impl-tests.factor deleted file mode 100644 index 6b930a994e..0000000000 --- a/extra/io/sockets/impl/impl-tests.factor +++ /dev/null @@ -1,45 +0,0 @@ -USING: io.sockets.impl io.sockets kernel tools.test ; -IN: io.sockets.impl.tests - -[ B{ 1 2 3 4 } ] -[ "1.2.3.4" T{ inet4 } inet-pton ] unit-test - -[ "1.2.3.4" ] -[ B{ 1 2 3 4 } T{ inet4 } inet-ntop ] unit-test - -[ "255.255.255.255" ] -[ B{ 255 255 255 255 } T{ inet4 } inet-ntop ] unit-test - -[ B{ 255 255 255 255 } ] -[ "255.255.255.255" T{ inet4 } inet-pton ] unit-test - -[ B{ 0 1 0 2 0 3 0 4 0 5 0 6 0 7 0 8 } ] -[ "1:2:3:4:5:6:7:8" T{ inet6 } inet-pton ] unit-test - -[ "1:2:3:4:5:6:7:8" ] -[ B{ 0 1 0 2 0 3 0 4 0 5 0 6 0 7 0 8 } T{ inet6 } inet-ntop ] unit-test - -[ B{ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 } ] -[ "::" T{ inet6 } inet-pton ] unit-test - -[ "0:0:0:0:0:0:0:0" ] -[ B{ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 } T{ inet6 } inet-ntop ] unit-test - -[ B{ 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 } ] -[ "1::" T{ inet6 } inet-pton ] unit-test - -[ B{ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 } ] -[ "::1" T{ inet6 } inet-pton ] unit-test - -[ B{ 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 2 } ] -[ "1::2" T{ inet6 } inet-pton ] unit-test - -[ B{ 0 1 0 0 0 0 0 0 0 0 0 0 0 2 0 3 } ] -[ "1::2:3" T{ inet6 } inet-pton ] unit-test - -[ B{ 0 1 0 2 0 0 0 0 0 0 0 0 0 3 0 4 } ] -[ "1:2::3:4" T{ inet6 } inet-pton ] unit-test - -[ "1:2:0:0:0:0:3:4" ] -[ B{ 0 1 0 2 0 0 0 0 0 0 0 0 0 3 0 4 } T{ inet6 } inet-ntop ] unit-test - diff --git a/extra/io/sockets/impl/impl.factor b/extra/io/sockets/impl/impl.factor deleted file mode 100755 index fa82080259..0000000000 --- a/extra/io/sockets/impl/impl.factor +++ /dev/null @@ -1,134 +0,0 @@ -! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov -! See http://factorcode.org/license.txt for BSD license. -USING: arrays byte-arrays io.backend io.binary io.sockets -io.encodings.ascii kernel math math.parser sequences splitting -system alien.c-types alien.strings alien combinators namespaces -parser ; -IN: io.sockets.impl - -<< { - { [ os windows? ] [ "windows.winsock" ] } - { [ os unix? ] [ "unix" ] } -} cond use+ >> - -GENERIC: protocol-family ( addrspec -- af ) - -GENERIC: sockaddr-type ( addrspec -- type ) - -GENERIC: make-sockaddr ( addrspec -- sockaddr ) - -: make-sockaddr/size ( addrspec -- sockaddr size ) - dup make-sockaddr swap sockaddr-type heap-size ; - -GENERIC: parse-sockaddr ( sockaddr addrspec -- newaddrspec ) - -HOOK: addrinfo-error io-backend ( n -- ) - -! IPV4 and IPV6 -GENERIC: address-size ( addrspec -- n ) - -GENERIC: inet-ntop ( data addrspec -- str ) - -GENERIC: inet-pton ( str addrspec -- data ) - - -M: inet4 inet-ntop ( data addrspec -- str ) - drop 4 memory>byte-array [ number>string ] { } map-as "." join ; - -M: inet4 inet-pton ( str addrspec -- data ) - drop "." split [ string>number ] B{ } map-as ; - -M: inet4 address-size drop 4 ; - -M: inet4 protocol-family drop PF_INET ; - -M: inet4 sockaddr-type drop "sockaddr-in" c-type ; - -M: inet4 make-sockaddr ( inet -- sockaddr ) - "sockaddr-in" - AF_INET over set-sockaddr-in-family - over inet4-port htons over set-sockaddr-in-port - over inet4-host - "0.0.0.0" or - rot inet-pton *uint over set-sockaddr-in-addr ; - -SYMBOL: port-override - -: (port) port-override get swap or ; - -M: inet4 parse-sockaddr - >r dup sockaddr-in-addr r> inet-ntop - swap sockaddr-in-port ntohs (port) ; - -M: inet6 inet-ntop ( data addrspec -- str ) - drop 16 memory>byte-array 2 [ be> >hex ] map ":" join ; - -M: inet6 inet-pton ( str addrspec -- data ) - drop "::" split1 - [ [ ":" split [ hex> dup 0 ? ] map ] [ f ] if* ] bi@ - 2dup [ length ] bi@ + 8 swap - 0 swap 3append - [ 2 >be ] map concat >byte-array ; - -M: inet6 address-size drop 16 ; - -M: inet6 protocol-family drop PF_INET6 ; - -M: inet6 sockaddr-type drop "sockaddr-in6" c-type ; - -M: inet6 make-sockaddr ( inet -- sockaddr ) - "sockaddr-in6" - AF_INET6 over set-sockaddr-in6-family - over inet6-port htons over set-sockaddr-in6-port - over inet6-host "::" or - rot inet-pton over set-sockaddr-in6-addr ; - -M: inet6 parse-sockaddr - >r dup sockaddr-in6-addr r> inet-ntop - swap sockaddr-in6-port ntohs (port) ; - -: addrspec-of-family ( af -- addrspec ) - { - { [ dup AF_INET = ] [ T{ inet4 } ] } - { [ dup AF_INET6 = ] [ T{ inet6 } ] } - { [ dup AF_UNIX = ] [ T{ local } ] } - [ f ] - } cond nip ; - -M: f parse-sockaddr nip ; - -: addrinfo>addrspec ( addrinfo -- addrspec ) - [ addrinfo-addr ] [ addrinfo-family addrspec-of-family ] bi - parse-sockaddr ; - -: parse-addrinfo-list ( addrinfo -- seq ) - [ addrinfo-next ] follow - [ addrinfo>addrspec ] map - [ ] filter ; - -: prepare-resolve-host ( host serv passive? -- host' serv' flags ) - #! If the port is a number, we resolve for 'http' then - #! change it later. This is a workaround for a FreeBSD - #! getaddrinfo() limitation -- on Windows, Linux and Mac, - #! we can convert a number to a string and pass that as the - #! service name, but on FreeBSD this gives us an unknown - #! service error. - >r - dup integer? [ port-override set "http" ] when - r> AI_PASSIVE 0 ? ; - -M: object resolve-host ( host serv passive? -- seq ) - [ - prepare-resolve-host - "addrinfo" - [ set-addrinfo-flags ] keep - PF_UNSPEC over set-addrinfo-family - IPPROTO_TCP over set-addrinfo-protocol - f [ getaddrinfo addrinfo-error ] keep *void* - [ parse-addrinfo-list ] keep - freeaddrinfo - ] with-scope ; - -M: object host-name ( -- name ) - 256 dup dup length gethostname - zero? [ "gethostname failed" throw ] unless - ascii alien>string ; diff --git a/extra/io/sockets/sockets-docs.factor b/extra/io/sockets/sockets-docs.factor index ee3cb3aa7b..db07caa330 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 ; +strings byte-arrays continuations quotations ; IN: io.sockets ARTICLE: "network-addressing" "Address specifiers" @@ -64,7 +64,7 @@ HELP: local } ; HELP: inet -{ $class-description "Host name/port number specifier for TCP/IP and UDP/IP connections. The " { $link inet-host } " and " { $link inet-port } " slots hold the host name and port name or number, respectively. New instances are created by calling " { $link } "." } +{ $class-description "Host name/port number specifier for TCP/IP and UDP/IP connections. The " { $snippet "host" } " and " { $snippet "port" } " slots hold the host name and port name or number, respectively. New instances are created by calling " { $link } "." } { $notes "This address specifier is only supported by " { $link } ", which calls " { $link resolve-host } " to obtain a list of IP addresses associated with the host name, and attempts a connection to each one in turn until one succeeds. Other network words do not accept this address specifier, and " { $link resolve-host } " must be called directly; it is then up to the application to pick the correct address from the (possibly several) addresses associated to the host name." } @@ -74,7 +74,7 @@ HELP: inet } ; HELP: inet4 -{ $class-description "IPv4 address/port number specifier for TCP/IP and UDP/IP connections. The " { $link inet4-host } " and " { $link inet4-port } " slots hold the IPv4 address and port number, respectively. New instances are created by calling " { $link } "." } +{ $class-description "IPv4 address/port number specifier for TCP/IP and UDP/IP connections. The " { $snippet "host" } " and " { $snippet "port" } " slots hold the IPv4 address and port number, respectively. New instances are created by calling " { $link } "." } { $notes "New instances should not be created directly; instead, use " { $link resolve-host } " to look up the address associated to a host name. Also, try to support IPv6 where possible." } @@ -83,7 +83,7 @@ HELP: inet4 } ; HELP: inet6 -{ $class-description "IPv6 address/port number specifier for TCP/IP and UDP/IP connections. The " { $link inet6-host } " and " { $link inet6-port } " slots hold the IPv6 address and port number, respectively. New instances are created by calling " { $link } "." } +{ $class-description "IPv6 address/port number specifier for TCP/IP and UDP/IP connections. The " { $snippet "host" } " and " { $snippet "port" } " slots hold the IPv6 address and port number, respectively. New instances are created by calling " { $link } "." } { $notes "New instances should not be created directly; instead, use " { $link resolve-host } " to look up the address associated to a host name." } { $examples @@ -91,13 +91,19 @@ HELP: inet6 } ; HELP: -{ $values { "addrspec" "an address specifier" } { "encoding" "an encding descriptor" } { "stream" "a bidirectional stream" } } -{ $description "Opens a network connection and outputs a bidirectional stream using the given encoding." } +{ $values { "remote" "an address specifier" } { "encoding" "an encding descriptor" } { "stream" "a bidirectional stream" } { "local" "an address specifier" } } +{ $description "Opens a network connection and outputs a bidirectional stream using the given encoding, together with the local address the socket was bound to." } { $errors "Throws an error if the connection cannot be established." } +{ $notes "The " { $link with-client } " word is easier to use in most situations." } { $examples { $code "\"www.apple.com\" \"http\" utf8 " } } ; +HELP: with-client +{ $values { "remote" "an address specifier" } { "encoding" "an encding descriptor" } { "quot" quotation } } +{ $description "Opens a network connection and calls the quotation in a new dynamic scope with " { $link input-stream } " and " { $link output-stream } " rebound to the network streams. The local address the socket is bound to is stored in the " { $link local-address } " variable." } +{ $errors "Throws an error if the connection cannot be established." } ; + HELP: { $values { "addrspec" "an address specifier" } { "encoding" "an encoding descriptor" } { "server" "a handle" } } { $description @@ -113,6 +119,13 @@ HELP: "To start a server which listens for connections from the loopback interface only, use an address specifier returned by the following code, where 1234 is the desired port number:" { $code "\"localhost\" 1234 t resolve-host" } "Since " { $link resolve-host } " can return multiple address specifiers, your server code must listen on them all to work properly. The " { $vocab-link "io.server" } " vocabulary can be used to help with this." + $nl + "To start a TCP/IP server which listens for connections on a randomly-assigned port, set the port number in the address specifier to 0, and then read the " { $snippet "addr" } " slot of the server instance to obtain the actual port number it is listening on:" + { $unchecked-example + "f 0 ascii " + "[ addr>> . ] [ dispose ] bi" + "T{ inet4 f \"0.0.0.0\" 58901 }" + } } { $errors "Throws an error if the address is already in use, or if it if the system forbids access." } ; diff --git a/extra/io/sockets/sockets-tests.factor b/extra/io/sockets/sockets-tests.factor index 1810b8587b..b4dd910004 100644 --- a/extra/io/sockets/sockets-tests.factor +++ b/extra/io/sockets/sockets-tests.factor @@ -1,4 +1,46 @@ IN: io.sockets.tests USING: io.sockets sequences math tools.test ; +[ B{ 1 2 3 4 } ] +[ "1.2.3.4" T{ inet4 } inet-pton ] unit-test + +[ "1.2.3.4" ] +[ B{ 1 2 3 4 } T{ inet4 } inet-ntop ] unit-test + +[ "255.255.255.255" ] +[ B{ 255 255 255 255 } T{ inet4 } inet-ntop ] unit-test + +[ B{ 255 255 255 255 } ] +[ "255.255.255.255" T{ inet4 } inet-pton ] unit-test + +[ B{ 0 1 0 2 0 3 0 4 0 5 0 6 0 7 0 8 } ] +[ "1:2:3:4:5:6:7:8" T{ inet6 } inet-pton ] unit-test + +[ "1:2:3:4:5:6:7:8" ] +[ B{ 0 1 0 2 0 3 0 4 0 5 0 6 0 7 0 8 } T{ inet6 } inet-ntop ] unit-test + +[ B{ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 } ] +[ "::" T{ inet6 } inet-pton ] unit-test + +[ "0:0:0:0:0:0:0:0" ] +[ B{ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 } T{ inet6 } inet-ntop ] unit-test + +[ B{ 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 } ] +[ "1::" T{ inet6 } inet-pton ] unit-test + +[ B{ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 } ] +[ "::1" T{ inet6 } inet-pton ] unit-test + +[ B{ 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 2 } ] +[ "1::2" T{ inet6 } inet-pton ] unit-test + +[ B{ 0 1 0 0 0 0 0 0 0 0 0 0 0 2 0 3 } ] +[ "1::2:3" T{ inet6 } inet-pton ] unit-test + +[ B{ 0 1 0 2 0 0 0 0 0 0 0 0 0 3 0 4 } ] +[ "1:2::3:4" T{ inet6 } inet-pton ] unit-test + +[ "1:2:0:0:0:0:3:4" ] +[ B{ 0 1 0 2 0 0 0 0 0 0 0 0 0 3 0 4 } T{ inet6 } inet-ntop ] unit-test + [ t ] [ "localhost" 80 f resolve-host length 1 >= ] unit-test diff --git a/extra/io/sockets/sockets.factor b/extra/io/sockets/sockets.factor index 7b0f55cab7..1075858346 100755 --- a/extra/io/sockets/sockets.factor +++ b/extra/io/sockets/sockets.factor @@ -1,10 +1,39 @@ -! Copyright (C) 2007, 2008 Slava Pestov, Daniel Ehrenberg. +! Copyright (C) 2007, 2008 Slava Pestov, Doug Coleman, +! Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: generic kernel io.backend namespaces continuations -sequences arrays io.encodings io.nonblocking io.streams.duplex -accessors destructors ; +sequences arrays io.encodings io.ports io.streams.duplex +io.encodings.ascii alien.strings io.binary accessors destructors +classes debugger byte-arrays system combinators parser +alien.c-types math.parser splitting math assocs inspector ; IN: io.sockets +<< { + { [ os windows? ] [ "windows.winsock" ] } + { [ os unix? ] [ "unix" ] } +} cond use+ >> + +! Addressing +GENERIC: protocol-family ( addrspec -- af ) + +GENERIC: sockaddr-type ( addrspec -- type ) + +GENERIC: make-sockaddr ( addrspec -- sockaddr ) + +GENERIC: address-size ( addrspec -- n ) + +GENERIC: inet-ntop ( data addrspec -- str ) + +GENERIC: inet-pton ( str addrspec -- data ) + +: make-sockaddr/size ( addrspec -- sockaddr size ) + dup make-sockaddr swap sockaddr-type heap-size ; + +: empty-sockaddr/size ( addrspec -- sockaddr len ) + sockaddr-type [ ] [ heap-size ] bi ; + +GENERIC: parse-sockaddr ( sockaddr addrspec -- newaddrspec ) + TUPLE: local path ; : ( path -- addrspec ) @@ -14,59 +43,248 @@ TUPLE: inet4 host port ; C: inet4 +M: inet4 inet-ntop ( data addrspec -- str ) + drop 4 memory>byte-array [ number>string ] { } map-as "." join ; + +ERROR: invalid-inet4 string reason ; + +M: invalid-inet4 summary drop "Invalid IPv4 address" ; + +M: inet4 inet-pton ( str addrspec -- data ) + drop + [ + "." split dup length 4 = [ + "Must have four components" throw + ] unless + [ + string>number + [ "Dotted component not a number" throw ] unless* + ] B{ } map-as + ] [ invalid-inet4 ] recover ; + +M: inet4 address-size drop 4 ; + +M: inet4 protocol-family drop PF_INET ; + +M: inet4 sockaddr-type drop "sockaddr-in" c-type ; + +M: inet4 make-sockaddr ( inet -- sockaddr ) + "sockaddr-in" + AF_INET over set-sockaddr-in-family + over inet4-port htons over set-sockaddr-in-port + over inet4-host + "0.0.0.0" or + rot inet-pton *uint over set-sockaddr-in-addr ; + + + +M: inet4 parse-sockaddr + >r dup sockaddr-in-addr r> inet-ntop + swap sockaddr-in-port ntohs (port) ; + TUPLE: inet6 host port ; C: inet6 +M: inet6 inet-ntop ( data addrspec -- str ) + drop 16 memory>byte-array 2 [ be> >hex ] map ":" join ; + +ERROR: invalid-inet6 string reason ; + +M: invalid-inet6 summary drop "Invalid IPv6 address" ; + + [ "Component not a number" throw ] unless* + ] B{ } map-as + ] if ; + +: pad-inet6 ( string1 string2 -- seq ) + 2dup [ length ] bi@ + 8 swap - + dup 0 < [ "More than 8 components" throw ] when + swap 3append ; + +: inet6-bytes ( seq -- bytes ) + [ 2 >be ] { } map-as concat >byte-array ; + +PRIVATE> + +M: inet6 inet-pton ( str addrspec -- data ) + drop + [ + "::" split1 [ parse-inet6 ] bi@ pad-inet6 inet6-bytes + ] [ invalid-inet6 ] recover ; + +M: inet6 address-size drop 16 ; + +M: inet6 protocol-family drop PF_INET6 ; + +M: inet6 sockaddr-type drop "sockaddr-in6" c-type ; + +M: inet6 make-sockaddr ( inet -- sockaddr ) + "sockaddr-in6" + AF_INET6 over set-sockaddr-in6-family + over inet6-port htons over set-sockaddr-in6-port + over inet6-host "::" or + rot inet-pton over set-sockaddr-in6-addr ; + +M: inet6 parse-sockaddr + >r dup sockaddr-in6-addr r> inet-ntop + swap sockaddr-in6-port ntohs (port) ; + +: addrspec-of-family ( af -- addrspec ) + { + { AF_INET [ T{ inet4 } ] } + { AF_INET6 [ T{ inet6 } ] } + { AF_UNIX [ T{ local } ] } + [ drop f ] + } case ; + +M: f parse-sockaddr nip ; + +GENERIC# (wait-to-connect) 1 ( client-out handle remote -- sockaddr ) + +: wait-to-connect ( client-out handle remote -- local ) + [ (wait-to-connect) ] keep parse-sockaddr ; + +GENERIC: ((client)) ( remote -- handle ) + +GENERIC: (client) ( remote -- client-in client-out local ) + +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 + ] with-destructors ; + +: ( remote encoding -- stream local ) + >r (client) -rot r> swap ; + +SYMBOL: local-address + +: with-client ( addrspec encoding quot -- ) + >r [ local-address set ] curry + r> compose with-stream ; inline + +TUPLE: server-port < port addr encoding ; + +: check-server-port ( port -- port ) + check-closed + dup server-port? [ "Not a server port" throw ] unless ; inline + +GENERIC: (server) ( addrspec -- handle sockaddr ) + +: ( addrspec encoding -- server ) + >r [ (server) ] keep parse-sockaddr + swap server-port + swap >>addr + r> >>encoding ; + +GENERIC: (accept) ( server addrspec -- handle remote ) + +: accept ( server -- client remote ) + check-server-port + [ dup addr>> (accept) ] keep + tuck + [ [ dup ] [ encoding>> ] bi* ] + [ addr>> parse-sockaddr ] + 2bi* ; + +TUPLE: datagram-port < port addr ; + +HOOK: (datagram) io-backend ( addr -- datagram ) + +: ( addr -- datagram ) + dup (datagram) datagram-port swap >>addr ; + +: check-datagram-port ( port -- port ) + check-closed + dup datagram-port? [ "Not a datagram port" throw ] unless ; inline + +HOOK: (receive) io-backend ( datagram -- packet addrspec ) + +: receive ( datagram -- packet sockaddr ) + check-datagram-port + [ (receive) ] [ addr>> ] bi parse-sockaddr ; + +: check-datagram-send ( packet addrspec port -- packet addrspec port ) + check-datagram-port + 2dup addr>> [ class ] bi@ assert= + pick class byte-array assert= ; + +HOOK: (send) io-backend ( packet addrspec datagram -- ) + +: send ( packet addrspec datagram -- ) + check-datagram-send (send) ; + +: addrinfo>addrspec ( addrinfo -- addrspec ) + [ addrinfo-addr ] [ addrinfo-family addrspec-of-family ] bi + parse-sockaddr ; + +: parse-addrinfo-list ( addrinfo -- seq ) + [ addrinfo-next ] follow + [ addrinfo>addrspec ] map + sift ; + +: prepare-resolve-host ( host serv passive? -- host' serv' flags ) + #! If the port is a number, we resolve for 'http' then + #! change it later. This is a workaround for a FreeBSD + #! getaddrinfo() limitation -- on Windows, Linux and Mac, + #! we can convert a number to a string and pass that as the + #! service name, but on FreeBSD this gives us an unknown + #! service error. + >r + dup integer? [ port-override set "http" ] when + r> AI_PASSIVE 0 ? ; + +HOOK: addrinfo-error io-backend ( n -- ) + +: resolve-host ( host serv passive? -- seq ) + [ + prepare-resolve-host + "addrinfo" + [ set-addrinfo-flags ] keep + PF_UNSPEC over set-addrinfo-family + IPPROTO_TCP over set-addrinfo-protocol + f [ getaddrinfo addrinfo-error ] keep *void* + [ parse-addrinfo-list ] keep + freeaddrinfo + ] with-scope ; + +: host-name ( -- string ) + 256 dup dup length gethostname + zero? [ "gethostname failed" throw ] unless + ascii alien>string ; + TUPLE: inet host port ; C: inet -GENERIC: wait-to-connect ( client-out handle -- ) - -GENERIC: ((client)) ( addrspec -- handle ) - -GENERIC: (client) ( addrspec -- client-in client-out ) - -M: array (client) [ (client) 2array ] attempt-all first2 ; - -M: object (client) - [ - ((client)) - dup - 2dup [ add-error-destructor ] bi@ - dup dup handle>> wait-to-connect - ] with-destructors ; - -: ( addrspec encoding -- stream ) - >r (client) r> ; - -: with-client ( addrspec encoding quot -- ) - >r r> with-stream ; inline - -HOOK: (server) io-backend ( addrspec -- handle ) - -: ( addrspec encoding -- server ) - >r [ (server) ] keep r> ; - -HOOK: (accept) io-backend ( server -- addrspec handle ) - -: accept ( server -- client addrspec ) - [ (accept) dup ] [ encoding>> ] bi - swap ; - -HOOK: io-backend ( addrspec -- datagram ) - -HOOK: receive io-backend ( datagram -- packet addrspec ) - -HOOK: send io-backend ( packet addrspec datagram -- ) - -HOOK: resolve-host io-backend ( host serv passive? -- seq ) - -HOOK: host-name io-backend ( -- string ) - : resolve-client-addr ( inet -- seq ) [ host>> ] [ port>> ] bi f resolve-host ; M: inet (client) resolve-client-addr (client) ; + +ERROR: invalid-inet-server addrspec ; + +M: invalid-inet-server summary + drop "Cannot use with ; use or instead" ; + +M: inet (server) + invalid-inet-server ; diff --git a/extra/io/timeouts/timeouts.factor b/extra/io/timeouts/timeouts.factor index f9ffd5e98f..816bfd1b19 100755 --- a/extra/io/timeouts/timeouts.factor +++ b/extra/io/timeouts/timeouts.factor @@ -4,7 +4,6 @@ USING: kernel calendar alarms io io.encodings accessors namespaces ; IN: io.timeouts -! Won't need this with new slot accessors GENERIC: timeout ( obj -- dt/f ) GENERIC: set-timeout ( dt/f obj -- ) @@ -14,8 +13,6 @@ M: encoder set-timeout stream>> set-timeout ; GENERIC: timed-out ( obj -- ) -M: object timed-out drop ; - : queue-timeout ( obj timeout -- alarm ) >r [ timed-out ] curry r> later ; diff --git a/extra/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor index 652d4e77b3..207fdc3cbc 100644 --- a/extra/io/unix/backend/backend.factor +++ b/extra/io/unix/backend/backend.factor @@ -1,69 +1,95 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien generic assocs kernel kernel.private math -io.nonblocking sequences strings structs sbufs threads unix +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 ; +io.encodings.utf8 accessors inspector combinators ; QUALIFIED: io IN: io.unix.backend ! I/O tasks -TUPLE: io-task port callbacks ; - GENERIC: handle-fd ( handle -- fd ) -M: integer handle-fd ; +TUPLE: fd fd closed ; -: io-task-fd port>> handle>> handle-fd ; +: ( n -- fd ) f fd boa ; -: ( port continuation/f class -- task ) - new - swap [ 1vector ] [ V{ } clone ] if* >>callbacks - swap >>port ; inline +M: fd dispose + dup closed>> + [ drop ] [ t >>closed fd>> close-file ] if ; -TUPLE: input-task < io-task ; - -TUPLE: output-task < io-task ; - -GENERIC: do-io-task ( task -- ? ) -GENERIC: io-task-container ( mx task -- hashtable ) +M: fd handle-fd fd>> ; ! I/O multiplexers TUPLE: mx fd reads writes ; -M: input-task io-task-container drop reads>> ; - -M: output-task io-task-container drop writes>> ; - : new-mx ( class -- obj ) new H{ } clone >>reads H{ } clone >>writes ; inline -GENERIC: register-io-task ( task mx -- ) -GENERIC: unregister-io-task ( task mx -- ) +GENERIC: add-input-callback ( thread fd mx -- ) + +: add-callback ( thread fd assoc -- ) + [ ?push ] change-at ; + +M: mx add-input-callback reads>> add-callback ; + +GENERIC: add-output-callback ( thread fd mx -- ) + +M: mx add-output-callback writes>> add-callback ; + +GENERIC: remove-input-callbacks ( fd mx -- callbacks ) + +M: mx remove-input-callbacks reads>> delete-at* drop ; + +GENERIC: remove-output-callbacks ( fd mx -- callbacks ) + +M: mx remove-output-callbacks writes>> delete-at* drop ; + GENERIC: wait-for-events ( ms mx -- ) -: fd/container ( task mx -- task fd container ) - over io-task-container >r dup io-task-fd r> ; inline +TUPLE: unix-io-error error port ; -: check-io-task ( task mx -- ) - fd/container key? nip [ - "Cannot perform multiple reads from the same port" throw - ] when ; +: report-error ( error port -- ) + tuck unix-io-error boa >>error drop ; -M: mx register-io-task ( task mx -- ) - 2dup check-io-task fd/container set-at ; +: input-available ( fd mx -- ) + remove-input-callbacks [ resume ] each ; -: add-io-task ( task -- ) - mx get-global register-io-task ; +: output-available ( fd mx -- ) + remove-output-callbacks [ resume ] each ; -: with-port-continuation ( port quot -- port ) - [ "I/O" suspend drop ] curry with-timeout ; inline +TUPLE: io-timeout ; -M: mx unregister-io-task ( task mx -- ) - fd/container delete-at drop ; +M: io-timeout summary drop "I/O operation timed out" ; + +M: unix cancel-io ( port -- ) + io-timeout new over report-error + handle>> handle-fd mx get-global + [ input-available ] [ output-available ] 2bi ; + +SYMBOL: +retry+ ! just try the operation again without blocking +SYMBOL: +input+ +SYMBOL: +output+ + +: wait-for-fd ( handle event -- ) + dup +retry+ eq? [ 2drop ] [ + [ + >r + swap handle-fd + mx get-global + r> { + { +input+ [ add-input-callback ] } + { +output+ [ add-output-callback ] } + } case + ] curry "I/O" suspend 2drop + ] if ; + +: wait-for-port ( port event -- ) + [ >r dup handle>> r> wait-for-fd ] curry + with-timeout pending-error ; ! Some general stuff : file-mode OCT: 0666 ; @@ -77,54 +103,19 @@ M: mx unregister-io-task ( task mx -- ) : io-error ( n -- ) 0 < [ (io-error) ] when ; -M: integer init-handle ( fd -- ) +M: fd init-handle ( fd -- ) #! We drop the error code rather than calling io-error, #! since on OS X 10.3, this operation fails from init-io #! when running the Factor.app (presumably because fd 0 and #! 1 are closed). + fd>> [ F_SETFL O_NONBLOCK fcntl drop ] [ F_SETFD FD_CLOEXEC fcntl drop ] bi ; -M: integer close-handle ( fd -- ) - close ; - -TUPLE: unix-io-error error port ; - -: report-error ( error port -- ) - tuck unix-io-error boa >>error drop ; - -: ignorable-error? ( n -- ? ) - [ EAGAIN number= ] [ EINTR number= ] bi or ; - -: defer-error ( port -- ? ) - #! Return t if it is an unrecoverable error. - err_no dup ignorable-error? - [ 2drop f ] [ strerror swap report-error t ] if ; - -: pop-callbacks ( mx task -- ) - dup rot unregister-io-task - io-task-callbacks [ resume ] each ; - -: perform-io-task ( mx task -- ) - dup do-io-task [ pop-callbacks ] [ 2drop ] if ; - -: handle-timeout ( port mx assoc -- ) - >r swap port-handle r> delete-at* [ - "I/O operation cancelled" over port>> report-error - pop-callbacks - ] [ - 2drop - ] if ; - -: cancel-io-tasks ( port mx -- ) - [ dup reads>> handle-timeout ] - [ dup writes>> handle-timeout ] 2bi ; - -M: unix cancel-io ( port -- ) - mx get-global cancel-io-tasks ; +M: fd close-handle ( fd -- ) dispose ; ! Readers -: reader-eof ( reader -- ) +: eof ( reader -- ) dup buffer>> buffer-empty? [ t >>eof ] when drop ; : (refill) ( port -- n ) @@ -132,70 +123,50 @@ M: unix cancel-io ( port -- ) [ buffer>> buffer-end ] [ buffer>> buffer-capacity ] tri read ; -GENERIC: refill ( port handle -- ? ) +! Returns an event to wait for which will ensure completion of +! this request +GENERIC: refill ( port handle -- event/f ) -M: integer refill - #! Return f if there is a recoverable error - drop - dup buffer>> buffer-empty? [ - dup (refill) dup 0 >= [ - swap buffer>> n>buffer t - ] [ - drop defer-error - ] if - ] [ drop t ] if ; +M: fd refill + fd>> over buffer>> [ buffer-end ] [ buffer-capacity ] bi read + { + { [ dup 0 = ] [ drop eof f ] } + { [ dup 0 > ] [ swap buffer>> n>buffer f ] } + { [ err_no EINTR = ] [ 2drop +retry+ ] } + { [ err_no EAGAIN = ] [ 2drop +input+ ] } + [ (io-error) ] + } cond ; -TUPLE: read-task < input-task ; - -: ( port continuation -- task ) read-task ; - -M: read-task do-io-task - port>> dup dup handle>> refill - [ [ reader-eof ] [ drop ] if ] keep ; - -M: unix (wait-to-read) - [ add-io-task ] with-port-continuation - pending-error ; +M: unix (wait-to-read) ( port -- ) + dup dup handle>> refill dup + [ dupd wait-for-port (wait-to-read) ] [ 2drop ] if ; ! Writers -GENERIC: drain ( port handle -- ? ) +GENERIC: drain ( port handle -- event/f ) -M: integer drain - drop - dup - [ handle>> ] - [ buffer>> buffer@ ] - [ buffer>> buffer-length ] tri - write dup 0 >= - [ swap buffer>> buffer-consume f ] - [ drop defer-error ] if ; +M: fd drain + fd>> over buffer>> [ buffer@ ] [ buffer-length ] bi write + { + { [ dup 0 >= ] [ + over buffer>> buffer-consume + buffer>> buffer-empty? f +output+ ? + ] } + { [ err_no EINTR = ] [ 2drop +retry+ ] } + { [ err_no EAGAIN = ] [ 2drop +output+ ] } + [ (io-error) ] + } cond ; -TUPLE: write-task < output-task ; - -: ( port continuation -- task ) write-task ; - -M: write-task do-io-task - io-task-port dup [ buffer>> buffer-empty? ] [ port-error ] bi or - [ 0 swap buffer>> buffer-reset t ] [ dup handle>> drain ] if ; - -: add-write-io-task ( port continuation -- ) - over handle>> mx get-global writes>> at* - [ io-task-callbacks push drop ] - [ drop add-io-task ] if ; - -: (wait-to-write) ( port -- ) - [ add-write-io-task ] with-port-continuation drop ; - -M: unix flush-port ( port -- ) - dup buffer>> buffer-empty? [ drop ] [ (wait-to-write) ] if ; +M: unix (wait-to-write) ( port -- ) + dup dup handle>> drain dup + [ dupd wait-for-port (wait-to-write) ] [ 2drop ] if ; M: unix io-multiplex ( ms/f -- ) mx get-global wait-for-events ; M: unix (init-stdio) ( -- ) - 0 - 1 - 2 ; + 0 + 1 + 2 ; ! mx io-task for embedding an fd-based mx inside another mx TUPLE: mx-port < port mx ; @@ -203,16 +174,10 @@ TUPLE: mx-port < port mx ; : ( mx -- port ) dup fd>> mx-port swap >>mx ; -TUPLE: mx-task < io-task ; - -: ( port -- task ) - f mx-task ; - -M: mx-task do-io-task - port>> mx>> 0 swap wait-for-events f ; - : multiplexer-error ( n -- ) - 0 < [ err_no ignorable-error? [ (io-error) ] unless ] when ; + 0 < [ + err_no [ EAGAIN = ] [ EINTR = ] bi or [ (io-error) ] unless + ] when ; : ?flag ( n mask symbol -- n ) pick rot bitand 0 > [ , ] [ drop ] if ; diff --git a/extra/io/unix/bsd/bsd.factor b/extra/io/unix/bsd/bsd.factor index d74c355642..c8219a9f63 100755 --- a/extra/io/unix/bsd/bsd.factor +++ b/extra/io/unix/bsd/bsd.factor @@ -3,16 +3,16 @@ IN: io.unix.bsd USING: namespaces system kernel accessors assocs continuations unix -io.backend io.unix.backend io.unix.select io.unix.kqueue io.monitors ; +io.backend io.unix.backend io.unix.select io.monitors ; M: bsd init-io ( -- ) - mx set-global - kqueue-mx set-global - kqueue-mx get-global - dup io-task-fd - [ mx get-global reads>> set-at ] - [ mx get-global writes>> set-at ] 2bi ; + mx set-global ; +! kqueue-mx set-global +! kqueue-mx get-global +! dup io-task-fd +! [ mx get-global reads>> set-at ] +! [ mx get-global writes>> set-at ] 2bi ; -M: bsd (monitor) ( path recursive? mailbox -- ) - swap [ "Recursive kqueue monitors not supported" throw ] when - ; +! M: bsd (monitor) ( path recursive? mailbox -- ) +! swap [ "Recursive kqueue monitors not supported" throw ] when +! ; diff --git a/extra/io/unix/epoll/epoll.factor b/extra/io/unix/epoll/epoll.factor index f34a4c7009..406a7fcb50 100644 --- a/extra/io/unix/epoll/epoll.factor +++ b/extra/io/unix/epoll/epoll.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types kernel io.nonblocking io.unix.backend +USING: alien.c-types kernel io.ports io.unix.backend bit-arrays sequences assocs unix unix.linux.epoll math namespaces structs ; IN: io.unix.epoll diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor index 835b14e66d..27dcc01889 100755 --- a/extra/io/unix/files/files.factor +++ b/extra/io/unix/files/files.factor @@ -1,44 +1,44 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: io.backend io.nonblocking io.unix.backend io.files io +USING: io.backend io.ports io.unix.backend io.files io unix unix.stat unix.time kernel math continuations math.bitfields byte-arrays alien combinators calendar io.encodings.binary accessors sequences strings system -io.files.private ; +io.files.private destructors ; IN: io.unix.files M: unix cwd ( -- path ) - MAXPATHLEN [ ] [ ] bi getcwd + MAXPATHLEN [ ] keep getcwd [ (io-error) ] unless* ; -M: unix cd ( path -- ) - chdir io-error ; +M: unix cd ( path -- ) [ chdir ] unix-system-call drop ; : read-flags O_RDONLY ; inline -: open-read ( path -- fd ) - O_RDONLY file-mode open dup io-error ; +: open-read ( path -- fd ) O_RDONLY file-mode open-file ; M: unix (file-reader) ( path -- stream ) - open-read ; + open-read ; : write-flags { O_WRONLY O_CREAT O_TRUNC } flags ; inline : open-write ( path -- fd ) - write-flags file-mode open dup io-error ; + write-flags file-mode open-file ; M: unix (file-writer) ( path -- stream ) - open-write ; + open-write ; : append-flags { O_WRONLY O_APPEND O_CREAT } flags ; inline : open-append ( path -- fd ) - append-flags file-mode open dup io-error - [ dup 0 SEEK_END lseek io-error ] [ ] [ close ] cleanup ; + [ + append-flags file-mode open-file dup close-later + dup 0 SEEK_END lseek io-error + ] with-destructors ; M: unix (file-appender) ( path -- stream ) - open-append ; + open-append ; : touch-mode ( -- n ) { O_WRONLY O_APPEND O_CREAT O_EXCL } flags ; foldable @@ -46,14 +46,13 @@ M: unix (file-appender) ( path -- stream ) M: unix touch-file ( path -- ) normalize-path dup exists? [ touch ] [ - touch-mode file-mode open close + touch-mode file-mode open-file close-file ] if ; M: unix move-file ( from to -- ) [ normalize-path ] bi@ rename io-error ; -M: unix delete-file ( path -- ) - normalize-path unlink io-error ; +M: unix delete-file ( path -- ) normalize-path unlink-file ; M: unix make-directory ( path -- ) normalize-path OCT: 777 mkdir io-error ; @@ -106,6 +105,4 @@ M: unix make-link ( path1 path2 -- ) normalize-path symlink io-error ; M: unix read-link ( path -- path' ) - normalize-path - PATH_MAX [ tuck ] [ ] bi readlink - dup io-error head-slice >string ; + normalize-path read-symbolic-link ; \ No newline at end of file diff --git a/extra/io/unix/files/unique/unique.factor b/extra/io/unix/files/unique/unique.factor index 035e6398ee..dca2f51958 100644 --- a/extra/io/unix/files/unique/unique.factor +++ b/extra/io/unix/files/unique/unique.factor @@ -1,4 +1,4 @@ -USING: kernel io.nonblocking io.unix.backend math.bitfields +USING: kernel io.ports io.unix.backend math.bitfields unix io.files.unique.backend system ; IN: io.unix.files.unique @@ -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" ; diff --git a/extra/io/unix/kqueue/kqueue.factor b/extra/io/unix/kqueue/kqueue.factor index ad5240e548..8888d0182f 100755 --- a/extra/io/unix/kqueue/kqueue.factor +++ b/extra/io/unix/kqueue/kqueue.factor @@ -4,7 +4,7 @@ USING: alien.c-types kernel math math.bitfields namespaces locals accessors combinators threads vectors hashtables sequences assocs continuations sets unix unix.time unix.kqueue unix.process -io.nonblocking io.unix.backend io.launcher io.unix.launcher +io.ports io.unix.backend io.launcher io.unix.launcher io.monitors ; IN: io.unix.kqueue diff --git a/extra/io/unix/launcher/launcher-tests.factor b/extra/io/unix/launcher/launcher-tests.factor index 177c5775dc..49bfc34164 100755 --- a/extra/io/unix/launcher/launcher-tests.factor +++ b/extra/io/unix/launcher/launcher-tests.factor @@ -110,3 +110,5 @@ accessors kernel sequences io.encodings.utf8 ; ] times "append-test" temp-file utf8 file-contents ] unit-test + +[ ] [ "ls" utf8 contents drop ] unit-test diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor index 043b2bd73e..3b9c8fc7af 100755 --- a/extra/io/unix/launcher/launcher.factor +++ b/extra/io/unix/launcher/launcher.factor @@ -3,7 +3,7 @@ USING: kernel namespaces math system sequences debugger continuations arrays assocs combinators alien.c-types strings threads accessors -io io.backend io.launcher io.nonblocking io.files +io io.backend io.launcher io.ports io.files io.files.private io.unix.files io.unix.backend io.unix.launcher.parser unix unix.process ; @@ -31,7 +31,7 @@ USE: unix ] when* ; : redirect-fd ( oldfd fd -- ) - 2dup = [ 2drop ] [ dupd dup2 io-error close ] if ; + 2dup = [ 2drop ] [ dupd dup2 io-error close-file ] if ; : reset-fd ( fd -- ) #! We drop the error code because on *BSD, fcntl of @@ -44,7 +44,7 @@ USE: unix : redirect-file ( obj mode fd -- ) >r >r normalize-path r> file-mode - open dup io-error r> redirect-fd ; + open-file r> redirect-fd ; : redirect-file-append ( obj mode fd -- ) >r drop path>> normalize-path open-append r> redirect-fd ; @@ -58,7 +58,7 @@ USE: unix { [ pick string? ] [ redirect-file ] } { [ pick appender? ] [ redirect-file-append ] } { [ pick +closed+ eq? ] [ redirect-closed ] } - { [ pick integer? ] [ >r drop dup reset-fd r> redirect-fd ] } + { [ pick fd? ] [ >r drop fd>> dup reset-fd r> redirect-fd ] } [ >r >r underlying-handle r> r> redirect ] } cond ; diff --git a/extra/io/unix/linux/monitors/monitors.factor b/extra/io/unix/linux/monitors/monitors.factor index 31dbe42e64..43733e8481 100644 --- a/extra/io/unix/linux/monitors/monitors.factor +++ b/extra/io/unix/linux/monitors/monitors.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel io.backend io.monitors io.monitors.recursive -io.files io.buffers io.monitors io.nonblocking io.timeouts +io.files io.buffers io.monitors io.ports io.timeouts io.unix.backend io.unix.select io.encodings.utf8 unix.linux.inotify assocs namespaces threads continuations init math math.bitfields sets alien alien.strings alien.c-types @@ -110,7 +110,7 @@ M: linux-monitor dispose ( monitor -- ) ] if ; : inotify-read-loop ( port -- ) - dup wait-to-read1 + dup wait-to-read 0 over buffer>> parse-file-notifications 0 over buffer>> buffer-reset inotify-read-loop ; diff --git a/extra/io/unix/mmap/mmap.factor b/extra/io/unix/mmap/mmap.factor index ada1f94d87..3798f422d8 100755 --- a/extra/io/unix/mmap/mmap.factor +++ b/extra/io/unix/mmap/mmap.factor @@ -1,22 +1,25 @@ ! Copyright (C) 2007 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien io io.files kernel math system unix io.unix.backend -io.mmap ; +USING: alien io io.files kernel math math.bitfields system unix +io.unix.backend io.ports io.mmap destructors locals accessors ; IN: io.unix.mmap -: open-r/w ( path -- fd ) O_RDWR file-mode open dup io-error ; +: open-r/w ( path -- fd ) O_RDWR file-mode open-file ; -: mmap-open ( length prot flags path -- alien fd ) - >r f -roll r> open-r/w [ 0 mmap ] keep - over MAP_FAILED = [ close (io-error) ] when ; +:: mmap-open ( length prot flags path -- alien fd ) + [ + f length prot flags + path open-r/w dup close-later + [ 0 mmap dup MAP_FAILED = [ (io-error) ] when ] keep + ] with-destructors ; -M: unix (mapped-file) ( path length -- obj ) +M: unix (mapped-file) swap >r - dup PROT_READ PROT_WRITE bitor MAP_FILE MAP_SHARED bitor - r> mmap-open f mapped-file boa ; + { PROT_READ PROT_WRITE } flags + { MAP_FILE MAP_SHARED } flags + r> mmap-open ; M: unix close-mapped-file ( mmap -- ) - [ mapped-file-address ] keep - [ mapped-file-length munmap ] keep - mapped-file-handle close - io-error ; + [ [ address>> ] [ length>> ] bi munmap io-error ] + [ handle>> close-file ] + bi ; diff --git a/extra/io/unix/pipes/pipes.factor b/extra/io/unix/pipes/pipes.factor index 4fc5acf634..db2c917520 100644 --- a/extra/io/unix/pipes/pipes.factor +++ b/extra/io/unix/pipes/pipes.factor @@ -1,12 +1,12 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: system alien.c-types kernel unix math sequences -qualified io.unix.backend io.nonblocking ; +qualified io.unix.backend io.ports ; IN: io.unix.pipes QUALIFIED: io.pipes M: unix io.pipes:(pipe) ( -- pair ) 2 "int" dup pipe io-error - 2 c-int-array> first2 + 2 c-int-array> first2 [ ] bi@ [ [ init-handle ] bi@ ] [ io.pipes:pipe boa ] 2bi ; diff --git a/extra/io/unix/select/select.factor b/extra/io/unix/select/select.factor index 58b8371d89..fea5f4e9ae 100755 --- a/extra/io/unix/select/select.factor +++ b/extra/io/unix/select/select.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types kernel io.nonblocking io.unix.backend +USING: alien.c-types kernel io.ports io.unix.backend bit-arrays sequences assocs unix math namespaces structs -accessors math.order ; +accessors math.order locals ; IN: io.unix.select TUPLE: select-mx < mx read-fdset write-fdset ; @@ -21,21 +21,20 @@ TUPLE: select-mx < mx read-fdset write-fdset ; : clear-nth ( n seq -- ? ) [ nth ] [ f -rot set-nth ] 2bi ; -: check-fd ( fd task fdset mx -- ) - roll munge rot clear-nth - [ swap perform-io-task ] [ 2drop ] if ; +:: check-fd ( fd fdset mx quot -- ) + fd munge fdset clear-nth [ fd mx quot call ] when ; inline -: check-fdset ( tasks fdset mx -- ) - [ check-fd ] 2curry assoc-each ; +: check-fdset ( fds fdset mx quot -- ) + [ check-fd ] 3curry each ; inline -: init-fdset ( tasks fdset -- ) - [ >r drop t swap munge r> set-nth ] curry assoc-each ; +: init-fdset ( fds fdset -- ) + [ >r t swap munge r> set-nth ] curry each ; : read-fdset/tasks - [ reads>> ] [ read-fdset>> ] bi ; + [ reads>> keys ] [ read-fdset>> ] bi ; : write-fdset/tasks - [ writes>> ] [ write-fdset>> ] bi ; + [ writes>> keys ] [ write-fdset>> ] bi ; : max-fd ( assoc -- n ) dup assoc-empty? [ drop 0 ] [ keys supremum ] if ; @@ -45,12 +44,13 @@ TUPLE: select-mx < mx read-fdset write-fdset ; : init-fdsets ( mx -- nfds read write except ) [ num-fds ] - [ read-fdset/tasks tuck init-fdset ] - [ write-fdset/tasks tuck init-fdset ] tri + [ read-fdset/tasks [ init-fdset ] keep ] + [ write-fdset/tasks [ init-fdset ] keep ] tri f ; -M: select-mx wait-for-events ( ms mx -- ) - swap >r dup init-fdsets r> dup [ make-timeval ] when - select multiplexer-error - dup read-fdset/tasks pick check-fdset - dup write-fdset/tasks rot check-fdset ; +M:: select-mx wait-for-events ( ms mx -- ) + mx + [ init-fdsets ms dup [ make-timeval ] when select multiplexer-error ] + [ [ read-fdset/tasks ] keep [ input-available ] check-fdset ] + [ [ write-fdset/tasks ] keep [ output-available ] check-fdset ] + tri ; diff --git a/extra/io/unix/sockets/secure/secure.factor b/extra/io/unix/sockets/secure/secure.factor index e8bcd0e0f0..14cd9fdb6f 100644 --- a/extra/io/unix/sockets/secure/secure.factor +++ b/extra/io/unix/sockets/secure/secure.factor @@ -4,94 +4,138 @@ USING: accessors byte-arrays kernel debugger sequences namespaces math math.order combinators init alien alien.c-types alien.strings libc continuations destructors openssl openssl.libcrypto openssl.libssl -io.files io.nonblocking io.unix.backend io.unix.sockets +io.files io.ports io.unix.backend io.unix.sockets io.encodings.ascii io.buffers io.sockets io.sockets.secure -unix ; +unix system ; IN: io.unix.sockets.secure ! todo: SSL_pending, rehandshake -! do we call write twice, wth 0 bytes at the end? ! check-certificate at some point ! test on windows -M: ssl-handle handle-fd file>> ; +M: ssl-handle handle-fd file>> handle-fd ; -: syscall-error ( port r -- ) +: syscall-error ( r -- * ) ERR_get_error dup zero? [ drop { - { -1 [ err_no strerror ] } - { 0 [ "Premature EOF" ] } + { -1 [ (io-error) ] } + { 0 [ "Premature EOF" throw ] } } case ] [ - nip (ssl-error-string) - ] if swap report-error ; + nip (ssl-error) + ] if ; : check-response ( port r -- port r n ) over handle>> handle>> over SSL_get_error ; inline ! Input ports -: report-ssl-error ( port r -- ) - drop ssl-error-string swap report-error ; - -: check-read-response ( port r -- ? ) +: check-read-response ( port r -- event ) check-response { - { SSL_ERROR_NONE [ swap buffer>> n>buffer t ] } - { SSL_ERROR_ZERO_RETURN [ drop reader-eof t ] } - { SSL_ERROR_WANT_READ [ 2drop f ] } - { SSL_ERROR_WANT_WRITE [ 2drop f ] } ! XXX - { SSL_ERROR_SYSCALL [ syscall-error t ] } - { SSL_ERROR_SSL [ report-ssl-error t ] } + { SSL_ERROR_NONE [ swap buffer>> n>buffer f ] } + { SSL_ERROR_ZERO_RETURN [ drop eof f ] } + { SSL_ERROR_WANT_READ [ 2drop +input+ ] } + { SSL_ERROR_WANT_WRITE [ 2drop +output+ ] } + { SSL_ERROR_SYSCALL [ syscall-error ] } + { SSL_ERROR_SSL [ (ssl-error) ] } } case ; M: ssl-handle refill - drop - dup buffer>> buffer-empty? [ - dup - [ handle>> handle>> ] ! ssl - [ buffer>> buffer-end ] ! buf - [ buffer>> buffer-capacity ] tri ! len - SSL_read - check-read-response - ] [ drop t ] if ; + handle>> ! ssl + over buffer>> + [ buffer-end ] ! buf + [ buffer-capacity ] bi ! len + SSL_read + check-read-response ; ! Output ports -: check-write-response ( port r -- ? ) +: check-write-response ( port r -- event ) check-response { { SSL_ERROR_NONE [ swap buffer>> buffer-consume f ] } - ! { SSL_ERROR_ZERO_RETURN [ drop reader-eof ] } ! XXX - { SSL_ERROR_WANT_READ [ 2drop f ] } ! XXX - { SSL_ERROR_WANT_WRITE [ 2drop f ] } - { SSL_ERROR_SYSCALL [ syscall-error t ] } - { SSL_ERROR_SSL [ report-ssl-error t ] } + { SSL_ERROR_WANT_READ [ 2drop +input+ ] } + { SSL_ERROR_WANT_WRITE [ 2drop +output+ ] } + { SSL_ERROR_SYSCALL [ syscall-error ] } + { SSL_ERROR_SSL [ (ssl-error) ] } } case ; M: ssl-handle drain - drop - dup - [ handle>> handle>> ] ! ssl - [ buffer>> buffer@ ] ! buf - [ buffer>> buffer-length ] tri ! len + handle>> ! ssl + over buffer>> + [ buffer@ ] ! buf + [ buffer-length ] bi ! len SSL_write check-write-response ; ! Client sockets -M: ssl ((client)) ( addrspec -- handle ) - [ addrspec>> ((client)) ] with-destructors ; +: ( fd -- ssl ) + [ fd>> BIO_NOCLOSE BIO_new_socket dup ssl-error ] keep + [ handle>> swap dup SSL_set_bio ] keep ; -: check-connect-response ( port r -- ? ) +M: ssl ((client)) ( addrspec -- handle ) + addrspec>> ((client)) ; + +M: ssl parse-sockaddr addrspec>> parse-sockaddr ; + +: check-connect-response ( port r -- event ) check-response { - { SSL_ERROR_NONE [ 2drop t ] } - { SSL_ERROR_WANT_READ [ 2drop f ] } ! XXX - { SSL_ERROR_WANT_WRITE [ 2drop f ] } ! XXX - { SSL_ERROR_SYSCALL [ syscall-error t ] } - { SSL_ERROR_SSL [ report-ssl-error t ] } + { SSL_ERROR_NONE [ 2drop f ] } + { SSL_ERROR_WANT_READ [ 2drop +input+ ] } + { SSL_ERROR_WANT_WRITE [ 2drop +output+ ] } + { SSL_ERROR_SYSCALL [ syscall-error ] } + { SSL_ERROR_SSL [ (ssl-error) ] } } case ; +: do-ssl-connect ( port ssl-handle -- ) + 2dup SSL_connect check-connect-response dup + [ >r over r> wait-for-port do-ssl-connect ] [ 3drop ] if ; + M: ssl-handle (wait-to-connect) - handle>> ! ssl - SSL_connect - check-connect-response ; + addrspec>> + [ >r file>> r> (wait-to-connect) ] + [ drop handle>> do-ssl-connect ] + [ drop t >>connected 2drop ] + 3tri ; + +M: ssl (server) addrspec>> (server) ; + +: check-accept-response ( handle r -- event ) + over handle>> over SSL_get_error + { + { SSL_ERROR_NONE [ 2drop f ] } + { SSL_ERROR_WANT_READ [ 2drop +input+ ] } + { SSL_ERROR_WANT_WRITE [ 2drop +output+ ] } + { SSL_ERROR_SYSCALL [ syscall-error ] } + { SSL_ERROR_SSL [ (ssl-error) ] } + } case ; + +: do-ssl-accept ( ssl-handle -- ) + dup dup handle>> SSL_accept check-accept-response dup + [ >r dup file>> r> wait-for-fd do-ssl-accept ] [ 2drop ] if ; + +M: ssl (accept) + [ + addrspec>> + (accept) >r + dup close-later + dup close-later + dup do-ssl-accept + r> + ] with-destructors ; + +: check-shutdown-response ( handle r -- event ) + >r handle>> r> SSL_get_error + { + { SSL_ERROR_WANT_READ [ +input+ ] } + { SSL_ERROR_WANT_WRITE [ +output+ ] } + { SSL_ERROR_SYSCALL [ -1 syscall-error ] } + { SSL_ERROR_SSL [ (ssl-error) ] } + } case ; + +M: unix ssl-shutdown + dup connected>> [ + dup dup handle>> SSL_shutdown check-shutdown-response + dup [ dupd wait-for-fd ssl-shutdown ] [ 2drop ] if + ] [ drop ] if ; diff --git a/extra/io/unix/sockets/sockets.factor b/extra/io/unix/sockets/sockets.factor index fee4821f50..127f50d1aa 100755 --- a/extra/io/unix/sockets/sockets.factor +++ b/extra/io/unix/sockets/sockets.factor @@ -1,104 +1,86 @@ ! Copyright (C) 2004, 2008 Slava Pestov, Ivan Tikhonov. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.strings generic kernel math -namespaces threads sequences byte-arrays io.nonblocking -io.binary io.unix.backend io.streams.duplex io.sockets.impl -io.backend io.nonblocking io.files io.files.private +namespaces threads sequences byte-arrays io.ports +io.binary io.unix.backend io.streams.duplex +io.backend io.ports io.files io.files.private io.encodings.utf8 math.parser continuations libc combinators -system accessors qualified destructors unix ; +system accessors qualified destructors unix locals ; EXCLUDE: io => read write close ; EXCLUDE: io.sockets => accept ; IN: io.unix.sockets -: socket-fd ( domain type -- socket ) - 0 socket - dup io-error - dup close-later - dup init-handle ; +: socket-fd ( domain type -- fd ) + 0 socket dup io-error [ close-later ] [ init-handle ] [ ] tri ; -: sockopt ( fd level opt -- ) - 1 "int" heap-size setsockopt io-error ; +: set-socket-option ( fd level opt -- ) + >r >r handle-fd r> r> 1 "int" heap-size setsockopt io-error ; 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 sockopt ; + SOL_SOCKET SO_OOBINLINE set-socket-option ; -TUPLE: connect-task < output-task ; +: get-socket-name ( fd addrspec -- sockaddr ) + >r handle-fd r> empty-sockaddr/size + [ getsockname io-error ] 2keep drop ; -: ( port continuation -- task ) - connect-task ; +: get-peer-name ( fd addrspec -- sockaddr ) + >r handle-fd r> empty-sockaddr/size + [ getpeername io-error ] 2keep drop ; -GENERIC: (wait-to-connect) ( port handle -- ? ) - -M: integer (wait-to-connect) - f 0 write 0 < [ defer-error ] [ drop t ] if ; - -M: connect-task do-io-task - port>> dup handle>> (wait-to-connect) ; - -M: object wait-to-connect ( client-out fd -- ) - drop - [ add-io-task ] with-port-continuation - pending-error ; +M: fd (wait-to-connect) + >r >r +output+ wait-for-port r> r> get-socket-name ; M: object ((client)) ( addrspec -- fd ) [ protocol-family SOCK_STREAM socket-fd ] [ make-sockaddr/size ] bi - [ 2drop ] [ connect ] 3bi - zero? err_no EINPROGRESS = or + >r >r dup handle-fd r> r> connect zero? err_no EINPROGRESS = or [ dup init-client-socket ] [ (io-error) ] if ; ! Server sockets - TCP and Unix domain : init-server-socket ( fd -- ) - SOL_SOCKET SO_REUSEADDR sockopt ; - -TUPLE: accept-task < input-task ; - -: ( port continuation -- task ) - accept-task ; - -: accept-sockaddr ( port -- fd sockaddr ) - [ handle>> ] [ addr>> sockaddr-type ] bi - dup [ swap heap-size accept ] keep ; inline - -: do-accept ( port fd sockaddr -- ) - swapd over addr>> parse-sockaddr >>client-addr (>>client) ; - -M: accept-task do-io-task - io-task-port dup accept-sockaddr - over 0 >= [ do-accept t ] [ 2drop defer-error ] if ; - -: wait-to-accept ( server -- ) - [ add-io-task ] with-port-continuation drop ; + SOL_SOCKET SO_REUSEADDR set-socket-option ; : server-socket-fd ( addrspec type -- fd ) >r dup protocol-family r> socket-fd dup init-server-socket - dup rot make-sockaddr/size bind - zero? [ dup close (io-error) ] unless ; + dup handle-fd rot make-sockaddr/size bind io-error ; -M: unix (server) ( addrspec -- handle ) +M: object (server) ( addrspec -- handle sockaddr ) [ - SOCK_STREAM server-socket-fd - dup 10 listen io-error + [ + SOCK_STREAM server-socket-fd + dup handle-fd 10 listen io-error + dup + ] keep + get-socket-name ] with-destructors ; -M: unix (accept) ( server -- addrspec handle ) - #! Wait for a client connection. - check-server-port - [ wait-to-accept ] - [ pending-error ] - [ [ client-addr>> ] [ client>> ] bi ] tri ; +: do-accept ( server addrspec -- fd remote ) + [ handle>> handle-fd ] [ empty-sockaddr/size ] bi* + [ accept ] 2keep drop ; inline + +M: object (accept) ( server addrspec -- fd remote ) + 2dup do-accept + { + { [ over 0 >= ] [ { [ drop ] [ drop ] [ ] [ ] } spread ] } + { [ err_no EINTR = ] [ 2drop (accept) ] } + { [ err_no EAGAIN = ] [ + 2drop + [ drop +input+ wait-for-port ] + [ (accept) ] + 2bi + ] } + [ (io-error) ] + } cond ; ! Datagram sockets - UDP and Unix domain -M: unix - [ - [ SOCK_DGRAM server-socket-fd ] keep - ] with-destructors ; +M: unix (datagram) + [ SOCK_DGRAM server-socket-fd ] with-destructors ; SYMBOL: receive-buffer @@ -106,76 +88,45 @@ 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 - >r >r receive-buffer get-global packet-size 0 r> r> ; +:: do-receive ( port -- packet sockaddr ) + port addr>> empty-sockaddr/size [| sockaddr len | + port handle>> handle-fd ! s + receive-buffer get-global ! buf + packet-size ! nbytes + 0 ! flags + sockaddr ! from + len ! fromlen + recvfrom dup 0 >= [ + receive-buffer get-global swap head sockaddr + ] [ + drop f f + ] if + ] call ; -: do-receive ( s buffer len flags from fromlen -- sockaddr data ) - over >r recvfrom r> - over -1 = [ - 2drop f f - ] [ - receive-buffer get-global - rot head +M: unix (receive) ( datagram -- packet sockaddr ) + dup do-receive dup [ rot drop ] [ + 2drop [ +input+ wait-for-port ] [ (receive) ] bi ] if ; -TUPLE: receive-task < input-task ; +:: do-send ( packet sockaddr len socket datagram -- ) + socket handle-fd packet dup length 0 sockaddr len sendto + 0 < [ + err_no EINTR = [ + packet sockaddr len socket datagram do-send + ] [ + err_no EAGAIN = [ + datagram +output+ wait-for-port + packet sockaddr len socket datagram do-send + ] [ + (io-error) + ] if + ] if + ] when ; -: ( stream continuation -- task ) - receive-task ; - -M: receive-task do-io-task - io-task-port - dup setup-receive do-receive dup [ - pick set-datagram-port-packet - over datagram-port-addr parse-sockaddr - swap set-datagram-port-packet-addr - t - ] [ - 2drop defer-error - ] if ; - -: wait-receive ( stream -- ) - [ add-io-task ] with-port-continuation drop ; - -M: unix receive ( datagram -- packet addrspec ) - check-datagram-port - [ wait-receive ] - [ pending-error ] - [ [ packet>> ] [ packet-addr>> ] bi ] tri ; - -: do-send ( socket data sockaddr len -- n ) - >r >r dup length 0 r> r> sendto ; - -TUPLE: send-task < output-task packet sockaddr len ; - -: ( packet sockaddr len stream continuation -- task ) - send-task [ - { - set-send-task-packet - set-send-task-sockaddr - set-send-task-len - } set-slots - ] keep ; - -M: send-task do-io-task - [ io-task-port port-handle ] keep - [ send-task-packet ] keep - [ send-task-sockaddr ] keep - [ send-task-len do-send ] keep - swap 0 < [ io-task-port defer-error ] [ drop t ] if ; - -: wait-send ( packet sockaddr len stream -- ) - [ add-io-task ] with-port-continuation - 2drop 2drop ; - -M: unix send ( packet addrspec datagram -- ) - check-datagram-send - [ >r make-sockaddr/size r> wait-send ] keep - pending-error ; +M: unix (send) ( packet addrspec datagram -- ) + [ make-sockaddr/size ] [ [ handle>> ] keep ] bi* do-send ; +! Unix domain sockets M: local protocol-family drop PF_UNIX ; M: local sockaddr-type drop "sockaddr-un" c-type ; diff --git a/extra/io/windows/ce/backend/backend.factor b/extra/io/windows/ce/backend/backend.factor index 46564f2aec..7209a68ebf 100755 --- a/extra/io/windows/ce/backend/backend.factor +++ b/extra/io/windows/ce/backend/backend.factor @@ -1,4 +1,4 @@ -USING: io.nonblocking io.windows threads.private kernel +USING: io.ports io.windows threads.private kernel io.backend windows.winsock windows.kernel32 windows io.streams.duplex io namespaces alien.syntax system combinators io.buffers io.encodings io.encodings.utf8 combinators.lib ; diff --git a/extra/io/windows/ce/files/files.factor b/extra/io/windows/ce/files/files.factor index 8f7390aa7c..83d456832b 100755 --- a/extra/io/windows/ce/files/files.factor +++ b/extra/io/windows/ce/files/files.factor @@ -1,5 +1,5 @@ USING: alien alien.c-types combinators io io.backend io.buffers -io.files io.nonblocking io.windows kernel libc math namespaces +io.files io.ports io.windows kernel libc math namespaces prettyprint sequences strings threads threads.private windows windows.kernel32 io.windows.ce.backend system ; IN: windows.ce.files diff --git a/extra/io/windows/ce/sockets/sockets.factor b/extra/io/windows/ce/sockets/sockets.factor index 45c10ea258..b3117dcde1 100755 --- a/extra/io/windows/ce/sockets/sockets.factor +++ b/extra/io/windows/ce/sockets/sockets.factor @@ -1,5 +1,5 @@ USING: alien alien.c-types combinators io io.backend io.buffers -io.nonblocking io.sockets io.sockets.impl io.windows kernel libc +io.ports io.sockets io.windows kernel libc math namespaces prettyprint qualified sequences strings threads threads.private windows windows.kernel32 io.windows.ce.backend byte-arrays system ; @@ -41,7 +41,6 @@ M: wince (server) ( addrspec -- handle ) M: wince (accept) ( server -- client ) [ - dup check-server-port [ dup port-handle win32-file-handle swap server-port-addr sockaddr-type heap-size diff --git a/extra/io/windows/files/files.factor b/extra/io/windows/files/files.factor index 1fd60fe1a5..ed6ca0bc54 100755 --- a/extra/io/windows/files/files.factor +++ b/extra/io/windows/files/files.factor @@ -3,7 +3,7 @@ USING: alien.c-types io.backend io.files io.windows kernel math windows windows.kernel32 windows.time calendar combinators math.functions sequences namespaces words symbols system -combinators.lib io.nonblocking destructors math.bitfields.lib ; +combinators.lib io.ports destructors math.bitfields.lib ; IN: io.windows.files SYMBOLS: +read-only+ +hidden+ +system+ diff --git a/extra/io/windows/files/unique/unique.factor b/extra/io/windows/files/unique/unique.factor index 0449980286..2c166373e7 100644 --- a/extra/io/windows/files/unique/unique.factor +++ b/extra/io/windows/files/unique/unique.factor @@ -1,5 +1,5 @@ USING: kernel system io.files.unique.backend -windows.kernel32 io.windows io.nonblocking windows ; +windows.kernel32 io.windows io.ports windows ; IN: io.windows.files.unique M: windows (make-unique-file) ( path -- ) diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor index a5d7338cd6..28e7e241e5 100755 --- a/extra/io/windows/launcher/launcher.factor +++ b/extra/io/windows/launcher/launcher.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types arrays continuations io -io.windows io.windows.nt.pipes libc io.nonblocking +io.windows io.windows.nt.pipes libc io.ports windows.types math windows.kernel32 namespaces io.launcher kernel sequences windows.errors splitting system threads init strings combinators diff --git a/extra/io/windows/mmap/mmap.factor b/extra/io/windows/mmap/mmap.factor index dc29405b12..b401ed5556 100755 --- a/extra/io/windows/mmap/mmap.factor +++ b/extra/io/windows/mmap/mmap.factor @@ -1,5 +1,5 @@ USING: alien alien.c-types alien.syntax arrays continuations -destructors generic io.mmap io.nonblocking io.windows +destructors generic io.mmap io.ports io.windows kernel libc math namespaces quotations sequences windows windows.advapi32 windows.kernel32 io.backend system ; IN: io.windows.mmap diff --git a/extra/io/windows/nt/backend/backend.factor b/extra/io/windows/nt/backend/backend.factor index fe7f1ecc61..99364f832d 100755 --- a/extra/io/windows/nt/backend/backend.factor +++ b/extra/io/windows/nt/backend/backend.factor @@ -1,5 +1,5 @@ USING: alien alien.c-types arrays assocs combinators -continuations destructors io io.backend io.nonblocking +continuations destructors io io.backend io.ports io.windows libc kernel math namespaces sequences threads classes.tuple.lib windows windows.errors windows.kernel32 strings splitting io.files qualified ascii diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor index 12fad1a2d0..2b3021a3f1 100755 --- a/extra/io/windows/nt/files/files.factor +++ b/extra/io/windows/nt/files/files.factor @@ -1,5 +1,5 @@ USING: continuations destructors io.buffers io.files io.backend -io.timeouts io.nonblocking io.windows io.windows.nt.backend +io.timeouts io.ports io.windows io.windows.nt.backend kernel libc math threads windows windows.kernel32 system alien.c-types alien.arrays alien.strings sequences combinators combinators.lib sequences.lib ascii splitting alien strings diff --git a/extra/io/windows/nt/launcher/launcher.factor b/extra/io/windows/nt/launcher/launcher.factor index 39edd931b1..c18523e68d 100755 --- a/extra/io/windows/nt/launcher/launcher.factor +++ b/extra/io/windows/nt/launcher/launcher.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types arrays continuations destructors io -io.windows libc io.nonblocking io.pipes windows.types +io.windows libc io.ports io.pipes windows.types math windows.kernel32 windows namespaces io.launcher kernel sequences windows.errors assocs splitting system strings io.windows.launcher io.windows.nt.pipes io.backend io.files diff --git a/extra/io/windows/nt/monitors/monitors.factor b/extra/io/windows/nt/monitors/monitors.factor index 37784c673c..ee8c6c60e1 100755 --- a/extra/io/windows/nt/monitors/monitors.factor +++ b/extra/io/windows/nt/monitors/monitors.factor @@ -5,7 +5,7 @@ kernel math assocs namespaces continuations sequences hashtables sorting arrays combinators math.bitfields strings system accessors threads splitting io.backend io.windows io.windows.nt.backend io.windows.nt.files -io.monitors io.nonblocking io.buffers io.files io.timeouts io +io.monitors io.ports io.buffers io.files io.timeouts io windows windows.kernel32 windows.types ; IN: io.windows.nt.monitors diff --git a/extra/io/windows/nt/pipes/pipes.factor b/extra/io/windows/nt/pipes/pipes.factor index aa565b52e8..8a0fa05b74 100755 --- a/extra/io/windows/nt/pipes/pipes.factor +++ b/extra/io/windows/nt/pipes/pipes.factor @@ -3,7 +3,7 @@ USING: alien alien.c-types arrays destructors io io.windows libc windows.types math.bitfields windows.kernel32 windows namespaces kernel sequences windows.errors assocs math.parser system random -combinators accessors io.pipes io.nonblocking ; +combinators accessors io.pipes io.ports ; IN: io.windows.nt.pipes ! This code is based on diff --git a/extra/io/windows/nt/sockets/sockets.factor b/extra/io/windows/nt/sockets/sockets.factor index 89e1ea3277..5baa0a31e5 100755 --- a/extra/io/windows/nt/sockets/sockets.factor +++ b/extra/io/windows/nt/sockets/sockets.factor @@ -1,6 +1,6 @@ USING: alien alien.accessors alien.c-types byte-arrays -continuations destructors io.nonblocking io.timeouts io.sockets -io.sockets.impl io namespaces io.streams.duplex io.windows +continuations destructors io.ports io.timeouts io.sockets +io.sockets io namespaces io.streams.duplex io.windows io.windows.nt.backend windows.winsock kernel libc math sequences threads classes.tuple.lib system accessors ; IN: io.windows.nt.sockets @@ -125,7 +125,6 @@ TUPLE: AcceptEx-args port M: winnt (accept) ( server -- addrspec handle ) [ [ - check-server-port \ AcceptEx-args new [ init-accept ] keep [ ((accept)) ] keep @@ -141,13 +140,11 @@ M: winnt (server) ( addrspec -- handle ) f ] with-destructors ; -M: winnt ( addrspec -- datagram ) +M: winnt (datagram) ( addrspec -- handle ) [ - [ - SOCK_DGRAM server-fd - dup add-completion - f - ] keep + SOCK_DGRAM server-fd + dup add-completion + f ] with-destructors ; TUPLE: WSARecvFrom-args port diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor index 6f793bc939..5c0a1c8ecf 100755 --- a/extra/io/windows/windows.factor +++ b/extra/io/windows/windows.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2004, 2008 Mackenzie Straight, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types arrays destructors io io.backend -io.buffers io.files io.nonblocking io.sockets io.binary -io.sockets.impl windows.errors strings +io.buffers io.files io.ports io.sockets io.binary +io.sockets windows.errors strings kernel math namespaces sequences windows windows.kernel32 windows.shell32 windows.types windows.winsock splitting continuations math.bitfields system accessors ; diff --git a/extra/koszul/koszul.factor b/extra/koszul/koszul.factor index aecae1cf88..4194ff6609 100755 --- a/extra/koszul/koszul.factor +++ b/extra/koszul/koszul.factor @@ -148,7 +148,7 @@ DEFER: (d) : nth-basis-elt ( generators n -- elt ) over length [ 3dup bit? [ nth ] [ 2drop f ] if - ] map [ ] filter 2nip ; + ] map sift 2nip ; : basis ( generators -- seq ) natural-sort dup length 2^ [ nth-basis-elt ] with map ; diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor index 52faf59c17..8582021d6d 100644 --- a/extra/lisp/lisp.factor +++ b/extra/lisp/lisp.factor @@ -26,14 +26,14 @@ DEFER: funcall unclip convert-form swap convert-body [ , % funcall ] bake ; > swap member? [ name>> make-local ] [ ] if ] - [ dup s-exp? [ body>> localize-body ] [ nip ] if ] if - ] with map ; +: localize-body ( assoc body -- assoc newbody ) + [ dup lisp-symbol? [ over dupd [ name>> ] dip at swap or ] + [ dup s-exp? [ body>> localize-body ] when ] if + ] map ; : localize-lambda ( body vars -- newbody newvars ) - dup make-locals dup push-locals [ swap localize-body convert-form ] dipd - pop-locals swap ; + make-locals dup push-locals swap + [ swap localize-body convert-form swap pop-locals ] dip swap ; PRIVATE> diff --git a/extra/lisp/parser/parser-tests.factor b/extra/lisp/parser/parser-tests.factor index 9e6b54ab0c..98a6d2a6ba 100644 --- a/extra/lisp/parser/parser-tests.factor +++ b/extra/lisp/parser/parser-tests.factor @@ -8,6 +8,14 @@ IN: lisp.parser.tests "1234" "atom" \ lisp-expr rule parse parse-result-ast ] unit-test +{ -42 } [ + "-42" "atom" \ lisp-expr rule parse parse-result-ast +] unit-test + +{ 37/52 } [ + "37/52" "atom" \ lisp-expr rule parse parse-result-ast +] unit-test + { 123.98 } [ "123.98" "atom" \ lisp-expr rule parse parse-result-ast ] unit-test diff --git a/extra/lisp/parser/parser.factor b/extra/lisp/parser/parser.factor index 65ad01aa6f..32886f9367 100644 --- a/extra/lisp/parser/parser.factor +++ b/extra/lisp/parser/parser.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 James Cash ! See http://factorcode.org/license.txt for BSD license. USING: kernel peg.ebnf peg.expr math.parser sequences arrays strings -combinators.lib ; +combinators.lib math ; IN: lisp.parser @@ -18,9 +18,11 @@ RPAREN = ")" dquote = '"' squote = "'" digit = [0-9] -integer = (digit)+ => [[ string>number ]] -float = (digit)+ "." (digit)* => [[ first3 >string [ >string ] dipd 3append string>number ]] +integer = ("-")? (digit)+ => [[ first2 append string>number ]] +float = integer "." (digit)* => [[ first3 >string [ number>string ] dipd 3append string>number ]] +rational = integer "/" (digit)+ => [[ first3 nip string>number / ]] number = float + | rational | integer id-specials = "!" | "$" | "%" | "&" | "*" | "/" | ":" | "<" | " =" | ">" | "?" | "^" | "_" | "~" | "+" | "-" | "." | "@" diff --git a/extra/logging/server/server.factor b/extra/logging/server/server.factor index 3bc8637f90..a832b10a18 100755 --- a/extra/logging/server/server.factor +++ b/extra/logging/server/server.factor @@ -37,7 +37,7 @@ SYMBOL: log-files write bl write ": " write print ; : write-message ( msg word-name level -- ) - rot [ empty? not ] filter { + rot harvest { { [ dup empty? ] [ 3drop ] } { [ dup length 1 = ] [ first -rot f (write-message) ] } [ diff --git a/extra/openssl/libssl/libssl.factor b/extra/openssl/libssl/libssl.factor index d1c53c4b23..5330a815a3 100755 --- a/extra/openssl/libssl/libssl.factor +++ b/extra/openssl/libssl/libssl.factor @@ -118,7 +118,7 @@ FUNCTION: int SSL_write ( ssl-pointer ssl, void* buf, int num ) ; FUNCTION: int SSL_read ( ssl-pointer ssl, void* buf, int num ) ; -FUNCTION: void SSL_shutdown ( ssl-pointer ssl ) ; +FUNCTION: int SSL_shutdown ( ssl-pointer ssl ) ; FUNCTION: void SSL_free ( ssl-pointer ssl ) ; diff --git a/extra/openssl/openssl.factor b/extra/openssl/openssl.factor index 3b58a606a0..6eb2d0dbda 100755 --- a/extra/openssl/openssl.factor +++ b/extra/openssl/openssl.factor @@ -5,7 +5,7 @@ math.order combinators init alien alien.c-types alien.strings libc continuations destructors debugger inspector locals unicode.case openssl.libcrypto openssl.libssl -io.nonblocking io.files io.encodings.ascii io.sockets.secure ; +io.backend io.ports io.files io.encodings.ascii io.sockets.secure ; IN: openssl ! This code is based on http://www.rtfm.com/openssl-examples/ @@ -25,8 +25,11 @@ M: TLSv1 ssl-method drop TLSv1_method ; : ssl-error-string ( -- string ) ERR_get_error ERR_clear_error f ERR_error_string ; +: (ssl-error) ( -- * ) + ssl-error-string throw ; + : ssl-error ( obj -- ) - { f 0 } member? [ ssl-error-string throw ] when ; + { f 0 } member? [ (ssl-error) ] when ; : init-ssl ( -- ) SSL_library_init ssl-error @@ -117,7 +120,7 @@ M: openssl-context dispose dup handle>> [ SSL_CTX_free ] when* f >>handle drop ; -TUPLE: ssl-handle file handle disposed ; +TUPLE: ssl-handle file handle connected disposed ; ERROR: no-ssl-context ; @@ -129,20 +132,19 @@ M: no-ssl-context summary : ( fd -- ssl ) current-ssl-context handle>> SSL_new dup ssl-error - f ssl-handle boa ; + f f ssl-handle boa ; -: ( fd -- ssl ) - [ BIO_NOCLOSE BIO_new_socket dup ssl-error ] keep - - [ handle>> swap dup SSL_set_bio ] keep ; +M: ssl-handle init-handle file>> init-handle ; -M: ssl-handle init-handle drop ; +HOOK: ssl-shutdown io-backend ( handle -- ) M: ssl-handle close-handle dup disposed>> [ drop ] [ - [ t >>disposed drop ] + t >>disposed + [ ssl-shutdown ] + [ handle>> SSL_free ] [ file>> close-handle ] - [ handle>> SSL_free ] tri + tri ] if ; ERROR: certificate-verify-error result ; diff --git a/extra/peg/search/search.factor b/extra/peg/search/search.factor index 3da676dcb2..7ab7e83d12 100755 --- a/extra/peg/search/search.factor +++ b/extra/peg/search/search.factor @@ -17,14 +17,14 @@ MEMO: any-char-parser ( -- parser ) : search ( string parser -- seq ) any-char-parser [ drop f ] action 2array choice repeat0 parse dup [ - parse-result-ast [ ] filter + parse-result-ast sift ] [ drop { } ] if ; : (replace) ( string parser -- seq ) - any-char-parser 2array choice repeat0 parse parse-result-ast [ ] filter ; + any-char-parser 2array choice repeat0 parse parse-result-ast sift ; : replace ( string parser -- result ) [ (replace) [ tree-write ] each ] with-string-writer ; diff --git a/extra/qualified/qualified.factor b/extra/qualified/qualified.factor index e48714bc44..3ce6d30819 100644 --- a/extra/qualified/qualified.factor +++ b/extra/qualified/qualified.factor @@ -23,7 +23,7 @@ IN: qualified ] curry map zip ; : partial-vocab-ignoring ( words name -- assoc ) - [ vocab-words keys swap diff ] keep partial-vocab ; + [ load-vocab vocab-words keys swap diff ] keep partial-vocab ; : EXCLUDE: #! Syntax: EXCLUDE: vocab => words ... ; @@ -32,12 +32,12 @@ IN: qualified : FROM: #! Syntax: FROM: vocab => words... ; - scan expect=> + scan dup load-vocab drop expect=> ";" parse-tokens swap partial-vocab use get push ; parsing : RENAME: #! Syntax: RENAME: word vocab => newname - scan scan lookup [ "No such word" throw ] unless* + scan scan dup load-vocab drop lookup [ "No such word" throw ] unless* expect=> scan associate use get push ; parsing diff --git a/extra/random/unix/unix.factor b/extra/random/unix/unix.factor index 7fda7c5d1d..e534691ecd 100644 --- a/extra/random/unix/unix.factor +++ b/extra/random/unix/unix.factor @@ -1,4 +1,4 @@ -USING: alien.c-types io io.files io.nonblocking kernel +USING: alien.c-types io io.files io.ports kernel namespaces random io.encodings.binary init accessors system ; IN: random.unix diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index 0dc5601cd0..b703bb55a0 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -216,7 +216,7 @@ USE: continuations >r dup length swap r> [ = [ ] [ drop f ] if ] curry 2map - [ ] filter ; + sift ; vocab-author : vocab-xref ( vocab quot -- vocabs ) >r dup vocab-name swap words r> map [ [ word? ] filter [ word-vocabulary ] map ] map>set - remove [ ] filter [ vocab ] map ; inline + remove sift [ vocab ] map ; inline : vocab-uses ( vocab -- vocabs ) [ uses ] vocab-xref ; diff --git a/extra/ui/gadgets/tracks/tracks.factor b/extra/ui/gadgets/tracks/tracks.factor index 56a0fbc3ee..cf97bedb8d 100644 --- a/extra/ui/gadgets/tracks/tracks.factor +++ b/extra/ui/gadgets/tracks/tracks.factor @@ -8,7 +8,7 @@ TUPLE: track sizes ; : normalized-sizes ( track -- seq ) track-sizes - [ [ ] filter sum ] keep [ dup [ over / ] when ] map nip ; + [ sift sum ] keep [ dup [ over / ] when ] map nip ; : ( orientation -- track ) V{ } clone diff --git a/extra/ui/tools/tools-tests.factor b/extra/ui/tools/tools-tests.factor index 6d22083096..47b0d51705 100755 --- a/extra/ui/tools/tools-tests.factor +++ b/extra/ui/tools/tools-tests.factor @@ -17,7 +17,7 @@ IN: ui.tools.tests [ ] [ "w" get com-scroll-down ] unit-test [ t ] [ "w" get workspace-book gadget-children - [ tool-scroller ] map [ ] filter [ scroller? ] all? + [ tool-scroller ] map sift [ scroller? ] all? ] unit-test [ ] [ "w" get hide-popup ] unit-test [ ] [ "w" get show-popup ] unit-test diff --git a/extra/unicode/breaks/breaks.factor b/extra/unicode/breaks/breaks.factor index dfac27f7a4..53f81ccbf9 100755 --- a/extra/unicode/breaks/breaks.factor +++ b/extra/unicode/breaks/breaks.factor @@ -24,8 +24,7 @@ CATEGORY: grapheme-control Zl Zp Cc Cf ; [ blank? ] right-trim ; : process-other-extend ( lines -- set ) - [ "#" split1 drop ";" split1 drop trim-blank ] map - [ empty? not ] filter + [ "#" split1 drop ";" split1 drop trim-blank ] map harvest [ ".." split1 [ dup ] unless* [ hex> ] bi@ [a,b] ] map concat unique ; diff --git a/extra/unicode/data/data.factor b/extra/unicode/data/data.factor index 52706647a9..b411e4e209 100755 --- a/extra/unicode/data/data.factor +++ b/extra/unicode/data/data.factor @@ -89,7 +89,7 @@ IN: unicode.data ] assoc-map >hashtable ; : multihex ( hexstring -- string ) - " " split [ hex> ] map [ ] filter ; + " " split [ hex> ] map sift ; TUPLE: code-point lower title upper ; diff --git a/extra/unicode/script/script.factor b/extra/unicode/script/script.factor index 846f797f71..2d07ba2caa 100755 --- a/extra/unicode/script/script.factor +++ b/extra/unicode/script/script.factor @@ -10,7 +10,7 @@ SYMBOL: interned : parse-script ( stream -- assoc ) ! assoc is code point/range => name - lines [ "#" split1 drop ] map [ empty? not ] filter [ + lines [ "#" split1 drop ] map harvest [ ";" split1 [ [ blank? ] trim ] bi@ ] H{ } map>assoc ; diff --git a/extra/unix/linux/ifreq/ifreq.factor b/extra/unix/linux/ifreq/ifreq.factor index d688153bd0..5dc1c0fde2 100755 --- a/extra/unix/linux/ifreq/ifreq.factor +++ b/extra/unix/linux/ifreq/ifreq.factor @@ -1,7 +1,6 @@ USING: kernel alien alien.c-types io.sockets - io.sockets.impl unix unix.linux.sockios unix.linux.if ; diff --git a/extra/unix/linux/route/route.factor b/extra/unix/linux/route/route.factor index c4eeadb69e..4d9bbfae99 100644 --- a/extra/unix/linux/route/route.factor +++ b/extra/unix/linux/route/route.factor @@ -42,7 +42,7 @@ C-STRUCT: struct-rtentry ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -USING: kernel alien.c-types io.sockets io.sockets.impl +USING: kernel alien.c-types io.sockets unix unix.linux.sockios ; : route ( dst gateway genmask flags -- ) diff --git a/extra/unix/process/process.factor b/extra/unix/process/process.factor index 0abefe14f1..644276ef7d 100755 --- a/extra/unix/process/process.factor +++ b/extra/unix/process/process.factor @@ -1,12 +1,20 @@ -USING: kernel alien.c-types alien.strings sequences math unix -vectors kernel namespaces continuations threads assocs vectors -io.unix.backend io.encodings.utf8 ; +USING: kernel alien.c-types alien.strings sequences math alien.syntax unix + vectors kernel namespaces continuations threads assocs vectors + io.unix.backend io.encodings.utf8 ; IN: unix.process ! Low-level Unix process launching utilities. These are used ! to implement io.launcher on Unix. User code should use ! io.launcher instead. +FUNCTION: pid_t fork ( ) ; + +: fork-process ( -- pid ) [ fork ] unix-system-call ; + +FUNCTION: int execv ( char* path, char** argv ) ; +FUNCTION: int execvp ( char* path, char** argv ) ; +FUNCTION: int execve ( char* path, char** argv, char** envp ) ; + : >argv ( seq -- alien ) [ utf8 malloc-string ] map f suffix >c-void*-array ; @@ -29,10 +37,65 @@ IN: unix.process >r [ first ] [ ] bi r> exec-with-env ; : with-fork ( child parent -- ) - fork dup io-error dup zero? -roll swap curry if ; inline + fork-process dup zero? -roll swap curry if ; inline -: wait-for-pid ( pid -- status ) - 0 [ 0 waitpid drop ] keep *int WEXITSTATUS ; +: SIGKILL 9 ; inline +: SIGTERM 15 ; inline + +FUNCTION: int kill ( pid_t pid, int sig ) ; + +: PRIO_PROCESS 0 ; inline +: PRIO_PGRP 1 ; inline +: PRIO_USER 2 ; inline + +: PRIO_MIN -20 ; inline +: PRIO_MAX 20 ; inline + +! which/who = 0 for current process +FUNCTION: int getpriority ( int which, int who ) ; +FUNCTION: int setpriority ( int which, int who, int prio ) ; : set-priority ( n -- ) - 0 0 rot setpriority io-error ; \ No newline at end of file + 0 0 rot setpriority io-error ; + +! Flags for waitpid + +: WNOHANG 1 ; inline +: WUNTRACED 2 ; inline + +: WSTOPPED 2 ; inline +: WEXITED 4 ; inline +: WCONTINUED 8 ; inline +: WNOWAIT HEX: 1000000 ; inline + +! Examining status + +: WTERMSIG ( status -- value ) + HEX: 7f bitand ; inline + +: WIFEXITED ( status -- ? ) + WTERMSIG zero? ; inline + +: WEXITSTATUS ( status -- value ) + HEX: ff00 bitand -8 shift ; inline + +: WIFSIGNALED ( status -- ? ) + HEX: 7f bitand 1+ -1 shift 0 > ; inline + +: WCOREFLAG ( -- value ) + HEX: 80 ; inline + +: WCOREDUMP ( status -- ? ) + WCOREFLAG bitand zero? not ; inline + +: WIFSTOPPED ( status -- ? ) + HEX: ff bitand HEX: 7f = ; inline + +: WSTOPSIG ( status -- value ) + WEXITSTATUS ; inline + +FUNCTION: pid_t wait ( int* status ) ; +FUNCTION: pid_t waitpid ( pid_t wpid, int* status, int options ) ; + +: wait-for-pid ( pid -- status ) + 0 [ 0 waitpid drop ] keep *int WEXITSTATUS ; \ No newline at end of file diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor index 71e8dba8e6..9a7d405546 100755 --- a/extra/unix/unix.factor +++ b/extra/unix/unix.factor @@ -2,9 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.syntax kernel libc structs sequences - continuations + continuations byte-arrays strings math namespaces system combinators vocabs.loader qualified - accessors inference macros fry arrays.lib + accessors inference macros locals shuffle arrays.lib unix.types ; IN: unix @@ -50,32 +50,40 @@ LIBRARY: factor FUNCTION: void clear_err_no ( ) ; FUNCTION: int err_no ( ) ; -ERROR: unix-system-call-error word args message ; - -DEFER: strerror - -MACRO: unix-system-call ( quot -- ) - [ ] [ infer in>> ] [ first ] tri - '[ - [ @ dup 0 < [ dup throw ] [ ] if ] - [ drop , narray , swap err_no strerror unix-system-call-error ] - recover - ] ; - LIBRARY: libc +ERROR: unix-system-call-error args message word ; + +FUNCTION: char* strerror ( int errno ) ; + +MACRO:: unix-system-call ( quot -- ) + [let | n [ quot infer in>> ] + word [ quot first ] | + [ + n ndup quot call dup 0 < [ + drop + n narray + err_no strerror + word unix-system-call-error + ] [ + n nnip + ] if + ] + ] ; + FUNCTION: int accept ( int s, void* sockaddr, socklen_t* socklen ) ; FUNCTION: int bind ( int s, void* name, socklen_t namelen ) ; FUNCTION: int chdir ( char* path ) ; FUNCTION: int chown ( char* path, uid_t owner, gid_t group ) ; FUNCTION: int chroot ( char* path ) ; -FUNCTION: void close ( int fd ) ; + +FUNCTION: int close ( int fd ) ; + +: close-file ( fd -- ) [ close ] unix-system-call drop ; + FUNCTION: int connect ( int s, void* name, socklen_t namelen ) ; FUNCTION: int dup2 ( int oldd, int newd ) ; ! FUNCTION: int dup ( int oldd ) ; -FUNCTION: int execv ( char* path, char** argv ) ; -FUNCTION: int execvp ( char* path, char** argv ) ; -FUNCTION: int execve ( char* path, char** argv, char** envp ) ; : _exit ( status -- * ) #! We throw to give this a terminating stack effect. "int" f "_exit" { "int" } alien-invoke "Exit failed" throw ; @@ -83,7 +91,6 @@ FUNCTION: int fchdir ( int fd ) ; FUNCTION: int fchown ( int fd, uid_t owner, gid_t group ) ; FUNCTION: int fcntl ( int fd, int cmd, int arg ) ; FUNCTION: int flock ( int fd, int operation ) ; -FUNCTION: pid_t fork ( ) ; FUNCTION: void freeaddrinfo ( addrinfo* ai ) ; FUNCTION: int futimes ( int id, timeval[2] times ) ; FUNCTION: char* gai_strerror ( int ecode ) ; @@ -100,6 +107,7 @@ FUNCTION: int getpwnam_r ( char* login, passwd* pwd, char* buffer, size_t bufsiz FUNCTION: int getgroups ( int gidsetlen, gid_t* gidset ) ; FUNCTION: int gethostname ( char* name, int len ) ; FUNCTION: int getsockname ( int socket, sockaddr* address, socklen_t* address_len ) ; +FUNCTION: int getpeername ( int socket, sockaddr* address, socklen_t* address_len ) ; FUNCTION: uid_t getuid ; FUNCTION: uint htonl ( uint n ) ; FUNCTION: ushort htons ( ushort n ) ; @@ -135,7 +143,17 @@ FUNCTION: int pclose ( void* file ) ; FUNCTION: int pipe ( int* filedes ) ; FUNCTION: void* popen ( char* command, char* type ) ; FUNCTION: ssize_t read ( int fd, void* buf, size_t nbytes ) ; + FUNCTION: ssize_t readlink ( char* path, char* buf, size_t bufsize ) ; + +: PATH_MAX 1024 ; inline + +: read-symbolic-link ( path -- path ) + PATH_MAX dup >r + PATH_MAX + [ readlink ] unix-system-call + r> swap head-slice >string ; + FUNCTION: ssize_t recv ( int s, void* buf, size_t nbytes, int flags ) ; FUNCTION: ssize_t recvfrom ( int s, void* buf, size_t nbytes, int flags, sockaddr-in* from, socklen_t* fromlen ) ; FUNCTION: int rename ( char* from, char* to ) ; @@ -151,69 +169,15 @@ FUNCTION: int setreuid ( uid_t ruid, uid_t euid ) ; FUNCTION: int setsockopt ( int s, int level, int optname, void* optval, socklen_t optlen ) ; FUNCTION: int setuid ( uid_t uid ) ; FUNCTION: int socket ( int domain, int type, int protocol ) ; -FUNCTION: char* strerror ( int errno ) ; FUNCTION: int symlink ( char* path1, char* path2 ) ; FUNCTION: int system ( char* command ) ; + FUNCTION: int unlink ( char* path ) ; + +: unlink-file ( path -- ) [ unlink ] unix-system-call drop ; + FUNCTION: int utimes ( char* path, timeval[2] times ) ; -: SIGKILL 9 ; inline -: SIGTERM 15 ; inline - -FUNCTION: int kill ( pid_t pid, int sig ) ; - -: PATH_MAX 1024 ; inline - -: PRIO_PROCESS 0 ; inline -: PRIO_PGRP 1 ; inline -: PRIO_USER 2 ; inline - -: PRIO_MIN -20 ; inline -: PRIO_MAX 20 ; inline - -! which/who = 0 for current process -FUNCTION: int getpriority ( int which, int who ) ; -FUNCTION: int setpriority ( int which, int who, int prio ) ; - -! Flags for waitpid - -: WNOHANG 1 ; inline -: WUNTRACED 2 ; inline - -: WSTOPPED 2 ; inline -: WEXITED 4 ; inline -: WCONTINUED 8 ; inline -: WNOWAIT HEX: 1000000 ; inline - -! Examining status - -: WTERMSIG ( status -- value ) - HEX: 7f bitand ; inline - -: WIFEXITED ( status -- ? ) - WTERMSIG zero? ; inline - -: WEXITSTATUS ( status -- value ) - HEX: ff00 bitand -8 shift ; inline - -: WIFSIGNALED ( status -- ? ) - HEX: 7f bitand 1+ -1 shift 0 > ; inline - -: WCOREFLAG ( -- value ) - HEX: 80 ; inline - -: WCOREDUMP ( status -- ? ) - WCOREFLAG bitand zero? not ; inline - -: WIFSTOPPED ( status -- ? ) - HEX: ff bitand HEX: 7f = ; inline - -: WSTOPSIG ( status -- value ) - WEXITSTATUS ; inline - -FUNCTION: pid_t wait ( int* status ) ; -FUNCTION: pid_t waitpid ( pid_t wpid, int* status, int options ) ; - FUNCTION: ssize_t write ( int fd, void* buf, size_t nbytes ) ; { diff --git a/extra/windows/com/syntax/syntax.factor b/extra/windows/com/syntax/syntax.factor index b3c803be2d..b63a5c3337 100755 --- a/extra/windows/com/syntax/syntax.factor +++ b/extra/windows/com/syntax/syntax.factor @@ -45,8 +45,7 @@ unless ; : parse-com-functions ( -- functions ) - ";" parse-tokens { ")" } split - [ empty? not ] filter + ";" parse-tokens { ")" } split harvest [ (parse-com-function) ] map ; : (iid-word) ( definition -- word ) diff --git a/extra/wrap/wrap.factor b/extra/wrap/wrap.factor index 9b1eeede96..29a8bbf10f 100644 --- a/extra/wrap/wrap.factor +++ b/extra/wrap/wrap.factor @@ -8,7 +8,7 @@ IN: wrap SYMBOL: width : line-chunks ( string -- words-lines ) - "\n" split [ " \t" split [ empty? not ] filter ] map ; + "\n" split [ " \t" split harvest ] map ; : (split-chunk) ( words -- ) -1 over [ length + 1+ dup width get > ] find drop nip