1 ;;;; the backquote reader macro
3 ;;;; This software is part of the SBCL system. See the README file for
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.
12 (in-package "SB!IMPL")
14 (/show0
"entering backq.lisp")
16 ;; An unquoting COMMA struct.
17 (defstruct (comma (:constructor unquote
(expr &optional
(kind 0)))
18 #+sb-xc-host
(:include structure
!object
)
19 ;; READing unpretty commas requires a default constructor.
20 ;; Not needed on the host.
21 #-sb-xc-host
(:constructor %default-comma-constructor
)
23 (expr nil
:read-only t
)
24 (kind nil
:read-only t
:type
(member 0 1 2)))
25 #+sb-xc
(declaim (freeze-type comma
))
27 (defconstant !+comma-dot
+ 1)
28 (defconstant !+comma-at
+ 2)
29 (defun unquote-nsplice (x) (unquote x
!+comma-dot
+))
30 (defun unquote-splice (x) (unquote x
!+comma-at
+))
31 (defun unquote* (list) (mapcar #'unquote list
))
32 (defun unquote*-splice
(list) (mapcar #'unquote-splice list
))
33 (declaim (inline comma-constructor comma-splicing-p
))
34 (defun comma-constructor (x)
35 (svref #(unquote unquote-nsplice unquote-splice
) (comma-kind x
)))
36 (defun comma-splicing-p (comma) (not (zerop (comma-kind comma
))))
37 (!set-load-form-method comma
(:host
:xc
:target
))
39 (declaim (type (and fixnum unsigned-byte
) *backquote-depth
*))
40 (defvar *backquote-depth
* 0 #!+sb-doc
"how deep we are into backquotes")
41 (defvar *bq-error
* "Comma not inside a backquote.")
43 (/show0
"backq.lisp 50")
45 ;;; the actual character macro
46 (defun backquote-charmacro (stream char
)
47 (declare (ignore char
))
48 (let* ((expr (let ((*backquote-depth
* (1+ *backquote-depth
*)))
49 (read stream t nil t
)))
50 (result (list 'quasiquote expr
)))
51 (if (and (comma-p expr
) (comma-splicing-p expr
))
52 ;; use RESULT rather than EXPR in the error so it pprints nicely
54 stream
"~S is not a well-formed backquote expression" result
)
57 (/show0
"backq.lisp 64")
59 (defun comma-charmacro (stream char
)
60 (declare (ignore char
))
61 (declare (notinline read-char unread-char
))
62 (unless (> *backquote-depth
* 0)
64 (return-from comma-charmacro nil
))
65 (simple-reader-error stream
*bq-error
*))
66 (let ((flag (let ((c (read-char stream
)))
70 (t (unread-char c stream
) 0))))
71 (x (peek-char t stream t nil t
)))
72 (when (and (char= x
#\
)) (eq (get-macro-character x
) 'read-right-paren
))
73 ;; Easier to figure out than an "unmatched parenthesis".
74 (simple-reader-error stream
"Trailing ~A in backquoted expression."
75 (svref #("comma" "comma-dot" "comma-at") flag
)))
76 (unquote (let ((*backquote-depth
* (1- *backquote-depth
*)))
77 (read stream t nil t
)) flag
)))
79 (/show0
"backq.lisp 83")
81 ;; KLUDGE: 'sfunction' is not a defined type yet.
82 (declaim (ftype (function (t fixnum boolean
) (values t t
&optional
))
83 qq-template-to-sexpr qq-template-1
))
85 ;; A QQ-SUBFORM is a cons whose car is an arbitrary S-expression, and
86 ;; cdr one of {EVAL,QUOTE,NCONC,|Append|} signifying how to treat the car.
87 ;; QUOTE and EVAL mean that a single element should be inserted,
88 ;; literally or after being evaluated; NCONC/Append evaluate and splice.
89 (declaim (inline qq-subform-splicing-p
))
90 (defun qq-subform-splicing-p (subform)
95 (defun expand-quasiquote (thing compiler-p
)
96 ;; QQ-TEMPLATE-TO-SEXPR returns the parts of a QQ-SUBFORM as 2 values.
97 (multiple-value-bind (expr operator
)
98 (qq-template-to-sexpr thing
0 compiler-p
)
99 (ecase operator
; Splicing is illegal at toplevel
101 (quote (list 'quote expr
)))))
103 ;; The compiler macro for QUASIQUOTE assumes that it's fine to use
104 ;; the foldable list constructors.
105 (define-compiler-macro quasiquote
(thing)
106 (expand-quasiquote thing t
))
108 ;; The ordinary macro uses CL-standard list constructors for a few reasons:
109 ;; - It makes COMPILE do slightly less work than COMPILE-FILE
110 ;; - If expanded forms are leaked to the user, it looks nicer.
111 ;; Pending discussion of how to or whether to prettify the value
112 ;; of (MACROEXPAND-1 '`(FOO ,X)) this could be irrelevant.
113 (defmacro quasiquote
(thing)
114 (expand-quasiquote thing nil
))
116 ;; Convert a quasi-quote template to a Lisp form that when evaluated constructs
117 ;; the template, substituting into the outermost commas. Return two values:
118 ;; the S-expression, and an indicator of how to incorporate it into its parent.
119 (defun qq-template-to-sexpr (expr depth compiler-p
)
120 (cond ((not expr
) (values nil
'quote
))
122 (qq-template-1 expr
(+ (if (eq (car expr
) 'quasiquote
) 1 0) depth
)
124 ((simple-vector-p expr
) (qq-template-1 expr depth compiler-p
))
125 ((not (comma-p expr
)) (values expr
'quote
))
127 (values (comma-expr expr
)
128 (svref #(eval nconc |Append|
) (comma-kind expr
))))
130 ;; A comma is "pure data" if deeper than the current backquote depth.
131 ;; If its expression interpolates 1 item, reconstruct it using its
132 ;; ordinary constructor, otherwise its multi-constructor.
133 (multiple-value-bind (subexpr operator
)
134 (qq-template-to-sexpr (comma-expr expr
) (1- depth
) compiler-p
)
135 (when (eq operator
'quote
)
136 (setq subexpr
(list 'quote subexpr
) operator
'eval
))
137 (values (list (cond ((eq operator
'eval
) (comma-constructor expr
))
138 ((comma-splicing-p expr
) 'unquote
*-splice
)
143 (/show0
"backq.lisp 139")
145 ;; Find the longest suffix comprised wholly of self-evaluating and/or quoted
146 ;; SUBFORMS. DOTTED-P indicates that the last item represents what was in the
147 ;; CDR of the last cons of the original list. Return the modified SUBFORMS
148 ;; as a proper list, and new DOTTED-P flag. i.e. Conceptually:
149 ;; `(a ,[@]b c d) -> `(a ,[@]b . (c d))
150 ;; `(a ,[@]b c . d) -> `(a ,[@]b . (c . d))
151 (defun qq-fold-suffix (subforms dotted-p vectorp
)
152 (labels ((const-tailp (list)
154 (let* ((rest (cdr list
))
155 (const-part (const-tailp rest
)))
156 (if (and (eq const-part rest
) (eq (cdar list
) 'quote
))
159 (let ((const-tail (and (cdr subforms
) (const-tailp subforms
))))
161 (let* ((constants (mapcar #'car const-tail
))
162 (new-tail (if dotted-p
(apply 'list
* constants
) constants
)))
163 (setq subforms
(nconc (ldiff subforms const-tail
)
164 (list (cons new-tail
'quote
)))
166 ;; If the only splicing operator is in the last element of a proper list,
167 ;; get rid of the splice and make it an improper list.
168 (labels ((convertible-p (list)
170 (and (not (qq-subform-splicing-p (car list
)))
171 (convertible-p (cdr list
)))
172 (qq-subform-splicing-p (car list
)))))
173 (when (and (not dotted-p
) (not vectorp
) (convertible-p subforms
))
174 (let ((tail (car (last subforms
))))
175 (setq subforms
(nconc (nbutlast subforms
) (list (list (car tail
))))
177 (values subforms dotted-p
))
179 ;; Map TEMPLATE-TO-SEXPR over INPUT, a list or simple-vector, producing a list
180 ;; as if by MAP. The cdr of the last cons of the input (if a list) may be a
181 ;; non-nil atom. Return a secondary value indicating whether it was or not.
182 ;; The output list never "dots" its last cons, regardless of the input.
183 (defun qq-map-template-to-list (input depth compiler-p
)
184 (let ((original input
) list dotted-p
)
186 (multiple-value-call #'cons
187 (qq-template-to-sexpr x depth compiler-p
))))
191 (push (to-sexpr (pop input
)) list
)
192 ;; Ensure that QQ-TEMPLATE-TO-SEXPR sees each occurrence of
193 ;; (QUASIQUOTE <form>) as a proper list so that it can
194 ;; bump the depth counter. The oddball case `(a . `(b))
195 ;; would otherwise be seen as not nested `(a quasiquote (b)).
196 (cond ((null input
) (return))
197 ((comma-p input
) ; (... . ,<expr>)
198 (when (comma-splicing-p input
) ; uncaught by reader
199 ;; Actually I don't even know how to get this error
200 (error "~S is not a well-formed backquote expression"
202 ;; (A B . ,X) becomes (A B ,@X). It matters only if there
203 ;; are commas in X like (... . ,,@C). Otherwise no effect.
204 (push (to-sexpr (unquote-splice (comma-expr input
))) list
)
206 ((or (not (listp input
)) (eq (car input
) 'quasiquote
))
207 (push (to-sexpr input
) list
)
210 (setq list
(nreverse list
)))
212 (setq list
(map 'list
#'to-sexpr input
)))))
213 ;; For lists, find the longest suffix comprised wholly of literals.
214 ;; For vectors without splicing we don't do that because (VECTOR 'A B 'C 'D)
215 ;; is better than (COERCE (LIST* 'A B '(C D)) 'VECTOR) by avoiding a step.
216 ;; But if splicing is required then we're going to construct the interim
217 ;; list no matter what. It could theoretically be avoided by doing:
218 ;; (MULTIPLE-VALUE-CALL #'VECTOR ... (VALUES-LIST <splice>) ...)
219 (if (or (listp original
)
220 ;; The target compiler open-codes SOME but the cross-compiler
221 ;; seems not to without (THE LIST) to help it out.
222 (some #'qq-subform-splicing-p
(the list list
)))
223 (qq-fold-suffix list dotted-p
(vectorp input
))
224 (values list dotted-p
))))
226 ;; Return an expression to quasi-quote INPUT, which is either a list
227 ;; or simple-vector, by recursing over its subexpressions.
228 ;; The expansion is in terms of CL-standard functions for MACROEXPAND,
229 ;; but SBCL-private functions for the compiler-macro.
230 ;; This is mainly for aesthetics. If users expressly macroexpand a sexpr
231 ;; and then compile it, they miss out on the opportunity for the minor
232 ;; advantage provided by the foldable functions, but why would they do that?
233 (defun qq-template-1 (input depth compiler-p
)
234 (multiple-value-bind (subforms dot-p
)
235 (qq-map-template-to-list input depth compiler-p
)
236 (labels ((const-p (subform) ; is SUBFORM constant?
237 ;; This needs to notice only the QQ-SUBFORM kind of QUOTE,
238 ;; but it helps to get EVAL forms whose expression is (QUOTE x).
239 ;; Otherwise, work is deferred to IR1 in processing `(A ,'B C).
240 (or (eq (cdr subform
) 'quote
) ; either the kind is QUOTE
241 (let ((exp (car subform
)))
242 (if (atom exp
) ; or it's a self-evaluating atom
244 ;; or (QUOTE <thing>)
245 (and (eq (car exp
) 'quote
) (singleton-p (cdr exp
)))))))
246 (atom-const-p (atom) ; is known to be an atom
247 (typep atom
'(or (not symbol
) (member t nil
) keyword
)))
248 (const-val (subform) ; given that it is known CONST-P
249 (let ((exp (car subform
)))
250 (if (or (eq (cdr subform
) 'quote
) (atom exp
))
252 (second exp
)))) ; (QUOTE x) in a for-evaluation position
253 (render (subform) ; Return a sexpr that evaluates to SUBFORM
254 ;; For subform kind = QUOTE, wrap it in a QUOTE unless
255 ;; the quoted object is self-evaluating, then elide the QUOTE.
256 (let ((exp (car subform
)))
257 (if (and (eq (cdr subform
) 'quote
)
258 (not (and (atom exp
) (atom-const-p exp
))))
261 (normalize-fn (fn-name)
262 (if (or compiler-p
(eq fn-name
'nconc
))
268 (|Vector|
'vector
))))
269 (recurse (list &aux
(elt (car list
)) (rest (cdr list
)))
271 (cond ((or dot-p
(qq-subform-splicing-p elt
))
272 (let ((tail (render elt
)))
274 ;; When splicing pieces into a vector,
275 ;; force the tail to be a list.
276 (list (normalize-fn '|Append|
) tail nil
)
278 ((const-p elt
) (list 'quote
(list (const-val elt
))))
279 (t (list (normalize-fn '|List|
)
280 (render elt
)))) ; singleton list
281 (let ((fn (normalize-fn
282 (or (qq-subform-splicing-p elt
) '|List
*|
)))
284 (tail (recurse rest
)))
285 (if (and (listp tail
) (eq (car tail
) fn
))
286 (list* fn head
(cdr tail
)) ; (F a (F b c)) -> (F a b c)
287 (list fn head tail
))))))
288 (let ((vect-p (vectorp input
)))
289 ;; If at least one splicing comma, use the recursive algorithm.
290 (if (some #'qq-subform-splicing-p
(the list subforms
))
291 (let ((x (recurse subforms
)))
292 (values (if vect-p
(list 'coerce x
''simple-vector
) x
) 'eval
))
293 (let ((fn (cond (vect-p '|Vector|
) (dot-p '|List
*|
) (t '|List|
))))
294 (if (every #'const-p subforms
)
295 (values (apply fn
(mapcar #'const-val subforms
)) 'quote
)
296 (values (cons (normalize-fn fn
)
297 (mapcar #'render subforms
)) 'eval
))))))))
299 ;;; COMPILE-FILE may treat anything as constant that is part of quoted
300 ;;; structure, including quasi-quoted structure (lp#1026439).
301 ;;; As such, we use foldable versions of the standard sequence constructors
302 ;;; which are otherwise identical to their ordinary counterparts.
303 ;;; Pretty-printing doesn't care about these names, only recognizing QUASIQUOTE.
304 ;;; Generated code looks nicer to me without prepending BACKQ-.
305 ;;; Also note there is no alter-ego of CONS or NCONC.
306 (setf (symbol-function '|Append|
) #'append
307 (symbol-function '|List|
) #'list
308 (symbol-function '|List
*|
) #'list
*
309 (symbol-function '|Vector|
) #'vector
)
313 ;;; Install BACKQ stuff in the current *READTABLE*.
315 ;;; In the target Lisp, we have to wait to do this until the readtable
316 ;;; has been created. In the cross-compilation host Lisp, we can do
317 ;;; this right away. (You may ask: In the cross-compilation host,
318 ;;; which already has its own implementation of the backquote
319 ;;; readmacro, why do we do this at all? Because the cross-compilation
320 ;;; host might -- as SBCL itself does -- express the backquote
321 ;;; expansion in terms of internal, nonportable functions. By
322 ;;; redefining backquote in terms of functions which are guaranteed to
323 ;;; exist on the target Lisp, we ensure that backquote expansions in
324 ;;; code-generating code work properly.)
326 (defun !backq-cold-init
()
327 (set-macro-character #\
` 'backquote-charmacro
)
328 (set-macro-character #\
, 'comma-charmacro
))
329 #-sb-xc
(!backq-cold-init
)
331 ;;; Since our backquote is installed on the host lisp, and since
332 ;;; developers make mistakes with backquotes and commas too, let's
333 ;;; ensure that we can report errors rather than get an undefined
334 ;;; function condition on SIMPLE-READER-ERROR.
335 #+sb-xc-host
; proper definition happens for the target
336 (defun simple-reader-error (stream format-string
&rest format-args
)
337 (error "READER-ERROR on stream ~S: ~?" stream format-string format-args
))
339 (/show0
"done with backq.lisp")