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

Modified Files: window-commands.lisp packages.lisp gui.lisp core.lisp climacs.asd climacs-lisp-syntax.lisp Added Files: typeout.lisp Log Message: Revamped typeout panes and turned them into typeout views.

Stability not guaranteed, the code is... special.

Some things are still known to be suboptimal.

--- /project/climacs/cvsroot/climacs/window-commands.lisp 2008/01/06 11:47:37 1.17 +++ /project/climacs/cvsroot/climacs/window-commands.lisp 2008/01/20 19:51:48 1.18 @@ -99,11 +99,7 @@

(define-presentation-to-command-translator blank-area-to-switch-to-this-window (blank-area com-switch-to-this-window window-table - :echo nil - ;; Putting the point in typeout-panes can cause errors. - :tester ((object presentation) - (declare (ignore presentation)) - (not (typep object 'typeout-pane)))) + :echo nil) (window x y) (list window x y))

@@ -152,26 +148,10 @@ 'window-table '((#\x :control) (#\1)))

-(defun scroll-typeout-window (window y) - "Scroll `window' down by `y' device units, but taking care not -to scroll past the size of `window'. If `window' does not have a -viewport, do nothing." - (let ((viewport (pane-viewport window))) - (unless (null viewport) ; Can't scroll without viewport - (multiple-value-bind (x-displacement y-displacement) - (transform-position (sheet-transformation window) 0 0) - (scroll-extent window - (- x-displacement) - (max 0 (min (+ (- y-displacement) y) - (- (bounding-rectangle-height window) - (bounding-rectangle-height viewport))))))))) - (define-command (com-scroll-other-window :name t :command-table window-table) () (let ((other-window (second (windows *application-frame*)))) (when other-window - (if (typeout-pane-p other-window) - (scroll-typeout-window other-window (bounding-rectangle-height (pane-viewport other-window))) - (page-down (view other-window)))))) + (page-down other-window (view other-window)))))

(set-key 'com-scroll-other-window 'window-table @@ -180,9 +160,7 @@ (define-command (com-scroll-other-window-up :name t :command-table window-table) () (let ((other-window (second (windows *application-frame*)))) (when other-window - (if (typeout-pane-p other-window) - (scroll-typeout-window other-window (- (bounding-rectangle-height (pane-viewport other-window)))) - (page-up (view other-window)))))) + (page-up other-window (view other-window)))))

(set-key 'com-scroll-other-window-up 'window-table --- /project/climacs/cvsroot/climacs/packages.lisp 2008/01/18 07:44:57 1.133 +++ /project/climacs/cvsroot/climacs/packages.lisp 2008/01/20 19:51:48 1.134 @@ -39,7 +39,6 @@ #:climacs-buffer #:external-format #:climacs-pane #:climacs-info-pane - #:typeout-pane #:typeout-pane-p #:kill-ring

;; View-stuff @@ -47,13 +46,12 @@ #:view-setting-error #:view #:unknown-view #:view-already-displayed #:window - #:switch-to-pane #:remove-other-use #:remove-other-pane #:clone-view #:cancel + #:remove-other-use #:remove-other-pane #:clone-view #:cancel #:any-view #:any-undisplayed-view #:clone-view-for-climacs #:make-new-view-for-climacs

;; GUI functions follow. - #:point #:syntax #:mark @@ -63,15 +61,14 @@ #:groups #:display-window #:split-window - #:typeout-window #:delete-window #:other-window #:buffer-pane-p + #:display-view-info-to-info-pane + #:display-view-status-to-info-pane

;; Some configuration variables - #:*bg-color* - #:*fg-color* #:*info-bg-color* #:*info-fg-color* #:*mini-bg-color* @@ -85,7 +82,11 @@ #:base-table #:buffer-table #:case-table #:development-table #:info-table #:pane-table - #:window-table)) + #:window-table + + ;; Typeout + #:typeout-view #:typeout-view-p + #:with-typeout #:invoke-with-typeout))

(defpackage :climacs-core (:use :clim-lisp :drei-base :drei-buffer :drei-fundamental-syntax @@ -100,8 +101,6 @@

#:switch-to-view #:switch-or-move-to-view #:make-new-buffer - #:make-new-named-buffer - #:erase-buffer #:kill-view

#:filepath-filename --- /project/climacs/cvsroot/climacs/gui.lisp 2008/01/18 07:16:22 1.254 +++ /project/climacs/cvsroot/climacs/gui.lisp 2008/01/20 19:51:48 1.255 @@ -8,6 +8,8 @@ ;;; Matthieu Villeneuve (matthieu.villeneuve@free.fr) ;;; (c) copyright 2005 by ;;; Aleksandar Bakic (a_bakic@yahoo.com) +;;; (c) copyright 2006-2008 by +;;; Troels Henriksen (athas@sigkill.dk)

;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public @@ -142,23 +144,6 @@ (with-accessors ((views views)) (pane-frame pane) (full-redisplay pane)))

-(defclass typeout-pane (application-pane esa-pane-mixin) - ((%active :accessor active - :initform nil - :initarg :active))) - -(defun typeout-pane-p (pane) - "Return true if `pane' is a typeout pane." - (typep pane 'typeout-pane)) - -(defmethod buffer ((pane typeout-pane))) - -(defmethod point-of ((pane typeout-pane))) - -(defmethod mark-of ((pane typeout-pane))) - -(defmethod full-redisplay ((pane typeout-pane))) - (defgeneric buffer-pane-p (pane) (:documentation "Returns T when a pane contains a buffer."))

@@ -225,18 +210,6 @@ (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)) - (make-command-table 'global-climacs-table :errorp nil :inherit-from '(base-table @@ -448,6 +421,12 @@ (:documentation "Display interesting information about `view' (which is in `master-pane') to `info-pane'."))

+(defgeneric display-view-status-to-info-pane (info-pane master-pane view) + (:documentation "Display interesting information about the +status of `view' (which is in `master-pane') to `info-pane'. The +status should be things like whether it is modified, read-only, +etc.")) + (defmethod display-view-info-to-info-pane ((info-pane climacs-info-pane) (master-pane climacs-pane) (view drei-syntax-view)) @@ -487,23 +466,36 @@ "Isearch")) (princ #) info-pane)))

+(defmethod display-view-info-to-info-pane ((info-pane climacs-info-pane) + (master-pane climacs-pane) + (view typeout-view))) + +(defmethod display-view-status-to-info-pane ((info-pane climacs-info-pane) + (master-pane climacs-pane) + (view drei-syntax-view)) + (with-output-as-presentation (info-pane view 'read-only) + (princ (cond + ((read-only-p (buffer view)) "%") + ((needs-saving (buffer view)) "*") + (t "-")) + info-pane)) + (with-output-as-presentation (info-pane view 'modified) + (princ (cond + ((needs-saving (buffer view)) "*") + ((read-only-p (buffer view)) "%") + (t "-")) + info-pane)) + (princ " " info-pane)) + +(defmethod display-view-status-to-info-pane ((info-pane climacs-info-pane) + (master-pane climacs-pane) + (view typeout-view))) + (defun display-info (frame pane) (let* ((master-pane (master-pane pane)) (view (view master-pane))) (princ " " pane) - (with-output-as-presentation (pane view 'read-only) - (princ (cond - ((read-only-p (buffer view)) "%") - ((needs-saving (buffer view)) "*") - (t "-")) - pane)) - (with-output-as-presentation (pane view 'modified) - (princ (cond - ((needs-saving (buffer view)) "*") - ((read-only-p (buffer view)) "%") - (t "-")) - pane)) - (princ " " pane) + (display-view-status-to-info-pane pane master-pane view) (with-text-face (pane :bold) (with-output-as-presentation (pane view 'view) (format pane "~A" (subscripted-name view))) @@ -628,14 +620,10 @@ `orig-pane' has a view."))

(defmethod setup-split-pane ((orig-pane climacs-pane) (new-pane climacs-pane) clone-view) - (setf (offset (point (buffer (view orig-pane)))) (offset (point (view orig-pane))) - (view new-pane) (if clone-view - (clone-view-for-climacs (pane-frame orig-pane) (view orig-pane)) - (any-preferably-undisplayed-view)))) - -(defmethod setup-split-pane ((orig-pane typeout-pane) (new-pane climacs-pane) clone-view) + (when (buffer-view-p (view orig-pane)) + (setf (offset (point (buffer (view orig-pane)))) (offset (point (view orig-pane))))) (setf (view new-pane) (if clone-view - (any-undisplayed-view) + (clone-view-for-climacs (pane-frame orig-pane) (view orig-pane)) (any-preferably-undisplayed-view))))

(defun split-window (&optional (vertically-p nil) (clone-view nil) (pane (current-window))) @@ -652,35 +640,6 @@ (activate-window pane) new-pane))))

-(defun make-typeout-constellation (&key label pane) - (let* ((typeout-pane - (or pane - (make-pane 'typeout-pane :foreground *foreground-color* - :background *background-color* - :width 900 :height 400 :display-time nil :name label))) - (label - (make-pane 'label-pane :label label)) - (vbox - (vertically () - (scrolling (:scroll-bar :vertical) typeout-pane) label))) - (values vbox typeout-pane))) - -(defun typeout-window (&optional (label "Typeout") (pane (current-window))) - "Get a typeout pane labelled `label'. If a pane with this label -already exists, it will be returned. Otherwise, a new pane will -be created." - (with-look-and-feel-realization - ((frame-manager *esa-instance*) *esa-instance*) - (or (find label (windows *esa-instance*) :key #'pane-name) - (multiple-value-bind (vbox new-pane) (make-typeout-constellation :label label) - (let* ((current-window pane) - (constellation-root (find-parent current-window))) - (push new-pane (windows *esa-instance*)) - (other-window) - (replace-constellation constellation-root vbox t) - (full-redisplay current-window) - new-pane))))) - (defun delete-window (&optional (window (current-window))) (unless (null (cdr (windows *esa-instance*))) (let* ((constellation (find-parent window)) @@ -719,99 +678,6 @@

;;; For the ESA help functions.

-(defmethod help-stream ((frame climacs) title) - (typeout-window (format nil "~10T~A" title))) - -;;; An implementation of the Gray streams protocol that uses a Climacs -;;; typeout pane to draw the output. - -(defclass typeout-stream (fundamental-character-output-stream) - ((%typeout-pane :accessor typeout-pane - :initform nil - :initarg :typeout-pane - :documentation "The typeout pane that output -will be performed on.") - (%climacs :reader climacs-instance - :initform (error "Must provide a Climacs instance for typeout streams") - :initarg :climacs) - (%label :reader label - :initform (error "A typeout stream must have a label") - :initarg :label)) - (:documentation "An output stream that performs output on -a (single) Climacs typeout pane. If the typeout pane is deleted -manually by the user, the stream will recreate it the next time -output is performed.")) - -(defmethod initialize-instance :after ((stream typeout-stream) &rest args) - (declare (ignore args)) - (setf (typeout-pane stream) - (with-look-and-feel-realization ((frame-manager (climacs-instance stream)) - (climacs-instance stream)) - (make-pane 'typeout-pane :foreground *foreground-color* - :background *background-color* - :width 900 :height 400 :display-time nil :name (label stream))))) - -(defgeneric ensure-typeout-pane-for-stream (stream) - (:documentation "Ensure that `stream' has a typeout pane that -it can display output to, and that this pane is on display.")) - -(defmethod ensure-typeout-pane-for-stream ((stream typeout-stream)) - (with-look-and-feel-realization ((frame-manager (climacs-instance stream)) - (climacs-instance stream)) - (unless (member (typeout-pane stream) (windows (climacs-instance stream))) - (setf (sheet-parent (typeout-pane stream)) nil) - (multiple-value-bind (vbox new-pane) (make-typeout-constellation :pane (typeout-pane stream) - :label (label stream)) - (let* ((current-window (current-window)) - (constellation-root (find-parent current-window))) - (push new-pane (windows *esa-instance*)) - (other-window) - (replace-constellation constellation-root vbox t) - (full-redisplay current-window)))))) - -(defmethod stream-write-char ((stream typeout-stream) char) - (ensure-typeout-pane-for-stream stream) - (stream-write-char (typeout-pane stream) char)) - -(defmethod stream-line-column ((stream typeout-stream)) - (ensure-typeout-pane-for-stream stream) - (stream-line-column (typeout-pane stream))) - -(defmethod stream-start-line-p ((stream typeout-stream)) - (ensure-typeout-pane-for-stream stream) - (stream-start-line-p (typeout-pane stream))) - -(defmethod stream-write-string ((stream typeout-stream) string &optional (start 0) end) - (ensure-typeout-pane-for-stream stream) - (stream-write-string (typeout-pane stream) string start end)) - -(defmethod stream-terpri ((stream typeout-stream)) - (ensure-typeout-pane-for-stream stream) - (stream-terpri (typeout-pane stream))) - -(defmethod stream-fresh-line ((stream typeout-stream)) - (ensure-typeout-pane-for-stream stream) - (stream-fresh-line (typeout-pane stream))) - -(defmethod stream-finish-output ((stream typeout-stream)) - (ensure-typeout-pane-for-stream stream) - (stream-finish-output (typeout-pane stream))) - -(defmethod stream-force-output ((stream typeout-stream)) - (ensure-typeout-pane-for-stream stream) - (stream-force-output (typeout-pane stream))) - -(defmethod stream-clear-output ((stream typeout-stream)) - (ensure-typeout-pane-for-stream stream) - (stream-clear-output (typeout-pane stream))) - -(defmethod stream-advance-to-column ((stream typeout-stream) (column integer)) - (ensure-typeout-pane-for-stream stream) - (stream-advance-to-column (typeout-pane stream) column)) - -(defmethod interactive-stream-p ((stream typeout-stream)) - (ensure-typeout-pane-for-stream stream) - (interactive-stream-p (typeout-pane stream))) - -(defun make-typeout-stream (climacs label) - (make-instance 'typeout-stream :climacs climacs :label label)) +(defmethod invoke-with-help-stream ((frame climacs) title continuation) + (with-typeout (stream title) + (funcall continuation stream))) --- /project/climacs/cvsroot/climacs/core.lisp 2008/01/18 07:44:56 1.23 +++ /project/climacs/cvsroot/climacs/core.lisp 2008/01/20 19:51:48 1.24 @@ -56,13 +56,6 @@ (defmethod switch-to-view ((drei climacs-pane) (view drei-view)) (setf (view drei) view))

-(defmethod switch-to-view ((drei typeout-pane) (view drei-view)) - (let ((usable-pane (or (find-if #'(lambda (pane) - (typep pane 'drei)) - (windows *application-frame*)) - (split-window t)))) - (switch-to-view usable-pane view))) - (defmethod switch-to-view (pane (name string)) (let ((view (find name (views (pane-frame pane)) :key #'subscripted-name :test #'string=))) @@ -124,7 +117,8 @@ ;; view will be kept in the buffer, and the view will thus not be ;; garbage-collected. So create a circular reference structure ;; that can be garbage-collected instead. - (setf (buffer view) (dummy-buffer)) + (when (buffer-view-p view) + (setf (buffer view) (dummy-buffer))) (full-redisplay (current-window)) (current-view)))

--- /project/climacs/cvsroot/climacs/climacs.asd 2008/01/10 10:48:24 1.69 +++ /project/climacs/cvsroot/climacs/climacs.asd 2008/01/20 19:51:48 1.70 @@ -44,7 +44,8 @@ (:file "c-syntax-commands" :depends-on ("c-syntax" "misc-commands")) (:file "java-syntax" :depends-on ("core")) (:file "java-syntax-commands" :depends-on ("java-syntax" "misc-commands")) - (:file "gui" :depends-on ("packages")) + (:file "typeout" :depends-on ("packages")) + (:file "gui" :depends-on ("packages" "typeout")) (:file "core" :depends-on ("gui")) (:file "io" :depends-on ("packages" "gui")) (:file "groups" :depends-on ("core")) --- /project/climacs/cvsroot/climacs/climacs-lisp-syntax.lisp 2008/01/18 07:44:56 1.12 +++ /project/climacs/cvsroot/climacs/climacs-lisp-syntax.lisp 2008/01/20 19:51:48 1.13 @@ -207,15 +207,14 @@ (def-print-for-menu note-compiler-note "Note" +brown+)

(defun show-notes (notes view-name definition) - (let ((stream (climacs-gui:typeout-window - (format nil "~10TCompiler Notes: ~A ~A" view-name definition)))) + (climacs-gui:with-typeout (stream (format nil "Compiler Notes: ~A ~A" view-name definition)) (loop for note in notes do (with-output-as-presentation (stream note 'compiler-note) (print-for-menu note stream)) (terpri stream) count note into length finally (change-space-requirements stream - :height (* length (stream-line-height stream))) + :height (* length (stream-line-height stream))) (scroll-extent stream 0 0))))

(defgeneric goto-location (location)) @@ -351,9 +350,10 @@ function (explicitly via `flet' or `labels', does not expand macros or similar). If no such form can be found, return NIL." (labels ((locally-binding-p (form) - (find-if #'(lambda (symbol) - (form-equal syntax (form-operator form) (string symbol))) - *local-function-definers*)) + (when (form-operator form) + (find-if #'(lambda (symbol) + (form-equal syntax (form-operator form) (string symbol))) + *local-function-definers*))) (match (form-operator) (when form-operator (form-equal syntax form-operator symbol-form))) @@ -419,15 +419,14 @@ (with-drawing-options (stream :ink +dark-blue+ :text-style (make-text-style :fixed nil nil)) (princ (dspec item) stream)))) - (let ((stream (climacs-gui:typeout-window - (format nil "~10T~A ~A" type symbol)))) + (climacs-gui:with-typeout (stream (format nil "~A ~A" type symbol)) (loop for xref in xrefs do (with-output-as-presentation (stream xref 'xref) (printer xref stream)) (terpri stream) count xref into length finally (change-space-requirements stream - :height (* length (stream-line-height stream))) + :height (* length (stream-line-height stream))) (scroll-extent stream 0 0)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

--- /project/climacs/cvsroot/climacs/typeout.lisp 2008/01/20 19:51:48 NONE +++ /project/climacs/cvsroot/climacs/typeout.lisp 2008/01/20 19:51:48 1.1 ;;; -*- Mode: Lisp; Package: CLIMACS-CORE -*-

;;; (c) copyright 2008 by ;;; Troels Henriksen (athas@sigkill.dk)

;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA.

;;; Typeout pane support.

(in-package :climacs-gui)

(defclass typeout-view (drei-view textual-view) ((%output-history :accessor output-history :initform (make-instance 'standard-tree-output-record) :initarg :output-history :documentation "The output record history that will be replayed whenever the views contents are shown.") (%dirty :accessor dirty :initform t :initarg :dirty :documentation "This value indicates whether the output has changed since it was last replayed.")) (:metaclass modual-class) (:documentation "A noneditable Drei view displaying an output record history."))

(defun typeout-view-p (view) "Return true if `view' is a typeout view, false otherwise." (typep view 'typeout-view))

(defmethod handle-redisplay ((pane drei-pane) (view typeout-view) (region region)) (if (and (not (dirty view)) (find (output-history view) (output-record-children (stream-output-history pane)))) (replay (stream-output-history pane) pane region) (call-next-method)))

(defmethod display-drei-view-contents ((pane pane) (view typeout-view))

(with-output-recording-options (pane :record nil :draw t) (with-bounding-rectangle* (x1 y1 x2 y2) (or (pane-viewport pane) pane) (draw-rectangle* pane x1 y1 x2 y2 :ink +background-ink+)) (replay-output-record (output-history view) pane)) (unless (eq (output-record-parent (output-history view)) (stream-output-history pane)) (setf (output-record-parent (output-history view)) nil) (add-output-record (output-history view) (stream-output-history pane))) (setf (dirty view) nil))

(defmethod bounding-rectangle* ((view typeout-view)) (if (output-history view) (bounding-rectangle* (output-history view)) (values 0 0 0 0)))

(defun scroll-typeout-window (window y) "Scroll `window' down by `y' device units, but taking care not to scroll past the size of `window'. If `window' does not have a viewport, do nothing." (let ((viewport (pane-viewport window))) (unless (null viewport) ; Can't scroll without viewport (multiple-value-bind (x-displacement y-displacement) (transform-position (sheet-transformation window) 0 0) (scroll-extent window (- x-displacement) (max 0 (min (+ (- y-displacement) y) (- (bounding-rectangle-height window) (bounding-rectangle-height viewport)))))))))

(defmethod page-down ((pane sheet) (view typeout-view)) (scroll-typeout-window pane (bounding-rectangle-height (pane-viewport pane))))

(defmethod page-up ((pane sheet) (view typeout-view)) (scroll-typeout-window pane (- (bounding-rectangle-height (pane-viewport pane)))))

(defun ensure-typeout-view (climacs label) "Ensure that `climacs' has a typeout view with the name `label', and return that view." (check-type label string) (or (find-if #'(lambda (view) (and (typeout-view-p view) (string= (name view) label))) (views climacs)) (make-new-view-for-climacs climacs 'typeout-view :name label)))

;; Because specialising on the type of `climacs' is so useful... (defun invoke-with-typeout (climacs label 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." (let* ((typeout-view (ensure-typeout-view climacs label)) (pane-with-typeout (or (find typeout-view (windows climacs) :key #'view) (let ((pane (split-window t))) (setf (view pane) typeout-view) pane)))) (let ((new-record (with-output-to-output-record (pane-with-typeout) (with-output-recording-options (pane-with-typeout :record t :draw t) (funcall continuation pane-with-typeout))))) (add-output-record new-record (output-history typeout-view)) (setf (dirty typeout-view) t))))

(defmacro with-typeout ((stream &optional (label "Typeout")) &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 *esa-instance* ,label #'(lambda (,stream) ,@body)))

;;; An implementation of the Gray streams protocol that uses a Climacs ;;; typeout view to draw the output.

(defclass typeout-stream (fundamental-character-output-stream) ((%climacs :reader climacs-instance :initform (error "Must provide a Climacs instance for typeout streams") :initarg :climacs) (%label :reader label :initform (error "A typeout stream must have a label") :initarg :label)) (:documentation "An output stream that performs output on a (single) Climacs typeout pane. If the typeout pane is deleted manually by the user, the stream will recreate it the next time output is performed."))

(defmethod stream-write-char ((stream typeout-stream) char) (with-typeout (typeout (label stream)) (stream-write-char typeout char)))

(defmethod stream-line-column ((stream typeout-stream)) (with-typeout (typeout (label stream)) (stream-line-column typeout)))

(defmethod stream-start-line-p ((stream typeout-stream)) (with-typeout (typeout (label stream)) (stream-start-line-p typeout)))

(defmethod stream-write-string ((stream typeout-stream) string &optional (start 0) end) (with-typeout (typeout (label stream)) (stream-write-string typeout string start end)))

(defmethod stream-terpri ((stream typeout-stream)) (with-typeout (typeout (label stream)) (stream-terpri typeout)))

(defmethod stream-fresh-line ((stream typeout-stream)) (with-typeout (typeout (label stream)) (stream-fresh-line typeout)))

(defmethod stream-finish-output ((stream typeout-stream)) (with-typeout (typeout (label stream)) (stream-finish-output typeout)))

(defmethod stream-force-output ((stream typeout-stream)) (with-typeout (typeout (label stream)) (stream-force-output typeout)))

(defmethod stream-clear-output ((stream typeout-stream)) (with-typeout (typeout (label stream)) (stream-clear-output typeout)))

(defmethod stream-advance-to-column ((stream typeout-stream) (column integer)) (with-typeout (typeout (label stream)) (stream-advance-to-column typeout column)))

(defmethod interactive-stream-p ((stream typeout-stream)) (with-typeout (typeout (label stream)) (interactive-stream-p typeout)))

(defun make-typeout-stream (climacs label) (make-instance 'typeout-stream :climacs climacs :label label))