From c1b42e964653df5ed89498e27b014ef57b06d3db Mon Sep 17 00:00:00 2001
From: "Jose A. Ortega Ruiz" <jao@gnu.org>
Date: Wed, 26 Nov 2008 22:58:11 +0100
Subject: [PATCH 01/24] Emacs factor mode: correct fontification in presence of
 word names containing !.

---
 misc/factor.el | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/misc/factor.el b/misc/factor.el
index 346642f70c..79e48e768c 100644
--- a/misc/factor.el
+++ b/misc/factor.el
@@ -227,7 +227,8 @@ buffer."
     (,factor--regexp-word-start (2 "(;"))
     ("\\(;\\)" (1 "):"))
     ("\\(#!\\)" (1 "<"))
-    ("\\(!\\)" (1 "<"))
+    (" \\(!\\)" (1 "<"))
+    ("^\\(!\\)" (1 "<"))
     ("\\(!(\\) .* \\()\\)" (1 "<") (2 ">"))))
 
 (defvar factor-mode-syntax-table nil

From d7587282fd315ae87517c4e85dd94fb040e519b3 Mon Sep 17 00:00:00 2001
From: "Jose A. Ortega Ruiz" <jao@gnu.org>
Date: Fri, 28 Nov 2008 01:51:33 +0100
Subject: [PATCH 02/24] Emacs factor mode: 'see' in minibuffer and Eldoc mode
 available.

---
 misc/factor.el | 305 +++++++++++++++++++++++++++++++++++--------------
 1 file changed, 219 insertions(+), 86 deletions(-)

diff --git a/misc/factor.el b/misc/factor.el
index 79e48e768c..99b271ad4f 100644
--- a/misc/factor.el
+++ b/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,13 +226,15 @@ 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\\)\\(:\\) " (regexp-opt sws))))
+  (format "^\\(%s:\\) " factor--regexp-word-starters))
 
 (defconst factor--font-lock-syntactic-keywords
-  `(("^\\(:\\)\\(:\\)" (1 ".") (2 "(;"))
-    (,factor--regexp-word-start (2 "(;"))
+  `((,(format "^\\(%s\\)\\(:\\)" factor--regexp-word-starters)
+     (1 "w") (2 "(;"))
     ("\\(;\\)" (1 "):"))
     ("\\(#!\\)" (1 "<"))
     (" \\(!\\)" (1 "<"))
@@ -280,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:
 
@@ -415,83 +444,10 @@ buffer."
           (goto-char (- (point-max) pos))))))
 
 
-;;; Factor mode commands:
-
-(defun factor-telnet-to-port (port)
-  (interactive "nPort: ")
-  (switch-to-buffer
-   (make-comint-in-buffer "factor-telnet" nil (cons "localhost" port))))
-
-(defun factor-telnet ()
-  (interactive)
-  (factor-telnet-to-port 9000))
-
-(defun factor-telnet-factory ()
-  (interactive)
-  (factor-telnet-to-port 9010))
-
-(defun factor-run-file ()
-  (interactive)
-  (when (and (buffer-modified-p)
-			 (y-or-n-p (format "Save file %s? " (buffer-file-name))))
-	(save-buffer))
-  (when factor-display-compilation-output
-	(factor-display-output-buffer))
-  (comint-send-string "*factor*" (format "\"%s\"" (buffer-file-name)))
-  (comint-send-string "*factor*" " run-file\n"))
-
-(defun factor-display-output-buffer ()
-  (with-current-buffer "*factor*"
-	(goto-char (point-max))
-	(unless (get-buffer-window (current-buffer) t)
-	  (display-buffer (current-buffer) t))))
-
-(defun factor-send-string (str)
-  (let ((n (length (split-string str "\n"))))
-    (save-excursion
-      (set-buffer "*factor*")
-      (goto-char (point-max))
-      (if (> n 1) (newline))
-      (insert str)
-      (comint-send-input))))
-
-(defun factor-send-region (start end)
-  (interactive "r")
-  (let ((str (buffer-substring start end))
-        (n   (count-lines      start end)))
-    (save-excursion
-      (set-buffer "*factor*")
-      (goto-char (point-max))
-      (if (> n 1) (newline))
-      (insert str)
-      (comint-send-input))))
-
-(defun factor-send-definition ()
-  (interactive)
-  (factor-send-region (search-backward ":")
-                      (search-forward  ";")))
-
-(defun factor-edit ()
-  (interactive)
-  (comint-send-string "*factor*" "\\ ")
-  (comint-send-string "*factor*" (thing-at-point 'sexp))
-  (comint-send-string "*factor*" " edit\n"))
-
-(defun factor-clear ()
-  (interactive)
-  (factor-send-string "clear"))
-
-(defun factor-comment-line ()
-  (interactive)
-  (beginning-of-line)
-  (insert "! "))
-
+;; Factor mode:
 (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.
@@ -519,6 +475,8 @@ buffer."
   (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--see-current-word)
 
   (run-hooks 'factor-mode-hook))
 
@@ -563,6 +521,171 @@ buffer."
         (pop-to-buffer buf)
       (switch-to-buffer buf))))
 
+(defun factor-telnet-to-port (port)
+  (interactive "nPort: ")
+  (switch-to-buffer
+   (make-comint-in-buffer "factor-telnet" nil (cons "localhost" port))))
+
+(defun factor-telnet ()
+  (interactive)
+  (factor-telnet-to-port 9000))
+
+(defun factor-telnet-factory ()
+  (interactive)
+  (factor-telnet-to-port 9010))
+
+
+;;; Factor listener interaction:
+
+(defun factor--listener-send-cmd (cmd)
+  (let* ((out (get-buffer-create "*factor messages*"))
+         (beg (with-current-buffer out (goto-char (point-max))))
+         (proc (factor--listener-process)))
+    (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:
+
+(defun factor--listener-sync-cmds (cmds &optional vocab)
+  (factor--with-vocab vocab
+    (mapcar #'(lambda (c)
+                (comint-redirect-results-list-from-process
+                 (factor--listener-process) c ".+" 0))
+            cmds)))
+
+(defsubst factor--listener-sync-cmd (cmd &optional vocab)
+  (car (factor--listener-sync-cmds (list cmd) vocab)))
+
+;;;;; Interface: see
+
+(defconst factor--regex-error-marker "^Type :help for debugging")
+(defconst factor--regex-data-stack "^--- Data stack:")
+
+(defun factor--prune-stack (ans)
+  (do ((res '() (cons (car s) res)) (s ans (cdr s)))
+      ((or (not s)
+           (and (car res) (string-match factor--regex-stack-effect (car res)))
+           (string-match factor--regex-data-stack (car s)))
+       (and (not (string-match factor--regex-error-marker (car res)))
+            (nreverse res)))))
+
+(defun factor--see-ans-to-string (ans)
+  (let ((s (mapconcat #'identity (factor--prune-stack ans) " ")))
+    (and (> (length s) 0)
+         (let ((font-lock-verbose nil))
+           (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))))
+        (factor--see-ans-to-string answer)))))
+
+(defun factor-see-current-word (&optional word)
+  "Echo in the minibuffer information about word at point."
+  (interactive)
+  (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)
+             (y-or-n-p (format "Save file %s? " (buffer-file-name))))
+    (save-buffer))
+  (when factor-display-compilation-output
+    (factor-display-output-buffer))
+  (comint-send-string "*factor*" (format "\"%s\"" (buffer-file-name)))
+  (comint-send-string "*factor*" " run-file\n"))
+
+(defun factor-display-output-buffer ()
+  (with-current-buffer "*factor*"
+    (goto-char (point-max))
+    (unless (get-buffer-window (current-buffer) t)
+      (display-buffer (current-buffer) t))))
+
+(defun factor-send-string (str)
+  (let ((n (length (split-string str "\n"))))
+    (save-excursion
+      (set-buffer "*factor*")
+      (goto-char (point-max))
+      (if (> n 1) (newline))
+      (insert str)
+      (comint-send-input))))
+
+(defun factor-send-region (start end)
+  (interactive "r")
+  (let ((str (buffer-substring start end))
+        (n   (count-lines      start end)))
+    (save-excursion
+      (set-buffer "*factor*")
+      (goto-char (point-max))
+      (if (> n 1) (newline))
+      (insert str)
+      (comint-send-input))))
+
+(defun factor-send-definition ()
+  (interactive)
+  (factor-send-region (search-backward ":")
+                      (search-forward  ";")))
+
+(defun factor-edit ()
+  (interactive)
+  (comint-send-string "*factor*" "\\ ")
+  (comint-send-string "*factor*" (thing-at-point 'sexp))
+  (comint-send-string "*factor*" " edit\n"))
+
+(defun factor-clear ()
+  (interactive)
+  (factor-send-string "clear"))
+
+(defun factor-comment-line ()
+  (interactive)
+  (beginning-of-line)
+  (insert "! "))
+
 
 ;;;; Factor help mode:
 
@@ -612,16 +735,16 @@ buffer."
 
 (defun factor--listener-help-buffer ()
   (with-current-buffer (get-buffer-create "*factor-help*")
-    (let ((inhibit-read-only t))
-      (delete-region (point-min) (point-max)))
+    (let ((inhibit-read-only t)) (erase-buffer))
     (factor-help-mode)
     (current-buffer)))
 
 (defvar factor--help-history nil)
 
 (defun factor--listener-show-help (&optional see)
-  (let* ((def (thing-at-point 'sexp))
-         (prompt (format "%s (%s): " (if see "See" "Help") def))
+  (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))
@@ -634,11 +757,21 @@ buffer."
     (pop-to-buffer hb)
     (beginning-of-buffer hb)))
 
-(defun factor-see ()
-  (interactive)
-  (factor--listener-show-help t))
+;;;; Interface: see/help commands
+
+(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))
 

From 95bf38f5ee5ac545e091b4f8bee44ba1f6c45c38 Mon Sep 17 00:00:00 2001
From: "Jose A. Ortega Ruiz" <jao@gnu.org>
Date: Fri, 28 Nov 2008 02:37:49 +0100
Subject: [PATCH 03/24] Emacs factor mode: Fail gracefully when the listener is
 not running.

---
 misc/factor.el | 50 ++++++++++++++++++++++++++++----------------------
 1 file changed, 28 insertions(+), 22 deletions(-)

diff --git a/misc/factor.el b/misc/factor.el
index 99b271ad4f..998261e4e6 100644
--- a/misc/factor.el
+++ b/misc/factor.el
@@ -476,7 +476,7 @@ buffer."
   (setq factor-indent-width (factor--guess-indent-width))
   (setq indent-tabs-mode nil)
   ;; ElDoc
-  (set (make-local-variable 'eldoc-documentation-function) 'factor--see-current-word)
+  (set (make-local-variable 'eldoc-documentation-function) 'factor--eldoc)
 
   (run-hooks 'factor-mode-hook))
 
@@ -503,11 +503,12 @@ buffer."
   (with-current-buffer factor--listener-buffer
     (factor-listener-mode)))
 
-(defun factor--listener-process ()
+(defun factor--listener-process (&optional start)
   (or (and (buffer-live-p factor--listener-buffer)
            (get-buffer-process factor--listener-buffer))
-      (progn (factor--listener-start-process)
-             (factor--listener-process))))
+      (when start
+        (factor--listener-start-process)
+        (factor--listener-process t))))
 
 ;;;###autoload
 (defalias 'switch-to-factor 'run-factor)
@@ -515,7 +516,7 @@ buffer."
 (defun run-factor (&optional arg)
   "Show the factor-listener buffer, starting the process if needed."
   (interactive)
-  (let ((buf (process-buffer (factor--listener-process)))
+  (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)
@@ -538,15 +539,16 @@ buffer."
 ;;; Factor listener interaction:
 
 (defun factor--listener-send-cmd (cmd)
-  (let* ((out (get-buffer-create "*factor messages*"))
-         (beg (with-current-buffer out (goto-char (point-max))))
-         (proc (factor--listener-process)))
-    (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))))
+  (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
@@ -581,15 +583,13 @@ buffer."
 
 ;;;;; Synchronous interaction:
 
-(defun factor--listener-sync-cmds (cmds &optional vocab)
+(defsubst factor--listener-vocab-cmds (cmds &optional vocab)
   (factor--with-vocab vocab
-    (mapcar #'(lambda (c)
-                (comint-redirect-results-list-from-process
-                 (factor--listener-process) c ".+" 0))
-            cmds)))
+    (mapcar #'factor--listener-send-cmd cmds)))
 
-(defsubst factor--listener-sync-cmd (cmd &optional vocab)
-  (car (factor--listener-sync-cmds (list cmd) vocab)))
+(defsubst factor--listener-vocab-cmd (cmd &optional vocab)
+  (factor--with-vocab vocab
+    (factor--listener-send-cmd cmd)))
 
 ;;;;; Interface: see
 
@@ -618,11 +618,15 @@ buffer."
   (let ((word (or word (factor--symbol-at-point))))
     (when word
       (let ((answer (factor--listener-send-cmd (format "\\ %s see" word))))
-        (factor--see-ans-to-string answer)))))
+        (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)
@@ -742,6 +746,8 @@ buffer."
 (defvar factor--help-history nil)
 
 (defun factor--listener-show-help (&optional see)
+  (unless (factor--listener-process)
+    (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) "")))

From 5402162df517499097194b08e063dde0eaf33b8d Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 27 Nov 2008 21:07:50 -0600
Subject: [PATCH 04/24] Add mnswap macro

---
 basis/generalizations/generalizations-tests.factor | 4 ++++
 basis/generalizations/generalizations.factor       | 3 +++
 2 files changed, 7 insertions(+)

diff --git a/basis/generalizations/generalizations-tests.factor b/basis/generalizations/generalizations-tests.factor
index 1ebe528f35..1291012700 100644
--- a/basis/generalizations/generalizations-tests.factor
+++ b/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
diff --git a/basis/generalizations/generalizations.factor b/basis/generalizations/generalizations.factor
index 490fa77204..b8d8db019c 100644
--- a/basis/generalizations/generalizations.factor
+++ b/basis/generalizations/generalizations.factor
@@ -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 ;

From 0c19abc0c1e4ea0f3471fe90f01384e2fe9e735c Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 27 Nov 2008 21:53:53 -0600
Subject: [PATCH 05/24] Better docs for generalizations

---
 .../generalizations-docs.factor               | 160 +++++++++++++++---
 basis/generalizations/generalizations.factor  |   8 +-
 2 files changed, 139 insertions(+), 29 deletions(-)

diff --git a/basis/generalizations/generalizations-docs.factor b/basis/generalizations/generalizations-docs.factor
index ba53e6c591..2380f5614d 100644
--- a/basis/generalizations/generalizations-docs.factor
+++ b/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" }
-}
-{ $see-also dup over pick } ;
+  "Some core words expressed in terms of " { $link npick } ":"
+    { $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" }
-}
-{ $see-also dup 2dup 3dup } ;
+  "Some core words expressed in terms of " { $link ndup } ":"
+    { $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" }
-}
-{ $see-also nip 2nip } ;
+  "Some core words expressed in terms of " { $link nnip } ":"
+    { $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" }
-}
-{ $see-also drop 2drop 3drop } ;
+  "Some core words expressed in terms of " { $link ndrop } ":"
+    { $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" }
-}
-{ $see-also rot -nrot } ;
+  "Some core words expressed in terms of " { $link 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" }
-}
-{ $see-also rot nrot } ;
+  "Some core words expressed in terms of " { $link -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" }
-}
-{ $see-also rot nrot } ;
+  "The " { $link spin } " word is equivalent to " { $snippet "3 nrev" } "."
+} ;
 
 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" }
-}
-{ $see-also dip 2dip } ;
+  "Some core words expressed in terms of " { $link ndip } ":"
+    { $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" }
-}
-{ $see-also slip nkeep } ;
+  "Some core words expressed in terms of " { $link nslip } ":"
+    { $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" }
-}
-{ $see-also keep nslip } ;
+  "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."
+} 
+{ $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 napply } ;
+{ $subsection nwith } ;
 
 ABOUT: "generalizations"
diff --git a/basis/generalizations/generalizations.factor b/basis/generalizations/generalizations.factor
index b8d8db019c..3c24d20c8a 100644
--- a/basis/generalizations/generalizations.factor
+++ b/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 -- )

From a3231c5a4e19038ac62a4c5840b2c5a48df91d9a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 27 Nov 2008 21:55:20 -0600
Subject: [PATCH 06/24] Refactor fry a bit, to add extension points for locals

---
 basis/fry/fry-docs.factor |  7 -------
 basis/fry/fry.factor      | 27 ++++++++++++++-------------
 2 files changed, 14 insertions(+), 20 deletions(-)

diff --git a/basis/fry/fry-docs.factor b/basis/fry/fry-docs.factor
index b5d1b8d8d2..a982ecdd7d 100644
--- a/basis/fry/fry-docs.factor
+++ b/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:"
diff --git a/basis/fry/fry.factor b/basis/fry/fry.factor
index ac036f58ad..f84ad233cd 100644
--- a/basis/fry/fry.factor
+++ b/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' )
-    [
-        [
-            dup callable? [
-                [ count-inputs \ _ <repetition> % ] [ fry % ] bi
-            ] [ , ] if
-        ] each
-    ] [ ] make shallow-fry ;
+: fry ( quot -- quot' ) shallow-fry [ncurry] swap prefix ;
+
+M: callable deep-fry
+    [ count-inputs \ _ <repetition> % ] [ fry % ] bi ;
+
+M: object deep-fry , ;
 
 : '[ \ ] parse-until fry over push-all ; parsing

From a729e72b7e05a7debeee8934c71cf96b5f031600 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 27 Nov 2008 21:55:46 -0600
Subject: [PATCH 07/24] 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  |  49 ++++++++++++--
 basis/locals/locals-tests.factor |  61 +++++++++++++----
 basis/locals/locals.factor       | 110 +++++++++++++++++++------------
 3 files changed, 163 insertions(+), 57 deletions(-)

diff --git a/basis/locals/locals-docs.factor b/basis/locals/locals-docs.factor
index 18488ed1dd..89314aadc5 100644
--- a/basis/locals/locals-docs.factor
+++ b/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:"
-{ $subsection >r/r>-in-lambda-error }
-"Another limitation concerns combinators implemented as macros. Locals can only be used with such combinators if the input array immediately precedes the combinator call. For example, the following will work:"
+"There are two main limitations of the current locals implementation, and both concern macros."
+{ $heading "Macro expansions with free variables" }
+"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." ;
 
diff --git a/basis/locals/locals-tests.factor b/basis/locals/locals-tests.factor
index 8796721b1b..f13c1d57fa 100644
--- a/basis/locals/locals-tests.factor
+++ b/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 -- ? )
-!     [wlet | is-integer? [ a integer? ]
-!             is-even? [ a even? ]
-!             >10? [ a 10 > ] |
-!         { [ is-integer? ] [ is-even? ] [ >10? ] } &&
-!     ] ;
+[ "USE: locals [| | { [let | a [ 0 ] | a ] } ]" eval ] must-fail
 
-! [ 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
\ No newline at end of file
+[ "USE: locals [| | { [wlet | a [ 0 ] | a ] } ]" eval ] must-fail
+
+[ "USE: locals [| | { [let* | a [ 0 ] | a ] } ]" eval ] must-fail
+
+[ "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
\ No newline at end of file
diff --git a/basis/locals/locals.factor b/basis/locals/locals.factor
index df713a50e7..ccc13acf91 100644
--- a/basis/locals/locals.factor
+++ b/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 )
-    >r "local-reader" word-prop r>
+GENERIC# localize 1 ( obj args -- quot )
+
+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 )
-    {
-        { [ 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 ;
+M: object localize drop 1quotation ;
 
 UNION: special local quote local-word local-reader local-writer ;
 
 : load-locals-quot ( args -- quot )
-    [
-        [ ]
-    ] [
+    [ [ ] ] [
         dup [ local-reader? ] contains? [
-            <reversed> [
-                local-reader? [ 1array >r ] [ >r ] ?
-            ] map concat
-        ] [
-            length [ load-locals ] curry >quotation
-        ] if
+            dup [ local-reader? [ 1array ] [ ] ? ] map spread>quot
+        ] [ [ ] ] if swap length [ load-locals ] curry append
     ] 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 )
-    <local-word> dup dup name>> set ;
+: make-local-word ( name def -- word )
+    [ <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 , ;

From 02b8dcf9f3ee6cbe87d5783e316744bc16e86779 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 27 Nov 2008 21:57:16 -0600
Subject: [PATCH 08/24] Stack checker now knows about wlet words

---
 basis/stack-checker/known-words/known-words.factor | 4 ++++
 1 file changed, 4 insertions(+)

diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor
index 6585698b23..09fce257bb 100644
--- a/basis/stack-checker/known-words/known-words.factor
+++ b/basis/stack-checker/known-words/known-words.factor
@@ -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 ;

From 6dfce7d4e790ce3859f86308e1a7097f11ce206c Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 27 Nov 2008 22:30:29 -0600
Subject: [PATCH 09/24] load-locals is a primitive now, change semantics of
 get-locals to bum out 2 instructions from the sub-primitive

---
 basis/cpu/ppc/bootstrap.factor                |  4 +--
 basis/cpu/x86/bootstrap.factor                |  4 +--
 basis/locals/backend/backend-tests.factor     | 31 ++-----------------
 basis/locals/backend/backend.factor           |  5 +--
 basis/locals/locals.factor                    | 14 ++++-----
 .../known-words/known-words.factor            |  6 ++--
 core/bootstrap/primitives.factor              |  1 +
 vm/primitives.c                               |  1 +
 vm/run.c                                      |  8 +++++
 vm/run.h                                      |  1 +
 vm/types.c                                    | 10 ++----
 11 files changed, 28 insertions(+), 57 deletions(-)

diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor
index 047d27c5f4..6b1a1014ee 100644
--- a/basis/cpu/ppc/bootstrap.factor
+++ b/basis/cpu/ppc/bootstrap.factor
@@ -406,9 +406,7 @@ big-endian on
 [
     3 ds-reg 0 LWZ
     3 3 1 SRAWI
-    4 4 LI
-    4 3 4 SUBF
-    rs-reg 3 4 LWZX
+    rs-reg 3 3 LWZX
     3 ds-reg 0 STW
 ] f f f \ get-local define-sub-primitive
 
diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor
index d5fc64de00..3272015848 100644
--- a/basis/cpu/x86/bootstrap.factor
+++ b/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
-    arg1 arg0 SUB                              ! turn it into a stack offset
-    arg0 rs-reg arg1 [+] MOV                   ! load local value
+    arg0 rs-reg arg0 [+] MOV                   ! load local value
     ds-reg [] arg0 MOV                         ! push to stack
 ] f f f \ get-local define-sub-primitive
 
diff --git a/basis/locals/backend/backend-tests.factor b/basis/locals/backend/backend-tests.factor
index 9352714509..ee714f7ef7 100644
--- a/basis/locals/backend/backend-tests.factor
+++ b/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
-
-[ 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 ( -- x ) 3 1 load-locals 0 get-local 1 drop-locals ;
 
 \ 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
-
-: 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
+[ 3 ] [ get-local-test-2 ] unit-test
diff --git a/basis/locals/backend/backend.factor b/basis/locals/backend/backend.factor
index 0d9ee6a64e..ece5c1d200 100644
--- a/basis/locals/backend/backend.factor
+++ b/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
diff --git a/basis/locals/locals.factor b/basis/locals/locals.factor
index ccc13acf91..d2b057953c 100644
--- a/basis/locals/locals.factor
+++ b/basis/locals/locals.factor
@@ -103,7 +103,7 @@ 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 ;
 
 GENERIC# localize 1 ( obj args -- quot )
 
@@ -139,19 +139,17 @@ UNION: special local quote local-word local-reader local-writer ;
 : point-free-end ( quot args -- newquot )
     over peek special?
     [ 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 ]
-    [ point-free-end ]
-    2tri 3append >quotation ;
+    [ reverse point-free-body ]
+    [ reverse point-free-end ]
+    2tri [ ] 3append-as ;
 
 : point-free ( quot args -- newquot )
-    over empty?
-    [ nip length \ drop <repetition> >quotation ]
-    [ (point-free) ] if ;
+    over empty? [ nip length '[ _ ndrop ] ] [ (point-free) ] if ;
 
 UNION: lexical local local-reader local-writer local-word ;
 
diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor
index 09fce257bb..2b5cf8eb52 100644
--- a/basis/stack-checker/known-words/known-words.factor
+++ b/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
-    [ [ f f ] dip ] [ reverse swap zip ] 2bi #shuffle, ;
+    consume-d dup copy-values dup output-r
+    [ [ 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 ] |
diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor
index 4624963aa6..84c79a340a 100644
--- a/core/bootstrap/primitives.factor
+++ b/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
 
diff --git a/vm/primitives.c b/vm/primitives.c
index a34d695bb8..135d5478ea 100755
--- a/vm/primitives.c
+++ b/vm/primitives.c
@@ -141,4 +141,5 @@ void *primitives[] = {
 	primitive_unimplemented,
 	primitive_gc_reset,
 	primitive_jit_compile,
+	primitive_load_locals,
 };
diff --git a/vm/run.c b/vm/run.c
index a28a956f29..c7002eb0ec 100755
--- a/vm/run.c
+++ b/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;
+}
diff --git a/vm/run.h b/vm/run.h
index f156ba3f03..06b6317015 100755
--- a/vm/run.h
+++ b/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;
diff --git a/vm/types.c b/vm/types.c
index f1588465a4..a1175b320a 100755
--- a/vm/types.c
+++ b/vm/types.c
@@ -331,15 +331,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);
-
-	F_FIXNUM i;
-	for(i = size - 1; i >= 0; i--)
-		put(AREF(tuple,i),dpop());
-
+	memcpy(tuple + 1,(CELL *)(ds - CELLS * (size - 1)),CELLS * size);
+	ds -= CELLS * size;
 	dpush(tag_tuple(tuple));
 }
 

From a3398f22964a9fa55c9a0509f3c08dd2a4f59f8b Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 27 Nov 2008 23:28:32 -0600
Subject: [PATCH 10/24] Fix editors.emacs docs

---
 basis/editors/emacs/emacs-docs.factor | 14 ++++++--------
 1 file changed, 6 insertions(+), 8 deletions(-)

diff --git a/basis/editors/emacs/emacs-docs.factor b/basis/editors/emacs/emacs-docs.factor
index 2ef1ced5ec..f55068e143 100644
--- a/basis/editors/emacs/emacs-docs.factor
+++ b/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"
-
-"Put this in your .emacs file:"
-
+ARTICLE: "editors.emacs" "Integration with Emacs"
+"Put this in your " { $snippet ".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 .emacs file:"
-
+"If you would like a new window to open when you ask Factor to edit an object, put this in your " { $snippet ".emacs" } " file:"
 { $code "(setq server-window 'switch-to-buffer-other-frame)" }
-
 { $see-also "editor" } ;
+
+ABOUT: "editors.emacs"
\ No newline at end of file

From cfbd3c679b9bdbf67e9ae09ed9e86a074b13e84f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 27 Nov 2008 23:28:38 -0600
Subject: [PATCH 11/24] Remove unused function from VM

---
 vm/types.c | 12 ------------
 vm/types.h |  1 -
 2 files changed, 13 deletions(-)

diff --git a/vm/types.c b/vm/types.c
index a1175b320a..d6e78013cb 100755
--- a/vm/types.c
+++ b/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);
diff --git a/vm/types.h b/vm/types.h
index ebbb8a2642..47747547db 100755
--- a/vm/types.h
+++ b/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);

From fff10d8082dd0774dfbb7f98ceed7408cebde17d Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 27 Nov 2008 23:32:17 -0600
Subject: [PATCH 12/24] Fix for gcc 4.2

---
 vm/Config.macosx.x86.64 | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/vm/Config.macosx.x86.64 b/vm/Config.macosx.x86.64
index e2063c4a75..7ef5f89559 100644
--- a/vm/Config.macosx.x86.64
+++ b/vm/Config.macosx.x86.64
@@ -1,3 +1,3 @@
 include vm/Config.macosx
 include vm/Config.x86.64
-CFLAGS += -arch x86_64
+CFLAGS += -m64

From 268f3e48386abafb980b695c2ea1320daf1d7162 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 27 Nov 2008 23:37:16 -0600
Subject: [PATCH 13/24] Make setlocale() failure non-fatal since it appears to
 be broken on the eeepc

---
 basis/x11/xlib/xlib.factor | 8 ++++----
 1 file changed, 4 insertions(+), 4 deletions(-)

diff --git a/basis/x11/xlib/xlib.factor b/basis/x11/xlib/xlib.factor
index eecf427c9e..555eb573fc 100644
--- a/basis/x11/xlib/xlib.factor
+++ b/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
-   XSupportsLocale [ "XSupportsLocale() failed" throw ] unless ;
+   LC_ALL "" setlocale [ "setlocale() failed" print flush ] 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 ;

From cdf3b48986d60352a072409633c22a0fb862e252 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 28 Nov 2008 00:02:02 -0600
Subject: [PATCH 14/24] Refactoring usages of >r/r> to dip in UI

---
 basis/ui/clipboards/clipboards.factor         |  2 +-
 basis/ui/cocoa/cocoa.factor                   |  4 +--
 basis/ui/cocoa/tools/tools.factor             |  2 +-
 basis/ui/cocoa/views/views.factor             | 25 +++++++++--------
 basis/ui/commands/commands.factor             |  4 +--
 basis/ui/freetype/freetype.factor             |  6 ++--
 basis/ui/gadgets/books/books.factor           |  5 ++--
 basis/ui/gadgets/gadgets.factor               | 20 ++++++-------
 basis/ui/gadgets/grid-lines/grid-lines.factor | 11 ++++----
 basis/ui/gadgets/grids/grids.factor           | 17 +++++------
 basis/ui/gadgets/labelled/labelled.factor     |  6 ++--
 basis/ui/gadgets/labels/labels.factor         |  2 +-
 basis/ui/gadgets/lists/lists.factor           |  8 +++---
 basis/ui/gadgets/menus/menus.factor           |  4 +--
 basis/ui/gadgets/packs/packs.factor           | 11 ++++----
 basis/ui/gadgets/panes/panes.factor           | 24 ++++++++--------
 .../presentations/presentations.factor        |  2 +-
 basis/ui/gadgets/sliders/sliders.factor       | 19 +++++++------
 basis/ui/gadgets/status-bar/status-bar.factor |  2 +-
 basis/ui/gadgets/worlds/worlds.factor         |  2 +-
 basis/ui/operations/operations.factor         |  2 +-
 basis/ui/render/render.factor                 | 10 +++----
 basis/ui/tools/deploy/deploy.factor           | 15 +++++-----
 basis/ui/tools/interactor/interactor.factor   |  6 ++--
 basis/ui/tools/listener/listener.factor       |  6 ++--
 basis/ui/tools/profiler/profiler.factor       |  8 +++---
 basis/ui/tools/search/search-tests.factor     |  2 +-
 basis/ui/tools/tools.factor                   |  4 +--
 basis/ui/tools/walker/walker.factor           |  6 ++--
 basis/ui/tools/workspace/workspace.factor     |  4 +--
 basis/ui/windows/windows.factor               | 28 ++++++++++---------
 basis/ui/x11/x11.factor                       | 27 ++++++++----------
 32 files changed, 145 insertions(+), 149 deletions(-)

diff --git a/basis/ui/clipboards/clipboards.factor b/basis/ui/clipboards/clipboards.factor
index e1b591dfb9..42c3f6ddef 100644
--- a/basis/ui/clipboards/clipboards.factor
+++ b/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 ;
 
diff --git a/basis/ui/cocoa/cocoa.factor b/basis/ui/cocoa/cocoa.factor
index 9ff3a59f71..5d3b8db19d 100644
--- a/basis/ui/cocoa/cocoa.factor
+++ b/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 ;
 
diff --git a/basis/ui/cocoa/tools/tools.factor b/basis/ui/cocoa/tools/tools.factor
index 876e9e5df1..a8ade05a86 100644
--- a/basis/ui/cocoa/tools/tools.factor
+++ b/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" }
diff --git a/basis/ui/cocoa/views/views.factor b/basis/ui/cocoa/views/views.factor
index 82a31ad0d9..1e35fcf4b2 100644
--- a/basis/ui/cocoa/views/views.factor
+++ b/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 ;
+    [
+        dup -> deltaX sgn neg over -> deltaY sgn neg 2array -rot
+        mouse-location
+    ] [ 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:"
-    "NSViewFrameDidChangeNotification" <NSString>
-    r> add-observer ;
+    [
+        "updateFactorGadgetSize:"
+        "NSViewFrameDidChangeNotification" <NSString>
+    ] 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
diff --git a/basis/ui/commands/commands.factor b/basis/ui/commands/commands.factor
index b45e2e4004..5f8c3381b7 100644
--- a/basis/ui/commands/commands.factor
+++ b/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 ;
 
diff --git a/basis/ui/freetype/freetype.factor b/basis/ui/freetype/freetype.factor
index d2dfe56ed4..41d000af26 100644
--- a/basis/ui/freetype/freetype.factor
+++ b/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+ ;
diff --git a/basis/ui/gadgets/books/books.factor b/basis/ui/gadgets/books/books.factor
index da0ff35728..4ef90d87b9 100644
--- a/basis/ui/gadgets/books/books.factor
+++ b/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 ;
diff --git a/basis/ui/gadgets/gadgets.factor b/basis/ui/gadgets/gadgets.factor
index 7d33ec21fd..a1386eef53 100644
--- a/basis/ui/gadgets/gadgets.factor
+++ b/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
-        >r parent>> r> relative-loc
-        r> v+
+        over rect-loc [ [ parent>> ] dip relative-loc ] dip 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>> '[ [ _ ] 2dip 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)
-        >r tuck v+ r> vmin >r v+ r>
+        [ rect-extent ] dip (screen-rect)
+        [ tuck v+ ] dip vmin [ v+ ] dip
     ] [
         rect-extent
     ] if* ;
diff --git a/basis/ui/gadgets/grid-lines/grid-lines.factor b/basis/ui/gadgets/grid-lines/grid-lines.factor
index feca8f7c63..8d79c9e07c 100755
--- a/basis/ui/gadgets/grid-lines/grid-lines.factor
+++ b/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
-math.vectors ui.gadgets ui.gadgets.grids ui.render math.geometry.rect ;
+USING: kernel accessors math namespaces opengl opengl.gl
+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
-    [ swap grid-line-from/to gl-line ] curry each ;
+    [ '[ _ v- ] map ] keep
+    '[ _ swap grid-line-from/to gl-line ] each ;
 
 M: grid-lines draw-boundary
     color>> gl-color [
diff --git a/basis/ui/gadgets/grids/grids.factor b/basis/ui/gadgets/grids/grids.factor
index 3e91e0ceb6..386457551f 100644
--- a/basis/ui/gadgets/grids/grids.factor
+++ b/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>
-    gap-sum >r gap-sum r> (pair-up) ;
+    dup gap>> swap compute-grid [ over ] dip
+    [ gap-sum ] 2bi@ (pair-up) ;
 
 : do-grid ( dims grid quot -- )
-    -rot grid>>
-    [ [ pick call ] 2each ] 2each
-    drop ; inline
+    [ grid>> ] dip '[ _ 2each ] 2each ; 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
-    >r over r> grid-positions >r grid-positions r>
-    pair-up r> [ (>>loc) ] do-grid ;
+    pick [ [ over ] dip [ grid-positions ] 2bi@ pair-up ] dip
+    [ (>>loc) ] do-grid ;
 
 : resize-grid ( grid horiz vert -- )
     pick fill?>> [
diff --git a/basis/ui/gadgets/labelled/labelled.factor b/basis/ui/gadgets/labelled/labelled.factor
index 79a485b711..e4343e6280 100644
--- a/basis/ui/gadgets/labelled/labelled.factor
+++ b/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 )
diff --git a/basis/ui/gadgets/labels/labels.factor b/basis/ui/gadgets/labels/labels.factor
index 6e56b48c8b..5706f47639 100644
--- a/basis/ui/gadgets/labels/labels.factor
+++ b/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
diff --git a/basis/ui/gadgets/lists/lists.factor b/basis/ui/gadgets/lists/lists.factor
index ec46638c91..0113e1959d 100644
--- a/basis/ui/gadgets/lists/lists.factor
+++ b/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+
-    over visible-dim r> v* v+ swap select-at ;
+    [ dup selected-rect rect-bounds 2 v/n v+ over visible-dim ] dip
+    v* v+ swap select-at ;
 
 : list-page-up ( list -- ) { 0 -1 } list-page ;
 
diff --git a/basis/ui/gadgets/menus/menus.factor b/basis/ui/gadgets/menus/menus.factor
index e973dd07dc..cbcfdb14d8 100644
--- a/basis/ui/gadgets/menus/menus.factor
+++ b/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 ;
diff --git a/basis/ui/gadgets/packs/packs.factor b/basis/ui/gadgets/packs/packs.factor
index 32a60374eb..5965e8b568 100644
--- a/basis/ui/gadgets/packs/packs.factor
+++ b/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
-    >r packed-locs r> [ (>>loc) ] 2each ;
+    [ dupd packed-dims ] dip
+    [ [ (>>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*
diff --git a/basis/ui/gadgets/panes/panes.factor b/basis/ui/gadgets/panes/panes.factor
index c612cbef0a..9a30cee777 100644
--- a/basis/ui/gadgets/panes/panes.factor
+++ b/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 >r with-output-stream* r> ?nl ; inline
+    over pane-clear [ <pane-stream> ] dip
+    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 ;
+    [
+        swap [ [ pane>> smash-pane ] map ] map
+        styled-grid
+    ] 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 ;
 
diff --git a/basis/ui/gadgets/presentations/presentations.factor b/basis/ui/gadgets/presentations/presentations.factor
index c5f078e82e..e39069ed7b 100644
--- a/basis/ui/gadgets/presentations/presentations.factor
+++ b/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
diff --git a/basis/ui/gadgets/sliders/sliders.factor b/basis/ui/gadgets/sliders/sliders.factor
index f42d65f738..968972a869 100644
--- a/basis/ui/gadgets/sliders/sliders.factor
+++ b/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
-    >r dup rect-dim r>
-    rot orientation>> set-axis [ ceiling ] map
-    r> (>>dim) ;
+    dup dup thumb-dim (layout-thumb)
+    [
+        [ dup rect-dim ] dip
+        rot orientation>> set-axis [ ceiling ] map
+    ] dip (>>dim) ;
 
 : layout-thumb ( slider -- )
     dup layout-thumb-loc layout-thumb-dim ;
@@ -121,13 +122,13 @@ M: elevator layout*
 : slide-by-line ( amount slider -- ) [ line>> * ] keep slide-by ;
 
 : <slide-button> ( vector polygon amount -- button )
-    >r gray swap <polygon-gadget> r>
-    [ swap find-slider slide-by-line ] curry <repeat-button>
+    [ gray swap <polygon-gadget> ] dip
+    '[ _ swap find-slider slide-by-line ] <repeat-button>
     swap >>orientation ;
 
 : elevator, ( gadget orientation -- gadget )
     tuck <elevator> >>elevator
-    swap <thumb>    >>thumb
+    swap <thumb> >>thumb
     dup elevator>> over thumb>> add-gadget
     @center grid-add ;
 
diff --git a/basis/ui/gadgets/status-bar/status-bar.factor b/basis/ui/gadgets/status-bar/status-bar.factor
index 431804f4ca..32abcd5466 100644
--- a/basis/ui/gadgets/status-bar/status-bar.factor
+++ b/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 ;
diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor
index 904a2a5bac..98c3258911 100644
--- a/basis/ui/gadgets/worlds/worlds.factor
+++ b/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 ;
diff --git a/basis/ui/operations/operations.factor b/basis/ui/operations/operations.factor
index 8e83f69edb..660ae1f43d 100644
--- a/basis/ui/operations/operations.factor
+++ b/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 ;
diff --git a/basis/ui/render/render.factor b/basis/ui/render/render.factor
index 36c0d5f256..55b8a82ac1 100755
--- a/basis/ui/render/render.factor
+++ b/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
-    over change-clip do-clip call
-    r> clip set do-clip ; inline
+    clip get [ over change-clip do-clip call ] dip 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
diff --git a/basis/ui/tools/deploy/deploy.factor b/basis/ui/tools/deploy/deploy.factor
index f310f72780..5a99d1174b 100644
--- a/basis/ui/tools/deploy/deploy.factor
+++ b/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
-       models models.mapping sequences ui.gadgets.buttons
-       ui.gadgets.packs ui.gadgets.labels tools.deploy.config
-       namespaces ui.gadgets.editors ui.gadgets.borders ui.gestures
-       ui.commands assocs ui.gadgets.tracks ui ui.tools.listener
-       tools.deploy vocabs ui.tools.workspace system accessors ;
-
+USING: ui.gadgets colors kernel ui.render namespaces models
+models.mapping sequences ui.gadgets.buttons ui.gadgets.packs
+ui.gadgets.labels tools.deploy.config namespaces
+ui.gadgets.editors ui.gadgets.borders ui.gestures ui.commands
+assocs ui.gadgets.tracks ui ui.tools.listener tools.deploy
+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 ( -- )
diff --git a/basis/ui/tools/interactor/interactor.factor b/basis/ui/tools/interactor/interactor.factor
index 5739a469ea..0676619b07 100644
--- a/basis/ui/tools/interactor/interactor.factor
+++ b/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
diff --git a/basis/ui/tools/listener/listener.factor b/basis/ui/tools/listener/listener.factor
index de0ce43f20..7ffbfd2738 100644
--- a/basis/ui/tools/listener/listener.factor
+++ b/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 ;
 
diff --git a/basis/ui/tools/profiler/profiler.factor b/basis/ui/tools/profiler/profiler.factor
index 05d1ccdb82..7280efe885 100644
--- a/basis/ui/tools/profiler/profiler.factor
+++ b/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. ] ;
diff --git a/basis/ui/tools/search/search-tests.factor b/basis/ui/tools/search/search-tests.factor
index c8c7c6c219..39a6442308 100644
--- a/basis/ui/tools/search/search-tests.factor
+++ b/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>
diff --git a/basis/ui/tools/tools.factor b/basis/ui/tools/tools.factor
index 3310a3e0a5..9927f9e5ae 100644
--- a/basis/ui/tools/tools.factor
+++ b/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 }
diff --git a/basis/ui/tools/walker/walker.factor b/basis/ui/tools/walker/walker.factor
index 9c825d4920..e6643698c7 100644
--- a/basis/ui/tools/walker/walker.factor
+++ b/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 ;
diff --git a/basis/ui/tools/workspace/workspace.factor b/basis/ui/tools/workspace/workspace.factor
index 6536cb8c7d..3b689eee39 100644
--- a/basis/ui/tools/workspace/workspace.factor
+++ b/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
 
diff --git a/basis/ui/windows/windows.factor b/basis/ui/windows/windows.factor
index 99a7d5fe0f..3805cf7e1f 100755
--- a/basis/ui/windows/windows.factor
+++ b/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 ;
+    [
+        over set-capture
+        dup message>button drop nc-buttons get delete
+    ] 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 -- )
-    >r nip r>
-    pick mouse-absolute>relative >r mouse-wheel r> rot window send-wheel ;
+:: handle-wm-mousewheel ( hWnd uMsg wParam lParam -- )
+    lParam mouse-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>
-    >r >r >r ex-style r> r>
+    [ class-name-ptr get-global f ] dip
+    [
+        [ 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 ;
 
diff --git a/basis/ui/x11/x11.factor b/basis/ui/x11/x11.factor
index de57c2dc72..b9889c75d4 100644
--- a/basis/ui/x11/x11.factor
+++ b/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>>
-    r> atom>> convert-selection ;
+    [ find-world handle>> window>> ] dip atom>> convert-selection ;
 
 : init-clipboard ( -- )
     XA_PRIMARY <x-clipboard> selection set-global
@@ -219,14 +218,13 @@ 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
-    r> utf8 encode dup length XChangeProperty drop ;
+    [ XA_NET_WM_NAME XA_UTF8_STRING 8 PropModeReplace ] dip
+    utf8 encode dup length XChangeProperty drop ;
 
 M: x11-ui-backend set-title ( string world -- )
     handle>> window>> swap dpy get -rot
     3dup set-title-old set-title-new ;
-    
+
 M: x11-ui-backend set-fullscreen* ( ? world -- )
     handle>> window>> "XClientMessageEvent" <c-object>
     tuck set-XClientMessageEvent-window
@@ -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

From b3ad902208bfcb212d4bea82f3028b3b645e943d Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 28 Nov 2008 00:48:20 -0600
Subject: [PATCH 15/24] Fix cosmetic issue

---
 vm/debug.c | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/vm/debug.c b/vm/debug.c
index db8e60c781..909cc8f710 100755
--- a/vm/debug.c
+++ b/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;
 	}
 }

From c8f227ccf733fb2e99eb85d6eb02f9032f0f5e6d Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 28 Nov 2008 00:56:54 -0600
Subject: [PATCH 16/24] Tweak standard-next-method-quot to produce smaller
 quotations

---
 core/generic/standard/standard.factor | 15 ++++++---------
 1 file changed, 6 insertions(+), 9 deletions(-)

diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor
index 4f26c40e78..d7b44d09f8 100644
--- a/core/generic/standard/standard.factor
+++ b/core/generic/standard/standard.factor
@@ -83,15 +83,12 @@ ERROR: no-next-method class generic ;
 
 : single-next-method-quot ( class generic -- quot )
     [
-        [ drop "predicate" word-prop % ]
-        [
-            2dup next-method
-            [ 2nip 1quotation ]
-            [ [ no-next-method ] 2curry [ ] like ] if* ,
-        ]
-        [ [ inconsistent-next-method ] 2curry , ]
-        2tri
-        \ if ,
+        2dup next-method [
+            pick "predicate" word-prop %
+            1quotation ,
+            [ inconsistent-next-method ] 2curry ,
+            \ if ,
+        ] [ [ no-next-method ] 2curry % ] if*
     ] [ ] make ;
 
 : single-effective-method ( obj word -- method )

From 817510cdb91dabdb94b87cf2c7085039739fbbb7 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 28 Nov 2008 01:08:16 -0600
Subject: [PATCH 17/24] Another attempt at size reduction

---
 core/generic/generic-docs.factor           | 16 +++++++++++
 core/generic/generic.factor                |  4 ++-
 core/generic/standard/standard-docs.factor | 16 -----------
 core/generic/standard/standard.factor      | 31 +++++++++++++---------
 core/sequences/.#sequences.factor          |  1 +
 5 files changed, 39 insertions(+), 29 deletions(-)
 create mode 120000 core/sequences/.#sequences.factor

diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor
index 35029a3fb0..429e272647 100644
--- a/core/generic/generic-docs.factor
+++ b/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."
+} ;
diff --git a/core/generic/generic.factor b/core/generic/generic.factor
index 8d7ed4cb60..0cd5a35623 100644
--- a/core/generic/generic.factor
+++ b/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 ;
 
diff --git a/core/generic/standard/standard-docs.factor b/core/generic/standard/standard-docs.factor
index 15913b46be..ec2e78c48d 100644
--- a/core/generic/standard/standard-docs.factor
+++ b/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
diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor
index d7b44d09f8..300bd44fb4 100644
--- a/core/generic/standard/standard.factor
+++ b/core/generic/standard/standard.factor
@@ -79,17 +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 )
-    [
-        2dup next-method [
+: single-next-method-quot ( class generic -- quot/f )
+    2dup next-method dup [
+        [
             pick "predicate" word-prop %
             1quotation ,
             [ inconsistent-next-method ] 2curry ,
             \ if ,
-        ] [ [ no-next-method ] 2curry % ] if*
-    ] [ ] make ;
+        ] [ ] make
+    ] [ 3drop f ] if ;
 
 : single-effective-method ( obj word -- method )
     [ [ order [ instance? ] with find-last nip ] keep method ]
@@ -127,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
@@ -142,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 [ ] ;
@@ -156,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 ;
 
diff --git a/core/sequences/.#sequences.factor b/core/sequences/.#sequences.factor
new file mode 120000
index 0000000000..fef0fea598
--- /dev/null
+++ b/core/sequences/.#sequences.factor
@@ -0,0 +1 @@
+slava@slava-pestovs-macbook-pro.local.14895
\ No newline at end of file

From 94ec0c9d1f9561fdaaba6a79c88964db604bc0d1 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 28 Nov 2008 01:08:33 -0600
Subject: [PATCH 18/24] Oops

---
 core/sequences/.#sequences.factor | 1 -
 1 file changed, 1 deletion(-)
 delete mode 120000 core/sequences/.#sequences.factor

diff --git a/core/sequences/.#sequences.factor b/core/sequences/.#sequences.factor
deleted file mode 120000
index fef0fea598..0000000000
--- a/core/sequences/.#sequences.factor
+++ /dev/null
@@ -1 +0,0 @@
-slava@slava-pestovs-macbook-pro.local.14895
\ No newline at end of file

From 92cc7600703131919f95cdf14907454eebada695 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 28 Nov 2008 01:11:03 -0600
Subject: [PATCH 19/24] Fixes

---
 basis/stack-checker/transforms/transforms.factor | 5 ++++-
 core/generic/standard/standard-tests.factor      | 2 +-
 2 files changed, 5 insertions(+), 2 deletions(-)

diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor
index 6e11eb1189..7eec29f94b 100644
--- a/basis/stack-checker/transforms/transforms.factor
+++ b/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
diff --git a/core/generic/standard/standard-tests.factor b/core/generic/standard/standard-tests.factor
index f6635276b3..7dadc807fd 100644
--- a/core/generic/standard/standard-tests.factor
+++ b/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 ;

From 9c40cb4a05ba3730083964deda74cde1002f41c4 Mon Sep 17 00:00:00 2001
From: sheeple <sheeple@oberon.local>
Date: Fri, 28 Nov 2008 01:14:33 -0600
Subject: [PATCH 20/24] Tree-shaker now merges wrappers; saves a few kb

---
 basis/tools/deploy/shaker/shaker.factor | 6 +++++-
 1 file changed, 5 insertions(+), 1 deletion(-)

diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor
index a537d37d11..00cee32ddb 100755
--- a/basis/tools/deploy/shaker/shaker.factor
+++ b/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

From 1c3e4f070a01ea8316d0886695d7760e9a7ef164 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 28 Nov 2008 02:31:21 -0600
Subject: [PATCH 21/24] I accidentally the UI

---
 basis/ui/gadgets/gadgets-tests.factor | 7 +++++++
 basis/ui/gadgets/gadgets.factor       | 2 +-
 2 files changed, 8 insertions(+), 1 deletion(-)

diff --git a/basis/ui/gadgets/gadgets-tests.factor b/basis/ui/gadgets/gadgets-tests.factor
index 01d695c281..c3a7216910 100644
--- a/basis/ui/gadgets/gadgets-tests.factor
+++ b/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
diff --git a/basis/ui/gadgets/gadgets.factor b/basis/ui/gadgets/gadgets.factor
index a1386eef53..51c8f07225 100644
--- a/basis/ui/gadgets/gadgets.factor
+++ b/basis/ui/gadgets/gadgets.factor
@@ -93,7 +93,7 @@ M: gadget children-on nip children>> ;
 : dim-sum ( seq -- dim ) { 0 0 } [ v+ ] reduce ;
 
 : orient ( gadget seq1 seq2 -- seq )
-    rot orientation>> '[ [ _ ] 2dip set-axis ] 2map ;
+    rot orientation>> '[ _ set-axis ] 2map ;
 
 : each-child ( gadget quot -- )
     [ children>> ] dip each ; inline

From 6ebe7bef7b0fe1b58e3554a561b6ae7833450ed3 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 28 Nov 2008 02:46:33 -0600
Subject: [PATCH 22/24] Maze no longer needs funny workaround

---
 extra/maze/maze.factor | 1 -
 1 file changed, 1 deletion(-)

diff --git a/extra/maze/maze.factor b/extra/maze/maze.factor
index 40e12a97c9..f56c579a3f 100644
--- a/extra/maze/maze.factor
+++ b/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

From c8a8d693824d4a77ed1c138180401676b3c5861c Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 28 Nov 2008 03:47:37 -0600
Subject: [PATCH 23/24] After merging quotations, we need to update references
 to the old versions' XTs in the code heap

---
 vm/data_gc.c | 1 +
 1 file changed, 1 insertion(+)

diff --git a/vm/data_gc.c b/vm/data_gc.c
index ac77058fea..513a7c429c 100755
--- a/vm/data_gc.c
+++ b/vm/data_gc.c
@@ -985,6 +985,7 @@ void primitive_become(void)
 	}
 
 	gc();
+	iterate_code_heap(relocate_code_block);
 }
 
 CELL find_all_words(void)

From 4c1e23b82d59e26fc22f6b115b32d8aee79c3e87 Mon Sep 17 00:00:00 2001
From: "Jose A. Ortega Ruiz" <jao@gnu.org>
Date: Fri, 28 Nov 2008 13:23:15 +0100
Subject: [PATCH 24/24] Emacs factor mode: bug fix: don't depend on cl's DO.

---
 misc/factor.el | 33 +++++++++++++++++++--------------
 1 file changed, 19 insertions(+), 14 deletions(-)

diff --git a/misc/factor.el b/misc/factor.el
index 998261e4e6..ba1c633466 100644
--- a/misc/factor.el
+++ b/misc/factor.el
@@ -596,23 +596,28 @@ buffer."
 (defconst factor--regex-error-marker "^Type :help for debugging")
 (defconst factor--regex-data-stack "^--- Data stack:")
 
-(defun factor--prune-stack (ans)
-  (do ((res '() (cons (car s) res)) (s ans (cdr s)))
-      ((or (not s)
-           (and (car res) (string-match factor--regex-stack-effect (car res)))
-           (string-match factor--regex-data-stack (car s)))
-       (and (not (string-match factor--regex-error-marker (car res)))
-            (nreverse res)))))
+(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-stack ans) " ")))
+  (let ((s (mapconcat #'identity (factor--prune-ans-strings ans) " "))
+        (font-lock-verbose nil))
     (and (> (length s) 0)
-         (let ((font-lock-verbose nil))
-           (with-temp-buffer
-             (insert s)
-             (factor-mode)
-             (font-lock-fontify-buffer)
-             (buffer-string))))))
+         (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))))