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

extra/bake/bake-tests.factor

@@ -0,0 +1,34 @@
+
+USING: kernel tools.test bake ;
+
+IN: bake.tests
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: unit-test* ( input output -- ) swap unit-test ;
+
+: must-be-t ( in -- ) [ t ] swap unit-test ;
+: must-be-f ( in -- ) [ f ] swap unit-test ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+[ 10 20 30 `{ , , , } ] [ { 10 20 30 } ] unit-test*
+
+[ 10 20 30 `{ , { , } , } ] [ { 10 { 20 } 30 } ] unit-test*
+
+[ 10 { 20 21 22 } 30 `{ , , , } ] [ { 10 { 20 21 22 } 30 } ] unit-test*
+
+[ 10 { 20 21 22 } 30 `{ , @ , } ] [ { 10 20 21 22 30 } ] unit-test*
+
+[ { 1 2 3 } `{ @ } ] [ { 1 2 3 } ] unit-test*
+
+[ { 1 2 3 } { 4 5 6 } { 7 8 9 } `{ @ @ @ } ]
+[ { 1 2 3 4 5 6 7 8 9 } ]
+unit-test*
+
+[ 10 20 30 40 `[ , V{ , { , } } , ] ] [ [ 10 V{ 20 { 30 } } 40 ] ] unit-test*
+
+[ { 1 2 3 } { 4 5 6 } { 7 8 9 } `[ , { V{ @ } { , } } ] ]
+[ [ { 1 2 3 } { V{ 4 5 6 } { { 7 8 9 } } } ] ]
+unit-test*
+

extra/bake/bake.factor

@@ -1,6 +1,7 @@
 
-USING: kernel parser combinators sequences splitting quotations arrays macros
+USING: kernel parser namespaces sequences quotations arrays vectors splitting
-       arrays.lib combinators.cleave combinators.conditional newfx ;
+       math
+       macros arrays.lib combinators.lib combinators.conditional newfx ;
 
 IN: bake
 
@@ -14,46 +15,79 @@ SYMBOL: @
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-DEFER: [bake-array]
+DEFER: [bake]
 
 : broil-element ( obj -- quot )
     {
-      { [ comma? ] [ drop [ >r ]               ] }
+      { [ comma?    ] [ drop [ >r ]          ] }
-      { [ array? ] [ [bake-array] [ >r ] append ] }
+      { [ integer?  ] [ [ >r ] prefix-on     ] }
-      { [ drop t ] [ [ >r ] prefix-on          ] }
+      { [ sequence? ] [ [bake] [ >r ] append ] }
+      { [ drop t    ] [ [ >r ] prefix-on     ] }
     }
   1cond ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: [broil] ( array -- quot )
+: constructor ( seq -- quot )
+    {
+      { [ array? ]     [ length [ narray ] prefix-on ] }
+      { [ quotation? ] [ length [ ncurry ] prefix-on [ ] prefix ] }
+      { [ vector? ]    [ length [ narray >vector ] prefix-on ] }
+    }
+  1cond ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: [broil] ( seq -- quot )
     [ reverse [ broil-element ] map concat ]
-    [ length [ drop [ r> ] ] map concat ]
+    [ length  [ drop [ r> ]   ] map concat ]
-    [ length [ narray ] prefix-on ]
+    [ constructor ]
   tri append append
   >quotation ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: [simmer] ( array -- quot )
+SYMBOL: saved-sequence
+
+: [connector] ( -- quot )
+  saved-sequence get quotation? [ [ compose ] ] [ [ append ] ] if ;
+
+: [starter] ( -- quot )
+  saved-sequence get
+    {
+      { [ quotation? ] [ drop [  [ ] ] ] }
+      { [ array?     ] [ drop [  { } ] ] }
+      { [ vector?    ] [ drop [ V{ } ] ] }
+    }
+  1cond ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: [simmer] ( seq -- quot )
+
+  dup saved-sequence set
 
   { @ } split reverse
-    [        [ [bake-array] [ append ] append [ >r ] append ] map concat ]
+    [ [ [bake] [connector] append [ >r ] append ] map concat ]
-    [ length [ drop [ r> append ]                          ] map concat ]
+    [ length [ drop [ r> ] [connector] append   ] map concat ]
   bi
 
-  >r 2 head* [ >r ] append r> ! remove the last append
+  >r 1 invert-index pluck r> ! remove the last append/compose
 
-  [ { } ] swap append
+  [starter] prepend
 
   append ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: [bake-array] ( array -- quot ) [ @ member? ] [ [simmer] ] [ [broil] ] 1if ;
+: [bake] ( seq -- quot ) [ @ member? ] [ [simmer] ] [ [broil] ] 1if ;
-
-MACRO: bake-array ( array -- quot ) [bake-array] ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: `{ \ } [ >array ] parse-literal \ bake-array parsed ; parsing
+MACRO: bake ( seq -- quot ) [bake] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: `{  \ } [ >array     ] parse-literal \ bake parsed ; parsing
+: `V{ \ } [ >vector    ] parse-literal \ bake parsed ; parsing
+: `[  \ ] [ >quotation ] parse-literal \ bake parsed ; parsing

extra/fry/fry.factor

@@ -10,9 +10,10 @@ IN: fry
 : _ ( -- * ) "Only valid inside a fry" throw ;
 
 DEFER: (shallow-fry)
+DEFER: shallow-fry
 
 : ((shallow-fry)) ( accum quot adder -- result )
-    >r [ ] swap (shallow-fry) r>
+    >r shallow-fry r>
     append swap dup empty? [ drop ] [
         [ prepose ] curry append
     ] if ; inline

extra/newfx/newfx.factor

@@ -199,4 +199,26 @@ METHOD: as-mutate { object object assoc }       set-at ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: start ( seq subseq -- i ) swap sequences:start ;
+: start ( seq subseq -- i ) swap sequences:start ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: pluck         ( seq i   -- seq ) cut-slice rest-slice append ;
+: pluck-from    ( i   seq -- seq ) swap pluck ;
+: pluck!        ( seq i   -- seq ) over delete-nth ;
+: pluck-from!   ( i   seq -- seq ) tuck delete-nth ;
+: plucked!      ( seq i   --     ) swap delete-nth ;
+: plucked-from! ( i   seq --     )      delete-nth ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: snip          ( seq a b -- seq ) >r over r> [ head ] [ tail ] 2bi* append ;
+: snip-this     ( a b seq -- seq ) -rot snip ;
+: snip!         ( seq a b -- seq )      pick delete-slice ;
+: snip-this!    ( a b seq -- seq ) -rot pick delete-slice ;
+: snipped!      ( seq a b --     )       rot delete-slice ;
+: snipped-from! ( a b seq --     )           delete-slice ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: invert-index ( seq i -- seq i ) >r dup length 1 - r> - ;

extra/rewrite-closures/rewrite-closures.factor

@@ -1,28 +1,19 @@
 
-USING: kernel parser math quotations namespaces sequences namespaces.lib 
+USING: kernel parser math quotations namespaces sequences macros fry ;
-       inference.transforms fry ;
 
 IN: rewrite-closures
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-! : set-parameters ( seq -- ) reverse [ set ] each ;
+: [set-parameters] ( seq -- quot ) reverse [ [ set ] curry ] map concat ;
 
-: [set-parameters] ( seq -- quot ) [ [ set ] curry ] map concat ;
+MACRO: set-parameters ( seq -- quot ) [set-parameters] ;
 
-: set-parameters ( seq -- ) [set-parameters] call ;
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-\ set-parameters [ [set-parameters] ] 1 define-transform
-
-! : parametric-quot ( parameters quot -- quot )
-! [ [ swap ] set-parameters [ ] call ] make* ;
 
 : parametric-quot ( parameters quot -- quot ) '[ , set-parameters , call ] ;
 
-: scoped-quot ( quot -- quot ) [ with-scope ] curry ;
+: scoped-quot ( quot -- quot ) '[ , with-scope ] ;
-
-! : closed-quot ( quot -- quot )
-! [ namestack >r [ namestack ] set-namestack [ ] call r> set-namestack ] make* ;
 
 : closed-quot ( quot -- quot )
   namestack swap '[ namestack [ , set-namestack @ ] dip set-namestack ] ;