diff --git a/core/graphs/graphs-docs.factor b/core/graphs/graphs-docs.factor index 1e4350d58c..f16f8cca3b 100644 --- a/core/graphs/graphs-docs.factor +++ b/core/graphs/graphs-docs.factor @@ -21,12 +21,12 @@ HELP: graph HELP: add-vertex { $values { "vertex" object } { "edges" "a sequence" } { "graph" "an assoc mapping vertices to sequences of edges" } } -{ $description "Adds a vertex to a directed graph, using the " { $snippet "edges" } " quotation to generate a sequence of edges leaving the vertex." } +{ $description "Adds a vertex to a directed graph, with " { $snippet "edges" } " as the outward edges from the vertex." } { $side-effects "graph" } ; HELP: remove-vertex { $values { "vertex" object } { "edges" "a sequence" } { "graph" "an assoc mapping vertices to sequences of edges" } } -{ $description "Removes a vertex from a graph, using the quotation to generate a sequence of edges leaving the vertex." } +{ $description "Removes a vertex from a graph, using the given edges sequence." } { $notes "The " { $snippet "edges" } " sequence must equal the value passed to " { $link add-vertex } ", otherwise some vertices of the graph may continue to refer to the removed vertex." } { $side-effects "graph" } ; diff --git a/extra/cocoa/application/application.factor b/extra/cocoa/application/application.factor index 0cf020a087..129b949b1d 100755 --- a/extra/cocoa/application/application.factor +++ b/extra/cocoa/application/application.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2006, 2007 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: alien io kernel namespaces core-foundation cocoa.messages -cocoa cocoa.classes cocoa.runtime sequences threads -debugger init inspector kernel.private ; +USING: alien io kernel namespaces core-foundation +core-foundation.run-loop cocoa.messages cocoa cocoa.classes +cocoa.runtime sequences threads debugger init inspector +kernel.private ; IN: cocoa.application : ( str -- alien ) -> autorelease ; @@ -21,8 +22,6 @@ IN: cocoa.application : with-cocoa ( quot -- ) [ NSApp drop call ] with-autorelease-pool ; -: CFRunLoopDefaultMode "kCFRunLoopDefaultMode" ; - : next-event ( app -- event ) 0 f CFRunLoopDefaultMode 1 -> nextEventMatchingMask:untilDate:inMode:dequeue: ; diff --git a/extra/core-foundation/core-foundation.factor b/extra/core-foundation/core-foundation.factor index 73b8fce229..77ad30ad8f 100644 --- a/extra/core-foundation/core-foundation.factor +++ b/extra/core-foundation/core-foundation.factor @@ -9,9 +9,9 @@ TYPEDEF: void* CFBundleRef TYPEDEF: void* CFStringRef TYPEDEF: void* CFURLRef TYPEDEF: void* CFUUIDRef -TYPEDEF: void* CFRunLoopRef TYPEDEF: bool Boolean TYPEDEF: int CFIndex +TYPEDEF: int SInt32 TYPEDEF: double CFTimeInterval TYPEDEF: double CFAbsoluteTime @@ -85,5 +85,3 @@ FUNCTION: void CFRelease ( void* cf ) ; ] [ "Cannot load bundled named " prepend throw ] ?if ; - -FUNCTION: CFRunLoopRef CFRunLoopGetMain ( ) ; diff --git a/extra/core-foundation/fsevents/fsevents.factor b/extra/core-foundation/fsevents/fsevents.factor index f181d8a761..24211a59c7 100644 --- a/extra/core-foundation/fsevents/fsevents.factor +++ b/extra/core-foundation/fsevents/fsevents.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.syntax kernel math sequences -namespaces assocs init continuations core-foundation ; +namespaces assocs init accessors continuations combinators +core-foundation core-foundation.run-loop ; IN: core-foundation.fsevents ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! @@ -182,11 +183,11 @@ SYMBOL: event-stream-callbacks } "cdecl" [ [ >event-triple ] 3curry map - swap event-stream-callbacks get at call - drop + swap event-stream-callbacks get at + dup [ call drop ] [ 3drop ] if ] alien-callback ; -TUPLE: event-stream info handle ; +TUPLE: event-stream info handle closed ; : ( quot paths latency flags -- event-stream ) >r >r >r @@ -194,9 +195,15 @@ TUPLE: event-stream info handle ; >r master-event-source-callback r> r> r> r> dup enable-event-stream - event-stream construct-boa ; + f event-stream construct-boa ; M: event-stream dispose - dup event-stream-info remove-event-source-callback - event-stream-handle dup disable-event-stream - FSEventStreamRelease ; + dup closed>> [ drop ] [ + t >>closed + { + [ info>> remove-event-source-callback ] + [ handle>> disable-event-stream ] + [ handle>> FSEventStreamInvalidate ] + [ handle>> FSEventStreamRelease ] + } cleave + ] if ; diff --git a/extra/core-foundation/run-loop/run-loop.factor b/extra/core-foundation/run-loop/run-loop.factor new file mode 100644 index 0000000000..7594766635 --- /dev/null +++ b/extra/core-foundation/run-loop/run-loop.factor @@ -0,0 +1,38 @@ +! Copyright (C) 2008 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: alien.syntax kernel threads init namespaces alien +core-foundation ; +IN: core-foundation.run-loop + +: kCFRunLoopRunFinished 1 ; inline +: kCFRunLoopRunStopped 2 ; inline +: kCFRunLoopRunTimedOut 3 ; inline +: kCFRunLoopRunHandledSource 4 ; inline + +TYPEDEF: void* CFRunLoopRef + +FUNCTION: CFRunLoopRef CFRunLoopGetMain ( ) ; + +FUNCTION: SInt32 CFRunLoopRunInMode ( + CFStringRef mode, + CFTimeInterval seconds, + Boolean returnAfterSourceHandled +) ; + +: CFRunLoopDefaultMode ( -- alien ) + #! Ugly, but we don't have static NSStrings + \ CFRunLoopDefaultMode get-global dup expired? [ + drop + "kCFRunLoopDefaultMode" + dup \ CFRunLoopDefaultMode set-global + ] when ; + +: run-loop-thread ( -- ) + CFRunLoopDefaultMode 0 f CFRunLoopRunInMode + kCFRunLoopRunHandledSource = [ 1000 sleep ] unless + run-loop-thread ; + +: start-run-loop-thread ( -- ) + [ run-loop-thread t ] "CFRunLoop dispatcher" spawn-server drop ; + +[ start-run-loop-thread ] "core-foundation.run-loop" add-init-hook diff --git a/extra/help/cookbook/cookbook.factor b/extra/help/cookbook/cookbook.factor index f1d4ac4ca7..9b21bf7fff 100755 --- a/extra/help/cookbook/cookbook.factor +++ b/extra/help/cookbook/cookbook.factor @@ -199,7 +199,7 @@ ARTICLE: "cookbook-io" "Input and output cookbook" } "Convert a file of 4-byte cells from little to big endian or vice versa, by directly mapping it into memory and operating on it with sequence words:" { $code - "\"mydata.dat\" dup file-info file-info-length [" + "\"mydata.dat\" dup file-info size>> [" " 4 [ reverse-here ] change-each" "] with-mapped-file" } diff --git a/extra/http/server/static/static.factor b/extra/http/server/static/static.factor index 905c7320ca..8632e0f139 100755 --- a/extra/http/server/static/static.factor +++ b/extra/http/server/static/static.factor @@ -10,7 +10,7 @@ IN: http.server.static TUPLE: file-responder root hook special ; : file-http-date ( filename -- string ) - file-info file-info-modified timestamp>http-string ; + file-info modified>> timestamp>http-string ; : last-modified-matches? ( filename -- ? ) file-http-date dup [ @@ -27,7 +27,7 @@ TUPLE: file-responder root hook special ; [ swap - [ file-info file-info-size "content-length" set-header ] + [ file-info size>> "content-length" set-header ] [ file-http-date "last-modified" set-header ] [ '[ , binary stdio get stream-copy ] >>body ] tri diff --git a/extra/inverse/inverse-tests.factor b/extra/inverse/inverse-tests.factor index 31e7c5f78a..101637e4e8 100644 --- a/extra/inverse/inverse-tests.factor +++ b/extra/inverse/inverse-tests.factor @@ -1,5 +1,5 @@ USING: inverse tools.test arrays math kernel sequences -math.functions math.constants ; +math.functions math.constants continuations ; IN: inverse-tests [ 2 ] [ { 3 2 } [ 3 swap 2array ] undo ] unit-test @@ -51,7 +51,7 @@ C: nil { { [ ] [ list-sum + ] } { [ ] [ 0 ] } - { [ ] [ "Malformed list" throw ] } + [ "Malformed list" throw ] } switch ; [ 10 ] [ 1 2 3 4 list-sum ] unit-test @@ -59,6 +59,7 @@ C: nil [ 1 2 ] [ 1 2 [ ] undo ] unit-test [ t ] [ 1 2 [ ] matches? ] unit-test [ f ] [ 1 2 [ ] matches? ] unit-test +[ "Malformed list" ] [ [ f list-sum ] [ ] recover ] unit-test : empty-cons ( -- cons ) cons construct-empty ; : cons* ( cdr car -- cons ) { set-cons-cdr set-cons-car } cons construct ; @@ -68,3 +69,4 @@ C: nil [ t ] [ pi [ pi ] matches? ] unit-test [ 0.0 ] [ 0.0 pi + [ pi + ] undo ] unit-test +[ ] [ 3 [ _ ] undo ] unit-test diff --git a/extra/inverse/inverse.factor b/extra/inverse/inverse.factor index 1b7badd94a..9c94c86ce9 100755 --- a/extra/inverse/inverse.factor +++ b/extra/inverse/inverse.factor @@ -60,11 +60,13 @@ PREDICATE: math-inverse < word "math-inverse" word-prop ; PREDICATE: pop-inverse < word "pop-length" word-prop ; UNION: explicit-inverse normal-inverse math-inverse pop-inverse ; -: enough? ( stack quot -- ? ) - [ >r length r> 1quotation infer effect-in >= ] [ 3drop f ] - recover ; +: enough? ( stack word -- ? ) + dup deferred? [ 2drop f ] [ + [ >r length r> 1quotation infer effect-in >= ] + [ 3drop f ] recover + ] if ; -: fold-word ( stack quot -- stack ) +: fold-word ( stack word -- stack ) 2dup enough? [ 1quotation with-datastack ] [ >r % r> , { } ] if ; @@ -72,10 +74,10 @@ UNION: explicit-inverse normal-inverse math-inverse pop-inverse ; [ { } swap [ fold-word ] each % ] [ ] make ; : flattenable? ( object -- ? ) - [ [ word? ] [ primitive? not ] and? ] [ + { [ word? ] [ primitive? not ] [ { "inverse" "math-inverse" "pop-inverse" } [ word-prop ] with contains? not - ] and? ; + ] } <-&& ; : (flatten) ( quot -- ) [ dup flattenable? [ word-def (flatten) ] [ , ] if ] each ; @@ -159,7 +161,7 @@ MACRO: undo ( quot -- ) [undo] ; 2curry ] define-pop-inverse -: _ f ; +DEFER: _ \ _ [ drop ] define-inverse : both ( object object -- object ) @@ -256,6 +258,7 @@ M: no-match summary drop "Fall through in switch" ; [ no-match ] [ swap \ recover-fail 3array >quotation ] reduce ; : [switch] ( quot-alist -- quot ) + [ dup quotation? [ [ ] swap 2array ] when ] map reverse [ >r [undo] r> compose ] { } assoc>map recover-chain ; diff --git a/extra/io/encodings/8-bit/8-bit.factor b/extra/io/encodings/8-bit/8-bit.factor index 259173fec4..04e8ee8569 100755 --- a/extra/io/encodings/8-bit/8-bit.factor +++ b/extra/io/encodings/8-bit/8-bit.factor @@ -29,9 +29,10 @@ IN: io.encodings.8-bit { "mac-roman" "ROMAN" } } ; -: full-path ( file-name -- path ) +: encoding-file ( file-name -- stream ) "extra/io/encodings/8-bit/" ".TXT" - swapd 3append resource-path ; + swapd 3append resource-path + ascii ; : tail-if ( seq n -- newseq ) 2dup swap length <= [ tail ] [ drop ] if ; @@ -48,8 +49,8 @@ IN: io.encodings.8-bit : ch>byte ( assoc -- newassoc ) [ swap ] assoc-map >hashtable ; -: parse-file ( file-name -- byte>ch ch>byte ) - ascii file-lines process-contents +: parse-file ( path -- byte>ch ch>byte ) + lines process-contents [ byte>ch ] [ ch>byte ] bi ; TUPLE: 8-bit name decode encode ; @@ -71,13 +72,13 @@ M: 8-bit decode-char : make-8-bit ( word byte>ch ch>byte -- ) [ 8-bit construct-boa ] 2curry dupd curry define ; -: define-8-bit-encoding ( name path -- ) +: define-8-bit-encoding ( name stream -- ) >r in get create r> parse-file make-8-bit ; PRIVATE> [ "io.encodings.8-bit" in [ - mappings [ full-path define-8-bit-encoding ] assoc-each + mappings [ encoding-file define-8-bit-encoding ] assoc-each ] with-variable ] with-compilation-unit diff --git a/extra/io/launcher/launcher-docs.factor b/extra/io/launcher/launcher-docs.factor index 0f6ca3a2c9..4446b82f20 100755 --- a/extra/io/launcher/launcher-docs.factor +++ b/extra/io/launcher/launcher-docs.factor @@ -129,9 +129,6 @@ HELP: { $values { "process" process } } { $description "Creates a new, empty process. It must be filled in before being passed to " { $link run-process } "." } ; -HELP: process-stream -{ $class-description "A bidirectional stream for interacting with a running process. Instances are created by calling " { $link } ". The " { $link process-stream-process } " slot holds a " { $link process } " instance." } ; - HELP: { $values { "desc" "a launch descriptor" } @@ -144,7 +141,7 @@ HELP: with-process-stream { "desc" "a launch descriptor" } { "quot" quotation } { "status" "an exit code" } } -{ $description "Calls " { $snippet "quot" } " in a dynamic scope where " { $link stdio } " is rebound to a " { $link process-stream } ". After the quotation returns, waits for the process to end and outputs the exit code." } ; +{ $description "Calls " { $snippet "quot" } " in a dynamic scope where " { $link stdio } " is rebound to a process stream. After the quotation returns, waits for the process to end and outputs the exit code." } ; HELP: wait-for-process { $values { "process" process } { "status" integer } } diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index fa4bdcaaea..00352adc7b 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -150,18 +150,18 @@ M: process timed-out kill-process ; HOOK: (process-stream) io-backend ( process -- handle in out ) -TUPLE: process-stream process ; +: ( desc encoding -- stream process ) + >r >process dup dup (process-stream) + r> -roll + process-started ; : ( desc encoding -- stream ) - >r >process dup dup (process-stream) - >r >r process-started process-stream construct-boa - r> r> r> - over set-delegate ; + drop ; inline : with-process-stream ( desc quot -- status ) - swap + swap >r [ swap with-stream ] keep - process>> wait-for-process ; inline + r> wait-for-process ; inline : notify-exit ( process status -- ) >>status diff --git a/extra/io/mmap/mmap-tests.factor b/extra/io/mmap/mmap-tests.factor index b17d7aeab9..a00f7cd92b 100755 --- a/extra/io/mmap/mmap-tests.factor +++ b/extra/io/mmap/mmap-tests.factor @@ -1,10 +1,10 @@ USING: io io.mmap io.files kernel tools.test continuations -sequences io.encodings.ascii ; +sequences io.encodings.ascii accessors ; IN: io.mmap.tests [ "mmap-test-file.txt" resource-path delete-file ] ignore-errors [ ] [ "12345" "mmap-test-file.txt" resource-path ascii set-file-contents ] unit-test -[ ] [ "mmap-test-file.txt" resource-path dup file-info file-info-size [ CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test -[ 5 ] [ "mmap-test-file.txt" resource-path dup file-info file-info-size [ length ] with-mapped-file ] unit-test +[ ] [ "mmap-test-file.txt" resource-path dup file-info size>> [ CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test +[ 5 ] [ "mmap-test-file.txt" resource-path dup file-info size>> [ length ] with-mapped-file ] unit-test [ "22345" ] [ "mmap-test-file.txt" resource-path ascii file-contents ] unit-test [ "mmap-test-file.txt" resource-path delete-file ] ignore-errors diff --git a/extra/io/monitors/monitors-tests.factor b/extra/io/monitors/monitors-tests.factor index 0216baf699..ab919dd008 100644 --- a/extra/io/monitors/monitors-tests.factor +++ b/extra/io/monitors/monitors-tests.factor @@ -75,13 +75,13 @@ os { winnt linux macosx } member? [ [ ] [ "monitor-test/xyz/test.txt" temp-file touch-file ] unit-test - [ ] [ "c1" get 5 seconds await-timeout ] unit-test + [ ] [ "c1" get 15 seconds await-timeout ] unit-test [ ] [ "monitor-test/subdir/blah/yxy" temp-file make-directories ] unit-test [ ] [ "monitor-test/subdir/blah/yxy/test.txt" temp-file touch-file ] unit-test - [ ] [ "c2" get 5 seconds await-timeout ] unit-test + [ ] [ "c2" get 15 seconds await-timeout ] unit-test ! Dispose twice [ ] [ "m" get dispose ] unit-test diff --git a/extra/io/nonblocking/nonblocking-docs.factor b/extra/io/nonblocking/nonblocking-docs.factor index ee9978f2c8..78bf0ba921 100755 --- a/extra/io/nonblocking/nonblocking-docs.factor +++ b/extra/io/nonblocking/nonblocking-docs.factor @@ -36,10 +36,10 @@ HELP: port $nl "Ports have the following slots:" { $list - { { $link port-handle } " - a native handle identifying the underlying native resource used by the port" } - { { $link port-error } " - the most recent I/O error, if any. This error is thrown to the waiting thread when " { $link pending-error } " is called by stream operations" } - { { $link port-type } " - a symbol identifying the port's intended purpose" } - { { $link port-eof? } " - a flag indicating if the port has reached the end of file while reading" } + { { $snippet "handle" } " - a native handle identifying the underlying native resource used by the port" } + { { $snippet "error" } " - the most recent I/O error, if any. This error is thrown to the waiting thread when " { $link pending-error } " is called by stream operations" } + { { $snippet "type" } " - a symbol identifying the port's intended purpose" } + { { $snippet "eof" } " - a flag indicating if the port has reached the end of file while reading" } } } ; HELP: input-port @@ -53,8 +53,8 @@ HELP: init-handle { $contract "Prepares a native handle for use by the port; called by " { $link } "." } ; HELP: -{ $values { "handle" "a native handle identifying an I/O resource" } { "buffer" "a " { $link buffer } " or " { $link f } } { "type" symbol } { "port" "a new " { $link port } } } -{ $description "Creates a new " { $link port } " using the specified native handle and I/O buffer." } +{ $values { "handle" "a native handle identifying an I/O resource" } { "type" symbol } { "port" "a new " { $link port } } } +{ $description "Creates a new " { $link port } " with no buffer." } $low-level-note ; HELP: diff --git a/extra/io/nonblocking/nonblocking.factor b/extra/io/nonblocking/nonblocking.factor index 85319ad8ef..048a5d7b1c 100755 --- a/extra/io/nonblocking/nonblocking.factor +++ b/extra/io/nonblocking/nonblocking.factor @@ -1,46 +1,39 @@ ! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman ! See http://factorcode.org/license.txt for BSD license. -IN: io.nonblocking USING: math kernel io sequences io.buffers io.timeouts generic byte-vectors system io.streams.duplex io.encodings io.backend continuations debugger classes byte-arrays namespaces -splitting dlists assocs io.encodings.binary ; +splitting dlists assocs io.encodings.binary accessors ; +IN: io.nonblocking SYMBOL: default-buffer-size 64 1024 * default-buffer-size set-global -! Common delegate of native stream readers and writers -TUPLE: port -handle -error -timeout -type eof? ; +TUPLE: port handle buffer error timeout closed eof ; -M: port timeout port-timeout ; +M: port timeout timeout>> ; -M: port set-timeout set-port-timeout ; - -SYMBOL: closed - -PREDICATE: input-port < port port-type input-port eq? ; -PREDICATE: output-port < port port-type output-port eq? ; +M: port set-timeout (>>timeout) ; GENERIC: init-handle ( handle -- ) + GENERIC: close-handle ( handle -- ) -: ( handle buffer type -- port ) - pick init-handle { - set-port-handle - set-delegate - set-port-type - } port construct ; +: ( handle class -- port ) + construct-empty + swap dup init-handle >>handle ; inline -: ( handle type -- port ) - default-buffer-size get swap ; +: ( 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 ; @@ -48,7 +41,10 @@ GENERIC: close-handle ( handle -- ) swap [ swap ] [ ] [ dispose drop ] cleanup ; : pending-error ( port -- ) - dup port-error f rot set-port-error [ throw ] when* ; + [ f ] change-error drop [ throw ] when* ; + +: check-closed ( port -- port ) + dup closed>> [ "Port closed" throw ] when ; HOOK: cancel-io io-backend ( port -- ) @@ -59,21 +55,22 @@ M: port timed-out cancel-io ; GENERIC: (wait-to-read) ( port -- ) : wait-to-read ( count port -- ) - tuck buffer-length > [ (wait-to-read) ] [ drop ] if ; + tuck buffer>> buffer-length > [ (wait-to-read) ] [ drop ] if ; : wait-to-read1 ( port -- ) 1 swap wait-to-read ; : unless-eof ( port quot -- value ) - >r dup buffer-empty? over port-eof? and - [ f swap set-port-eof? f ] r> if ; inline + >r dup buffer>> buffer-empty? over eof>> and + [ f >>eof drop f ] r> if ; inline M: input-port stream-read1 - dup wait-to-read1 [ buffer-pop ] unless-eof ; + check-closed + dup wait-to-read1 [ buffer>> buffer-pop ] unless-eof ; : read-step ( count port -- byte-array/f ) [ wait-to-read ] 2keep - [ dupd buffer-read ] unless-eof nip ; + [ dupd buffer>> buffer-read ] unless-eof nip ; : read-loop ( count port accum -- ) pick over length - dup 0 > [ @@ -87,6 +84,7 @@ M: input-port stream-read1 ] if ; M: input-port stream-read + check-closed >r 0 max >fixnum r> 2dup read-step dup [ pick over length > [ @@ -94,72 +92,75 @@ M: input-port stream-read [ push-all ] keep [ read-loop ] keep B{ } like - ] [ - 2nip - ] if - ] [ - 2nip - ] if ; + ] [ 2nip ] if + ] [ 2nip ] if ; M: input-port stream-read-partial ( max stream -- byte-array/f ) + check-closed >r 0 max >fixnum r> read-step ; -: can-write? ( len writer -- ? ) +: can-write? ( len buffer -- ? ) [ buffer-fill + ] keep buffer-capacity <= ; : wait-to-write ( len port -- ) - tuck can-write? [ drop ] [ stream-flush ] if ; + tuck buffer>> can-write? [ drop ] [ stream-flush ] if ; M: output-port stream-write1 - 1 over wait-to-write byte>buffer ; + check-closed + 1 over wait-to-write + buffer>> byte>buffer ; M: output-port stream-write - over length over buffer-size > [ - [ buffer-size ] keep - [ stream-write ] curry each + check-closed + over length over buffer>> buffer-size > [ + [ buffer>> buffer-size ] + [ [ stream-write ] curry ] bi + each ] [ - over length over wait-to-write >buffer + [ >r length r> wait-to-write ] + [ buffer>> >buffer ] 2bi ] if ; GENERIC: port-flush ( port -- ) M: output-port stream-flush ( port -- ) - dup port-flush pending-error ; + check-closed + [ port-flush ] [ pending-error ] bi ; -: close-port ( port type -- ) - output-port eq? [ dup port-flush ] when +GENERIC: close-port ( port -- ) + +M: output-port close-port + [ port-flush ] [ call-next-method ] bi ; + +M: port close-port dup cancel-io - dup port-handle close-handle - dup delegate [ buffer-free ] when* - f swap set-delegate ; + dup handle>> close-handle + [ [ buffer-free ] when* f ] change-buffer drop ; M: port dispose - dup port-type closed eq? - [ drop ] - [ dup port-type >r closed over set-port-type r> close-port ] - if ; + dup closed>> [ drop ] [ t >>closed close-port ] if ; -TUPLE: server-port addr client client-addr encoding ; +TUPLE: server-port < port addr client client-addr encoding ; : ( handle addr encoding -- server ) - rot f server-port - { set-server-port-addr set-server-port-encoding set-delegate } - server-port construct ; + rot server-port + swap >>encoding + swap >>addr ; -: check-server-port ( port -- ) - port-type server-port assert= ; +: check-server-port ( port -- port ) + dup server-port? [ "Not a server port" throw ] unless ; inline -TUPLE: datagram-port addr packet packet-addr ; +TUPLE: datagram-port < port addr packet packet-addr ; : ( handle addr -- datagram ) - >r f datagram-port r> - { set-delegate set-datagram-port-addr } - datagram-port construct ; + swap datagram-port + swap >>addr ; -: check-datagram-port ( port -- ) - port-type datagram-port assert= ; +: check-datagram-port ( port -- port ) + check-closed + dup datagram-port? [ "Not a datagram port" throw ] unless ; inline -: check-datagram-send ( packet addrspec port -- ) - dup check-datagram-port - datagram-port-addr [ class ] bi@ assert= - class byte-array assert= ; +: check-datagram-send ( packet addrspec port -- packet addrspec port ) + check-datagram-port + 2dup addr>> [ class ] bi@ assert= + pick class byte-array assert= ; diff --git a/extra/io/server/server.factor b/extra/io/server/server.factor index 0b7e626908..1d5ed16dc5 100755 --- a/extra/io/server/server.factor +++ b/extra/io/server/server.factor @@ -12,17 +12,17 @@ SYMBOL: servers LOG: accepted-connection NOTICE -: with-client ( client quot -- ) +: with-client ( client addrspec quot -- ) [ - over client-stream-addr accepted-connection + swap accepted-connection with-stream* - ] curry with-disposal ; inline + ] 2curry with-disposal ; inline \ with-client DEBUG add-error-logging : accept-loop ( server quot -- ) [ - >r accept r> [ with-client ] 2curry "Client" spawn drop + >r accept r> [ with-client ] 3curry "Client" spawn drop ] 2keep accept-loop ; inline : server-loop ( addrspec encoding quot -- ) diff --git a/extra/io/sockets/sockets-docs.factor b/extra/io/sockets/sockets-docs.factor index fa38ec90ee..ad78b4631c 100755 --- a/extra/io/sockets/sockets-docs.factor +++ b/extra/io/sockets/sockets-docs.factor @@ -17,8 +17,6 @@ ARTICLE: "network-connection" "Connection-oriented networking" "Connection-oriented network servers are implemented by first opening a server socket, then waiting for connections:" { $subsection } { $subsection accept } -"The stream returned by " { $link accept } " holds the address specifier of the remote client:" -{ $subsection client-stream-addr } "Server sockets are closed by calling " { $link dispose } "." $nl "Address specifiers have the following interpretation with connection-oriented networking words:" @@ -118,10 +116,8 @@ HELP: { $errors "Throws an error if the address is already in use, or if it if the system forbids access." } ; HELP: accept -{ $values { "server" "a handle" } { "client" "a bidirectional stream" } } -{ $description "Waits for a connection to a server socket created by " { $link } ", and outputs a bidirectional stream when the connection has been established. The encoding of this stream is the one that was passed to the server constructor." -$nl -"The returned client stream responds to the " { $link client-stream-addr } " word with the address of the incoming connection." } +{ $values { "server" "a handle" } { "client" "a bidirectional stream" } { "addrspec" "an address specifier" } } +{ $description "Waits for a connection to a server socket created by " { $link } ", and outputs a bidirectional stream when the connection has been established. The encoding of this stream is the one that was passed to the server constructor." } { $errors "Throws an error if the server socket is closed or otherwise is unavailable." } ; HELP: diff --git a/extra/io/sockets/sockets.factor b/extra/io/sockets/sockets.factor index 17799227b8..04141c56ef 100755 --- a/extra/io/sockets/sockets.factor +++ b/extra/io/sockets/sockets.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007, 2008 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: generic kernel io.backend namespaces continuations -sequences arrays io.encodings io.nonblocking ; +sequences arrays io.encodings io.nonblocking accessors ; IN: io.sockets TUPLE: local path ; @@ -21,20 +21,14 @@ TUPLE: inet host port ; C: inet -TUPLE: client-stream addr ; +HOOK: ((client)) io-backend ( addrspec -- client-in client-out ) -: ( addrspec delegate -- stream ) - { set-client-stream-addr set-delegate } - client-stream construct ; - -HOOK: (client) io-backend ( addrspec -- client-in client-out ) - -GENERIC: client* ( addrspec -- client-in client-out ) -M: array client* [ (client) 2array ] attempt-all first2 ; -M: object client* (client) ; +GENERIC: (client) ( addrspec -- client-in client-out ) +M: array (client) [ ((client)) 2array ] attempt-all first2 ; +M: object (client) ((client)) ; : ( addrspec encoding -- stream ) - >r client* r> ; + >r (client) r> ; HOOK: (server) io-backend ( addrspec -- handle ) @@ -43,10 +37,9 @@ HOOK: (server) io-backend ( addrspec -- handle ) HOOK: (accept) io-backend ( server -- addrspec handle ) -: accept ( server -- client ) - [ (accept) dup ] keep - server-port-encoding - ; +: accept ( server -- client addrspec ) + [ (accept) dup ] [ encoding>> ] bi + swap ; HOOK: io-backend ( addrspec -- datagram ) @@ -58,7 +51,8 @@ HOOK: resolve-host io-backend ( host serv passive? -- seq ) HOOK: host-name io-backend ( -- string ) -M: inet client* - dup inet-host swap inet-port f resolve-host - dup empty? [ "Host name lookup failed" throw ] when - client* ; +M: inet (client) + [ host>> ] [ port>> ] bi f resolve-host + [ empty? [ "Host name lookup failed" throw ] when ] + [ (client) ] + bi ; diff --git a/extra/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor index 0fb8b0c5f2..396b8cf2e8 100644 --- a/extra/io/unix/backend/backend.factor +++ b/extra/io/unix/backend/backend.factor @@ -14,18 +14,13 @@ TUPLE: io-task port callbacks ; : io-task-fd port>> handle>> ; : ( port continuation/f class -- task ) - >r [ 1vector ] [ V{ } clone ] if* io-task construct-boa - r> construct-delegate ; inline + construct-empty + swap [ 1vector ] [ V{ } clone ] if* >>callbacks + swap >>port ; inline -TUPLE: input-task ; +TUPLE: input-task < io-task ; -: ( port continuation class -- task ) - >r input-task r> construct-delegate ; inline - -TUPLE: output-task ; - -: ( port continuation class -- task ) - >r output-task r> construct-delegate ; inline +TUPLE: output-task < io-task ; GENERIC: do-io-task ( task -- ? ) GENERIC: io-task-container ( mx task -- hashtable ) @@ -37,9 +32,10 @@ M: input-task io-task-container drop reads>> ; M: output-task io-task-container drop writes>> ; -: ( -- mx ) f H{ } clone H{ } clone mx construct-boa ; - -: construct-mx ( class -- obj ) swap construct-delegate ; +: construct-mx ( class -- obj ) + construct-empty + H{ } clone >>reads + H{ } clone >>writes ; inline GENERIC: register-io-task ( task mx -- ) GENERIC: unregister-io-task ( task mx -- ) @@ -123,16 +119,18 @@ M: unix cancel-io ( port -- ) ! Readers : reader-eof ( reader -- ) - dup buffer-empty? [ t >>eof? ] when drop ; + dup buffer>> buffer-empty? [ t >>eof ] when drop ; : (refill) ( port -- n ) - [ handle>> ] [ buffer-end ] [ buffer-capacity ] tri read ; + [ handle>> ] + [ buffer>> buffer-end ] + [ buffer>> buffer-capacity ] tri read ; : refill ( port -- ? ) #! Return f if there is a recoverable error - dup buffer-empty? [ + dup buffer>> buffer-empty? [ dup (refill) dup 0 >= [ - swap n>buffer t + swap buffer>> n>buffer t ] [ drop defer-error ] if @@ -140,10 +138,10 @@ M: unix cancel-io ( port -- ) drop t ] if ; -TUPLE: read-task ; +TUPLE: read-task < input-task ; : ( port continuation -- task ) - read-task ; + read-task ; M: read-task do-io-task io-task-port dup refill @@ -155,28 +153,33 @@ M: input-port (wait-to-read) ! Writers : write-step ( port -- ? ) - dup [ handle>> ] [ buffer@ ] [ buffer-length ] tri write - dup 0 >= [ swap buffer-consume f ] [ drop defer-error ] if ; + dup + [ handle>> ] + [ buffer>> buffer@ ] + [ buffer>> buffer-length ] tri + write dup 0 >= + [ swap buffer>> buffer-consume f ] + [ drop defer-error ] if ; -TUPLE: write-task ; +TUPLE: write-task < output-task ; : ( port continuation -- task ) - write-task ; + write-task ; M: write-task do-io-task - io-task-port dup [ buffer-empty? ] [ port-error ] bi or - [ 0 swap buffer-reset t ] [ write-step ] if ; + io-task-port dup [ buffer>> buffer-empty? ] [ port-error ] bi or + [ 0 swap buffer>> buffer-reset t ] [ write-step ] if ; : add-write-io-task ( port continuation -- ) - over port-handle mx get-global mx-writes at* + 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: port port-flush ( port -- ) - dup buffer-empty? [ drop ] [ (wait-to-write) ] if ; +M: output-port port-flush ( port -- ) + dup buffer>> buffer-empty? [ drop ] [ (wait-to-write) ] if ; M: unix io-multiplex ( ms/f -- ) mx get-global wait-for-events ; @@ -187,13 +190,12 @@ M: unix (init-stdio) ( -- ) 2 ; ! mx io-task for embedding an fd-based mx inside another mx -TUPLE: mx-port mx ; +TUPLE: mx-port < port mx ; : ( mx -- port ) - dup fd>> f mx-port - { set-mx-port-mx set-delegate } mx-port construct ; + dup fd>> mx-port swap >>mx ; -TUPLE: mx-task ; +TUPLE: mx-task < io-task ; : ( port -- task ) f mx-task ; diff --git a/extra/io/unix/epoll/epoll.factor b/extra/io/unix/epoll/epoll.factor index 1459549f9e..2d7ca9ba3f 100644 --- a/extra/io/unix/epoll/epoll.factor +++ b/extra/io/unix/epoll/epoll.factor @@ -5,7 +5,7 @@ bit-arrays sequences assocs unix unix.linux.epoll math namespaces structs ; IN: io.unix.epoll -TUPLE: epoll-mx events ; +TUPLE: epoll-mx < mx events ; : max-events ( -- n ) #! We read up to 256 events at a time. This is an arbitrary @@ -33,12 +33,10 @@ M: output-task io-task-events drop EPOLLOUT ; epoll_ctl io-error ; M: epoll-mx register-io-task ( task mx -- ) - 2dup EPOLL_CTL_ADD do-epoll-ctl - delegate register-io-task ; + [ EPOLL_CTL_ADD do-epoll-ctl ] [ call-next-method ] 2bi ; M: epoll-mx unregister-io-task ( task mx -- ) - 2dup delegate unregister-io-task - EPOLL_CTL_DEL do-epoll-ctl ; + [ call-next-method ] [ EPOLL_CTL_DEL do-epoll-ctl ] 2bi ; : wait-event ( mx timeout -- n ) >r { mx-fd epoll-mx-events } get-slots max-events diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor index ed54eb26f3..5873568a9e 100755 --- a/extra/io/unix/files/files.factor +++ b/extra/io/unix/files/files.factor @@ -72,7 +72,7 @@ M: unix delete-directory ( path -- ) M: unix copy-file ( from to -- ) [ normalize-path ] bi@ [ (copy-file) ] - [ swap file-info file-info-permissions chmod io-error ] + [ swap file-info permissions>> chmod io-error ] 2bi ; : stat>type ( stat -- type ) diff --git a/extra/io/unix/kqueue/kqueue.factor b/extra/io/unix/kqueue/kqueue.factor index 3735caa7d2..3a140bdbec 100644 --- a/extra/io/unix/kqueue/kqueue.factor +++ b/extra/io/unix/kqueue/kqueue.factor @@ -8,7 +8,7 @@ io.nonblocking io.unix.backend io.launcher io.unix.launcher io.monitors ; IN: io.unix.kqueue -TUPLE: kqueue-mx events monitors ; +TUPLE: kqueue-mx < mx events monitors ; : max-events ( -- n ) #! We read up to 256 events at a time. This is an arbitrary @@ -43,12 +43,14 @@ M: io-task io-task-fflags drop 0 ; 0 < [ err_no ESRCH = [ (io-error) ] unless ] when ; M: kqueue-mx register-io-task ( task mx -- ) - over EV_ADD make-kevent over register-kevent - delegate register-io-task ; + [ >r EV_ADD make-kevent r> register-kevent ] + [ call-next-method ] + 2bi ; M: kqueue-mx unregister-io-task ( task mx -- ) - 2dup delegate unregister-io-task - swap EV_DELETE make-kevent swap register-kevent ; + [ call-next-method ] + [ >r EV_DELETE make-kevent r> register-kevent ] + 2bi ; : wait-kevent ( mx timespec -- n ) >r [ fd>> f 0 ] keep events>> max-events r> kevent diff --git a/extra/io/unix/linux/monitors/monitors.factor b/extra/io/unix/linux/monitors/monitors.factor index bda20a71fa..f92fb36d0d 100644 --- a/extra/io/unix/linux/monitors/monitors.factor +++ b/extra/io/unix/linux/monitors/monitors.factor @@ -103,8 +103,8 @@ M: linux-monitor dispose ( monitor -- ) : inotify-read-loop ( port -- ) dup wait-to-read1 - 0 over parse-file-notifications - 0 over buffer-reset + 0 over buffer>> parse-file-notifications + 0 over buffer>> buffer-reset inotify-read-loop ; : inotify-read-thread ( port -- ) diff --git a/extra/io/unix/select/select.factor b/extra/io/unix/select/select.factor index 6527a87010..facaf4d73d 100755 --- a/extra/io/unix/select/select.factor +++ b/extra/io/unix/select/select.factor @@ -5,7 +5,7 @@ bit-arrays sequences assocs unix math namespaces structs accessors ; IN: io.unix.select -TUPLE: select-mx read-fdset write-fdset ; +TUPLE: select-mx < mx read-fdset write-fdset ; ! Factor's bit-arrays are an array of bytes, OS X expects ! FD_SET to be an array of cells, so we have to account for @@ -15,8 +15,8 @@ TUPLE: select-mx read-fdset write-fdset ; : ( -- mx ) select-mx construct-mx - FD_SETSIZE 8 * >>read-fdset - FD_SETSIZE 8 * >>write-fdset ; + FD_SETSIZE 8 * >>read-fdset + FD_SETSIZE 8 * >>write-fdset ; : clear-nth ( n seq -- ? ) [ nth ] [ f -rot set-nth ] 2bi ; diff --git a/extra/io/unix/sockets/sockets.factor b/extra/io/unix/sockets/sockets.factor index a54205a878..cecc70fb08 100755 --- a/extra/io/unix/sockets/sockets.factor +++ b/extra/io/unix/sockets/sockets.factor @@ -7,7 +7,7 @@ USING: alien alien.c-types generic io kernel math namespaces io.nonblocking parser threads unix sequences byte-arrays io.sockets io.binary io.unix.backend io.streams.duplex io.sockets.impl math.parser continuations libc -combinators io.backend io.files io.files.private system ; +combinators io.backend io.files io.files.private system accessors ; IN: io.unix.sockets : pending-init-error ( port -- ) @@ -30,10 +30,10 @@ M: unix addrinfo-error ( n -- ) : init-client-socket ( fd -- ) SOL_SOCKET SO_OOBINLINE sockopt ; -TUPLE: connect-task ; +TUPLE: connect-task < output-task ; : ( port continuation -- task ) - connect-task ; + connect-task ; M: connect-task do-io-task io-task-port dup port-handle f 0 write @@ -42,7 +42,7 @@ M: connect-task do-io-task : wait-to-connect ( port -- ) [ add-io-task ] with-port-continuation drop ; -M: unix (client) ( addrspec -- client-in client-out ) +M: unix ((client)) ( addrspec -- client-in client-out ) dup make-sockaddr/size >r >r protocol-family SOCK_STREAM socket-fd dup r> r> connect @@ -61,10 +61,10 @@ USE: unix : init-server-socket ( fd -- ) SOL_SOCKET SO_REUSEADDR sockopt ; -TUPLE: accept-task ; +TUPLE: accept-task < input-task ; : ( port continuation -- task ) - accept-task ; + accept-task ; : accept-sockaddr ( port -- fd sockaddr ) dup port-handle swap server-port-addr sockaddr-type @@ -97,11 +97,10 @@ M: unix (server) ( addrspec -- handle ) M: unix (accept) ( server -- addrspec handle ) #! Wait for a client connection. - dup check-server-port - dup wait-to-accept - dup pending-error - dup server-port-client-addr - swap server-port-client ; + check-server-port + [ wait-to-accept ] + [ pending-error ] + [ [ client-addr>> ] [ client>> ] bi ] tri ; ! Datagram sockets - UDP and Unix domain M: unix @@ -128,10 +127,10 @@ packet-size receive-buffer set-global rot head ] if ; -TUPLE: receive-task ; +TUPLE: receive-task < input-task ; : ( stream continuation -- task ) - receive-task ; + receive-task ; M: receive-task do-io-task io-task-port @@ -148,19 +147,18 @@ M: receive-task do-io-task [ add-io-task ] with-port-continuation drop ; M: unix receive ( datagram -- packet addrspec ) - dup check-datagram-port - dup wait-receive - dup pending-error - dup datagram-port-packet - swap datagram-port-packet-addr ; + 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 packet sockaddr len ; +TUPLE: send-task < output-task packet sockaddr len ; : ( packet sockaddr len stream continuation -- task ) - send-task [ + send-task [ { set-send-task-packet set-send-task-sockaddr @@ -180,7 +178,7 @@ M: send-task do-io-task 2drop 2drop ; M: unix send ( packet addrspec datagram -- ) - 3dup check-datagram-send + check-datagram-send [ >r make-sockaddr/size r> wait-send ] keep pending-error ; diff --git a/extra/io/unix/unix-tests.factor b/extra/io/unix/unix-tests.factor index c8ed4fc41c..ff315bc529 100755 --- a/extra/io/unix/unix-tests.factor +++ b/extra/io/unix/unix-tests.factor @@ -11,7 +11,7 @@ IN: io.unix.tests socket-server ascii [ - accept [ + accept drop [ "Hello world" print flush readln "XYZ" = "FOO" "BAR" ? print flush ] with-stream diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor index f2615b67de..745b9f6afc 100755 --- a/extra/io/windows/nt/files/files.factor +++ b/extra/io/windows/nt/files/files.factor @@ -64,7 +64,7 @@ M: winnt FileArgs-overlapped ( port -- overlapped ) dup pending-error tuck get-overlapped-result dup pick update-file-ptr - swap buffer-consume ; + swap buffer>> buffer-consume ; : (flush-output) ( port -- ) dup make-FileArgs @@ -73,7 +73,7 @@ M: winnt FileArgs-overlapped ( port -- overlapped ) >r FileArgs-lpOverlapped r> [ save-callback ] 2keep [ finish-flush ] keep - dup buffer-empty? [ drop ] [ (flush-output) ] if + dup buffer>> buffer-empty? [ drop ] [ (flush-output) ] if ] [ 2drop ] if ; @@ -82,7 +82,7 @@ M: winnt FileArgs-overlapped ( port -- overlapped ) [ [ (flush-output) ] with-timeout ] with-destructors ; M: port port-flush - dup buffer-empty? [ dup flush-output ] unless drop ; + dup buffer>> buffer-empty? [ dup flush-output ] unless drop ; : finish-read ( overlapped port -- ) dup pending-error diff --git a/extra/io/windows/nt/monitors/monitors.factor b/extra/io/windows/nt/monitors/monitors.factor index 87e6280118..8f873ee23b 100755 --- a/extra/io/windows/nt/monitors/monitors.factor +++ b/extra/io/windows/nt/monitors/monitors.factor @@ -37,10 +37,12 @@ M: winnt ( path recursive? -- monitor ) ] with-destructors ; : begin-reading-changes ( monitor -- overlapped ) - dup port-handle win32-file-handle - over buffer-ptr - pick buffer-size - roll win32-monitor-recursive? 1 0 ? + { + [ handle>> handle>> ] + [ buffer>> buffer-ptr ] + [ buffer>> buffer-size ] + [ win32-monitor-recursive? 1 0 ? ] + } cleave FILE_NOTIFY_CHANGE_ALL 0 (make-overlapped) @@ -82,6 +84,6 @@ M: winnt ( path recursive? -- monitor ) [ 2drop ] [ swap (changed-files) ] if ; M: win32-monitor fill-queue ( monitor -- ) - dup buffer-ptr over read-changes + dup buffer>> buffer-ptr over read-changes [ zero? [ drop ] [ (changed-files) ] if ] H{ } make-assoc swap set-monitor-queue ; diff --git a/extra/io/windows/nt/sockets/sockets.factor b/extra/io/windows/nt/sockets/sockets.factor index 36acaac992..c0dc0afd06 100755 --- a/extra/io/windows/nt/sockets/sockets.factor +++ b/extra/io/windows/nt/sockets/sockets.factor @@ -122,7 +122,7 @@ TUPLE: AcceptEx-args port M: winnt (accept) ( server -- addrspec handle ) [ [ - dup check-server-port + check-server-port \ AcceptEx-args construct-empty [ init-accept ] keep [ ((accept)) ] keep @@ -159,7 +159,7 @@ TUPLE: WSARecvFrom-args port : init-WSARecvFrom ( datagram WSARecvFrom -- ) [ set-WSARecvFrom-args-port ] 2keep [ - >r delegate port-handle delegate win32-file-handle r> + >r handle>> handle>> r> set-WSARecvFrom-args-s* ] 2keep [ >r datagram-port-addr sockaddr-type heap-size r> @@ -192,7 +192,7 @@ TUPLE: WSARecvFrom-args port M: winnt receive ( datagram -- packet addrspec ) [ - dup check-datagram-port + check-datagram-port \ WSARecvFrom-args construct-empty [ init-WSARecvFrom ] keep [ call-WSARecvFrom ] keep @@ -244,7 +244,7 @@ USE: io.sockets M: winnt send ( packet addrspec datagram -- ) [ - 3dup check-datagram-send + check-datagram-send \ WSASendTo-args construct-empty [ init-WSASendTo ] keep [ call-WSASendTo ] keep diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor index 3e0f4e9e86..89a78f1f74 100755 --- a/extra/io/windows/windows.factor +++ b/extra/io/windows/windows.factor @@ -92,7 +92,7 @@ M: win32-file close-handle ( handle -- ) ] when drop ; : open-append ( path -- handle length ) - [ dup file-info file-info-size ] [ drop 0 ] recover + [ dup file-info size>> ] [ drop 0 ] recover >r (open-append) r> 2dup set-file-pointer ; TUPLE: FileArgs @@ -103,9 +103,9 @@ C: FileArgs : make-FileArgs ( port -- ) [ port-handle win32-file-handle ] keep - [ delegate ] keep + [ buffer>> ] keep [ - buffer-length + buffer>> buffer-length "DWORD" ] keep FileArgs-overlapped ; @@ -152,11 +152,10 @@ M: windows delete-directory ( path -- ) HOOK: WSASocket-flags io-backend ( -- DWORD ) -TUPLE: win32-socket ; +TUPLE: win32-socket < win32-file ; : ( handle -- win32-socket ) - f - \ win32-socket construct-delegate ; + f win32-file construct-boa ; : open-socket ( family type -- socket ) 0 f 0 WSASocket-flags WSASocket dup socket-error ; diff --git a/extra/tools/deploy/backend/backend.factor b/extra/tools/deploy/backend/backend.factor index e11d16c4ec..b838654248 100755 --- a/extra/tools/deploy/backend/backend.factor +++ b/extra/tools/deploy/backend/backend.factor @@ -22,9 +22,8 @@ IN: tools.deploy.backend +stdout+ >>stderr +closed+ >>stdin +low-priority+ >>priority - utf8 - dup copy-lines - process>> wait-for-process zero? [ + utf8 + >r copy-lines r> wait-for-process zero? [ "Deployment failed" throw ] unless ; diff --git a/extra/tools/deploy/deploy-tests.factor b/extra/tools/deploy/deploy-tests.factor index 99e533f1c1..37689f749f 100755 --- a/extra/tools/deploy/deploy-tests.factor +++ b/extra/tools/deploy/deploy-tests.factor @@ -1,7 +1,7 @@ IN: tools.deploy.tests USING: tools.test system io.files kernel tools.deploy.config tools.deploy.backend math sequences io.launcher arrays -namespaces continuations layouts ; +namespaces continuations layouts accessors ; : shake-and-bake ( vocab -- ) [ "test.image" temp-file delete-file ] ignore-errors @@ -12,7 +12,7 @@ namespaces continuations layouts ; ] with-directory ; : small-enough? ( n -- ? ) - >r "test.image" temp-file file-info file-info-size r> <= ; + >r "test.image" temp-file file-info size>> r> <= ; [ ] [ "hello-world" shake-and-bake ] unit-test diff --git a/extra/ui/tools/interactor/interactor-tests.factor b/extra/ui/tools/interactor/interactor-tests.factor index 94953f9c72..99c005451d 100755 --- a/extra/ui/tools/interactor/interactor-tests.factor +++ b/extra/ui/tools/interactor/interactor-tests.factor @@ -1,27 +1,29 @@ IN: ui.tools.interactor.tests USING: ui.tools.interactor ui.gadgets.panes namespaces ui.gadgets.editors concurrency.promises threads listener -tools.test kernel calendar ; - -\ must-infer - -[ ] [ "interactor" set ] unit-test - -[ ] [ "[ 1 2 3" "interactor" get set-editor-string ] unit-test - -[ ] [ "promise" set ] unit-test +tools.test kernel calendar parser ; [ - "interactor" get stream-read-quot "promise" get fulfill -] "Interactor test" spawn drop + \ must-infer -! This should not throw an exception -[ ] [ "interactor" get evaluate-input ] unit-test + [ ] [ "interactor" set ] unit-test -[ ] [ [ "interactor" get interactor-busy? ] [ yield ] [ ] while ] unit-test + [ ] [ "[ 1 2 3" "interactor" get set-editor-string ] unit-test -[ ] [ "[ 1 2 3 ]" "interactor" get set-editor-string ] unit-test + [ ] [ "promise" set ] unit-test -[ ] [ "interactor" get evaluate-input ] unit-test + [ + "interactor" get stream-read-quot "promise" get fulfill + ] "Interactor test" spawn drop -[ [ [ 1 2 3 ] ] ] [ "promise" get 5 seconds ?promise-timeout ] unit-test + ! This should not throw an exception + [ ] [ "interactor" get evaluate-input ] unit-test + + [ ] [ [ "interactor" get interactor-busy? ] [ yield ] [ ] while ] unit-test + + [ ] [ "[ 1 2 3 ]" "interactor" get set-editor-string ] unit-test + + [ ] [ "interactor" get evaluate-input ] unit-test + + [ [ [ 1 2 3 ] ] ] [ "promise" get 5 seconds ?promise-timeout ] unit-test +] with-interactive-vocabs