- (block-name (gensym "PPRINT-LOGICAL-BLOCK-"))
- (count-name (gensym "PPRINT-LOGICAL-BLOCK-LENGTH-"))
- (pp-pop-name (gensym "PPRINT-POP-"))
- (body
- ;; FIXME: It looks as though PPRINT-LOGICAL-BLOCK might
- ;; expand into a boatload of code, since DESCEND-INTO is a
- ;; macro too. It might be worth looking at this to make
- ;; sure it's not too bloated, since PPRINT-LOGICAL-BLOCK
- ;; is called many times from system pretty-printing code.
- ;;
- ;; FIXME: I think pprint-logical-block is broken wrt
- ;; argument order, multiple evaluation, etc. of its
- ;; keyword (:PREFIX, :PER-LINE-PREFIX and :SUFFIX)
- ;; arguments. Dunno if that's legal.
- `(descend-into (,stream-var)
- (let ((,count-name 0))
- (declare (type index ,count-name) (ignorable ,count-name))
- ,@(when (or prefixp per-line-prefix-p)
- `((unless (typep ,(or prefix per-line-prefix) 'string)
- (error 'type-error
- :datum ,(or prefix per-line-prefix)
- :expected-type 'string))))
- ,@(when suffixp
- `((unless (typep ,suffix 'string)
- (error 'type-error
- :datum ,suffix
- :expected-type 'string))))
- (start-logical-block ,stream-var
- ,(if (or prefixp per-line-prefix-p)
- (or prefix per-line-prefix)
- nil)
- ,(if per-line-prefix-p t nil)
- ,suffix)
- (block ,block-name
- (flet ((,pp-pop-name ()
- ,@(when object
- `((unless (listp ,object-var)
- (write-string ". " ,stream-var)
- (output-object ,object-var ,stream-var)
- (return-from ,block-name nil))))
- (when (and (not *print-readably*)
- (eql ,count-name *print-length*))
- (write-string "..." ,stream-var)
- (return-from ,block-name nil))
- ,@(when object
- `((when (and ,object-var
- (plusp ,count-name)
- (check-for-circularity
- ,object-var))
- (write-string ". " ,stream-var)
- (output-object ,object-var ,stream-var)
- (return-from ,block-name nil))))
- (incf ,count-name)
- ,@(when object
- `((pop ,object-var)))))
- (locally
- (declare (disable-package-locks
- pprint-pop pprint-exit-if-list-exhausted))
- (macrolet ((pprint-pop ()
- '(,pp-pop-name))
- (pprint-exit-if-list-exhausted ()
- ,(if object
- `'(when (null ,object-var)
- (return-from ,block-name nil))
- `'(return-from ,block-name nil))))
- (declare (enable-package-locks
- pprint-pop pprint-exit-if-list-exhausted))
- ,@body))))
- ;; FIXME: Don't we need UNWIND-PROTECT to ensure this
- ;; always gets executed?
- (end-logical-block ,stream-var)))))
+ (block-name (gensym "PPRINT-LOGICAL-BLOCK-"))
+ (count-name (gensym "PPRINT-LOGICAL-BLOCK-LENGTH-"))
+ (pp-pop-name (gensym "PPRINT-POP-"))
+ (body
+ ;; FIXME: It looks as though PPRINT-LOGICAL-BLOCK might
+ ;; expand into a boatload of code, since DESCEND-INTO is a
+ ;; macro too. It might be worth looking at this to make
+ ;; sure it's not too bloated, since PPRINT-LOGICAL-BLOCK
+ ;; is called many times from system pretty-printing code.
+ ;;
+ ;; FIXME: I think pprint-logical-block is broken wrt
+ ;; argument order, multiple evaluation, etc. of its
+ ;; keyword (:PREFIX, :PER-LINE-PREFIX and :SUFFIX)
+ ;; arguments. Dunno if that's legal.
+ `(descend-into (,stream-var)
+ (let ((,count-name 0))
+ (declare (type index ,count-name) (ignorable ,count-name))
+ ,@(when (and (or prefixp per-line-prefix-p)
+ (not (and (sb!xc:constantp (or prefix per-line-prefix) env)
+ ;; KLUDGE: EVAL-IN-ENV would
+ ;; be useful here.
+ (typep (eval (or prefix per-line-prefix)) 'string))))
+ `((unless (typep ,(or prefix per-line-prefix) 'string)
+ (error 'type-error
+ :datum ,(or prefix per-line-prefix)
+ :expected-type 'string))))
+ ,@(when (and suffixp
+ (not (and (sb!xc:constantp suffix env)
+ (typep (eval suffix) 'string))))
+ `((unless (typep ,suffix 'string)
+ (error 'type-error
+ :datum ,suffix
+ :expected-type 'string))))
+ (start-logical-block ,stream-var
+ ,(if (or prefixp per-line-prefix-p)
+ (or prefix per-line-prefix)
+ nil)
+ ,(if per-line-prefix-p t nil)
+ ,suffix)
+ (block ,block-name
+ (flet ((,pp-pop-name ()
+ ,@(when object
+ `((unless (listp ,object-var)
+ (write-string ". " ,stream-var)
+ (output-object ,object-var ,stream-var)
+ (return-from ,block-name nil))))
+ (when (and (not *print-readably*)
+ (eql ,count-name *print-length*))
+ (write-string "..." ,stream-var)
+ (return-from ,block-name nil))
+ ,@(when object
+ `((when (and ,object-var
+ (plusp ,count-name)
+ (check-for-circularity
+ ,object-var
+ nil
+ :logical-block))
+ (write-string ". " ,stream-var)
+ (output-object ,object-var ,stream-var)
+ (return-from ,block-name nil))))
+ (incf ,count-name)
+ ,@(if object
+ `((pop ,object-var))
+ `(nil))))
+ (declare (ignorable (function ,pp-pop-name)))
+ (locally
+ (declare (disable-package-locks
+ pprint-pop pprint-exit-if-list-exhausted))
+ (macrolet ((pprint-pop ()
+ '(,pp-pop-name))
+ (pprint-exit-if-list-exhausted ()
+ ,(if object
+ `'(when (null ,object-var)
+ (return-from ,block-name nil))
+ `'(return-from ,block-name nil))))
+ (declare (enable-package-locks
+ pprint-pop pprint-exit-if-list-exhausted))
+ ,@body))))
+ ;; FIXME: Don't we need UNWIND-PROTECT to ensure this
+ ;; always gets executed?
+ (end-logical-block ,stream-var)))))