0.7.5.15:
[sbcl.git] / 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 (defun backq-unparse-expr (form splicing)
15   (ecase splicing
16     ((nil)
17      `(backq-comma ,form))
18     ((t)
19      `((backq-comma-at ,form)))
20     (:nconc
21      `((backq-comma-dot ,form)))
22     ))
23
24 (defun backq-unparse (form &optional splicing)
25   #!+sb-doc
26   "Given a lisp form containing the magic functions BACKQ-LIST, BACKQ-LIST*,
27   BACKQ-APPEND, etc. produced by the backquote reader macro, will return a
28   corresponding backquote input form. In this form, `,' `,@' and `,.' are
29   represented by lists whose cars are BACKQ-COMMA, BACKQ-COMMA-AT, and
30   BACKQ-COMMA-DOT respectively, and whose cadrs are the form after the comma.
31   SPLICING indicates whether a comma-escape return should be modified for
32   splicing with other forms: a value of T or :NCONC meaning that an extra
33   level of parentheses should be added."
34   (cond
35    ((atom form)
36     (backq-unparse-expr form splicing))
37    ((not (null (cdr (last form))))
38     ;; FIXME: Shouldn't this be an ERROR?
39     "### illegal dotted backquote form ###")
40    (t
41     (case (car form)
42       (backq-list
43        (mapcar #'backq-unparse (cdr form)))
44       (backq-list*
45        (do ((tail (cdr form) (cdr tail))
46             (accum nil))
47            ((null (cdr tail))
48             (nconc (nreverse accum)
49                    (backq-unparse (car tail) t)))
50          (push (backq-unparse (car tail)) accum)))
51       (backq-append
52        (mapcan (lambda (el) (backq-unparse el t))
53                (cdr form)))
54       (backq-nconc
55        (mapcan (lambda (el) (backq-unparse el :nconc))
56                (cdr form)))
57       (backq-cons
58        (cons (backq-unparse (cadr form) nil)
59              (backq-unparse (caddr form) t)))
60       (backq-vector
61        (coerce (backq-unparse (cadr form)) 'vector))
62       (quote
63        (cadr form))
64       (t
65        (backq-unparse-expr form splicing))))))
66
67 (defun pprint-backquote (stream form &rest noise)
68   (declare (ignore noise))
69   (write-char #\` stream)
70   (write (backq-unparse form) :stream stream))
71
72 (defun pprint-backq-comma (stream form &rest noise)
73   (declare (ignore noise))
74   (ecase (car form)
75     (backq-comma
76      (write-char #\, stream))
77     (backq-comma-at
78      (princ ",@" stream))
79     (backq-comma-dot
80      (princ ",." stream)))
81   (write (cadr form) :stream stream))
82
83 ;;; This is called by !PPRINT-COLD-INIT, fairly late, because
84 ;;; SET-PPRINT-DISPATCH doesn't work until the compiler works.
85 ;;;
86 ;;; FIXME: It might be cleaner to just make these be toplevel forms and
87 ;;; enforce the delay by putting this file late in the build sequence.
88 (defun !backq-pp-cold-init ()
89   (set-pprint-dispatch '(cons (eql backq-list)) #'pprint-backquote)
90   (set-pprint-dispatch '(cons (eql backq-list*)) #'pprint-backquote)
91   (set-pprint-dispatch '(cons (eql backq-append)) #'pprint-backquote)
92   (set-pprint-dispatch '(cons (eql backq-nconc)) #'pprint-backquote)
93   (set-pprint-dispatch '(cons (eql backq-cons)) #'pprint-backquote)
94   (set-pprint-dispatch '(cons (eql backq-vector)) #'pprint-backquote)
95
96   (set-pprint-dispatch '(cons (eql backq-comma)) #'pprint-backq-comma)
97   (set-pprint-dispatch '(cons (eql backq-comma-at)) #'pprint-backq-comma)
98   (set-pprint-dispatch '(cons (eql backq-comma-dot)) #'pprint-backq-comma))