steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
Slava Pestov 2008-07-03 01:40:21 -05:00
parent 2831cb8d9b d0cddcfc41
commit 8356ba71cb
5 changed files with 116 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
extra/bake/bake-tests.factor Normal file
View File

@ -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*

70
extra/bake/bake.factor
View File

@ -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
MACRO: bake ( seq -- quot ) [bake] ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: `{ \ } [ >array ] parse-literal \ bake parsed ; parsing
: `V{ \ } [ >vector ] parse-literal \ bake parsed ; parsing
: `[ \ ] [ >quotation ] parse-literal \ bake parsed ; parsing

3
extra/fry/fry.factor
View File

@ -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

24
extra/newfx/newfx.factor
View File

@ -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> - ;

19
extra/rewrite-closures/rewrite-closures.factor
View File

@ -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 ] ;