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

* 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."))
(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))
......@@ -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 @@ Signals and error if the file does not exist."
'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 @@ Signals and error if the file does not exist."
(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))
......
......@@ -150,4 +150,8 @@ is empty a new entry is pushed."))
(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
......@@ -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
(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 @@ 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.
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
......
......@@ -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*
......
......@@ -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) ()
(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))
......
......@@ -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 @@ If with-scrollbars nil, omit the scroller."
'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 @@ If with-scrollbars nil, omit the scroller."
'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))
......
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