src/code/pp-backq.lisp

   1 ;;;; pretty-printing of backquote expansions
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB!IMPL")
  13
  14 (file-comment
  15   "$Header$")
  16
  17 (defun backq-unparse-expr (form splicing)
  18   (ecase splicing
  19     ((nil)
  20      `(backq-comma ,form))
  21     ((t)
  22      `((backq-comma-at ,form)))
  23     (:nconc
  24      `((backq-comma-dot ,form)))
  25     ))
  26
  27 (defun backq-unparse (form &optional splicing)
  28   #!+sb-doc
  29   "Given a lisp form containing the magic functions BACKQ-LIST, BACKQ-LIST*,
  30   BACKQ-APPEND, etc. produced by the backquote reader macro, will return a
  31   corresponding backquote input form. In this form, `,' `,@' and `,.' are
  32   represented by lists whose cars are BACKQ-COMMA, BACKQ-COMMA-AT, and
  33   BACKQ-COMMA-DOT respectively, and whose cadrs are the form after the comma.
  34   SPLICING indicates whether a comma-escape return should be modified for
  35   splicing with other forms: a value of T or :NCONC meaning that an extra
  36   level of parentheses should be added."
  37   (cond
  38    ((atom form)
  39     (backq-unparse-expr form splicing))
  40    ((not (null (cdr (last form))))
  41     ;; FIXME: Shouldn't this be an ERROR?
  42     "### illegal dotted backquote form ###")
  43    (t
  44     (case (car form)
  45       (backq-list
  46        (mapcar #'backq-unparse (cdr form)))
  47       (backq-list*
  48        (do ((tail (cdr form) (cdr tail))
  49             (accum nil))
  50            ((null (cdr tail))
  51             (nconc (nreverse accum)
  52                    (backq-unparse (car tail) t)))
  53          (push (backq-unparse (car tail)) accum)))
  54       (backq-append
  55        (mapcan #'(lambda (el) (backq-unparse el t))
  56                (cdr form)))
  57       (backq-nconc
  58        (mapcan #'(lambda (el) (backq-unparse el :nconc))
  59                (cdr form)))
  60       (backq-cons
  61        (cons (backq-unparse (cadr form) nil)
  62              (backq-unparse (caddr form) t)))
  63       (backq-vector
  64        (coerce (backq-unparse (cadr form)) 'vector))
  65       (quote
  66        (cadr form))
  67       (t
  68        (backq-unparse-expr form splicing))))))
  69
  70 (defun pprint-backquote (stream form &rest noise)
  71   (declare (ignore noise))
  72   (write-char #\` stream)
  73   (write (backq-unparse form) :stream stream))
  74
  75 (defun pprint-backq-comma (stream form &rest noise)
  76   (declare (ignore noise))
  77   (ecase (car form)
  78     (backq-comma
  79      (write-char #\, stream))
  80     (backq-comma-at
  81      (princ ",@" stream))
  82     (backq-comma-dot
  83      (princ ",." stream)))
  84   (write (cadr form) :stream stream))
  85
  86 ;;; This is called by !PPRINT-COLD-INIT, fairly late, because
  87 ;;; SET-PPRINT-DISPATCH doesn't work until the compiler works.
  88 ;;;
  89 ;;; FIXME: It might be cleaner to just make these toplevel forms and
  90 ;;; enforce the delay by putting this file late in the build sequence.
  91 (defun !backq-pp-cold-init ()
  92   (set-pprint-dispatch '(cons (eql backq-list)) #'pprint-backquote)
  93   (set-pprint-dispatch '(cons (eql backq-list*)) #'pprint-backquote)
  94   (set-pprint-dispatch '(cons (eql backq-append)) #'pprint-backquote)
  95   (set-pprint-dispatch '(cons (eql backq-nconc)) #'pprint-backquote)
  96   (set-pprint-dispatch '(cons (eql backq-cons)) #'pprint-backquote)
  97   (set-pprint-dispatch '(cons (eql backq-vector)) #'pprint-backquote)
  98
  99   (set-pprint-dispatch '(cons (eql backq-comma)) #'pprint-backq-comma)
 100   (set-pprint-dispatch '(cons (eql backq-comma-at)) #'pprint-backq-comma)
 101   (set-pprint-dispatch '(cons (eql backq-comma-dot)) #'pprint-backq-comma))