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))