Delete empty unit tests files, remove 1- and 1+, reorder IN: lines in a lot of places...

[factor.git] / basis / fry / fry.factor

diff --git a/basis/fry/fry.factor b/basis/fry/fry.factor
old mode 100755 (executable)
new mode 100644 (file)
index e2feb3c..fd029cc
--- a/basis/fry/fry.factor
+++ b/basis/fry/fry.factor
@@ -1,66 +1,56 @@
 ! 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 namespaces qualified ;
-QUALIFIED: namespaces
+quotations arrays make words locals.backend summary sets ;
 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 ;
+
+ERROR: >r/r>-in-fry-error ;
+
+<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 ;
+
+PREDICATE: fry-specifier < word { _ @ } memq? ;
+
+GENERIC: count-inputs ( quot -- n )
+
+M: callable count-inputs [ count-inputs ] sigma ;
+M: fry-specifier count-inputs drop 1 ;
+M: object count-inputs drop 0 ;
+
+GENERIC: deep-fry ( obj -- )
+
+: shallow-fry ( quot -- quot' curry# )
+    check-fry
+    [ [ deep-fry ] each ] [ ] make
+    [ dup \ @ = [ drop [ _ call ] ] [ 1array ] if ] map concat
+    { _ } split [ spread>quot ] [ length 1 - ] bi ;
+
+PRIVATE>
+
+: fry ( quot -- quot' ) shallow-fry [ncurry] swap prefix ;
+
+M: callable deep-fry
+    [ count-inputs \ _ <repetition> % ] [ fry % ] bi ;
+
+M: object deep-fry , ;
 
-DEFER: (shallow-fry)
-DEFER: shallow-fry
-
-: ((shallow-fry)) ( accum quot adder -- result )
-    >r shallow-fry r>
-    append swap dup empty? [ drop ] [
-        [ prepose ] curry append
-    ] if ; inline
-
-: (shallow-fry) ( accum quot -- result )
-    dup empty? [
-        drop 1quotation
-    ] [
-        unclip {
-            { \ , [ [ curry ] ((shallow-fry)) ] }
-            { \ @ [ [ compose ] ((shallow-fry)) ] }
-
-            ! to avoid confusion, remove if fry goes core
-            { \ namespaces:, [ [ curry ] ((shallow-fry)) ] }
-
-            [ swap >r suffix r> (shallow-fry) ]
-        } case
-    ] if ;
-
-: shallow-fry ( quot -- quot' ) [ ] swap (shallow-fry) ;
-
-: deep-fry ( quot -- quot )
-    { _ } last-split1 dup [
-      shallow-fry [ >r ] rot
-      deep-fry    [ [ dip ] curry r> compose ] 4array concat
-    ] [
-        drop shallow-fry
-    ] if ;
-
-: fry-specifier? ( obj -- ? ) { , namespaces:, @ } member? ;
-
-: count-inputs ( quot -- n )
-    [
-        {
-            { [ dup callable?      ] [ count-inputs ] }
-            { [ dup fry-specifier? ] [ drop 1       ] }
-                                     [ drop 0       ]
-        } cond
-    ] map sum ;
-    
-: fry ( quot -- quot' )
-    [
-        [
-            dup callable? [
-                [ count-inputs \ , <repetition> % ] [ fry % ] bi
-            ] [ namespaces:, ] if
-        ] each
-    ] [ ] make deep-fry ;
-
-: '[ \ ] parse-until fry over push-all ; parsing
+SYNTAX: '[ parse-quotation fry over push-all ;