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