Line data Source code
1 : ;;; backquote.el --- implement the ` Lisp construct
2 :
3 : ;; Copyright (C) 1990, 1992, 1994, 2001-2017 Free Software Foundation,
4 : ;; Inc.
5 :
6 : ;; Author: Rick Sladkey <jrs@world.std.com>
7 : ;; Maintainer: emacs-devel@gnu.org
8 : ;; Keywords: extensions, internal
9 : ;; Package: emacs
10 :
11 : ;; This file is part of GNU Emacs.
12 :
13 : ;; GNU Emacs is free software: you can redistribute it and/or modify
14 : ;; it under the terms of the GNU General Public License as published by
15 : ;; the Free Software Foundation, either version 3 of the License, or
16 : ;; (at your option) any later version.
17 :
18 : ;; GNU Emacs is distributed in the hope that it will be useful,
19 : ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20 : ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21 : ;; GNU General Public License for more details.
22 :
23 : ;; You should have received a copy of the GNU General Public License
24 : ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
25 :
26 : ;;; Commentary:
27 :
28 : ;; When the Lisp reader sees `(...), it generates (\` (...)).
29 : ;; When it sees ,... inside such a backquote form, it generates (\, ...).
30 : ;; For ,@... it generates (\,@ ...).
31 :
32 : ;; This backquote will generate calls to the backquote-list* form.
33 : ;; Both a function version and a macro version are included.
34 : ;; The macro version is used by default because it is faster
35 : ;; and needs no run-time support. It should really be a subr.
36 :
37 : ;;; Code:
38 :
39 : (provide 'backquote)
40 :
41 : ;; function and macro versions of backquote-list*
42 :
43 : (defun backquote-list*-function (first &rest list)
44 : "Like `list' but the last argument is the tail of the new list.
45 :
46 : For example (backquote-list* \\='a \\='b \\='c) => (a b . c)"
47 : ;; The recursive solution is much nicer:
48 : ;; (if list (cons first (apply 'backquote-list*-function list)) first))
49 : ;; but Emacs is not very good at efficiently processing recursion.
50 0 : (if list
51 0 : (let* ((rest list) (newlist (cons first nil)) (last newlist))
52 0 : (while (cdr rest)
53 0 : (setcdr last (cons (car rest) nil))
54 0 : (setq last (cdr last)
55 0 : rest (cdr rest)))
56 0 : (setcdr last (car rest))
57 0 : newlist)
58 0 : first))
59 :
60 : (defmacro backquote-list*-macro (first &rest list)
61 : "Like `list' but the last argument is the tail of the new list.
62 :
63 : For example (backquote-list* \\='a \\='b \\='c) => (a b . c)"
64 : ;; The recursive solution is much nicer:
65 : ;; (if list (list 'cons first (cons 'backquote-list*-macro list)) first))
66 : ;; but Emacs is not very good at efficiently processing such things.
67 279 : (setq list (nreverse (cons first list))
68 279 : first (car list)
69 279 : list (cdr list))
70 279 : (if list
71 279 : (let* ((second (car list))
72 279 : (rest (cdr list))
73 279 : (newlist (list 'cons second first)))
74 956 : (while rest
75 677 : (setq newlist (list 'cons (car rest) newlist)
76 677 : rest (cdr rest)))
77 279 : newlist)
78 279 : first))
79 :
80 : (defalias 'backquote-list* (symbol-function 'backquote-list*-macro))
81 :
82 : ;; A few advertised variables that control which symbols are used
83 : ;; to represent the backquote, unquote, and splice operations.
84 : (defconst backquote-backquote-symbol '\`
85 : "Symbol used to represent a backquote or nested backquote.")
86 :
87 : (defconst backquote-unquote-symbol '\,
88 : "Symbol used to represent an unquote inside a backquote.")
89 :
90 : (defconst backquote-splice-symbol '\,@
91 : "Symbol used to represent a splice inside a backquote.")
92 :
93 : (defmacro backquote (structure)
94 : "Argument STRUCTURE describes a template to build.
95 :
96 : The whole structure acts as if it were quoted except for certain
97 : places where expressions are evaluated and inserted or spliced in.
98 :
99 : For example:
100 :
101 : b => (ba bb bc) ; assume b has this value
102 : \\=`(a b c) => (a b c) ; backquote acts like quote
103 : \\=`(a ,b c) => (a (ba bb bc) c) ; insert the value of b
104 : \\=`(a ,@b c) => (a ba bb bc c) ; splice in the value of b
105 :
106 : Vectors work just like lists. Nested backquotes are permitted."
107 3235 : (cdr (backquote-process structure)))
108 :
109 : ;; GNU Emacs has no reader macros
110 :
111 : (defalias '\` (symbol-function 'backquote))
112 :
113 : ;; backquote-process returns a dotted-pair of a tag (0, 1, or 2) and
114 : ;; the backquote-processed structure. 0 => the structure is
115 : ;; constant, 1 => to be unquoted, 2 => to be spliced in.
116 : ;; The top-level backquote macro just discards the tag.
117 :
118 : (defun backquote-delay-process (s level)
119 : "Process a (un|back|splice)quote inside a backquote.
120 : This simply recurses through the body."
121 2 : (let ((exp (backquote-listify (list (cons 0 (list 'quote (car s))))
122 2 : (backquote-process (cdr s) level))))
123 2 : (cons (if (eq (car-safe exp) 'quote) 0 1) exp)))
124 :
125 : (defun backquote-process (s &optional level)
126 : "Process the body of a backquote.
127 : S is the body. Returns a cons cell whose cdr is piece of code which
128 : is the macro-expansion of S, and whose car is a small integer whose value
129 : can either indicate that the code is constant (0), or not (1), or returns
130 : a list which should be spliced into its environment (2).
131 : LEVEL is only used internally and indicates the nesting level:
132 : 0 (the default) is for the toplevel nested inside a single backquote."
133 24665 : (unless level (setq level 0))
134 24665 : (cond
135 24665 : ((vectorp s)
136 28 : (let ((n (backquote-process (append s ()) level)))
137 28 : (if (= (car n) 0)
138 25 : (cons 0 s)
139 3 : (cons 1 (cond
140 3 : ((not (listp (cdr n)))
141 0 : (list 'vconcat (cdr n)))
142 3 : ((eq (nth 1 n) 'list)
143 1 : (cons 'vector (nthcdr 2 n)))
144 2 : ((eq (nth 1 n) 'append)
145 0 : (cons 'vconcat (nthcdr 2 n)))
146 : (t
147 28 : (list 'apply '(function vector) (cdr n))))))))
148 24637 : ((atom s)
149 : ;; FIXME: Use macroexp-quote!
150 11863 : (cons 0 (if (or (null s) (eq s t) (not (symbolp s)))
151 6224 : s
152 11863 : (list 'quote s))))
153 12774 : ((eq (car s) backquote-unquote-symbol)
154 3937 : (if (<= level 0)
155 3936 : (cond
156 3936 : ((> (length s) 2)
157 : ;; We could support it with: (cons 2 `(list . ,(cdr s)))
158 : ;; But let's not encourage such uses.
159 0 : (error "Multiple args to , are not supported: %S" s))
160 3936 : (t (cons (if (eq (car-safe (nth 1 s)) 'quote) 0 1)
161 3936 : (nth 1 s))))
162 3937 : (backquote-delay-process s (1- level))))
163 8837 : ((eq (car s) backquote-splice-symbol)
164 2074 : (if (<= level 0)
165 2074 : (if (> (length s) 2)
166 : ;; (cons 2 `(append . ,(cdr s)))
167 0 : (error "Multiple args to ,@ are not supported: %S" s)
168 2074 : (cons 2 (nth 1 s)))
169 2074 : (backquote-delay-process s (1- level))))
170 6763 : ((eq (car s) backquote-backquote-symbol)
171 1 : (backquote-delay-process s (1+ level)))
172 : (t
173 6762 : (let ((rest s)
174 : item firstlist list lists expression)
175 : ;; Scan this list-level, setting LISTS to a list of forms,
176 : ;; each of which produces a list of elements
177 : ;; that should go in this level.
178 : ;; The order of LISTS is backwards.
179 : ;; If there are non-splicing elements (constant or variable)
180 : ;; at the beginning, put them in FIRSTLIST,
181 : ;; as a list of tagged values (TAG . FORM).
182 : ;; If there are any at the end, they go in LIST, likewise.
183 23445 : (while (and (consp rest)
184 : ;; Stop if the cdr is an expression inside a backquote or
185 : ;; unquote since this needs to go recursively through
186 : ;; backquote-process.
187 16784 : (not (or (eq (car rest) backquote-unquote-symbol)
188 23445 : (eq (car rest) backquote-backquote-symbol))))
189 16683 : (setq item (backquote-process (car rest) level))
190 16683 : (cond
191 16683 : ((= (car item) 2)
192 : ;; Put the nonspliced items before the first spliced item
193 : ;; into FIRSTLIST.
194 2074 : (if (null lists)
195 2061 : (setq firstlist list
196 2074 : list nil))
197 : ;; Otherwise, put any preceding nonspliced items into LISTS.
198 2074 : (if list
199 2074 : (push (backquote-listify list '(0 . nil)) lists))
200 4148 : (push (cdr item) lists)
201 2074 : (setq list nil))
202 : (t
203 16683 : (setq list (cons item list))))
204 16683 : (setq rest (cdr rest)))
205 : ;; Handle nonsplicing final elements, and the tail of the list
206 : ;; (which remains in REST).
207 6762 : (if (or rest list)
208 4717 : (push (backquote-listify list (backquote-process rest level))
209 9434 : lists))
210 : ;; Turn LISTS into a form that produces the combined list.
211 6762 : (setq expression
212 6762 : (if (or (cdr lists)
213 6762 : (eq (car-safe (car lists)) backquote-splice-symbol))
214 21 : (cons 'append (nreverse lists))
215 6762 : (car lists)))
216 : ;; Tack on any initial elements.
217 6762 : (if firstlist
218 6762 : (setq expression (backquote-listify firstlist (cons 1 expression))))
219 24665 : (cons (if (eq (car-safe expression) 'quote) 0 1) expression)))))
220 :
221 : ;; backquote-listify takes (tag . structure) pairs from backquote-process
222 : ;; and decides between append, list, backquote-list*, and cons depending
223 : ;; on which tags are in the list.
224 :
225 : (defun backquote-listify (list old-tail)
226 6777 : (let ((heads nil) (tail (cdr old-tail)) (list-tail list) (item nil))
227 6777 : (if (= (car old-tail) 0)
228 4617 : (setq tail (eval tail)
229 6777 : old-tail nil))
230 21388 : (while (consp list-tail)
231 14611 : (setq item (car list-tail))
232 14611 : (setq list-tail (cdr list-tail))
233 14611 : (if (or heads old-tail (/= (car item) 0))
234 8446 : (setq heads (cons (cdr item) heads))
235 14611 : (setq tail (cons (eval (cdr item)) tail))))
236 6777 : (cond
237 6777 : (tail
238 4634 : (if (null old-tail)
239 4634 : (setq tail (list 'quote tail)))
240 4634 : (if heads
241 2462 : (let ((use-list* (or (cdr heads)
242 2183 : (and (consp (car heads))
243 207 : (eq (car (car heads))
244 2462 : backquote-splice-symbol)))))
245 2462 : (cons (if use-list* 'backquote-list* 'cons)
246 2462 : (append heads (list tail))))
247 4634 : tail))
248 6777 : (t (cons 'list heads)))))
249 :
250 :
251 : ;; Give `,' and `,@' documentation strings which can be examined by C-h f.
252 : (put '\, 'function-documentation
253 : "See `\\=`' (also `pcase') for the usage of `,'.")
254 : (put '\, 'reader-construct t)
255 :
256 : (put '\,@ 'function-documentation
257 : "See `\\=`' for the usage of `,@'.")
258 : (put '\,@ 'reader-construct t)
259 :
260 : ;;; backquote.el ends here
|