diff --git a/extra/bake/bake-tests.factor b/extra/bake/bake-tests.factor new file mode 100644 index 0000000000..7b40d603f1 --- /dev/null +++ b/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* + diff --git a/extra/bake/bake.factor b/extra/bake/bake.factor index 7a12a3cc97..71818bc5c6 100644 --- a/extra/bake/bake.factor +++ b/extra/bake/bake.factor @@ -1,6 +1,7 @@ -USING: kernel parser combinators sequences splitting quotations arrays macros - arrays.lib combinators.cleave combinators.conditional newfx ; +USING: kernel parser namespaces sequences quotations arrays vectors splitting + 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 ] ] } - { [ array? ] [ [bake-array] [ >r ] append ] } - { [ drop t ] [ [ >r ] prefix-on ] } + { [ comma? ] [ drop [ >r ] ] } + { [ integer? ] [ [ >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 [ narray ] prefix-on ] + [ length [ drop [ r> ] ] map concat ] + [ 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 ] - [ length [ drop [ r> append ] ] map concat ] + [ [ [bake] [connector] append [ >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 ; - -MACRO: bake-array ( array -- quot ) [bake-array] ; +: [bake] ( seq -- quot ) [ @ member? ] [ [simmer] ] [ [broil] ] 1if ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: `{ \ } [ >array ] parse-literal \ bake-array parsed ; parsing \ No newline at end of file +MACRO: bake ( seq -- quot ) [bake] ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: `{ \ } [ >array ] parse-literal \ bake parsed ; parsing +: `V{ \ } [ >vector ] parse-literal \ bake parsed ; parsing +: `[ \ ] [ >quotation ] parse-literal \ bake parsed ; parsing \ No newline at end of file diff --git a/extra/fry/fry.factor b/extra/fry/fry.factor index f15a6b24c2..4a97ace2fe 100755 --- a/extra/fry/fry.factor +++ b/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 diff --git a/extra/newfx/newfx.factor b/extra/newfx/newfx.factor index b59e204e0c..e62747a2eb 100644 --- a/extra/newfx/newfx.factor +++ b/extra/newfx/newfx.factor @@ -199,4 +199,26 @@ METHOD: as-mutate { object object assoc } set-at ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: start ( seq subseq -- i ) swap sequences:start ; \ No newline at end of file +: 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> - ; \ No newline at end of file diff --git a/extra/rewrite-closures/rewrite-closures.factor b/extra/rewrite-closures/rewrite-closures.factor index 6e30a11cfc..198e1744bc 100644 --- a/extra/rewrite-closures/rewrite-closures.factor +++ b/extra/rewrite-closures/rewrite-closures.factor @@ -1,28 +1,19 @@ -USING: kernel parser math quotations namespaces sequences namespaces.lib - inference.transforms fry ; +USING: kernel parser math quotations namespaces sequences macros 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 ; - -! : closed-quot ( quot -- quot ) -! [ namestack >r [ namestack ] set-namestack [ ] call r> set-namestack ] make* ; +: scoped-quot ( quot -- quot ) '[ , with-scope ] ; : closed-quot ( quot -- quot ) namestack swap '[ namestack [ , set-namestack @ ] dip set-namestack ] ;