From b369ed600d1a9e4dd1e21ab765e8aef2d9f2682c Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sat, 5 Apr 2008 16:02:41 -0500 Subject: [PATCH 001/109] Graph docs fix --- core/graphs/graphs-docs.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) 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" } ; From d81a4aa914ac947bf6f6e14029ac87ff9e330c5f Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sun, 6 Apr 2008 19:03:00 -0500 Subject: [PATCH 002/109] Minor io.encodings.8-bit cleanup --- extra/io/encodings/8-bit/8-bit.factor | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) 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 From 368599baf81fcd864b9fd2234df882ff326a5f1a Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Mon, 7 Apr 2008 00:45:46 -0500 Subject: [PATCH 003/109] Fix to inverse, and syntax change --- extra/inverse/inverse-tests.factor | 6 ++++-- extra/inverse/inverse.factor | 17 ++++++++++------- 2 files changed, 14 insertions(+), 9 deletions(-) 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 ; From 0c351581b5c299450e4d081bde4260ee294b36a1 Mon Sep 17 00:00:00 2001 From: slava Date: Wed, 9 Apr 2008 20:15:24 -0500 Subject: [PATCH 004/109] Fix -no-monitors switch --- extra/tools/vocabs/monitor/monitor.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/tools/vocabs/monitor/monitor.factor b/extra/tools/vocabs/monitor/monitor.factor index 867c3b2903..185f8d157a 100755 --- a/extra/tools/vocabs/monitor/monitor.factor +++ b/extra/tools/vocabs/monitor/monitor.factor @@ -45,7 +45,7 @@ IN: tools.vocabs.monitor ] ignore-errors ; [ - "-no-monitors" cli-args get member? [ + "-no-monitors" cli-args member? [ start-monitor-thread ] unless ] "tools.vocabs.monitor" add-init-hook From 688cbfaafacf383374b162d6163ca957f7b84032 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Fri, 11 Apr 2008 14:46:11 +1200 Subject: [PATCH 005/109] Delocalise grow-lr --- extra/peg/peg.factor | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 7390c15684..164f7c9ee9 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -100,21 +100,21 @@ C: peg-head : setup-growth ( h p -- ) pos set dup involved-set>> clone >>eval-set drop ; -:: (grow-lr) ( h p r m -- ) - h p setup-growth - r eval-rule - dup m stop-growth? [ - drop +: (grow-lr) ( h p r m -- ) + >r >r [ setup-growth ] 2keep r> r> + >r dup eval-rule r> swap + dup pick stop-growth? [ + 4drop drop ] [ - m update-m - h p r m (grow-lr) + over update-m + (grow-lr) ] if ; inline -:: grow-lr ( h p r m -- ast ) - h p heads get set-at - h p r m (grow-lr) - p heads get delete-at - m pos>> pos set m ans>> +: grow-lr ( h p r m -- ast ) + >r >r [ heads get set-at ] 2keep r> r> + pick over >r >r (grow-lr) r> r> + swap heads get delete-at + dup pos>> pos set ans>> ; inline :: (setup-lr) ( r l s -- ) From 56892ae74afe8b3050615380c8fc01e77521e4a4 Mon Sep 17 00:00:00 2001 From: slava Date: Fri, 11 Apr 2008 07:15:26 -0500 Subject: [PATCH 006/109] Overhaul monitors --- core/continuations/continuations-docs.factor | 6 +- core/io/files/files-docs.factor | 3 +- core/threads/threads.factor | 58 ++++---- .../mailboxes/mailboxes-docs.factor | 4 +- .../mailboxes/mailboxes-tests.factor | 39 +++++- extra/concurrency/mailboxes/mailboxes.factor | 46 +++++-- .../messaging/messaging-docs.factor | 5 +- .../messaging/messaging-tests.factor | 16 ++- extra/io/monitors/monitors-docs.factor | 84 +++++++++--- extra/io/monitors/monitors-tests.factor | 99 ++++++++++---- extra/io/monitors/monitors.factor | 92 ++++--------- .../monitors/recursive/recursive-tests.factor | 59 ++++++++ extra/io/monitors/recursive/recursive.factor | 105 ++++++++++++++ extra/io/timeouts/timeouts-docs.factor | 4 +- extra/io/unix/linux/linux.factor | 121 +--------------- extra/io/unix/linux/monitors/monitors.factor | 129 ++++++++++++++++++ extra/io/unix/macosx/macosx.factor | 19 ++- extra/io/unix/select/select.factor | 7 +- extra/tools/threads/threads.factor | 2 +- extra/tools/vocabs/monitor/monitor.factor | 27 ++-- extra/tools/vocabs/vocabs-tests.factor | 1 + extra/tools/vocabs/vocabs.factor | 9 +- 22 files changed, 627 insertions(+), 308 deletions(-) create mode 100644 extra/io/monitors/recursive/recursive-tests.factor create mode 100644 extra/io/monitors/recursive/recursive.factor create mode 100644 extra/io/unix/linux/monitors/monitors.factor diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor index b3adb1b165..b1db09b6bc 100755 --- a/core/continuations/continuations-docs.factor +++ b/core/continuations/continuations-docs.factor @@ -90,7 +90,11 @@ ABOUT: "continuations" HELP: dispose { $values { "object" "a disposable object" } } -{ $contract "Releases operating system resources associated with a disposable object. No further operations can be performed on a disposable object after this call. Disposable objects include streams, memory mapped files, and so on." } +{ $contract "Releases operating system resources associated with a disposable object. Disposable objects include streams, memory mapped files, and so on." +$nl +"No further operations can be performed on a disposable object after this call." +$nl +"Disposing an object which has already been disposed should have no effect, and in particular it should not fail with an error." } { $notes "You must close disposable objects after you are finished working with them, to avoid leaking operating system resources. A convenient way to automate this is by using the " { $link with-disposal } " word." } ; HELP: with-disposal diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor index e3f86c079d..0d49e344a8 100755 --- a/core/io/files/files-docs.factor +++ b/core/io/files/files-docs.factor @@ -112,8 +112,7 @@ ARTICLE: "io.files" "Basic file operations" { $subsection "file-streams" } { $subsection "fs-meta" } { $subsection "directories" } -{ $subsection "delete-move-copy" } -{ $see-also "os" } ; +{ $subsection "delete-move-copy" } ; ABOUT: "io.files" diff --git a/core/threads/threads.factor b/core/threads/threads.factor index d7d7988893..ba8f4f2e52 100755 --- a/core/threads/threads.factor +++ b/core/threads/threads.factor @@ -4,7 +4,7 @@ IN: threads USING: arrays hashtables heaps kernel kernel.private math namespaces sequences vectors continuations continuations.private -dlists assocs system combinators init boxes ; +dlists assocs system combinators init boxes accessors ; SYMBOL: initial-thread @@ -18,11 +18,10 @@ mailbox variables sleep-entry ; ! Thread-local storage : tnamespace ( -- assoc ) - self dup thread-variables - [ ] [ H{ } clone dup rot set-thread-variables ] ?if ; + self variables>> [ H{ } clone dup self (>>variables) ] unless* ; : tget ( key -- value ) - self thread-variables at ; + self variables>> at ; : tset ( value key -- ) tnamespace set-at ; @@ -35,7 +34,7 @@ mailbox variables sleep-entry ; : thread ( id -- thread ) threads at ; : thread-registered? ( thread -- ? ) - thread-id threads key? ; + id>> threads key? ; : check-unregistered dup thread-registered? @@ -48,38 +47,37 @@ mailbox variables sleep-entry ; > threads set-at ; : unregister-thread ( thread -- ) - check-registered thread-id threads delete-at ; + check-registered id>> threads delete-at ; : set-self ( thread -- ) 40 setenv ; inline PRIVATE> : ( quot name -- thread ) - \ thread counter [ ] { - set-thread-quot - set-thread-name - set-thread-id - set-thread-continuation - set-thread-exit-handler - } \ thread construct ; + \ thread construct-empty + swap >>name + swap >>quot + \ thread counter >>id + >>continuation + [ ] >>exit-handler ; : run-queue 42 getenv ; : sleep-queue 43 getenv ; : resume ( thread -- ) - f over set-thread-state + f >>state check-registered run-queue push-front ; : resume-now ( thread -- ) - f over set-thread-state + f >>state check-registered run-queue push-back ; : resume-with ( obj thread -- ) - f over set-thread-state + f >>state check-registered 2array run-queue push-front ; : sleep-time ( -- ms/f ) @@ -93,14 +91,14 @@ PRIVATE> : schedule-sleep ( thread ms -- ) >r check-registered dup r> sleep-queue heap-push* - swap set-thread-sleep-entry ; + >>sleep-entry drop ; : expire-sleep? ( heap -- ? ) dup heap-empty? [ drop f ] [ heap-peek nip millis <= ] if ; : expire-sleep ( thread -- ) - f over set-thread-sleep-entry resume ; + f >>sleep-entry resume ; : expire-sleep-loop ( -- ) sleep-queue @@ -123,21 +121,21 @@ PRIVATE> ] [ pop-back dup array? [ first2 ] [ f swap ] if dup set-self - f over set-thread-state - thread-continuation box> + f >>state + continuation>> box> continue-with ] if ; PRIVATE> : stop ( -- ) - self dup thread-exit-handler call + self dup exit-handler>> call unregister-thread next ; : suspend ( quot state -- obj ) [ - self thread-continuation >box - self set-thread-state + self continuation>> >box + self (>>state) self swap call next ] callcc1 2nip ; inline @@ -157,9 +155,9 @@ M: real sleep millis + >integer sleep-until ; : interrupt ( thread -- ) - dup thread-state [ - dup thread-sleep-entry [ sleep-queue heap-delete ] when* - f over set-thread-sleep-entry + dup state>> [ + dup sleep-entry>> [ sleep-queue heap-delete ] when* + f >>sleep-entry dup resume ] when drop ; @@ -171,7 +169,7 @@ M: real sleep V{ } set-catchstack { } set-retainstack >r { } set-datastack r> - thread-quot [ call stop ] call-clear + quot>> [ call stop ] call-clear ] 1 (throw) ] "spawn" suspend 2drop ; @@ -196,8 +194,8 @@ GENERIC: error-in-thread ( error thread -- ) 43 setenv initial-thread global [ drop f "Initial" ] cache - over set-thread-continuation - f over set-thread-state + >>continuation + f >>state dup register-thread set-self ; diff --git a/extra/concurrency/mailboxes/mailboxes-docs.factor b/extra/concurrency/mailboxes/mailboxes-docs.factor index 50694776c5..a9b86e3bcd 100755 --- a/extra/concurrency/mailboxes/mailboxes-docs.factor +++ b/extra/concurrency/mailboxes/mailboxes-docs.factor @@ -57,7 +57,7 @@ HELP: mailbox-get? ARTICLE: "concurrency.mailboxes" "Mailboxes" -"A " { $emphasis "mailbox" } " is a first-in-first-out queue where the operation of removing an element blocks if the queue is empty, instead of throwing an error." +"A " { $emphasis "mailbox" } " is a first-in-first-out queue where the operation of removing an element blocks if the queue is empty, instead of throwing an error. Mailboxes are implemented in the " { $vocab-link "concurrency.mailboxes" } " vocabulary." { $subsection mailbox } { $subsection } "Removing the first element:" @@ -73,3 +73,5 @@ ARTICLE: "concurrency.mailboxes" "Mailboxes" "Testing if a mailbox is empty:" { $subsection mailbox-empty? } { $subsection while-mailbox-empty } ; + +ABOUT: "concurrency.mailboxes" diff --git a/extra/concurrency/mailboxes/mailboxes-tests.factor b/extra/concurrency/mailboxes/mailboxes-tests.factor index 2cb12bcaba..7fe09cdcf5 100755 --- a/extra/concurrency/mailboxes/mailboxes-tests.factor +++ b/extra/concurrency/mailboxes/mailboxes-tests.factor @@ -1,6 +1,7 @@ IN: concurrency.mailboxes.tests -USING: concurrency.mailboxes vectors sequences threads -tools.test math kernel strings ; +USING: concurrency.mailboxes concurrency.count-downs vectors +sequences threads tools.test math kernel strings namespaces +continuations calendar ; [ V{ 1 2 3 } ] [ 0 @@ -38,3 +39,37 @@ tools.test math kernel strings ; "junk2" over mailbox-put mailbox-get ] unit-test + + "m" set + +1 "c" set +1 "d" set + +[ + "c" get await + [ "m" get mailbox-get drop ] + [ drop "d" get count-down ] recover +] "Mailbox close test" spawn drop + +[ ] [ "c" get count-down ] unit-test +[ ] [ "m" get dispose ] unit-test +[ ] [ "d" get 5 seconds await-timeout ] unit-test + +[ ] [ "m" get dispose ] unit-test + + "m" set + +1 "c" set +1 "d" set + +[ + "c" get await + "m" get wait-for-close + "d" get count-down +] "Mailbox close test" spawn drop + +[ ] [ "c" get count-down ] unit-test +[ ] [ "m" get dispose ] unit-test +[ ] [ "d" get 5 seconds await-timeout ] unit-test + +[ ] [ "m" get dispose ] unit-test diff --git a/extra/concurrency/mailboxes/mailboxes.factor b/extra/concurrency/mailboxes/mailboxes.factor index 7b6405679f..36aafbdc84 100755 --- a/extra/concurrency/mailboxes/mailboxes.factor +++ b/extra/concurrency/mailboxes/mailboxes.factor @@ -3,41 +3,50 @@ IN: concurrency.mailboxes USING: dlists threads sequences continuations namespaces random math quotations words kernel arrays assocs -init system concurrency.conditions ; +init system concurrency.conditions accessors ; -TUPLE: mailbox threads data ; +TUPLE: mailbox threads data closed ; + +: check-closed ( mailbox -- ) + closed>> [ "Mailbox closed" throw ] when ; inline + +M: mailbox dispose + t >>closed threads>> notify-all ; : ( -- mailbox ) - mailbox construct-boa ; + f mailbox construct-boa ; : mailbox-empty? ( mailbox -- bool ) - mailbox-data dlist-empty? ; + data>> dlist-empty? ; : mailbox-put ( obj mailbox -- ) - [ mailbox-data push-front ] keep - mailbox-threads notify-all yield ; + [ data>> push-front ] + [ threads>> notify-all ] bi yield ; + +: wait-for-mailbox ( mailbox timeout -- ) + >r threads>> r> "mailbox" wait ; : block-unless-pred ( mailbox timeout pred -- ) - pick mailbox-data over dlist-contains? [ + pick check-closed + pick data>> over dlist-contains? [ 3drop ] [ - >r over mailbox-threads over "mailbox" wait r> - block-unless-pred + >r 2dup wait-for-mailbox r> block-unless-pred ] if ; inline : block-if-empty ( mailbox timeout -- mailbox ) + over check-closed over mailbox-empty? [ - over mailbox-threads over "mailbox" wait - block-if-empty + 2dup wait-for-mailbox block-if-empty ] [ drop ] if ; : mailbox-peek ( mailbox -- obj ) - mailbox-data peek-back ; + data>> peek-back ; : mailbox-get-timeout ( mailbox timeout -- obj ) - block-if-empty mailbox-data pop-back ; + block-if-empty data>> pop-back ; : mailbox-get ( mailbox -- obj ) f mailbox-get-timeout ; @@ -45,7 +54,7 @@ TUPLE: mailbox threads data ; : mailbox-get-all-timeout ( mailbox timeout -- array ) block-if-empty [ dup mailbox-empty? ] - [ dup mailbox-data pop-back ] + [ dup data>> pop-back ] [ ] unfold nip ; : mailbox-get-all ( mailbox -- array ) @@ -60,11 +69,18 @@ TUPLE: mailbox threads data ; : mailbox-get-timeout? ( mailbox timeout pred -- obj ) 3dup block-unless-pred - nip >r mailbox-data r> delete-node-if ; inline + nip >r data>> r> delete-node-if ; inline : mailbox-get? ( mailbox pred -- obj ) f swap mailbox-get-timeout? ; inline +: wait-for-close-timeout ( mailbox timeout -- ) + over closed>> + [ 2drop ] [ 2dup wait-for-mailbox wait-for-close-timeout ] if ; + +: wait-for-close ( mailbox -- ) + f wait-for-close-timeout ; + TUPLE: linked-error thread ; : ( error thread -- linked ) diff --git a/extra/concurrency/messaging/messaging-docs.factor b/extra/concurrency/messaging/messaging-docs.factor index e7aa5d1a7e..1219982f51 100755 --- a/extra/concurrency/messaging/messaging-docs.factor +++ b/extra/concurrency/messaging/messaging-docs.factor @@ -32,7 +32,7 @@ HELP: spawn-linked { $description "Start a thread which runs the given quotation. If that quotation throws an error which is not caught then the error will get propagated to the thread that spawned it. This can be used to set up 'supervisor' threades that restart child threades that crash due to uncaught errors.\n" } { $see-also spawn } ; -ARTICLE: { "concurrency" "messaging" } "Mailboxes" +ARTICLE: { "concurrency" "messaging" } "Sending and receiving messages" "Each thread has an associated mailbox. Other threads can place items on this queue by sending the thread a message. A thread can check its mailbox for messages, blocking if none are pending, and thread them as they are queued." $nl "The messages that are sent from thread to thread are any Factor value. Factor tuples are ideal for this sort of thing as you can send a tuple to a thread and the generic word dispatch mechanism can be used to perform actions depending on what the type of the tuple is." @@ -43,7 +43,8 @@ $nl { $subsection receive } { $subsection receive-timeout } { $subsection receive-if } -{ $subsection receive-if-timeout } ; +{ $subsection receive-if-timeout } +{ $see-also "concurrency.mailboxes" } ; ARTICLE: { "concurrency" "synchronous-sends" } "Synchronous sends" "The " { $link send } " word sends a message asynchronously, and the sending thread continues immediately. It is also possible to send a message to a thread and block until a response is received:" diff --git a/extra/concurrency/messaging/messaging-tests.factor b/extra/concurrency/messaging/messaging-tests.factor index 6de381b166..b69773f3b1 100755 --- a/extra/concurrency/messaging/messaging-tests.factor +++ b/extra/concurrency/messaging/messaging-tests.factor @@ -3,7 +3,8 @@ ! USING: kernel threads vectors arrays sequences namespaces tools.test continuations dlists strings math words -match quotations concurrency.messaging concurrency.mailboxes ; +match quotations concurrency.messaging concurrency.mailboxes +concurrency.count-downs ; IN: concurrency.messaging.tests [ ] [ my-mailbox mailbox-data dlist-delete-all ] unit-test @@ -52,4 +53,15 @@ SYMBOL: exit [ value , self , ] { } make "counter" get send receive exit "counter" get send -] unit-test \ No newline at end of file +] unit-test + +! Not yet + +! 1 "c" set + +! [ +! "c" get count-down +! receive drop +! ] "Bad synchronous send" spawn "t" set + +! [ 3 "t" get send-synchronous ] must-fail \ No newline at end of file diff --git a/extra/io/monitors/monitors-docs.factor b/extra/io/monitors/monitors-docs.factor index 4f24879e19..ae561cd666 100755 --- a/extra/io/monitors/monitors-docs.factor +++ b/extra/io/monitors/monitors-docs.factor @@ -1,58 +1,106 @@ IN: io.monitors -USING: help.markup help.syntax continuations ; +USING: help.markup help.syntax continuations +concurrency.mailboxes quotations ; + +HELP: with-monitors +{ $values { "quot" quotation } } +{ $description "Calls a quotation in a new dynamic scope where file system monitor operations can be performed." } +{ $errors "Throws an error if the platform does not support file system change monitors." } ; HELP: { $values { "path" "a pathname string" } { "recursive?" "a boolean" } { "monitor" "a new monitor" } } -{ $description "Opens a file system change monitor which listens for changes on " { $snippet "path" } ". The boolean indicates whether changes in subdirectories should be reported." -$nl -"Not all operating systems support recursive monitors; if recursive monitoring is not available, an error is thrown and the caller must implement alternative logic for monitoring subdirectories." } ; +{ $contract "Opens a file system change monitor which listens for changes on " { $snippet "path" } ". The boolean indicates whether changes in subdirectories should be reported." } +{ $errors "Throws an error if the pathname does not exist, if a monitor could not be created or if the platform does not support monitors." } ; + +HELP: (monitor) +{ $values { "path" "a pathname string" } { "recursive?" "a boolean" } { "mailbox" mailbox } { "monitor" "a new monitor" } } +{ $contract "Opens a file system change monitor which listens for changes on " { $snippet "path" } " and posts notifications to " { $snippet "mailbox" } " as triples with shape " { $snippet "{ path changed monitor } " } ". The boolean indicates whether changes in subdirectories should be reported." } +{ $errors "Throws an error if the pathname does not exist, if a monitor could not be created or if the platform does not support monitors." } ; HELP: next-change { $values { "monitor" "a monitor" } { "path" "a pathname string" } { "changed" "a change descriptor" } } -{ $description "Waits for file system changes and outputs the pathname of the first changed file. The change descriptor is a sequence of symbols documented in " { $link "io.monitors.descriptors" } "." } ; +{ $contract "Waits for file system changes and outputs the pathname of the first changed file. The change descriptor is a sequence of symbols documented in " { $link "io.monitors.descriptors" } "." } +{ $errors "Throws an error if the monitor is closed from another thread." } ; HELP: with-monitor { $values { "path" "a pathname string" } { "recursive?" "a boolean" } { "quot" "a quotation with stack effect " { $snippet "( monitor -- )" } } } -{ $description "Opens a file system change monitor and passes it to the quotation. Closes the monitor after the quotation returns or throws an error." } ; +{ $description "Opens a file system change monitor and passes it to the quotation. Closes the monitor after the quotation returns or throws an error." } +{ $errors "Throws an error if the pathname does not exist, if a monitor could not be created or if the platform does not support monitors." } ; HELP: +add-file+ -{ $description "Indicates that the file has been added to the directory." } ; +{ $description "Indicates that a file has been added to its parent directory." } ; HELP: +remove-file+ -{ $description "Indicates that the file has been removed from the directory." } ; +{ $description "Indicates that a file has been removed from its parent directory." } ; HELP: +modify-file+ -{ $description "Indicates that the file contents have changed." } ; +{ $description "Indicates that a file's contents have changed." } ; -HELP: +rename-file+ -{ $description "Indicates that file has been renamed." } ; +HELP: +rename-file-old+ +{ $description "Indicates that a file has been renamed, and this is the old name." } ; + +HELP: +rename-file-new+ +{ $description "Indicates that a file has been renamed, and this is the new name." } ; ARTICLE: "io.monitors.descriptors" "File system change descriptors" "Change descriptors output by " { $link next-change } ":" { $subsection +add-file+ } { $subsection +remove-file+ } { $subsection +modify-file+ } -{ $subsection +rename-file+ } -{ $subsection +add-file+ } ; +{ $subsection +rename-file-old+ } +{ $subsection +rename-file-new+ } ; + +ARTICLE: "io.monitors.platforms" "Monitors on different platforms" +"Whether the " { $snippet "path" } " output value of " { $link next-change } " contains an absolute path or a path relative to the path given to " { $link } " is platform-specific. User code should not assume either case." +{ $heading "Mac OS X" } +"Factor uses " { $snippet "FSEventStream" } "s to implement monitors on Mac OS X. This requires Mac OS X 10.5 or later." +$nl +{ $snippet "FSEventStream" } "s always monitor directory hierarchies recursively, and the " { $snippet "recursive?" } " parameter to " { $link } " has no effect." +$nl +"The " { $snippet "changed" } " output value of the " { $link next-change } " word always outputs " { $link +modify-file+ } " and the " { $snippet "path" } " output value is always the directory containing the file that changed. Unlike other platforms, fine-grained information is not available." +{ $heading "Windows" } +"Factor uses " { $snippet "ReadDirectoryChanges" } " to implement monitors on Windows." +$nl +"Both recursive and non-recursive monitors are directly supported by the operating system." +{ $heading "Linux" } +"Factor uses " { $snippet "inotify" } " to implement monitors on Linux. This requires Linux kernel version 2.6.16 or later." +$nl +"Since " { $snippet "inotify" } " can only monitor a single directory, Factor simulates recursive monitors by creating a hierarchy of monitors for every subdirectory. This is transparent to user code." +$nl +"Inside a single " { $link with-monitors } " scope, only one monitor may be created for any given directory." +{ $heading "BSD" } +"Factor uses " { $snippet "kqueue" } " to implement monitors on BSD." +$nl +"Since " { $snippet "kqueue" } " can only monitor a single directory, Factor simulates recursive monitors by creating a hierarchy of monitors for every subdirectory. This is transparent to user code." +$nl +"Because " { $snippet "kqueue" } " requires that a file descriptor is allocated for each directory being monitored, monitoring of large directory hierarchies may exhaust file descriptors or exhibit suboptimal performance. Furthermore, unmounting a subdirectory of a recursively-monitored directory is not possible." +{ $heading "Windows CE" } +"Windows CE does not support monitors." ; ARTICLE: "io.monitors" "File system change monitors" "File system change monitors listen for changes to file names, attributes and contents under a specified directory. They can optionally be recursive, in which case subdirectories are also monitored." $nl +"Monitoring operations must be wrapped in a combinator:" +{ $subsection with-monitors } "Creating a file system change monitor and listening for changes:" { $subsection } { $subsection next-change } +"An alternative programming style is where instead of having a thread listen for changes on a monitor, change notifications are posted to a mailbox:" +{ $subsection (monitor) } { $subsection "io.monitors.descriptors" } -"Monitors are closed by calling " { $link dispose } " or " { $link with-disposal } "." -$nl -"A utility combinator which opens a monitor and cleans it up after:" +{ $subsection "io.monitors.platforms" } +"Monitors are closed by calling " { $link dispose } " or " { $link with-disposal } ". An easy way to pair construction with disposal is to use a combinator:" { $subsection with-monitor } -"An example which watches the Factor directory for changes:" +"Monitors support the " { $link "io.timeouts" } "." +$nl +"An example which watches a directory for changes:" { $code "USE: io.monitors" ": watch-loop ( monitor -- )" " dup next-change . . nl nl flush watch-loop ;" "" - "\"\" resource-path f [ watch-loop ] with-monitor" + ": watch-directory ( path -- )" + " [ t [ watch-loop ] with-monitor ] with-monitors" } ; ABOUT: "io.monitors" diff --git a/extra/io/monitors/monitors-tests.factor b/extra/io/monitors/monitors-tests.factor index 7170e824c8..6f7478fce2 100644 --- a/extra/io/monitors/monitors-tests.factor +++ b/extra/io/monitors/monitors-tests.factor @@ -3,36 +3,89 @@ USING: io.monitors tools.test io.files system sequences continuations namespaces concurrency.count-downs kernel io threads calendar prettyprint ; -os { winnt macosx linux } member? [ - [ "monitor-test" temp-file delete-tree ] ignore-errors +os wince? [ + [ + [ "monitor-test" temp-file delete-tree ] ignore-errors - [ ] [ "monitor-test/xyz" temp-file make-directories ] unit-test + [ ] [ "monitor-test" temp-file make-directory ] unit-test - [ ] [ "monitor-test" temp-file t "m" set ] unit-test + [ ] [ "monitor-test" temp-file t "m" set ] unit-test - [ ] [ 1 "b" set ] unit-test + [ ] [ "monitor-test/a1" temp-file make-directory ] unit-test - [ ] [ 1 "c" set ] unit-test + [ ] [ "monitor-test/a2" temp-file make-directory ] unit-test - [ ] [ - [ - "b" get count-down - [ - "m" get next-change drop - dup print flush right-trim-separators - "xyz" tail? not - ] [ ] [ ] while - "c" get count-down - ] "Monitor test thread" spawn drop - ] unit-test + [ ] [ "monitor-test/a1" temp-file "monitor-test/a2" temp-file move-file-into ] unit-test - [ ] [ "b" get await ] unit-test + [ t ] [ "monitor-test/a2/a1" temp-file exists? ] unit-test - [ ] [ "monitor-test/xyz/test.txt" temp-file touch-file ] unit-test + [ ] [ "monitor-test/a2/a1/a3.txt" temp-file touch-file ] unit-test - [ ] [ "c" get 30 seconds await-timeout ] unit-test + [ t ] [ "monitor-test/a2/a1/a3.txt" temp-file exists? ] unit-test - [ ] [ "m" get dispose ] unit-test + [ ] [ "monitor-test/a2/a1/a4.txt" temp-file touch-file ] unit-test + [ ] [ "monitor-test/a2/a1/a5.txt" temp-file touch-file ] unit-test + [ ] [ "monitor-test/a2/a1/a4.txt" temp-file delete-file ] unit-test + [ ] [ "monitor-test/a2/a1/a5.txt" temp-file "monitor-test/a2/a1/a4.txt" temp-file move-file ] unit-test - [ "m" get dispose ] must-fail -] when + [ t ] [ "monitor-test/a2/a1/a4.txt" temp-file exists? ] unit-test + + [ ] [ "m" get dispose ] unit-test + ] with-monitors + + + [ + [ "monitor-test" temp-file delete-tree ] ignore-errors + + [ ] [ "monitor-test/xyz" temp-file make-directories ] unit-test + + [ ] [ "monitor-test" temp-file t "m" set ] unit-test + + [ ] [ 1 "b" set ] unit-test + + [ ] [ 1 "c1" set ] unit-test + + [ ] [ 1 "c2" set ] unit-test + + [ ] [ + [ + "b" get count-down + + [ + "m" get next-change drop + dup print flush + dup parent-directory + [ right-trim-separators "xyz" tail? ] either? not + ] [ ] [ ] while + + "c1" get count-down + + [ + "m" get next-change drop + dup print flush + dup parent-directory + [ right-trim-separators "yxy" tail? ] either? not + ] [ ] [ ] while + + "c2" get count-down + ] "Monitor test thread" spawn drop + ] unit-test + + [ ] [ "b" get await ] unit-test + + [ ] [ "monitor-test/xyz/test.txt" temp-file touch-file ] unit-test + + [ ] [ "c1" get 5 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 + + ! Dispose twice + [ ] [ "m" get dispose ] unit-test + + [ ] [ "m" get dispose ] unit-test + ] with-monitors +] unless diff --git a/extra/io/monitors/monitors.factor b/extra/io/monitors/monitors.factor index 1678c2de41..8128acfea8 100755 --- a/extra/io/monitors/monitors.factor +++ b/extra/io/monitors/monitors.factor @@ -1,83 +1,49 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: io.backend kernel continuations namespaces sequences -assocs hashtables sorting arrays threads boxes io.timeouts ; +assocs hashtables sorting arrays threads boxes io.timeouts +accessors concurrency.mailboxes ; IN: io.monitors -array ; - -M: monitor dispose - dup check-monitor - t over set-monitor-closed? - delegate dispose ; - -! Simple monitor; used on Linux and Mac OS X. On Windows, -! monitors are full-fledged ports. -TUPLE: simple-monitor handle callback timeout ; - -M: simple-monitor timeout simple-monitor-timeout ; - -M: simple-monitor set-timeout set-simple-monitor-timeout ; - -: ( handle -- simple-monitor ) - f (monitor) { - set-simple-monitor-handle - set-delegate - set-simple-monitor-callback - } simple-monitor construct ; - -: construct-simple-monitor ( handle class -- simple-monitor ) - >r r> construct-delegate ; inline - -: notify-callback ( simple-monitor -- ) - simple-monitor-callback [ resume ] if-box? ; - -M: simple-monitor timed-out - notify-callback ; - -M: simple-monitor fill-queue ( monitor -- ) +: with-monitors ( quot -- ) [ - [ swap simple-monitor-callback >box ] - "monitor" suspend drop - ] with-timeout - check-monitor ; + init-monitors + [ dispose-monitors ] [ ] cleanup + ] with-scope ; inline -M: simple-monitor dispose ( monitor -- ) - dup delegate dispose notify-callback ; +TUPLE: monitor < identity-tuple path queue timeout ; -PRIVATE> +M: monitor hashcode* path>> hashcode* ; -HOOK: io-backend ( path recursive? -- monitor ) +M: monitor timeout timeout>> ; + +M: monitor set-timeout (>>timeout) ; + +: construct-monitor ( path mailbox class -- monitor ) + construct-empty + swap >>queue + swap >>path ; inline + +: queue-change ( path changes monitor -- ) + dup [ [ 3array ] keep queue>> mailbox-put ] [ 3drop ] if ; + +HOOK: (monitor) io-backend ( path recursive? mailbox -- monitor ) + +: ( path recursive? -- monitor ) + (monitor) ; : next-change ( monitor -- path changed ) - dup check-monitor - dup monitor-queue dup assoc-empty? [ - drop dup fill-queue next-change - ] [ nip dequeue-change ] if ; + [ queue>> ] [ timeout ] bi mailbox-get-timeout first2 ; SYMBOL: +add-file+ SYMBOL: +remove-file+ SYMBOL: +modify-file+ -SYMBOL: +rename-file+ +SYMBOL: +rename-file-old+ +SYMBOL: +rename-file-new+ : with-monitor ( path recursive? quot -- ) >r r> with-disposal ; inline diff --git a/extra/io/monitors/recursive/recursive-tests.factor b/extra/io/monitors/recursive/recursive-tests.factor new file mode 100644 index 0000000000..3182747194 --- /dev/null +++ b/extra/io/monitors/recursive/recursive-tests.factor @@ -0,0 +1,59 @@ +USING: accessors math kernel namespaces continuations +io.files io.monitors io.monitors.recursive io.backend +concurrency.mailboxes +tools.test ; +IN: io.monitors.recursive.tests + +\ pump-thread must-infer + +SINGLETON: mock-io-backend + +TUPLE: counter i ; + +SYMBOL: dummy-monitor-created +SYMBOL: dummy-monitor-disposed + +TUPLE: dummy-monitor < monitor ; + +M: dummy-monitor dispose + drop dummy-monitor-disposed get [ 1+ ] change-i drop ; + +M: mock-io-backend (monitor) + nip + over exists? [ + dummy-monitor construct-monitor + dummy-monitor-created get [ 1+ ] change-i drop + ] [ + "Does not exist" throw + ] if ; + +M: mock-io-backend link-info + global [ link-info ] bind ; + +[ ] [ 0 counter construct-boa dummy-monitor-created set ] unit-test +[ ] [ 0 counter construct-boa dummy-monitor-disposed set ] unit-test + +[ ] [ + mock-io-backend io-backend [ + "" resource-path dispose + ] with-variable +] unit-test + +[ t ] [ dummy-monitor-created get i>> 0 > ] unit-test + +[ t ] [ dummy-monitor-created get i>> dummy-monitor-disposed get i>> = ] unit-test + +[ "doesnotexist" temp-file delete-tree ] ignore-errors + +[ + mock-io-backend io-backend [ + "doesnotexist" temp-file dispose + ] with-variable +] must-fail + +[ ] [ + mock-io-backend io-backend [ + "" resource-path + [ dispose ] [ dispose ] bi + ] with-variable +] unit-test diff --git a/extra/io/monitors/recursive/recursive.factor b/extra/io/monitors/recursive/recursive.factor new file mode 100644 index 0000000000..8c2560f681 --- /dev/null +++ b/extra/io/monitors/recursive/recursive.factor @@ -0,0 +1,105 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors sequences assocs arrays continuations combinators kernel +threads concurrency.messaging concurrency.mailboxes +concurrency.promises +io.files io.monitors ; +IN: io.monitors.recursive + +! Simulate recursive monitors on platforms that don't have them + +TUPLE: recursive-monitor < monitor children thread ready ; + +DEFER: add-child-monitor + +: qualify-path ( path -- path' ) + monitor tget path>> prepend-path ; + +: add-child-monitors ( path -- ) + #! We yield since this directory scan might take a while. + [ + directory* [ first add-child-monitor yield ] each + ] curry ignore-errors ; + +: add-child-monitor ( path -- ) + qualify-path dup link-info type>> +directory+ eq? [ + [ add-child-monitors ] + [ + [ f my-mailbox (monitor) ] keep + monitor tget children>> set-at + ] bi + ] [ drop ] if ; + +USE: io +USE: prettyprint + +: remove-child-monitor ( monitor -- ) + monitor tget children>> delete-at* + [ dispose ] [ drop ] if ; + +M: recursive-monitor dispose + dup queue>> closed>> [ + drop + ] [ + [ "stop" swap thread>> send-synchronous drop ] + [ queue>> dispose ] bi + ] if ; + +: stop-pump ( -- ) + monitor tget children>> [ nip dispose ] assoc-each ; + +: pump-step ( msg -- ) + first3 path>> swap >r prepend-path r> monitor tget 3array + monitor tget queue>> + mailbox-put ; + +: child-added ( path monitor -- ) + path>> prepend-path add-child-monitor ; + +: child-removed ( path monitor -- ) + path>> prepend-path remove-child-monitor ; + +: update-hierarchy ( msg -- ) + first3 swap [ + { + { +add-file+ [ child-added ] } + { +remove-file+ [ child-removed ] } + { +rename-file-old+ [ child-removed ] } + { +rename-file-new+ [ child-added ] } + [ 3drop ] + } case + ] with with each ; + +: pump-loop ( -- ) + receive dup synchronous? [ + >r stop-pump t r> reply-synchronous + ] [ + [ [ update-hierarchy ] curry ignore-errors ] [ pump-step ] bi + pump-loop + ] if ; + +: monitor-ready ( error/t -- ) + monitor tget ready>> fulfill ; + +: pump-thread ( monitor -- ) + monitor tset + [ "" add-child-monitor t monitor-ready ] + [ [ self monitor-ready ] keep rethrow ] + recover + pump-loop ; + +: start-pump-thread ( monitor -- ) + dup [ pump-thread ] curry + "Recursive monitor pump" spawn + >>thread drop ; + +: wait-for-ready ( monitor -- ) + ready>> ?promise ?linked drop ; + +: ( path mailbox -- monitor ) + >r (normalize-path) r> + recursive-monitor construct-monitor + H{ } clone >>children + >>ready + dup start-pump-thread + dup wait-for-ready ; diff --git a/extra/io/timeouts/timeouts-docs.factor b/extra/io/timeouts/timeouts-docs.factor index df7e1389cc..64104083be 100755 --- a/extra/io/timeouts/timeouts-docs.factor +++ b/extra/io/timeouts/timeouts-docs.factor @@ -18,13 +18,13 @@ HELP: with-timeout { $description "Applies the quotation to the object. If the object's timeout expires before the quotation returns, " { $link timed-out } " is called on the object." } ; ARTICLE: "io.timeouts" "I/O timeout protocol" -"Streams and processes support optional timeouts, which impose an upper bound on the length of time for which an operation on these objects can block. Timeouts are used in network servers to prevent malicious clients from holding onto connections forever, and to ensure that runaway processes get killed." +"Streams, processes and monitors support optional timeouts, which impose an upper bound on the length of time for which an operation on these objects can block. Timeouts are used in network servers to prevent malicious clients from holding onto connections forever, and to ensure that runaway processes get killed." { $subsection timeout } { $subsection set-timeout } "The I/O timeout protocol can be implemented by any class wishing to support timeouts on blocking operations." { $subsection timed-out } "A combinator to be used in operations which can time out:" { $subsection with-timeout } -{ $see-also "stream-protocol" "io.launcher" } ; +{ $see-also "stream-protocol" "io.launcher" "io.monitors" } ; ABOUT: "io.timeouts" diff --git a/extra/io/unix/linux/linux.factor b/extra/io/unix/linux/linux.factor index 30c61f6d21..e75f4c5f6b 100755 --- a/extra/io/unix/linux/linux.factor +++ b/extra/io/unix/linux/linux.factor @@ -1,125 +1,10 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel io.backend io.monitors io.monitors.private -io.files io.buffers io.nonblocking io.timeouts io.unix.backend -io.unix.select io.unix.launcher unix.linux.inotify assocs -namespaces threads continuations init math alien.c-types alien -vocabs.loader accessors system ; +USING: kernel io.backend io.monitors io.unix.backend +io.unix.select io.unix.linux.monitors system namespaces ; IN: io.unix.linux -TUPLE: linux-monitor ; - -: ( wd -- monitor ) - linux-monitor construct-simple-monitor ; - -TUPLE: inotify watches ; - -: watches ( -- assoc ) inotify get-global watches>> ; - -: wd>monitor ( wd -- monitor ) watches at ; - -: ( -- port/f ) - H{ } clone - inotify_init dup 0 < [ 2drop f ] [ - inotify - { set-inotify-watches set-delegate } inotify construct - ] if ; - -: inotify-fd inotify get-global handle>> ; - -: (add-watch) ( path mask -- wd ) - inotify-fd -rot inotify_add_watch dup io-error ; - -: check-existing ( wd -- ) - watches key? [ - "Cannot open multiple monitors for the same file" throw - ] when ; - -: add-watch ( path mask -- monitor ) - (add-watch) dup check-existing - [ dup ] keep watches set-at ; - -: remove-watch ( monitor -- ) - dup simple-monitor-handle watches delete-at - simple-monitor-handle inotify-fd swap inotify_rm_watch io-error ; - -: check-inotify - inotify get [ - "inotify is not supported by this Linux release" throw - ] unless ; - -M: linux ( path recursive? -- monitor ) - check-inotify - drop IN_CHANGE_EVENTS add-watch ; - -M: linux-monitor dispose ( monitor -- ) - dup delegate dispose remove-watch ; - -: ?flag ( n mask symbol -- n ) - pick rot bitand 0 > [ , ] [ drop ] if ; - -: parse-action ( mask -- changed ) - [ - IN_CREATE +add-file+ ?flag - IN_DELETE +remove-file+ ?flag - IN_DELETE_SELF +remove-file+ ?flag - IN_MODIFY +modify-file+ ?flag - IN_ATTRIB +modify-file+ ?flag - IN_MOVED_FROM +rename-file+ ?flag - IN_MOVED_TO +rename-file+ ?flag - IN_MOVE_SELF +rename-file+ ?flag - drop - ] { } make ; - -: parse-file-notify ( buffer -- changed path ) - { inotify-event-name inotify-event-mask } get-slots - parse-action swap alien>char-string ; - -: events-exhausted? ( i buffer -- ? ) - fill>> >= ; - -: inotify-event@ ( i buffer -- alien ) - ptr>> ; - -: next-event ( i buffer -- i buffer ) - 2dup inotify-event@ - inotify-event-len "inotify-event" heap-size + - swap >r + r> ; - -: parse-file-notifications ( i buffer -- ) - 2dup events-exhausted? [ 2drop ] [ - 2dup inotify-event@ dup inotify-event-wd wd>monitor [ - monitor-queue [ - parse-file-notify changed-file - ] bind - ] keep notify-callback - next-event parse-file-notifications - ] if ; - -: read-notifications ( port -- ) - dup refill drop - 0 over parse-file-notifications - 0 swap buffer-reset ; - -TUPLE: inotify-task ; - -: ( port -- task ) - f inotify-task ; - -: init-inotify ( mx -- ) - dup [ - dup inotify set-global - swap register-io-task - ] [ - 2drop - ] if ; - -M: inotify-task do-io-task ( task -- ) - io-task-port read-notifications f ; - M: linux init-io ( -- ) - - [ mx set-global ] - [ init-inotify ] bi ; + mx set-global ; linux set-io-backend diff --git a/extra/io/unix/linux/monitors/monitors.factor b/extra/io/unix/linux/monitors/monitors.factor new file mode 100644 index 0000000000..5f23199146 --- /dev/null +++ b/extra/io/unix/linux/monitors/monitors.factor @@ -0,0 +1,129 @@ +! 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.unix.backend io.unix.select unix.linux.inotify assocs +namespaces threads continuations init math math.bitfields +alien.c-types alien vocabs.loader accessors system ; +IN: io.unix.linux.monitors + +TUPLE: linux-monitor < monitor wd ; + +: ( wd path mailbox -- monitor ) + linux-monitor construct-monitor + swap >>wd ; + +SYMBOL: watches + +SYMBOL: inotify + +: wd>monitor ( wd -- monitor ) watches get at ; + +: ( -- port/f ) + inotify_init dup 0 < [ drop f ] [ ] if ; + +: inotify-fd inotify get handle>> ; + +: check-existing ( wd -- ) + watches get key? [ + "Cannot open multiple monitors for the same file" throw + ] when ; + +: (add-watch) ( path mask -- wd ) + inotify-fd -rot inotify_add_watch dup io-error dup check-existing ; + +: add-watch ( path mask mailbox -- monitor ) + >r + >r (normalize-path) r> + [ (add-watch) ] [ drop ] 2bi r> + [ ] [ ] [ wd>> ] tri watches get set-at ; + +: check-inotify + inotify get [ + "Calling outside with-monitors" throw + ] unless ; + +M: linux (monitor) ( path recursive? mailbox -- monitor ) + swap [ + + ] [ + check-inotify + IN_CHANGE_EVENTS swap add-watch + ] if ; + +M: linux-monitor dispose ( monitor -- ) + [ wd>> watches get delete-at ] + [ wd>> inotify-fd swap inotify_rm_watch io-error ] bi ; + +: ?flag ( n mask symbol -- n ) + pick rot bitand 0 > [ , ] [ drop ] if ; + +: ignore-flags? ( mask -- ? ) + { + IN_DELETE_SELF + IN_MOVE_SELF + IN_UNMOUNT + IN_Q_OVERFLOW + IN_IGNORED + } flags bitand 0 > ; + +: parse-action ( mask -- changed ) + [ + IN_CREATE +add-file+ ?flag + IN_DELETE +remove-file+ ?flag + IN_MODIFY +modify-file+ ?flag + IN_ATTRIB +modify-file+ ?flag + IN_MOVED_FROM +rename-file-old+ ?flag + IN_MOVED_TO +rename-file-new+ ?flag + drop + ] { } make ; + +: parse-file-notify ( buffer -- path changed ) + dup inotify-event-mask ignore-flags? [ + drop f f + ] [ + [ inotify-event-name alien>char-string ] + [ inotify-event-mask parse-action ] bi + ] if ; + +: events-exhausted? ( i buffer -- ? ) + fill>> >= ; + +: inotify-event@ ( i buffer -- alien ) + ptr>> ; + +: next-event ( i buffer -- i buffer ) + 2dup inotify-event@ + inotify-event-len "inotify-event" heap-size + + swap >r + r> ; + +: parse-file-notifications ( i buffer -- ) + 2dup events-exhausted? [ 2drop ] [ + 2dup inotify-event@ dup inotify-event-wd wd>monitor + >r parse-file-notify r> queue-change + next-event parse-file-notifications + ] if ; + +: inotify-read-loop ( port -- ) + dup wait-to-read1 + 0 over parse-file-notifications + 0 over buffer-reset + inotify-read-loop ; + +: inotify-read-thread ( port -- ) + [ inotify-read-loop ] curry ignore-errors ; + +M: linux init-monitors + H{ } clone watches set + [ + [ inotify set ] + [ + [ inotify-read-thread ] curry + "Linux monitor thread" spawn drop + ] bi + ] [ + "Linux kernel version is too old" throw + ] if* ; + +M: linux dispose-monitors + inotify get dispose ; diff --git a/extra/io/unix/macosx/macosx.factor b/extra/io/unix/macosx/macosx.factor index c1c73ea018..039b1b250b 100644 --- a/extra/io/unix/macosx/macosx.factor +++ b/extra/io/unix/macosx/macosx.factor @@ -1,23 +1,22 @@ -USING: io.unix.bsd io.backend io.monitors io.monitors.private -continuations kernel core-foundation.fsevents sequences -namespaces arrays system ; +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: io.unix.bsd io.backend io.monitors core-foundation.fsevents +continuations kernel sequences namespaces arrays system locals ; IN: io.unix.macosx macosx set-io-backend -TUPLE: macosx-monitor ; +TUPLE: macosx-monitor < monitor handle ; : enqueue-notifications ( triples monitor -- ) tuck monitor-queue [ [ first { +modify-file+ } swap changed-file ] each ] bind notify-callback ; -M: macosx - drop - f macosx-monitor construct-simple-monitor +M:: macosx (monitor) ( path recursive? mailbox -- monitor ) + path mailbox macosx-monitor construct-monitor dup [ enqueue-notifications ] curry - rot 1array 0 0 - over set-simple-monitor-handle ; + path 1array 0 0 >>handle ; M: macosx-monitor dispose - dup simple-monitor-handle dispose delegate dispose ; + handle>> dispose ; diff --git a/extra/io/unix/select/select.factor b/extra/io/unix/select/select.factor index aceee0f311..6527a87010 100755 --- a/extra/io/unix/select/select.factor +++ b/extra/io/unix/select/select.factor @@ -29,7 +29,6 @@ TUPLE: select-mx read-fdset write-fdset ; [ handle-fd ] 2curry assoc-each ; : init-fdset ( tasks fdset -- ) - ! dup clear-bits [ >r drop t swap munge r> set-nth ] curry assoc-each ; : read-fdset/tasks @@ -45,9 +44,9 @@ TUPLE: select-mx read-fdset write-fdset ; [ reads>> max-fd ] [ writes>> max-fd ] bi max 1+ ; : init-fdsets ( mx -- nfds read write except ) - [ num-fds ] keep - [ read-fdset/tasks tuck init-fdset ] keep - write-fdset/tasks tuck init-fdset + [ num-fds ] + [ read-fdset/tasks tuck init-fdset ] + [ write-fdset/tasks tuck init-fdset ] tri f ; M: select-mx wait-for-events ( ms mx -- ) diff --git a/extra/tools/threads/threads.factor b/extra/tools/threads/threads.factor index 552247e2c4..060377d127 100755 --- a/extra/tools/threads/threads.factor +++ b/extra/tools/threads/threads.factor @@ -22,7 +22,7 @@ heaps.private system math math.parser ; : threads. ( -- ) standard-table-style [ [ - { "ID" "Name" "Waiting on" "Remaining sleep" } + { "ID:" "Name:" "Waiting on:" "Remaining sleep:" } [ [ write ] with-cell ] each ] with-row diff --git a/extra/tools/vocabs/monitor/monitor.factor b/extra/tools/vocabs/monitor/monitor.factor index f763a1520d..ab5e8c66b7 100755 --- a/extra/tools/vocabs/monitor/monitor.factor +++ b/extra/tools/vocabs/monitor/monitor.factor @@ -22,22 +22,29 @@ IN: tools.vocabs.monitor : path>vocab ( path -- vocab ) chop-vocab-root path>vocab-name vocab-dir>vocab-name ; -: monitor-thread ( monitor -- ) +: monitor-loop ( monitor -- ) #! On OS X, monitors give us the full path, so we chop it #! off if its there. - next-change drop path>vocab changed-vocab reset-cache ; + dup next-change drop path>vocab changed-vocab + reset-cache + monitor-loop ; + +: monitor-thread ( -- ) + [ + [ + "" resource-path t + + H{ } clone changed-vocabs set-global + vocabs [ changed-vocab ] each + + monitor-loop + ] with-monitors + ] ignore-errors ; : start-monitor-thread ( -- ) #! Silently ignore errors during monitor creation since #! monitors are not supported on all platforms. - [ - "" resource-path t [ monitor-thread t ] curry - "Vocabulary monitor" spawn-server drop - - H{ } clone changed-vocabs set-global - - vocabs [ changed-vocab ] each - ] ignore-errors ; + [ monitor-thread ] "Vocabulary monitor" spawn drop ; [ "-no-monitors" cli-args member? [ diff --git a/extra/tools/vocabs/vocabs-tests.factor b/extra/tools/vocabs/vocabs-tests.factor index ae74d516e4..04e628d080 100644 --- a/extra/tools/vocabs/vocabs-tests.factor +++ b/extra/tools/vocabs/vocabs-tests.factor @@ -4,5 +4,6 @@ USING: tools.test tools.vocabs namespaces continuations ; [ ] [ changed-vocabs get-global f changed-vocabs set-global + [ t ] [ "kernel" changed-vocab? ] unit-test [ "kernel" changed-vocab ] [ changed-vocabs set-global ] [ ] cleanup ] unit-test diff --git a/extra/tools/vocabs/vocabs.factor b/extra/tools/vocabs/vocabs.factor index 371bbc7813..a65a8f093a 100755 --- a/extra/tools/vocabs/vocabs.factor +++ b/extra/tools/vocabs/vocabs.factor @@ -85,10 +85,11 @@ SYMBOL: changed-vocabs : unchanged-vocabs ( vocabs -- ) [ unchanged-vocab ] each ; +: changed-vocab? ( vocab -- ? ) + changed-vocabs get dup [ key? ] [ 2drop t ] if ; + : filter-changed ( vocabs -- vocabs' ) - changed-vocabs get [ - [ key? ] curry subset - ] when* ; + [ changed-vocab? ] subset ; SYMBOL: modified-sources SYMBOL: modified-docs @@ -96,7 +97,7 @@ SYMBOL: modified-docs : (to-refresh) ( vocab variable loaded? path -- ) dup [ swap [ - pick changed-vocabs get key? [ + pick changed-vocab? [ source-modified? [ get push ] [ 2drop ] if ] [ 3drop ] if ] [ drop get push ] if From 0c7e742b8c9796d5352b5721001245f68e9a13cb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 11 Apr 2008 08:35:07 -0500 Subject: [PATCH 007/109] step-into for hooks --- core/generic/standard/standard.factor | 10 ++++++++-- extra/tools/walker/walker.factor | 1 + 2 files changed, 9 insertions(+), 2 deletions(-) diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index ed5134a624..98194e7ef3 100644 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -110,6 +110,9 @@ ERROR: no-next-method class generic ; \ if , ] [ ] make ; +: single-effective-method ( obj word -- method ) + [ order [ instance? ] with find-last nip ] keep method ; + TUPLE: standard-combination # ; C: standard-combination @@ -142,8 +145,7 @@ M: standard-combination next-method-quot* ] with-standard ; M: standard-generic effective-method - [ dispatch# (picker) call ] keep - [ order [ instance? ] with find-last nip ] keep method ; + [ dispatch# (picker) call ] keep single-effective-method ; TUPLE: hook-combination var ; @@ -161,6 +163,10 @@ M: hook-combination dispatch# drop 0 ; M: hook-generic extra-values drop 1 ; +M: hook-generic effective-method + [ "combination" word-prop var>> get ] keep + single-effective-method ; + M: hook-combination make-default-method [ error-method ] with-hook ; diff --git a/extra/tools/walker/walker.factor b/extra/tools/walker/walker.factor index 4d1a4da6b1..42c8f93e4c 100755 --- a/extra/tools/walker/walker.factor +++ b/extra/tools/walker/walker.factor @@ -72,6 +72,7 @@ M: object add-breakpoint ; { { [ dup "step-into" word-prop ] [ "step-into" word-prop call ] } { [ dup standard-generic? ] [ effective-method (step-into-execute) ] } + { [ dup hook-generic? ] [ effective-method (step-into-execute) ] } { [ dup primitive? ] [ execute break ] } { [ t ] [ word-def (step-into-quot) ] } } cond ; From 82d793b14183ab06e597738811e6950f8848c599 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 11 Apr 2008 08:35:21 -0500 Subject: [PATCH 008/109] Update Mac OS X monitors for new API --- extra/core-foundation/fsevents/fsevents.factor | 4 +--- extra/io/monitors/monitors.factor | 3 ++- extra/io/unix/macosx/macosx.factor | 17 +++++++++++------ 3 files changed, 14 insertions(+), 10 deletions(-) diff --git a/extra/core-foundation/fsevents/fsevents.factor b/extra/core-foundation/fsevents/fsevents.factor index 55f2462061..f181d8a761 100644 --- a/extra/core-foundation/fsevents/fsevents.factor +++ b/extra/core-foundation/fsevents/fsevents.factor @@ -151,12 +151,10 @@ SYMBOL: event-stream-callbacks [ event-stream-callbacks global - [ [ drop expired? not ] assoc-subset ] change-at + [ [ drop expired? not ] assoc-subset H{ } assoc-like ] change-at 1 \ event-stream-counter set-global ] "core-foundation" add-init-hook -event-stream-callbacks global [ H{ } assoc-like ] change-at - : add-event-source-callback ( quot -- id ) event-stream-counter [ event-stream-callbacks get set-at ] keep ; diff --git a/extra/io/monitors/monitors.factor b/extra/io/monitors/monitors.factor index 8128acfea8..8d2ddba5f2 100755 --- a/extra/io/monitors/monitors.factor +++ b/extra/io/monitors/monitors.factor @@ -29,7 +29,8 @@ M: monitor set-timeout (>>timeout) ; swap >>path ; inline : queue-change ( path changes monitor -- ) - dup [ [ 3array ] keep queue>> mailbox-put ] [ 3drop ] if ; + 3dup and and + [ [ 3array ] keep queue>> mailbox-put ] [ 3drop ] if ; HOOK: (monitor) io-backend ( path recursive? mailbox -- monitor ) diff --git a/extra/io/unix/macosx/macosx.factor b/extra/io/unix/macosx/macosx.factor index 039b1b250b..68eb2f13bb 100644 --- a/extra/io/unix/macosx/macosx.factor +++ b/extra/io/unix/macosx/macosx.factor @@ -1,17 +1,20 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: io.unix.bsd io.backend io.monitors core-foundation.fsevents -continuations kernel sequences namespaces arrays system locals ; +continuations kernel sequences namespaces arrays system locals +accessors ; IN: io.unix.macosx -macosx set-io-backend - TUPLE: macosx-monitor < monitor handle ; : enqueue-notifications ( triples monitor -- ) - tuck monitor-queue - [ [ first { +modify-file+ } swap changed-file ] each ] bind - notify-callback ; + [ + >r first { +modify-file+ } r> queue-change + ] curry each ; + +M: macosx init-monitors ; + +M: macosx dispose-monitors ; M:: macosx (monitor) ( path recursive? mailbox -- monitor ) path mailbox macosx-monitor construct-monitor @@ -20,3 +23,5 @@ M:: macosx (monitor) ( path recursive? mailbox -- monitor ) M: macosx-monitor dispose handle>> dispose ; + +macosx set-io-backend From d132bce5a3603eb9df65f390cce6301c5903adff Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 11 Apr 2008 09:54:50 -0500 Subject: [PATCH 009/109] Implement monitors for BSD --- extra/io/monitors/monitors-docs.factor | 6 +- extra/io/monitors/monitors-tests.factor | 4 +- extra/io/monitors/monitors.factor | 1 + extra/io/unix/backend/backend.factor | 3 + extra/io/unix/bsd/bsd.factor | 19 +++- extra/io/unix/kqueue/kqueue.factor | 104 +++++++++++++++---- extra/io/unix/linux/monitors/monitors.factor | 5 +- 7 files changed, 113 insertions(+), 29 deletions(-) mode change 100755 => 100644 extra/io/unix/backend/backend.factor mode change 100755 => 100644 extra/io/unix/kqueue/kqueue.factor diff --git a/extra/io/monitors/monitors-docs.factor b/extra/io/monitors/monitors-docs.factor index ae561cd666..df4f7ae352 100755 --- a/extra/io/monitors/monitors-docs.factor +++ b/extra/io/monitors/monitors-docs.factor @@ -42,13 +42,17 @@ HELP: +rename-file-old+ HELP: +rename-file-new+ { $description "Indicates that a file has been renamed, and this is the new name." } ; +HELP: +rename-file+ +{ $description "Indicates that a file has been renamed." } ; + ARTICLE: "io.monitors.descriptors" "File system change descriptors" "Change descriptors output by " { $link next-change } ":" { $subsection +add-file+ } { $subsection +remove-file+ } { $subsection +modify-file+ } { $subsection +rename-file-old+ } -{ $subsection +rename-file-new+ } ; +{ $subsection +rename-file-new+ } +{ $subsection +rename-file+ } ; ARTICLE: "io.monitors.platforms" "Monitors on different platforms" "Whether the " { $snippet "path" } " output value of " { $link next-change } " contains an absolute path or a path relative to the path given to " { $link } " is platform-specific. User code should not assume either case." diff --git a/extra/io/monitors/monitors-tests.factor b/extra/io/monitors/monitors-tests.factor index 6f7478fce2..0216baf699 100644 --- a/extra/io/monitors/monitors-tests.factor +++ b/extra/io/monitors/monitors-tests.factor @@ -3,7 +3,7 @@ USING: io.monitors tools.test io.files system sequences continuations namespaces concurrency.count-downs kernel io threads calendar prettyprint ; -os wince? [ +os { winnt linux macosx } member? [ [ [ "monitor-test" temp-file delete-tree ] ignore-errors @@ -88,4 +88,4 @@ os wince? [ [ ] [ "m" get dispose ] unit-test ] with-monitors -] unless +] when diff --git a/extra/io/monitors/monitors.factor b/extra/io/monitors/monitors.factor index 8d2ddba5f2..51cbdd5b1b 100755 --- a/extra/io/monitors/monitors.factor +++ b/extra/io/monitors/monitors.factor @@ -45,6 +45,7 @@ SYMBOL: +remove-file+ SYMBOL: +modify-file+ SYMBOL: +rename-file-old+ SYMBOL: +rename-file-new+ +SYMBOL: +rename-file+ : with-monitor ( path recursive? quot -- ) >r r> with-disposal ; inline diff --git a/extra/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor old mode 100755 new mode 100644 index 865490b0ce..0fb8b0c5f2 --- a/extra/io/unix/backend/backend.factor +++ b/extra/io/unix/backend/backend.factor @@ -203,3 +203,6 @@ M: mx-task do-io-task : multiplexer-error ( n -- ) 0 < [ err_no ignorable-error? [ (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 12a64a41f9..03723a65e5 100755 --- a/extra/io/unix/bsd/bsd.factor +++ b/extra/io/unix/bsd/bsd.factor @@ -1,8 +1,21 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: io.unix.bsd -USING: io.backend io.unix.backend io.unix.select -namespaces system ; +USING: namespaces system kernel accessors assocs continuations +unix +io.backend io.unix.backend io.unix.select io.unix.kqueue io.monitors ; M: bsd init-io ( -- ) - mx set-global ; + 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 init-monitors ; + +M: bsd dispose-monitors ; + +M: bsd (monitor) ( path recursive? mailbox -- ) + nip ; diff --git a/extra/io/unix/kqueue/kqueue.factor b/extra/io/unix/kqueue/kqueue.factor old mode 100755 new mode 100644 index 97b186edf3..3735caa7d2 --- a/extra/io/unix/kqueue/kqueue.factor +++ b/extra/io/unix/kqueue/kqueue.factor @@ -1,12 +1,14 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types kernel io.nonblocking io.unix.backend -sequences assocs unix unix.time unix.kqueue unix.process math namespaces -combinators threads vectors io.launcher -io.unix.launcher ; +USING: alien.c-types kernel math math.bitfields namespaces +locals accessors combinators threads vectors hashtables +sequences assocs continuations +unix unix.time unix.kqueue unix.process +io.nonblocking io.unix.backend io.launcher io.unix.launcher +io.monitors ; IN: io.unix.kqueue -TUPLE: kqueue-mx events ; +TUPLE: kqueue-mx events monitors ; : max-events ( -- n ) #! We read up to 256 events at a time. This is an arbitrary @@ -15,8 +17,9 @@ TUPLE: kqueue-mx events ; : ( -- mx ) kqueue-mx construct-mx - kqueue dup io-error over set-mx-fd - max-events "kevent" over set-kqueue-mx-events ; + H{ } clone >>monitors + kqueue dup io-error >>fd + max-events "kevent" >>events ; GENERIC: io-task-filter ( task -- n ) @@ -24,14 +27,19 @@ M: input-task io-task-filter drop EVFILT_READ ; M: output-task io-task-filter drop EVFILT_WRITE ; +GENERIC: io-task-fflags ( task -- n ) + +M: io-task io-task-fflags drop 0 ; + : make-kevent ( task flags -- event ) "kevent" tuck set-kevent-flags over io-task-fd over set-kevent-ident + over io-task-fflags over set-kevent-fflags swap io-task-filter over set-kevent-filter ; : register-kevent ( kevent mx -- ) - mx-fd swap 1 f 0 f kevent + fd>> swap 1 f 0 f kevent 0 < [ err_no ESRCH = [ (io-error) ] unless ] when ; M: kqueue-mx register-io-task ( task mx -- ) @@ -43,33 +51,52 @@ M: kqueue-mx unregister-io-task ( task mx -- ) swap EV_DELETE make-kevent swap register-kevent ; : wait-kevent ( mx timespec -- n ) - >r dup mx-fd f 0 roll kqueue-mx-events max-events r> kevent + >r [ fd>> f 0 ] keep events>> max-events r> kevent dup multiplexer-error ; -: kevent-read-task ( mx fd -- ) - over mx-reads at handle-io-task ; +:: kevent-read-task ( mx fd kevent -- ) + mx fd mx reads>> at handle-io-task ; -: kevent-write-task ( mx fd -- ) - over mx-reads at handle-io-task ; +:: kevent-write-task ( mx fd kevent -- ) + mx fd mx writes>> at handle-io-task ; -: kevent-proc-task ( pid -- ) - dup wait-for-pid swap find-process +:: kevent-proc-task ( mx pid kevent -- ) + pid wait-for-pid + pid find-process dup [ swap notify-exit ] [ 2drop ] if ; +: parse-action ( mask -- changed ) + [ + NOTE_DELETE +remove-file+ ?flag + NOTE_WRITE +modify-file+ ?flag + NOTE_EXTEND +modify-file+ ?flag + NOTE_ATTRIB +modify-file+ ?flag + NOTE_RENAME +rename-file+ ?flag + NOTE_REVOKE +remove-file+ ?flag + drop + ] { } make prune ; + +:: kevent-vnode-task ( mx kevent fd -- ) + "" + kevent kevent-fflags parse-action + fd mx monitors>> at queue-change ; + : handle-kevent ( mx kevent -- ) - dup kevent-ident swap kevent-filter { + [ ] [ kevent-ident ] [ kevent-filter ] tri { { [ dup EVFILT_READ = ] [ drop kevent-read-task ] } { [ dup EVFILT_WRITE = ] [ drop kevent-write-task ] } - { [ dup EVFILT_PROC = ] [ drop kevent-proc-task drop ] } + { [ dup EVFILT_PROC = ] [ drop kevent-proc-task ] } + { [ dup EVFILT_VNODE = ] [ drop kevent-vnode-task ] } } cond ; : handle-kevents ( mx n -- ) - [ over kqueue-mx-events kevent-nth handle-kevent ] with each ; + [ over events>> kevent-nth handle-kevent ] with each ; M: kqueue-mx wait-for-events ( ms mx -- ) swap dup [ make-timespec ] when dupd wait-kevent handle-kevents ; +! Procs : make-proc-kevent ( pid -- kevent ) "kevent" tuck set-kevent-ident @@ -77,5 +104,44 @@ M: kqueue-mx wait-for-events ( ms mx -- ) EVFILT_PROC over set-kevent-filter NOTE_EXIT over set-kevent-fflags ; -: add-pid-task ( pid mx -- ) +: register-pid-task ( pid mx -- ) swap make-proc-kevent swap register-kevent ; + +! VNodes +TUPLE: vnode-monitor < monitor fd ; + +: vnode-fflags ( -- n ) + { + NOTE_DELETE + NOTE_WRITE + NOTE_EXTEND + NOTE_ATTRIB + NOTE_LINK + NOTE_RENAME + NOTE_REVOKE + } flags ; + +: make-vnode-kevent ( fd flags -- kevent ) + "kevent" + tuck set-kevent-flags + tuck set-kevent-ident + EVFILT_VNODE over set-kevent-filter + vnode-fflags over set-kevent-fflags ; + +: register-monitor ( monitor mx -- ) + >r dup fd>> r> + [ >r EV_ADD EV_CLEAR bitor make-vnode-kevent r> register-kevent drop ] + [ monitors>> set-at ] 3bi ; + +: unregister-monitor ( monitor mx -- ) + >r fd>> r> + [ monitors>> delete-at ] + [ >r EV_DELETE make-vnode-kevent r> register-kevent ] 2bi ; + +: ( path mailbox -- monitor ) + >r [ O_RDONLY 0 open dup io-error ] keep r> + vnode-monitor construct-monitor swap >>fd + [ dup kqueue-mx get register-monitor ] [ ] [ fd>> close ] cleanup ; + +M: vnode-monitor dispose + [ kqueue-mx get unregister-monitor ] [ fd>> close ] bi ; diff --git a/extra/io/unix/linux/monitors/monitors.factor b/extra/io/unix/linux/monitors/monitors.factor index 5f23199146..a257873ed5 100644 --- a/extra/io/unix/linux/monitors/monitors.factor +++ b/extra/io/unix/linux/monitors/monitors.factor @@ -55,9 +55,6 @@ M: linux-monitor dispose ( monitor -- ) [ wd>> watches get delete-at ] [ wd>> inotify-fd swap inotify_rm_watch io-error ] bi ; -: ?flag ( n mask symbol -- n ) - pick rot bitand 0 > [ , ] [ drop ] if ; - : ignore-flags? ( mask -- ? ) { IN_DELETE_SELF @@ -76,7 +73,7 @@ M: linux-monitor dispose ( monitor -- ) IN_MOVED_FROM +rename-file-old+ ?flag IN_MOVED_TO +rename-file-new+ ?flag drop - ] { } make ; + ] { } make prune ; : parse-file-notify ( buffer -- path changed ) dup inotify-event-mask ignore-flags? [ From 1f759a7b2d6377ae6227445fcb1e15dae9b4a768 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 11 Apr 2008 10:09:45 -0500 Subject: [PATCH 010/109] Fix documentation --- extra/io/monitors/monitors-docs.factor | 6 ++---- extra/io/unix/bsd/bsd.factor | 3 ++- 2 files changed, 4 insertions(+), 5 deletions(-) diff --git a/extra/io/monitors/monitors-docs.factor b/extra/io/monitors/monitors-docs.factor index df4f7ae352..cd6a06a8e9 100755 --- a/extra/io/monitors/monitors-docs.factor +++ b/extra/io/monitors/monitors-docs.factor @@ -69,15 +69,13 @@ $nl { $heading "Linux" } "Factor uses " { $snippet "inotify" } " to implement monitors on Linux. This requires Linux kernel version 2.6.16 or later." $nl -"Since " { $snippet "inotify" } " can only monitor a single directory, Factor simulates recursive monitors by creating a hierarchy of monitors for every subdirectory. This is transparent to user code." +"Factor simulates recursive monitors by creating a hierarchy of monitors for every subdirectory, since " { $snippet "inotify" } " can only monitor a single directory. This is transparent to user code." $nl "Inside a single " { $link with-monitors } " scope, only one monitor may be created for any given directory." { $heading "BSD" } "Factor uses " { $snippet "kqueue" } " to implement monitors on BSD." $nl -"Since " { $snippet "kqueue" } " can only monitor a single directory, Factor simulates recursive monitors by creating a hierarchy of monitors for every subdirectory. This is transparent to user code." -$nl -"Because " { $snippet "kqueue" } " requires that a file descriptor is allocated for each directory being monitored, monitoring of large directory hierarchies may exhaust file descriptors or exhibit suboptimal performance. Furthermore, unmounting a subdirectory of a recursively-monitored directory is not possible." +"The " { $snippet "kqueue" } " system is limited to monitoring individual files and directories. Monitoring a directory only notifies of files being added and removed to the directory itself, not of changes to file contents." { $heading "Windows CE" } "Windows CE does not support monitors." ; diff --git a/extra/io/unix/bsd/bsd.factor b/extra/io/unix/bsd/bsd.factor index 03723a65e5..1b51b3c4e4 100755 --- a/extra/io/unix/bsd/bsd.factor +++ b/extra/io/unix/bsd/bsd.factor @@ -18,4 +18,5 @@ M: bsd init-monitors ; M: bsd dispose-monitors ; M: bsd (monitor) ( path recursive? mailbox -- ) - nip ; + swap [ "Recursive kqueue monitors not supported" throw ] when + ; From 8460780f61906a7d39df01df785741d7c0863f58 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 11 Apr 2008 12:18:39 -0500 Subject: [PATCH 011/109] Do a runloop so that monitors work in terminal --- extra/cocoa/application/application.factor | 9 +++--- extra/core-foundation/core-foundation.factor | 2 +- .../core-foundation/fsevents/fsevents.factor | 23 +++++++++----- .../core-foundation/run-loop/run-loop.factor | 30 +++++++++++++++++++ extra/io/monitors/monitors-tests.factor | 4 +-- 5 files changed, 52 insertions(+), 16 deletions(-) create mode 100644 extra/core-foundation/run-loop/run-loop.factor 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..5025ab39a7 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 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..7cd148e022 --- /dev/null +++ b/extra/core-foundation/run-loop/run-loop.factor @@ -0,0 +1,30 @@ +! Copyright (C) 2008 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: alien.syntax kernel threads init +cocoa.application core-foundation ; +IN: core-foundation.run-loop + +: kCFRunLoopRunFinished 1 ; inline +: kCFRunLoopRunStopped 2 ; inline +: kCFRunLoopRunTimedOut 3 ; inline +: kCFRunLoopRunHandledSource 4 ; inline + +TYPEDEF: void* CFRunLoopRef + +FUNCTION: SInt32 CFRunLoopRunInMode ( + CFStringRef mode, + CFTimeInterval seconds, + Boolean returnAfterSourceHandled +) ; + +: CFRunLoopDefaultMode "kCFRunLoopDefaultMode" ; + +: 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/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 From c5de8189259991d11bbec37bce6be5882784e7ae Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 11 Apr 2008 12:47:49 -0500 Subject: [PATCH 012/109] Use inheritance in Unix I?O backend --- extra/io/unix/backend/backend.factor | 32 ++++++++++++---------------- extra/io/unix/epoll/epoll.factor | 8 +++---- extra/io/unix/kqueue/kqueue.factor | 12 ++++++----- extra/io/unix/select/select.factor | 6 +++--- extra/io/unix/sockets/sockets.factor | 16 +++++++------- 5 files changed, 35 insertions(+), 39 deletions(-) diff --git a/extra/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor index 0fb8b0c5f2..d42f8827b1 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 -- ) @@ -140,10 +136,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 @@ -158,10 +154,10 @@ M: input-port (wait-to-read) dup [ handle>> ] [ buffer@ ] [ buffer-length ] tri write dup 0 >= [ swap 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 @@ -193,7 +189,7 @@ TUPLE: mx-port mx ; dup fd>> f mx-port { set-mx-port-mx set-delegate } mx-port construct ; -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/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/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..9ad1338b96 100755 --- a/extra/io/unix/sockets/sockets.factor +++ b/extra/io/unix/sockets/sockets.factor @@ -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 @@ -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 @@ -128,10 +128,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 @@ -157,10 +157,10 @@ M: unix receive ( datagram -- packet addrspec ) : 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 From ce57aca4f541b9236e2aad46af8ca7eb235d9e08 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 11 Apr 2008 12:51:50 -0500 Subject: [PATCH 013/109] case now executes its keys if they are words cond now accepts a default quotation --- core/combinators/combinators-docs.factor | 10 +- core/combinators/combinators-tests.factor | 232 +++++++++++++++++++++- core/combinators/combinators.factor | 30 ++- 3 files changed, 254 insertions(+), 18 deletions(-) diff --git a/core/combinators/combinators-docs.factor b/core/combinators/combinators-docs.factor index f497fd20e5..54c62c44fa 100755 --- a/core/combinators/combinators-docs.factor +++ b/core/combinators/combinators-docs.factor @@ -64,9 +64,9 @@ HELP: alist>quot { $notes "This word is used to implement compile-time behavior for " { $link cond } ", and it is also used by the generic word system. Note that unlike " { $link cond } ", the constructed quotation performs the tests starting from the end and not the beginning." } ; HELP: cond -{ $values { "assoc" "a sequence of quotation pairs" } } +{ $values { "assoc" "a sequence of quotation pairs and an optional quotation" } } { $description - "Calls the second quotation in the first pair whose first quotation yields a true value." + "Calls the second quotation in the first pair whose first quotation yields a true value. A single quotation will always yield a true value." $nl "The following two phrases are equivalent:" { $code "{ { [ X ] [ Y ] } { [ Z ] [ T ] } } cond" } @@ -78,7 +78,7 @@ HELP: cond "{" " { [ dup 0 > ] [ \"positive\" ] }" " { [ dup 0 < ] [ \"negative\" ] }" - " { [ dup zero? ] [ \"zero\" ] }" + " [ \"zero\" ]" "} cond" } } ; @@ -88,9 +88,9 @@ HELP: no-cond { $error-description "Thrown by " { $link cond } " if none of the test quotations yield a true value. Some uses of " { $link cond } " include a default case where the test quotation is " { $snippet "[ t ]" } "; such a " { $link cond } " form will never throw this error." } ; HELP: case -{ $values { "obj" object } { "assoc" "a sequence of object/quotation pairs, with an optional quotation at the end" } } +{ $values { "obj" object } { "assoc" "a sequence of object/word,quotation pairs, with an optional quotation at the end" } } { $description - "Compares " { $snippet "obj" } " against the first element of every pair. If some pair matches, removes " { $snippet "obj" } " from the stack and calls the second element of that pair, which must be a quotation." + "Compares " { $snippet "obj" } " against the first element of every pair, first evaluating the first element if it is a word. If some pair matches, removes " { $snippet "obj" } " from the stack and calls the second element of that pair, which must be a quotation." $nl "If there is no case matching " { $snippet "obj" } ", the default case is taken. If the last element of " { $snippet "cases" } " is a quotation, the quotation is called with " { $snippet "obj" } " on the stack. Otherwise, a " { $link no-cond } " error is rasied." $nl diff --git a/core/combinators/combinators-tests.factor b/core/combinators/combinators-tests.factor index 8abc53e43f..b612669b71 100755 --- a/core/combinators/combinators-tests.factor +++ b/core/combinators/combinators-tests.factor @@ -1,7 +1,54 @@ -IN: combinators.tests USING: alien strings kernel math tools.test io prettyprint -namespaces combinators words ; +namespaces combinators words classes sequences ; +IN: combinators.tests +! Compiled +: cond-test-1 ( obj -- str ) + { + { [ dup 2 mod 0 = ] [ drop "even" ] } + { [ dup 2 mod 1 = ] [ drop "odd" ] } + } cond ; + +\ cond-test-1 must-infer + +[ "even" ] [ 2 cond-test-1 ] unit-test +[ "odd" ] [ 3 cond-test-1 ] unit-test + +: cond-test-2 ( obj -- str ) + { + { [ dup t = ] [ drop "true" ] } + { [ dup f = ] [ drop "false" ] } + [ drop "something else" ] + } cond ; + +\ cond-test-2 must-infer + +[ "true" ] [ t cond-test-2 ] unit-test +[ "false" ] [ f cond-test-2 ] unit-test +[ "something else" ] [ "ohio" cond-test-2 ] unit-test + +: cond-test-3 ( obj -- str ) + { + [ drop "something else" ] + { [ dup t = ] [ drop "true" ] } + { [ dup f = ] [ drop "false" ] } + } cond ; + +\ cond-test-3 must-infer + +[ "something else" ] [ t cond-test-3 ] unit-test +[ "something else" ] [ f cond-test-3 ] unit-test +[ "something else" ] [ "ohio" cond-test-3 ] unit-test + +: cond-test-4 ( -- ) + { + } cond ; + +\ cond-test-4 must-infer + +[ cond-test-4 ] [ class \ no-cond = ] must-fail-with + +! Interpreted [ "even" ] [ 2 { { [ dup 2 mod 0 = ] [ drop "even" ] } @@ -21,11 +68,66 @@ namespaces combinators words ; { [ dup string? ] [ drop "string" ] } { [ dup float? ] [ drop "float" ] } { [ dup alien? ] [ drop "alien" ] } - { [ t ] [ drop "neither" ] } + [ drop "neither" ] } cond ] unit-test -: case-test-1 +[ "neither" ] [ + 3 { + { [ dup string? ] [ drop "string" ] } + { [ dup float? ] [ drop "float" ] } + { [ dup alien? ] [ drop "alien" ] } + [ drop "neither" ] + } cond +] unit-test + +[ "neither" ] [ + 3 { + { [ dup string? ] [ drop "string" ] } + { [ dup float? ] [ drop "float" ] } + { [ dup alien? ] [ drop "alien" ] } + [ drop "neither" ] + } cond +] unit-test + +[ "early" ] [ + 2 { + { [ dup 2 mod 1 = ] [ drop "odd" ] } + [ drop "early" ] + { [ dup 2 mod 0 = ] [ drop "even" ] } + } cond +] unit-test + +[ "really early" ] [ + 2 { + [ drop "really early" ] + { [ dup 2 mod 1 = ] [ drop "odd" ] } + { [ dup 2 mod 0 = ] [ drop "even" ] } + } cond +] unit-test + +[ { } cond ] [ class \ no-cond = ] must-fail-with + +[ "early" ] [ + 2 { + { [ dup 2 mod 1 = ] [ drop "odd" ] } + [ drop "early" ] + { [ dup 2 mod 0 = ] [ drop "even" ] } + } cond +] unit-test + +[ "really early" ] [ + 2 { + [ drop "really early" ] + { [ dup 2 mod 1 = ] [ drop "odd" ] } + { [ dup 2 mod 0 = ] [ drop "even" ] } + } cond +] unit-test + +[ { } cond ] [ class \ no-cond = ] must-fail-with + +! Compiled +: case-test-1 ( obj -- obj' ) { { 1 [ "one" ] } { 2 [ "two" ] } @@ -33,6 +135,8 @@ namespaces combinators words ; { 4 [ "four" ] } } case ; +\ case-test-1 must-infer + [ "two" ] [ 2 case-test-1 ] unit-test ! Interpreted @@ -40,7 +144,7 @@ namespaces combinators words ; [ "x" case-test-1 ] must-fail -: case-test-2 +: case-test-2 ( obj -- obj' ) { { 1 [ "one" ] } { 2 [ "two" ] } @@ -49,12 +153,14 @@ namespaces combinators words ; [ sq ] } case ; +\ case-test-2 must-infer + [ 25 ] [ 5 case-test-2 ] unit-test ! Interpreted [ 25 ] [ 5 \ case-test-2 word-def call ] unit-test -: case-test-3 +: case-test-3 ( obj -- obj' ) { { 1 [ "one" ] } { 2 [ "two" ] } @@ -65,8 +171,122 @@ namespaces combinators words ; [ sq ] } case ; +\ case-test-3 must-infer + [ "an array" ] [ { 1 2 3 } case-test-3 ] unit-test +: case-const-1 1 ; +: case-const-2 2 ; inline + +! Compiled +: case-test-4 ( obj -- str ) + { + { case-const-1 [ "uno" ] } + { case-const-2 [ "dos" ] } + { 3 [ "tres" ] } + { 4 [ "cuatro" ] } + { 5 [ "cinco" ] } + [ drop "demasiado" ] + } case ; + +\ case-test-4 must-infer + +[ "uno" ] [ 1 case-test-4 ] unit-test +[ "dos" ] [ 2 case-test-4 ] unit-test +[ "tres" ] [ 3 case-test-4 ] unit-test +[ "demasiado" ] [ 100 case-test-4 ] unit-test + +: case-test-5 ( obj -- ) + { + { case-const-1 [ "uno" print ] } + { case-const-2 [ "dos" print ] } + { 3 [ "tres" print ] } + { 4 [ "cuatro" print ] } + { 5 [ "cinco" print ] } + [ drop "demasiado" print ] + } case ; + +\ case-test-5 must-infer + +[ ] [ 1 case-test-5 ] unit-test + +! Interpreted +[ "uno" ] [ + 1 { + { case-const-1 [ "uno" ] } + { case-const-2 [ "dos" ] } + { 3 [ "tres" ] } + { 4 [ "cuatro" ] } + { 5 [ "cinco" ] } + [ drop "demasiado" ] + } case +] unit-test + +[ "dos" ] [ + 2 { + { case-const-1 [ "uno" ] } + { case-const-2 [ "dos" ] } + { 3 [ "tres" ] } + { 4 [ "cuatro" ] } + { 5 [ "cinco" ] } + [ drop "demasiado" ] + } case +] unit-test + +[ "tres" ] [ + 3 { + { case-const-1 [ "uno" ] } + { case-const-2 [ "dos" ] } + { 3 [ "tres" ] } + { 4 [ "cuatro" ] } + { 5 [ "cinco" ] } + [ drop "demasiado" ] + } case +] unit-test + +[ "demasiado" ] [ + 100 { + { case-const-1 [ "uno" ] } + { case-const-2 [ "dos" ] } + { 3 [ "tres" ] } + { 4 [ "cuatro" ] } + { 5 [ "cinco" ] } + [ drop "demasiado" ] + } case +] unit-test + +: do-not-call "do not call" throw ; + +: test-case-6 + { + { \ do-not-call [ "do-not-call" ] } + { 3 [ "three" ] } + } case ; + +[ "three" ] [ 3 test-case-6 ] unit-test +[ "do-not-call" ] [ \ do-not-call test-case-6 ] unit-test + +[ "three" ] [ + 3 { + { \ do-not-call [ "do-not-call" ] } + { 3 [ "three" ] } + } case +] unit-test + +[ "do-not-call" ] [ + [ do-not-call ] first { + { \ do-not-call [ "do-not-call" ] } + { 3 [ "three" ] } + } case +] unit-test + +[ "do-not-call" ] [ + \ do-not-call { + { \ do-not-call [ "do-not-call" ] } + { 3 [ "three" ] } + } case +] unit-test + ! Interpreted [ "a hashtable" ] [ H{ } \ case-test-3 word-def call ] unit-test diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index 96c4009ba9..11ad8d60e7 100755 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -3,7 +3,7 @@ IN: combinators USING: arrays sequences sequences.private math.private kernel kernel.private math assocs quotations vectors -hashtables sorting ; +hashtables sorting words ; : cleave ( x seq -- ) [ call ] with each ; @@ -34,13 +34,24 @@ hashtables sorting ; ERROR: no-cond ; : cond ( assoc -- ) - [ first call ] find nip dup [ second call ] [ no-cond ] if ; + [ dup callable? [ drop t ] [ first call ] if ] find nip + [ dup callable? [ call ] [ second call ] if ] + [ no-cond ] if* ; ERROR: no-case ; +: case-find ( obj assoc -- obj' ) + [ + dup array? [ + dupd first dup word? [ + execute + ] [ + dup wrapper? [ wrapped ] when + ] if = + ] [ quotation? ] if + ] find nip ; : case ( obj assoc -- ) - [ dup array? [ dupd first = ] [ quotation? ] if ] find nip - { + case-find { { [ dup array? ] [ nip second call ] } { [ dup quotation? ] [ call ] } { [ dup not ] [ no-case ] } @@ -73,11 +84,14 @@ M: hashtable hashcode* [ rot \ if 3array append [ ] like ] assoc-each ; : cond>quot ( assoc -- quot ) + [ dup callable? [ [ t ] swap 2array ] when ] map reverse [ no-cond ] swap alist>quot ; : linear-case-quot ( default assoc -- quot ) - [ >r [ dupd = ] curry r> \ drop prefix ] assoc-map - alist>quot ; + [ + [ 1quotation \ dup prefix \ = suffix ] + [ \ drop prefix ] bi* + ] assoc-map alist>quot ; : (distribute-buckets) ( buckets pair keys -- ) dup t eq? [ @@ -135,7 +149,9 @@ M: hashtable hashcode* dup empty? [ drop ] [ - dup length 4 <= [ + dup length 4 <= + over keys [ word? ] contains? or + [ linear-case-quot ] [ dup keys contiguous-range? [ From 9348b9b8a7d09d6fa0120e6f5367d5fe59491fc5 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 11 Apr 2008 12:52:56 -0500 Subject: [PATCH 014/109] gensyms don't output a number in the name now --- core/words/words.factor | 15 +++++++-------- 1 file changed, 7 insertions(+), 8 deletions(-) diff --git a/core/words/words.factor b/core/words/words.factor index 7794a7f41f..e1d2f11356 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -2,8 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays definitions graphs assocs kernel kernel.private slots.private math namespaces sequences strings vectors sbufs -quotations assocs hashtables sorting math.parser words.private -vocabs combinators ; +quotations assocs hashtables sorting words.private vocabs ; IN: words : word ( -- word ) \ word get-global ; @@ -66,11 +65,11 @@ SYMBOL: bootstrapping? GENERIC: crossref? ( word -- ? ) M: word crossref? - { - { [ dup "forgotten" word-prop ] [ f ] } - { [ dup word-vocabulary ] [ t ] } - { [ t ] [ f ] } - } cond nip ; + dup "forgotten" word-prop [ + drop f + ] [ + word-vocabulary >boolean + ] if ; GENERIC# (quot-uses) 1 ( obj assoc -- ) @@ -191,7 +190,7 @@ M: word subwords drop f ; { "methods" "combination" "default-method" } reset-props ; : gensym ( -- word ) - "G:" \ gensym counter number>string append f ; + "( gensym )" f ; : define-temp ( quot -- word ) gensym dup rot define ; From bced4022e59438846e7c362d445884e895a7bc46 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 11 Apr 2008 12:53:22 -0500 Subject: [PATCH 015/109] updating usages of cond/case --- core/alien/alien-docs.factor | 2 +- core/alien/compiler/compiler.factor | 4 +-- core/alien/syntax/syntax.factor | 2 +- core/classes/algebra/algebra.factor | 14 +++++----- core/classes/mixin/mixin.factor | 2 +- core/compiler/tests/simple.factor | 4 +-- core/cpu/x86/32/32.factor | 3 +-- core/cpu/x86/assembler/assembler.factor | 2 +- core/debugger/debugger.factor | 2 +- core/dlists/dlists.factor | 2 +- core/effects/effects.factor | 2 +- core/generator/fixup/fixup.factor | 4 +-- core/generator/generator.factor | 2 +- core/generator/registers/registers.factor | 6 ++--- core/generic/math/math.factor | 2 +- .../engines/predicate/predicate.factor | 2 +- core/inference/backend/backend.factor | 4 +-- core/io/encodings/utf8/utf8.factor | 6 ++--- core/io/files/files.factor | 27 ++++++++++--------- core/math/intervals/intervals.factor | 6 ++--- core/math/parser/parser.factor | 10 +++---- core/optimizer/control/control-tests.factor | 14 +++++----- core/optimizer/control/control.factor | 2 +- core/optimizer/inlining/inlining.factor | 8 +++--- .../pattern-match/pattern-match.factor | 2 +- .../specializers/specializers.factor | 2 +- core/parser/parser.factor | 2 +- core/prettyprint/prettyprint.factor | 2 +- core/syntax/syntax.factor | 2 +- core/threads/threads.factor | 2 +- 30 files changed, 71 insertions(+), 73 deletions(-) diff --git a/core/alien/alien-docs.factor b/core/alien/alien-docs.factor index 136af91bb2..7d13080e3c 100755 --- a/core/alien/alien-docs.factor +++ b/core/alien/alien-docs.factor @@ -78,7 +78,7 @@ $nl "<< \"freetype\" {" " { [ os macosx? ] [ \"libfreetype.6.dylib\" \"cdecl\" add-library ] }" " { [ os windows? ] [ \"freetype6.dll\" \"cdecl\" add-library ] }" - " { [ t ] [ drop ] }" + " [ drop ]" "} cond >>" } "Note the parse time evaluation with " { $link POSTPONE: << } "." } ; diff --git a/core/alien/compiler/compiler.factor b/core/alien/compiler/compiler.factor index 0f74f52d60..594c42268c 100755 --- a/core/alien/compiler/compiler.factor +++ b/core/alien/compiler/compiler.factor @@ -375,7 +375,7 @@ TUPLE: callback-context ; return>> { { [ dup "void" = ] [ drop [ ] ] } { [ dup large-struct? ] [ heap-size [ memcpy ] curry ] } - { [ t ] [ c-type c-type-prep ] } + [ c-type c-type-prep ] } cond ; : wrap-callback-quot ( node -- quot ) @@ -390,7 +390,7 @@ TUPLE: callback-context ; { { [ dup abi>> "stdcall" = ] [ alien-stack-frame ] } { [ dup return>> large-struct? ] [ drop 4 ] } - { [ t ] [ drop 0 ] } + [ drop 0 ] } cond ; : %callback-return ( node -- ) diff --git a/core/alien/syntax/syntax.factor b/core/alien/syntax/syntax.factor index 6e4b8b4e21..67ea30f379 100755 --- a/core/alien/syntax/syntax.factor +++ b/core/alien/syntax/syntax.factor @@ -68,7 +68,7 @@ M: alien pprint* { { [ dup expired? ] [ drop "( alien expired )" text ] } { [ dup pinned-c-ptr? not ] [ drop "( displaced alien )" text ] } - { [ t ] [ \ ALIEN: [ alien-address pprint* ] pprint-prefix ] } + [ \ ALIEN: [ alien-address pprint* ] pprint-prefix ] } cond ; M: dll pprint* dll-path dup "DLL\" " "\"" pprint-string ; diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor index 4614e4c4ce..faf57fcd0d 100755 --- a/core/classes/algebra/algebra.factor +++ b/core/classes/algebra/algebra.factor @@ -84,7 +84,7 @@ C: anonymous-complement { [ dup anonymous-complement? ] [ class>> classes-intersect? not ] } { [ dup members ] [ right-union-class< ] } { [ over superclass ] [ superclass< ] } - { [ t ] [ 2drop f ] } + [ 2drop f ] } cond ; : anonymous-union-intersect? ( first second -- ? ) @@ -104,14 +104,14 @@ C: anonymous-complement { [ over tuple eq? ] [ 2drop t ] } { [ over builtin-class? ] [ 2drop f ] } { [ over tuple-class? ] [ [ class< ] [ swap class< ] 2bi or ] } - { [ t ] [ swap classes-intersect? ] } + [ swap classes-intersect? ] } cond ; : builtin-class-intersect? ( first second -- ? ) { { [ 2dup eq? ] [ 2drop t ] } { [ over builtin-class? ] [ 2drop f ] } - { [ t ] [ swap classes-intersect? ] } + [ swap classes-intersect? ] } cond ; : (classes-intersect?) ( first second -- ? ) @@ -154,7 +154,7 @@ C: anonymous-complement { [ over members ] [ left-union-and ] } { [ over anonymous-union? ] [ left-anonymous-union-and ] } { [ over anonymous-intersection? ] [ left-anonymous-intersection-and ] } - { [ t ] [ 2array ] } + [ 2array ] } cond ; : left-anonymous-union-or ( first second -- class ) @@ -169,7 +169,7 @@ C: anonymous-complement { [ 2dup swap class< ] [ drop ] } { [ dup anonymous-union? ] [ right-anonymous-union-or ] } { [ over anonymous-union? ] [ left-anonymous-union-or ] } - { [ t ] [ 2array ] } + [ 2array ] } cond ; : (class-not) ( class -- complement ) @@ -177,7 +177,7 @@ C: anonymous-complement { [ dup anonymous-complement? ] [ class>> ] } { [ dup object eq? ] [ drop null ] } { [ dup null eq? ] [ drop object ] } - { [ t ] [ ] } + [ ] } cond ; : largest-class ( seq -- n elt ) @@ -205,7 +205,7 @@ C: anonymous-complement { [ dup builtin-class? ] [ dup set ] } { [ dup members ] [ members [ (flatten-class) ] each ] } { [ dup superclass ] [ superclass (flatten-class) ] } - { [ t ] [ drop ] } + [ drop ] } cond ; : flatten-class ( class -- assoc ) diff --git a/core/classes/mixin/mixin.factor b/core/classes/mixin/mixin.factor index aefd522269..9bbe89d7d9 100755 --- a/core/classes/mixin/mixin.factor +++ b/core/classes/mixin/mixin.factor @@ -49,7 +49,7 @@ M: mixin-instance equal? { [ over mixin-instance? not ] [ f ] } { [ 2dup [ mixin-instance-class ] bi@ = not ] [ f ] } { [ 2dup [ mixin-instance-mixin ] bi@ = not ] [ f ] } - { [ t ] [ t ] } + [ t ] } cond 2nip ; M: mixin-instance hashcode* diff --git a/core/compiler/tests/simple.factor b/core/compiler/tests/simple.factor index 09b0c190e6..dce2ec562a 100755 --- a/core/compiler/tests/simple.factor +++ b/core/compiler/tests/simple.factor @@ -187,7 +187,7 @@ DEFER: countdown-b { [ dup string? ] [ drop "string" ] } { [ dup float? ] [ drop "float" ] } { [ dup alien? ] [ drop "alien" ] } - { [ t ] [ drop "neither" ] } + [ drop "neither" ] } cond ] compile-call ] unit-test @@ -196,7 +196,7 @@ DEFER: countdown-b [ 3 { { [ dup fixnum? ] [ ] } - { [ t ] [ drop t ] } + [ drop t ] } cond ] compile-call ] unit-test diff --git a/core/cpu/x86/32/32.factor b/core/cpu/x86/32/32.factor index 699670aecd..cc3fceff23 100755 --- a/core/cpu/x86/32/32.factor +++ b/core/cpu/x86/32/32.factor @@ -246,9 +246,8 @@ M: x86.32 %cleanup ( alien-node -- ) } { [ dup return>> large-struct? ] [ drop EAX PUSH ] - } { - [ t ] [ drop ] } + [ drop ] } cond ; M: x86.32 %unwind ( n -- ) %epilogue-later RET ; diff --git a/core/cpu/x86/assembler/assembler.factor b/core/cpu/x86/assembler/assembler.factor index a3ab256ea1..450aa8f980 100755 --- a/core/cpu/x86/assembler/assembler.factor +++ b/core/cpu/x86/assembler/assembler.factor @@ -189,7 +189,7 @@ UNION: operand register indirect ; { { [ dup register-128? ] [ drop operand-64? ] } { [ dup not ] [ drop operand-64? ] } - { [ t ] [ nip operand-64? ] } + [ nip operand-64? ] } cond and ; : rex.r diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor index 071535a01e..dea1904e92 100755 --- a/core/debugger/debugger.factor +++ b/core/debugger/debugger.factor @@ -160,7 +160,7 @@ PREDICATE: kernel-error < array { { [ dup empty? ] [ drop f ] } { [ dup first "kernel-error" = not ] [ drop f ] } - { [ t ] [ second 0 15 between? ] } + [ second 0 15 between? ] } cond ; : kernel-errors diff --git a/core/dlists/dlists.factor b/core/dlists/dlists.factor index 56134f3b54..b4ae207455 100755 --- a/core/dlists/dlists.factor +++ b/core/dlists/dlists.factor @@ -126,7 +126,7 @@ PRIVATE> { { [ over front>> over eq? ] [ drop pop-front* ] } { [ over back>> over eq? ] [ drop pop-back* ] } - { [ t ] [ unlink-node dec-length ] } + [ unlink-node dec-length ] } cond ; : delete-node-if* ( dlist quot -- obj/f ? ) diff --git a/core/effects/effects.factor b/core/effects/effects.factor index aed4a64c6c..7da290992c 100755 --- a/core/effects/effects.factor +++ b/core/effects/effects.factor @@ -20,7 +20,7 @@ TUPLE: effect in out terminated? ; { [ dup effect-terminated? ] [ f ] } { [ 2dup [ effect-in length ] bi@ > ] [ f ] } { [ 2dup [ effect-height ] bi@ = not ] [ f ] } - { [ t ] [ t ] } + [ t ] } cond 2nip ; GENERIC: (stack-picture) ( obj -- str ) diff --git a/core/generator/fixup/fixup.factor b/core/generator/fixup/fixup.factor index 5cc0442464..3a5a6571b7 100755 --- a/core/generator/fixup/fixup.factor +++ b/core/generator/fixup/fixup.factor @@ -40,8 +40,8 @@ M: label fixup* M: word fixup* { - { %prologue-later [ dup [ %prologue ] if-stack-frame ] } - { %epilogue-later [ dup [ %epilogue ] if-stack-frame ] } + { \ %prologue-later [ dup [ %prologue ] if-stack-frame ] } + { \ %epilogue-later [ dup [ %epilogue ] if-stack-frame ] } } case ; SYMBOL: relocation-table diff --git a/core/generator/generator.factor b/core/generator/generator.factor index 3514947e3d..7858205384 100755 --- a/core/generator/generator.factor +++ b/core/generator/generator.factor @@ -16,7 +16,7 @@ SYMBOL: compiled { [ dup compiled get key? ] [ drop ] } { [ dup inlined-block? ] [ drop ] } { [ dup primitive? ] [ drop ] } - { [ t ] [ dup compile-queue get set-at ] } + [ dup compile-queue get set-at ] } cond ; : maybe-compile ( word -- ) diff --git a/core/generator/registers/registers.factor b/core/generator/registers/registers.factor index f3dc0fb10e..8abd1cd3e0 100755 --- a/core/generator/registers/registers.factor +++ b/core/generator/registers/registers.factor @@ -195,7 +195,7 @@ INSTANCE: constant value { [ dup byte-array class< ] [ drop %unbox-byte-array ] } { [ dup bit-array class< ] [ drop %unbox-byte-array ] } { [ dup float-array class< ] [ drop %unbox-byte-array ] } - { [ t ] [ drop %unbox-any-c-ptr ] } + [ drop %unbox-any-c-ptr ] } cond ; inline : %move-via-temp ( dst src -- ) @@ -357,14 +357,14 @@ SYMBOL: fresh-objects { [ dup unboxed-c-ptr eq? ] [ over { unboxed-byte-array unboxed-alien } member? ] } - { [ t ] [ f ] } + [ f ] } cond 2nip ; : allocation ( value spec -- reg-class ) { { [ dup quotation? ] [ 2drop f ] } { [ 2dup compatible? ] [ 2drop f ] } - { [ t ] [ nip reg-spec>class ] } + [ nip reg-spec>class ] } cond ; : alloc-vreg-for ( value spec -- vreg ) diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor index fce908bdef..884ab8027e 100755 --- a/core/generic/math/math.factor +++ b/core/generic/math/math.factor @@ -19,7 +19,7 @@ PREDICATE: math-class < class { { [ dup null class< ] [ drop { -1 -1 } ] } { [ dup math-class? ] [ class-types last/first ] } - { [ t ] [ drop { 100 100 } ] } + [ drop { 100 100 } ] } cond ; : math-class-max ( class class -- class ) diff --git a/core/generic/standard/engines/predicate/predicate.factor b/core/generic/standard/engines/predicate/predicate.factor index ce7d5c6c21..5335074dea 100644 --- a/core/generic/standard/engines/predicate/predicate.factor +++ b/core/generic/standard/engines/predicate/predicate.factor @@ -18,7 +18,7 @@ C: predicate-dispatch-engine { [ dup empty? ] [ drop [ "Unreachable" throw ] { } ] } { [ dup length 1 = ] [ first second { } ] } { [ dup keep-going? ] [ 1 tail-slice prune-redundant-predicates ] } - { [ t ] [ [ first second ] [ 1 tail-slice ] bi ] } + [ [ first second ] [ 1 tail-slice ] bi ] } cond ; : sort-methods ( assoc -- assoc' ) diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor index 3dcb1d2360..1945ed1a38 100755 --- a/core/inference/backend/backend.factor +++ b/core/inference/backend/backend.factor @@ -251,7 +251,7 @@ TUPLE: cannot-unify-specials ; { [ dup [ curried? ] all? ] [ unify-curries ] } { [ dup [ composed? ] all? ] [ unify-composed ] } { [ dup [ special? ] contains? ] [ cannot-unify-specials ] } - { [ t ] [ drop ] } + [ drop ] } cond ; : unify-stacks ( seq -- stack ) @@ -395,7 +395,7 @@ TUPLE: effect-error word effect ; { [ dup "infer" word-prop ] [ custom-infer ] } { [ dup "no-effect" word-prop ] [ no-effect ] } { [ dup "inferred-effect" word-prop ] [ cached-infer ] } - { [ t ] [ dup infer-word make-call-node ] } + [ dup infer-word make-call-node ] } cond ; TUPLE: recursive-declare-error word ; diff --git a/core/io/encodings/utf8/utf8.factor b/core/io/encodings/utf8/utf8.factor index e98860f25d..7a22107f19 100644 --- a/core/io/encodings/utf8/utf8.factor +++ b/core/io/encodings/utf8/utf8.factor @@ -33,7 +33,7 @@ TUPLE: utf8 ; { [ dup -5 shift BIN: 110 number= ] [ double ] } { [ dup -4 shift BIN: 1110 number= ] [ triple ] } { [ dup -3 shift BIN: 11110 number= ] [ quad ] } - { [ t ] [ drop replacement-char ] } + [ drop replacement-char ] } cond ; : decode-utf8 ( stream -- char/f ) @@ -59,12 +59,12 @@ M: utf8 decode-char 2dup -6 shift encoded encoded ] } - { [ t ] [ + [ 2dup -18 shift BIN: 11110000 bitor swap stream-write1 2dup -12 shift encoded 2dup -6 shift encoded encoded - ] } + ] } cond ; M: utf8 encode-char diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 6719d1334c..061e6386da 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -95,7 +95,7 @@ ERROR: no-parent-directory path ; 1 tail left-trim-separators append-path-empty ] } { [ dup head..? ] [ drop no-parent-directory ] } - { [ t ] [ nip ] } + [ nip ] } cond ; PRIVATE> @@ -105,7 +105,7 @@ PRIVATE> { [ dup "\\\\?\\" head? ] [ t ] } { [ dup length 2 < ] [ f ] } { [ dup second CHAR: : = ] [ t ] } - { [ t ] [ f ] } + [ f ] } cond ; : absolute-path? ( path -- ? ) @@ -114,7 +114,7 @@ PRIVATE> { [ dup "resource:" head? ] [ t ] } { [ os windows? ] [ windows-absolute-path? ] } { [ dup first path-separator? ] [ t ] } - { [ t ] [ f ] } + [ f ] } cond nip ; : append-path ( str1 str2 -- str ) @@ -130,10 +130,10 @@ PRIVATE> { [ over absolute-path? over first path-separator? and ] [ >r 2 head r> append ] } - { [ t ] [ + [ >r right-trim-separators "/" r> left-trim-separators 3append - ] } + ] } cond ; : prepend-path ( str1 str2 -- str ) @@ -220,10 +220,10 @@ HOOK: make-directory io-backend ( path -- ) { [ dup root-directory? ] [ ] } { [ dup empty? ] [ ] } { [ dup exists? ] [ ] } - { [ t ] [ + [ dup parent-directory make-directories dup make-directory - ] } + ] } cond drop ; ! Directory listings @@ -322,9 +322,10 @@ C: pathname M: pathname <=> [ pathname-string ] compare ; ! Home directory -: home ( -- dir ) - { - { [ os winnt? ] [ "USERPROFILE" os-env ] } - { [ os wince? ] [ "" resource-path ] } - { [ os unix? ] [ "HOME" os-env ] } - } cond ; +HOOK: home os ( -- dir ) + +M: winnt home "USERPROFILE" os-env ; + +M: wince home "" resource-path ; + +M: unix home "HOME" os-env ; diff --git a/core/math/intervals/intervals.factor b/core/math/intervals/intervals.factor index cc51060f63..4ca1a8637c 100755 --- a/core/math/intervals/intervals.factor +++ b/core/math/intervals/intervals.factor @@ -103,7 +103,7 @@ C: interval 2drop over second over second and [ ] [ 2drop f ] if ] } - { [ t ] [ 2drop ] } + [ 2drop ] } cond ; : interval-intersect ( i1 i2 -- i3 ) @@ -202,7 +202,7 @@ SYMBOL: incomparable { [ 2dup interval-intersect not ] [ (interval<) ] } { [ 2dup left-endpoint-< ] [ f ] } { [ 2dup right-endpoint-< ] [ f ] } - { [ t ] [ incomparable ] } + [ incomparable ] } cond 2nip ; : left-endpoint-<= ( i1 i2 -- ? ) @@ -215,7 +215,7 @@ SYMBOL: incomparable { { [ 2dup interval-intersect not ] [ (interval<) ] } { [ 2dup right-endpoint-<= ] [ t ] } - { [ t ] [ incomparable ] } + [ incomparable ] } cond 2nip ; : interval> ( i1 i2 -- ? ) diff --git a/core/math/parser/parser.factor b/core/math/parser/parser.factor index 68c4768c87..1a1a080564 100755 --- a/core/math/parser/parser.factor +++ b/core/math/parser/parser.factor @@ -62,7 +62,7 @@ SYMBOL: negative? { { [ dup empty? ] [ drop f ] } { [ f over memq? ] [ drop f ] } - { [ t ] [ radix get [ < ] curry all? ] } + [ radix get [ < ] curry all? ] } cond ; : string>integer ( str -- n/f ) @@ -77,7 +77,7 @@ PRIVATE> { { [ CHAR: / over member? ] [ string>ratio ] } { [ CHAR: . over member? ] [ string>float ] } - { [ t ] [ string>integer ] } + [ string>integer ] } cond r> [ dup [ neg ] when ] when ] with-radix ; @@ -134,10 +134,8 @@ M: ratio >base } { [ CHAR: . over member? ] [ ] - } { - [ t ] - [ ".0" append ] } + [ ".0" append ] } cond ; M: float >base @@ -145,7 +143,7 @@ M: float >base { [ dup 1.0/0.0 = ] [ drop "1.0/0.0" ] } { [ dup -1.0/0.0 = ] [ drop "-1.0/0.0" ] } { [ dup fp-nan? ] [ drop "0.0/0.0" ] } - { [ t ] [ float>string fix-float ] } + [ float>string fix-float ] } cond ; : number>string ( n -- str ) 10 >base ; diff --git a/core/optimizer/control/control-tests.factor b/core/optimizer/control/control-tests.factor index d7638fa66d..ce77cdd43a 100755 --- a/core/optimizer/control/control-tests.factor +++ b/core/optimizer/control/control-tests.factor @@ -9,23 +9,23 @@ optimizer ; { [ over #label? not ] [ 2drop f ] } { [ over #label-word over eq? not ] [ 2drop f ] } { [ over #label-loop? not ] [ 2drop f ] } - { [ t ] [ 2drop t ] } + [ 2drop t ] } cond ] curry node-exists? ; : label-is-not-loop? ( node word -- ? ) [ { - { [ over #label? not ] [ 2drop f ] } - { [ over #label-word over eq? not ] [ 2drop f ] } - { [ over #label-loop? ] [ 2drop f ] } - { [ t ] [ 2drop t ] } - } cond + { [ over #label? not ] [ f ] } + { [ over #label-word over eq? not ] [ f ] } + { [ over #label-loop? ] [ f ] } + [ t ] + } cond 2nip ] curry node-exists? ; : loop-test-1 ( a -- ) dup [ 1+ loop-test-1 ] [ drop ] if ; inline - + [ t ] [ [ loop-test-1 ] dataflow dup detect-loops \ loop-test-1 label-is-loop? diff --git a/core/optimizer/control/control.factor b/core/optimizer/control/control.factor index 11228c879a..f9f8901c41 100755 --- a/core/optimizer/control/control.factor +++ b/core/optimizer/control/control.factor @@ -156,7 +156,7 @@ SYMBOL: potential-loops { [ dup null class< ] [ drop f f ] } { [ dup \ f class-not class< ] [ drop t t ] } { [ dup \ f class< ] [ drop f t ] } - { [ t ] [ drop f f ] } + [ drop f f ] } cond ] if ; diff --git a/core/optimizer/inlining/inlining.factor b/core/optimizer/inlining/inlining.factor index 9d41d6eae1..8447d1be5f 100755 --- a/core/optimizer/inlining/inlining.factor +++ b/core/optimizer/inlining/inlining.factor @@ -36,7 +36,7 @@ DEFER: (flat-length) ! not inline { [ dup inline? not ] [ drop 1 ] } ! inline - { [ t ] [ dup dup set word-def (flat-length) ] } + [ dup dup set word-def (flat-length) ] } cond ; : (flat-length) ( seq -- n ) @@ -45,7 +45,7 @@ DEFER: (flat-length) { [ dup quotation? ] [ (flat-length) 1+ ] } { [ dup array? ] [ (flat-length) ] } { [ dup word? ] [ word-flat-length ] } - { [ t ] [ drop 1 ] } + [ drop 1 ] } cond ] map sum ; @@ -94,7 +94,7 @@ DEFER: (flat-length) dup node-param { { [ dup standard-generic? ] [ inline-standard-method ] } { [ dup math-generic? ] [ inline-math-method ] } - { [ t ] [ 2drop t ] } + [ 2drop t ] } cond ; ! Resolve type checks at compile time where possible @@ -217,5 +217,5 @@ M: #call optimize-node* { [ dup optimize-predicate? ] [ optimize-predicate ] } { [ dup optimistic-inline? ] [ optimistic-inline ] } { [ dup method-body-inline? ] [ optimistic-inline ] } - { [ t ] [ inline-method ] } + [ inline-method ] } cond dup not ; diff --git a/core/optimizer/pattern-match/pattern-match.factor b/core/optimizer/pattern-match/pattern-match.factor index 0e7e801938..5beb2555f0 100755 --- a/core/optimizer/pattern-match/pattern-match.factor +++ b/core/optimizer/pattern-match/pattern-match.factor @@ -19,7 +19,7 @@ SYMBOL: @ { [ dup @ eq? ] [ drop match-@ ] } { [ dup class? ] [ match-class ] } { [ over value? not ] [ 2drop f ] } - { [ t ] [ swap value-literal = ] } + [ swap value-literal = ] } cond ; : node-match? ( node values pattern -- ? ) diff --git a/core/optimizer/specializers/specializers.factor b/core/optimizer/specializers/specializers.factor index d115d0a1c6..b33a9e8fc2 100755 --- a/core/optimizer/specializers/specializers.factor +++ b/core/optimizer/specializers/specializers.factor @@ -57,7 +57,7 @@ IN: optimizer.specializers [ dup "specializer" word-prop ] [ "specializer" word-prop specialize-quot ] } - { [ t ] [ drop ] } + [ drop ] } cond ; : specialized-length ( specializer -- n ) diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 6c09e08f84..1e1d6a5606 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -324,7 +324,7 @@ M: staging-violation summary { [ dup not ] [ drop unexpected-eof t ] } { [ dup delimiter? ] [ unexpected t ] } { [ dup parsing? ] [ nip execute-parsing t ] } - { [ t ] [ pick push drop t ] } + [ pick push drop t ] } cond ; : (parse-until) ( accum end -- accum ) diff --git a/core/prettyprint/prettyprint.factor b/core/prettyprint/prettyprint.factor index 03d3e456ca..e1a53696af 100755 --- a/core/prettyprint/prettyprint.factor +++ b/core/prettyprint/prettyprint.factor @@ -107,7 +107,7 @@ SYMBOL: -> { [ dup word? not ] [ , ] } { [ dup "break?" word-prop ] [ drop ] } { [ dup "step-into?" word-prop ] [ remove-step-into ] } - { [ t ] [ , ] } + [ , ] } cond ] each ] [ ] make ; diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 005672c1c6..0c759265e9 100755 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -61,7 +61,7 @@ IN: bootstrap.syntax scan { { [ dup length 1 = ] [ first ] } { [ "\\" ?head ] [ next-escape drop ] } - { [ t ] [ name>char-hook get call ] } + [ name>char-hook get call ] } cond parsed ] define-syntax diff --git a/core/threads/threads.factor b/core/threads/threads.factor index d7d7988893..d568153034 100755 --- a/core/threads/threads.factor +++ b/core/threads/threads.factor @@ -86,7 +86,7 @@ PRIVATE> { { [ run-queue dlist-empty? not ] [ 0 ] } { [ sleep-queue heap-empty? ] [ f ] } - { [ t ] [ sleep-queue heap-peek nip millis [-] ] } + [ sleep-queue heap-peek nip millis [-] ] } cond ; Date: Fri, 11 Apr 2008 12:53:46 -0500 Subject: [PATCH 016/109] refactor tar a bit --- extra/tar/tar.factor | 81 +++++++++++++++----------------------------- 1 file changed, 28 insertions(+), 53 deletions(-) diff --git a/extra/tar/tar.factor b/extra/tar/tar.factor index 99af06b80f..038078969d 100755 --- a/extra/tar/tar.factor +++ b/extra/tar/tar.factor @@ -1,7 +1,7 @@ USING: combinators io io.files io.streams.duplex io.streams.string kernel math math.parser continuations namespaces pack prettyprint sequences strings system -hexdump io.encodings.binary ; +hexdump io.encodings.binary inspector accessors ; IN: tar : zero-checksum 256 ; @@ -79,87 +79,67 @@ SYMBOL: filename ] keep ] if ; -TUPLE: unknown-typeflag str ; -: ( ch -- obj ) - 1string \ unknown-typeflag construct-boa ; - -TUPLE: unimplemented-typeflag header ; -: ( header -- obj ) - global [ "Unimplemented typeflag: " print dup . flush ] bind - tar-header-typeflag - 1string \ unimplemented-typeflag construct-boa ; +ERROR: unknown-typeflag ch ; +M: unknown-typeflag summary ( obj -- str ) + ch>> 1string + "Unknown typeflag: " prepend ; : tar-append-path ( path -- newpath ) base-dir get prepend-path ; ! Normal file : typeflag-0 - tar-header-name tar-append-path binary + name>> tar-append-path binary [ read-data-blocks ] keep dispose ; ! Hard link -: typeflag-1 ( header -- ) - throw ; +: typeflag-1 ( header -- ) unknown-typeflag ; ! Symlink -: typeflag-2 ( header -- ) - throw ; +: typeflag-2 ( header -- ) unknown-typeflag ; ! character special -: typeflag-3 ( header -- ) - throw ; +: typeflag-3 ( header -- ) unknown-typeflag ; ! Block special -: typeflag-4 ( header -- ) - throw ; +: typeflag-4 ( header -- ) unknown-typeflag ; ! Directory : typeflag-5 ( header -- ) tar-header-name tar-append-path make-directories ; ! FIFO -: typeflag-6 ( header -- ) - throw ; +: typeflag-6 ( header -- ) unknown-typeflag ; ! Contiguous file -: typeflag-7 ( header -- ) - throw ; +: typeflag-7 ( header -- ) unknown-typeflag ; ! Global extended header -: typeflag-8 ( header -- ) - throw ; +: typeflag-8 ( header -- ) unknown-typeflag ; ! Extended header -: typeflag-9 ( header -- ) - throw ; +: typeflag-9 ( header -- ) unknown-typeflag ; ! Global POSIX header -: typeflag-g ( header -- ) - throw ; +: typeflag-g ( header -- ) unknown-typeflag ; ! Extended POSIX header -: typeflag-x ( header -- ) - throw ; +: typeflag-x ( header -- ) unknown-typeflag ; ! Solaris access control list -: typeflag-A ( header -- ) - throw ; +: typeflag-A ( header -- ) unknown-typeflag ; ! GNU dumpdir -: typeflag-D ( header -- ) - throw ; +: typeflag-D ( header -- ) unknown-typeflag ; ! Solaris extended attribute file -: typeflag-E ( header -- ) - throw ; +: typeflag-E ( header -- ) unknown-typeflag ; ! Inode metadata -: typeflag-I ( header -- ) - throw ; +: typeflag-I ( header -- ) unknown-typeflag ; ! Long link name -: typeflag-K ( header -- ) - throw ; +: typeflag-K ( header -- ) unknown-typeflag ; ! Long file name : typeflag-L ( header -- ) @@ -169,24 +149,19 @@ TUPLE: unimplemented-typeflag header ; filename get tar-append-path make-directories ; ! Multi volume continuation entry -: typeflag-M ( header -- ) - throw ; +: typeflag-M ( header -- ) unknown-typeflag ; ! GNU long file name -: typeflag-N ( header -- ) - throw ; +: typeflag-N ( header -- ) unknown-typeflag ; ! Sparse file -: typeflag-S ( header -- ) - throw ; +: typeflag-S ( header -- ) unknown-typeflag ; ! Volume header -: typeflag-V ( header -- ) - throw ; +: typeflag-V ( header -- ) unknown-typeflag ; ! Vendor extended header type -: typeflag-X ( header -- ) - throw ; +: typeflag-X ( header -- ) unknown-typeflag ; : (parse-tar) ( -- ) 512 read @@ -218,7 +193,7 @@ TUPLE: unimplemented-typeflag header ; { CHAR: S [ typeflag-S ] } { CHAR: V [ typeflag-V ] } { CHAR: X [ typeflag-X ] } - [ throw ] + [ unknown-typeflag ] } case ! dup tar-header-size zero? [ ! out-stream get [ dispose ] when @@ -237,7 +212,7 @@ TUPLE: unimplemented-typeflag header ; : parse-tar ( path -- obj ) binary [ - "tar-test" resource-path base-dir set + "resource:tar-test" base-dir set global [ nl nl nl "Starting to parse .tar..." print flush ] bind global [ "Expanding to: " write base-dir get . flush ] bind (parse-tar) From 1e01d73e616de962e68b2bab525724c02caa98dd Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 11 Apr 2008 12:54:33 -0500 Subject: [PATCH 017/109] fix usages of cond/case --- extra/ui/gadgets/buttons/buttons.factor | 2 +- extra/ui/gadgets/gadgets.factor | 2 +- extra/ui/gadgets/panes/panes.factor | 2 +- extra/ui/gadgets/scrollers/scrollers.factor | 2 +- extra/ui/gestures/gestures.factor | 2 +- extra/ui/render/render.factor | 2 +- extra/ui/tools/interactor/interactor.factor | 6 +++--- extra/ui/tools/listener/listener.factor | 2 +- extra/ui/tools/walker/walker.factor | 2 +- extra/ui/traverse/traverse.factor | 2 +- extra/ui/windows/windows.factor | 4 ++-- extra/ui/x11/x11.factor | 4 ++-- 12 files changed, 16 insertions(+), 16 deletions(-) diff --git a/extra/ui/gadgets/buttons/buttons.factor b/extra/ui/gadgets/buttons/buttons.factor index 7e649b7ff7..978e5d48e2 100755 --- a/extra/ui/gadgets/buttons/buttons.factor +++ b/extra/ui/gadgets/buttons/buttons.factor @@ -55,7 +55,7 @@ C: button-paint { [ dup button-pressed? ] [ drop button-paint-pressed ] } { [ dup button-selected? ] [ drop button-paint-selected ] } { [ dup button-rollover? ] [ drop button-paint-rollover ] } - { [ t ] [ drop button-paint-plain ] } + [ drop button-paint-plain ] } cond ; M: button-paint draw-interior diff --git a/extra/ui/gadgets/gadgets.factor b/extra/ui/gadgets/gadgets.factor index 3ad76b0a16..f4e5ca2a46 100755 --- a/extra/ui/gadgets/gadgets.factor +++ b/extra/ui/gadgets/gadgets.factor @@ -378,7 +378,7 @@ SYMBOL: in-layout? { { [ 2dup eq? ] [ 2drop t ] } { [ dup not ] [ 2drop f ] } - { [ t ] [ gadget-parent child? ] } + [ gadget-parent child? ] } cond ; GENERIC: focusable-child* ( gadget -- child/t ) diff --git a/extra/ui/gadgets/panes/panes.factor b/extra/ui/gadgets/panes/panes.factor index fedacbd2af..439e938186 100755 --- a/extra/ui/gadgets/panes/panes.factor +++ b/extra/ui/gadgets/panes/panes.factor @@ -88,7 +88,7 @@ C: pane-stream dup gadget-children { { [ dup empty? ] [ 2drop ""