/[climacs]/climacs/gui.lisp
ViewVC logotype

Diff of /climacs/gui.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.230 by thenriksen, Wed Sep 6 20:07:21 2006 UTC revision 1.231 by thenriksen, Tue Sep 12 19:49:18 2006 UTC
# Line 40  Line 40 
40  (defclass typeout-pane (application-pane esa-pane-mixin)  (defclass typeout-pane (application-pane esa-pane-mixin)
41    ())    ())
42    
43    (defmethod full-redisplay ((pane typeout-pane)))
44    
45  (defgeneric buffer-pane-p (pane)  (defgeneric buffer-pane-p (pane)
46    (:documentation "Returns T when a pane contains a buffer."))    (:documentation "Returns T when a pane contains a buffer."))
47    
# Line 119  Line 121 
121  (make-command-table 'climacs-help-table :inherit-from '(help-table)  (make-command-table 'climacs-help-table :inherit-from '(help-table)
122                      :errorp nil)                      :errorp nil)
123    
124    ;; We have a special command table for typeout panes because we want
125    ;; to keep being able to do window, buffer, etc, management, but we do
126    ;; not want any actual editing commands.
127    (make-command-table 'typeout-pane-table
128                        :errorp nil
129                        :inherit-from '(global-esa-table
130                                        base-table
131                                        pane-table
132                                        window-table
133                                        development-table
134                                        climacs-help-table))
135    
136  (defvar *bg-color* +white+)  (defvar *bg-color* +white+)
137  (defvar *fg-color* +black+)  (defvar *fg-color* +black+)
# Line 212  Line 225 
225    "Return the current buffer."    "Return the current buffer."
226    (buffer (car (windows application-frame))))    (buffer (car (windows application-frame))))
227    
228    (defun any-buffer ()
229      "Return some buffer, any buffer, as long as it is a buffer!"
230      (first (buffers *application-frame*)))
231    
232  (define-presentation-type read-only ())  (define-presentation-type read-only ())
233  (define-presentation-method highlight-presentation  (define-presentation-method highlight-presentation
234      ((type read-only) record stream state)      ((type read-only) record stream state)
# Line 322  Line 339 
339                 (setf (needs-saving buffer) t)))))                 (setf (needs-saving buffer) t)))))
340    
341  (defmethod find-applicable-command-table ((frame climacs))  (defmethod find-applicable-command-table ((frame climacs))
342    (or    (cond ((typep (current-window) 'typeout-pane)
343     (let ((syntax (and (buffer-pane-p (current-window))           (find-command-table 'typeout-pane-table))
344                        (syntax (buffer (current-window))))))          ((buffer-pane-p (current-window))
345        (and syntax           (or (let ((syntax (syntax (buffer (current-window)))))
346             (slot-exists-p syntax 'command-table)                 ;; Why all this absurd checking? Smells fishy.
347             (slot-boundp syntax 'command-table)                 (and (slot-exists-p syntax 'command-table)
348             (slot-value syntax 'command-table)                      (slot-boundp syntax 'command-table)
349             (find-command-table (slot-value syntax 'command-table))))                      (slot-value syntax 'command-table)
350     (find-command-table 'global-climacs-table)))                      (find-command-table (slot-value syntax 'command-table))))
351                 (find-command-table 'global-climacs-table)))))
352    
353  (define-command (com-full-redisplay :name t :command-table base-table) ()  (define-command (com-full-redisplay :name t :command-table base-table) ()
354    "Redisplay the contents of the current window.    "Redisplay the contents of the current window.
# Line 431  If with-scrollbars nil, omit the scrolle Line 449  If with-scrollbars nil, omit the scrolle
449                         :width 900))))                         :width 900))))
450      (values vbox extended-pane)))      (values vbox extended-pane)))
451    
452    (defgeneric setup-split-pane (orig-pane new-pane)
453      (:documentation "Perform split-setup operations `new-pane',
454      which is supposed to be a pane that has been freshly split from
455      `orig-pane'."))
456    
457    (defmethod setup-split-pane ((orig-pane extended-pane) (new-pane extended-pane))
458      (setf (offset (point (buffer orig-pane))) (offset (point orig-pane))
459            (buffer new-pane) (buffer orig-pane)
460            (auto-fill-mode new-pane) (auto-fill-mode orig-pane)
461            (auto-fill-column new-pane) (auto-fill-column orig-pane)))
462    
463    (defmethod setup-split-pane ((orig-pane typeout-pane) (new-pane extended-pane))
464      (setf (buffer new-pane) (any-buffer)))
465    
466  (defun split-window (&optional (vertically-p nil) (pane (current-window)))  (defun split-window (&optional (vertically-p nil) (pane (current-window)))
467    (with-look-and-feel-realization    (with-look-and-feel-realization
468        ((frame-manager *application-frame*) *application-frame*)        ((frame-manager *application-frame*) *application-frame*)
469      (multiple-value-bind (vbox new-pane) (make-pane-constellation)      (multiple-value-bind (vbox new-pane) (make-pane-constellation)
470        (let* ((current-window pane)        (let* ((current-window pane)
471               (constellation-root (find-parent current-window)))               (constellation-root (find-parent current-window)))
472          (setf (offset (point (buffer current-window))) (offset (point current-window))          (setup-split-pane current-window new-pane)
               (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))  
473          (push new-pane (windows *application-frame*))          (push new-pane (windows *application-frame*))
474          (setf *standard-output* new-pane)          (setf *standard-output* new-pane)
475          (replace-constellation constellation-root vbox vertically-p)          (replace-constellation constellation-root vbox vertically-p)
# Line 510  be created." Line 539  be created."
539        (setf (windows *application-frame*)        (setf (windows *application-frame*)
540              (append (cdr (windows *application-frame*))              (append (cdr (windows *application-frame*))
541                      (list (car (windows *application-frame*))))))                      (list (car (windows *application-frame*))))))
542    ;; Try to avoid setting the point in a typeout pane. FIXME: This is a kludge.    (setf *standard-output* (car (windows *application-frame*))))
   (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*)))))  
543    
544  ;;; For the ESA help functions.  ;;; For the ESA help functions.
545    

Legend:
Removed from v.1.230  
changed lines
  Added in v.1.231

  ViewVC Help
Powered by ViewVC 1.1.5