🚀 go-pugleaf

There is an ambiguity in how CL handles the printing of circular
references when a print-function is defined for a structure.  I want
to write out possibly circular structures in such a way that they can
be read back in.  As long as I want to print all of the slots in the
structures, I can do this by setting *print-circle* to T.  But, I have
defstructs that point to objects that can't be printed like closures.
What I think I should be able to do is define a :print-function for my
structure that prints out #S syntax without all of the slots.

(defstruct (woof (:print-function print-woof)) 
  a b)

(defun print-woof (woof stream depth)
  (format stream "#S(WOOF A ~A)" (woof-a woof)))

(progn
  (setf *a (make-woof)
	*b (make-woof)
	(woof-a *a) *b
	(woof-b *a) (let* ((a 3))
		      #'(lambda (x) (+ x a)))
	(woof-a *b) *a
	*print-circle* t)
  (print *a))

Some implementations handle this, but most don't.  My reading of the
spec says that the printer will handle circular references when
*print-circle* is T.  It doesn't say anything about not handling it
when you have print functions on structures.  One way to get this
behavior is to have write check for circular structures something like
this:

;;;
(defvar *REAL-PRINT-CIRCLE* nil
  "Global to control printing of circular objects.")
(defvar *PRINT-HASH-TABLE* (make-hash-table)
  "Hash table from objects being printed to their reader number.")
(defvar *PRINT-COUNTER* 0
  "Current counter number.")

;;;
(unless (fboundp 'old-write)
  (setf (symbol-function 'old-write) (symbol-function 'write)))

;;;
(defun WRITE (object
              &rest args
              &key 
              (circle *print-circle*)
              (stream *standard-output*)
              &allow-other-keys)
  "Fixed write function."
  (if (or (symbolp object) (numberp object) (stringp object))
    ;; Never have circular references
    (apply #'old-write object args)
    (if *real-print-circle*
      ;; We've already entered write the circle T
      (let* ((number (gethash object *print-hash-table*)))
        (if number
          (format stream "#~A#" number)
          (progn
            (setf (gethash object *print-hash-table*)
                  (incf *print-counter*))
            (format stream "#~A=" *print-counter*)
            (apply #'old-write object args))))
      (progn
        (if circle
          ;; First time with circle T
          (let* ((*real-print-circle* t))
            (setf (getf args :circle) nil)
            (apply #'write object args)
            (setq *print-counter* 0)
            (clrhash *print-hash-table*))
          ;; Circle is nil
          (apply #'old-write object args)))))
  object)

This approach does generate a #n for every list, array, etc.  If I set
*print-circle* to T, I am perfectly willing to have a #n= for every
list, array and structure.  No it is not pretty, but the primary
purpose of the #n syntax is not to make it so that its pretty, but to
make it so that objects can be written and then read back in using the
reader.  Since CLTL explicitly specifies that some things (like
closures) do need to be written in a way that can be read, I do not
think that it is unreasonable to have the printer support
print-functions that suppress those values.  I would write this stuff
myself, except that there is no portable way to find the names of
slots in defstructs.  (Even if there were, monsterous defstructs like
those used in CLOS where every slot is an array with all sorts of
garbage in them would still be a problem.)

Has this been addressed by the cleanup committee?