new fry implementation that builds human-readable quotations (e.g. { 1 2 3 } 4 '[ _ [ _ + ] map ] => [ { 1 2 3 } [ 4 + ] map ])

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 } } ] [

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
+
 <PRIVATE
 
-: [ncurry] ( n -- quot )
-    {
-        { 0 [ [ ] ] }
-        { 1 [ [ curry ] ] }
-        { 2 [ [ 2curry ] ] }
-        { 3 [ [ 3curry ] ] }
-        [ \ curry <repetition> ]
-    } 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 } ;
+
+: <dredge-fry> ( quot -- dredge-fry )
+    V{ } clone V{ } clone dredge-fry-state boa ; inline
+
+: in-quot-slices ( n i state -- head tail )
+    in-quot>>
+    [ <slice> ]
+    [ [ 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 \ _ <repetition> % ] [ fry % ] bi ;
-
-M: object deep-fry , ;
+: fry ( quot -- quot' )
+    0 swap <dredge-fry>
+    [ dredge-fry ] [
+        [ prequot>> >quotation ]
+        [ quot>> >quotation shallow-fry ] bi append
+    ] bi ;
 
 SYNTAX: '[ parse-quotation fry append! ;