;;;; DEFPRINTER

;;;; 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 "ESB-UTILS")

;;; These functions are called by the expansion of the DEFPRINTER
;;; macro to do the actual printing.
(declaim (ftype (function (symbol t stream) (values))
                defprinter-prin1 defprinter-princ))
(defun defprinter-prin1 (name value stream)
  (defprinter-prinx #'prin1 name value stream))
(defun defprinter-princ (name value stream)
  (defprinter-prinx #'princ name value stream))
(defun defprinter-prinx (prinx name value stream)
  (declare (type function prinx))
  (when *print-pretty*
    (pprint-newline :linear stream))
  (format stream ":~A " name)
  (funcall prinx value stream)
  (values))
(defun defprinter-print-space (stream)
  (write-char #\space stream))

;;; Define some kind of reasonable PRINT-OBJECT method for a
;;; STRUCTURE-OBJECT class.
;;;
;;; NAME is the name of the structure class, and CONC-NAME is the same
;;; as in DEFSTRUCT.
;;;
;;; The SLOT-DESCS describe how each slot should be printed. Each
;;; SLOT-DESC can be a slot name, indicating that the slot should
;;; simply be printed. A SLOT-DESC may also be a list of a slot name
;;; and other stuff. The other stuff is composed of keywords followed
;;; by expressions. The expressions are evaluated with the variable
;;; which is the slot name bound to the value of the slot. These
;;; keywords are defined:
;;;
;;; :PRIN1    Print the value of the expression instead of the slot value.
;;; :PRINC    Like :PRIN1, only PRINC the value
;;; :TEST     Only print something if the test is true.
;;;
;;; If no printing thing is specified then the slot value is printed
;;; as if by PRIN1.
;;;
;;; The structure being printed is bound to STRUCTURE and the stream
;;; is bound to STREAM.
(defmacro defprinter ((name
                       &key
                       (conc-name (concatenate 'simple-string
                                               (symbol-name name)
                                               "-"))
                       identity)
                      &rest slot-descs)
  (let ((first? t)
        maybe-print-space
        (reversed-prints nil)
        (stream (gensym "STREAM")))
    (flet ((sref (slot-name)
             `(,(symbolicate conc-name slot-name) structure)))
      (dolist (slot-desc slot-descs)
        (if first?
            (setf maybe-print-space nil
                  first? nil)
            (setf maybe-print-space `(defprinter-print-space ,stream)))
        (cond ((atom slot-desc)
               (push maybe-print-space reversed-prints)
               (push `(defprinter-prin1 ',slot-desc ,(sref slot-desc) ,stream)
                     reversed-prints))
              (t
               (let ((sname (first slot-desc))
                     (test t))
                 (collect ((stuff))
                   (do ((option (rest slot-desc) (cddr option)))
                       ((null option)
                        (push `(let ((,sname ,(sref sname)))
                                 (when ,test
                                   ,maybe-print-space
                                   ,@(or (stuff)
                                         `((defprinter-prin1
                                             ',sname ,sname ,stream)))))
                              reversed-prints))
                     (case (first option)
                       (:prin1
                        (stuff `(defprinter-prin1
                                  ',sname ,(second option) ,stream)))
                       (:princ
                        (stuff `(defprinter-princ
                                  ',sname ,(second option) ,stream)))
                       (:test (setq test (second option)))
                       (t
                        (error "bad option: ~S" (first option)))))))))))
    `(defmethod print-object ((structure ,name) ,stream)
       (pprint-logical-block (,stream nil)
         (print-unreadable-object (structure
                                   ,stream
                                   :type t
                                   :identity ,identity)
           ,@(nreverse reversed-prints))))))

;;; EOF
