Merge branch 'master' of git://factorcode.org/git/factor

basis/cpu/ppc/bootstrap.factor

@@ -406,9 +406,7 @@ big-endian on
 [
     3 ds-reg 0 LWZ
     3 3 1 SRAWI
-    4 4 LI
+    rs-reg 3 3 LWZX
-    4 3 4 SUBF
-    rs-reg 3 4 LWZX
     3 ds-reg 0 STW
 ] f f f \ get-local define-sub-primitive
 

basis/cpu/x86/bootstrap.factor

@@ -382,9 +382,7 @@ big-endian off
 [
     arg0 ds-reg [] MOV                         ! load local number
     fixnum>slot@                               ! turn local number into offset
-    arg1 bootstrap-cell MOV                    ! load base
+    arg0 rs-reg arg0 [+] MOV                   ! load local value
-    arg1 arg0 SUB                              ! turn it into a stack offset
-    arg0 rs-reg arg1 [+] MOV                   ! load local value
     ds-reg [] arg0 MOV                         ! push to stack
 ] f f f \ get-local define-sub-primitive
 

basis/editors/emacs/emacs-docs.factor

@@ -1,13 +1,11 @@
 USING: help help.syntax help.markup ;
+IN: editors.emacs
 
-ARTICLE: { "emacs" "emacs" } "Integration with Emacs"
+ARTICLE: "editors.emacs" "Integration with Emacs"
-
+"Put this in your " { $snippet ".emacs" } " file:"
-"Put this in your .emacs file:"
-
 { $code "(server-start)" }
-
+"If you would like a new window to open when you ask Factor to edit an object, put this in your " { $snippet ".emacs" } " file:"
-"If you would like a new window to open when you ask Factor to edit an object, put this in your .emacs file:"
-
 { $code "(setq server-window 'switch-to-buffer-other-frame)" }
-
 { $see-also "editor" } ;
+
+ABOUT: "editors.emacs"

basis/fry/fry-docs.factor

@@ -75,12 +75,6 @@ ARTICLE: "fry.philosophy" "Fried quotation philosophy"
     "[let | a [ ] b [ ] | [ 3 a + 4 b / ] ]"
 } ;
 
-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."
-$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."
 $nl
@@ -92,7 +86,6 @@ $nl
 "The holes are filled in with the top of stack going in the rightmost hole, the second item on the stack going in the second hole from the right, and so on."
 { $subsection "fry.examples" }
 { $subsection "fry.philosophy" }
-{ $subsection "fry.limitations" }
 "Fry is implemented as a parsing word which reads a quotation and scans for occurrences of " { $link _ } " and " { $link @ } "; these words are not actually executed, and doing so raises an error (this can happen if they're accidentally used outside of a fry)."
 $nl
 "Fried quotations can also be constructed without using a parsing word; this is useful when meta-programming:"

basis/fry/fry.factor

@@ -28,11 +28,6 @@ M: >r/r>-in-fry-error summary
     dup { >r r> load-locals get-local drop-locals } intersect
     empty? [ >r/r>-in-fry-error ] unless ;
 
-: 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? ;
 
 GENERIC: count-inputs ( quot -- n )
@@ -41,15 +36,21 @@ 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' )
+: fry ( quot -- quot' ) shallow-fry [ncurry] swap prefix ;
-    [
+
-        [
+M: callable deep-fry
-            dup callable? [
+    [ count-inputs \ _ <repetition> % ] [ fry % ] bi ;
-                [ count-inputs \ _ <repetition> % ] [ fry % ] bi
+
-            ] [ , ] if
+M: object deep-fry , ;
-        ] each
-    ] [ ] make shallow-fry ;
 
 : '[ \ ] parse-until fry over push-all ; parsing

basis/generalizations/generalizations-docs.factor

@@ -17,6 +17,15 @@ HELP: narray
 { $description "A generalization of " { $link 1array } ", "
 { $link 2array } ", " { $link 3array } " and " { $link 4array } " "
 "that constructs an array from the top " { $snippet "n" } " elements of the stack."
+}
+{ $examples
+    "Some core words expressed in terms of " { $link narray } ":"
+    { $table
+        { { $link 1array } { $snippet "1 narray" } }
+        { { $link 2array } { $snippet "2 narray" } }
+        { { $link 3array } { $snippet "3 narray" } }
+        { { $link 4array } { $snippet "4 narray" } }
+    }
 } ;
 
 { nsequence narray } related-words
@@ -26,6 +35,15 @@ HELP: firstn
 { $description "A generalization of " { $link first } ", "
 { $link first2 } ", " { $link first3 } " and " { $link first4 } " "
 "that pushes the first " { $snippet "n" } " elements of a sequence on the stack."
+}
+{ $examples
+    "Some core words expressed in terms of " { $link firstn } ":"
+    { $table
+        { { $link first } { $snippet "1 firstn" } }
+        { { $link first2 } { $snippet "2 firstn" } }
+        { { $link first3 } { $snippet "3 firstn" } }
+        { { $link first4 } { $snippet "4 firstn" } }
+    }
 } ;
 
 HELP: npick
@@ -37,8 +55,13 @@ HELP: npick
 }
 { $examples
   { $example "USING: prettyprint generalizations ;" "1 2 3 4 4 npick .s" "1\n2\n3\n4\n1" }
-}
+  "Some core words expressed in terms of " { $link npick } ":"
-{ $see-also dup over pick } ;
+    { $table
+        { { $link dup } { $snippet "1 npick" } }
+        { { $link over } { $snippet "2 npick" } }
+        { { $link pick } { $snippet "3 npick" } }
+    }
+} ;
 
 HELP: ndup
 { $values { "n" integer } }
@@ -49,8 +72,13 @@ HELP: ndup
 }
 { $examples
   { $example "USING: prettyprint generalizations ;" "1 2 3 4 4 ndup .s" "1\n2\n3\n4\n1\n2\n3\n4" }
-}
+  "Some core words expressed in terms of " { $link ndup } ":"
-{ $see-also dup 2dup 3dup } ;
+    { $table
+        { { $link dup } { $snippet "1 ndup" } }
+        { { $link 2dup } { $snippet "2 ndup" } }
+        { { $link 3dup } { $snippet "3 ndup" } }
+    }
+} ;
 
 HELP: nnip
 { $values { "n" integer } }
@@ -60,8 +88,12 @@ HELP: nnip
 }
 { $examples
   { $example "USING: prettyprint generalizations ;" "1 2 3 4 3 nnip .s" "4" }
-}
+  "Some core words expressed in terms of " { $link nnip } ":"
-{ $see-also nip 2nip } ;
+    { $table
+        { { $link nip } { $snippet "1 nnip" } }
+        { { $link 2nip } { $snippet "2 nnip" } }
+    }
+} ;
 
 HELP: ndrop
 { $values { "n" integer } }
@@ -71,8 +103,13 @@ HELP: ndrop
 }
 { $examples
   { $example "USING: prettyprint generalizations ;" "1 2 3 4 3 ndrop .s" "1" }
-}
+  "Some core words expressed in terms of " { $link ndrop } ":"
-{ $see-also drop 2drop 3drop } ;
+    { $table
+        { { $link drop } { $snippet "1 ndrop" } }
+        { { $link 2drop } { $snippet "2 ndrop" } }
+        { { $link 3drop } { $snippet "3 ndrop" } }
+    }
+} ;
 
 HELP: nrot
 { $values { "n" integer } }
@@ -81,8 +118,12 @@ HELP: nrot
 }
 { $examples
   { $example "USING: prettyprint generalizations ;" "1 2 3 4 4 nrot .s" "2\n3\n4\n1" }
-}
+  "Some core words expressed in terms of " { $link nrot } ":"
-{ $see-also rot -nrot } ;
+    { $table
+        { { $link swap } { $snippet "1 nrot" } }
+        { { $link rot } { $snippet "2 nrot" } }
+    }
+} ;
 
 HELP: -nrot
 { $values { "n" integer } }
@@ -91,8 +132,12 @@ HELP: -nrot
 }
 { $examples
   { $example "USING: prettyprint generalizations ;" "1 2 3 4 4 -nrot .s" "4\n1\n2\n3" }
-}
+  "Some core words expressed in terms of " { $link -nrot } ":"
-{ $see-also rot nrot } ;
+    { $table
+        { { $link swap } { $snippet "1 -nrot" } }
+        { { $link -rot } { $snippet "2 -nrot" } }
+    }
+} ;
 
 HELP: nrev
 { $values { "n" integer } }
@@ -100,11 +145,11 @@ HELP: nrev
 }
 { $examples
   { $example "USING: prettyprint generalizations ;" "1 2 3 4 4 nrev .s" "4\n3\n2\n1" }
-}
+  "The " { $link spin } " word is equivalent to " { $snippet "3 nrev" } "."
-{ $see-also rot nrot } ;
+} ;
 
 HELP: ndip
-{ $values { "quot" quotation } { "n" number } }
+{ $values { "quot" quotation } { "n" integer } }
 { $description "A generalization of " { $link dip } " that can work " 
 "for any stack depth. The quotation will be called with a stack that "
 "has 'n' items removed first. The 'n' items are then put back on the "
@@ -113,30 +158,93 @@ HELP: ndip
 { $examples
   { $example "USING: generalizations kernel prettyprint ;" "1 2 [ dup ] 1 ndip .s" "1\n1\n2" }
   { $example "USING: generalizations kernel prettyprint ;" "1 2 3 [ drop ] 2 ndip .s" "2\n3" }
-}
+  "Some core words expressed in terms of " { $link ndip } ":"
-{ $see-also dip 2dip } ;
+    { $table
+        { { $link dip } { $snippet "1 ndip" } }
+        { { $link 2dip } { $snippet "2 ndip" } }
+        { { $link 3dip } { $snippet "3 ndip" } }
+    }
+} ;
 
 HELP: nslip
-{ $values { "n" number } }
+{ $values { "n" integer } }
 { $description "A generalization of " { $link slip } " that can work " 
 "for any stack depth. The first " { $snippet "n" } " items after the quotation will be "
 "removed from the stack, the quotation called, and the items restored."
 } 
 { $examples
   { $example "USING: generalizations prettyprint ;" "[ 99 ] 1 2 3 4 5 5 nslip .s" "99\n1\n2\n3\n4\n5" }
-}
+  "Some core words expressed in terms of " { $link nslip } ":"
-{ $see-also slip nkeep } ;
+    { $table
+        { { $link slip } { $snippet "1 nslip" } }
+        { { $link 2slip } { $snippet "2 nslip" } }
+        { { $link 3slip } { $snippet "3 nslip" } }
+    }
+} ;
 
 HELP: nkeep
-{ $values { "quot" quotation } { "n" number } }
+{ $values { "quot" quotation } { "n" integer } }
 { $description "A generalization of " { $link keep } " that can work " 
 "for any stack depth. The first " { $snippet "n" } " items after the quotation will be "
 "saved, the quotation called, and the items restored."
 } 
 { $examples
   { $example "USING: generalizations kernel prettyprint ;" "1 2 3 4 5 [ drop drop drop drop drop 99 ] 5 nkeep .s" "99\n1\n2\n3\n4\n5" }
+  "Some core words expressed in terms of " { $link nkeep } ":"
+    { $table
+        { { $link keep } { $snippet "1 nkeep" } }
+        { { $link 2keep } { $snippet "2 nkeep" } }
+        { { $link 3keep } { $snippet "3 nkeep" } }
+    }
+} ;
+
+HELP: ncurry
+{ $values { "quot" quotation } { "n" integer } }
+{ $description "A generalization of " { $link curry } " that can work for any stack depth."
 } 
-{ $see-also keep nslip } ;
+{ $examples
+  "Some core words expressed in terms of " { $link ncurry } ":"
+    { $table
+        { { $link curry } { $snippet "1 ncurry" } }
+        { { $link 2curry } { $snippet "2 ncurry" } }
+        { { $link 3curry } { $snippet "3 ncurry" } }
+    }
+} ;
+
+HELP: nwith
+{ $values { "quot" quotation } { "n" integer } }
+{ $description "A generalization of " { $link with } " that can work for any stack depth."
+} 
+{ $examples
+  "Some core words expressed in terms of " { $link nwith } ":"
+    { $table
+        { { $link with } { $snippet "1 nwith" } }
+    }
+} ;
+
+HELP: napply
+{ $values { "quot" quotation } { "n" integer } }
+{ $description "A generalization of " { $link bi@ } " and " { $link tri@ } " that can work for any stack depth."
+} 
+{ $examples
+  "Some core words expressed in terms of " { $link napply } ":"
+    { $table
+        { { $link bi@ } { $snippet "1 napply" } }
+        { { $link tri@ } { $snippet "2 napply" } }
+    }
+} ;
+
+HELP: mnswap
+{ $values { "m" integer } { "n" integer } }
+{ $description "Swaps the top " { $snippet "m" } " stack elements with the " { $snippet "n" } " elements directly underneath." }
+{ $examples
+  "Some core words expressed in terms of " { $link mnswap } ":"
+    { $table
+        { { $link swap } { $snippet "1 1 mnswap" } }
+        { { $link rot } { $snippet "2 1 mnswap" } }
+        { { $link -rot } { $snippet "1 2 mnswap" } }
+    }
+} ;
 
 ARTICLE: "generalizations" "Generalized shuffle words and combinators"
 "The " { $vocab-link "generalizations" } " vocabulary defines a number of stack shuffling words and combinators for use in "
@@ -155,12 +263,14 @@ $nl
 { $subsection nnip }
 { $subsection ndrop }
 { $subsection nrev }
+{ $subsection mnswap }
 "Generalized combinators:"
 { $subsection ndip }
 { $subsection nslip }
 { $subsection nkeep }
+{ $subsection napply }
+"Generalized quotation construction:"
 { $subsection ncurry } 
-{ $subsection nwith } 
+{ $subsection nwith } ;
-{ $subsection napply } ;
 
 ABOUT: "generalizations"

basis/generalizations/generalizations-tests.factor

@@ -38,3 +38,7 @@ IN: generalizations.tests
 [ "a" ] [ { "a" } 1 firstn ] unit-test
 
 [ [ 1 2 ] ] [ 1 2 2 [ ] nsequence ] unit-test
+
+[ 4 5 1 2 3 ] [ 1 2 3 4 5 2 3 mnswap ] unit-test
+
+[ 1 2 3 4 5 6 ] [ 1 2 3 4 5 6 2 4 mnswap 4 2 mnswap ] unit-test

basis/generalizations/generalizations.factor

@@ -13,14 +13,14 @@ IN: generalizations
 
 >>
 
-MACRO: nsequence ( n seq -- quot )
+MACRO: nsequence ( n seq -- )
     [
         [ drop <reversed> ] [ '[ _ _ new-sequence ] ] 2bi
         [ '[ @ [ _ swap set-nth-unsafe ] keep ] ] reduce
     ] keep
     '[ @ _ like ] ;
 
-MACRO: narray ( n -- quot )
+MACRO: narray ( n -- )
     '[ _ { } nsequence ] ;
 
 MACRO: firstn ( n -- )
@@ -30,7 +30,7 @@ MACRO: firstn ( n -- )
         bi prefix '[ _ cleave ]
     ] if ;
 
-MACRO: npick ( n -- quot )
+MACRO: npick ( n -- )
     1- [ dup ] [ '[ _ dip swap ] ] repeat ;
 
 MACRO: ndup ( n -- )
@@ -51,7 +51,7 @@ MACRO: nnip ( n -- )
 MACRO: ntuck ( n -- )
     2 + '[ dup _ -nrot ] ;
 
-MACRO: nrev ( n -- quot )
+MACRO: nrev ( n -- )
     1 [a,b] [ ] [ '[ @ _ -nrot ] ] reduce ;
 
 MACRO: ndip ( quot n -- )
@@ -73,3 +73,6 @@ MACRO: napply ( n -- )
     2 [a,b]
     [ [ 1- ] [ ] bi '[ _ ntuck _ nslip ] ]
     map concat >quotation [ call ] append ;
+
+MACRO: mnswap ( m n -- )
+    1+ '[ _ -nrot ] <repetition> spread>quot ;

basis/locals/backend/backend-tests.factor

@@ -1,39 +1,14 @@
 IN: locals.backend.tests
 USING: tools.test locals.backend kernel arrays ;
 
-[ 3 ] [ 3 >r 1 get-local r> drop ] unit-test
+: get-local-test-1 ( -- x ) 3 1 load-locals 0 get-local 1 drop-locals ;
-
-[ 4 ] [ 3 4 >r >r 2 get-local 2 drop-locals ] unit-test
-
-: get-local-test-1 ( -- x ) 3 >r 1 get-local r> drop ;
 
 \ get-local-test-1 must-infer
 
 [ 3 ] [ get-local-test-1 ] unit-test
 
-: get-local-test-2 ( -- x ) 3 4 >r >r 2 get-local 2 drop-locals ;
+: get-local-test-2 ( -- x ) 3 4 2 load-locals -1 get-local 2 drop-locals ;
 
 \ get-local-test-2 must-infer
 
-[ 4 ] [ get-local-test-2 ] unit-test
+[ 3 ] [ get-local-test-2 ] unit-test
-
-: get-local-test-3 ( -- a b ) 3 4 >r >r 2 get-local r> r> 2array ;
-
-\ get-local-test-3 must-infer
-
-[ 4 { 3 4 } ] [ get-local-test-3 ] unit-test
-
-: get-local-test-4 ( -- a b )
-    3 4 >r >r r> r> dup swap >r swap >r r> r> 2array ;
-
-\ get-local-test-4 must-infer
-
-[ 4 { 3 4 } ] [ get-local-test-4 ] unit-test
-
-[ 1 2 ] [ 1 2 2 load-locals r> r> ] unit-test
-
-: load-locals-test-1 ( -- a b ) 1 2 2 load-locals r> r> ;
-
-\ load-locals-test-1 must-infer
-
-[ 1 2 ] [ load-locals-test-1 ] unit-test

basis/locals/backend/backend.factor

@@ -1,11 +1,8 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: math.private kernel slots.private sequences effects words ;
+USING: slots.private ;
 IN: locals.backend
 
-: load-locals ( n -- )
-    dup 0 eq? [ drop ] [ swap >r 1 fixnum-fast load-locals ] if ;
-
 : local-value 2 slot ; inline
 
 : set-local-value 2 set-slot ; inline

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 ;
@@ -85,60 +103,53 @@ C: <quote> quote
     [ dup quote? [ local>> ] when eq? ] with find drop ;
 
 : read-local-quot ( obj args -- quot )
-    local-index 1+ [ get-local ] curry ;
+    local-index neg [ 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 ]
+    [ drop-locals-quot swap peek suffix ]
     if ;
 
 : (point-free) ( quot args -- newquot )
     [ nip load-locals-quot ]
-    [ point-free-body ]
+    [ reverse point-free-body ]
-    [ point-free-end ]
+    [ reverse point-free-end ]
-    2tri 3append >quotation ;
+    2tri [ ] 3append-as ;
 
 : point-free ( quot args -- newquot )
-    over empty?
+    over empty? [ nip length '[ _ ndrop ] ] [ (point-free) ] if ;
-    [ nip length \ drop <repetition> >quotation ]
-    [ (point-free) ] if ;
 
 UNION: lexical local local-reader local-writer local-word ;
 
@@ -227,9 +238,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 +245,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 +296,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 +347,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 +359,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 +370,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 +378,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 +445,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 +511,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 , ;

basis/stack-checker/known-words/known-words.factor

@@ -134,11 +134,11 @@ M: object infer-call*
 
 : infer-load-locals ( -- )
     pop-literal nip
-    consume-d dup reverse copy-values dup output-r
+    consume-d dup copy-values dup output-r
-    [ [ f f ] dip ] [ reverse swap zip ] 2bi #shuffle, ;
+    [ [ f f ] dip ] [ swap zip ] 2bi #shuffle, ;
 
 : infer-get-local ( -- )
-    [let* | n [ pop-literal nip ]
+    [let* | n [ pop-literal nip 1 swap - ]
             in-r [ n consume-r ]
             out-d [ in-r first copy-value 1array ]
             out-r [ in-r copy-values ] |
@@ -186,6 +186,9 @@ M: object infer-call*
 : infer-local-writer ( word -- )
     (( value -- )) apply-word/effect ;
 
+: infer-local-word ( word -- )
+    "local-word-def" word-prop infer-quot-here ;
+
 {
     >r r> declare call (call) slip 2slip 3slip curry compose
     execute (execute) if dispatch <tuple-boa> (throw)
@@ -209,6 +212,7 @@ M: object infer-call*
         { [ dup local? ] [ infer-local-reader ] }
         { [ dup local-reader? ] [ infer-local-reader ] }
         { [ dup local-writer? ] [ infer-local-writer ] }
+        { [ dup local-word? ] [ infer-local-word ] }
         { [ dup recursive-word? ] [ call-recursive-word ] }
         [ dup infer-word apply-word/effect ]
     } cond ;

basis/stack-checker/transforms/transforms.factor

@@ -94,7 +94,10 @@ IN: stack-checker.transforms
         [ "method-class" word-prop ]
         [ "method-generic" word-prop ] bi
         [ inlined-dependency depends-on ] bi@
-    ] [ next-method-quot ] bi
+    ] [
+        [ next-method-quot ]
+        [ '[ _ no-next-method ] ] bi or
+    ] bi
 ] 1 define-transform
 
 ! Constructors

basis/tools/deploy/shaker/shaker.factor

@@ -343,6 +343,9 @@ IN: tools.deploy.shaker
 : compress-strings ( -- )
     [ string? ] [ ] "strings" compress ;
 
+: compress-wrappers ( -- )
+    [ wrapper? ] [ ] "wrappers" compress ;
+
 : finish-deploy ( final-image -- )
     "Finishing up" show
     >r { } set-datastack r>
@@ -391,7 +394,8 @@ SYMBOL: deploy-vocab
     r> strip-words
     compress-byte-arrays
     compress-quotations
-    compress-strings ;
+    compress-strings
+    compress-wrappers ;
 
 : (deploy) ( final-image vocab config -- )
     #! Does the actual work of a deployment in the slave

basis/ui/clipboards/clipboards.factor

@@ -33,7 +33,7 @@ SYMBOL: selection
 
 : gadget-copy ( gadget clipboard -- )
     over gadget-selection?
-        [ >r [ gadget-selection ] keep r> copy-clipboard ]
+        [ [ [ gadget-selection ] keep ] dip copy-clipboard ]
         [ 2drop ]
     if ;
 

basis/ui/cocoa/cocoa.factor

@@ -5,7 +5,7 @@ command-line kernel memory namespaces cocoa.messages
 cocoa.runtime cocoa.subclassing cocoa.pasteboard cocoa.types
 cocoa.windows cocoa.classes cocoa.application sequences system
 ui ui.backend ui.clipboards ui.gadgets ui.gadgets.worlds
-ui.cocoa.views core-foundation threads math.geometry.rect ;
+ui.cocoa.views core-foundation threads math.geometry.rect fry ;
 IN: ui.cocoa
 
 TUPLE: handle view window ;
@@ -15,7 +15,7 @@ C: <handle> handle
 SINGLETON: cocoa-ui-backend
 
 M: cocoa-ui-backend do-events ( -- )
-    [ NSApp [ do-event ] curry loop ui-wait ] with-autorelease-pool ;
+    [ NSApp '[ _ do-event ] loop ui-wait ] with-autorelease-pool ;
 
 TUPLE: pasteboard handle ;
 

basis/ui/cocoa/tools/tools.factor

@@ -25,7 +25,7 @@ CLASS: {
 }
 
 { "application:openFiles:" "void" { "id" "SEL" "id" "id" }
-    [ >r 3drop r> finder-run-files ]
+    [ [ 3drop ] dip finder-run-files ]
 }
 
 { "newFactorWorkspace:" "id" { "id" "SEL" "id" }

basis/ui/cocoa/views/views.factor

@@ -8,7 +8,7 @@ core-foundation threads combinators math.geometry.rect ;
 IN: ui.cocoa.views
 
 : send-mouse-moved ( view event -- )
-    over >r mouse-location r> window move-hand fire-motion ;
+    [ mouse-location ] [ drop window ] 2bi move-hand fire-motion ;
 
 : button ( event -- n )
     #! Cocoa -> Factor UI button mapping
@@ -85,18 +85,19 @@ IN: ui.cocoa.views
     mouse-location rot window send-button-up ;
 
 : send-wheel$ ( view event -- )
-    over >r
+    [
         dup -> deltaX sgn neg over -> deltaY sgn neg 2array -rot
         mouse-location
-    r> window send-wheel ;
+    ] [ drop window ] 2bi send-wheel ;
 
 : send-action$ ( view event gesture -- junk )
-    >r drop window r> send-action f ;
+    [ drop window ] dip send-action f ;
 
 : add-resize-observer ( observer object -- )
-    >r "updateFactorGadgetSize:"
+    [
+        "updateFactorGadgetSize:"
         "NSViewFrameDidChangeNotification" <NSString>
-    r> add-observer ;
+    ] dip add-observer ;
 
 : string-or-nil? ( NSString -- ? )
     [ CF>string NSStringPboardType = ] [ t ] if* ;
@@ -109,7 +110,7 @@ IN: ui.cocoa.views
     ] if ;
 
 : NSRect>rect ( NSRect world -- rect )
-    >r dup NSRect-x over NSRect-y r>
+    [ dup NSRect-x over NSRect-y ] dip
     rect-dim second swap - 2array
     over NSRect-w rot NSRect-h 2array
     <rect> ;
@@ -256,7 +257,7 @@ CLASS: {
 { "validRequestorForSendType:returnType:" "id" { "id" "SEL" "id" "id" }
     [
         ! We return either self or nil
-        >r >r over window-focus r> r>
+        [ over window-focus ] 2dip
         valid-service? [ drop ] [ 2drop f ] if
     ]
 }
@@ -278,7 +279,7 @@ CLASS: {
 { "readSelectionFromPasteboard:" "char" { "id" "SEL" "id" }
     [
         pasteboard-string dup [
-            >r drop window-focus r> swap user-input 1
+            [ drop window-focus ] dip swap user-input 1
         ] [
             3drop 0
         ] if

basis/ui/commands/commands.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays definitions kernel sequences strings
 math assocs words generic namespaces make assocs quotations
-splitting ui.gestures unicode.case unicode.categories tr ;
+splitting ui.gestures unicode.case unicode.categories tr fry ;
 IN: ui.commands
 
 SYMBOL: +nullary+
@@ -37,7 +37,7 @@ GENERIC: command-word ( command -- word )
         [
             commands>>
             [ drop ] assoc-filter
-            [ [ invoke-command ] curry swap set ] assoc-each
+            [ '[ _ invoke-command ] swap set ] assoc-each
         ] each
     ] H{ } make-assoc ;
 

basis/ui/freetype/freetype.factor

@@ -111,7 +111,7 @@ M: freetype-renderer open-font ( font -- open-font )
     freetype drop open-fonts get [ <font> ] cache ;
 
 : load-glyph ( font char -- glyph )
-    >r handle>> dup r> 0 FT_Load_Char
+    [ handle>> dup ] dip 0 FT_Load_Char
     freetype-error face-glyph ;
 
 : char-width ( open-font char -- w )
@@ -174,7 +174,7 @@ M: freetype-renderer string-height ( open-font string -- h )
     bi 2array ;
 
 : <char-sprite> ( open-font char -- sprite )
-    over >r render-glyph dup r> glyph-texture-loc
+    over [ render-glyph dup ] dip glyph-texture-loc
     over glyph-size pick glyph-texture-size <sprite>
     [ bitmap>texture ] keep [ init-sprite ] keep ;
 
@@ -206,7 +206,7 @@ M: freetype-renderer string-height ( open-font string -- h )
     fonts>> [ open-font H{ } clone 2array ] cache first2 ;
 
 M: freetype-renderer draw-string ( font string loc -- )
-    >r >r world get font-sprites r> r> (draw-string) ;
+    [ world get font-sprites ] 2dip (draw-string) ;
 
 : run-char-widths ( open-font string -- widths )
     char-widths [ scan-sums ] [ 2 v/n ] bi v+ ;

basis/ui/gadgets/books/books.factor

@@ -1,6 +1,7 @@
 ! Copyright (C) 2006, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel sequences models ui.gadgets math.geometry.rect ;
+USING: accessors kernel sequences models ui.gadgets
+math.geometry.rect fry ;
 IN: ui.gadgets.books
 
 TUPLE: book < gadget ;
@@ -25,6 +26,6 @@ M: book model-changed ( model book -- )
 M: book pref-dim* ( book -- dim ) children>> pref-dims max-dim ;
 
 M: book layout* ( book -- )
-    [ children>> ] [ dim>> ] bi [ >>dim drop ] curry each ;
+    [ children>> ] [ dim>> ] bi '[ _ >>dim drop ] each ;
 
 M: book focusable-child* ( book -- child/t ) current-page ;

basis/ui/gadgets/gadgets-tests.factor

@@ -152,6 +152,13 @@ M: mock-gadget ungraft*
     { { f f } { f t } { t f } { t t } } [ notify-combo ] assoc-each
 ] with-string-writer print
 
+[ { { 10 30 } } ] [
+    <gadget> { 0 1 } >>orientation
+    { { 10 20 } }
+    { { 100 30 } }
+    orient
+] unit-test
+
 \ <gadget> must-infer
 \ unparent must-infer
 \ add-gadget must-infer

basis/ui/gadgets/gadgets.factor

@@ -3,7 +3,7 @@
 USING: accessors arrays hashtables kernel models math namespaces
 make sequences quotations math.vectors combinators sorting
 binary-search vectors dlists deques models threads
-concurrency.flags math.order math.geometry.rect ;
+concurrency.flags math.order math.geometry.rect fry ;
 IN: ui.gadgets
 
 SYMBOL: ui-notify-flag
@@ -56,9 +56,7 @@ M: gadget model-changed 2drop ;
     2dup eq? [
         2drop { 0 0 }
     ] [
-        over rect-loc >r
+        over rect-loc [ [ parent>> ] dip relative-loc ] dip v+
-        >r parent>> r> relative-loc
-        r> v+
     ] if ;
 
 GENERIC: user-input* ( str gadget -- ? )
@@ -73,7 +71,7 @@ M: gadget children-on nip children>> ;
     [ swap loc>> v- ] dip v. 0 <=> ;
 
 : (fast-children-on) ( dim axis children -- i )
-    -rot [ ((fast-children-on)) ] 2curry search drop ;
+    -rot '[ _ _ ((fast-children-on)) ] search drop ;
 
 : fast-children-on ( rect axis children -- from to )
     [ [ rect-loc ] 2dip (fast-children-on) 0 or ]
@@ -95,10 +93,10 @@ M: gadget children-on nip children>> ;
 : dim-sum ( seq -- dim ) { 0 0 } [ v+ ] reduce ;
 
 : orient ( gadget seq1 seq2 -- seq )
-    >r >r orientation>> r> r> [ pick set-axis ] 2map nip ;
+    rot orientation>> '[ _ set-axis ] 2map ;
 
 : each-child ( gadget quot -- )
-    >r children>> r> each ; inline
+    [ children>> ] dip each ; inline
 
 ! Selection protocol
 GENERIC: gadget-selection? ( gadget -- ? )
@@ -310,18 +308,18 @@ SYMBOL: in-layout?
     [ parent>> ] follow ;
 
 : each-parent ( gadget quot -- ? )
-    >r parents r> all? ; inline
+    [ parents ] dip all? ; inline
 
 : find-parent ( gadget quot -- parent )
-    >r parents r> find nip ; inline
+    [ parents ] dip find nip ; inline
 
 : screen-loc ( gadget -- loc )
     parents { 0 0 } [ rect-loc v+ ] reduce ;
 
 : (screen-rect) ( gadget -- loc ext )
     dup parent>> [
-        >r rect-extent r> (screen-rect)
+        [ rect-extent ] dip (screen-rect)
-        >r tuck v+ r> vmin >r v+ r>
+        [ tuck v+ ] dip vmin [ v+ ] dip
     ] [
         rect-extent
     ] if* ;

basis/ui/gadgets/grid-lines/grid-lines.factor

@@ -1,7 +1,8 @@
-! Copyright (C) 2006, 2007 Slava Pestov.
+! Copyright (C) 2006, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors math namespaces opengl opengl.gl sequences
+USING: kernel accessors math namespaces opengl opengl.gl
-math.vectors ui.gadgets ui.gadgets.grids ui.render math.geometry.rect ;
+sequences math.vectors ui.gadgets ui.gadgets.grids ui.render
+math.geometry.rect fry ;
 IN: ui.gadgets.grid-lines
 
 TUPLE: grid-lines color ;
@@ -19,8 +20,8 @@ SYMBOL: grid-dim
 
 : draw-grid-lines ( gaps orientation -- )
     [ grid get swap grid-positions grid get rect-dim suffix ] dip
-    [ [ v- ] curry map ] keep
+    [ '[ _ v- ] map ] keep
-    [ swap grid-line-from/to gl-line ] curry each ;
+    '[ _ swap grid-line-from/to gl-line ] each ;
 
 M: grid-lines draw-boundary
     color>> gl-color [

basis/ui/gadgets/grids/grids.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays kernel math namespaces make sequences words io
 io.streams.string math.vectors ui.gadgets columns accessors
-math.geometry.rect locals ;
+math.geometry.rect locals fry ;
 IN: ui.gadgets.grids
 
 TUPLE: grid < gadget
@@ -48,21 +48,18 @@ grid
     dupd add-gaps dim-sum v+ ;
 
 M: grid pref-dim*
-    dup gap>> swap compute-grid >r over r>
+    dup gap>> swap compute-grid [ over ] dip
-    gap-sum >r gap-sum r> (pair-up) ;
+    [ gap-sum ] 2bi@ (pair-up) ;
 
 : do-grid ( dims grid quot -- )
-    -rot grid>>
+    [ grid>> ] dip '[ _ 2each ] 2each ; inline
-    [ [ pick call ] 2each ] 2each
-    drop ; inline
 
 : grid-positions ( grid dims -- locs )
-    >r gap>> dup r> add-gaps swap [ v+ ] accumulate nip ;
+    [ gap>> dup ] dip add-gaps swap [ v+ ] accumulate nip ;
 
 : position-grid ( grid horiz vert -- )
-    pick >r
+    pick [ [ over ] dip [ grid-positions ] 2bi@ pair-up ] dip
-    >r over r> grid-positions >r grid-positions r>
+    [ (>>loc) ] do-grid ;
-    pair-up r> [ (>>loc) ] do-grid ;
 
 : resize-grid ( grid horiz vert -- )
     pick fill?>> [

basis/ui/gadgets/labelled/labelled.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2006, 2007 Slava Pestov.
+! Copyright (C) 2006, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays ui.gadgets.buttons ui.gadgets.borders
 ui.gadgets.labels ui.gadgets.panes ui.gadgets.scrollers
@@ -19,10 +19,10 @@ TUPLE: labelled-gadget < track content ;
 M: labelled-gadget focusable-child* content>> ;
 
 : <labelled-scroller> ( gadget title -- gadget )
-    >r <scroller> r> <labelled-gadget> ;
+    [ <scroller> ] dip <labelled-gadget> ;
 
 : <labelled-pane> ( model quot scrolls? title -- gadget )
-    >r >r <pane-control> r> >>scrolls? r>
+    [ [ <pane-control> ] dip >>scrolls? ] dip
     <labelled-scroller> ;
 
 : <close-box> ( quot -- button/f )

basis/ui/gadgets/labels/labels.factor

@@ -13,7 +13,7 @@ TUPLE: label < gadget text font color ;
 
 : set-label-string ( string label -- )
     CHAR: \n pick memq? [
-        >r string-lines r> (>>text)
+        [ string-lines ] dip (>>text)
     ] [
         (>>text)
     ] if ; inline

basis/ui/gadgets/lists/lists.factor

@@ -33,7 +33,7 @@ TUPLE: list < pack index presenter color hook ;
     hook>> [ [ list? ] find-parent ] prepend ;
 
 : <list-presentation> ( hook elt presenter -- gadget )
-    keep >r >label text-theme r>
+    keep [ >label text-theme ] dip
     <presentation>
     swap >>hook ; inline
 
@@ -42,7 +42,7 @@ TUPLE: list < pack index presenter color hook ;
     [ presenter>> ]
     [ control-value ]
     tri [
-        >r 2dup r> swap <list-presentation>
+        [ 2dup ] dip swap <list-presentation>
     ] map 2nip ;
 
 M: list model-changed
@@ -113,8 +113,8 @@ M: list focusable-child* drop t ;
     select-gadget ;
 
 : list-page ( list vec -- )
-    >r dup selected-rect rect-bounds 2 v/n v+
+    [ dup selected-rect rect-bounds 2 v/n v+ over visible-dim ] dip
-    over visible-dim r> v* v+ swap select-at ;
+    v* v+ swap select-at ;
 
 : list-page-up ( list -- ) { 0 -1 } list-page ;
 

basis/ui/gadgets/menus/menus.factor

@@ -8,13 +8,13 @@ math.geometry.rect ;
 IN: ui.gadgets.menus
 
 : menu-loc ( world menu -- loc )
-    >r rect-dim r> pref-dim [v-] hand-loc get-global vmin ;
+    [ rect-dim ] [ pref-dim ] bi* [v-] hand-loc get-global vmin ;
 
 TUPLE: menu-glass < gadget ;
 
 : <menu-glass> ( menu world -- glass )
     menu-glass new-gadget
-    >r over menu-loc >>loc r>
+    [ over menu-loc >>loc ] dip
     swap add-gadget ;
 
 M: menu-glass layout* gadget-child prefer ;

basis/ui/gadgets/packs/packs.factor

@@ -19,10 +19,10 @@ TUPLE: pack < gadget
     { 0 0 } [ v+ over v+ ] accumulate 2nip ;
 
 : aligned-locs ( gadget sizes -- seq )
-    [ >r dup align>> swap rect-dim r> v- n*v ] with map ;
+    [ [ dup align>> swap rect-dim ] dip v- n*v ] with map ;
 
 : packed-locs ( gadget sizes -- seq )
-    over gap>> over gap-locs >r dupd aligned-locs r> orient ;
+    over gap>> over gap-locs [ dupd aligned-locs ] dip orient ;
 
 : round-dims ( seq -- newseq )
     { 0 0 } swap
@@ -31,8 +31,9 @@ TUPLE: pack < gadget
 
 : pack-layout ( pack sizes -- )
     round-dims over children>>
-    >r dupd packed-dims r> 2dup [ (>>dim) ] 2each
+    [ dupd packed-dims ] dip
-    >r packed-locs r> [ (>>loc) ] 2each ;
+    [ [ (>>dim) ] 2each ]
+    [ [ packed-locs ] dip [ (>>loc) ] 2each ] 2bi ;
 
 : <pack> ( orientation -- pack )
     pack new-gadget
@@ -48,7 +49,7 @@ TUPLE: pack < gadget
     [ dim-sum ] keep length 1 [-] rot n*v v+ ;
 
 : pack-pref-dim ( gadget sizes -- dim )
-    over gap>> over gap-dims >r max-dim r>
+    over gap>> over gap-dims [ max-dim ] dip
     rot orientation>> set-axis ;
 
 M: pack pref-dim*

basis/ui/gadgets/panes/panes.factor

@@ -9,7 +9,7 @@ opengl combinators math.vectors sorting splitting
 io.streams.nested assocs ui.gadgets.presentations
 ui.gadgets.slots ui.gadgets.grids ui.gadgets.grid-lines
 classes.tuple models continuations destructors accessors
-math.geometry.rect ;
+math.geometry.rect fry ;
 IN: ui.gadgets.panes
 
 TUPLE: pane < pack
@@ -59,7 +59,7 @@ M: pane gadget-selection ( pane -- string/f )
 GENERIC: draw-selection ( loc obj -- )
 
 : if-fits ( rect quot -- )
-    >r clip get over intersects? r> [ drop ] if ; inline
+    [ clip get over intersects? ] dip [ drop ] if ; inline
 
 M: gadget draw-selection ( loc gadget -- )
     swap offset-rect [
@@ -135,8 +135,8 @@ M: style-stream write-gadget
 
 : with-pane ( pane quot -- )
     over scroll>top
-    over pane-clear >r <pane-stream> r>
+    over pane-clear [ <pane-stream> ] dip
-    over >r with-output-stream* r> ?nl ; inline
+    over [ with-output-stream* ] dip ?nl ; inline
 
 : make-pane ( quot -- gadget )
     <pane> [ swap with-pane ] keep smash-pane ; inline
@@ -154,7 +154,7 @@ M: pane-control model-changed ( model pane-control -- )
         swap >>model ;
 
 : do-pane-stream ( pane-stream quot -- )
-    >r pane>> r> keep scroll-pane ; inline
+    [ pane>> ] dip keep scroll-pane ; inline
 
 M: pane-stream stream-nl
     [ pane-nl drop ] do-pane-stream ;
@@ -178,7 +178,7 @@ M: pane-stream make-span-stream
 ! Character styles
 
 : apply-style ( style gadget key quot -- style gadget )
-    >r pick at r> when* ; inline
+    [ pick at ] dip when* ; inline
 
 : apply-foreground-style ( style gadget -- style gadget )
     foreground [ >>color ] apply-style ;
@@ -228,7 +228,7 @@ M: pane-stream make-span-stream
     border-width [ <border> ] apply-style ;
 
 : apply-printer-style ( style gadget -- style gadget )
-    presented-printer [ [ make-pane ] curry >>printer ] apply-style ;
+    presented-printer [ '[ _ make-pane ] >>printer ] apply-style ;
 
 : style-pane ( style pane -- pane )
     apply-border-width-style
@@ -284,10 +284,10 @@ M: pane-stream make-cell-stream
     pane-cell-stream new-nested-pane-stream ;
 
 M: pane-stream stream-write-table
-    >r
+    [
         swap [ [ pane>> smash-pane ] map ] map
         styled-grid
-    r> print-gadget ;
+    ] dip print-gadget ;
 
 ! Stream utilities
 M: pack dispose drop ;
@@ -309,7 +309,7 @@ M: paragraph stream-write
     drop ;
 
 : gadget-write1 ( char gadget -- )
-    >r 1string r> stream-write ;
+    [ 1string ] dip stream-write ;
 
 M: pack stream-write1 gadget-write1 ;
 

basis/ui/gadgets/presentations/presentations.factor

@@ -12,7 +12,7 @@ TUPLE: presentation < button object hook ;
 
 : invoke-presentation ( presentation command -- )
     over dup hook>> call
-    >r object>> r> invoke-command ;
+    [ object>> ] dip invoke-command ;
 
 : invoke-primary ( presentation -- )
     dup object>> primary-operation

basis/ui/gadgets/sliders/sliders.factor

@@ -4,7 +4,7 @@ USING: accessors arrays ui.gestures ui.gadgets ui.gadgets.buttons
 ui.gadgets.frames ui.gadgets.grids math.order
 ui.gadgets.theme ui.render kernel math namespaces sequences
 vectors models models.range math.vectors math.functions
-quotations colors math.geometry.rect ;
+quotations colors math.geometry.rect fry ;
 IN: ui.gadgets.sliders
 
 TUPLE: elevator < gadget direction ;
@@ -104,13 +104,14 @@ elevator H{
 
 : layout-thumb-loc ( slider -- )
     dup thumb-loc (layout-thumb)
-    >r [ floor ] map r> (>>loc) ;
+    [ [ floor ] map ] dip (>>loc) ;
 
 : layout-thumb-dim ( slider -- )
-    dup dup thumb-dim (layout-thumb) >r
+    dup dup thumb-dim (layout-thumb)
-    >r dup rect-dim r>
+    [
+        [ dup rect-dim ] dip
         rot orientation>> set-axis [ ceiling ] map
-    r> (>>dim) ;
+    ] dip (>>dim) ;
 
 : layout-thumb ( slider -- )
     dup layout-thumb-loc layout-thumb-dim ;
@@ -121,8 +122,8 @@ M: elevator layout*
 : slide-by-line ( amount slider -- ) [ line>> * ] keep slide-by ;
 
 : <slide-button> ( vector polygon amount -- button )
-    >r gray swap <polygon-gadget> r>
+    [ gray swap <polygon-gadget> ] dip
-    [ swap find-slider slide-by-line ] curry <repeat-button>
+    '[ _ swap find-slider slide-by-line ] <repeat-button>
     swap >>orientation ;
 
 : elevator, ( gadget orientation -- gadget )

basis/ui/gadgets/status-bar/status-bar.factor

@@ -16,4 +16,4 @@ IN: ui.gadgets.status-bar
     open-world-window ;
 
 : show-summary ( object gadget -- )
-    >r [ summary ] [ "" ] if* r> show-status ;
+    [ [ summary ] [ "" ] if* ] dip show-status ;

basis/ui/gadgets/worlds/worlds.factor

@@ -52,7 +52,7 @@ M: world request-focus-on ( child gadget -- )
 M: world layout*
     dup call-next-method
     dup glass>> [
-        >r dup rect-dim r> (>>dim)
+        [ dup rect-dim ] dip (>>dim)
     ] when* drop ;
 
 M: world focusable-child* gadget-child ;

basis/ui/operations/operations.factor

@@ -38,7 +38,7 @@ SYMBOL: operations
     operations get [ predicate>> call ] with filter ;
 
 : find-operation ( obj quot -- command )
-    >r object-operations r> find-last nip ; inline
+    [ object-operations ] dip find-last nip ; inline
 
 : primary-operation ( obj -- operation )
     [ command>> +primary+ word-prop ] find-operation ;

basis/ui/render/render.factor

@@ -12,7 +12,7 @@ SYMBOL: viewport-translation
 
 : flip-rect ( rect -- loc dim )
     rect-bounds [
-        >r { 1 -1 } v* r> { 0 -1 } v* v+
+        [ { 1 -1 } v* ] dip { 0 -1 } v* v+
         viewport-translation get v+
     ] keep ;
 
@@ -79,9 +79,7 @@ DEFER: draw-gadget
     >absolute clip [ rect-intersect ] change ;
 
 : with-clipping ( gadget quot -- )
-    clip get >r
+    clip get [ over change-clip do-clip call ] dip clip set do-clip ; inline
-    over change-clip do-clip call
-    r> clip set do-clip ; inline
 
 : draw-gadget ( gadget -- )
     {
@@ -200,7 +198,7 @@ M: polygon draw-interior
 
 : <polygon-gadget> ( color points -- gadget )
     dup max-dim
-    >r <polygon> <gadget> r> >>dim
+    [ <polygon> <gadget> ] dip >>dim
     swap >>interior ;
 
 ! Font rendering
@@ -242,7 +240,7 @@ HOOK: free-fonts font-renderer ( world -- )
         [
             [
                 2dup { 0 0 } draw-string
-                >r open-font r> string-height
+                [ open-font ] dip string-height
                 0.0 swap 0.0 glTranslated
             ] with each
         ] with-translation

basis/ui/tools/deploy/deploy.factor

@@ -1,12 +1,11 @@
 ! Copyright (C) 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: ui.gadgets colors kernel ui.render namespaces
+USING: ui.gadgets colors kernel ui.render namespaces models
-       models models.mapping sequences ui.gadgets.buttons
+models.mapping sequences ui.gadgets.buttons ui.gadgets.packs
-       ui.gadgets.packs ui.gadgets.labels tools.deploy.config
+ui.gadgets.labels tools.deploy.config namespaces
-       namespaces ui.gadgets.editors ui.gadgets.borders ui.gestures
+ui.gadgets.editors ui.gadgets.borders ui.gestures ui.commands
-       ui.commands assocs ui.gadgets.tracks ui ui.tools.listener
+assocs ui.gadgets.tracks ui ui.tools.listener tools.deploy
-       tools.deploy vocabs ui.tools.workspace system accessors ;
+vocabs ui.tools.workspace system accessors fry ;
-
 IN: ui.tools.deploy
 
 TUPLE: deploy-gadget < pack vocab settings ;
@@ -83,7 +82,7 @@ TUPLE: deploy-gadget < pack vocab settings ;
 
 : com-deploy ( gadget -- )
     dup com-save
-    dup find-deploy-vocab [ deploy ] curry call-listener
+    dup find-deploy-vocab '[ _ deploy ] call-listener
     close-window ;
 
 : com-help ( -- )

basis/ui/tools/interactor/interactor.factor

@@ -7,7 +7,7 @@ quotations sequences strings threads listener classes.tuple
 ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.status-bar
 ui.gadgets.presentations ui.gadgets.worlds ui.gestures
 definitions calendar concurrency.flags concurrency.mailboxes
-ui.tools.workspace accessors sets destructors ;
+ui.tools.workspace accessors sets destructors fry ;
 IN: ui.tools.interactor
 
 ! If waiting is t, we're waiting for user input, and invoking
@@ -88,7 +88,7 @@ M: interactor model-changed
     [ editor-string ] keep
     [ interactor-input. ] 2keep
     [ add-interactor-history ] keep
-    [ clear-input ] curry "Clearing input" spawn drop ;
+    '[ _ clear-input ] "Clearing input" spawn drop ;
 
 : interactor-eof ( interactor -- )
     dup interactor-busy? [
@@ -126,7 +126,7 @@ M: interactor stream-read
     swap dup zero? [
         2drop ""
     ] [
-        >r interactor-read dup [ "\n" join ] when r> short head
+        [ interactor-read dup [ "\n" join ] when ] dip short head
     ] if ;
 
 M: interactor stream-read-partial

basis/ui/tools/listener/listener.factor

@@ -28,7 +28,7 @@ M: listener-gadget focusable-child*
     input>> ;
 
 M: listener-gadget call-tool* ( input listener -- )
-    >r string>> r> input>> set-editor-string ;
+    [ string>> ] dip input>> set-editor-string ;
 
 M: listener-gadget tool-scroller
     output>> find-scroller ;
@@ -95,13 +95,13 @@ M: engine-word word-completion-string
 : use-if-necessary ( word seq -- )
     over vocabulary>> over and [
         2dup [ assoc-stack ] keep = [ 2drop ] [
-            >r vocabulary>> vocab-words r> push
+            [ vocabulary>> vocab-words ] dip push
         ] if
     ] [ 2drop ] if ;
 
 : insert-word ( word -- )
     get-workspace listener>> input>>
-    [ >r word-completion-string r> user-input* drop ]
+    [ [ word-completion-string ] dip user-input* drop ]
     [ interactor-use use-if-necessary ]
     2bi ;
 

basis/ui/tools/profiler/profiler.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: ui.tools.workspace kernel quotations tools.profiler
 ui.commands ui.gadgets ui.gadgets.panes ui.gadgets.scrollers
-ui.gadgets.tracks ui.gestures ui.gadgets.buttons accessors ;
+ui.gadgets.tracks ui.gestures ui.gadgets.buttons accessors fry ;
 IN: ui.tools.profiler
 
 TUPLE: profiler-gadget < track pane ;
@@ -14,7 +14,7 @@ TUPLE: profiler-gadget < track pane ;
         dup pane>> <scroller> 1 track-add ;
 
 : with-profiler-pane ( gadget quot -- )
-    >r pane>> r> with-pane ;
+    [ pane>> ] dip with-pane ;
 
 : com-full-profile ( gadget -- )
     [ profile. ] with-profiler-pane ;
@@ -39,10 +39,10 @@ profiler-gadget "toolbar" f {
 GENERIC: profiler-presentation ( obj -- quot )
 
 M: usage-profile profiler-presentation
-    word>> [ usage-profile. ] curry ;
+    word>> '[ _ usage-profile. ] ;
 
 M: vocab-profile profiler-presentation
-    vocab>> [ vocab-profile. ] curry ;
+    vocab>> '[ _ vocab-profile. ] ;
 
 M: f profiler-presentation
     drop [ vocabs-profile. ] ;

basis/ui/tools/search/search-tests.factor

@@ -19,7 +19,7 @@ IN: ui.tools.search.tests
     ] with-grafted-gadget ;
 
 : test-live-search ( gadget quot -- ? )
-    >r update-live-search dup assert-non-empty r> all? ;
+    [ update-live-search dup assert-non-empty ] dip all? ;
 
 [ t ] [
     "swp" all-words f <definition-search>

basis/ui/tools/tools.factor

@@ -9,7 +9,7 @@ ui.gadgets.books ui.gadgets.buttons ui.gadgets.labelled
 ui.gadgets.scrollers ui.gadgets.tracks ui.gadgets.worlds
 ui.gadgets.presentations ui.gestures words vocabs.loader
 tools.test tools.vocabs ui.gadgets.buttons ui.gadgets.status-bar
-mirrors ;
+mirrors fry ;
 IN: ui.tools
 
 : <workspace-tabs> ( workspace -- tabs )
@@ -93,7 +93,7 @@ workspace "workflow" f {
 ] workspace-window-hook set-global
 
 : inspect-continuation ( traceback -- )
-    control-value [ inspect ] curry call-listener ;
+    control-value '[ _ inspect ] call-listener ;
 
 traceback-gadget "toolbar" f {
     { T{ key-down f f "v" } variables }

basis/ui/tools/walker/walker.factor

@@ -5,7 +5,7 @@ ui.tools.listener ui.tools.traceback ui.gadgets.buttons
 ui.gadgets.status-bar ui.gadgets.tracks ui.commands ui.gadgets
 models models.filter ui.tools.workspace ui.gestures
 ui.gadgets.labels ui threads namespaces make tools.walker assocs
-combinators ;
+combinators fry ;
 IN: ui.tools.walker
 
 TUPLE: walker-gadget < track
@@ -53,7 +53,7 @@ M: walker-gadget focusable-child*
     ] "" make ;
 
 : <thread-status> ( model thread -- gadget )
-    [ walker-state-string ] curry <filter> <label-control> ;
+    '[ _ walker-state-string ] <filter> <label-control> ;
 
 : <walker-gadget> ( status continuation thread -- gadget )
     { 0 1 } walker-gadget new-track
@@ -89,7 +89,7 @@ walker-gadget "toolbar" f {
     } cond ;
 
 : find-walker-window ( thread -- world/f )
-    [ swap walker-for-thread? ] curry find-window ;
+    '[ _ swap walker-for-thread? ] find-window ;
 
 : walker-window ( status continuation thread -- )
     [ <walker-gadget> ] [ name>> ] bi open-status-window ;

basis/ui/tools/workspace/workspace.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2006, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: classes continuations help help.topics kernel models
-sequences assocs arrays namespaces accessors math.vectors ui
+sequences assocs arrays namespaces accessors math.vectors fry ui
 ui.backend ui.tools.debugger ui.gadgets ui.gadgets.books
 ui.gadgets.buttons ui.gadgets.labelled ui.gadgets.panes
 ui.gadgets.scrollers ui.gadgets.tracks ui.gadgets.worlds
@@ -33,7 +33,7 @@ M: gadget tool-scroller drop f ;
     set-model ;
 
 : get-workspace* ( quot -- workspace )
-    [ >r dup workspace? r> [ drop f ] if ] curry find-window
+    '[ dup workspace? _ [ drop f ] if ] find-window
     [ dup raise-window gadget-child ]
     [ workspace-window* ] if* ; inline
 

basis/ui/windows/windows.factor

@@ -288,7 +288,7 @@ SYMBOL: nc-buttons
 : mouse-wheel ( lParam -- array ) >lo-hi [ sgn neg ] map ;
 
 : mouse-absolute>relative ( lparam handle -- array )
-    >r >lo-hi r>
+    [ >lo-hi ] dip
     "RECT" <c-object> [ GetWindowRect win32-error=0/f ] keep
     get-RECT-top-left 2array v- ;
 
@@ -297,7 +297,7 @@ SYMBOL: nc-buttons
     [ <button-down> ] [ <button-up> ] if ;
 
 : prepare-mouse ( hWnd uMsg wParam lParam -- button coordinate world )
-    nip >r mouse-event>gesture r> >lo-hi rot window ;
+    [ drop mouse-event>gesture ] dip >lo-hi rot window ;
 
 : set-capture ( hwnd -- )
     mouse-captured get [
@@ -312,10 +312,10 @@ SYMBOL: nc-buttons
     mouse-captured off ;
 
 : handle-wm-buttondown ( hWnd uMsg wParam lParam -- )
-    >r >r
+    [
         over set-capture
         dup message>button drop nc-buttons get delete
-    r> r> prepare-mouse send-button-down ;
+    ] 2dip prepare-mouse send-button-down ;
 
 : handle-wm-buttonup ( hWnd uMsg wParam lParam -- )
     mouse-captured get [ release-capture ] when
@@ -337,9 +337,10 @@ SYMBOL: nc-buttons
     TrackMouseEvent drop
     >lo-hi swap window move-hand fire-motion ;
 
-: handle-wm-mousewheel ( hWnd uMsg wParam lParam -- )
+:: handle-wm-mousewheel ( hWnd uMsg wParam lParam -- )
-    >r nip r>
+    lParam mouse-wheel
-    pick mouse-absolute>relative >r mouse-wheel r> rot window send-wheel ;
+    hWnd mouse-absolute>relative
+    hWnd window send-wheel ;
 
 : handle-wm-cancelmode ( hWnd uMsg wParam lParam -- )
     #! message sent if windows needs application to stop dragging
@@ -456,10 +457,11 @@ M: windows-ui-backend do-events
 
 : create-window ( rect -- hwnd )
     make-adjusted-RECT
-    >r class-name-ptr get-global f r>
+    [ class-name-ptr get-global f ] dip
-    >r >r >r ex-style r> r>
+    [
+        [ ex-style ] 2dip
         { WS_CLIPSIBLINGS WS_CLIPCHILDREN style } flags
-    r> get-RECT-dimensions
+    ] dip get-RECT-dimensions
     f f f GetModuleHandle f CreateWindowEx dup win32-error=0/f ;
 
 : show-window ( hWnd -- )
@@ -515,7 +517,7 @@ M: windows-ui-backend raise-window* ( world -- )
 M: windows-ui-backend set-title ( string world -- )
     handle>>
     dup title>> [ free ] when*
-    >r utf16n malloc-string r>
+    [ utf16n malloc-string ] dip
     2dup (>>title)
     hWnd>> WM_SETTEXT 0 roll alien-address SendMessage drop ;
 

basis/ui/x11/x11.factor

@@ -79,7 +79,7 @@ M: world configure-event
 : key-down-event>gesture ( event world -- string gesture )
     dupd
     handle>> xic>> lookup-string
-    >r swap event-modifiers r> key-code <key-down> ;
+    [ swap event-modifiers ] dip key-code <key-down> ;
 
 M: world key-down-event
     [ key-down-event>gesture ] keep
@@ -92,18 +92,18 @@ M: world key-down-event
     dup event-modifiers swap 0 XLookupKeysym key-code <key-up> ;
 
 M: world key-up-event
-    >r key-up-event>gesture r> world-focus propagate-gesture ;
+    [ key-up-event>gesture ] dip world-focus propagate-gesture ;
 
 : mouse-event>gesture ( event -- modifiers button loc )
     dup event-modifiers over XButtonEvent-button
     rot mouse-event-loc ;
 
 M: world button-down-event
-    >r mouse-event>gesture >r <button-down> r> r>
+    [ mouse-event>gesture [ <button-down> ] dip ] dip
     send-button-down ;
 
 M: world button-up-event
-    >r mouse-event>gesture >r <button-up> r> r>
+    [ mouse-event>gesture [ <button-up> ] dip ] dip
     send-button-up ;
 
 : mouse-event>scroll-direction ( event -- pair )
@@ -115,7 +115,7 @@ M: world button-up-event
     } at ;
 
 M: world wheel-event
-    >r dup mouse-event>scroll-direction swap mouse-event-loc r>
+    [ dup mouse-event>scroll-direction swap mouse-event-loc ] dip
     send-wheel ;
 
 M: world enter-event motion-event ;
@@ -123,7 +123,7 @@ M: world enter-event motion-event ;
 M: world leave-event 2drop forget-rollover ;
 
 M: world motion-event
-    >r dup XMotionEvent-x swap XMotionEvent-y 2array r>
+    [ dup XMotionEvent-x swap XMotionEvent-y 2array ] dip
     move-hand fire-motion ;
 
 M: world focus-in-event
@@ -158,7 +158,7 @@ M: world selection-notify-event
     [ XSelectionRequestEvent-requestor ] keep
     [ XSelectionRequestEvent-property ] keep
     [ XSelectionRequestEvent-target ] keep
-    >r 8 PropModeReplace r>
+    [ 8 PropModeReplace ] dip
     [
         XSelectionRequestEvent-selection
         clipboard-for-atom contents>>
@@ -208,8 +208,7 @@ M: x-clipboard copy-clipboard
     (>>contents) ;
 
 M: x-clipboard paste-clipboard
-    >r find-world handle>> window>>
+    [ find-world handle>> window>> ] dip atom>> convert-selection ;
-    r> atom>> convert-selection ;
 
 : init-clipboard ( -- )
     XA_PRIMARY <x-clipboard> selection set-global
@@ -219,9 +218,8 @@ M: x-clipboard paste-clipboard
     dup [ 127 <= ] all? [ XStoreName drop ] [ 3drop ] if ;
 
 : set-title-new ( dpy window string -- )
-    >r
+    [ XA_NET_WM_NAME XA_UTF8_STRING 8 PropModeReplace ] dip
-    XA_NET_WM_NAME XA_UTF8_STRING 8 PropModeReplace
+    utf8 encode dup length XChangeProperty drop ;
-    r> utf8 encode dup length XChangeProperty drop ;
 
 M: x11-ui-backend set-title ( string world -- )
     handle>> window>> swap dpy get -rot
@@ -237,8 +235,7 @@ M: x11-ui-backend set-fullscreen* ( ? world -- )
     "_NET_WM_STATE" x-atom over set-XClientMessageEvent-message_type
     32 over set-XClientMessageEvent-format
     "_NET_WM_STATE_FULLSCREEN" x-atom over set-XClientMessageEvent-data1
-    >r dpy get root get 0 SubstructureNotifyMask r> XSendEvent drop ;
+    [ dpy get root get 0 SubstructureNotifyMask ] dip XSendEvent drop ;
-
 
 M: x11-ui-backend (open-window) ( world -- )
     dup gadget-window

basis/x11/xlib/xlib.factor

@@ -13,7 +13,7 @@
 
 USING: kernel arrays alien alien.c-types alien.strings
 alien.syntax math math.bitwise words sequences namespaces
-continuations io.encodings.ascii ;
+continuations io io.encodings.ascii ;
 IN: x11.xlib
 
 LIBRARY: xlib
@@ -1359,8 +1359,8 @@ SYMBOL: scr
 SYMBOL: root
 
 : init-locale ( -- )
-   LC_ALL "" setlocale [ "setlocale() failed" throw ] unless
+   LC_ALL "" setlocale [ "setlocale() failed" print flush ] unless
-   XSupportsLocale [ "XSupportsLocale() failed" throw ] unless ;
+   XSupportsLocale [ "XSupportsLocale() failed" print flush ] unless ;
 
 : flush-dpy ( -- ) dpy get XFlush drop ;
 
@@ -1381,4 +1381,4 @@ SYMBOL: root
 : close-x ( -- ) dpy get XCloseDisplay drop ;
 
 : with-x ( display-string quot -- )
-    >r initialize-x r> [ close-x ] [ ] cleanup ;
+    [ initialize-x ] dip [ close-x ] [ ] cleanup ;

core/bootstrap/primitives.factor

@@ -534,6 +534,7 @@ tuple
     { "unimplemented" "kernel.private" }
     { "gc-reset" "memory" }
     { "jit-compile" "quotations" }
+    { "load-locals" "locals.backend" }
 }
 [ [ first2 ] dip make-primitive ] each-index
 

core/generic/generic-docs.factor

@@ -165,3 +165,19 @@ HELP: (call-next-method)
 { $values { "method" method-body } }
 { $description "Low-level word implementing " { $link POSTPONE: call-next-method } "." }
 { $notes "In most cases, " { $link POSTPONE: call-next-method } " should be used instead." } ;
+
+HELP: no-next-method
+{ $error-description "Thrown by " { $link POSTPONE: call-next-method } " if the current method is already the least specific method." }
+{ $examples
+    "The following code throws this error:"
+    { $code
+        "GENERIC: error-test ( object -- )"
+        ""
+        "M: number error-test 3 + call-next-method ;"
+        ""
+        "M: integer error-test recip call-next-method ;"
+        ""
+        "123 error-test"
+    }
+    "This results in the method on " { $link integer } " being called, which then calls the method on " { $link number } ". The latter then calls " { $link POSTPONE: call-next-method } ", however there is no method less specific than the method on " { $link number } " and so an error is thrown."
+} ;

core/generic/generic.factor

@@ -58,8 +58,10 @@ GENERIC: next-method-quot* ( class generic combination -- quot )
         ] bi next-method-quot*
     ] cache ;
 
+ERROR: no-next-method method ;
+
 : (call-next-method) ( method -- )
-    next-method-quot call ;
+    dup next-method-quot [ call ] [ no-next-method ] ?if ;
 
 TUPLE: check-method class generic ;
 

core/generic/standard/standard-docs.factor

@@ -33,22 +33,6 @@ HELP: define-simple-generic
 
 { standard-combination hook-combination } related-words
 
-HELP: no-next-method
-{ $error-description "Thrown by " { $link POSTPONE: call-next-method } " if the current method is already the least specific method." }
-{ $examples
-    "The following code throws this error:"
-    { $code
-        "GENERIC: error-test ( object -- )"
-        ""
-        "M: number error-test 3 + call-next-method ;"
-        ""
-        "M: integer error-test recip call-next-method ;"
-        ""
-        "123 error-test"
-    }
-    "This results in the method on " { $link integer } " being called, which then calls the method on " { $link number } ". The latter then calls " { $link POSTPONE: call-next-method } ", however there is no method less specific than the method on " { $link number } " and so an error is thrown."
-} ;
-
 HELP: inconsistent-next-method
 { $error-description "Thrown by " { $link POSTPONE: call-next-method } " if the values on the stack are not compatible with the current method." }
 { $examples

core/generic/standard/standard-tests.factor

@@ -200,7 +200,7 @@ M: ceo salary
 [ T{ inconsistent-next-method f ceo salary } = ] must-fail-with
 
 [ intern boa salary ]
-[ T{ no-next-method f intern salary } = ] must-fail-with
+[ no-next-method? ] must-fail-with
 
 ! Weird shit
 TUPLE: a ;

core/generic/standard/standard.factor

@@ -79,20 +79,15 @@ ERROR: no-method object generic ;
 
 ERROR: inconsistent-next-method class generic ;
 
-ERROR: no-next-method class generic ;
+: single-next-method-quot ( class generic -- quot/f )
-
+    2dup next-method dup [
-: single-next-method-quot ( class generic -- quot )
         [
-        [ drop "predicate" word-prop % ]
+            pick "predicate" word-prop %
-        [
+            1quotation ,
-            2dup next-method
+            [ inconsistent-next-method ] 2curry ,
-            [ 2nip 1quotation ]
-            [ [ no-next-method ] 2curry [ ] like ] if* ,
-        ]
-        [ [ inconsistent-next-method ] 2curry , ]
-        2tri
             \ if ,
-    ] [ ] make ;
+        ] [ ] make
+    ] [ 3drop f ] if ;
 
 : single-effective-method ( obj word -- method )
     [ [ order [ instance? ] with find-last nip ] keep method ]
@@ -130,7 +125,8 @@ M: standard-combination method-declaration
 
 M: standard-combination next-method-quot*
     [
-        single-next-method-quot picker prepend
+        single-next-method-quot
+        dup [ picker prepend ] when
     ] with-standard ;
 
 M: standard-generic effective-method
@@ -145,9 +141,12 @@ PREDICATE: hook-generic < generic
 
 : with-hook ( combination quot -- quot' )
     0 (dispatch#) [
-        dip var>> [ get ] curry prepend
+        [ hook-combination ] dip with-variable
     ] with-variable ; inline
 
+: prepend-hook-var ( quot -- quot' )
+    hook-combination get var>> [ get ] curry prepend ;
+
 M: hook-combination dispatch# drop 0 ;
 
 M: hook-combination method-declaration 2drop [ ] ;
@@ -159,13 +158,18 @@ M: hook-generic effective-method
     single-effective-method ;
 
 M: hook-combination make-default-method
-    [ error-method ] with-hook ;
+    [ error-method prepend-hook-var ] with-hook ;
 
 M: hook-combination perform-combination
-    [ drop ] [ [ single-combination ] with-hook ] 2bi define ;
+    [ drop ] [
+        [ single-combination prepend-hook-var ] with-hook
+    ] 2bi define ;
 
 M: hook-combination next-method-quot*
-    [ single-next-method-quot ] with-hook ;
+    [
+        single-next-method-quot
+        dup [ prepend-hook-var ] when
+    ] with-hook ;
 
 M: simple-generic definer drop \ GENERIC: f ;
 

extra/maze/maze.factor

@@ -41,7 +41,6 @@ SYMBOL: visited
     ] if ;
 
 : draw-maze ( n -- )
-    -0.5 0.5 0 glTranslated
     line-width 2 - glLineWidth
     line-width 2 - glPointSize
     1.0 1.0 1.0 1.0 glColor4d

misc/factor.el

@@ -89,6 +89,11 @@ buffer."
   :type 'boolean
   :group 'factor)
 
+(defcustom factor-help-use-minibuffer t
+  "When enabled, use the minibuffer for short help messages."
+  :type 'boolean
+  :group 'factor)
+
 (defcustom factor-display-compilation-output t
   "Display the REPL buffer before compiling files."
   :type 'boolean
@@ -195,11 +200,14 @@ buffer."
 (defconst factor--regex-symbol-definition
   (factor--regex-second-word '("SYMBOL:")))
 
+(defconst factor--regex-stack-effect " ( .* )")
+
 (defconst factor--regex-using-line "^USING: +\\([^;]*\\);")
+
 (defconst factor--regex-use-line "^USE: +\\(.*\\)$")
 
 (defconst factor--font-lock-keywords
-  `(("( .* )" . 'factor-font-lock-stack-effect)
+  `((,factor--regex-stack-effect . 'factor-font-lock-stack-effect)
     ("\\(P\\|SBUF\\)\"" 1 'factor-font-lock-parsing-word)
     ,@(mapcar #'(lambda (w) (cons (concat "\\(^\\| \\)\\(" w "\\)\\($\\| \\)")
                              '(2 'factor-font-lock-parsing-word)))
@@ -218,16 +226,19 @@ buffer."
 
 ;;; Factor mode syntax:
 
+(defconst factor--regexp-word-starters
+  (regexp-opt '("TUPLE" "MACRO" "MACRO:" "M" ":" "")))
+
 (defconst factor--regexp-word-start
-  (let ((sws '("" ":" "TUPLE" "MACRO" "MACRO:" "M")))
+  (format "^\\(%s:\\) " factor--regexp-word-starters))
-    (format "^\\(%s\\)\\(:\\) " (regexp-opt sws))))
 
 (defconst factor--font-lock-syntactic-keywords
-  `(("^\\(:\\)\\(:\\)" (1 ".") (2 "(;"))
+  `((,(format "^\\(%s\\)\\(:\\)" factor--regexp-word-starters)
-    (,factor--regexp-word-start (2 "(;"))
+     (1 "w") (2 "(;"))
     ("\\(;\\)" (1 "):"))
     ("\\(#!\\)" (1 "<"))
-    ("\\(!\\)" (1 "<"))
+    (" \\(!\\)" (1 "<"))
+    ("^\\(!\\)" (1 "<"))
     ("\\(!(\\) .* \\()\\)" (1 "<") (2 ">"))))
 
 (defvar factor-mode-syntax-table nil
@@ -279,6 +290,25 @@ buffer."
     (modify-syntax-entry ?\" "\"" factor-mode-syntax-table)
     (modify-syntax-entry ?\\ "/" factor-mode-syntax-table)))
 
+;;; symbol-at-point
+
+(defun factor--beginning-of-symbol ()
+  "Move point to the beginning of the current symbol."
+  (while (eq (char-before) ?:) (backward-char))
+  (skip-syntax-backward "w_"))
+
+(defun factor--end-of-symbol ()
+  "Move point to the end of the current symbol."
+  (skip-syntax-forward "w_")
+  (while (looking-at ":") (forward-char)))
+
+(put 'factor-symbol 'end-op 'factor--end-of-symbol)
+(put 'factor-symbol 'beginning-op 'factor--beginning-of-symbol)
+
+(defsubst factor--symbol-at-point ()
+  (let ((s (substring-no-properties (thing-at-point 'factor-symbol))))
+    (and (> (length s) 0) s)))
+
 
 ;;; Factor mode indentation:
 
@@ -414,7 +444,83 @@ buffer."
           (goto-char (- (point-max) pos))))))
 
 
-;;; Factor mode commands:
+;; Factor mode:
+(defvar factor-mode-map (make-sparse-keymap)
+  "Key map used by Factor mode.")
+
+;;;###autoload
+(defun factor-mode ()
+  "A mode for editing programs written in the Factor programming language.
+\\{factor-mode-map}"
+  (interactive)
+  (kill-all-local-variables)
+  (use-local-map factor-mode-map)
+  (setq major-mode 'factor-mode)
+  (setq mode-name "Factor")
+  ;; Font locking
+  (set (make-local-variable 'comment-start) "! ")
+  (set (make-local-variable 'parse-sexp-lookup-properties) t)
+  (set (make-local-variable 'font-lock-comment-face) 'factor-font-lock-comment)
+  (set (make-local-variable 'font-lock-string-face) 'factor-font-lock-string)
+  (set (make-local-variable 'font-lock-defaults)
+       `(factor--font-lock-keywords
+         nil nil nil nil
+         (font-lock-syntactic-keywords . ,factor--font-lock-syntactic-keywords)))
+
+  (set-syntax-table factor-mode-syntax-table)
+  ;; Defun navigation
+  (setq defun-prompt-regexp "[^ :]+")
+  (set (make-local-variable 'open-paren-in-column-0-is-defun-start) t)
+  ;; Indentation
+  (set (make-local-variable 'indent-line-function) 'factor--indent-line)
+  (setq factor-indent-width (factor--guess-indent-width))
+  (setq indent-tabs-mode nil)
+  ;; ElDoc
+  (set (make-local-variable 'eldoc-documentation-function) 'factor--eldoc)
+
+  (run-hooks 'factor-mode-hook))
+
+(add-to-list 'auto-mode-alist '("\\.factor\\'" . factor-mode))
+
+
+;;; Factor listener mode:
+
+;;;###autoload
+(define-derived-mode factor-listener-mode comint-mode "Factor Listener"
+  "Major mode for interacting with an inferior Factor listener process.
+\\{factor-listener-mode-map}"
+  (set (make-local-variable 'comint-prompt-regexp) "^( [^)]+ ) "))
+
+(defvar factor--listener-buffer nil
+  "The buffer in which the Factor listener is running.")
+
+(defun factor--listener-start-process ()
+  "Start an inferior Factor listener process, using
+`factor-binary' and `factor-image'."
+  (setq factor--listener-buffer
+        (apply 'make-comint "factor" (expand-file-name factor-binary) nil
+               `("-run=listener" ,(format "-i=%s" (expand-file-name factor-image)))))
+  (with-current-buffer factor--listener-buffer
+    (factor-listener-mode)))
+
+(defun factor--listener-process (&optional start)
+  (or (and (buffer-live-p factor--listener-buffer)
+           (get-buffer-process factor--listener-buffer))
+      (when start
+        (factor--listener-start-process)
+        (factor--listener-process t))))
+
+;;;###autoload
+(defalias 'switch-to-factor 'run-factor)
+;;;###autoload
+(defun run-factor (&optional arg)
+  "Show the factor-listener buffer, starting the process if needed."
+  (interactive)
+  (let ((buf (process-buffer (factor--listener-process t)))
+        (pop-up-windows factor-listener-window-allow-split))
+    (if factor-listener-use-other-window
+        (pop-to-buffer buf)
+      (switch-to-buffer buf))))
 
 (defun factor-telnet-to-port (port)
   (interactive "nPort: ")
@@ -429,6 +535,110 @@ buffer."
   (interactive)
   (factor-telnet-to-port 9010))
 
+
+;;; Factor listener interaction:
+
+(defun factor--listener-send-cmd (cmd)
+  (let ((proc (factor--listener-process)))
+    (when proc
+      (let* ((out (get-buffer-create "*factor messages*"))
+             (beg (with-current-buffer out (goto-char (point-max)))))
+        (comint-redirect-send-command-to-process cmd out proc nil t)
+        (with-current-buffer factor--listener-buffer
+          (while (not comint-redirect-completed) (sleep-for 0 1)))
+        (with-current-buffer out
+          (split-string (buffer-substring-no-properties beg (point-max))
+                        "[\"\f\n\r\v]+" t))))))
+
+;;;;; Current vocabulary:
+(make-variable-buffer-local
+ (defvar factor--current-vocab nil
+   "Current vocabulary."))
+
+(defconst factor--regexp-current-vocab "^IN: +\\([^ \r\n\f]+\\)")
+
+(defun factor--current-buffer-vocab ()
+  (save-excursion
+    (when (or (re-search-backward factor--regexp-current-vocab nil t)
+              (re-search-forward factor--regexp-current-vocab nil t))
+      (setq factor--current-vocab (match-string-no-properties 1)))))
+
+(defun factor--current-listener-vocab ()
+  (car (factor--listener-send-cmd "USING: parser ; in get .")))
+
+
+(defun factor--set-current-listener-vocab (&optional vocab)
+  (factor--listener-send-cmd
+   (format "IN: %s" (or vocab (factor--current-buffer-vocab))))
+  t)
+
+(defmacro factor--with-vocab (vocab &rest body)
+  (let ((current (make-symbol "current")))
+    `(let ((,current (factor--current-listener-vocab)))
+       (factor--set-current-listener-vocab ,vocab)
+       (prog1 (condition-case nil (progn . ,body) (error nil))
+         (factor--set-current-listener-vocab ,current)))))
+
+(put 'factor--with-vocab 'lisp-indent-function 1)
+
+;;;;; Synchronous interaction:
+
+(defsubst factor--listener-vocab-cmds (cmds &optional vocab)
+  (factor--with-vocab vocab
+    (mapcar #'factor--listener-send-cmd cmds)))
+
+(defsubst factor--listener-vocab-cmd (cmd &optional vocab)
+  (factor--with-vocab vocab
+    (factor--listener-send-cmd cmd)))
+
+;;;;; Interface: see
+
+(defconst factor--regex-error-marker "^Type :help for debugging")
+(defconst factor--regex-data-stack "^--- Data stack:")
+
+(defun factor--prune-ans-strings (ans)
+  (nreverse
+   (catch 'done
+     (let ((res))
+       (dolist (a ans res)
+         (cond ((string-match factor--regex-stack-effect a)
+                (throw 'done (cons a res)))
+               ((string-match factor--regex-data-stack a)
+                (throw 'done res))
+               ((string-match factor--regex-error-marker a)
+                (throw 'done nil))
+               (t (push a res))))))))
+
+(defun factor--see-ans-to-string (ans)
+  (let ((s (mapconcat #'identity (factor--prune-ans-strings ans) " "))
+        (font-lock-verbose nil))
+    (and (> (length s) 0)
+         (with-temp-buffer
+           (insert s)
+           (factor-mode)
+           (font-lock-fontify-buffer)
+           (buffer-string)))))
+
+(defun factor--see-current-word (&optional word)
+  (let ((word (or word (factor--symbol-at-point))))
+    (when word
+      (let ((answer (factor--listener-send-cmd (format "\\ %s see" word))))
+        (and answer (factor--see-ans-to-string answer))))))
+
+(defalias 'factor--eldoc 'factor--see-current-word)
+
+(defun factor-see-current-word (&optional word)
+  "Echo in the minibuffer information about word at point."
+  (interactive)
+  (unless (factor--listener-process)
+    (error "No factor listener running. Try M-x run-factor"))
+  (let ((word (or word (factor--symbol-at-point)))
+        (msg (factor--see-current-word word)))
+    (if msg (message "%s" msg)
+      (if word (message "No help found for '%s'" word)
+        (message "No word at point")))))
+
+;;; to fix:
 (defun factor-run-file ()
   (interactive)
   (when (and (buffer-modified-p)
@@ -485,83 +695,6 @@ buffer."
   (beginning-of-line)
   (insert "! "))
 
-(defvar factor-mode-map (make-sparse-keymap)
-  "Key map used by Factor mode.")
-
-
-;; Factor mode:
-
-;;;###autoload
-(defun factor-mode ()
-  "A mode for editing programs written in the Factor programming language.
-\\{factor-mode-map}"
-  (interactive)
-  (kill-all-local-variables)
-  (use-local-map factor-mode-map)
-  (setq major-mode 'factor-mode)
-  (setq mode-name "Factor")
-  ;; Font locking
-  (set (make-local-variable 'comment-start) "! ")
-  (set (make-local-variable 'parse-sexp-lookup-properties) t)
-  (set (make-local-variable 'font-lock-comment-face) 'factor-font-lock-comment)
-  (set (make-local-variable 'font-lock-string-face) 'factor-font-lock-string)
-  (set (make-local-variable 'font-lock-defaults)
-       `(factor--font-lock-keywords
-         nil nil nil nil
-         (font-lock-syntactic-keywords . ,factor--font-lock-syntactic-keywords)))
-
-  (set-syntax-table factor-mode-syntax-table)
-  ;; Defun navigation
-  (setq defun-prompt-regexp "[^ :]+")
-  (set (make-local-variable 'open-paren-in-column-0-is-defun-start) t)
-  ;; Indentation
-  (set (make-local-variable 'indent-line-function) 'factor--indent-line)
-  (setq factor-indent-width (factor--guess-indent-width))
-  (setq indent-tabs-mode nil)
-
-  (run-hooks 'factor-mode-hook))
-
-(add-to-list 'auto-mode-alist '("\\.factor\\'" . factor-mode))
-
-
-;;; Factor listener mode:
-
-;;;###autoload
-(define-derived-mode factor-listener-mode comint-mode "Factor Listener"
-  "Major mode for interacting with an inferior Factor listener process.
-\\{factor-listener-mode-map}"
-  (set (make-local-variable 'comint-prompt-regexp) "^( [^)]+ ) "))
-
-(defvar factor--listener-buffer nil
-  "The buffer in which the Factor listener is running.")
-
-(defun factor--listener-start-process ()
-  "Start an inferior Factor listener process, using
-`factor-binary' and `factor-image'."
-  (setq factor--listener-buffer
-        (apply 'make-comint "factor" (expand-file-name factor-binary) nil
-               `("-run=listener" ,(format "-i=%s" (expand-file-name factor-image)))))
-  (with-current-buffer factor--listener-buffer
-    (factor-listener-mode)))
-
-(defun factor--listener-process ()
-  (or (and (buffer-live-p factor--listener-buffer)
-           (get-buffer-process factor--listener-buffer))
-      (progn (factor--listener-start-process)
-             (factor--listener-process))))
-
-;;;###autoload
-(defalias 'switch-to-factor 'run-factor)
-;;;###autoload
-(defun run-factor (&optional arg)
-  "Show the factor-listener buffer, starting the process if needed."
-  (interactive)
-  (let ((buf (process-buffer (factor--listener-process)))
-        (pop-up-windows factor-listener-window-allow-split))
-    (if factor-listener-use-other-window
-        (pop-to-buffer buf)
-      (switch-to-buffer buf))))
-
 
 ;;;; Factor help mode:
 
@@ -611,16 +744,18 @@ buffer."
 
 (defun factor--listener-help-buffer ()
   (with-current-buffer (get-buffer-create "*factor-help*")
-    (let ((inhibit-read-only t))
+    (let ((inhibit-read-only t)) (erase-buffer))
-      (delete-region (point-min) (point-max)))
     (factor-help-mode)
     (current-buffer)))
 
 (defvar factor--help-history nil)
 
 (defun factor--listener-show-help (&optional see)
-  (let* ((def (thing-at-point 'sexp))
+  (unless (factor--listener-process)
-         (prompt (format "%s (%s): " (if see "See" "Help") def))
+    (error "No running factor listener. Try M-x run-factor"))
+  (let* ((def (factor--symbol-at-point))
+         (prompt (format "See%s help on%s: " (if see " short" "")
+                         (if def (format " (%s)" def) "")))
          (ask (or (not (eq major-mode 'factor-mode))
                   (not def)
                   factor-help-always-ask))
@@ -633,11 +768,21 @@ buffer."
     (pop-to-buffer hb)
     (beginning-of-buffer hb)))
 
-(defun factor-see ()
+;;;; Interface: see/help commands
-  (interactive)
+
-  (factor--listener-show-help t))
+(defun factor-see (&optional arg)
+  "See a help summary of symbol at point.
+By default, the information is shown in the minibuffer. When
+called with a prefix argument, the information is displayed in a
+separate help buffer."
+  (interactive "P")
+  (if (if factor-help-use-minibuffer (not arg) arg)
+      (factor-see-current-word)
+    (factor--listener-show-help t)))
 
 (defun factor-help ()
+  "Show extended help about the symbol at point, using a help
+buffer."
   (interactive)
   (factor--listener-show-help))
 

vm/Config.macosx.x86.64

@@ -1,3 +1,3 @@
 include vm/Config.macosx
 include vm/Config.x86.64
-CFLAGS += -arch x86_64
+CFLAGS += -m64

vm/data_gc.c

@@ -985,6 +985,7 @@ void primitive_become(void)
 	}
 
 	gc();
+	iterate_code_heap(relocate_code_block);
 }
 
 CELL find_all_words(void)

vm/debug.c

@@ -129,7 +129,7 @@ void print_nested_obj(CELL obj, F_FIXNUM nesting)
 		print_string(" ]");
 		break;
 	default:
-		print_string("#<type "); print_cell(type_of(obj)); print_string(" @ "); print_cell_hex(obj);
+		print_string("#<type "); print_cell(type_of(obj)); print_string(" @ "); print_cell_hex(obj); print_string(">");
 		break;
 	}
 }

vm/primitives.c

@@ -141,4 +141,5 @@ void *primitives[] = {
 	primitive_unimplemented,
 	primitive_gc_reset,
 	primitive_jit_compile,
+	primitive_load_locals,
 };

vm/run.c

@@ -190,3 +190,11 @@ void primitive_set_slot(void)
 	CELL value = dpop();
 	set_slot(obj,slot,value);
 }
+
+void primitive_load_locals(void)
+{
+	F_FIXNUM count = untag_fixnum_fast(dpop());
+	memcpy((CELL *)(rs + CELLS),(CELL *)(ds - CELLS * (count - 1)),CELLS * count);
+	ds -= CELLS * count;
+	rs += CELLS * count;
+}

vm/run.h

@@ -247,5 +247,6 @@ void primitive_set_os_envs(void);
 void primitive_micros(void);
 void primitive_sleep(void);
 void primitive_set_slot(void);
+void primitive_load_locals(void);
 
 bool stage2;

vm/types.c

@@ -139,18 +139,6 @@ CELL allot_array_1(CELL obj)
 	return tag_object(a);
 }
 
-CELL allot_array_2(CELL v1, CELL v2)
-{
-	REGISTER_ROOT(v1);
-	REGISTER_ROOT(v2);
-	F_ARRAY *a = allot_array_internal(ARRAY_TYPE,2);
-	UNREGISTER_ROOT(v2);
-	UNREGISTER_ROOT(v1);
-	set_array_nth(a,0,v1);
-	set_array_nth(a,1,v2);
-	return tag_object(a);
-}
-
 CELL allot_array_4(CELL v1, CELL v2, CELL v3, CELL v4)
 {
 	REGISTER_ROOT(v1);
@@ -331,15 +319,9 @@ void primitive_tuple_boa(void)
 {
 	F_TUPLE_LAYOUT *layout = untag_object(dpop());
 	F_FIXNUM size = untag_fixnum_fast(layout->size);
-
-	REGISTER_UNTAGGED(layout);
 	F_TUPLE *tuple = allot_tuple(layout);
-	UNREGISTER_UNTAGGED(layout);
+	memcpy(tuple + 1,(CELL *)(ds - CELLS * (size - 1)),CELLS * size);
-
+	ds -= CELLS * size;
-	F_FIXNUM i;
-	for(i = size - 1; i >= 0; i--)
-		put(AREF(tuple,i),dpop());
-
 	dpush(tag_tuple(tuple));
 }
 

vm/types.h

@@ -109,7 +109,6 @@ F_ARRAY *allot_array(CELL type, CELL capacity, CELL fill);
 F_BYTE_ARRAY *allot_byte_array(CELL size);
 
 CELL allot_array_1(CELL obj);
-CELL allot_array_2(CELL v1, CELL v2);
 CELL allot_array_4(CELL v1, CELL v2, CELL v3, CELL v4);
 
 void primitive_array(void);