[climacs-cvs] CVS climacs
thenriksen
thenriksen at common-lisp.net
Tue Sep 12 19:49:19 UTC 2006
Update of /project/climacs/cvsroot/climacs
In directory clnet:/tmp/cvs-serv17172
Modified Files:
core.lisp file-commands.lisp fundamental-syntax.lisp gui.lisp
lisp-syntax-swine.lisp packages.lisp search-commands.lisp
Log Message:
Try to naively unbreak typeout panes a little more. Also some fixes
related to accepting buffers.
--- /project/climacs/cvsroot/climacs/core.lisp 2006/09/08 18:12:03 1.9
+++ /project/climacs/cvsroot/climacs/core.lisp 2006/09/12 19:49:18 1.10
@@ -373,38 +373,43 @@
:value-key #'identity))
:partial-completers '(#\Space)
:allow-any-input t)
- (cond (success
- (values object type))
+ (cond ((and success (plusp (length string)))
+ (if object
+ (values object type)
+ (values string 'string)))
((and (zerop (length string)) defaultp)
- (values default default-type))
- (t (values string 'string)))))
+ (values default default-type))
+ (t
+ (values string 'string)))))
+
+(defgeneric switch-to-buffer (pane buffer))
+
+(defmethod switch-to-buffer ((pane extended-pane) (buffer climacs-buffer))
+ (with-accessors ((buffers buffers)) *application-frame*
+ (let* ((position (position buffer buffers))
+ (pane (current-window)))
+ (when position
+ (setf buffers (delete buffer buffers)))
+ (push buffer buffers)
+ (setf (offset (point (buffer pane))) (offset (point pane)))
+ (setf (buffer pane) buffer)
+ (full-redisplay pane)
+ buffer)))
+
+(defmethod switch-to-buffer ((pane typeout-pane) (buffer climacs-buffer))
+ (let ((usable-pane (or (find-if #'(lambda (pane)
+ (typep pane 'extended-pane))
+ (windows *application-frame*))
+ (split-window t))))
+ (switch-to-buffer usable-pane buffer)))
-(defgeneric switch-to-buffer (buffer))
-
-(defmethod switch-to-buffer ((buffer climacs-buffer))
- (let* ((buffers (buffers *application-frame*))
- (position (position buffer buffers))
- (pane (current-window)))
- (when position
- (setf buffers (delete buffer buffers)))
- (push buffer (buffers *application-frame*))
- (setf (offset (point (buffer pane))) (offset (point pane)))
- (setf (buffer pane) buffer)
- (full-redisplay pane)
- buffer))
-
-(defmethod switch-to-buffer ((name string))
+(defmethod switch-to-buffer (pane (name string))
(let ((buffer (find name (buffers *application-frame*)
:key #'name :test #'string=)))
- (switch-to-buffer (or buffer
+ (switch-to-buffer pane
+ (or buffer
(make-new-buffer :name name)))))
-;;placeholder
-(defmethod switch-to-buffer ((symbol (eql 'nil)))
- (let ((default (second (buffers *application-frame*))))
- (when default
- (switch-to-buffer default))))
-
;; ;;; FIXME: see the comment by (SETF SYNTAX) :AROUND. -- CSR,
;; ;;; 2005-10-31.
;; (defmethod (setf buffer) :around (buffer (pane extended-pane))
--- /project/climacs/cvsroot/climacs/file-commands.lisp 2006/08/20 13:06:39 1.24
+++ /project/climacs/cvsroot/climacs/file-commands.lisp 2006/09/12 19:49:18 1.25
@@ -224,27 +224,22 @@
;;;
;;; Buffer commands
-(define-command (com-switch-to-buffer :name t :command-table pane-table) ()
+(define-command (com-switch-to-buffer :name t :command-table pane-table)
+ ((buffer 'buffer :default (or (second (buffers *application-frame*))
+ (any-buffer))))
"Prompt for a buffer name and switch to that buffer.
-If the a buffer with that name does not exist, create it. Uses the name of the next buffer (if any) as a default."
- (let* ((default (second (buffers *application-frame*)))
- (buffer (if default
- (accept 'buffer
- :prompt "Switch to buffer"
- :default default)
- (accept 'buffer
- :prompt "Switch to buffer"))))
- (switch-to-buffer buffer)))
+If the a buffer with that name does not exist, create it. Uses
+the name of the next buffer (if any) as a default."
+ (switch-to-buffer (current-window) buffer))
-(set-key 'com-switch-to-buffer
+(set-key `(com-switch-to-buffer ,*unsupplied-argument-marker*)
'pane-table
'((#\x :control) (#\b)))
(define-command (com-kill-buffer :name t :command-table pane-table)
((buffer 'buffer
:prompt "Kill buffer"
- :default (buffer (current-window))
- :default-type 'buffer))
+ :default (buffer (current-window))))
"Prompt for a buffer name and kill that buffer.
If the buffer needs saving, will prompt you to do so before killing it. Uses the current buffer as a default."
(kill-buffer buffer))
@@ -253,22 +248,22 @@
'pane-table
'((#\x :control) (#\k)))
-(define-command (com-toggle-read-only :name t :command-table base-table)
+(define-command (com-toggle-read-only :name t :command-table buffer-table)
((buffer 'buffer :default (current-buffer *application-frame*)))
(setf (read-only-p buffer) (not (read-only-p buffer))))
(define-presentation-to-command-translator toggle-read-only
- (read-only com-toggle-read-only base-table
+ (read-only com-toggle-read-only buffer-table
:gesture :menu)
(object)
(list object))
-(define-command (com-toggle-modified :name t :command-table base-table)
+(define-command (com-toggle-modified :name t :command-table buffer-table)
((buffer 'buffer :default (current-buffer *application-frame*)))
(setf (needs-saving buffer) (not (needs-saving buffer))))
(define-presentation-to-command-translator toggle-modified
- (modified com-toggle-modified base-table
+ (modified com-toggle-modified buffer-table
:gesture :menu)
(object)
(list object))
\ No newline at end of file
--- /project/climacs/cvsroot/climacs/fundamental-syntax.lisp 2006/09/11 20:13:32 1.6
+++ /project/climacs/cvsroot/climacs/fundamental-syntax.lisp 2006/09/12 19:49:18 1.7
@@ -194,7 +194,7 @@
(let ((point (point pane)))
(multiple-value-bind (cursor-x cursor-y line-height)
(offset-to-screen-position (offset point) pane)
- (updating-output (pane :unique-id -1 :cache-value (offset point))
+ (updating-output (pane :unique-id -1 :cache-value (cons (offset point) current-p))
(draw-rectangle* pane
(1- cursor-x) cursor-y
(+ cursor-x 2) (+ cursor-y line-height)
--- /project/climacs/cvsroot/climacs/gui.lisp 2006/09/06 20:07:21 1.230
+++ /project/climacs/cvsroot/climacs/gui.lisp 2006/09/12 19:49:18 1.231
@@ -40,6 +40,8 @@
(defclass typeout-pane (application-pane esa-pane-mixin)
())
+(defmethod full-redisplay ((pane typeout-pane)))
+
(defgeneric buffer-pane-p (pane)
(:documentation "Returns T when a pane contains a buffer."))
@@ -119,6 +121,17 @@
(make-command-table 'climacs-help-table :inherit-from '(help-table)
:errorp nil)
+;; We have a special command table for typeout panes because we want
+;; to keep being able to do window, buffer, etc, management, but we do
+;; not want any actual editing commands.
+(make-command-table 'typeout-pane-table
+ :errorp nil
+ :inherit-from '(global-esa-table
+ base-table
+ pane-table
+ window-table
+ development-table
+ climacs-help-table))
(defvar *bg-color* +white+)
(defvar *fg-color* +black+)
@@ -212,6 +225,10 @@
"Return the current buffer."
(buffer (car (windows application-frame))))
+(defun any-buffer ()
+ "Return some buffer, any buffer, as long as it is a buffer!"
+ (first (buffers *application-frame*)))
+
(define-presentation-type read-only ())
(define-presentation-method highlight-presentation
((type read-only) record stream state)
@@ -322,15 +339,16 @@
(setf (needs-saving buffer) t)))))
(defmethod find-applicable-command-table ((frame climacs))
- (or
- (let ((syntax (and (buffer-pane-p (current-window))
- (syntax (buffer (current-window))))))
- (and syntax
- (slot-exists-p syntax 'command-table)
- (slot-boundp syntax 'command-table)
- (slot-value syntax 'command-table)
- (find-command-table (slot-value syntax 'command-table))))
- (find-command-table 'global-climacs-table)))
+ (cond ((typep (current-window) 'typeout-pane)
+ (find-command-table 'typeout-pane-table))
+ ((buffer-pane-p (current-window))
+ (or (let ((syntax (syntax (buffer (current-window)))))
+ ;; Why all this absurd checking? Smells fishy.
+ (and (slot-exists-p syntax 'command-table)
+ (slot-boundp syntax 'command-table)
+ (slot-value syntax 'command-table)
+ (find-command-table (slot-value syntax 'command-table))))
+ (find-command-table 'global-climacs-table)))))
(define-command (com-full-redisplay :name t :command-table base-table) ()
"Redisplay the contents of the current window.
@@ -431,16 +449,27 @@
:width 900))))
(values vbox extended-pane)))
+(defgeneric setup-split-pane (orig-pane new-pane)
+ (:documentation "Perform split-setup operations `new-pane',
+ which is supposed to be a pane that has been freshly split from
+ `orig-pane'."))
+
+(defmethod setup-split-pane ((orig-pane extended-pane) (new-pane extended-pane))
+ (setf (offset (point (buffer orig-pane))) (offset (point orig-pane))
+ (buffer new-pane) (buffer orig-pane)
+ (auto-fill-mode new-pane) (auto-fill-mode orig-pane)
+ (auto-fill-column new-pane) (auto-fill-column orig-pane)))
+
+(defmethod setup-split-pane ((orig-pane typeout-pane) (new-pane extended-pane))
+ (setf (buffer new-pane) (any-buffer)))
+
(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))
+ (setup-split-pane current-window new-pane)
(push new-pane (windows *application-frame*))
(setf *standard-output* new-pane)
(replace-constellation constellation-root vbox vertically-p)
@@ -510,11 +539,7 @@
(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*)))))
+ (setf *standard-output* (car (windows *application-frame*))))
;;; For the ESA help functions.
--- /project/climacs/cvsroot/climacs/lisp-syntax-swine.lisp 2006/09/12 17:24:56 1.7
+++ /project/climacs/cvsroot/climacs/lisp-syntax-swine.lisp 2006/09/12 19:49:18 1.8
@@ -1013,7 +1013,7 @@
(esa:display-message "No buffer ~A" (buffer-name location))
(beep)
(return-from goto-location))
- (switch-to-buffer buffer)
+ (switch-to-buffer (current-window) buffer)
(goto-position (point (current-window))
(char-position (source-position location)))))
--- /project/climacs/cvsroot/climacs/packages.lisp 2006/09/11 20:13:32 1.118
+++ /project/climacs/cvsroot/climacs/packages.lisp 2006/09/12 19:49:18 1.119
@@ -344,6 +344,7 @@
#:current-buffer
#:current-point
#:current-mark
+ #:any-buffer
#:point
#:syntax
#:mark
--- /project/climacs/cvsroot/climacs/search-commands.lisp 2006/09/06 20:07:21 1.14
+++ /project/climacs/cvsroot/climacs/search-commands.lisp 2006/09/12 19:49:18 1.15
@@ -318,7 +318,7 @@
(buffers buffers)
(mark mark)) state
(flet ((head-to-buffer (buffer)
- (switch-to-buffer buffer)
+ (switch-to-buffer (current-window) buffer)
(setf mark (point (current-window)))
(beginning-of-buffer mark)))
(unless (eq (current-buffer) (first buffers))
More information about the Climacs-cvs
mailing list