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")
17 ;;; The flags passed back by BACKQUOTIFY can be interpreted as follows:
20 ;;; NIL: [a] => a ;the NIL flag is used only when a is NIL
21 ;;; T: [a] => a ;the T flag is used when a is self-evaluating
22 ;;; QUOTE: [a] => (QUOTE a)
23 ;;; APPEND: [a] => (APPEND . a)
24 ;;; NCONC: [a] => (NCONC . a)
25 ;;; LIST: [a] => (LIST . a)
26 ;;; LIST*: [a] => (LIST* . a)
28 ;;; The flags are combined according to the following set of rules:
29 ;;; ([a] means that a should be converted according to the previous table)
31 ;;; \ car || otherwise | QUOTE or | |`,@| | |`,.|
32 ;;;cdr \ || | T or NIL | |
33 ;;;================================================================================
34 ;;; |`,| || LIST* ([a] [d]) | LIST* ([a] [d]) | APPEND (a [d]) | NCONC (a [d])
35 ;;; NIL || LIST ([a]) | QUOTE (a) | <hair> a | <hair> a
36 ;;;QUOTE or T|| LIST* ([a] [d]) | QUOTE (a . d) | APPEND (a [d]) | NCONC (a [d])
37 ;;; APPEND || LIST* ([a] [d]) | LIST* ([a] [d]) | APPEND (a . d) | NCONC (a [d])
38 ;;; NCONC || 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])
40 ;;; LIST* || LIST* ([a] . d) | LIST* ([a] . d) | APPEND (a [d]) | NCONC (a [d])
42 ;;;<hair> involves starting over again pretending you had read ".,a)" instead
45 (defvar *backquote-count* 0 #!+sb-doc "how deep we are into backquotes")
46 (defvar *bq-comma-flag* '(|,|))
47 (defvar *bq-at-flag* '(|,@|))
48 (defvar *bq-dot-flag* '(|,.|))
49 (defvar *bq-vector-flag* '(|bqv|))
51 ;;; the actual character macro
52 (defun backquote-macro (stream ignore)
53 (declare (ignore ignore))
54 (let ((*backquote-count* (1+ *backquote-count*)))
55 (multiple-value-bind (flag thing)
56 (backquotify stream (read stream t nil t))
57 (if (eq flag *bq-at-flag*)
58 (%reader-error stream ",@ after backquote in ~S" thing))
59 (if (eq flag *bq-dot-flag*)
60 (%reader-error stream ",. after backquote in ~S" thing))
61 (values (backquotify-1 flag thing) 'list))))
63 (defun comma-macro (stream ignore)
64 (declare (ignore ignore))
65 (unless (> *backquote-count* 0)
67 (return-from comma-macro nil))
68 (%reader-error stream "comma not inside a backquote"))
69 (let ((c (read-char stream))
70 (*backquote-count* (1- *backquote-count*)))
73 (cons *bq-at-flag* (read stream t nil t)))
75 (cons *bq-dot-flag* (read stream t nil t)))
76 (t (unread-char c stream)
77 (cons *bq-comma-flag* (read stream t nil t))))
80 ;;; This does the expansion from table 2.
81 (defun backquotify (stream code)
83 (cond ((null code) (values nil nil))
86 ;; Keywords are self-evaluating. Install after packages.
88 (t (values 'quote code))))
89 ((or (eq (car code) *bq-at-flag*)
90 (eq (car code) *bq-dot-flag*))
91 (values (car code) (cdr code)))
92 ((eq (car code) *bq-comma-flag*)
94 ((eq (car code) *bq-vector-flag*)
95 (multiple-value-bind (dflag d) (backquotify stream (cdr code))
96 (values 'vector (backquotify-1 dflag d))))
97 (t (multiple-value-bind (aflag a) (backquotify stream (car code))
98 (multiple-value-bind (dflag d) (backquotify stream (cdr code))
99 (if (eq dflag *bq-at-flag*)
100 ;; Get the errors later.
101 (%reader-error stream ",@ after dot in ~S" code))
102 (if (eq dflag *bq-dot-flag*)
103 (%reader-error stream ",. after dot in ~S" code))
105 ((eq aflag *bq-at-flag*)
109 (cond ((eq dflag 'append)
111 (t (list a (backquotify-1 dflag d)))))))
112 ((eq aflag *bq-dot-flag*)
116 (cond ((eq dflag 'nconc)
118 (t (list a (backquotify-1 dflag d)))))))
120 (if (member aflag '(quote t nil))
121 (values 'quote (list a))
122 (values 'list (list (backquotify-1 aflag a)))))
123 ((member dflag '(quote t))
124 (if (member aflag '(quote t nil))
125 (values 'quote (cons a d ))
126 (values 'list* (list (backquotify-1 aflag a)
127 (backquotify-1 dflag d)))))
128 (t (setq a (backquotify-1 aflag a))
129 (if (member dflag '(list list*))
130 (values dflag (cons a d))
132 (list a (backquotify-1 dflag d)))))))))))
134 ;;; This handles the <hair> cases.
139 ((or (numberp code) (eq code 't))
141 (t (values *bq-comma-flag* code))))
142 ((eq (car code) 'quote)
143 (values (car code) (cadr code)))
144 ((member (car code) '(append list list* nconc))
145 (values (car code) (cdr code)))
146 ((eq (car code) 'cons)
147 (values 'list* (cdr code)))
148 (t (values *bq-comma-flag* code))))
150 ;;; This handles table 1.
151 (defun backquotify-1 (flag thing)
152 (cond ((or (eq flag *bq-comma-flag*)
153 (member flag '(t nil)))
158 (cond ((null (cddr thing))
159 (cons 'backq-cons thing))
161 (cons 'backq-list* thing))))
163 (list 'backq-vector thing))
166 '((cons . backq-cons)
168 (append . backq-append)
169 (nconc . backq-nconc))
173 ;;;; magic BACKQ- versions of builtin functions
175 ;;; Define synonyms for the lisp functions we use, so that by using them, we
176 ;;; backquoted material will be recognizable to the pretty-printer.
177 (macrolet ((def-frob (b-name name)
178 (let ((args (gensym "ARGS")))
179 ;; FIXME: This function should be INLINE so that the lists
180 ;; aren't consed twice, but I ran into an optimizer bug the
181 ;; first time I tried to make this work for BACKQ-LIST. See
182 ;; whether there's still an optimizer bug, and fix it if so, and
183 ;; then make these INLINE.
184 `(defun ,b-name (&rest ,args)
185 (apply #',name ,args)))))
186 (def-frob backq-list list)
187 (def-frob backq-list* list*)
188 (def-frob backq-append append)
189 (def-frob backq-nconc nconc)
190 (def-frob backq-cons cons))
192 (defun backq-vector (list)
193 (declare (list list))
194 (coerce list 'simple-vector))
198 ;;; Install BACKQ stuff in the current *READTABLE*.
200 ;;; In the target Lisp, we have to wait to do this until the readtable has been
201 ;;; created. In the cross-compilation host Lisp, we can do this right away.
202 ;;; (You may ask: In the cross-compilation host, which already has its own
203 ;;; implementation of the backquote readmacro, why do we do this at all?
204 ;;; Because the cross-compilation host might -- as SBCL itself does -- express
205 ;;; the backquote expansion in terms of internal, nonportable functions. By
206 ;;; redefining backquote in terms of functions which are guaranteed to exist on
207 ;;; the target Lisp, we ensure that backquote expansions in code-generating
208 ;;; code work properly.)
209 (defun !backq-cold-init ()
210 (set-macro-character #\` #'backquote-macro)
211 (set-macro-character #\, #'comma-macro))
212 #+sb-xc-host (!backq-cold-init)