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 : funny-dip '[ @ _ ] call ; inline
[ "hi" 3 ] [ "h" "i" 3 [ append ] funny-dip ] unit-test [ "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 ;
: _ "Only valid inside a fry" throw ; : _ "Only valid inside a fry" throw ;
DEFER: (fry) DEFER: (shallow-fry)
: ((fry)) ( accum quot adder -- result ) : ((shallow-fry)) ( accum quot adder -- result )
>r [ ] swap (fry) r> >r [ ] swap (shallow-fry) r>
append swap dup empty? [ drop ] [ append swap dup empty? [ drop ] [
[ swap compose ] curry append [ swap compose ] curry append
] if ; inline ] if ; inline
: (fry) ( accum quot -- result ) : (shallow-fry) ( accum quot -- result )
dup empty? [ dup empty? [
drop 1quotation drop 1quotation
] [ ] [
unclip { unclip {
{ \ , [ [ curry ] ((fry)) ] } { \ , [ [ curry ] ((shallow-fry)) ] }
{ \ @ [ [ compose ] ((fry)) ] } { \ @ [ [ compose ] ((shallow-fry)) ] }
! to avoid confusion, remove if fry goes core ! 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 } case
] if ; ] if ;
: trivial-fry ( quot -- quot' ) [ ] swap (fry) ; : shallow-fry ( quot -- quot' ) [ ] swap (shallow-fry) ;
: fry ( quot -- quot' ) : deep-fry ( quot -- quot' )
{ _ } last-split1 [ { _ } last-split1 [
[ [
trivial-fry % shallow-fry %
[ >r ] % [ >r ] %
fry % deep-fry %
[ [ dip ] curry r> compose ] % [ [ dip ] curry r> compose ] %
] [ ] make ] [ ] make
] [ ] [
trivial-fry shallow-fry
] if* ; ] 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 : '[ \ ] parse-until fry over push-all ; parsing