Commit 05f03dba authored by Troels Henriksen's avatar Troels Henriksen
Browse files

* 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.
parent 23425149
...@@ -663,9 +663,3 @@ delimited by mark1 and mark2.")) ...@@ -663,9 +663,3 @@ delimited by mark1 and mark2."))
(when (> offset1 offset2) (when (> offset1 offset2)
(rotatef offset1 offset2)) (rotatef offset1 offset2))
(untabify-buffer-region (buffer mark1) offset1 offset2 tab-width))) (untabify-buffer-region (buffer mark1) offset1 offset2 tab-width)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Kill ring
(defvar *kill-ring* (make-instance 'kill-ring :max-size 7))
...@@ -37,6 +37,9 @@ ...@@ -37,6 +37,9 @@
(dabbrev-expansion-mark :initform nil :accessor dabbrev-expansion-mark) (dabbrev-expansion-mark :initform nil :accessor dabbrev-expansion-mark)
(overwrite-mode :initform nil :accessor overwrite-mode))) (overwrite-mode :initform nil :accessor overwrite-mode)))
(defclass typeout-pane (application-pane esa-pane-mixin)
())
(defgeneric buffer-pane-p (pane) (defgeneric buffer-pane-p (pane)
(:documentation "Returns T when a pane contains a buffer.")) (:documentation "Returns T when a pane contains a buffer."))
...@@ -124,10 +127,10 @@ ...@@ -124,10 +127,10 @@
(defvar *mini-bg-color* +white+) (defvar *mini-bg-color* +white+)
(defvar *mini-fg-color* +black+) (defvar *mini-fg-color* +black+)
(define-application-frame climacs (standard-application-frame (define-application-frame climacs (standard-application-frame
esa-frame-mixin) 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 (:command-table (global-climacs-table
:inherit-from (global-esa-table :inherit-from (global-esa-table
keyboard-macro-table keyboard-macro-table
...@@ -184,7 +187,9 @@ ...@@ -184,7 +187,9 @@
(vertically (:scroll-bars nil) (vertically (:scroll-bars nil)
climacs-window climacs-window
minibuffer))) 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)) (defmethod frame-standard-input ((frame climacs))
(get-frame-pane frame 'minibuffer)) (get-frame-pane frame 'minibuffer))
...@@ -380,8 +385,150 @@ Signals and error if the file does not exist." ...@@ -380,8 +385,150 @@ Signals and error if the file does not exist."
'self-insert-table 'self-insert-table
'((#\Newline))) '((#\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) (defun make-buffer (&optional name)
(let ((buffer (make-instance 'climacs-buffer))) (let ((buffer (make-instance 'climacs-buffer)))
...@@ -389,6 +536,20 @@ Signals and error if the file does not exist." ...@@ -389,6 +536,20 @@ Signals and error if the file does not exist."
(push buffer (buffers *application-frame*)) (push buffer (buffers *application-frame*))
buffer)) 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)) (defgeneric erase-buffer (buffer))
(defmethod erase-buffer ((buffer string)) (defmethod erase-buffer ((buffer string))
......
...@@ -150,4 +150,8 @@ is empty a new entry is pushed.")) ...@@ -150,4 +150,8 @@ is empty a new entry is pushed."))
(defmethod kill-ring-yank ((kr kill-ring) &optional (reset nil)) (defmethod kill-ring-yank ((kr kill-ring) &optional (reset nil))
(if reset (reset-yank-position kr)) (if reset (reset-yank-position kr))
(element> (kill-ring-cursor kr))) (element> (kill-ring-cursor kr)))
\ No newline at end of file
(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
...@@ -476,7 +476,9 @@ point at the beginning of the last line of the buffer." ...@@ -476,7 +476,9 @@ point at the beginning of the last line of the buffer."
;; Copies an element from a kill-ring to a buffer at the given offset ;; Copies an element from a kill-ring to a buffer at the given offset
(define-command (com-yank :name t :command-table editing-table) () (define-command (com-yank :name t :command-table editing-table) ()
"Insert the objects most recently added to the kill ring at point." "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 (set-key 'com-yank
'editing-table 'editing-table
...@@ -510,15 +512,17 @@ That is, push them onto the kill ring, and delete them from the buffer." ...@@ -510,15 +512,17 @@ That is, push them onto the kill ring, and delete them from the buffer."
Must be given immediately following a Yank or Rotate Yank command. Must be given immediately following a Yank or Rotate Yank command.
The replacement objects are those before the previously yanked The replacement objects are those before the previously yanked
objects in the kill ring." objects in the kill ring."
(let* ((pane (current-window)) (handler-case (let* ((pane (current-window))
(point (point pane)) (point (point pane))
(last-yank (kill-ring-yank *kill-ring*))) (last-yank (kill-ring-yank *kill-ring*)))
(if (eq (previous-command pane) (if (eq (previous-command pane)
'com-rotate-yank) 'com-rotate-yank)
(progn (progn
(delete-range point (* -1 (length last-yank))) (delete-range point (* -1 (length last-yank)))
(rotate-yank-position *kill-ring*))) (rotate-yank-position *kill-ring*)))
(insert-sequence point (kill-ring-yank *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 (set-key 'com-rotate-yank
'editing-table 'editing-table
......
...@@ -70,7 +70,8 @@ ...@@ -70,7 +70,8 @@
#:append-next-p #:append-next-p
#:reset-yank-position #:rotate-yank-position #:kill-ring-yank #:reset-yank-position #:rotate-yank-position #:kill-ring-yank
#:kill-ring-standard-push #:kill-ring-concatenating-push #: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.")) (:documentation "An implementation of a kill ring."))
(defpackage :climacs-base (defpackage :climacs-base
...@@ -99,8 +100,7 @@ ...@@ -99,8 +100,7 @@
#:downcase-buffer-region #:downcase-region #:downcase-buffer-region #:downcase-region
#:upcase-buffer-region #:upcase-region #:upcase-buffer-region #:upcase-region
#:capitalize-buffer-region #:capitalize-region #:capitalize-buffer-region #:capitalize-region
#:tabify-region #:untabify-region #:tabify-region #:untabify-region)
#:*kill-ring*)
(:documentation "Basic functionality built on top of the buffer (:documentation "Basic functionality built on top of the buffer
protocol. Here is where we define slightly higher level protocol. Here is where we define slightly higher level
functions, that can be directly implemented in terms of the functions, that can be directly implemented in terms of the
...@@ -318,6 +318,8 @@ ...@@ -318,6 +318,8 @@
#:extended-pane #:extended-pane
#:climacs-info-pane #:climacs-info-pane
#:typeout-pane
#:kill-ring
;; GUI functions follow. ;; GUI functions follow.
#:current-window #:current-window
...@@ -333,6 +335,10 @@ ...@@ -333,6 +335,10 @@
#:erase-buffer #:erase-buffer
#:buffer-pane-p #:buffer-pane-p
#:display-window #:display-window
#:split-window
#:typeout-window
#:delete-window
#:other-window
;; Some configuration variables ;; Some configuration variables
#:*bg-color* #:*bg-color*
......
...@@ -209,7 +209,9 @@ If found, leaves point before the word. If not, leaves point where it is." ...@@ -209,7 +209,9 @@ If found, leaves point before the word. If not, leaves point where it is."
(define-command (com-isearch-append-kill :name t :command-table isearch-climacs-table) () (define-command (com-isearch-append-kill :name t :command-table isearch-climacs-table) ()
(let* ((pane (current-window)) (let* ((pane (current-window))
(states (isearch-states pane)) (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 (string (concatenate 'string
(search-string (first states)) (search-string (first states))
yank)) yank))
......
...@@ -32,123 +32,6 @@ ...@@ -32,123 +32,6 @@
;;; ;;;
;;; Commands for splitting windows ;;; 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) () (define-command (com-split-window-vertically :name t :command-table window-table) ()
(split-window t)) (split-window t))
...@@ -163,20 +46,6 @@ If with-scrollbars nil, omit the scroller." ...@@ -163,20 +46,6 @@ If with-scrollbars nil, omit the scroller."
'window-table 'window-table
'((#\x :control) (#\3))) '((#\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) () (define-command (com-other-window :name t :command-table window-table) ()
(other-window)) (other-window))
...@@ -282,33 +151,6 @@ If with-scrollbars nil, omit the scroller." ...@@ -282,33 +151,6 @@ If with-scrollbars nil, omit the scroller."
'window-table 'window-table
'((#\V :control :meta :shift))) '((#\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) () (define-command (com-delete-window :name t :command-table window-table) ()
(delete-window)) (delete-window))
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment