diff --git a/basis/concurrency/combinators/combinators-docs.factor b/basis/concurrency/combinators/combinators-docs.factor index cb07e5a8d6..c61967fc8a 100644 --- a/basis/concurrency/combinators/combinators-docs.factor +++ b/basis/concurrency/combinators/combinators-docs.factor @@ -27,11 +27,17 @@ HELP: parallel-filter { $errors "Throws an error if one of the iterations throws an error." } ; ARTICLE: "concurrency.combinators" "Concurrent combinators" -"The " { $vocab-link "concurrency.combinators" } " vocabulary provides concurrent variants of " { $link each } ", " { $link map } " and " { $link filter } ":" +"The " { $vocab-link "concurrency.combinators" } " vocabulary provides concurrent variants of various combinators." +$nl +"Concurrent sequence combinators:" { $subsection parallel-each } { $subsection 2parallel-each } { $subsection parallel-map } { $subsection 2parallel-map } -{ $subsection parallel-filter } ; +{ $subsection parallel-filter } +"Concurrent cleave combinators:" +{ $subsection parallel-cleave } +{ $subsection parallel-spread } +{ $subsection parallel-napply } ; ABOUT: "concurrency.combinators" diff --git a/basis/concurrency/combinators/combinators-tests.factor b/basis/concurrency/combinators/combinators-tests.factor index 562111242d..3a38daed86 100644 --- a/basis/concurrency/combinators/combinators-tests.factor +++ b/basis/concurrency/combinators/combinators-tests.factor @@ -1,6 +1,7 @@ IN: concurrency.combinators.tests USING: concurrency.combinators tools.test random kernel math -concurrency.mailboxes threads sequences accessors arrays ; +concurrency.mailboxes threads sequences accessors arrays +math.parser ; [ [ drop ] parallel-each ] must-infer { 2 0 } [ [ 2drop ] 2parallel-each ] must-infer-as @@ -45,3 +46,10 @@ concurrency.mailboxes threads sequences accessors arrays ; ] unit-test [ { f } [ "OOPS" throw ] parallel-each ] must-fail + +[ "1a" "4b" "3c" ] [ + 2 + { [ 1- ] [ sq ] [ 1+ ] } parallel-cleave + [ number>string ] 3 parallel-napply + { [ "a" append ] [ "b" append ] [ "c" append ] } parallel-spread +] unit-test diff --git a/basis/concurrency/combinators/combinators.factor b/basis/concurrency/combinators/combinators.factor index ab3ca7ed4a..4608faf79b 100644 --- a/basis/concurrency/combinators/combinators.factor +++ b/basis/concurrency/combinators/combinators.factor @@ -1,34 +1,58 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: concurrency.futures concurrency.count-downs sequences -kernel ; +kernel macros fry combinators generalizations ; IN: concurrency.combinators r r> keep await ; inline + [ ] dip keep await ; inline + PRIVATE> : parallel-each ( seq quot -- ) over length [ - [ >r curry r> spawn-stage ] 2curry each + '[ _ curry _ spawn-stage ] each ] (parallel-each) ; inline : 2parallel-each ( seq1 seq2 quot -- ) 2over min-length [ - [ >r 2curry r> spawn-stage ] 2curry 2each + '[ _ 2curry _ spawn-stage ] 2each ] (parallel-each) ; inline : parallel-filter ( seq quot -- newseq ) - over >r pusher >r each r> r> like ; inline + over [ pusher [ each ] dip ] dip like ; inline : parallel-map ( seq quot -- newseq ) - [ curry future ] curry map future-values ; - inline + [future] map future-values ; inline : 2parallel-map ( seq1 seq2 quot -- newseq ) - [ 2curry future ] curry 2map future-values ; + '[ _ 2curry future ] 2map future-values ; + + ; inline + +: (parallel-cleave) ( quots -- quot-array spread-array ) + [ [future] ] map dup length (parallel-spread) ; inline + +PRIVATE> + +MACRO: parallel-cleave ( quots -- ) + (parallel-cleave) '[ _ cleave _ spread ] ; + +MACRO: parallel-spread ( quots -- ) + (parallel-cleave) '[ _ spread _ spread ] ; + +MACRO: parallel-napply ( quot n -- ) + [ [future] ] dip dup (parallel-spread) '[ _ _ napply _ spread ] ; diff --git a/basis/prettyprint/prettyprint.factor b/basis/prettyprint/prettyprint.factor index 3befdaff2b..1ecca0ec19 100644 --- a/basis/prettyprint/prettyprint.factor +++ b/basis/prettyprint/prettyprint.factor @@ -7,7 +7,7 @@ prettyprint.config sorting splitting grouping math.parser vocabs definitions effects classes.builtin classes.tuple io.files classes continuations hashtables classes.mixin classes.union classes.intersection classes.predicate classes.singleton -combinators quotations sets accessors colors ; +combinators quotations sets accessors colors parser ; IN: prettyprint : make-pprint ( obj quot -- block in use ) @@ -48,6 +48,22 @@ IN: prettyprint dupd remove [ { "syntax" "scratchpad" } member? not ] filter use. in. ; +: vocab-names ( words -- vocabs ) + dictionary get + [ [ words>> eq? nip ] with assoc-find 2drop ] curry map sift ; + +: prelude. ( -- ) + in get use get vocab-names vocabs. ; + +[ + nl + "Restarts were invoked adding vocabularies to the search path." print + "To avoid doing this in the future, add the following USING:" print + "and IN: forms at the top of the source file:" print nl + prelude. + nl +] print-use-hook set-global + : with-use ( obj quot -- ) make-pprint vocabs. do-pprint ; inline diff --git a/basis/tools/completion/completion.factor b/basis/tools/completion/completion.factor index 4bb6d6142f..2306ff53a8 100644 --- a/basis/tools/completion/completion.factor +++ b/basis/tools/completion/completion.factor @@ -72,7 +72,9 @@ IN: tools.completion ] if ; : string-completions ( short strs -- seq ) - [ dup ] { } map>assoc completions ; + dup zip completions ; : limited-completions ( short candidates -- seq ) - completions dup length 1000 > [ drop f ] when ; + [ completions ] [ drop ] 2bi + 2dup [ length 50 > ] [ empty? ] bi* and + [ 2drop f ] [ drop 50 short head ] if ; diff --git a/core/parser/parser.factor b/core/parser/parser.factor index ed8fc4510b..00d13e6e56 100644 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -52,7 +52,12 @@ SYMBOL: in M: parsing-word stack-effect drop (( parsed -- parsed )) ; -ERROR: no-current-vocab ; +TUPLE: no-current-vocab ; + +: no-current-vocab ( -- vocab ) + \ no-current-vocab boa + { { "Define words in scratchpad vocabulary" "scratchpad" } } + throw-restarts dup set-in ; : current-vocab ( -- str ) in get [ no-current-vocab ] unless* ; @@ -64,20 +69,31 @@ ERROR: no-current-vocab ; : CREATE-WORD ( -- word ) CREATE dup reset-generic ; -: word-restarts ( possibilities -- restarts ) - natural-sort [ +: word-restarts ( possibilities name -- restarts ) + [ + natural-sort [ - "Use the " swap vocabulary>> " vocabulary" 3append - ] keep - ] { } map>assoc ; + [ "Use the " swap vocabulary>> " vocabulary" 3append ] keep + ] { } map>assoc + ] + [ "Defer word in current vocabulary" swap 2array ] bi* + suffix ; ERROR: no-word-error name ; +SYMBOL: amended-use? + +: no-word-restarted ( restart-value -- word ) + dup word? + [ amended-use? on dup vocabulary>> (use+) ] + [ create-in ] + if ; + : no-word ( name -- newword ) dup \ no-word-error boa - swap words-named [ forward-reference? not ] filter + swap [ words-named [ forward-reference? not ] filter ] keep word-restarts throw-restarts - dup vocabulary>> (use+) ; + no-word-restarted ; : check-forward ( str word -- word/f ) dup forward-reference? [ @@ -127,7 +143,9 @@ ERROR: staging-violation word ; : parsed ( accum obj -- accum ) over push ; : (parse-lines) ( lexer -- quot ) - [ f parse-until >quotation ] with-lexer ; + [ + f parse-until >quotation + ] with-lexer ; : parse-lines ( lines -- quot ) lexer-factory get call (parse-lines) ; @@ -206,8 +224,18 @@ SYMBOL: interactive-vocabs call ] with-scope ; inline +SYMBOL: print-use-hook + +[ ] print-use-hook set-global + : parse-fresh ( lines -- quot ) - [ parse-lines ] with-file-vocabs ; + [ + amended-use? off + parse-lines + amended-use? get [ + print-use-hook get call + ] when + ] with-file-vocabs ; : parsing-file ( file -- ) "quiet" get [