diff --git a/basis/fry/fry-tests.factor b/basis/fry/fry-tests.factor index 549db25e09..b57c562c61 100644 --- a/basis/fry/fry-tests.factor +++ b/basis/fry/fry-tests.factor @@ -1,18 +1,39 @@ -USING: fry tools.test math prettyprint kernel io arrays +! (c)2009 Slava Pestov, Eduardo Cavazos, Joe Groff bsd license +USING: new.fry tools.test math prettyprint kernel io arrays sequences eval accessors ; IN: fry.tests +SYMBOLS: a b c d e f g h ; + +[ [ 1 ] ] [ 1 '[ _ ] ] unit-test +[ [ 1 ] ] [ [ 1 ] '[ @ ] ] unit-test +[ [ 1 2 ] ] [ [ 1 ] [ 2 ] '[ @ @ ] ] unit-test + +[ [ 1 2 a ] ] [ 1 2 '[ _ _ a ] ] unit-test +[ [ 1 2 a ] ] [ [ 1 ] [ 2 ] '[ @ @ a ] ] unit-test +[ [ 1 a 2 b ] ] [ 1 2 '[ _ a _ b ] ] unit-test +[ [ 1 a 2 b ] ] [ 1 [ 2 ] '[ _ a @ b ] ] unit-test +[ [ a 1 b ] ] [ 1 '[ a _ b ] ] unit-test + +[ [ a 1 b ] ] [ [ 1 ] '[ a @ b ] ] unit-test +[ [ a 1 2 ] ] [ [ 1 ] [ 2 ] '[ a @ @ ] ] unit-test + +[ [ a [ 1 ] b ] ] [ 1 '[ a [ _ ] b ] ] unit-test +[ [ a 1 b [ c 2 d ] e 3 f ] ] [ 1 2 3 '[ a _ b [ c _ d ] e _ f ] ] unit-test +[ [ a 1 b [ c 2 d [ e 3 f ] ] g 4 h ] ] [ 1 2 3 4 '[ a _ b [ c _ d [ e _ f ] ] g _ h ] ] unit-test +[ [ a 1 b [ [ c 2 d ] e 3 f ] g 4 h ] ] [ 1 2 3 4 '[ a _ b [ [ c _ d ] e _ f ] g _ h ] ] unit-test + [ [ 3 + ] ] [ 3 '[ _ + ] ] unit-test [ [ 1 3 + ] ] [ 1 3 '[ _ _ + ] ] unit-test -[ [ 1 [ + ] call ] ] [ 1 [ + ] '[ _ @ ] ] unit-test +[ [ 1 + ] ] [ 1 [ + ] '[ _ @ ] ] unit-test -[ [ 1 [ + ] call . ] ] [ 1 [ + ] '[ _ @ . ] ] unit-test +[ [ 1 + . ] ] [ 1 [ + ] '[ _ @ . ] ] unit-test -[ [ [ + ] [ - ] [ call ] dip call ] ] [ [ + ] [ - ] '[ @ @ ] ] unit-test +[ [ + - ] ] [ [ + ] [ - ] '[ @ @ ] ] unit-test -[ [ "a" "b" [ write ] dip print ] ] +[ [ "a" write "b" print ] ] [ "a" "b" '[ _ write _ print ] ] unit-test [ 1/2 ] [ @@ -56,7 +77,7 @@ IN: fry.tests 3 '[ [ [ _ 1array ] call 1array ] call 1array ] call ] unit-test -[ "USING: fry locals.backend ; f '[ load-local _ ]" eval( -- quot ) ] +[ "USING: new.fry locals.backend ; f '[ load-local _ ]" eval( -- quot ) ] [ error>> >r/r>-in-fry-error? ] must-fail-with [ { { "a" 1 } { "b" 2 } { "c" 3 } { "d" 4 } } ] [ diff --git a/basis/fry/fry.factor b/basis/fry/fry.factor index 184c6247a6..991ab76420 100644 --- a/basis/fry/fry.factor +++ b/basis/fry/fry.factor @@ -1,7 +1,6 @@ -! Copyright (C) 2008 Slava Pestov, Eduardo Cavazos. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences combinators parser splitting math -quotations arrays make words locals.backend summary sets ; +! (c)2009 Slava Pestov, Eduardo Cavazos, Joe Groff bsd license +USING: accessors combinators kernel locals.backend math parser +quotations sequences sets splitting words ; IN: fry : _ ( -- * ) "Only valid inside a fry" throw ; @@ -9,21 +8,10 @@ IN: fry ERROR: >r/r>-in-fry-error ; +DEFER: fry + ] - } case ; - -M: >r/r>-in-fry-error summary - drop - "Explicit retain stack manipulation is not permitted in fried quotations" ; - : check-fry ( quot -- quot ) dup { load-local load-locals get-local drop-locals } intersect [ >r/r>-in-fry-error ] unless-empty ; @@ -36,21 +24,78 @@ M: callable count-inputs [ count-inputs ] map-sum ; M: fry-specifier count-inputs drop 1 ; M: object count-inputs drop 0 ; -GENERIC: deep-fry ( obj -- ) +PREDICATE: fried-callable < callable + count-inputs 0 > ; -: shallow-fry ( quot -- quot' curry# ) +: convert-curry ( quot -- quot' ) + [ [ [ ] curry compose ] ] [ + dup first \ @ = + [ rest >quotation \ compose \ compose [ ] 3sequence ] + [ >quotation \ curry \ compose [ ] 3sequence ] if + ] if-empty ; + +: convert-curries ( seq -- seq' ) + unclip-slice [ [ convert-curry ] map ] [ >quotation 1quotation ] bi* prefix ; + +: shallow-fry ( quot -- quot' ) check-fry - [ [ deep-fry ] each ] [ ] make - [ dup \ @ = [ drop [ _ call ] ] [ 1array ] if ] map concat - { _ } split [ spread>quot ] [ length 1 - ] bi ; + [ dup \ @ = [ drop [ _ @ ] ] [ 1quotation ] if ] map concat + { _ } split convert-curries + spread>quot ; + +: [ndip] ( quot n -- quot' ) + { + { 0 [ \ call [ ] 2sequence ] } + { 1 [ \ dip [ ] 2sequence ] } + { 2 [ \ 2dip [ ] 2sequence ] } + { 3 [ \ 3dip [ ] 2sequence ] } + [ [ \ dip [ ] 2sequence ] times ] + } case ; + +DEFER: dredge-fry + +TUPLE: dredge-fry-state + { in-quot read-only } + { prequot read-only } + { quot read-only } ; + +: ( quot -- dredge-fry ) + V{ } clone V{ } clone dredge-fry-state boa ; inline + +: in-quot-slices ( n i state -- head tail ) + in-quot>> + [ ] + [ [ drop ] 2dip swap 1 + tail-slice ] 3bi ; inline + +: push-head-slice ( head state -- ) + quot>> [ push-all ] [ \ _ swap push ] bi ; inline + +: push-subquot ( tail elt state -- ) + [ fry swap >quotation count-inputs [ndip] ] dip prequot>> push-all ; inline + +: (dredge-fry-subquot) ( n state i elt -- ) + rot { + [ nip in-quot-slices ] ! head tail i elt state + [ [ 2drop swap ] dip push-head-slice ] + [ [ drop ] 2dip push-subquot ] + [ [ 1 + ] [ drop ] [ ] tri* dredge-fry ] + } 3cleave ; inline recursive + +: (dredge-fry-simple) ( n state -- ) + [ in-quot>> swap tail-slice ] [ quot>> ] bi push-all ; inline recursive + +: dredge-fry ( n dredge-fry -- ) + 2dup in-quot>> [ fried-callable? ] find-from + [ (dredge-fry-subquot) ] + [ drop (dredge-fry-simple) ] if* ; inline recursive PRIVATE> -: fry ( quot -- quot' ) shallow-fry [ncurry] swap prefix ; - -M: callable deep-fry - [ count-inputs \ _ % ] [ fry % ] bi ; - -M: object deep-fry , ; +: fry ( quot -- quot' ) + 0 swap + [ dredge-fry ] [ + [ prequot>> >quotation ] + [ quot>> >quotation shallow-fry ] bi append + ] bi ; SYNTAX: '[ parse-quotation fry append! ;