Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv26158

Modified Files: gui.lisp typeout.lisp Log Message: Blank typeout views before printing help information in them.

--- /project/climacs/cvsroot/climacs/gui.lisp 2008/02/05 22:07:31 1.260 +++ /project/climacs/cvsroot/climacs/gui.lisp 2008/02/06 09:22:58 1.261 @@ -695,5 +695,5 @@ ;;; For the ESA help functions.

(defmethod invoke-with-help-stream ((frame climacs) title continuation) - (with-typeout-view (stream title) + (with-typeout-view (stream title t) (funcall continuation stream))) --- /project/climacs/cvsroot/climacs/typeout.lisp 2008/02/05 22:07:31 1.7 +++ /project/climacs/cvsroot/climacs/typeout.lisp 2008/02/06 09:23:01 1.8 @@ -56,6 +56,16 @@ (defmethod clear-redisplay-information ((view typeout-view)) (setf (dirty view) t))

+(defun blank-typeout-view (view) + "Blank out the contents of the typeout view `view'." + (setf (output-history view) (make-instance 'standard-tree-output-record) + (last-cursor-position view) nil) + (clear-redisplay-information view) + ;; If it's on display, clear the window too. + (let ((window (find view (windows *application-frame*) + :key #'view))) + (when window (window-clear window)))) + (defmethod handle-redisplay ((pane drei-pane) (view typeout-view) (region region)) (if (and (not (dirty view)) (eq (output-record-parent (output-history view)) @@ -106,24 +116,27 @@ (scroll-typeout-window pane (- (bounding-rectangle-height (pane-viewport pane)))))

-(defun ensure-typeout-view (climacs label) +(defun ensure-typeout-view (climacs label erase) "Ensure that `climacs' has a typeout view with the name -`label', and return that view." +`label', and return that view. If `erase' is true, clear any +already existing typeout view by that name first." (check-type label string) - (or (find-if #'(lambda (view) - (and (typeout-view-p view) - (string= (name view) label))) - (views climacs)) + (or (let ((view (find-if #'(lambda (view) + (and (typeout-view-p view) + (string= (name view) label))) + (views climacs)))) + (when (and view erase) (blank-typeout-view view)) + view) (make-new-view-for-climacs climacs 'typeout-view :name label)))

;; Because specialising on the type of `climacs' is so useful... -(defun invoke-with-typeout-view (climacs label continuation) +(defun invoke-with-typeout-view (climacs label erase continuation) "Call `continuation' with a single argument, a stream meant for typeout. `Climacs' is the Climacs instance in which the typeout pane should be shown, and `label' is the name of the created typeout view. Returns NIL." - (let* ((typeout-view (ensure-typeout-view climacs label)) + (let* ((typeout-view (ensure-typeout-view climacs label erase)) (pane-with-typeout-view (or (find typeout-view (windows climacs) :key #'view) (let ((pane (split-window t))) @@ -141,11 +154,13 @@ (setf (dirty typeout-view) t) nil)))

-(defmacro with-typeout-view ((stream &optional (label "Typeout")) &body body) +(defmacro with-typeout-view ((stream &optional (label "Typeout") erase) + &body body) "Evaluate `body' with `stream' bound to a stream that can be used for typeout. `Label' is the name of the created typeout -view." - `(invoke-with-typeout-view *esa-instance* ,label +view. If `erase' is true, clear the contents of any existing +typeout view with that name." + `(invoke-with-typeout-view *esa-instance* ,label ,erase #'(lambda (,stream) ,@body)))