Merge branch 'master' of git://factorcode.org/git/factor

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"

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

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
 
 <PRIVATE
+
 : (parallel-each) ( n quot -- )
-    >r <count-down> r> keep await ; inline
+    [ <count-down> ] 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
 
 <PRIVATE
+
+: [future] ( quot -- quot' ) '[ _ curry future ] ; inline
+
 : future-values dup [ ?future ] change-each ; inline
+
 PRIVATE>
 
 : parallel-map ( seq quot -- newseq )
-    [ curry future ] curry map future-values ;
+    [future] map future-values ; inline
-    inline
 
 : 2parallel-map ( seq1 seq2 quot -- newseq )
-    [ 2curry future ] curry 2map future-values ;
+    '[ _ 2curry future ] 2map future-values ;
+
+<PRIVATE
+
+: (parallel-spread) ( n -- spread-array )
+    [ ?future ] <repetition> ; 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 ] ;

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
 

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 ;

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 )
+: word-restarts ( possibilities name -- restarts )
-    natural-sort [
+    [
+        natural-sort
         [
-            "Use the " swap vocabulary>> " vocabulary" 3append
+            [ "Use the " swap vocabulary>> " vocabulary" 3append ] keep
-        ] keep
+        ] { } map>assoc
-    ] { } 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 [