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