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

Recursive fry

db4
Slava Pestov 2008-04-22 16:29:20 -05:00
parent f1113b7c2a
commit decdaf1e32
2 changed files with 30 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
extra/fry/fry-tests.factor
View File

@ -44,3 +44,7 @@ sequences ;
: funny-dip '[ @ _ ] call ; inline
[ "hi" 3 ] [ "h" "i" 3 [ append ] funny-dip ] unit-test
[ { 1 2 3 } ] [
3 1 '[ , [ , + ] map ] call
] unit-test

39
extra/fry/fry.factor
View File

@ -9,41 +9,54 @@ IN: fry
: @ "Only valid inside a fry" throw ;
: _ "Only valid inside a fry" throw ;
DEFER: (fry)
DEFER: (shallow-fry)
: ((fry)) ( accum quot adder -- result )
>r [ ] swap (fry) r>
: ((shallow-fry)) ( accum quot adder -- result )
>r [ ] swap (shallow-fry) r>
append swap dup empty? [ drop ] [
[ swap compose ] curry append
] if ; inline
: (fry) ( accum quot -- result )
: (shallow-fry) ( accum quot -- result )
dup empty? [
drop 1quotation
] [
unclip {
{ \ , [ [ curry ] ((fry)) ] }
{ \ @ [ [ compose ] ((fry)) ] }
{ \ , [ [ curry ] ((shallow-fry)) ] }
{ \ @ [ [ compose ] ((shallow-fry)) ] }
! to avoid confusion, remove if fry goes core
{ \ namespaces:, [ [ curry ] ((fry)) ] }
{ \ namespaces:, [ [ curry ] ((shallow-fry)) ] }
[ swap >r suffix r> (fry) ]
[ swap >r suffix r> (shallow-fry) ]
} case
] if ;
: trivial-fry ( quot -- quot' ) [ ] swap (fry) ;
: shallow-fry ( quot -- quot' ) [ ] swap (shallow-fry) ;
: fry ( quot -- quot' )
: deep-fry ( quot -- quot' )
{ _ } last-split1 [
[
trivial-fry %
shallow-fry %
[ >r ] %
fry %
deep-fry %
[ [ dip ] curry r> compose ] %
] [ ] make
] [
trivial-fry
shallow-fry
] if* ;
: fry ( quot -- quot' )
[
[
dup callable? [
[
[ { , namespaces:, @ } member? ] subset length
\ , <repetition> %
]
[ deep-fry % ] bi
] [ namespaces:, ] if
] each
] [ ] make deep-fry ;
: '[ \ ] parse-until fry over push-all ; parsing