[climacs-cvs] CVS climacs
thenriksen
thenriksen at common-lisp.net
Mon Jul 24 16:33:16 UTC 2006
Update of /project/climacs/cvsroot/climacs
In directory clnet:/tmp/cvs-serv13591
Modified Files:
window-commands.lisp search-commands.lisp packages.lisp
misc-commands.lisp kill-ring.lisp gui.lisp base.lisp
Log Message:
* Moved some functions from window-commands.lisp to gui.lisp (and the
CLIMACs-GUI package) and export them.
* The kill ring is no longer a global, special symbol, thus fixing a
bunch of problems regarding sharing of kill rings between instances
of Climacs (and remembering the kill ring across invocations).
* Various yank-commands no longer signal an error when the kill ring
is empty. This is done by handling the flexichain:at-end-error
condition, which is suboptimal - user code should not need to be
aware of the implementation of the kill ring. Will be fixed at some
point.
CVS problems made it too hard to divide this up into several patches,
sorry.
--- /project/climacs/cvsroot/climacs/window-commands.lisp 2006/07/24 13:24:40 1.9
+++ /project/climacs/cvsroot/climacs/window-commands.lisp 2006/07/24 16:33:16 1.10
@@ -32,123 +32,6 @@
;;;
;;; Commands for splitting windows
-(defun replace-constellation (constellation additional-constellation vertical-p)
- (let* ((parent (sheet-parent constellation))
- (children (sheet-children parent))
- (first (first children))
- (second (second children))
- (third (third children))
- (first-split-p (= (length (sheet-children parent)) 2))
- (parent-region (sheet-region parent))
- (parent-height (rectangle-height parent-region))
- (parent-width (rectangle-width parent-region))
- (filler (when first-split-p (make-pane 'basic-pane))) ;Prevents resizing.
- (adjust #+mcclim (make-pane 'clim-extensions:box-adjuster-gadget)))
- (assert (member constellation children))
-
- (when first-split-p (setf (sheet-region filler) (sheet-region parent))
- (sheet-adopt-child parent filler))
-
- (sheet-disown-child parent constellation)
-
- (if vertical-p
- (resize-sheet constellation parent-width (/ parent-height 2))
- (resize-sheet constellation (/ parent-width 2) parent-height))
-
- (let ((new (if vertical-p
- (vertically ()
- constellation adjust additional-constellation)
- (horizontally ()
- constellation adjust additional-constellation))))
- (sheet-adopt-child parent new)
-
- (when first-split-p (sheet-disown-child parent filler))
- (reorder-sheets parent
- (if (eq constellation first)
- (if third
- (list new second third)
- (list new second))
- (if third
- (list first second new)
- (list first new)))))))
-
-(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 :foreground *fg-color* :background *bg-color*
- :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 (&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."
- (let* ((extended-pane
- (make-pane 'extended-pane
- :width 900 :height 400
- :name 'window
- :end-of-line-action :scroll
- :incremental-redisplay t
- :background *bg-color*
- :foreground *fg-color*
- :display-function 'display-window
- :command-table 'global-climacs-table))
- (vbox
- (vertically ()
- (if with-scrollbars
- (scrolling ()
- extended-pane)
- extended-pane)
- (make-pane 'climacs-info-pane
- :background *info-bg-color*
- :foreground *info-fg-color*
- :master-pane extended-pane
- :width 900))))
- (values vbox extended-pane)))
-
-(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 (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 vertically-p)
- (full-redisplay current-window)
- (full-redisplay new-pane)
- new-pane))))
-
(define-command (com-split-window-vertically :name t :command-table window-table) ()
(split-window t))
@@ -163,20 +46,6 @@
'window-table
'((#\x :control) (#\3)))
-(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*))))))
- ;; Try to avoid setting the point in a typeout pane. FIXME: This is a kludge.
- (if (and (subtypep 'typeout-pane (type-of (car (windows *application-frame*))))
- (> (length (windows *application-frame*)) 1))
- (other-window)
- (setf *standard-output* (car (windows *application-frame*)))))
-
(define-command (com-other-window :name t :command-table window-table) ()
(other-window))
@@ -282,33 +151,6 @@
'window-table
'((#\V :control :meta :shift)))
-(defun delete-window (&optional (window (current-window)))
- (unless (null (cdr (windows *application-frame*)))
- (let* ((constellation (find-parent window))
- (box (sheet-parent constellation))
- (box-children (sheet-children box))
- (other (if (eq constellation (first box-children))
- (third box-children)
- (first box-children)))
- (parent (sheet-parent box))
- (children (sheet-children parent))
- (first (first children))
- (second (second children))
- (third (third children)))
- (setf (windows *application-frame*)
- (remove window (windows *application-frame*)))
- (setf *standard-output* (car (windows *application-frame*)))
- (sheet-disown-child box other)
- (sheet-adopt-child parent other)
- (sheet-disown-child parent box)
- (reorder-sheets parent (if (eq box first)
- (if third
- (list other second third)
- (list other second))
- (if third
- (list first second other)
- (list first other)))))))
-
(define-command (com-delete-window :name t :command-table window-table) ()
(delete-window))
--- /project/climacs/cvsroot/climacs/search-commands.lisp 2006/07/24 13:24:40 1.9
+++ /project/climacs/cvsroot/climacs/search-commands.lisp 2006/07/24 16:33:16 1.10
@@ -209,7 +209,9 @@
(define-command (com-isearch-append-kill :name t :command-table isearch-climacs-table) ()
(let* ((pane (current-window))
(states (isearch-states pane))
- (yank (kill-ring-yank *kill-ring*))
+ (yank (handler-case (kill-ring-yank *kill-ring*)
+ (flexichain:at-end-error ()
+ "")))
(string (concatenate 'string
(search-string (first states))
yank))
--- /project/climacs/cvsroot/climacs/packages.lisp 2006/07/24 13:24:40 1.106
+++ /project/climacs/cvsroot/climacs/packages.lisp 2006/07/24 16:33:16 1.107
@@ -70,7 +70,8 @@
#:append-next-p
#:reset-yank-position #:rotate-yank-position #:kill-ring-yank
#:kill-ring-standard-push #:kill-ring-concatenating-push
- #:kill-ring-reverse-concatenating-push)
+ #:kill-ring-reverse-concatenating-push
+ #:*kill-ring*)
(:documentation "An implementation of a kill ring."))
(defpackage :climacs-base
@@ -99,8 +100,7 @@
#:downcase-buffer-region #:downcase-region
#:upcase-buffer-region #:upcase-region
#:capitalize-buffer-region #:capitalize-region
- #:tabify-region #:untabify-region
- #:*kill-ring*)
+ #:tabify-region #:untabify-region)
(:documentation "Basic functionality built on top of the buffer
protocol. Here is where we define slightly higher level
functions, that can be directly implemented in terms of the
@@ -318,6 +318,8 @@
#:extended-pane
#:climacs-info-pane
+ #:typeout-pane
+ #:kill-ring
;; GUI functions follow.
#:current-window
@@ -333,6 +335,10 @@
#:erase-buffer
#:buffer-pane-p
#:display-window
+ #:split-window
+ #:typeout-window
+ #:delete-window
+ #:other-window
;; Some configuration variables
#:*bg-color*
--- /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/07/24 13:24:40 1.17
+++ /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/07/24 16:33:16 1.18
@@ -476,7 +476,9 @@
;; Copies an element from a kill-ring to a buffer at the given offset
(define-command (com-yank :name t :command-table editing-table) ()
"Insert the objects most recently added to the kill ring at point."
- (insert-sequence (point (current-window)) (kill-ring-yank *kill-ring*)))
+ (handler-case (insert-sequence (point (current-window)) (kill-ring-yank *kill-ring*))
+ (flexichain:at-end-error ()
+ (display-message "Kill ring is empty"))))
(set-key 'com-yank
'editing-table
@@ -510,15 +512,17 @@
Must be given immediately following a Yank or Rotate Yank command.
The replacement objects are those before the previously yanked
objects in the kill ring."
- (let* ((pane (current-window))
- (point (point pane))
- (last-yank (kill-ring-yank *kill-ring*)))
- (if (eq (previous-command pane)
- 'com-rotate-yank)
- (progn
- (delete-range point (* -1 (length last-yank)))
- (rotate-yank-position *kill-ring*)))
- (insert-sequence point (kill-ring-yank *kill-ring*))))
+ (handler-case (let* ((pane (current-window))
+ (point (point pane))
+ (last-yank (kill-ring-yank *kill-ring*)))
+ (if (eq (previous-command pane)
+ 'com-rotate-yank)
+ (progn
+ (delete-range point (* -1 (length last-yank)))
+ (rotate-yank-position *kill-ring*)))
+ (insert-sequence point (kill-ring-yank *kill-ring*)))
+ (flexichain:at-end-error ()
+ (display-message "Kill ring is empty"))))
(set-key 'com-rotate-yank
'editing-table
--- /project/climacs/cvsroot/climacs/kill-ring.lisp 2006/03/03 19:38:57 1.9
+++ /project/climacs/cvsroot/climacs/kill-ring.lisp 2006/07/24 16:33:16 1.10
@@ -150,4 +150,8 @@
(defmethod kill-ring-yank ((kr kill-ring) &optional (reset nil))
(if reset (reset-yank-position kr))
- (element> (kill-ring-cursor kr)))
\ No newline at end of file
+ (element> (kill-ring-cursor kr)))
+
+(defparameter *kill-ring* nil
+ "This special variable is bound to the kill ring of the running
+ Climacs, whenever a command is executed.")
\ No newline at end of file
--- /project/climacs/cvsroot/climacs/gui.lisp 2006/07/24 13:24:40 1.223
+++ /project/climacs/cvsroot/climacs/gui.lisp 2006/07/24 16:33:16 1.224
@@ -37,6 +37,9 @@
(dabbrev-expansion-mark :initform nil :accessor dabbrev-expansion-mark)
(overwrite-mode :initform nil :accessor overwrite-mode)))
+(defclass typeout-pane (application-pane esa-pane-mixin)
+ ())
+
(defgeneric buffer-pane-p (pane)
(:documentation "Returns T when a pane contains a buffer."))
@@ -124,10 +127,10 @@
(defvar *mini-bg-color* +white+)
(defvar *mini-fg-color* +black+)
-
(define-application-frame climacs (standard-application-frame
esa-frame-mixin)
- ((buffers :initform '() :accessor buffers))
+ ((buffers :initform '() :accessor buffers)
+ (kill-ring :initform (make-instance 'kill-ring :max-size 7) :accessor kill-ring))
(:command-table (global-climacs-table
:inherit-from (global-esa-table
keyboard-macro-table
@@ -184,7 +187,9 @@
(vertically (:scroll-bars nil)
climacs-window
minibuffer)))
- (:top-level (esa-top-level :prompt "M-x ")))
+ (:top-level ((lambda (frame)
+ (let ((*kill-ring* (kill-ring frame)))
+ (esa-top-level frame :prompt "M-x "))))))
(defmethod frame-standard-input ((frame climacs))
(get-frame-pane frame 'minibuffer))
@@ -380,8 +385,150 @@
'self-insert-table
'((#\Newline)))
-;;;;;;;;;;;;;;;;;;;
-;;; Pane commands
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Pane/buffer functions
+
+(defun replace-constellation (constellation additional-constellation vertical-p)
+ (let* ((parent (sheet-parent constellation))
+ (children (sheet-children parent))
+ (first (first children))
+ (second (second children))
+ (third (third children))
+ (first-split-p (= (length (sheet-children parent)) 2))
+ (parent-region (sheet-region parent))
+ (parent-height (rectangle-height parent-region))
+ (parent-width (rectangle-width parent-region))
+ (filler (when first-split-p (make-pane 'basic-pane))) ;Prevents resizing.
+ (adjust #+mcclim (make-pane 'clim-extensions:box-adjuster-gadget)))
+ (assert (member constellation children))
+
+ (when first-split-p (setf (sheet-region filler) (sheet-region parent))
+ (sheet-adopt-child parent filler))
+
+ (sheet-disown-child parent constellation)
+
+ (if vertical-p
+ (resize-sheet constellation parent-width (/ parent-height 2))
+ (resize-sheet constellation (/ parent-width 2) parent-height))
+
+ (let ((new (if vertical-p
+ (vertically ()
+ constellation adjust additional-constellation)
+ (horizontally ()
+ constellation adjust additional-constellation))))
+ (sheet-adopt-child parent new)
+
+ (when first-split-p (sheet-disown-child parent filler))
+ (reorder-sheets parent
+ (if (eq constellation first)
+ (if third
+ (list new second third)
+ (list new second))
+ (if third
+ (list first second new)
+ (list first new)))))))
+(defun find-parent (sheet)
+ (loop for parent = (sheet-parent sheet)
+ then (sheet-parent parent)
+ until (typep parent 'vrack-pane)
+ finally (return parent)))
+
+(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."
+ (let* ((extended-pane
+ (make-pane 'extended-pane
+ :width 900 :height 400
+ :name 'window
+ :end-of-line-action :scroll
+ :incremental-redisplay t
+ :background *bg-color*
+ :foreground *fg-color*
+ :display-function 'display-window
+ :command-table 'global-climacs-table))
+ (vbox
+ (vertically ()
+ (if with-scrollbars
+ (scrolling ()
+ extended-pane)
+ extended-pane)
+ (make-pane 'climacs-info-pane
+ :background *info-bg-color*
+ :foreground *info-fg-color*
+ :master-pane extended-pane
+ :width 900))))
+ (values vbox extended-pane)))
+
+(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 (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 vertically-p)
+ (full-redisplay current-window)
+ (full-redisplay new-pane)
+ new-pane))))
+
+(defun make-typeout-constellation (&optional label)
+ (let* ((typeout-pane
+ (make-pane 'typeout-pane :foreground *fg-color* :background *bg-color*
+ :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 delete-window (&optional (window (current-window)))
+ (unless (null (cdr (windows *application-frame*)))
+ (let* ((constellation (find-parent window))
+ (box (sheet-parent constellation))
+ (box-children (sheet-children box))
+ (other (if (eq constellation (first box-children))
+ (third box-children)
+ (first box-children)))
+ (parent (sheet-parent box))
+ (children (sheet-children parent))
+ (first (first children))
+ (second (second children))
+ (third (third children)))
+ (setf (windows *application-frame*)
+ (remove window (windows *application-frame*)))
+ (setf *standard-output* (car (windows *application-frame*)))
+ (sheet-disown-child box other)
+ (sheet-adopt-child parent other)
+ (sheet-disown-child parent box)
+ (reorder-sheets parent (if (eq box first)
+ (if third
+ (list other second third)
+ (list other second))
+ (if third
+ (list first second other)
+ (list first other)))))))
(defun make-buffer (&optional name)
(let ((buffer (make-instance 'climacs-buffer)))
@@ -389,6 +536,20 @@
(push buffer (buffers *application-frame*))
buffer))
+(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*))))))
+ ;; Try to avoid setting the point in a typeout pane. FIXME: This is a kludge.
+ (if (and (subtypep 'typeout-pane (type-of (car (windows *application-frame*))))
+ (> (length (windows *application-frame*)) 1))
+ (other-window)
+ (setf *standard-output* (car (windows *application-frame*)))))
+
(defgeneric erase-buffer (buffer))
(defmethod erase-buffer ((buffer string))
--- /project/climacs/cvsroot/climacs/base.lisp 2006/07/24 13:24:40 1.56
+++ /project/climacs/cvsroot/climacs/base.lisp 2006/07/24 16:33:16 1.57
@@ -663,9 +663,3 @@
(when (> offset1 offset2)
(rotatef offset1 offset2))
(untabify-buffer-region (buffer mark1) offset1 offset2 tab-width)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;; Kill ring
-
-(defvar *kill-ring* (make-instance 'kill-ring :max-size 7))
More information about the Climacs-cvs
mailing list