[climacs-cvs] CVS climacs

[thenriksen]

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)
                             , at body)))