[climacs-cvs] CVS climacs
thenriksen
thenriksen at common-lisp.net
Sun Jan 20 19:51:48 UTC 2008
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 at free.fr)
;;; (c) copyright 2005 by
;;; Aleksandar Bakic (a_bakic at yahoo.com)
+;;; (c) copyright 2006-2008 by
+;;; Troels Henriksen (athas at 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 at 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)
, at 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))
More information about the Climacs-cvs
mailing list