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 ;;; The flags passed back by BACKQUOTIFY can be interpreted as follows:
19 ;;; NIL: [a] => a ;the NIL flag is used only when a is NIL
20 ;;; T: [a] => a ;the T flag is used when a is self-evaluating
21 ;;; QUOTE: [a] => (QUOTE a)
22 ;;; APPEND: [a] => (APPEND . a)
23 ;;; NCONC: [a] => (NCONC . a)
24 ;;; LIST: [a] => (LIST . a)
25 ;;; LIST*: [a] => (LIST* . a)
27 ;;; The flags are combined according to the following set of rules:
28 ;;; ([a] means that a should be converted according to the previous table)
30 ;;; \ car || otherwise | QUOTE or | |`,@| | |`,.|
31 ;;;cdr \ || | T or NIL | |
32 ;;;================================================================================
33 ;;; |`,| || LIST* ([a] [d]) | LIST* ([a] [d]) | APPEND (a [d]) | NCONC (a [d])
34 ;;; NIL || LIST ([a]) | QUOTE (a) | <hair> a | <hair> a
35 ;;;QUOTE or T|| LIST* ([a] [d]) | QUOTE (a . d) | APPEND (a [d]) | NCONC (a [d])
36 ;;; APPEND || LIST* ([a] [d]) | LIST* ([a] [d]) | APPEND (a . d) | NCONC (a [d])
37 ;;; NCONC || LIST* ([a] [d]) | LIST* ([a] [d]) | APPEND (a [d]) | NCONC (a . d)
38 ;;; LIST || LIST ([a] . d) | LIST ([a] . d) | APPEND (a [d]) | NCONC (a [d])
39 ;;; LIST* || LIST* ([a] . d) | LIST* ([a] . d) | APPEND (a [d]) | NCONC (a [d])
41 ;;;<hair> involves starting over again pretending you had read ".,a)" instead
44 (defvar *backquote-count
* 0 #!+sb-doc
"how deep we are into backquotes")
45 (defvar *bq-comma-flag
* '(|
,|
))
46 (defvar *bq-at-flag
* '(|
,@|
))
47 (defvar *bq-dot-flag
* '(|
,.|
))
48 (defvar *bq-vector-flag
* '(|bqv|
))
49 (defvar *bq-error
* "Comma not inside a backquote.")
51 (/show0
"backq.lisp 50")
53 ;;; the actual character macro
54 (defun backquote-macro (stream ignore
)
55 (declare (ignore ignore
))
56 (let ((*backquote-count
* (1+ *backquote-count
*)))
57 (multiple-value-bind (flag thing
)
58 (backquotify stream
(read stream t nil t
))
59 (when (eq flag
*bq-at-flag
*)
60 (simple-reader-error stream
",@ after backquote in ~S" thing
))
61 (when (eq flag
*bq-dot-flag
*)
62 (simple-reader-error stream
",. after backquote in ~S" thing
))
63 (backquotify-1 flag thing
))))
65 (/show0
"backq.lisp 64")
67 (defun comma-macro (stream ignore
)
68 (declare (ignore ignore
))
69 (unless (> *backquote-count
* 0)
71 (return-from comma-macro nil
))
72 (simple-reader-error stream
*bq-error
*))
73 (let ((c (read-char stream
))
74 (*backquote-count
* (1- *backquote-count
*)))
76 (cons *bq-at-flag
* (read stream t nil t
)))
78 (cons *bq-dot-flag
* (read stream t nil t
)))
79 (t (unread-char c stream
)
80 (cons *bq-comma-flag
* (read stream t nil t
))))))
82 (/show0
"backq.lisp 83")
85 (defun expandable-backq-expression-p (object)
87 (let ((flag (car object
)))
88 (or (eq flag
*bq-at-flag
*)
89 (eq flag
*bq-dot-flag
*)))))
91 ;;; This does the expansion from table 2.
92 (defun backquotify (stream code
)
94 (cond ((null code
) (values nil nil
))
97 ;; Keywords are self-evaluating. Install after packages.
100 ((or (eq (car code
) *bq-at-flag
*)
101 (eq (car code
) *bq-dot-flag
*))
102 (values (car code
) (cdr code
)))
103 ((eq (car code
) *bq-comma-flag
*)
105 ((eq (car code
) *bq-vector-flag
*)
106 (multiple-value-bind (dflag d
) (backquotify stream
(cdr code
))
107 (values 'vector
(backquotify-1 dflag d
))))
108 (t (multiple-value-bind (aflag a
) (backquotify stream
(car code
))
109 (multiple-value-bind (dflag d
) (backquotify stream
(cdr code
))
110 (when (eq dflag
*bq-at-flag
*)
111 ;; Get the errors later.
112 (simple-reader-error stream
",@ after dot in ~S" code
))
113 (when (eq dflag
*bq-dot-flag
*)
114 (simple-reader-error stream
",. after dot in ~S" code
))
116 ((eq aflag
*bq-at-flag
*)
118 (if (expandable-backq-expression-p a
)
119 (values 'append
(list a
))
122 (cond ((eq dflag
'append
)
124 (t (list a
(backquotify-1 dflag d
)))))))
125 ((eq aflag
*bq-dot-flag
*)
127 (if (expandable-backq-expression-p a
)
128 (values 'nconc
(list a
))
131 (cond ((eq dflag
'nconc
)
133 (t (list a
(backquotify-1 dflag d
)))))))
135 (if (member aflag
'(quote t nil
))
136 (values 'quote
(list a
))
137 (values 'list
(list (backquotify-1 aflag a
)))))
138 ((member dflag
'(quote t
))
139 (if (member aflag
'(quote t nil
))
140 (values 'quote
(cons a d
))
141 (values 'list
* (list (backquotify-1 aflag a
)
142 (backquotify-1 dflag d
)))))
143 (t (setq a
(backquotify-1 aflag a
))
144 (if (member dflag
'(list list
*))
145 (values dflag
(cons a d
))
147 (list a
(backquotify-1 dflag d
)))))))))))
149 (/show0
"backq.lisp 139")
151 ;;; This handles the <hair> cases.
156 ((or (numberp code
) (eq code t
))
158 (t (values *bq-comma-flag
* code
))))
159 ((and (eq (car code
) 'quote
)
160 (not (expandable-backq-expression-p (cadr code
))))
161 (values (car code
) (cadr code
)))
162 ((member (car code
) '(append list list
* nconc
))
163 (values (car code
) (cdr code
)))
164 ((eq (car code
) 'cons
)
165 (values 'list
* (cdr code
)))
166 (t (values *bq-comma-flag
* code
))))
168 (/show0
"backq.lisp 157")
170 ;;; This handles table 1.
171 (defun backquotify-1 (flag thing
)
172 (cond ((or (eq flag
*bq-comma-flag
*)
173 (member flag
'(t nil
)))
178 (cond ((and (null (cddr thing
))
179 (not (expandable-backq-expression-p (car thing
)))
180 (not (expandable-backq-expression-p (cadr thing
))))
181 (cons 'backq-cons thing
))
182 ((expandable-backq-expression-p (car (last thing
)))
184 (cons 'backq-list
(butlast thing
))
185 ;; Can it be optimized further? -- APD, 2001-12-21
188 (cons 'backq-list
* thing
))))
190 (list 'backq-vector thing
))
193 ((append) 'backq-append
)
194 ((nconc) 'backq-nconc
))
197 ;;;; magic BACKQ- versions of builtin functions
199 (/show0
"backq.lisp 184")
201 ;;; Define synonyms for the lisp functions we use, so that by using
202 ;;; them, the backquoted material will be recognizable to the
204 (macrolet ((def (b-name name
)
205 ;; FIXME: This function should be INLINE so that the lists
206 ;; aren't consed twice, but I ran into an optimizer bug the
207 ;; first time I tried to make this work for BACKQ-LIST. See
208 ;; whether there's still an optimizer bug, and fix it if so, and
209 ;; then make these INLINE.
210 `(defun ,b-name
(&rest rest
)
211 (declare (truly-dynamic-extent rest
))
212 (apply #',name rest
))))
213 (def backq-list list
)
214 (def backq-list
* list
*)
215 (def backq-append append
)
216 (def backq-nconc nconc
)
217 (def backq-cons cons
))
219 (/show0
"backq.lisp 204")
221 (defun backq-vector (list)
222 (declare (list list
))
223 (coerce list
'simple-vector
))
227 (/show0
"backq.lisp 212")
229 ;;; Install BACKQ stuff in the current *READTABLE*.
231 ;;; In the target Lisp, we have to wait to do this until the readtable
232 ;;; has been created. In the cross-compilation host Lisp, we can do
233 ;;; this right away. (You may ask: In the cross-compilation host,
234 ;;; which already has its own implementation of the backquote
235 ;;; readmacro, why do we do this at all? Because the cross-compilation
236 ;;; host might -- as SBCL itself does -- express the backquote
237 ;;; expansion in terms of internal, nonportable functions. By
238 ;;; redefining backquote in terms of functions which are guaranteed to
239 ;;; exist on the target Lisp, we ensure that backquote expansions in
240 ;;; code-generating code work properly.)
241 (defun !backq-cold-init
()
242 (set-macro-character #\
` #'backquote-macro
)
243 (set-macro-character #\
, #'comma-macro
))
244 #+sb-xc-host
(!backq-cold-init
)
246 ;;; The pretty-printer needs to know about our special tokens
247 (defvar *backq-tokens
*
248 '(backq-comma backq-comma-at backq-comma-dot backq-list
249 backq-list
* backq-append backq-nconc backq-cons backq-vector
))
251 ;;; Since our backquote is installed on the host lisp, and since
252 ;;; developers make mistakes with backquotes and commas too, let's
253 ;;; ensure that we can report errors rather than get an undefined
254 ;;; function condition on SIMPLE-READER-ERROR.
255 #+sb-xc-host
; proper definition happens for the target
256 (defun simple-reader-error (stream format-string
&rest format-args
)
257 (bug "READER-ERROR on stream ~S: ~?" stream format-string format-args
))
259 (/show0
"done with backq.lisp")