- (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
+ (block-name (sb!xc:gensym "PPRINT-LOGICAL-BLOCK-"))
+ (count-name (gensym "PPRINT-LOGICAL-BLOCK-LENGTH-"))
+ (pp-pop-name (sb!xc: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 (sb!int:constant-typep
+ (or prefix per-line-prefix)
+ 'string
+ env)))
+ `((unless (typep ,(or prefix per-line-prefix) 'string)
+ (error 'type-error
+ :datum ,(or prefix per-line-prefix)
+ :expected-type 'string))))
+ ,@(when (and suffixp
+ (not (sb!int:constant-typep suffix 'string env)))
+ `((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