Commit b72e80fa authored by Troels Henriksen's avatar Troels Henriksen

Try to naively unbreak typeout panes a little more. Also some fixes

related to accepting buffers.
parent 938e764b
......@@ -373,38 +373,43 @@ spaces only."))
: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)))))
(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))
(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)))
(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))
......
......@@ -224,27 +224,22 @@ Signals and error if the file does not exist."
;;;
;;; 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 @@ If the buffer needs saving, will prompt you to do so before killing it. Uses the
'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
......@@ -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)
......
......@@ -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 @@ If with-scrollbars nil, omit the scroller."
: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 @@ be created."
(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.
......
......@@ -1013,7 +1013,7 @@ Each newline and following whitespace is replaced by a single space."
(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)))))
......
......@@ -344,6 +344,7 @@
#:current-buffer
#:current-point
#:current-mark
#:any-buffer
#:point
#:syntax
#:mark
......
......@@ -318,7 +318,7 @@ using the case of those objects if USE-REGION-CASE is true."
(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))
......
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