Fix some bugs in locals, throw a parse time error if usage of >r r> is detected

basis/locals/locals-docs.factor

@@ -132,8 +132,8 @@ $nl
 "Unlike some languages such as Python and Java, writing to mutable locals in outer scopes is fully supported and has the expected semantics." ;
 
 ARTICLE: "locals-limitations" "Limitations of locals"
-"The first limitation is that the " { $link >r } " and " { $link r> } " words may not be used together with locals. Instead, use the " { $link dip } " combinator."
+"The first limitation is also shared by " { $vocab-link "fry" } ": the " { $link >r } " and " { $link r> } " words may not be used together with locals. Instead, use the " { $link dip } " combinator. An error is thrown at parse time if an attempt is made to use " { $link >r } " and " { $link r> } " inside a lambda body:"
-$nl
+{ $subsection >r/r>-in-lambda-error }
 "Another limitation concerns combinators implemented as macros. Locals can only be used with such combinators if the input array immediately precedes the combinator call. For example, the following will work:"
 { $code
     ":: good-cond-usage ( a -- ... )"

basis/locals/locals-tests.factor

@@ -2,7 +2,7 @@ USING: locals math sequences tools.test hashtables words kernel
 namespaces arrays strings prettyprint io.streams.string parser
 accessors generic eval combinators combinators.short-circuit
 combinators.short-circuit.smart math.order math.functions
-definitions compiler.units ;
+definitions compiler.units fry ;
 IN: locals.tests
 
 :: foo ( a b -- a a ) a a ;
@@ -286,6 +286,8 @@ M:: sequence method-with-locals ( a -- y ) a reverse ;
         { [ a b > ] [ 5 ] }
     } cond ;
 
+\ cond-test must-infer
+
 [ 3 ] [ 1 2 cond-test ] unit-test
 [ 4 ] [ 2 2 cond-test ] unit-test
 [ 5 ] [ 3 2 cond-test ] unit-test
@@ -293,6 +295,8 @@ M:: sequence method-with-locals ( a -- y ) a reverse ;
 :: 0&&-test ( a -- ? )
     { [ a integer? ] [ a even? ] [ a 10 > ] } 0&& ;
 
+\ 0&&-test must-infer
+
 [ f ] [ 1.5 0&&-test ] unit-test
 [ f ] [ 3 0&&-test ] unit-test
 [ f ] [ 8 0&&-test ] unit-test
@@ -301,6 +305,8 @@ M:: sequence method-with-locals ( a -- y ) a reverse ;
 :: &&-test ( a -- ? )
     { [ a integer? ] [ a even? ] [ a 10 > ] } && ;
 
+\ &&-test must-infer
+
 [ f ] [ 1.5 &&-test ] unit-test
 [ f ] [ 3 &&-test ] unit-test
 [ f ] [ 8 &&-test ] unit-test
@@ -346,6 +352,10 @@ M:: sequence method-with-locals ( a -- y ) a reverse ;
 
 { 3 1 } [| from to seq | T{ slice f from to seq } ] must-infer-as
 
+ERROR: punned-class x ;
+
+[ T{ punned-class f 3 } ] [ 3 [| a | T{ punned-class f a } ] call ] unit-test
+
 :: literal-identity-test ( -- a b )
     { } V{ } ;
 
@@ -390,6 +400,18 @@ M:: integer lambda-method-forget-test ( a -- b ) ;
 
 [ { [ 10 ] } ] [ 10 [| A | { [ A ] } ] call ] unit-test
 
+[
+    "USING: locals fry math ; [ 0 '[ [let | A [ 10 ] | A _ + ] ] ]" eval
+] [ error>> >r/r>-in-fry-error? ] must-fail-with
+
+:: (funny-macro-test) ( obj quot -- ? ) obj { quot } 1&& ; inline
+: funny-macro-test ( n -- ? ) [ odd? ] (funny-macro-test) ;
+
+\ funny-macro-test must-infer
+
+[ t ] [ 3 funny-macro-test ] unit-test
+[ f ] [ 2 funny-macro-test ] unit-test
+
 ! :: wlet-&&-test ( a -- ? )
 !     [wlet | is-integer? [ a integer? ]
 !             is-even? [ a even? ]

basis/locals/locals.factor

@@ -6,12 +6,18 @@ quotations debugger macros arrays macros splitting combinators
 prettyprint.backend definitions prettyprint hashtables
 prettyprint.sections sets sequences.private effects
 effects.parser generic generic.parser compiler.units accessors
-locals.backend memoize macros.expander lexer classes ;
+locals.backend memoize macros.expander lexer classes summary ;
 IN: locals
 
 ! Inspired by
 ! http://cat-language.googlecode.com/svn/trunk/CatPointFreeForm.cs
 
+ERROR: >r/r>-in-lambda-error ;
+
+M: >r/r>-in-lambda-error summary
+    drop
+    "Explicit retain stack manipulation is not permitted in lambda bodies" ;
+
 <PRIVATE
 
 TUPLE: lambda vars body ;
@@ -141,20 +147,17 @@ GENERIC: free-vars* ( form -- )
 : free-vars ( form -- vars )
     [ free-vars* ] { } make prune ;
 
-: add-if-free ( object -- )
+M: local-writer free-vars* "local-reader" word-prop , ;
-    {
+
-        { [ dup local-writer? ] [ "local-reader" word-prop , ] }
+M: lexical free-vars* , ;
-        { [ dup lexical? ] [ , ] }
+
-        { [ dup quote? ] [ local>> , ] }
+M: quote free-vars* , ;
-        { [ t ] [ free-vars* ] }
-    } cond ;
 
 M: object free-vars* drop ;
 
-M: quotation free-vars* [ add-if-free ] each ;
+M: quotation free-vars* [ free-vars* ] each ;
 
-M: lambda free-vars*
+M: lambda free-vars* [ vars>> ] [ body>> ] bi free-vars swap diff % ;
-    [ vars>> ] [ body>> ] bi free-vars swap diff % ;
 
 GENERIC: lambda-rewrite* ( obj -- )
 
@@ -201,6 +204,8 @@ M: special rewrite-literal? drop t ;
 
 M: array rewrite-literal? [ rewrite-literal? ] contains? ;
 
+M: quotation rewrite-literal? [ rewrite-literal? ] contains? ;
+
 M: hashtable rewrite-literal? drop t ;
 
 M: vector rewrite-literal? drop t ;
@@ -215,17 +220,20 @@ GENERIC: rewrite-element ( obj -- )
     [ rewrite-element ] each ;
 
 : rewrite-sequence ( seq -- )
-    [ rewrite-elements ] [ length , ] [ , ] tri \ nsequence , ;
+    [ rewrite-elements ] [ length , ] [ 0 head , ] tri \ nsequence , ;
 
 M: array rewrite-element
     dup rewrite-literal? [ rewrite-sequence ] [ , ] if ;
 
+M: quotation rewrite-element
+    dup rewrite-literal? [ rewrite-sequence ] [ , ] if ;
+
 M: vector rewrite-element rewrite-sequence ;
 
 M: hashtable rewrite-element >alist rewrite-sequence \ >hashtable , ;
 
 M: tuple rewrite-element
-    [ tuple-slots rewrite-elements ] [ class , ] bi \ boa , ;
+    [ tuple-slots rewrite-elements ] [ class literalize , ] bi \ boa , ;
 
 M: local rewrite-element , ;
 
@@ -243,6 +251,10 @@ M: tuple local-rewrite* rewrite-element ;
 
 M: hashtable local-rewrite* rewrite-element ;
 
+M: word local-rewrite*
+    dup { >r r> } memq?
+    [ >r/r>-in-lambda-error ] [ call-next-method ] if ;
+
 M: object lambda-rewrite* , ;
 
 M: object local-rewrite* , ;