Our exploration of pretty-printing has now reached the point where we’ll show real code instead of just describing some functions.  We’ve arrived at pprint-logical-block, which is the starting point for constructing pretty-printing functions.

The pprint-logical-block macro sets up a pretty-printing context inside of which the programmer writes his or her pretty-printing directives.  The required arguments are the stream and the object to be printed.  If the object to be printed is not a list, this macro simply sends the object to write, but if it is a list, then objects in the list can be retrieved with pprint-pop, and the logical block is exited by calling pprint-exit-if-list-exhausted.

One important restriction is that pprint-logical-block must not modify the values of variables not bound within the block itself.  The reason for this is that, during circularity detection, the entire block may be executed more than once, causing these side-effects to be invoked an unpredictable number of times.

So, now we will define a special pretty-printing function.  This function will act on lists whose first element is the keyword :SPECIAL.  In that case, this first entry in the list is skipped, and the following entries are printed out, one to a line, with an index number and the type, enclosed in brace brackets instead of parentheses, and with an SP: prefix to denote this behaviour:

(defun my-special-pprint (stream obj)
  (pprint-logical-block (stream obj 
                                :prefix "SP: { "
                                :suffix "}")
    (let ((ctr 0))
      (pprint-pop)
      (pprint-newline :mandatory stream)
      (do ()
          (nil)
        (pprint-exit-if-list-exhausted)
        (let ((entry (pprint-pop)))
          (write entry :stream stream)
          (pprint-tab :section-relative 6 6 stream)
          (format stream
                  "<--- Entry #~D.  ~A" 
                  ctr (type-of entry)))
        (incf ctr)
        (pprint-newline :mandatory stream)
        ))))

Next is the function that we use to demonstrate the new printing.  Notice that I set the *print-pretty* special variable in an enclosing let form to allow automatic restoration of its value after the various setf calls have finished modifying it.  We discussed this, and special variables in general, as an aside in the article on print.  Here is the function:

(defun demonstrate ()
  (set-pprint-dispatch '(cons (member :SPECIAL))
                       'my-special-pprint 10.0)

  (let ((list-1 (list 1.0d0 "2" :THREE '(:SPECIAL 4.0d0) 5.0d0))
        (list-2 (list :SPECIAL 1.0d0 "2" :THREE '(:SPECIAL 4.0d0) 5.0d0))
        (*print-pretty* nil))

    (setf *print-pretty* nil)
    (format t "Non-pretty-printing a list:~%")
    (print list-1)
    (setf *print-pretty* t)
    (terpri)
    (terpri)
    (terpri)
    (format t "Pretty-printing the same list:~%")
    (print list-1)
    (terpri)
    (terpri)
    (terpri)
    (setf *print-pretty* nil)
    (format t "Non-pretty-printing another list:~%")
    (print list-2)
    (terpri)
    (terpri)
    (terpri)
    (setf *print-pretty* t)
    (format t "Pretty-printing the second list:~%")
    (print list-2)
    (values)))

Finally, here is the output. You’ll notice that this function is recursively dispatched when appropriate.

CL-USER> (demonstrate)
Non-pretty-printing a list:

(1.0d0 "2" :THREE (:SPECIAL 4.0d0) 5.0d0) 


Pretty-printing the same list:

(1.0d0 "2" :THREE
 SP: {
       4.0d0       <--- Entry #0.  DOUBLE-FLOAT
       }
 5.0d0) 


Non-pretty-printing another list:

(:SPECIAL 1.0d0 "2" :THREE (:SPECIAL 4.0d0) 5.0d0) 


Pretty-printing the second list:

SP: {
      1.0d0       <--- Entry #0.  DOUBLE-FLOAT
      "2"         <--- Entry #1.  (SIMPLE-ARRAY CHARACTER (1))
      :THREE      <--- Entry #2.  KEYWORD
      SP: {
            4.0d0       <--- Entry #0.  DOUBLE-FLOAT
            }           <--- Entry #3.  CONS
      5.0d0       <--- Entry #4.  DOUBLE-FLOAT
      } 
; No value