From 420ff0a447dba13efebbd798e8f352ea563b74ec Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 21 Nov 2008 05:17:51 -0600
Subject: [PATCH] Fry now throws a parse time error if it detects >r r> usage,
 tweak fry to better interact with locals

---
 basis/fry/fry-docs.factor           |  8 +++++-
 basis/fry/fry-tests.factor          | 16 ++++++------
 basis/fry/fry.factor                | 38 ++++++++++++++++-------------
 core/combinators/combinators.factor |  5 +---
 4 files changed, 37 insertions(+), 30 deletions(-)

diff --git a/basis/fry/fry-docs.factor b/basis/fry/fry-docs.factor
index 8f402f2e8c..b5d1b8d8d2 100644
--- a/basis/fry/fry-docs.factor
+++ b/basis/fry/fry-docs.factor
@@ -19,6 +19,9 @@ HELP: '[
 { $description "Literal fried quotation. Expands into code which takes values from the stack and substitutes them in place of the fry specifiers " { $link _ } " and " { $link @ } "." }
 { $examples "See " { $link "fry.examples" } "." } ;
 
+HELP: >r/r>-in-fry-error
+{ $error-description "Thrown by " { $link POSTPONE: '[ } " if the fried quotation contains calls to " { $link >r } " or " { $link r> } ". Explicit retain stack manipulation of this form does not work with fry; use " { $link dip } " instead." } ;
+
 ARTICLE: "fry.examples" "Examples of fried quotations"
 "The easiest way to understand fried quotations is to look at some examples."
 $nl
@@ -73,7 +76,10 @@ ARTICLE: "fry.philosophy" "Fried quotation philosophy"
 } ;
 
 ARTICLE: "fry.limitations" "Fried quotation limitations"
-"As with " { $vocab-link "locals" } ", fried quotations cannot contain " { $link >r } " and " { $link r> } ". This is not a real limitation in practice, since " { $link dip } " can be used instead." ;
+"As with " { $vocab-link "locals" } ", fried quotations cannot contain " { $link >r } " and " { $link r> } ". This is not a real limitation in practice, since " { $link dip } " can be used instead."
+$nl
+"An error thrown if a fried quotation contains calls to " { $link >r } " and " { $link r> } ":"
+{ $subsection >r/r>-in-fry-error } ;
 
 ARTICLE: "fry" "Fried quotations"
 "The " { $vocab-link "fry" } " vocabulary implements " { $emphasis "fried quotation" } ". Conceptually, fried quotations are quotations with ``holes'' (more formally, " { $emphasis "fry specifiers" } "), and the holes are filled in when the fried quotation is pushed on the stack."
diff --git a/basis/fry/fry-tests.factor b/basis/fry/fry-tests.factor
index d4a3b8b734..27d5430d33 100644
--- a/basis/fry/fry-tests.factor
+++ b/basis/fry/fry-tests.factor
@@ -1,23 +1,20 @@
 IN: fry.tests
 USING: fry tools.test math prettyprint kernel io arrays
-sequences ;
+sequences eval accessors ;
 
 [ [ 3 + ] ] [ 3 '[ _ + ] ] unit-test
 
 [ [ 1 3 + ] ] [ 1 3 '[ _ _ + ] ] unit-test
 
-[ [ 1 + ] ] [ 1 [ + ] '[ _ @ ] ] unit-test
+[ [ 1 [ + ] call ] ] [ 1 [ + ] '[ _ @ ] ] unit-test
 
-[ [ 1 + . ] ] [ 1 [ + ] '[ _ @ . ] ] unit-test
+[ [ 1 [ + ] call . ] ] [ 1 [ + ] '[ _ @ . ] ] unit-test
 
-[ [ + - ] ] [ [ + ] [ - ] '[ @ @ ] ] unit-test
+[ [ [ + ] [ - ] [ call ] dip call ] ] [ [ + ] [ - ] '[ @ @ ] ] unit-test
 
-[ [ "a" write "b" print ] ]
+[ [ "a" "b" [ write ] dip print ] ]
 [ "a" "b" '[ _ write _ print ] ] unit-test
 
-[ [ 1 2 + 3 4 - ] ]
-[ [ + ] [ - ] '[ 1 2 @ 3 4 @ ] ] unit-test
-
 [ 1/2 ] [
     1 '[ [ _ ] dip / ] 2 swap call
 ] unit-test
@@ -58,3 +55,6 @@ sequences ;
 [ { { { 3 } } } ] [
     3 '[ [ [ _ 1array ] call 1array ] call 1array ] call
 ] unit-test
+
+[ "USING: fry kernel ; f '[ >r _ r> ]" eval ]
+[ error>> >r/r>-in-fry-error? ] must-fail-with
diff --git a/basis/fry/fry.factor b/basis/fry/fry.factor
index 87c59e18a0..bab49de108 100644
--- a/basis/fry/fry.factor
+++ b/basis/fry/fry.factor
@@ -1,33 +1,37 @@
 ! 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 ;
+quotations arrays make words locals.backend summary sets ;
 IN: fry
 
 : _ ( -- * ) "Only valid inside a fry" throw ;
 : @ ( -- * ) "Only valid inside a fry" throw ;
 
+ERROR: >r/r>-in-fry-error ;
+
 <PRIVATE
 
-DEFER: (shallow-fry)
-DEFER: shallow-fry
+: [ncurry] ( n -- quot )
+    {
+        { 0 [ [ ] ] }
+        { 1 [ [ curry ] ] }
+        { 2 [ [ 2curry ] ] }
+        { 3 [ [ 3curry ] ] }
+        [ [ curry ] <repetition> ]
+    } case ;
 
-: ((shallow-fry)) ( accum quot adder -- result )
-    >r shallow-fry r>
-    append swap [
-        [ prepose ] curry append
-    ] unless-empty ; inline
+M: >r/r>-in-fry-error summary
+    drop
+    "Explicit retain stack manipulation is not permitted in fried quotations" ;
 
-: (shallow-fry) ( accum quot -- result )
-    [ 1quotation ] [
-        unclip {
-            { \ _ [ [ curry ] ((shallow-fry)) ] }
-            { \ @ [ [ compose ] ((shallow-fry)) ] }
-            [ swap >r suffix r> (shallow-fry) ]
-        } case
-    ] if-empty ;
+: check-fry ( quot -- quot )
+    dup { >r r> load-locals get-local drop-locals } intersect
+    empty? [ >r/r>-in-fry-error ] unless ;
 
-: shallow-fry ( quot -- quot' ) [ ] swap (shallow-fry) ;
+: shallow-fry ( quot -- quot' )
+    check-fry
+    [ dup \ @ = [ drop [ _ call ] ] [ 1array ] if ] map concat
+    { _ } split [ length 1- [ncurry] ] [ spread>quot ] bi prefix ;
 
 PREDICATE: fry-specifier < word { _ @ } memq? ;
 
diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor
index 8cfa671a8b..82744276fd 100644
--- a/core/combinators/combinators.factor
+++ b/core/combinators/combinators.factor
@@ -28,10 +28,7 @@ IN: combinators
 
 ! spread
 : spread>quot ( seq -- quot )
-    [ ] [
-        [ dup empty? [ [ >r ] swap [ r> ] 3append ] unless ] dip
-        append
-    ] reduce ;
+    [ ] [ [ dup empty? [ [ dip ] curry ] unless ] dip append ] reduce ;
 
 : spread ( objs... seq -- )
     spread>quot call ;