Changeset 880


Ignore:
Timestamp:
Sep 25, 2004, 9:15:29 PM (16 years ago)
Author:
gb
Message:

WITH-POPUP-DISPLAY: use typeout-stream (from Alex Crain.)

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/ccl/hemlock/src/macros.lisp

    r735 r880  
    546546
    547547
     548
    548549(defmacro with-pop-up-display ((var &key height (buffer-name "Random Typeout"))
    549550                               &body body)
     551  (declare (ignore buffer-name))
     552
     553
    550554  "Execute body in a context with var bound to a stream.  Output to the stream
    551555   appears in the buffer named buffer-name.  The pop-up display appears after
     
    556560  (let ((cleanup-p (gensym))
    557561        (stream (gensym)))
    558     `(let ((,cleanup-p nil)
    559            (,stream (get-random-typeout-info ,buffer-name ,height)))
     562    `(let ()
     563       (let ((,stream (ccl::typeout-stream)))
     564       (ccl::stream-clear-output (ccl::typeout-stream))
    560565       (unwind-protect
    561566           (progn
    562567             (catch 'more-punt
    563                ,(when height
    564                   ;; Test height since it may be supplied, but evaluate
    565                   ;; to nil.
    566                   `(when ,height
    567                        (prepare-for-random-typeout ,stream ,height)
    568                        (setf ,cleanup-p t)))
    569568               (let ((,var ,stream))
    570569                 ;; GB ,@decls
    571570                 (multiple-value-prog1
    572                      (locally ,@body)
    573                    (unless ,height
    574                      (prepare-for-random-typeout ,stream nil)
    575                      (setf ,cleanup-p t)
    576                      (funcall (device-random-typeout-full-more
    577                                (device-hunk-device
    578                                 (window-hunk
    579                                  (random-typeout-stream-window ,stream))))
    580                               ,stream))
    581                    (end-random-typeout ,var))))
    582              (setf ,cleanup-p nil))
    583          (when ,cleanup-p (random-typeout-cleanup ,stream))))))
     571                     (locally ,@body))))))))))
     572
    584573
    585574(declaim (special *random-typeout-ml-fields* *buffer-names*))
Note: See TracChangeset for help on using the changeset viewer.