Fixing some problems with the locals implementation:

- Smart combinators now work with wlet words
- Expansion no longer usees >r/r>
- Hook into fry so that fry and locals can work as expected
- Document limitations of locals with macros in more detail, remove mention of >r/r> limitation since those two words are going away anyway

basis/locals/locals-docs.factor

@@ -1,5 +1,5 @@
 USING: help.syntax help.markup kernel macros prettyprint
-memoize combinators arrays ;
+memoize combinators arrays generalizations ;
 IN: locals
 
 HELP: [|
@@ -131,10 +131,40 @@ $nl
 $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-fry" "Locals and fry"
+"Locals integrate with " { $link "fry" } " so that mixing locals with fried quotations gives intuitive results."
+$nl
+"Recall that the following two code snippets are equivalent:"
+{ $code "'[ sq _ + ]" }
+{ $code "[ [ sq ] dip + ] curry" }
+"The semantics of " { $link dip } " and " { $link curry } " are such that the first example behaves as if the top of the stack as ``inserted'' in the ``hole'' in the quotation's second element."
+$nl
+"Conceptually, " { $link curry } " is defined so that the following two code snippets are equivalent:"
+{ $code "3 [ - ] curry" }
+{ $code "[ 3 - ]" }
+"With lambdas, " { $link curry } " behaves differently. Rather than prepending an element, it fills in named parameters from right to left. The following two snippets are equivalent:"
+{ $code "3 [| a b | a b - ] curry" }
+{ $code "[| a | a 3 - ]" }
+"Because of this, the behavior of fry changes when applied to a lambda, to ensure that conceptually, fry behaves as with quotations. So the following snippets are no longer equivalent:"
+{ $code "'[ [| a | _ a - ] ]" }
+{ $code "'[ [| a | a - ] curry ] call" }
+"Instead, the first line above expands into something like the following:"
+{ $code "[ [ swap [| a | a - ] ] curry call ]" }
+"This ensures that the fried value appears ``underneath'' the local variable " { $snippet "a" } " when the quotation calls."
+$nl
+"The precise behavior is the following. When frying a lambda, a stack shuffle (" { $link mnswap } ") is prepended to the lambda so that the " { $snippet "m" } " curried values, which start off at the top of the stack, are transposed with the " { $snippet "n" } " inputs to the lambda." ;
+
 ARTICLE: "locals-limitations" "Limitations of locals"
-"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:"
+"There are two main limitations of the current locals implementation, and both concern macros."
-{ $subsection >r/r>-in-lambda-error }
+{ $heading "Macro expansions with free variables" }
-"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:"
+"The expansion of a macro cannot reference local variables bound in the outer scope. For example, the following macro is invalid:"
+{ $code "MACRO:: twice ( quot -- ) [ quot call quot call ] ;" }
+"The following is fine, though:"
+{ $code "MACRO:: twice ( quot -- ) quot quot '[ @ @ ] ;" }
+{ $heading "Static stack effect inference and macros" }
+"Recall that a macro will only expand at compile-time, and the word containing it will only get a static stack effect, if all inputs to the macro are literal. When locals are used, there is an additional restriction; the literals must immediately precede the macro call, lexically."
+$nl
+"For example, all of the following three examples are equivalent semantically, but only the first will have a static stack effect and compile with the optimizing compiler:"
 { $code
     ":: good-cond-usage ( a -- ... )"
     "    {"
@@ -143,7 +173,7 @@ ARTICLE: "locals-limitations" "Limitations of locals"
     "        { [ a 0 = ] [ ... ] }"
     "    } cond ;"
 }
-"But not the following:"
+"The following two will not, and will run slower as a result:"
 { $code
     ": my-cond ( alist -- ) cond ; inline"
     ""
@@ -154,6 +184,14 @@ ARTICLE: "locals-limitations" "Limitations of locals"
     "        { [ a 0 = ] [ ... ] }"
     "    } my-cond ;"
 }
+{ $code
+    ":: bad-cond-usage ( a -- ... )"
+    "    {"
+    "        { [ a 0 < ] [ ... ] }"
+    "        { [ a 0 > ] [ ... ] }"
+    "        { [ a 0 = ] [ ... ] }"
+    "    } swap swap cond ;"
+}
 "The reason is that locals are rewritten into stack code at parse time, whereas macro expansion is performed later during compile time. To circumvent this problem, the " { $vocab-link "macros.expander" } " vocabulary is used to rewrite simple macro usages prior to local transformation, however "{ $vocab-link "macros.expander" } " does not deal with more complicated cases where the literal inputs to the macro do not immediately precede the macro call in the source." ;
 
 ARTICLE: "locals" "Local variables and lexical closures"
@@ -174,6 +212,7 @@ $nl
 "Additional topics:"
 { $subsection "locals-literals" }
 { $subsection "locals-mutable" }
+{ $subsection "locals-fry" }
 { $subsection "locals-limitations" }
 "Locals complement dynamically scoped variables implemented in the " { $vocab-link "namespaces" } " vocabulary." ;
 

basis/locals/locals-tests.factor

@@ -398,7 +398,7 @@ M:: integer lambda-method-forget-test ( a -- b ) ;
 
 [ ] [ [ { integer lambda-method-forget-test } forget ] with-compilation-unit ] unit-test
 
-[ { [ 10 ] } ] [ 10 [| A | { [ A ] } ] call ] unit-test
+[ 10 ] [ 10 [| A | { [ A ] } ] call first call ] unit-test
 
 [
     "USING: locals fry math ; [ 0 '[ [let | A [ 10 ] | A _ + ] ] ]" eval
@@ -431,14 +431,53 @@ M:: integer lambda-method-forget-test ( a -- b ) ;
 
 [ 3 ] [ 3 [| a | \ a ] call ] unit-test
 
-! :: wlet-&&-test ( a -- ? )
+[ "USE: locals [| | { [let | a [ 0 ] | a ] } ]" eval ] must-fail
-!     [wlet | is-integer? [ a integer? ]
-!             is-even? [ a even? ]
-!             >10? [ a 10 > ] |
-!         { [ is-integer? ] [ is-even? ] [ >10? ] } &&
-!     ] ;
 
-! [ f ] [ 1.5 wlet-&&-test ] unit-test
+[ "USE: locals [| | { [wlet | a [ 0 ] | a ] } ]" eval ] must-fail
-! [ f ] [ 3 wlet-&&-test ] unit-test
+
-! [ f ] [ 8 wlet-&&-test ] unit-test
+[ "USE: locals [| | { [let* | a [ 0 ] | a ] } ]" eval ] must-fail
-! [ t ] [ 12 wlet-&&-test ] unit-test
+
+[ "USE: locals [| | [let | a! [ 0 ] | { a! } ] ]" eval ] must-fail
+
+[ "USE: locals [| | [wlet | a [ 0 ] | { a } ] ]" eval ] must-fail
+
+:: wlet-&&-test ( a -- ? )
+    [wlet | is-integer? [ a integer? ]
+            is-even? [ a even? ]
+            >10? [ a 10 > ] |
+        { [ is-integer? ] [ is-even? ] [ >10? ] } &&
+    ] ;
+
+\ wlet-&&-test must-infer
+[ f ] [ 1.5 wlet-&&-test ] unit-test
+[ f ] [ 3 wlet-&&-test ] unit-test
+[ f ] [ 8 wlet-&&-test ] unit-test
+[ t ] [ 12 wlet-&&-test ] unit-test
+
+: fry-locals-test-1 ( -- n )
+    [let | | 6 '[ [let | A [ 4 ] | A _ + ] ] call ] ;
+
+\ fry-locals-test-1 must-infer
+[ 10 ] [ fry-locals-test-1 ] unit-test
+
+:: fry-locals-test-2 ( -- n )
+    [let | | 6 '[ [let | A [ 4 ] | A _ + ] ] call ] ;
+
+\ fry-locals-test-2 must-infer
+[ 10 ] [ fry-locals-test-2 ] unit-test
+
+[ 1 ] [ 3 4 [| | '[ [ _ swap - ] call ] call ] call ] unit-test
+[ -1 ] [ 3 4 [| | [| a | a - ] call ] call ] unit-test
+[ -1 ] [ 3 4 [| | [| a | a - ] curry call ] call ] unit-test
+[ -1 ] [ 3 4 [| a | a - ] curry call ] unit-test
+[ 1 ] [ 3 4 [| | '[ [| a | _ a - ] call ] call ] call ] unit-test
+[ -1 ] [ 3 4 [| | '[ [| a | a _ - ] call ] call ] call ] unit-test
+
+[ { 1 2 3 4 } ] [
+    1 3 2 4
+    [| | '[ [| a b | a _ b _ 4array ] call ] call ] call
+] unit-test
+
+[ 10 ] [
+    [| | 0 '[ [let | A [ 10 ] | A _ + ] ] call ] call
+] unit-test

basis/locals/locals.factor

@@ -6,18 +6,36 @@ 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 summary ;
+locals.backend memoize macros.expander lexer classes summary fry
+fry.private ;
 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" ;
 
+ERROR: binding-form-in-literal-error ;
+
+M: binding-form-in-literal-error summary
+    drop "[let, [let* and [wlet not permitted inside literals" ;
+
+ERROR: local-writer-in-literal-error ;
+
+M: local-writer-in-literal-error summary
+    drop "Local writer words not permitted inside literals" ;
+
+ERROR: local-word-in-literal-error ;
+
+M: local-word-in-literal-error summary
+    drop "Local words not permitted inside literals" ;
+
+ERROR: bad-lambda-rewrite output ;
+
+M: bad-lambda-rewrite summary
+    drop "You have found a bug in locals. Please report." ;
+
 <PRIVATE
 
 TUPLE: lambda vars body ;
@@ -87,45 +105,40 @@ C: <quote> quote
 : read-local-quot ( obj args -- quot )
     local-index 1+ [ get-local ] curry ;
 
-: localize-writer ( obj args -- quot )
+GENERIC# localize 1 ( obj args -- quot )
-    >r "local-reader" word-prop r>
+
+M: local localize read-local-quot ;
+
+M: quote localize [ local>> ] dip read-local-quot ;
+
+M: local-word localize read-local-quot [ call ] append ;
+
+M: local-reader localize read-local-quot [ local-value ] append ;
+
+M: local-writer localize
+    [ "local-reader" word-prop ] dip
     read-local-quot [ set-local-value ] append ;
 
-: localize ( obj args -- quot )
+M: object localize drop 1quotation ;
-    {
-        { [ over local? ]        [ read-local-quot ] }
-        { [ over quote? ]        [ >r local>> r> read-local-quot ] }
-        { [ over local-word? ]   [ read-local-quot [ call ] append ] }
-        { [ over local-reader? ] [ read-local-quot [ local-value ] append ] }
-        { [ over local-writer? ] [ localize-writer ] }
-        { [ over \ lambda eq? ]  [ 2drop [ ] ] }
-        { [ t ]                  [ drop 1quotation ] }
-    } cond ;
 
 UNION: special local quote local-word local-reader local-writer ;
 
 : load-locals-quot ( args -- quot )
-    [
+    [ [ ] ] [
-        [ ]
-    ] [
         dup [ local-reader? ] contains? [
-            <reversed> [
+            dup [ local-reader? [ 1array ] [ ] ? ] map spread>quot
-                local-reader? [ 1array >r ] [ >r ] ?
+        ] [ [ ] ] if swap length [ load-locals ] curry append
-            ] map concat
-        ] [
-            length [ load-locals ] curry >quotation
-        ] if
     ] if-empty ;
 
 : drop-locals-quot ( args -- quot )
     [ [ ] ] [ length [ drop-locals ] curry ] if-empty ;
 
 : point-free-body ( quot args -- newquot )
-    >r but-last-slice r> [ localize ] curry map concat ;
+    [ but-last-slice ] dip '[ _ localize ] map concat ;
 
 : point-free-end ( quot args -- newquot )
     over peek special?
-    [ dup drop-locals-quot >r >r peek r> localize r> append ]
+    [ dup drop-locals-quot [ [ peek ] dip localize ] dip append ]
     [ dup drop-locals-quot nip swap peek suffix ]
     if ;
 
@@ -227,9 +240,6 @@ GENERIC: rewrite-element ( obj -- )
 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 , ;
@@ -237,12 +247,22 @@ M: hashtable rewrite-element >alist rewrite-sequence \ >hashtable , ;
 M: tuple rewrite-element
     [ tuple-slots rewrite-elements ] [ class literalize , ] bi \ boa , ;
 
+M: quotation rewrite-element local-rewrite* ;
+
 M: lambda rewrite-element local-rewrite* ;
 
+M: binding-form rewrite-element binding-form-in-literal-error ;
+
 M: local rewrite-element , ;
 
 M: local-reader rewrite-element , ;
 
+M: local-writer rewrite-element
+    local-writer-in-literal-error ;
+
+M: local-word rewrite-element
+    local-word-in-literal-error ;
+
 M: word rewrite-element literalize , ;
 
 M: wrapper rewrite-element
@@ -278,8 +298,9 @@ M: object local-rewrite* , ;
 : make-locals ( seq -- words assoc )
     [ [ make-local ] map ] H{ } make-assoc ;
 
-: make-local-word ( name -- word )
+: make-local-word ( name def -- word )
-    <local-word> dup dup name>> set ;
+    [ <local-word> [ dup name>> set ] [ ] [ ] tri ] dip
+    "local-word-def" set-word-prop ;
 
 : push-locals ( assoc -- )
     use get push ;
@@ -328,7 +349,7 @@ SYMBOL: in-lambda?
 
 : (parse-wbindings) ( -- )
     parse-binding [
-        first2 >r make-local-word r> 2array ,
+        first2 [ make-local-word ] keep 2array ,
         (parse-wbindings)
     ] when* ;
 
@@ -340,7 +361,7 @@ SYMBOL: in-lambda?
 
 : let-rewrite ( body bindings -- )
     <reversed> [
-        >r 1array r> spin <lambda> [ call ] curry compose
+        [ 1array ] dip spin <lambda> '[ @ @ ]
     ] assoc-each local-rewrite* \ call , ;
 
 M: let local-rewrite*
@@ -351,7 +372,7 @@ M: let* local-rewrite*
 
 M: wlet local-rewrite*
     [ body>> ] [ bindings>> ] bi
-    [ [ ] curry ] assoc-map
+    [ '[ _ ] ] assoc-map
     let-rewrite ;
 
 : parse-locals ( -- vars assoc )
@@ -359,11 +380,6 @@ M: wlet local-rewrite*
     word [ over "declared-effect" set-word-prop ] when*
     in>> [ dup pair? [ first ] when ] map make-locals dup push-locals ;
 
-ERROR: bad-lambda-rewrite output ;
-
-M: bad-lambda-rewrite summary
-    drop "You have found a bug in locals. Please report." ;
-
 : parse-locals-definition ( word -- word quot )
     "(" expect parse-locals \ ; (parse-lambda) <lambda>
     2dup "lambda" set-word-prop
@@ -431,7 +447,7 @@ M: lambda pprint*
     \ | pprint-word
     t <inset
     <block
-    [ <block >r pprint-var r> pprint* block> ] assoc-each
+    [ <block [ pprint-var ] dip pprint* block> ] assoc-each
     block>
     \ | pprint-word
     <block pprint-elements block>
@@ -497,3 +513,15 @@ M: lambda-method synopsis*
     method-stack-effect effect>string comment. ;
 
 PRIVATE>
+
+! Locals and fry
+M: binding-form count-inputs body>> count-inputs ;
+
+M: lambda count-inputs body>> count-inputs ;
+
+M: lambda deep-fry
+    clone [ shallow-fry swap ] change-body
+    [ [ vars>> length ] keep '[ _ _ mnswap @ ] , ] [ drop [ncurry] % ] 2bi ;
+
+M: binding-form deep-fry
+    clone [ fry '[ @ call ] ] change-body , ;