Permalink
Browse files

Implemented indenting-output. Also, encapsulating stream hackery,

end-of-page-action fix, and stream-increment-cursor-position compliance fix.
  • Loading branch information...
Andy Hefner
Andy Hefner committed Apr 10, 2003
1 parent 3dbd608 commit cc178bfeeaae692438fcf76377b5cd70c76101da
Showing with 94 additions and 6 deletions.
  1. +47 −0 encapsulate.lisp
  2. +9 −6 stream-output.lisp
  3. +38 −0 text-formatting.lisp
View
@@ -395,9 +395,18 @@ state ~S lambda list ~S"
;;; Text Style binding forms
+#+nil
(def-stream-method invoke-with-text-style
((stream standard-encapsulating-stream) continuation text-style))
+(defmethod invoke-with-text-style ((stream standard-encapsulating-stream)
+ continuation text-style)
+ (invoke-with-text-style (slot-value stream 'stream)
+ #'(lambda (medium)
+ (declare (ignore medium))
+ (funcall continuation stream))
+ text-style))
+
;;; Drawing functions
(def-stream-method medium-draw-point* ((stream standard-encapsulating-stream)
@@ -582,21 +591,59 @@ state ~S lambda list ~S"
((stream standard-encapsulating-stream)
string start end text-style width height baseline))
+#+nil
(def-stream-method invoke-with-output-recording-options
((stream standard-encapsulating-stream) continuation record draw))
+(defmethod invoke-with-output-recording-options
+ ((stream standard-encapsulating-stream) continuation record draw)
+ (invoke-with-output-recording-options
+ (slot-value stream 'stream)
+ #'(lambda (old-stream)
+ (declare (ignore old-stream))
+ (funcall continuation stream))
+ record
+ draw))
+
+#+nil
(def-stream-method invoke-with-new-output-record
((stream standard-encapsulating-stream) continuation record-type
&rest initargs
&key
&allow-other-keys))
+(defmethod invoke-with-new-output-record ((stream standard-encapsulating-stream)
+ continuation record-type
+ &rest initargs &key &allow-other-keys)
+ (apply #'invoke-with-new-output-record
+ (slot-value stream 'stream)
+ #'(lambda (inner-stream output-record)
+ (declare (ignore inner-stream))
+ (funcall continuation stream output-record))
+ record-type
+ initargs))
+
+#+nil
(def-stream-method invoke-with-output-to-output-record
((stream standard-encapsulating-stream) continuation record-type
&rest initargs
&key
&allow-other-keys))
+(defmethod invoke-with-output-to-output-record
+ ((stream standard-encapsulating-stream) continuation record-type
+ &rest initargs
+ &key
+ &allow-other-keys)
+ (invoke-with-output-to-output-record
+ (slot-value stream 'stream)
+ #'(lambda (inner-stream record)
+ (declare (ignore inner-stream))
+ (funcall continuation stream record))
+ record-type
+ initargs))
+
+
;;; Presentation type generics
View
@@ -240,7 +240,9 @@
(defmethod stream-increment-cursor-position ((stream standard-extended-output-stream) dx dy)
(multiple-value-bind (x y) (cursor-position (stream-text-cursor stream))
- (setf (cursor-position (stream-text-cursor stream)) (values (+ x dx) (+ y dy)))))
+ (let ((dx (or dx 0))
+ (dy (or dy 0)))
+ (setf (cursor-position (stream-text-cursor stream)) (values (+ x dx) (+ y dy))))))
;;;
@@ -323,7 +325,7 @@ than one line of output."))
cy (+ cy height vspace))
(when (> (+ cy height) view-height)
(ecase (stream-end-of-page-action stream)
- (:scroll
+ ((:scroll :allow)
(let ((jump 0))
(with-slots (seos-current-width seos-current-height) stream
(setf seos-current-width (max (bounding-rectangle-width stream))
@@ -335,10 +337,11 @@ than one line of output."))
;;(scroll-vertical stream (+ height vspace))
)
(:wrap
- (setq cy 0))
- (:allow
- )))
- (scroll-extent stream 0 (max 0 (- (+ cy height) %view-height)))
+ (setq cy 0))))
+ (unless (eq :allow (stream-end-of-page-action stream))
+ (scroll-extent stream 0 (max 0 (- (+ cy height) %view-height))))
+
+
;; mikemac says that this "erase the new line" behavior is
;; required by the stream text protocol, but I don't see
;; it. I'm happy to put this back in again, but in the
View
@@ -114,3 +114,41 @@ SUPPRESS-SPACE-AFTER-CONJUNCTION are non-standard."
,@body))
,@args)))
+;;; indenting-output
+
+(defclass indenting-output-stream (standard-encapsulating-stream
+ extended-output-stream
+ output-recording-stream)
+ ((indentation :accessor indentation)))
+
+(defmethod initialize-instance :after ((obj indenting-output-stream)
+ &key (indent-spec 0) &allow-other-keys)
+ (setf (indentation obj) (parse-space (encapsulating-stream-stream obj)
+ indent-spec
+ :horizontal)))
+
+(defmethod stream-write-char :around ((stream indenting-output-stream) char)
+ (let ((under-stream (encapsulating-stream-stream stream)))
+ (when (stream-start-line-p under-stream)
+ (stream-increment-cursor-position under-stream (indentation stream) nil))
+ (call-next-method)))
+
+(defmethod stream-write-string :around ((stream indenting-output-stream)
+ string &optional (start 0) end)
+ (loop for i from start below end
+ do (stream-write-char stream (aref string i))))
+
+(defmacro indenting-output ((stream indent &key (move-cursor T)) &body body)
+ (when (eq stream T)
+ (setq stream '*standard-output*))
+ (with-gensyms (old-x old-y)
+ `(multiple-value-bind (,old-x ,old-y)
+ (stream-cursor-position ,stream)
+ (let ((,stream (make-instance
+ 'indenting-output-stream
+ :stream ,stream
+ :indent-spec ,indent)))
+ ,@body)
+ (unless ,move-cursor
+ (setf (stream-cursor-position ,stream)
+ (values ,old-x ,old-y))))))

0 comments on commit cc178bf

Please sign in to comment.