;;;; pretty printer stuff which has to be defined early (e.g. DEFMACROs)

  This software is part of the SBCL system . See the README file for
;;;; more information.
;;;;
  This software is derived from the CMU CL system , which was
  written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.

(in-package "SB!PRETTY")

;;;; utilities

(defmacro with-pretty-stream ((stream-var
                               &optional (stream-expression stream-var))
                              &body body)
  (let ((flet-name (sb!xc:gensym "WITH-PRETTY-STREAM")))
    `(flet ((,flet-name (,stream-var)
              ,@body))
       (let ((stream ,stream-expression))
         (if (pretty-stream-p stream)
             (,flet-name stream)
             (catch 'line-limit-abbreviation-happened
               (let ((stream (make-pretty-stream stream)))
                 (,flet-name stream)
                 (force-pretty-output stream)))))
       nil)))

;;;; user interface to the pretty printer

(defmacro pprint-logical-block ((stream-symbol
                                 object
                                 &key
                                 (prefix nil prefixp)
                                 (per-line-prefix nil per-line-prefix-p)
                                 (suffix "" suffixp))
                                &body body)
  #!+sb-doc
  "Group some output into a logical block. STREAM-SYMBOL should be either a
   stream, T (for *TERMINAL-IO*), or NIL (for *STANDARD-OUTPUT*). The printer
   control variable *PRINT-LEVEL* is automatically handled."
  (let ((prefix (cond ((and prefixp per-line-prefix-p)
                       (error "cannot specify values for both PREFIX and PER-LINE-PREFIX."))
                      (prefixp prefix)
                      (per-line-prefix-p per-line-prefix))))
    (let ((object-var (if object (gensym) nil)))
      (once-only ((prefix-var prefix) (suffix-var suffix))
        (multiple-value-bind (stream-var stream-expression)
            (case stream-symbol
              ((nil)
               (values '*standard-output* '*standard-output*))
              ((t)
               (values '*terminal-io* '*terminal-io*))
              (t
               (values stream-symbol
                       (once-only ((stream stream-symbol))
                         `(case ,stream
                            ((nil) *standard-output*)
                            ((t) *terminal-io*)
                            (t ,stream))))))
          (let* ((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 (or prefixp per-line-prefix-p)
                               `((declare (string ,prefix-var))))
                       ,@(when (and suffixp)
                               `((declare (string ,suffix-var))))
                       (start-logical-block ,stream-var
                                            ,prefix-var
                                            ,(if per-line-prefix-p t nil)
                                            ,suffix-var)
                       (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)))))
            (when object
              (setf body
                    `(let ((,object-var ,object))
                       (if (listp ,object-var)
                           (with-circularity-detection (,object-var ,stream-var)
                             ,body)
                           (output-object ,object-var ,stream-var)))))
            `(with-pretty-stream (,stream-var ,stream-expression)
               ,body)))))))

(defmacro pprint-exit-if-list-exhausted ()
  #!+sb-doc
  "Cause the closest enclosing use of PPRINT-LOGICAL-BLOCK to return
   if its list argument is exhausted. Can only be used inside
   PPRINT-LOGICAL-BLOCK, and only when the LIST argument to
   PPRINT-LOGICAL-BLOCK is supplied."
  (error "PPRINT-EXIT-IF-LIST-EXHAUSTED must be lexically inside ~
          PPRINT-LOGICAL-BLOCK."))

(defmacro pprint-pop ()
  #!+sb-doc
  "Return the next element from LIST argument to the closest enclosing
   use of PPRINT-LOGICAL-BLOCK, automatically handling *PRINT-LENGTH*
   and *PRINT-CIRCLE*. Can only be used inside PPRINT-LOGICAL-BLOCK.
   If the LIST argument to PPRINT-LOGICAL-BLOCK was NIL, then nothing
   is popped, but the *PRINT-LENGTH* testing still happens."
  (error "PPRINT-POP must be lexically inside PPRINT-LOGICAL-BLOCK."))

 pretty printer stuff which has to be defined early (e.g. DEFMACROs)
 more information.

 public domain. The software is in the public domain and is
 provided with absolutely no warranty. See the COPYING and CREDITS
 files for more information.
 utilities
 user interface to the pretty printer
 macro too. It might be worth looking at this to make
 is called many times from system pretty-printing code.

 argument order, multiple evaluation, etc. of its
 keyword (:PREFIX, :PER-LINE-PREFIX and :SUFFIX)
 arguments.  Dunno if that's legal.
 FIXME: Don't we need UNWIND-PROTECT to ensure this
 always gets executed?

  This software is part of the SBCL system . See the README file for
  This software is derived from the CMU CL system , which was
  written at Carnegie Mellon University and released into the

(in-package "SB!PRETTY")


(defmacro with-pretty-stream ((stream-var
                               &optional (stream-expression stream-var))
                              &body body)
  (let ((flet-name (sb!xc:gensym "WITH-PRETTY-STREAM")))
    `(flet ((,flet-name (,stream-var)
              ,@body))
       (let ((stream ,stream-expression))
         (if (pretty-stream-p stream)
             (,flet-name stream)
             (catch 'line-limit-abbreviation-happened
               (let ((stream (make-pretty-stream stream)))
                 (,flet-name stream)
                 (force-pretty-output stream)))))
       nil)))


(defmacro pprint-logical-block ((stream-symbol
                                 object
                                 &key
                                 (prefix nil prefixp)
                                 (per-line-prefix nil per-line-prefix-p)
                                 (suffix "" suffixp))
                                &body body)
  #!+sb-doc
  "Group some output into a logical block. STREAM-SYMBOL should be either a
   stream, T (for *TERMINAL-IO*), or NIL (for *STANDARD-OUTPUT*). The printer
   control variable *PRINT-LEVEL* is automatically handled."
  (let ((prefix (cond ((and prefixp per-line-prefix-p)
                       (error "cannot specify values for both PREFIX and PER-LINE-PREFIX."))
                      (prefixp prefix)
                      (per-line-prefix-p per-line-prefix))))
    (let ((object-var (if object (gensym) nil)))
      (once-only ((prefix-var prefix) (suffix-var suffix))
        (multiple-value-bind (stream-var stream-expression)
            (case stream-symbol
              ((nil)
               (values '*standard-output* '*standard-output*))
              ((t)
               (values '*terminal-io* '*terminal-io*))
              (t
               (values stream-symbol
                       (once-only ((stream stream-symbol))
                         `(case ,stream
                            ((nil) *standard-output*)
                            ((t) *terminal-io*)
                            (t ,stream))))))
          (let* ((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
  sure it 's not too bloated , since PPRINT - LOGICAL - BLOCK
  FIXME : I think pprint - logical - block is broken wrt
                  `(descend-into (,stream-var)
                     (let ((,count-name 0))
                       (declare (type index ,count-name) (ignorable ,count-name))
                       ,@(when (or prefixp per-line-prefix-p)
                               `((declare (string ,prefix-var))))
                       ,@(when (and suffixp)
                               `((declare (string ,suffix-var))))
                       (start-logical-block ,stream-var
                                            ,prefix-var
                                            ,(if per-line-prefix-p t nil)
                                            ,suffix-var)
                       (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))))
                       (end-logical-block ,stream-var)))))
            (when object
              (setf body
                    `(let ((,object-var ,object))
                       (if (listp ,object-var)
                           (with-circularity-detection (,object-var ,stream-var)
                             ,body)
                           (output-object ,object-var ,stream-var)))))
            `(with-pretty-stream (,stream-var ,stream-expression)
               ,body)))))))

(defmacro pprint-exit-if-list-exhausted ()
  #!+sb-doc
  "Cause the closest enclosing use of PPRINT-LOGICAL-BLOCK to return
   if its list argument is exhausted. Can only be used inside
   PPRINT-LOGICAL-BLOCK, and only when the LIST argument to
   PPRINT-LOGICAL-BLOCK is supplied."
  (error "PPRINT-EXIT-IF-LIST-EXHAUSTED must be lexically inside ~
          PPRINT-LOGICAL-BLOCK."))

(defmacro pprint-pop ()
  #!+sb-doc
  "Return the next element from LIST argument to the closest enclosing
   use of PPRINT-LOGICAL-BLOCK, automatically handling *PRINT-LENGTH*
   and *PRINT-CIRCLE*. Can only be used inside PPRINT-LOGICAL-BLOCK.
   If the LIST argument to PPRINT-LOGICAL-BLOCK was NIL, then nothing
   is popped, but the *PRINT-LENGTH* testing still happens."
  (error "PPRINT-POP must be lexically inside PPRINT-LOGICAL-BLOCK."))
