Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv7426
Modified Files:
syntax.lisp slidemacs-gui.lisp pane.lisp packages.lisp
lisp-syntax.lisp gui.lisp esa.lisp
Log Message:
Two major groups of changes, as steps towards supporting
the multi-pane paradigm: (a) changes to support non-buffer-
containing panes (a typeout pane is the first example - try
C-h b); (b) distributed commands among a plethora of little
command tables, as threatened on the mailing list.
Also: changed info-pane (again) - now includes call to
name-for-info-pane (specialised on syntax) - try a lisp file
where climacs can work out the package name; got rid of
'Toggle' names (didn't add anything); mouse-clicks now change
window and position the cursor; now command Insert Parentheses
(M-() that almost works.
Slidemacs temporarily broken...
Date: Tue Sep 13 21:24:00 2005
Author: dmurray
Index: climacs/syntax.lisp
diff -u climacs/syntax.lisp:1.57 climacs/syntax.lisp:1.58
--- climacs/syntax.lisp:1.57 Wed Aug 17 01:10:29 2005
+++ climacs/syntax.lisp Tue Sep 13 21:23:59 2005
@@ -148,6 +148,12 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
+;;; Name for info-pane
+
+(defgeneric name-for-info-pane (syntax))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
;;; Syntax completion
(defparameter *syntaxes* '())
@@ -240,6 +246,9 @@
(defmethod update-syntax-for-display (buffer (syntax basic-syntax) from to)
(declare (ignore buffer from to))
nil)
+
+(defmethod name-for-info-pane ((syntax basic-syntax))
+ (name syntax))
(defmethod syntax-line-indentation (mark tab-width (syntax basic-syntax))
(declare (ignore mark tab-width))
Index: climacs/slidemacs-gui.lisp
diff -u climacs/slidemacs-gui.lisp:1.18 climacs/slidemacs-gui.lisp:1.19
--- climacs/slidemacs-gui.lisp:1.18 Thu Sep 1 02:21:08 2005
+++ climacs/slidemacs-gui.lisp Tue Sep 13 21:23:59 2005
@@ -35,6 +35,8 @@
(defvar *current-slideset*)
(defvar *did-display-a-slide*)
+(make-command-table 'slidemacs-table)
+
(defun slidemacs-entity-string (entity)
(coerce (buffer-sequence (buffer entity)
(1+ (start-offset entity))
@@ -357,7 +359,7 @@
(- y2 y1)))))))
(define-command (com-reveal-text :name "Reveal Text In Window"
- :command-table global-command-table
+ :command-table slidemacs-table
:menu t
:provide-output-destination-keyword t)
((text 'string :prompt "text"))
@@ -366,7 +368,7 @@
(write-string text stream))))
(define-presentation-to-command-translator reveal-text-translator
- (reveal-button com-reveal-text global-command-table
+ (reveal-button com-reveal-text slidemacs-table
:gesture :select
:documentation "Reveal Text In Window"
:pointer-documentation "Reveal Text In Window")
@@ -478,7 +480,7 @@
(or (word-is lexeme "info")
(word-is lexeme "graph")))))
-(climacs-gui::define-named-command com-next-talking-point ()
+(define-command (com-next-talking-point :name t :command-table slidemacs-table) ()
(let* ((pane (climacs-gui::current-window))
(buffer (buffer pane))
(syntax (syntax buffer)))
@@ -493,7 +495,7 @@
(return (setf (offset point) (start-offset lexeme)))))
(full-redisplay pane))))))
-(climacs-gui::define-named-command com-previous-talking-point ()
+(define-command (com-previous-talking-point :name t :command-table slidemacs-table) ()
(let* ((pane (climacs-gui::current-window))
(buffer (buffer pane))
(syntax (syntax buffer)))
@@ -516,23 +518,23 @@
collect thing
else collect (if decrease-p (- thing 8) (+ thing 8)))))
-(climacs-gui::define-named-command com-decrease-presentation-font-sizes ()
+(define-command (com-decrease-presentation-font-sizes :name t :command-table slidemacs-table) ()
(adjust-font-sizes t)
(full-redisplay (climacs-gui::current-window)))
-(climacs-gui::define-named-command com-increase-presentation-font-sizes ()
+(define-command (com-increase-presentation-font-sizes :name t :command-table slidemacs-table) ()
(adjust-font-sizes nil)
(full-redisplay (climacs-gui::current-window)))
-(climacs-gui::define-named-command com-first-talking-point ()
+(define-command (com-first-talking-point :name t :command-table slidemacs-table) ()
(climacs-gui::com-beginning-of-buffer)
(com-next-talking-point))
-(climacs-gui::define-named-command com-last-talking-point ()
+(define-command (com-last-talking-point :name t :command-table slidemacs-table) ()
(climacs-gui::com-end-of-buffer)
(com-previous-talking-point))
-(climacs-gui::define-named-command com-flip-slidemacs-syntax ()
+(define-command (com-flip-slidemacs-syntax :name t :command-table slidemacs-table) ()
(let* ((buffer (buffer (climacs-gui::current-window)))
(syntax (syntax buffer)))
(typecase syntax
@@ -544,28 +546,28 @@
:buffer buffer))))))
(esa:set-key 'com-next-talking-point
- 'climacs-gui::global-climacs-table
+ 'slidemacs-table
'((#\= :control)))
(esa:set-key 'com-previous-talking-point
- 'climacs-gui::global-climacs-table
+ 'slidemacs-table
'((#\- :control)))
(esa:set-key 'com-increase-presentation-font-sizes
- 'climacs-gui::global-climacs-table
+ 'slidemacs-table
'((#\= :meta)))
(esa:set-key 'com-decrease-presentation-font-sizes
- 'climacs-gui::global-climacs-table
+ 'slidemacs-table
'((#\- :meta)))
(esa:set-key 'com-last-talking-point
- 'climacs-gui::global-climacs-table
+ 'slidemacs-table
'((#\= :control :meta)))
(esa:set-key 'com-first-talking-point
- 'climacs-gui::global-climacs-table
+ 'slidemacs-table
'((#\- :control :meta)))
(esa:set-key 'com-flip-slidemacs-syntax
- 'climacs-gui::global-climacs-table
+ 'slidemacs-table
'((#\s :control :meta)))
-(climacs-gui::define-named-command com-postscript-print-presentation ()
+(define-command (com-postscript-print-presentation :name t :command-table slidemacs-table) ()
(let ((pane (climacs-gui::current-window)))
(if (not (and (typep pane 'climacs-pane)
(typep (syntax (buffer pane)) 'slidemacs-gui-syntax)))
Index: climacs/pane.lisp
diff -u climacs/pane.lisp:1.32 climacs/pane.lisp:1.33
--- climacs/pane.lisp:1.32 Thu Sep 1 02:21:08 2005
+++ climacs/pane.lisp Tue Sep 13 21:23:59 2005
@@ -267,7 +267,7 @@
(cursor-y :initform 2)
(space-width :initform nil)
(tab-width :initform nil)
- (auto-fill-mode :initform t :accessor auto-fill-mode)
+ (auto-fill-mode :initform nil :accessor auto-fill-mode)
(auto-fill-column :initform 70 :accessor auto-fill-column)
(isearch-mode :initform nil :accessor isearch-mode)
(isearch-states :initform '() :accessor isearch-states)
Index: climacs/packages.lisp
diff -u climacs/packages.lisp:1.81 climacs/packages.lisp:1.82
--- climacs/packages.lisp:1.81 Tue Sep 6 23:30:33 2005
+++ climacs/packages.lisp Tue Sep 13 21:23:59 2005
@@ -107,6 +107,7 @@
#:parse-stack-next #:parse-stack-symbol
#:parse-stack-parse-trees #:map-over-parse-trees
#:no-such-operation #:no-expression
+ #:name-for-info-pane
#:syntax-line-indentation
#:forward-expression #:backward-expression
#:eval-defun
Index: climacs/lisp-syntax.lisp
diff -u climacs/lisp-syntax.lisp:1.34 climacs/lisp-syntax.lisp:1.35
--- climacs/lisp-syntax.lisp:1.34 Mon Sep 5 09:07:28 2005
+++ climacs/lisp-syntax.lisp Tue Sep 13 21:23:59 2005
@@ -43,6 +43,11 @@
(with-slots (buffer scan) syntax
(setf scan (clone-mark (low-mark buffer) :left))))
+(defmethod name-for-info-pane ((syntax lisp-syntax))
+ (format nil "Lisp~@[:~(~A~)~]"
+ (when (slot-value syntax 'package)
+ (package-name (slot-value syntax 'package)))))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; lexer
@@ -1571,6 +1576,31 @@
(mark< mark (end-offset form)))
do (setf (offset mark) (end-offset form))
(loop-finish))))
+
+(defun in-type-p-in-children (children offset type)
+ (loop for child in children
+ do (cond ((< (start-offset child) offset (end-offset child))
+ (return (if (typep child type)
+ child
+ (in-type-p-in-children (children child) offset type))))
+ ((<= offset (start-offset child))
+ (return nil))
+ (t nil))))
+
+(defun in-type-p (mark syntax type)
+ (let ((offset (offset mark)))
+ (with-slots (stack-top) syntax
+ (if (or (null (start-offset stack-top))
+ (>= offset (end-offset stack-top))
+ (<= offset (start-offset stack-top)))
+ nil)
+ (in-type-p-in-children (children stack-top) offset type))))
+
+(defun in-string-p (mark syntax)
+ (in-type-p mark syntax 'string-form))
+
+(defun in-comment-p (mark syntax)
+ (in-type-p mark syntax 'comment))
;;; shamelessly replacing SWANK code
;; We first work through the string removing the characters and noting
Index: climacs/gui.lisp
diff -u climacs/gui.lisp:1.187 climacs/gui.lisp:1.188
--- climacs/gui.lisp:1.187 Tue Sep 6 23:30:33 2005
+++ climacs/gui.lisp Tue Sep 13 21:23:59 2005
@@ -53,38 +53,93 @@
(defparameter *with-scrollbars* t
"If T, classic look and feel. If NIL, stripped-down look (:")
+;;; Basic functionality
+(make-command-table 'base-table)
+;;; buffers
+(make-command-table 'buffer-table)
+;;; case
+(make-command-table 'case-table)
+;;; comments
+(make-command-table 'comment-table)
+;;; deleting
+(make-command-table 'deletion-table)
+;;; commands used for climacs development
+(make-command-table 'development-table)
+;;; editing - making changes to a buffer
+(make-command-table 'editing-table)
+;;; filling
+(make-command-table 'fill-table)
+;;; indentation
+(make-command-table 'indent-table)
+;;; information about the buffer
+(make-command-table 'info-table)
+;;; lisp-related commands
+(make-command-table 'lisp-table)
+;;; marking things
+(make-command-table 'marking-table)
+;;; moving around
+(make-command-table 'movement-table)
+;;; panes
+(make-command-table 'pane-table)
+;;; searching
+(make-command-table 'search-table)
+;;; self-insertion
+(make-command-table 'self-insert-table)
+;;; windows
+(make-command-table 'window-table)
+
(define-application-frame climacs (standard-application-frame
esa-frame-mixin)
((buffers :initform '() :accessor buffers))
- (:command-table (global-climacs-table :inherit-from (global-esa-table keyboard-macro-table
- help-table)))
+ (:command-table (global-climacs-table
+ :inherit-from (global-esa-table
+ keyboard-macro-table
+ help-table
+ base-table
+ buffer-table
+ case-table
+ comment-table
+ deletion-table
+ development-table
+ editing-table
+ fill-table
+ indent-table
+ info-table
+ lisp-table
+ marking-table
+ movement-table
+ pane-table
+ search-table
+ self-insert-table
+ window-table)))
(:menu-bar nil)
(:panes
- (window (let* ((extended-pane
- (make-pane 'extended-pane
- :width 900 :height 400
- :end-of-line-action :scroll
- :incremental-redisplay t
- :display-function 'display-window
- :command-table 'global-climacs-table))
- (info-pane
- (make-pane 'climacs-info-pane
- :master-pane extended-pane
- :width 900)))
- (setf (windows *application-frame*) (list extended-pane)
- (buffers *application-frame*) (list (buffer extended-pane)))
+ (climacs-window
+ (let* ((extended-pane
+ (make-pane 'extended-pane
+ :width 900 :height 400
+ :end-of-line-action :scroll
+ :incremental-redisplay t
+ :display-function 'display-window
+ :command-table 'global-climacs-table))
+ (info-pane
+ (make-pane 'climacs-info-pane
+ :master-pane extended-pane
+ :width 900)))
+ (setf (windows *application-frame*) (list extended-pane)
+ (buffers *application-frame*) (list (buffer extended-pane)))
- (vertically ()
- (if *with-scrollbars*
- (scrolling ()
- extended-pane)
- extended-pane)
- info-pane)))
+ (vertically ()
+ (if *with-scrollbars*
+ (scrolling ()
+ extended-pane)
+ extended-pane)
+ info-pane)))
(minibuffer (make-pane 'climacs-minibuffer-pane :width 900)))
(:layouts
(default
(vertically (:scroll-bars nil)
- window
+ climacs-window
minibuffer)))
(:top-level (esa-top-level)))
@@ -93,7 +148,9 @@
(defmethod redisplay-frame-panes :around ((frame climacs) &rest args)
(declare (ignore args))
- (let ((buffers (remove-duplicates (mapcar #'buffer (windows frame)))))
+ (let ((buffers (remove-duplicates (loop for pane in (windows frame)
+ when (typep pane 'extended-pane)
+ collect (buffer pane)))))
(loop for buffer in buffers
do (update-syntax buffer (syntax buffer)))
(call-next-method)
@@ -116,52 +173,56 @@
(buffer (buffer master-pane))
(size (size buffer))
(top (top master-pane))
- (bot (bot master-pane))
- (name-info (format nil "~3T~A~
- ~3@T~A~
- ~:[~30T~A~;~*~]~
- ~3@T~:[(~;Syntax: ~]~
- ~A~
- ~{~:[~*~; ~A~]~}~
- ~:[)~;~]~
- ~3@T~A"
- (cond ((and (needs-saving buffer)
- (read-only-p buffer)
- "%*"))
- ((needs-saving buffer) "**")
- ((read-only-p buffer) "%%")
- (t "--"))
- (name buffer)
- *with-scrollbars*
- (cond ((and (mark= size bot)
- (mark= 0 top))
- "")
- ((mark= size bot)
- "Bot")
- ((mark= 0 top)
- "Top")
- (t (format nil "~a%"
- (round (* 100 (/ (offset top)
- size))))))
- *with-scrollbars*
- (name (syntax buffer))
- (list
- (slot-value master-pane 'overwrite-mode)
- "Ovwrt"
- (auto-fill-mode master-pane)
- "Fill"
- (isearch-mode master-pane)
- "Isearch")
- *with-scrollbars*
- (if (recordingp *application-frame*)
- "Def"
- ""))))
- (princ name-info pane)))
-
-(defun display-window (frame pane)
- "The display function used by the climacs application frame."
- (declare (ignore frame))
- (redisplay-pane pane (eq pane (current-window))))
+ (bot (bot master-pane)))
+ (formatting-table (pane)
+ (formatting-row (pane)
+ (formatting-cell (pane :align-x :right :min-width '(5 :character))
+ (princ (cond ((and (needs-saving buffer)
+ (read-only-p buffer)
+ "%*"))
+ ((needs-saving buffer) "**")
+ ((read-only-p buffer) "%%")
+ (t "--"))
+ pane))
+ (formatting-cell (pane :min-width '(25 :character))
+ (princ " " pane)
+ (with-text-face (pane :bold)
+ (princ (name buffer) pane)))
+ (formatting-cell (pane :min-width '(5 :character))
+ (princ (cond ((and (mark= size bot)
+ (mark= 0 top))
+ "")
+ ((mark= size bot)
+ "Bot")
+ ((mark= 0 top)
+ "Top")
+ (t (format nil "~a%"
+ (round (* 100 (/ (offset top)
+ size))))))
+ pane))
+ (formatting-cell (pane)
+ (with-text-family (pane :sans-serif)
+ (princ #\( pane)
+ (princ (name-for-info-pane (syntax buffer)) pane)
+ (format pane "~{~:[~*~; ~A~]~}" (list
+ (slot-value master-pane 'overwrite-mode)
+ "Ovwrt"
+ (auto-fill-mode master-pane)
+ "Fill"
+ (isearch-mode master-pane)
+ "Isearch"))
+ (princ #\) pane)))
+ (formatting-cell (pane)
+ (with-text-family (pane :sans-serif)
+ (princ (if (recordingp *application-frame*)
+ "Def"
+ "")
+ pane))))))
+
+ (defun display-window (frame pane)
+ "The display function used by the climacs application frame."
+ (declare (ignore frame))
+ (redisplay-pane pane (eq pane (current-window)))))
(defmethod handle-repaint :before ((pane extended-pane) region)
(declare (ignore region))
@@ -171,8 +232,10 @@
(defmethod execute-frame-command :around ((frame climacs) command)
(handler-case
- (with-undo ((buffer (current-window)))
- (call-next-method))
+ (if (typep (current-window) 'extended-pane)
+ (with-undo ((buffer (current-window)))
+ (call-next-method))
+ (call-next-method))
(offset-before-beginning ()
(beep) (display-message "Beginning of buffer"))
(offset-after-end ()
@@ -193,29 +256,27 @@
do (when (modified-p buffer)
(setf (needs-saving buffer) t))))
-(defmacro define-named-command (command-name args &body body)
- `(define-command ,(if (listp command-name)
- `(,@command-name :name t :command-table global-climacs-table)
- `(,command-name :name t :command-table global-climacs-table))
- ,args ,@body))
-
-(define-named-command com-toggle-overwrite-mode ()
+(define-command (com-overwrite-mode :name t :command-table editing-table) ()
(with-slots (overwrite-mode) (current-window)
(setf overwrite-mode (not overwrite-mode))))
-(set-key 'com-toggle-overwrite-mode 'global-climacs-table
+(set-key 'com-overwrite-mode
+ 'editing-table
'((:insert)))
-(define-named-command com-not-modified ()
+(define-command (com-not-modified :name t :command-table buffer-table) ()
(setf (needs-saving (buffer (current-window))) nil))
-(set-key 'com-not-modified 'global-climacs-table
+(set-key 'com-not-modified
+ 'buffer-table
'((#\~ :meta :shift)))
-(define-named-command com-set-fill-column ((column 'integer :prompt "Column Number:"))
+(define-command (com-set-fill-column :name t :command-table fill-table)
+ ((column 'integer :prompt "Column Number:"))
(set-fill-column column))
-(set-key `(com-set-fill-column ,*numeric-argument-marker*) 'global-climacs-table
+(set-key `(com-set-fill-column ,*numeric-argument-marker*)
+ 'fill-table
'((#\x :control) (#\f)))
(defun set-fill-column (column)
@@ -256,26 +317,31 @@
(define-command com-self-insert ((count 'integer))
(loop repeat count do (insert-character *current-gesture*)))
-(define-named-command com-beginning-of-line ()
+(define-command (com-beginning-of-line :name t :command-table movement-table) ()
(beginning-of-line (point (current-window))))
-(set-key 'com-beginning-of-line 'global-climacs-table
+(set-key 'com-beginning-of-line
+ 'movement-table
'((:home)))
-(set-key 'com-beginning-of-line 'global-climacs-table
+(set-key 'com-beginning-of-line
+ 'movement-table
'((#\a :control)))
-(define-named-command com-end-of-line ()
+(define-command (com-end-of-line :name t :command-table movement-table) ()
(end-of-line (point (current-window))))
-(set-key 'com-end-of-line 'global-climacs-table
+(set-key 'com-end-of-line
+ 'movement-table
'((#\e :control)))
-(set-key 'com-end-of-line 'global-climacs-table
+(set-key 'com-end-of-line
+ 'movement-table
'((:end)))
-(define-named-command com-delete-object ((count 'integer :prompt "Number of Objects")
- (killp 'boolean :prompt "Kill?"))
+(define-command (com-delete-object :name t :command-table deletion-table)
+ ((count 'integer :prompt "Number of Objects")
+ (killp 'boolean :prompt "Kill?"))
(let* ((point (point (current-window)))
(mark (clone-mark point)))
(forward-object mark count)
@@ -286,16 +352,17 @@
(set-key `(com-delete-object ,*numeric-argument-marker*
,*numeric-argument-p*)
- 'global-climacs-table
+ 'deletion-table
'(#\Rubout))
(set-key `(com-delete-object ,*numeric-argument-marker*
,*numeric-argument-p*)
- 'global-climacs-table
+ 'deletion-table
'((#\d :control)))
-(define-named-command com-backward-delete-object ((count 'integer :prompt "Number of Objects")
- (killp 'boolean :prompt "Kill?"))
+(define-command (com-backward-delete-object :name t :command-table deletion-table)
+ ((count 'integer :prompt "Number of Objects")
+ (killp 'boolean :prompt "Kill?"))
(let* ((point (point (current-window)))
(mark (clone-mark point)))
(backward-object mark count)
@@ -306,10 +373,10 @@
(set-key `(com-backward-delete-object ,*numeric-argument-marker*
,*numeric-argument-p*)
- 'global-climacs-table
+ 'deletion-table
'(#\Backspace))
-(define-named-command com-zap-to-object ()
+(define-command (com-zap-to-object :name t :command-table deletion-table) ()
(let* ((item (handler-case (accept 't :prompt "Zap to Object")
(error () (progn (beep)
(display-message "Not a valid object")
@@ -320,7 +387,7 @@
(search-forward item-mark (vector item))
(delete-range current-point (- (offset item-mark) current-offset))))
-(define-named-command com-zap-to-character ()
+(define-command (com-zap-to-character :name t :command-table deletion-table) ()
(let* ((item-string (handler-case (accept 'string :prompt "Zap to Character") ; Figure out how to get #\d and d. (or 'string 'character)?
(error () (progn (beep)
(display-message "Not a valid string. ")
@@ -335,7 +402,8 @@
(search-forward item-mark item)
(delete-range current-point (- (offset item-mark) current-offset))))
-(set-key 'com-zap-to-character 'global-climacs-table
+(set-key 'com-zap-to-character
+ 'deletion-table
'((#\z :meta)))
(defun transpose-objects (mark)
@@ -348,32 +416,35 @@
(insert-object mark object)
(forward-object mark))))
-(define-named-command com-transpose-objects ()
+(define-command (com-transpose-objects :name t :command-table editing-table) ()
(transpose-objects (point (current-window))))
-(set-key 'com-transpose-objects 'global-climacs-table
+(set-key 'com-transpose-objects
+ 'editing-table
'((#\t :control)))
-(define-named-command com-backward-object ((count 'integer :prompt "Number of Objects"))
+(define-command (com-backward-object :name t :command-table movement-table)
+ ((count 'integer :prompt "Number of Objects"))
(backward-object (point (current-window)) count))
(set-key `(com-backward-object ,*numeric-argument-marker*)
- 'global-climacs-table
+ 'movement-table
'((#\b :control)))
(set-key `(com-backward-object ,*numeric-argument-marker*)
- 'global-climacs-table
+ 'movement-table
'((:left)))
-(define-named-command com-forward-object ((count 'integer :prompt "Number of Objects"))
+(define-command (com-forward-object :name t :command-table movement-table)
+ ((count 'integer :prompt "Number of Objects"))
(forward-object (point (current-window)) count))
(set-key `(com-forward-object ,*numeric-argument-marker*)
- 'global-climacs-table
+ 'movement-table
'((#\f :control)))
(set-key `(com-forward-object ,*numeric-argument-marker*)
- 'global-climacs-table
+ 'movement-table
'((:right)))
(defun transpose-words (mark)
@@ -399,10 +470,11 @@
(insert-sequence mark w2)
(forward-word mark))))
-(define-named-command com-transpose-words ()
+(define-command (com-transpose-words :name t :command-table editing-table) ()
(transpose-words (point (current-window))))
-(set-key 'com-transpose-words 'global-climacs-table
+(set-key 'com-transpose-words
+ 'editing-table
'((#\t :meta)))
(defun transpose-lines (mark)
@@ -427,13 +499,15 @@
(insert-sequence mark line)
(insert-object mark #\Newline)))
-(define-named-command com-transpose-lines ()
+(define-command (com-transpose-lines :name t :command-table editing-table) ()
(transpose-lines (point (current-window))))
-(set-key 'com-transpose-lines 'global-climacs-table
+(set-key 'com-transpose-lines
+ 'editing-table
'((#\x :control) (#\t :control)))
-(define-named-command com-previous-line ((numarg 'integer :prompt "How many lines?"))
+(define-command (com-previous-line :name t :command-table movement-table)
+ ((numarg 'integer :prompt "How many lines?"))
(let* ((window (current-window))
(point (point window)))
(unless (or (eq (previous-command window) 'com-previous-line)
@@ -444,14 +518,15 @@
(next-line point (slot-value window 'goal-column) (- numarg)))))
(set-key `(com-previous-line ,*numeric-argument-marker*)
- 'global-climacs-table
+ 'movement-table
'((#\p :control)))
(set-key `(com-previous-line ,*numeric-argument-marker*)
- 'global-climacs-table
+ 'movement-table
'((:up)))
-(define-named-command com-next-line ((numarg 'integer :prompt "How many lines?"))
+(define-command (com-next-line :name t :command-table movement-table)
+ ((numarg 'integer :prompt "How many lines?"))
(let* ((window (current-window))
(point (point window)))
(unless (or (eq (previous-command window) 'com-previous-line)
@@ -462,18 +537,19 @@
(previous-line point (slot-value window 'goal-column) (- numarg)))))
(set-key `(com-next-line ,*numeric-argument-marker*)
- 'global-climacs-table
+ 'movement-table
'((#\n :control)))
(set-key `(com-next-line ,*numeric-argument-marker*)
- 'global-climacs-table
+ 'movement-table
'((:down)))
-(define-named-command com-open-line ((numarg 'integer :prompt "How many lines?"))
+(define-command (com-open-line :name t :command-table editing-table)
+ ((numarg 'integer :prompt "How many lines?"))
(open-line (point (current-window)) numarg))
(set-key `(com-open-line ,*numeric-argument-marker*)
- 'global-climacs-table
+ 'editing-table
'((#\o :control)))
(defun kill-line (mark &optional (count 1) (whole-lines-p nil) (concatenate-p nil))
@@ -504,42 +580,45 @@
(region-to-sequence start mark)))
(delete-region start mark))))
-(define-named-command com-kill-line ((numarg 'integer :prompt "Kill how many lines?")
- (numargp 'boolean :prompt "Kill entire lines?"))
+(define-command (com-kill-line :name t :command-table deletion-table)
+ ((numarg 'integer :prompt "Kill how many lines?")
+ (numargp 'boolean :prompt "Kill entire lines?"))
(let* ((pane (current-window))
(point (point pane))
(concatenate-p (eq (previous-command pane) 'com-kill-line)))
(kill-line point numarg numargp concatenate-p)))
(set-key `(com-kill-line ,*numeric-argument-marker* ,*numeric-argument-p*)
- 'global-climacs-table
+ 'deletion-table
'((#\k :control)))
-(define-named-command com-forward-word ((count 'integer :prompt "Number of words"))
+(define-command (com-forward-word :name t :command-table movement-table)
+ ((count 'integer :prompt "Number of words"))
(if (plusp count)
(forward-word (point (current-window)) count)
(backward-word (point (current-window)) (- count))))
(set-key `(com-forward-word ,*numeric-argument-marker*)
- 'global-climacs-table
+ 'movement-table
'((#\f :meta)))
(set-key `(com-forward-word ,*numeric-argument-marker*)
- 'global-climacs-table
+ 'movement-table
'((:right :control)))
-(define-named-command com-backward-word ((count 'integer :prompt "Number of words"))
+(define-command (com-backward-word :name t :command-table movement-table)
+ ((count 'integer :prompt "Number of words"))
(backward-word (point (current-window)) count))
(set-key `(com-backward-word ,*numeric-argument-marker*)
- 'global-climacs-table
+ 'movement-table
'((#\b :meta)))
(set-key `(com-backward-word ,*numeric-argument-marker*)
- 'global-climacs-table
+ 'movement-table
'((:left :control)))
-(define-named-command com-delete-word ((count 'integer :prompt "Number of words"))
+(define-command (com-delete-word :name t :command-table deletion-table) ((count 'integer :prompt "Number of words"))
(delete-word (point (current-window)) count))
(defun kill-word (mark &optional (count 1) (concatenate-p nil))
@@ -562,27 +641,30 @@
(region-to-sequence start mark)))
(delete-region start mark))))
-(define-named-command com-kill-word ((count 'integer :prompt "Number of words"))
+(define-command (com-kill-word :name t :command-table deletion-table)
+ ((count 'integer :prompt "Number of words"))
(let* ((pane (current-window))
(point (point pane))
(concatenate-p (eq (previous-command pane) 'com-kill-word)))
(kill-word point count concatenate-p)))
(set-key `(com-kill-word ,*numeric-argument-marker*)
- 'global-climacs-table
+ 'deletion-table
'((#\d :meta)))
-(define-named-command com-backward-kill-word ((count 'integer :prompt "Number of words"))
+(define-command (com-backward-kill-word :name t :command-table deletion-table)
+ ((count 'integer :prompt "Number of words"))
(let* ((pane (current-window))
(point (point pane))
(concatenate-p (eq (previous-command pane) 'com-backward-kill-word)))
(kill-word point (- count) concatenate-p)))
(set-key `(com-backward-kill-word ,*numeric-argument-marker*)
- 'global-climacs-table
+ 'deletion-table
'((#\Backspace :meta)))
-(define-named-command com-mark-word ((count 'integer :prompt "Number of words"))
+(define-command (com-mark-word :name t :command-table marking-table)
+ ((count 'integer :prompt "Number of words"))
(let* ((pane (current-window))
(point (point pane))
(mark (mark pane)))
@@ -593,48 +675,52 @@
(backward-word mark (- count)))))
(set-key `(com-mark-word ,*numeric-argument-marker*)
- 'global-climacs-table
+ 'marking-table
'((#\@ :meta :shift)))
-(define-named-command com-backward-delete-word ((count 'integer :prompt "Number of words"))
+(define-command (com-backward-delete-word :name t :command-table deletion-table)
+ ((count 'integer :prompt "Number of words"))
(backward-delete-word (point (current-window)) count))
-(define-named-command com-upcase-region ()
+(define-command (com-upcase-region :name t :command-table case-table) ()
(let ((cw (current-window)))
(upcase-region (mark cw) (point cw))))
-(define-named-command com-downcase-region ()
+(define-command (com-downcase-region :name t :command-table case-table) ()
(let ((cw (current-window)))
(downcase-region (mark cw) (point cw))))
-(define-named-command com-capitalize-region ()
+(define-command (com-capitalize-region :name t :command-table case-table) ()
(let ((cw (current-window)))
(capitalize-region (mark cw) (point cw))))
-(define-named-command com-upcase-word ()
+(define-command (com-upcase-word :name t :command-table case-table) ()
(upcase-word (point (current-window))))
-(set-key 'com-upcase-word 'global-climacs-table
+(set-key 'com-upcase-word
+ 'case-table
'((#\u :meta)))
-(define-named-command com-downcase-word ()
+(define-command (com-downcase-word :name t :command-table case-table) ()
(downcase-word (point (current-window))))
-(set-key 'com-downcase-word 'global-climacs-table
+(set-key 'com-downcase-word
+ 'case-table
'((#\l :meta)))
-(define-named-command com-capitalize-word ()
+(define-command (com-capitalize-word :name t :command-table case-table) ()
(capitalize-word (point (current-window))))
-(set-key 'com-capitalize-word 'global-climacs-table
+(set-key 'com-capitalize-word
+ 'case-table
'((#\c :meta)))
-(define-named-command com-tabify-region ()
+(define-command (com-tabify-region :name t :command-table editing-table) ()
(let ((pane (current-window)))
(tabify-region
(mark pane) (point pane) (tab-space-count (stream-default-view pane)))))
-(define-named-command com-untabify-region ()
+(define-command (com-untabify-region :name t :command-table editing-table) ()
(let ((pane (current-window)))
(untabify-region
(mark pane) (point pane) (tab-space-count (stream-default-view pane)))))
@@ -649,37 +735,41 @@
(indent-line point indentation (and (indent-tabs-mode buffer)
tab-space-count))))
-(define-named-command com-indent-line ()
+(define-command (com-indent-line :name t :command-table indent-table) ()
(let* ((pane (current-window))
(point (point pane)))
(indent-current-line pane point)))
-(set-key 'com-indent-line 'global-climacs-table
+(set-key 'com-indent-line
+ 'indent-table
'((#\Tab)))
-(set-key 'com-indent-line 'global-climacs-table
+(set-key 'com-indent-line
+ 'indent-table
'((#\i :control)))
-(define-named-command com-newline-and-indent ()
+(define-command (com-newline-and-indent :name t :command-table indent-table) ()
(let* ((pane (current-window))
(point (point pane)))
(insert-object point #\Newline)
(indent-current-line pane point)))
-(set-key 'com-newline-and-indent 'global-climacs-table
+(set-key 'com-newline-and-indent
+ 'indent-table
'((#\j :control)))
-(define-named-command com-delete-indentation ()
+(define-command (com-delete-indentation :name t :command-table indent-table) ()
(delete-indentation (point (current-window))))
-(set-key 'com-delete-indentation 'global-climacs-table
+(set-key 'com-delete-indentation
+ 'indent-table
'((#\^ :shift :meta)))
-(define-named-command com-auto-fill-mode ()
+(define-command (com-auto-fill-mode :name t :command-table fill-table) ()
(let ((pane (current-window)))
(setf (auto-fill-mode pane) (not (auto-fill-mode pane)))))
-(define-named-command com-fill-paragraph ()
+(define-command (com-fill-paragraph :name t :command-table fill-table) ()
(let* ((pane (current-window))
(buffer (buffer pane))
(syntax (syntax buffer))
@@ -699,7 +789,8 @@
(possibly-fill-line)
(setf (offset point) (offset point-backup)))))
-(set-key 'com-fill-paragraph 'global-climacs-table
+(set-key 'com-fill-paragraph
+ 'fill-table
'((#\q :meta)))
(defun filename-completer (so-far mode)
@@ -849,11 +940,12 @@
(redisplay-frame-panes *application-frame*)
buffer))))))
-(define-named-command com-find-file ()
+(define-command (com-find-file :name t :command-table buffer-table) ()
(let* ((filepath (accept 'pathname :prompt "Find File")))
(find-file filepath)))
-(set-key 'com-find-file 'global-climacs-table
+(set-key 'com-find-file
+ 'buffer-table
'((#\x :control) (#\f :control)))
(defun find-file-read-only (filepath)
@@ -892,18 +984,20 @@
(beep)
nil)))))))
-(define-named-command com-find-file-read-only ()
+(define-command (com-find-file-read-only :name t :command-table buffer-table) ()
(let ((filepath (accept 'pathname :Prompt "Find file read only")))
(find-file-read-only filepath)))
-(set-key 'com-find-file-read-only 'global-climacs-table
+(set-key 'com-find-file-read-only
+ 'buffer-table
'((#\x :control) (#\r :control)))
-(define-named-command com-toggle-read-only ()
+(define-command (com-read-only :name t :command-table buffer-table) ()
(let ((buffer (buffer (current-window))))
(setf (read-only-p buffer) (not (read-only-p buffer)))))
-(set-key 'com-toggle-read-only 'global-climacs-table
+(set-key 'com-read-only
+ 'buffer-table
'((#\x :control) (#\q :control)))
(defun set-visited-file-name (filename buffer)
@@ -911,11 +1005,11 @@
(name buffer) (filepath-filename filename)
(needs-saving buffer) t))
-(define-named-command com-set-visited-file-name ()
+(define-command (com-set-visited-file-name :name t :command-table buffer-table) ()
(let ((filename (accept 'pathname :prompt "New file name")))
(set-visited-file-name filename (buffer (current-window)))))
-(define-named-command com-insert-file ()
+(define-command (com-insert-file :name t :command-table buffer-table) ()
(let ((filename (accept 'pathname :prompt "Insert File"))
(pane (current-window)))
(when (probe-file filename)
@@ -928,7 +1022,8 @@
(offset (point pane)) (offset (mark pane))))
(redisplay-frame-panes *application-frame*)))
-(set-key 'com-insert-file 'global-climacs-table
+(set-key 'com-insert-file
+ 'buffer-table
'((#\x :control) (#\i :control)))
(defgeneric erase-buffer (buffer))
@@ -945,7 +1040,7 @@
(end-of-buffer point)
(delete-region mark point)))
-(define-named-command com-revert-buffer ()
+(define-command (com-revert-buffer :name t :command-table buffer-table) ()
(let* ((pane (current-window))
(buffer (buffer pane))
(filepath (filepath buffer))
@@ -985,14 +1080,15 @@
(display-message "Wrote: ~a" (filepath buffer))
(setf (needs-saving buffer) nil)))))
-(define-named-command com-save-buffer ()
+(define-command (com-save-buffer :name t :command-table buffer-table) ()
(let ((buffer (buffer (current-window))))
(if (or (null (filepath buffer))
(needs-saving buffer))
(save-buffer buffer)
(display-message "No changes need to be saved from ~a" (name buffer)))))
-(set-key 'com-save-buffer 'global-climacs-table
+(set-key 'com-save-buffer
+ 'buffer-table
'((#\x :control) (#\s :control)))
(defmethod frame-exit :around ((frame climacs))
@@ -1013,7 +1109,7 @@
(return-from frame-exit nil)))))
(call-next-method)))
-(define-named-command com-write-buffer ()
+(define-command (com-write-buffer :name t :command-table buffer-table) ()
(let ((filepath (accept 'pathname :prompt "Write Buffer to File"))
(buffer (buffer (current-window))))
(cond
@@ -1027,7 +1123,8 @@
(needs-saving buffer) nil)
(display-message "Wrote: ~a" (filepath buffer))))))
-(set-key 'com-write-buffer 'global-climacs-table
+(set-key 'com-write-buffer
+ 'buffer-table
'((#\x :control) (#\w :control)))
(define-presentation-method present (object (type buffer)
@@ -1079,14 +1176,15 @@
(defmethod switch-to-buffer ((symbol (eql 'nil)))
(switch-to-buffer (second (buffers *application-frame*))))
-(define-named-command com-switch-to-buffer ()
+(define-command (com-switch-to-buffer :name t :command-table pane-table) ()
(let ((buffer (accept 'buffer
:prompt "Switch to buffer"
:default (second (buffers *application-frame*))
:default-type 'buffer)))
(switch-to-buffer buffer)))
-(set-key 'com-switch-to-buffer 'global-climacs-table
+(set-key 'com-switch-to-buffer
+ 'pane-table
'((#\x :control) (#\b)))
(defgeneric kill-buffer (buffer))
@@ -1113,20 +1211,22 @@
(defmethod kill-buffer ((symbol (eql 'nil)))
(kill-buffer (buffer (current-window))))
-(define-named-command com-kill-buffer ()
+(define-command (com-kill-buffer :name t :command-table pane-table) ()
(let ((buffer (accept 'buffer
:prompt "Kill buffer"
:default (buffer (current-window))
:default-type 'buffer)))
(kill-buffer buffer)))
-(set-key 'com-kill-buffer 'global-climacs-table
+(set-key 'com-kill-buffer
+ 'pane-table
'((#\x :control) (#\k)))
-(define-named-command com-full-redisplay ()
+(define-command (com-full-redisplay :name t :command-table base-table) ()
(full-redisplay (current-window)))
-(set-key 'com-full-redisplay 'global-climacs-table
+(set-key 'com-full-redisplay
+ 'base-table
'((#\l :control)))
(defun load-file (file-name)
@@ -1140,56 +1240,66 @@
(display-message "No such file: ~A" file-name)
(beep))))))
-(define-named-command com-load-file ()
+(define-command (com-load-file :name t :command-table base-table) ()
(let ((filepath (accept 'pathname :prompt "Load File")))
(load-file filepath)))
-(set-key 'com-load-file 'global-climacs-table
+(set-key 'com-load-file
+ 'base-table
'((#\c :control) (#\l :control)))
-(define-named-command com-beginning-of-buffer ()
+(define-command (com-beginning-of-buffer :name t :command-table movement-table) ()
(beginning-of-buffer (point (current-window))))
-(set-key 'com-beginning-of-buffer 'global-climacs-table
+(set-key 'com-beginning-of-buffer
+ 'movement-table
'((#\< :shift :meta)))
-(set-key 'com-beginning-of-buffer 'global-climacs-table
+(set-key 'com-beginning-of-buffer
+ 'movement-table
'((:home :control)))
-(define-named-command com-page-down ()
+(define-command (com-page-down :name t :command-table movement-table) ()
(let ((pane (current-window)))
(page-down pane)))
-(set-key 'com-page-down 'global-climacs-table
+(set-key 'com-page-down
+ 'movement-table
'((#\v :control)))
-(set-key 'com-page-down 'global-climacs-table
+(set-key 'com-page-down
+ 'movement-table
'((:next)))
-(define-named-command com-page-up ()
+(define-command (com-page-up :name t :command-table movement-table) ()
(let ((pane (current-window)))
(page-up pane)))
-(set-key 'com-page-up 'global-climacs-table
+(set-key 'com-page-up
+ 'movement-table
'((#\v :meta)))
-(set-key 'com-page-up 'global-climacs-table
+(set-key 'com-page-up
+ 'movement-table
'((:prior)))
-(define-named-command com-end-of-buffer ()
+(define-command (com-end-of-buffer :name t :command-table movement-table) ()
(end-of-buffer (point (current-window))))
-(set-key 'com-end-of-buffer 'global-climacs-table
+(set-key 'com-end-of-buffer
+ 'movement-table
'((#\> :shift :meta)))
-(set-key 'com-end-of-buffer 'global-climacs-table
+(set-key 'com-end-of-buffer
+ 'movement-table
'((:end :control)))
-(define-named-command com-mark-whole-buffer ()
+(define-command (com-mark-whole-buffer :name t :command-table marking-table) ()
(beginning-of-buffer (point (current-window)))
(end-of-buffer (mark (current-window))))
-(set-key 'com-mark-whole-buffer 'global-climacs-table
+(set-key 'com-mark-whole-buffer
+ 'marking-table
'((#\x :control) (#\h)))
(defun back-to-indentation (mark)
@@ -1198,10 +1308,11 @@
while (whitespacep (object-after mark))
do (forward-object mark)))
-(define-named-command com-back-to-indentation ()
+(define-command (com-back-to-indentation :name t :command-table movement-table) ()
(back-to-indentation (point (current-window))))
-(set-key 'com-back-to-indentation 'global-climacs-table
+(set-key 'com-back-to-indentation
+ 'movement-table
'((#\m :meta)))
(defun delete-horizontal-space (mark &optional (backward-only-p nil))
@@ -1215,12 +1326,13 @@
do (forward-object mark2)))
(delete-region mark mark2)))
-(define-named-command com-delete-horizontal-space ((backward-only-p
- 'boolean :prompt "Delete backwards only?"))
+(define-command (com-delete-horizontal-space :name t :command-table deletion-table)
+ ((backward-only-p
+ 'boolean :prompt "Delete backwards only?"))
(delete-horizontal-space (point (current-window)) backward-only-p))
(set-key `(com-delete-horizontal-space ,*numeric-argument-p*)
- 'global-climacs-table
+ 'deletion-table
'((#\\ :meta)))
(defun just-one-space (mark count)
@@ -1237,17 +1349,18 @@
do (forward-object mark))
(delete-region offset mark)))
-(define-named-command com-just-one-space ((count 'integer :prompt "Number of spaces"))
+(define-command (com-just-one-space :name t :command-table deletion-table)
+ ((count 'integer :prompt "Number of spaces"))
(just-one-space (point (current-window)) count))
(set-key `(com-just-one-space ,*numeric-argument-marker*)
- 'global-climacs-table
+ 'deletion-table
'((#\Space :meta)))
(defun goto-position (mark pos)
(setf (offset mark) pos))
-(define-named-command com-goto-position ()
+(define-command (com-goto-position :name t :command-table movement-table) ()
(goto-position
(point (current-window))
(handler-case (accept 'integer :prompt "Goto Position")
@@ -1267,33 +1380,35 @@
finally (beginning-of-line m)
(setf (offset mark) (offset m))))
-(define-named-command com-goto-line ()
+(define-command (com-goto-line :name t :command-table movement-table) ()
(goto-line (point (current-window))
(handler-case (accept 'integer :prompt "Goto Line")
(error () (progn (beep)
(display-message "Not a valid line number")
(return-from com-goto-line nil))))))
-(define-named-command com-browse-url ()
+(define-command (com-browse-url :name t :command-table base-table) ()
(let ((url (accept 'url :prompt "Browse URL")))
#+ (and sbcl darwin)
(sb-ext:run-program "/usr/bin/open" `(,url) :wait nil)
#+ (and openmcl darwin)
(ccl:run-program "/usr/bin/open" `(,url) :wait nil)))
-(define-named-command com-set-mark ()
+(define-command (com-set-mark :name t :command-table marking-table) ()
(let ((pane (current-window)))
(setf (mark pane) (clone-mark (point pane)))))
-(set-key 'com-set-mark 'global-climacs-table
+(set-key 'com-set-mark
+ 'marking-table
'((#\Space :control)))
-(define-named-command com-exchange-point-and-mark ()
+(define-command (com-exchange-point-and-mark :name t :command-table marking-table) ()
(let ((pane (current-window)))
(psetf (offset (mark pane)) (offset (point pane))
(offset (point pane)) (offset (mark pane)))))
-(set-key 'com-exchange-point-and-mark 'global-climacs-table
+(set-key 'com-exchange-point-and-mark
+ 'marking-table
'((#\x :control) (#\x :control)))
(defgeneric set-syntax (buffer syntax))
@@ -1314,7 +1429,7 @@
(beep)
(display-message "No such syntax: ~A." syntax)))))
-(define-named-command com-set-syntax ()
+(define-command (com-set-syntax :name t :command-table buffer-table) ()
(let* ((pane (current-window))
(buffer (buffer pane)))
(set-syntax buffer (accept 'syntax :prompt "Set Syntax"))))
@@ -1334,9 +1449,9 @@
(sheet-disown-child parent constellation)
(let ((new (if vertical-p
(vertically ()
- (1/2 constellation) adjust (1/2 additional-constellation))
+ constellation adjust additional-constellation)
(horizontally ()
- (1/2 constellation) adjust (1/2 additional-constellation)))))
+ constellation adjust additional-constellation))))
(sheet-adopt-child parent new)
(reorder-sheets parent
(if (eq constellation first)
@@ -1347,16 +1462,56 @@
(list first second new)
(list first new)))))))
-(defun parent3 (sheet)
- (sheet-parent (sheet-parent (sheet-parent sheet))))
+(defun find-parent (sheet)
+ (loop for parent = (sheet-parent sheet)
+ then (sheet-parent parent)
+ until (typep parent 'vrack-pane)
+ finally (return parent)))
+
+(defclass typeout-pane (application-pane esa-pane-mixin) ())
+
+(defun make-typeout-constellation (&optional label)
+ (let* ((typeout-pane
+ (make-pane 'typeout-pane :width 900 :height 400 :display-time nil))
+ (label
+ (make-pane 'label-pane :label label))
+ (vbox
+ (vertically ()
+ (scrolling (:scroll-bar :vertical) typeout-pane) label)))
+ (values vbox typeout-pane)))
+
+(defun typeout-window (&optional (label "Typeout") (pane (current-window)))
+ (with-look-and-feel-realization
+ ((frame-manager *application-frame*) *application-frame*)
+ (multiple-value-bind (vbox new-pane) (make-typeout-constellation label)
+ (let* ((current-window pane)
+ (constellation-root (find-parent current-window)))
+ (push new-pane (windows *application-frame*))
+ (other-window)
+ (replace-constellation constellation-root vbox t)
+ (full-redisplay current-window)
+ new-pane))))
-(defun make-pane-constellation ()
+(define-command (com-describe-bindings :name t :command-table help-table)
+ ((sort-by-keystrokes 'boolean :prompt "Sort by keystrokes?"))
+ (let* ((window (current-window))
+ (buffer (buffer (current-window)))
+ (stream (typeout-window
+ (format nil "~10THelp: Describe Bindings for ~A" (name buffer))))
+ (command-table (command-table window)))
+ (esa::describe-bindings stream command-table
+ (if sort-by-keystrokes
+ #'esa::sort-by-keystrokes
+ #'esa::sort-by-name))))
+
+(set-key `(com-describe-bindings ,*numeric-argument-p*) 'help-table '((#\h :control) (#\b)))
+
+(defun make-pane-constellation (&optional (with-scrollbars *with-scrollbars*))
"make a vbox containing a scroller pane as its first child and an
info pane as its second child. The scroller pane contains a viewport
which contains an extended pane. Return the vbox and the extended pane
as two values.
-If *with-scrollbars* nil, omit the scroller."
-
+If with-scrollbars nil, omit the scroller."
(let* ((extended-pane
(make-pane 'extended-pane
:width 900 :height 400
@@ -1367,7 +1522,7 @@
:command-table 'global-climacs-table))
(vbox
(vertically ()
- (if *with-scrollbars*
+ (if with-scrollbars
(scrolling ()
extended-pane)
extended-pane)
@@ -1376,68 +1531,79 @@
:width 900))))
(values vbox extended-pane)))
-(defun split-window-vertically (&optional (pane (current-window)))
+(defun split-window (&optional (vertically-p nil) (pane (current-window)))
(with-look-and-feel-realization
((frame-manager *application-frame*) *application-frame*)
(multiple-value-bind (vbox new-pane) (make-pane-constellation)
(let* ((current-window pane)
- (constellation-root (if *with-scrollbars*
- (parent3 current-window)
- (sheet-parent current-window))))
+ (constellation-root (find-parent current-window)))
(setf (offset (point (buffer current-window))) (offset (point current-window))
(buffer new-pane) (buffer current-window)
(auto-fill-mode new-pane) (auto-fill-mode current-window)
(auto-fill-column new-pane) (auto-fill-column current-window))
(push new-pane (windows *application-frame*))
(setf *standard-output* new-pane)
- (replace-constellation constellation-root vbox t)
+ (replace-constellation constellation-root vbox vertically-p)
(full-redisplay current-window)
(full-redisplay new-pane)
new-pane))))
-(define-named-command com-split-window-vertically ()
- (split-window-vertically))
+(define-command (com-split-window-vertically :name t :command-table window-table) ()
+ (split-window t))
-(set-key 'com-split-window-vertically 'global-climacs-table
+(set-key 'com-split-window-vertically
+ 'window-table
'((#\x :control) (#\2)))
-(defun split-window-horizontally (&optional (pane (current-window)))
- (with-look-and-feel-realization
- ((frame-manager *application-frame*) *application-frame*)
- (multiple-value-bind (vbox new-pane) (make-pane-constellation)
- (let* ((current-window pane)
- (constellation-root (if *with-scrollbars*
- (parent3 current-window)
- (sheet-parent current-window))))
- (setf (offset (point (buffer current-window))) (offset (point current-window))
- (buffer new-pane) (buffer current-window)
- (auto-fill-mode new-pane) (auto-fill-mode current-window)
- (auto-fill-column new-pane) (auto-fill-column current-window))
- (push new-pane (windows *application-frame*))
- (setf *standard-output* new-pane)
- (replace-constellation constellation-root vbox nil)
- (full-redisplay current-window)
- (full-redisplay new-pane)
- new-pane))))
-
-(define-named-command com-split-window-horizontally ()
- (split-window-horizontally))
+(define-command (com-split-window-horizontally :name t :command-table window-table) ()
+ (split-window))
-(set-key 'com-split-window-horizontally 'global-climacs-table
+(set-key 'com-split-window-horizontally
+ 'window-table
'((#\x :control) (#\3)))
-(defun other-window ()
- (setf (windows *application-frame*)
- (append (cdr (windows *application-frame*))
- (list (car (windows *application-frame*)))))
+(defun other-window (&optional pane)
+ (if (and pane (find pane (windows *application-frame*)))
+ (setf (windows *application-frame*)
+ (append (list pane)
+ (remove pane (windows *application-frame*))))
+ (setf (windows *application-frame*)
+ (append (cdr (windows *application-frame*))
+ (list (car (windows *application-frame*))))))
(setf *standard-output* (car (windows *application-frame*))))
-
-(define-named-command com-other-window ()
+
+(define-command (com-other-window :name t :command-table window-table) ()
(other-window))
-(set-key 'com-other-window 'global-climacs-table
+(set-key 'com-other-window
+ 'window-table
'((#\x :control) (#\o)))
+(define-command (com-switch-to-this-window :name nil :command-table window-table)
+ ((window 'pane) (x 'integer) (y 'integer))
+ (other-window window)
+ (with-slots (top bot) window
+ (let ((new-x (floor x (stream-character-width window #\m)))
+ (new-y (floor y (stream-line-height window)))
+ (buffer (buffer window)))
+ (loop for scan from (offset top)
+ with lines = 0
+ until (= scan (offset bot))
+ until (= lines new-y)
+ when (eql (buffer-object buffer scan) #\Newline)
+ do (incf lines)
+ finally (loop for columns from 0
+ until (= scan (offset bot))
+ until (eql (buffer-object buffer scan) #\Newline)
+ until (= columns new-x)
+ do (incf scan))
+ (setf (offset (point window)) scan)))))
+
+(define-presentation-to-command-translator blank-area-to-switch-to-this-window
+ (blank-area com-switch-to-this-window window-table :echo nil)
+ (object window x y)
+ (list window x y))
+
(defun single-window ()
(loop until (null (cdr (windows *application-frame*)))
do (rotatef (car (windows *application-frame*))
@@ -1445,33 +1611,34 @@
(com-delete-window))
(setf *standard-output* (car (windows *application-frame*))))
-(define-named-command com-single-window ()
+(define-command (com-single-window :name t :command-table window-table) ()
(single-window))
-(set-key 'com-single-window 'global-climacs-table
+(set-key 'com-single-window
+ 'window-table
'((#\x :control) (#\1)))
-(define-named-command com-scroll-other-window ()
+(define-command (com-scroll-other-window :name t :command-table window-table) ()
(let ((other-window (second (windows *application-frame*))))
(when other-window
(page-down other-window))))
-(set-key 'com-scroll-other-window 'global-climacs-table
+(set-key 'com-scroll-other-window
+ 'window-table
'((#\v :control :meta)))
-(define-named-command com-scroll-other-window-up ()
+(define-command (com-scroll-other-window-up :name t :command-table window-table) ()
(let ((other-window (second (windows *application-frame*))))
(when other-window
(page-up other-window))))
-(set-key 'com-scroll-other-window-up 'global-climacs-table
+(set-key 'com-scroll-other-window-up
+ 'window-table
'((#\V :control :meta :shift)))
(defun delete-window (&optional (window (current-window)))
(unless (null (cdr (windows *application-frame*)))
- (let* ((constellation (if *with-scrollbars*
- (parent3 window)
- (sheet-parent window)))
+ (let* ((constellation (find-parent window))
(box (sheet-parent constellation))
(box-children (sheet-children box))
(other (if (eq constellation (first box-children))
@@ -1496,41 +1663,45 @@
(list first second other)
(list first other)))))))
-(define-named-command com-delete-window ()
+(define-command (com-delete-window :name t :command-table window-table) ()
(delete-window))
-(set-key 'com-delete-window 'global-climacs-table
+(set-key 'com-delete-window
+ 'window-table
'((#\x :control) (#\0)))
;;;;;;;;;;;;;;;;;;;;
;; Kill ring commands
;; Copies an element from a kill-ring to a buffer at the given offset
-(define-named-command com-yank ()
+(define-command (com-yank :name t :command-table editing-table) ()
(insert-sequence (point (current-window)) (kill-ring-yank *kill-ring*)))
-(set-key 'com-yank 'global-climacs-table
+(set-key 'com-yank
+ 'editing-table
'((#\y :control)))
;; Destructively cut a given buffer region into the kill-ring
-(define-named-command com-kill-region ()
+(define-command (com-kill-region :name t :command-table editing-table) ()
(let ((pane (current-window)))
(kill-ring-standard-push
*kill-ring* (region-to-sequence (mark pane) (point pane)))
(delete-region (mark pane) (point pane))))
-(set-key 'com-kill-region 'global-climacs-table
+(set-key 'com-kill-region
+ 'editing-table
'((#\w :control)))
;; Non destructively copies buffer region to the kill ring
-(define-named-command com-copy-region ()
+(define-command (com-copy-region :name t :command-table marking-table) ()
(let ((pane (current-window)))
(kill-ring-standard-push *kill-ring* (region-to-sequence (point pane) (mark pane)))))
-(set-key 'com-copy-region 'global-climacs-table
+(set-key 'com-copy-region
+ 'marking-table
'((#\w :meta)))
-(define-named-command com-rotate-yank ()
+(define-command (com-rotate-yank :name t :command-table editing-table) ()
(let* ((pane (current-window))
(point (point pane))
(last-yank (kill-ring-yank *kill-ring*)))
@@ -1541,20 +1712,22 @@
(rotate-yank-position *kill-ring*)))
(insert-sequence point (kill-ring-yank *kill-ring*))))
-(set-key 'com-rotate-yank 'global-climacs-table
+(set-key 'com-rotate-yank
+ 'editing-table
'((#\y :meta)))
-(define-named-command com-resize-kill-ring ()
+(define-command (com-resize-kill-ring :name t :command-table editing-table) ()
(let ((size (handler-case (accept 'integer :prompt "New kill ring size")
(error () (progn (beep)
(display-message "Not a valid kill ring size")
(return-from com-resize-kill-ring nil))))))
(setf (kill-ring-max-size *kill-ring*) size)))
-(define-named-command com-append-next-kill ()
+(define-command (com-append-next-kill :name t :command-table editing-table) ()
(setf (append-next-p *kill-ring*) t))
-(set-key 'com-append-next-kill 'global-climacs-table
+(set-key 'com-append-next-kill
+ 'editing-table
'((#\w :control :meta)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -1606,18 +1779,20 @@
(unless success
(beep)))))
-(define-named-command com-isearch-forward ()
+(define-command (com-isearch-forward :name t :command-table search-table) ()
(display-message "Isearch: ")
(isearch-command-loop (current-window) t))
-(set-key 'com-isearch-forward 'global-climacs-table
+(set-key 'com-isearch-forward
+ 'search-table
'((#\s :control)))
-(define-named-command com-isearch-backward ()
+(define-command (com-isearch-backward :name t :command-table search-table) ()
(display-message "Isearch backward: ")
(isearch-command-loop (current-window) nil))
-(set-key 'com-isearch-backward 'global-climacs-table
+(set-key 'com-isearch-backward
+ 'search-table
'((#\r :control)))
(define-command (com-isearch-append-char :name t :command-table isearch-climacs-table) ()
@@ -1703,7 +1878,7 @@
(search-forward mark string :test #'object-equal)
(/= (offset mark) offset-before))))
-(define-named-command com-query-replace ()
+(define-command (com-query-replace :name t :command-table search-table) ()
(let* ((pane (current-window))
(old-state (query-replace-state pane))
(old-string1 (when old-state (string1 old-state)))
@@ -1745,7 +1920,8 @@
((setf (query-replace-mode pane) nil))))
(display-message "Replaced ~A occurrence~:P" occurrences)))
-(set-key 'com-query-replace 'global-climacs-table
+(set-key 'com-query-replace
+ 'search-table
'((#\% :shift :meta)))
(define-command (com-query-replace-replace :name t :command-table query-replace-climacs-table) ()
@@ -1800,33 +1976,37 @@
;;;
;;; Undo/redo
-(define-named-command com-undo ()
+(define-command (com-undo :name t :command-table editing-table) ()
(handler-case (undo (undo-tree (buffer (current-window))))
(no-more-undo () (beep) (display-message "No more undo")))
(full-redisplay (current-window)))
-(set-key 'com-undo 'global-climacs-table
+(set-key 'com-undo
+ 'editing-table
'((#\_ :shift :control)))
-(set-key 'com-undo 'global-climacs-table
+(set-key 'com-undo
+ 'editing-table
'((#\x :control) (#\u)))
-(define-named-command com-redo ()
+(define-command (com-redo :name t :command-table editing-table) ()
(handler-case (redo (undo-tree (buffer (current-window))))
(no-more-undo () (beep) (display-message "No more redo")))
(full-redisplay (current-window)))
-(set-key 'com-redo 'global-climacs-table
+(set-key 'com-redo
+ 'editing-table
'((#\_ :shift :meta)))
-(set-key 'com-redo 'global-climacs-table
+(set-key 'com-redo
+ 'editing-table
'((#\x :control) (#\r :control)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Dynamic abbrevs
-(define-named-command com-dabbrev-expand ()
+(define-command (com-dabbrev-expand :name t :command-table editing-table) ()
(let* ((window (current-window))
(point (point window)))
(with-slots (original-prefix prefix-start-offset dabbrev-expansion-mark) window
@@ -1863,10 +2043,12 @@
(setf (offset dabbrev-expansion-mark) offset))))
(move))))))))
-(set-key 'com-dabbrev-expand 'global-climacs-table
+(set-key 'com-dabbrev-expand
+ 'editing-table
'((#\/ :meta)))
-(define-named-command com-backward-paragraph ((count 'integer :prompt "Number of paragraphs"))
+(define-command (com-backward-paragraph :name t :command-table movement-table)
+ ((count 'integer :prompt "Number of paragraphs"))
(let* ((pane (current-window))
(point (point pane))
(syntax (syntax (buffer pane))))
@@ -1875,10 +2057,11 @@
(loop repeat (- count) do (forward-paragraph point syntax)))))
(set-key `(com-backward-paragraph ,*numeric-argument-marker*)
- 'global-climacs-table
+ 'movement-table
'((#\{ :shift :meta)))
-(define-named-command com-forward-paragraph ((count 'integer :prompt "Number of paragraphs"))
+(define-command (com-forward-paragraph :name t :command-table movement-table)
+ ((count 'integer :prompt "Number of paragraphs"))
(let* ((pane (current-window))
(point (point pane))
(syntax (syntax (buffer pane))))
@@ -1887,10 +2070,11 @@
(loop repeat (- count) do (backward-paragraph point syntax)))))
(set-key `(com-forward-paragraph ,*numeric-argument-marker*)
- 'global-climacs-table
+ 'movement-table
'((#\} :shift :meta)))
-(define-named-command com-mark-paragraph ((count 'integer :prompt "Number of paragraphs"))
+(define-command (com-mark-paragraph :name t :command-table marking-table)
+ ((count 'integer :prompt "Number of paragraphs"))
(let* ((pane (current-window))
(point (point pane))
(mark (mark pane))
@@ -1905,10 +2089,11 @@
(loop repeat (- count) do (backward-paragraph mark syntax)))))
(set-key `(com-mark-paragraph ,*numeric-argument-marker*)
- 'global-climacs-table
+ 'marking-table
'((#\h :meta)))
-(define-named-command com-backward-sentence ((count 'integer :prompt "Number of sentences"))
+(define-command (com-backward-sentence :name t :command-table movement-table)
+ ((count 'integer :prompt "Number of sentences"))
(let* ((pane (current-window))
(point (point pane))
(syntax (syntax (buffer pane))))
@@ -1917,10 +2102,11 @@
(loop repeat (- count) do (forward-sentence point syntax)))))
(set-key `(com-backward-sentence ,*numeric-argument-marker*)
- 'global-climacs-table
+ 'movement-table
'((#\a :meta)))
-(define-named-command com-forward-sentence ((count 'integer :prompt "Number of sentences"))
+(define-command (com-forward-sentence :name t :command-table movement-table)
+ ((count 'integer :prompt "Number of sentences"))
(let* ((pane (current-window))
(point (point pane))
(syntax (syntax (buffer pane))))
@@ -1929,10 +2115,11 @@
(loop repeat (- count) do (backward-sentence point syntax)))))
(set-key `(com-forward-sentence ,*numeric-argument-marker*)
- 'global-climacs-table
+ 'movement-table
'((#\e :meta)))
-(define-named-command com-kill-sentence ((count 'integer :prompt "Number of sentences"))
+(define-command (com-kill-sentence :name t :command-table deletion-table)
+ ((count 'integer :prompt "Number of sentences"))
(let* ((pane (current-window))
(point (point pane))
(mark (clone-mark point))
@@ -1944,10 +2131,11 @@
(delete-region point mark)))
(set-key `(com-kill-sentence ,*numeric-argument-marker*)
- 'global-climacs-table
+ 'deletion-table
'((#\k :meta)))
-(define-named-command com-backward-kill-sentence ((count 'integer :prompt "Number of sentences"))
+(define-command (com-backward-kill-sentence :name t :command-table deletion-table)
+ ((count 'integer :prompt "Number of sentences"))
(let* ((pane (current-window))
(point (point pane))
(mark (clone-mark point))
@@ -1959,7 +2147,7 @@
(delete-region point mark)))
(set-key `(com-backward-kill-sentence ,*numeric-argument-marker*)
- 'global-climacs-table
+ 'deletion-table
'((#\x :control) (#\Backspace)))
(defun forward-page (mark &optional (count 1))
@@ -1968,7 +2156,8 @@
do (end-of-buffer mark)
(loop-finish)))
-(define-named-command com-forward-page ((count 'integer :prompt "Number of pages"))
+(define-command (com-forward-page :name t :command-table movement-table)
+ ((count 'integer :prompt "Number of pages"))
(let* ((pane (current-window))
(point (point pane)))
(if (plusp count)
@@ -1976,7 +2165,7 @@
(backward-page point count))))
(set-key `(com-forward-page ,*numeric-argument-marker*)
- 'global-climacs-table
+ 'movement-table
'((#\x :control) (#\])))
(defun backward-page (mark &optional (count 1))
@@ -1986,18 +2175,21 @@
else do (beginning-of-buffer mark)
(loop-finish)))
-(define-named-command com-backward-page ((count 'integer :prompt "Number of pages"))
+(define-command (com-backward-page :name t :command-table movement-table)
+ ((count 'integer :prompt "Number of pages"))
(let* ((pane (current-window))
(point (point pane)))
(if (plusp count)
(backward-page point count)
(forward-page point count))))
-(set-key `(com-backward-page ,*numeric-argument-marker*) 'global-climacs-table
+(set-key `(com-backward-page ,*numeric-argument-marker*)
+ 'movement-table
'((#\x :control) (#\[)))
-(define-named-command com-mark-page ((count 'integer :prompt "Move how many pages")
- (numargp 'boolean :prompt "Move to another page?"))
+(define-command (com-mark-page :name t :command-table marking-table)
+ ((count 'integer :prompt "Move how many pages")
+ (numargp 'boolean :prompt "Move to another page?"))
(let* ((pane (current-window))
(point (point pane))
(mark (mark pane)))
@@ -2010,10 +2202,10 @@
(forward-page mark 1)))
(set-key `(com-mark-page ,*numeric-argument-marker* ,*numeric-argument-p*)
- 'global-climacs-table
+ 'marking-table
'((#\x :control) (#\p :control)))
-(define-named-command com-count-lines-page ()
+(define-command (com-count-lines-page :name t :command-table info-table) ()
(let* ((pane (current-window))
(point (point pane))
(start (clone-mark point))
@@ -2025,10 +2217,11 @@
(after (number-of-lines-in-region point end)))
(display-message "Page has ~A lines (~A + ~A)" total before after))))
-(set-key 'com-count-lines-page 'global-climacs-table
+(set-key 'com-count-lines-page
+ 'info-table
'((#\x :control) (#\l)))
-(define-named-command com-count-lines-region ()
+(define-command (com-count-lines-region :name t :command-table info-table) ()
(let* ((pane (current-window))
(point (point pane))
(mark (mark pane))
@@ -2036,10 +2229,11 @@
(chars (abs (- (offset point) (offset mark)))))
(display-message "Region has ~D line~:P, ~D character~:P." lines chars)))
-(set-key 'com-count-lines-region 'global-climacs-table
+(set-key 'com-count-lines-region
+ 'info-table
'((#\= :meta)))
-(define-named-command com-what-cursor-position ()
+(define-command (com-what-cursor-position :name t :command-table info-table) ()
(let* ((pane (current-window))
(point (point pane))
(buffer (buffer pane))
@@ -2051,10 +2245,12 @@
char (char-code char) offset size
(round (* 100 (/ offset size))) column)))
-(set-key 'com-what-cursor-position 'global-climacs-table
+(set-key 'com-what-cursor-position
+ 'info-table
'((#\x :control) (#\=)))
-(define-named-command com-eval-expression ((insertp 'boolean :prompt "Insert?"))
+(define-command (com-eval-expression :name t :command-table base-table)
+ ((insertp 'boolean :prompt "Insert?"))
(let* ((*package* (find-package :climacs-gui))
(string (handler-case (accept 'string :prompt "Eval")
(error () (progn (beep)
@@ -2071,7 +2267,7 @@
(display-message result))))
(set-key `(com-eval-expression ,*numeric-argument-p*)
- 'global-climacs-table
+ 'base-table
'((#\: :shift :meta)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -2079,14 +2275,15 @@
;;; Commenting
;;; figure out how to make commands without key bindings accept numeric arguments.
-(define-named-command com-comment-region ()
+(define-command (com-comment-region :name t :command-table comment-table) ()
(let* ((pane (current-window))
(point (point pane))
(mark (mark pane))
(syntax (syntax (buffer pane))))
(comment-region syntax point mark)))
-(define-named-command com-backward-expression ((count 'integer :prompt "Number of expressions"))
+(define-command (com-backward-expression :name t :command-table movement-table)
+ ((count 'integer :prompt "Number of expressions"))
(let* ((pane (current-window))
(point (point pane))
(syntax (syntax (buffer pane))))
@@ -2095,10 +2292,11 @@
(loop repeat (- count) do (forward-expression point syntax)))))
(set-key `(com-backward-expression ,*numeric-argument-marker*)
- 'global-climacs-table
+ 'movement-table
'((#\b :control :meta)))
-(define-named-command com-forward-expression ((count 'integer :prompt "Number of expresssions"))
+(define-command (com-forward-expression :name t :command-table movement-table)
+ ((count 'integer :prompt "Number of expresssions"))
(let* ((pane (current-window))
(point (point pane))
(syntax (syntax (buffer pane))))
@@ -2107,10 +2305,11 @@
(loop repeat (- count) do (backward-expression point syntax)))))
(set-key `(com-forward-expression ,*numeric-argument-marker*)
- 'global-climacs-table
+ 'movement-table
'((#\f :control :meta)))
-(define-named-command com-mark-expression ((count 'integer :prompt "Number of expressions"))
+(define-command (com-mark-expression :name t :command-table marking-table)
+ ((count 'integer :prompt "Number of expressions"))
(let* ((pane (current-window))
(point (point pane))
(mark (mark pane))
@@ -2122,10 +2321,11 @@
(loop repeat (- count) do (backward-expression mark syntax)))))
(set-key `(com-mark-expression ,*numeric-argument-marker*)
- 'global-climacs-table
+ 'marking-table
'((#\@ :shift :control :meta)))
-(define-named-command com-kill-expression ((count 'integer :prompt "Number of expressions"))
+(define-command (com-kill-expression :name t :command-table deletion-table)
+ ((count 'integer :prompt "Number of expressions"))
(let* ((pane (current-window))
(point (point pane))
(mark (clone-mark point))
@@ -2137,10 +2337,10 @@
(delete-region mark point)))
(set-key `(com-kill-expression ,*numeric-argument-marker*)
- 'global-climacs-table
+ 'deletion-table
'((#\k :control :meta)))
-(define-named-command com-backward-kill-expression
+(define-command (com-backward-kill-expression :name t :command-table deletion-table)
((count 'integer :prompt "Number of expressions"))
(let* ((pane (current-window))
(point (point pane))
@@ -2153,10 +2353,50 @@
(delete-region mark point)))
(set-key `(com-backward-kill-expression ,*numeric-argument-marker*)
- 'global-climacs-table
+ 'deletion-table
'((#\Backspace :control :meta)))
-(define-named-command com-forward-list ((count 'integer :prompt "Number of lists"))
+;; (defparameter *insert-pair-alist*
+;; '((#\( #\)) (#\[ #\]) (#\{ #\}) (#\< #\>) (#\" #\") (#\' #\') (#\` #\')))
+
+(defun insert-pair (mark syntax &optional (count 0) (open #\() (close #\)))
+ (cond ((> count 0)
+ (loop while (and (not (end-of-buffer-p mark))
+ (whitespacep (object-after mark)))
+ do (forward-object mark)))
+ ((< count 0)
+ (setf count (- count))
+ (loop repeat count do (backward-expression mark syntax))))
+ (unless (or (beginning-of-buffer-p mark)
+ (whitespacep (object-before mark)))
+ (insert-object mark #\Space))
+ (insert-object mark open)
+ (let ((here (clone-mark mark)))
+ (loop repeat count
+ do (forward-expression here syntax))
+ (insert-object here close)
+ (unless (or (end-of-buffer-p here)
+ (whitespacep (object-after here)))
+ (insert-object here #\Space))))
+
+(defun insert-parentheses (mark syntax count)
+ (insert-pair mark syntax count #\( #\)))
+
+(define-command (com-insert-parentheses :name t :command-table editing-table)
+ ((count 'integer :prompt "Number of expressions")
+ (wrap-p 'boolean :prompt "Wrap expressions?"))
+ (let* ((pane (current-window))
+ (point (point pane))
+ (syntax (syntax (buffer pane))))
+ (unless wrap-p (setf count 0))
+ (insert-parentheses point syntax count)))
+
+(set-key `(com-insert-parentheses ,*numeric-argument-marker* ,*numeric-argument-p*)
+ 'editing-table
+ '((#\( :meta)))
+
+(define-command (com-forward-list :name t :command-table movement-table)
+ ((count 'integer :prompt "Number of lists"))
(let* ((pane (current-window))
(point (point pane))
(syntax (syntax (buffer pane))))
@@ -2165,10 +2405,11 @@
(loop repeat (- count) do (backward-list point syntax)))))
(set-key `(com-forward-list ,*numeric-argument-marker*)
- 'global-climacs-table
+ 'movement-table
'((#\n :control :meta)))
-(define-named-command com-backward-list ((count 'integer :prompt "Number of lists"))
+(define-command (com-backward-list :name t :command-table movement-table)
+ ((count 'integer :prompt "Number of lists"))
(let* ((pane (current-window))
(point (point pane))
(syntax (syntax (buffer pane))))
@@ -2177,10 +2418,11 @@
(loop repeat (- count) do (forward-list point syntax)))))
(set-key `(com-backward-list ,*numeric-argument-marker*)
- 'global-climacs-table
+ 'movement-table
'((#\p :control :meta)))
-(define-named-command com-down-list ((count 'integer :prompt "Number of lists"))
+(define-command (com-down-list :name t :command-table movement-table)
+ ((count 'integer :prompt "Number of lists"))
(let* ((pane (current-window))
(point (point pane))
(syntax (syntax (buffer pane))))
@@ -2189,10 +2431,11 @@
(loop repeat (- count) do (backward-down-list point syntax)))))
(set-key `(com-down-list ,*numeric-argument-marker*)
- 'global-climacs-table
+ 'movement-table
'((#\d :control :meta)))
-(define-named-command com-backward-down-list ((count 'integer :prompt "Number of lists"))
+(define-command (com-backward-down-list :name t :command-table movement-table)
+ ((count 'integer :prompt "Number of lists"))
(let* ((pane (current-window))
(point (point pane))
(syntax (syntax (buffer pane))))
@@ -2200,7 +2443,8 @@
(loop repeat count do (backward-down-list point syntax))
(loop repeat (- count) do (down-list point syntax)))))
-(define-named-command com-backward-up-list ((count 'integer :prompt "Number of lists"))
+(define-command (com-backward-up-list :name t :command-table movement-table)
+ ((count 'integer :prompt "Number of lists"))
(let* ((pane (current-window))
(point (point pane))
(syntax (syntax (buffer pane))))
@@ -2209,10 +2453,10 @@
(loop repeat (- count) do (up-list point syntax)))))
(set-key `(com-backward-up-list ,*numeric-argument-marker*)
- 'global-climacs-table
+ 'movement-table
'((#\u :control :meta)))
-(define-named-command com-up-list ((count 'integer :prompt "Number of lists"))
+(define-command (com-up-list :name t :command-table movement-table) ((count 'integer :prompt "Number of lists"))
(let* ((pane (current-window))
(point (point pane))
(syntax (syntax (buffer pane))))
@@ -2220,16 +2464,18 @@
(loop repeat count do (up-list point syntax))
(loop repeat (- count) do (backward-up-list point syntax)))))
-(define-named-command com-eval-defun ()
+(define-command (com-eval-defun :name t :command-table lisp-table) ()
(let* ((pane (current-window))
(point (point pane))
(syntax (syntax (buffer pane))))
(eval-defun point syntax)))
-(set-key 'com-eval-defun 'global-climacs-table
+(set-key 'com-eval-defun
+ 'lisp-table
'((#\x :control :meta)))
-(define-named-command com-beginning-of-definition ((count 'integer :prompt "Number of definitions"))
+(define-command (com-beginning-of-definition :name t :command-table movement-table)
+ ((count 'integer :prompt "Number of definitions"))
(let* ((pane (current-window))
(point (point pane))
(syntax (syntax (buffer pane))))
@@ -2238,10 +2484,11 @@
(loop repeat (- count) do (end-of-definition point syntax)))))
(set-key `(com-beginning-of-definition ,*numeric-argument-marker*)
- 'global-climacs-table
+ 'movement-table
'((#\a :control :meta)))
-(define-named-command com-end-of-definition ((count 'integer :prompt "Number of definitions"))
+(define-command (com-end-of-definition :name t :command-table movement-table)
+ ((count 'integer :prompt "Number of definitions"))
(let* ((pane (current-window))
(point (point pane))
(syntax (syntax (buffer pane))))
@@ -2250,10 +2497,10 @@
(loop repeat (- count) do (beginning-of-definition point syntax)))))
(set-key `(com-end-of-definition ,*numeric-argument-marker*)
- 'global-climacs-table
+ 'movement-table
'((#\e :control :meta)))
-(define-named-command com-mark-definition ()
+(define-command (com-mark-definition :name t :command-table marking-table) ()
(let* ((pane (current-window))
(point (point pane))
(mark (mark pane))
@@ -2263,10 +2510,11 @@
(setf (offset mark) (offset point)))
(end-of-definition mark syntax)))
-(set-key 'com-mark-definition 'global-climacs-table
+(set-key 'com-mark-definition
+ 'marking-table
'((#\h :control :meta)))
-(define-named-command com-package ()
+(define-command (com-package :name t :command-table lisp-table) ()
(let* ((pane (current-window))
(syntax (syntax (buffer pane)))
(package (climacs-lisp-syntax::package-of syntax)))
@@ -2276,22 +2524,22 @@
;;;
;;; For testing purposes
-(define-named-command com-reset-profile ()
+(define-command (com-reset-profile :name t :command-table development-table) ()
#+sbcl (sb-profile:reset)
#-sbcl nil)
-(define-named-command com-report-profile ()
+(define-command (com-report-profile :name t :command-table development-table) ()
#+sbcl (sb-profile:report)
#-sbcl nil)
-(define-named-command com-recompile ()
+(define-command (com-recompile :name t :command-table development-table) ()
(asdf:operate 'asdf:load-op :climacs))
(define-gesture-name :select-other :pointer-button-press (:left :meta) :unique nil)
(define-presentation-translator lisp-string-to-string
- (climacs-lisp-syntax::lisp-string string global-climacs-table
+ (climacs-lisp-syntax::lisp-string string development-table
:gesture :select-other
:tester-definitive t
:menu nil
@@ -2299,115 +2547,116 @@
(object)
object)
-(define-named-command com-accept-string ()
+(define-command (com-accept-string :name t :command-table development-table) ()
(display-message (format nil "~s" (accept 'string))))
-(define-named-command com-accept-symbol ()
+(define-command (com-accept-symbol :name t :command-table development-table) ()
(display-message (format nil "~s" (accept 'symbol))))
-(define-named-command com-accept-lisp-string ()
+(define-command (com-accept-lisp-string :name t :command-table development-table) ()
(display-message (format nil "~s" (accept 'lisp-string))))
-(define-named-command com-toggle-visible-mark ()
+(define-command (com-visible-mark :name t :command-table marking-table) ()
(setf (mark-visible-p (current-window)) (not (mark-visible-p (current-window)))))
(loop for code from (char-code #\Space) to (char-code #\~)
do (set-key `(com-self-insert ,*numeric-argument-marker*)
- 'global-climacs-table
+ 'self-insert-table
(list (list (code-char code)))))
(set-key `(com-self-insert ,*numeric-argument-marker*)
- 'global-climacs-table
+ 'self-insert-table
'((#\Newline)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Some Unicode stuff
-(define-named-command com-insert-charcode ((code 'integer :prompt "Code point"))
+(define-command (com-insert-charcode :name t :command-table self-insert-table)
+ ((code 'integer :prompt "Code point"))
(insert-object (point (current-window)) (code-char code)))
-(set-key '(com-insert-charcode 193) 'global-climacs-table '((:dead--acute)(#\A)))
-(set-key '(com-insert-charcode 201) 'global-climacs-table '((:dead--acute)(#\E)))
-(set-key '(com-insert-charcode 205) 'global-climacs-table '((:dead--acute)(#\I)))
-(set-key '(com-insert-charcode 211) 'global-climacs-table '((:dead--acute)(#\O)))
-(set-key '(com-insert-charcode 218) 'global-climacs-table '((:dead--acute)(#\U)))
-(set-key '(com-insert-charcode 221) 'global-climacs-table '((:dead--acute)(#\Y)))
-(set-key '(com-insert-charcode 225) 'global-climacs-table '((:dead--acute)(#\a)))
-(set-key '(com-insert-charcode 233) 'global-climacs-table '((:dead--acute)(#\e)))
-(set-key '(com-insert-charcode 237) 'global-climacs-table '((:dead--acute)(#\i)))
-(set-key '(com-insert-charcode 243) 'global-climacs-table '((:dead--acute)(#\o)))
-(set-key '(com-insert-charcode 250) 'global-climacs-table '((:dead--acute)(#\u)))
-(set-key '(com-insert-charcode 253) 'global-climacs-table '((:dead--acute)(#\y)))
-(set-key '(com-insert-charcode 199) 'global-climacs-table '((:dead--acute)(#\C)))
-(set-key '(com-insert-charcode 231) 'global-climacs-table '((:dead--acute)(#\c)))
-(set-key '(com-insert-charcode 215) 'global-climacs-table '((:dead--acute)(#\x)))
-(set-key '(com-insert-charcode 247) 'global-climacs-table '((:dead--acute)(#\-)))
-(set-key '(com-insert-charcode 222) 'global-climacs-table '((:dead--acute)(#\T)))
-(set-key '(com-insert-charcode 254) 'global-climacs-table '((:dead--acute)(#\t)))
-(set-key '(com-insert-charcode 223) 'global-climacs-table '((:dead--acute)(#\s)))
-(set-key '(com-insert-charcode 39) 'global-climacs-table '((:dead--acute)(#\Space)))
-
-(set-key '(com-insert-charcode 197) 'global-climacs-table '((:dead--acute)(:dead--acute)(#\A)))
-(set-key '(com-insert-charcode 229) 'global-climacs-table '((:dead--acute)(:dead--acute)(#\a)))
-
-(set-key '(com-insert-charcode 192) 'global-climacs-table '((:dead--grave)(#\A)))
-(set-key '(com-insert-charcode 200) 'global-climacs-table '((:dead--grave)(#\E)))
-(set-key '(com-insert-charcode 204) 'global-climacs-table '((:dead--grave)(#\I)))
-(set-key '(com-insert-charcode 210) 'global-climacs-table '((:dead--grave)(#\O)))
-(set-key '(com-insert-charcode 217) 'global-climacs-table '((:dead--grave)(#\U)))
-(set-key '(com-insert-charcode 224) 'global-climacs-table '((:dead--grave)(#\a)))
-(set-key '(com-insert-charcode 232) 'global-climacs-table '((:dead--grave)(#\e)))
-(set-key '(com-insert-charcode 236) 'global-climacs-table '((:dead--grave)(#\i)))
-(set-key '(com-insert-charcode 242) 'global-climacs-table '((:dead--grave)(#\o)))
-(set-key '(com-insert-charcode 249) 'global-climacs-table '((:dead--grave)(#\u)))
-(set-key '(com-insert-charcode 96) 'global-climacs-table '((:dead--grave)(#\Space)))
-
-(set-key '(com-insert-charcode 196) 'global-climacs-table '((:dead--diaeresis :shift)(#\A)))
-(set-key '(com-insert-charcode 203) 'global-climacs-table '((:dead--diaeresis :shift)(#\E)))
-(set-key '(com-insert-charcode 207) 'global-climacs-table '((:dead--diaeresis :shift)(#\I)))
-(set-key '(com-insert-charcode 214) 'global-climacs-table '((:dead--diaeresis :shift)(#\O)))
-(set-key '(com-insert-charcode 220) 'global-climacs-table '((:dead--diaeresis :shift)(#\U)))
-(set-key '(com-insert-charcode 228) 'global-climacs-table '((:dead--diaeresis :shift)(#\a)))
-(set-key '(com-insert-charcode 235) 'global-climacs-table '((:dead--diaeresis :shift)(#\e)))
-(set-key '(com-insert-charcode 239) 'global-climacs-table '((:dead--diaeresis :shift)(#\i)))
-(set-key '(com-insert-charcode 246) 'global-climacs-table '((:dead--diaeresis :shift)(#\o)))
-(set-key '(com-insert-charcode 252) 'global-climacs-table '((:dead--diaeresis :shift)(#\u)))
-(set-key '(com-insert-charcode 255) 'global-climacs-table '((:dead--diaeresis :shift)(#\y)))
-(set-key '(com-insert-charcode 34) 'global-climacs-table '((:dead--diaeresis :shift)(#\Space)))
-
-(set-key '(com-insert-charcode 195) 'global-climacs-table '((:dead--tilde :shift)(#\A)))
-(set-key '(com-insert-charcode 209) 'global-climacs-table '((:dead--tilde :shift)(#\N)))
-(set-key '(com-insert-charcode 227) 'global-climacs-table '((:dead--tilde :shift)(#\a)))
-(set-key '(com-insert-charcode 241) 'global-climacs-table '((:dead--tilde :shift)(#\n)))
-(set-key '(com-insert-charcode 198) 'global-climacs-table '((:dead--tilde :shift)(#\E)))
-(set-key '(com-insert-charcode 230) 'global-climacs-table '((:dead--tilde :shift)(#\e)))
-(set-key '(com-insert-charcode 208) 'global-climacs-table '((:dead--tilde :shift)(#\D)))
-(set-key '(com-insert-charcode 240) 'global-climacs-table '((:dead--tilde :shift)(#\d)))
-(set-key '(com-insert-charcode 216) 'global-climacs-table '((:dead--tilde :shift)(#\O)))
-(set-key '(com-insert-charcode 248) 'global-climacs-table '((:dead--tilde :shift)(#\o)))
-(set-key '(com-insert-charcode 126) 'global-climacs-table '((:dead--tilde :shift)(#\Space)))
-
-(set-key '(com-insert-charcode 194) 'global-climacs-table '((:dead--circumflex :shift)(#\A)))
-(set-key '(com-insert-charcode 202) 'global-climacs-table '((:dead--circumflex :shift)(#\E)))
-(set-key '(com-insert-charcode 206) 'global-climacs-table '((:dead--circumflex :shift)(#\I)))
-(set-key '(com-insert-charcode 212) 'global-climacs-table '((:dead--circumflex :shift)(#\O)))
-(set-key '(com-insert-charcode 219) 'global-climacs-table '((:dead--circumflex :shift)(#\U)))
-(set-key '(com-insert-charcode 226) 'global-climacs-table '((:dead--circumflex :shift)(#\a)))
-(set-key '(com-insert-charcode 234) 'global-climacs-table '((:dead--circumflex :shift)(#\e)))
-(set-key '(com-insert-charcode 238) 'global-climacs-table '((:dead--circumflex :shift)(#\i)))
-(set-key '(com-insert-charcode 244) 'global-climacs-table '((:dead--circumflex :shift)(#\o)))
-(set-key '(com-insert-charcode 251) 'global-climacs-table '((:dead--circumflex :shift)(#\u)))
-(set-key '(com-insert-charcode 94) 'global-climacs-table '((:dead--circumflex :shift)(#\Space)))
+(set-key '(com-insert-charcode 193) 'self-insert-table '((:dead--acute)(#\A)))
+(set-key '(com-insert-charcode 201) 'self-insert-table '((:dead--acute)(#\E)))
+(set-key '(com-insert-charcode 205) 'self-insert-table '((:dead--acute)(#\I)))
+(set-key '(com-insert-charcode 211) 'self-insert-table '((:dead--acute)(#\O)))
+(set-key '(com-insert-charcode 218) 'self-insert-table '((:dead--acute)(#\U)))
+(set-key '(com-insert-charcode 221) 'self-insert-table '((:dead--acute)(#\Y)))
+(set-key '(com-insert-charcode 225) 'self-insert-table '((:dead--acute)(#\a)))
+(set-key '(com-insert-charcode 233) 'self-insert-table '((:dead--acute)(#\e)))
+(set-key '(com-insert-charcode 237) 'self-insert-table '((:dead--acute)(#\i)))
+(set-key '(com-insert-charcode 243) 'self-insert-table '((:dead--acute)(#\o)))
+(set-key '(com-insert-charcode 250) 'self-insert-table '((:dead--acute)(#\u)))
+(set-key '(com-insert-charcode 253) 'self-insert-table '((:dead--acute)(#\y)))
+(set-key '(com-insert-charcode 199) 'self-insert-table '((:dead--acute)(#\C)))
+(set-key '(com-insert-charcode 231) 'self-insert-table '((:dead--acute)(#\c)))
+(set-key '(com-insert-charcode 215) 'self-insert-table '((:dead--acute)(#\x)))
+(set-key '(com-insert-charcode 247) 'self-insert-table '((:dead--acute)(#\-)))
+(set-key '(com-insert-charcode 222) 'self-insert-table '((:dead--acute)(#\T)))
+(set-key '(com-insert-charcode 254) 'self-insert-table '((:dead--acute)(#\t)))
+(set-key '(com-insert-charcode 223) 'self-insert-table '((:dead--acute)(#\s)))
+(set-key '(com-insert-charcode 39) 'self-insert-table '((:dead--acute)(#\Space)))
+
+(set-key '(com-insert-charcode 197) 'self-insert-table '((:dead--acute)(:dead--acute)(#\A)))
+(set-key '(com-insert-charcode 229) 'self-insert-table '((:dead--acute)(:dead--acute)(#\a)))
+
+(set-key '(com-insert-charcode 192) 'self-insert-table '((:dead--grave)(#\A)))
+(set-key '(com-insert-charcode 200) 'self-insert-table '((:dead--grave)(#\E)))
+(set-key '(com-insert-charcode 204) 'self-insert-table '((:dead--grave)(#\I)))
+(set-key '(com-insert-charcode 210) 'self-insert-table '((:dead--grave)(#\O)))
+(set-key '(com-insert-charcode 217) 'self-insert-table '((:dead--grave)(#\U)))
+(set-key '(com-insert-charcode 224) 'self-insert-table '((:dead--grave)(#\a)))
+(set-key '(com-insert-charcode 232) 'self-insert-table '((:dead--grave)(#\e)))
+(set-key '(com-insert-charcode 236) 'self-insert-table '((:dead--grave)(#\i)))
+(set-key '(com-insert-charcode 242) 'self-insert-table '((:dead--grave)(#\o)))
+(set-key '(com-insert-charcode 249) 'self-insert-table '((:dead--grave)(#\u)))
+(set-key '(com-insert-charcode 96) 'self-insert-table '((:dead--grave)(#\Space)))
+
+(set-key '(com-insert-charcode 196) 'self-insert-table '((:dead--diaeresis :shift)(#\A)))
+(set-key '(com-insert-charcode 203) 'self-insert-table '((:dead--diaeresis :shift)(#\E)))
+(set-key '(com-insert-charcode 207) 'self-insert-table '((:dead--diaeresis :shift)(#\I)))
+(set-key '(com-insert-charcode 214) 'self-insert-table '((:dead--diaeresis :shift)(#\O)))
+(set-key '(com-insert-charcode 220) 'self-insert-table '((:dead--diaeresis :shift)(#\U)))
+(set-key '(com-insert-charcode 228) 'self-insert-table '((:dead--diaeresis :shift)(#\a)))
+(set-key '(com-insert-charcode 235) 'self-insert-table '((:dead--diaeresis :shift)(#\e)))
+(set-key '(com-insert-charcode 239) 'self-insert-table '((:dead--diaeresis :shift)(#\i)))
+(set-key '(com-insert-charcode 246) 'self-insert-table '((:dead--diaeresis :shift)(#\o)))
+(set-key '(com-insert-charcode 252) 'self-insert-table '((:dead--diaeresis :shift)(#\u)))
+(set-key '(com-insert-charcode 255) 'self-insert-table '((:dead--diaeresis :shift)(#\y)))
+(set-key '(com-insert-charcode 34) 'self-insert-table '((:dead--diaeresis :shift)(#\Space)))
+
+(set-key '(com-insert-charcode 195) 'self-insert-table '((:dead--tilde :shift)(#\A)))
+(set-key '(com-insert-charcode 209) 'self-insert-table '((:dead--tilde :shift)(#\N)))
+(set-key '(com-insert-charcode 227) 'self-insert-table '((:dead--tilde :shift)(#\a)))
+(set-key '(com-insert-charcode 241) 'self-insert-table '((:dead--tilde :shift)(#\n)))
+(set-key '(com-insert-charcode 198) 'self-insert-table '((:dead--tilde :shift)(#\E)))
+(set-key '(com-insert-charcode 230) 'self-insert-table '((:dead--tilde :shift)(#\e)))
+(set-key '(com-insert-charcode 208) 'self-insert-table '((:dead--tilde :shift)(#\D)))
+(set-key '(com-insert-charcode 240) 'self-insert-table '((:dead--tilde :shift)(#\d)))
+(set-key '(com-insert-charcode 216) 'self-insert-table '((:dead--tilde :shift)(#\O)))
+(set-key '(com-insert-charcode 248) 'self-insert-table '((:dead--tilde :shift)(#\o)))
+(set-key '(com-insert-charcode 126) 'self-insert-table '((:dead--tilde :shift)(#\Space)))
+
+(set-key '(com-insert-charcode 194) 'self-insert-table '((:dead--circumflex :shift)(#\A)))
+(set-key '(com-insert-charcode 202) 'self-insert-table '((:dead--circumflex :shift)(#\E)))
+(set-key '(com-insert-charcode 206) 'self-insert-table '((:dead--circumflex :shift)(#\I)))
+(set-key '(com-insert-charcode 212) 'self-insert-table '((:dead--circumflex :shift)(#\O)))
+(set-key '(com-insert-charcode 219) 'self-insert-table '((:dead--circumflex :shift)(#\U)))
+(set-key '(com-insert-charcode 226) 'self-insert-table '((:dead--circumflex :shift)(#\a)))
+(set-key '(com-insert-charcode 234) 'self-insert-table '((:dead--circumflex :shift)(#\e)))
+(set-key '(com-insert-charcode 238) 'self-insert-table '((:dead--circumflex :shift)(#\i)))
+(set-key '(com-insert-charcode 244) 'self-insert-table '((:dead--circumflex :shift)(#\o)))
+(set-key '(com-insert-charcode 251) 'self-insert-table '((:dead--circumflex :shift)(#\u)))
+(set-key '(com-insert-charcode 94) 'self-insert-table '((:dead--circumflex :shift)(#\Space)))
-(define-named-command com-regex-search-forward ()
+(define-command (com-regex-search-forward :name t :command-table search-table) ()
(let ((string (accept 'string :prompt "RE search"
:delimiter-gestures nil
:activation-gestures
'(:newline :return))))
(re-search-forward (point (current-window)) string)))
-(define-named-command com-regex-search-backward ()
+(define-command (com-regex-search-backward :name t :command-table search-table) ()
(let ((string (accept 'string :prompt "RE search backward"
:delimiter-gestures nil
:activation-gestures
Index: climacs/esa.lisp
diff -u climacs/esa.lisp:1.17 climacs/esa.lisp:1.18
--- climacs/esa.lisp:1.17 Tue Sep 6 23:30:34 2005
+++ climacs/esa.lisp Tue Sep 13 21:23:59 2005
@@ -466,6 +466,17 @@
(helper command-table nil)
results)))
+(defun find-all-keystrokes-and-commands-with-inheritance (start-table)
+ (let ((results '()))
+ (labels ((helper (table)
+ (let ((res (find-all-keystrokes-and-commands table)))
+ (when res (setf results (nconc res results)))
+ (dolist (subtable (command-table-inherit-from
+ (find-command-table table)))
+ (helper subtable)))))
+ (helper start-table))
+ results))
+
(defun sort-by-name (list)
(sort list #'string< :key (lambda (item) (symbol-name (second item)))))
@@ -486,8 +497,9 @@
&optional (sort-function #'sort-by-name))
(formatting-table (stream)
(loop for (keys command)
- in (funcall sort-function (find-all-keystrokes-and-commands
- command-table))
+ in (funcall sort-function
+ (find-all-keystrokes-and-commands-with-inheritance
+ command-table))
do (formatting-row (stream)
(formatting-cell (stream :align-x :right)
(with-text-style (stream '(:sans-serif nil nil))
