Mercurial > hg > xemacs-beta

comparison lisp/prim/backquote.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
1 ;;; backquote.el --- Full backquote support for elisp. Reverse compatible too.
2
3 ;; Keywords: extensions
4
5 ;;; Synched up with: Not synched with FSF.
6
7 ;;; The bulk of the code is originally from CMU Common Lisp (original notice
8 ;;; below).
9 ;;;
10 ;;; It correctly supports nested backquotes and backquoted vectors.
11 ;;;
12 ;;; Converted to work with elisp by Miles Bader <miles@cogsci.ed.ac.uk>
13 ;;;
14 ;;; Changes by Jonathan Stigelman <Stig@hackvan.com>:
15 ;;; - Documentation added
16 ;;; - support for old-backquote-compatibility-hook nixed because the
17 ;;; old-backquote compatibility is now done in the reader...
18 ;;; - nixed support for |,.| because
19 ;;; (a) it's not in CLtl2
20 ;;; (b) ",.foo" is the same as ". ,foo"
21 ;;; (c) because RMS isn't interested in using this version of backquote.el
22 ;;;
23 ;;; wing@666.com; added ,. support back in:
24 ;;; (a) yes, it is in CLtl2. Read closely on page 529.
25 ;;; (b) RMS in 19.30 adds C support for ,. even if it's not really
26 ;;; handled.
27 ;;;
28 ;;; **********************************************************************
29 ;;; This code was written as part of the CMU Common Lisp project at
30 ;;; Carnegie Mellon University, and has been placed in the public domain.
31 ;;; If you want to use this code or any part of CMU Common Lisp, please contact
32 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
33 ;;;
34 ;;; **********************************************************************
35 ;;;
36 ;;; BACKQUOTE: Code Spice Lispified by Lee Schumacher.
37 ;;;
38 ;;; The flags passed back by BQ-PROCESS-2 can be interpreted as follows:
39 ;;;
40 ;;; |`,|: [a] => a
41 ;;; NIL: [a] => a ;the NIL flag is used only when a is NIL
42 ;;; T: [a] => a ;the T flag is used when a is self-evaluating
43 ;;; QUOTE: [a] => (QUOTE a)
44 ;;; APPEND: [a] => (APPEND . a)
45 ;;; NCONC: [a] => (NCONC . a)
46 ;;; LIST: [a] => (LIST . a)
47 ;;; LIST*: [a] => (LIST* . a)
48 ;;;
49 ;;; The flags are combined according to the following set of rules:
50 ;;; ([a] means that a should be converted according to the previous table)
51 ;;;
52 ;;; \ car || otherwise | QUOTE or | |`,@| | |`,.|
53 ;;;cdr \ || | T or NIL | |
54 ;;;============================================================================
55 ;;; |`,| ||LIST* ([a] [d]) |LIST* ([a] [d]) |APPEND (a [d]) |NCONC (a [d])
56 ;;; NIL ||LIST ([a]) |QUOTE (a) |<hair> a |<hair> a
57 ;;;QUOTE or T||LIST* ([a] [d]) |QUOTE (a . d) |APPEND (a [d]) |NCONC (a [d])
58 ;;; APPEND ||LIST* ([a] [d]) |LIST* ([a] [d]) |APPEND (a . d) |NCONC (a [d])
59 ;;; NCONC ||LIST* ([a] [d]) |LIST* ([a] [d]) |APPEND (a [d]) |NCONC (a . d)
60 ;;; LIST ||LIST ([a] . d) |LIST ([a] . d) |APPEND (a [d]) |NCONC (a [d])
61 ;;; LIST* ||LIST* ([a] . d) |LIST* ([a] . d) |APPEND (a [d]) |NCONC (a [d])
62 ;;;
63 ;;;<hair> involves starting over again pretending you had read ".,a)" instead
64 ;;; of ",@a)"
65 ;;;
66
67 ;;;
68 ;;;
69 ;;;
70 ;;;
71 ;;;
72 ;;;
73 ;;;
74 ;;;
75 ;;;
76 ;;;
77
78 ;;; These are the forms it expects: |backquote| |`| |,| |,@| and |,.|.
79 (defconst bq-backquote-marker 'backquote)
80 (defconst bq-backtick-marker '\`) ; remnant of the old lossage
81 (defconst bq-comma-marker '\,)
82 (defconst bq-at-marker '\,@)
83 (defconst bq-dot-marker '\,\.)
84
85 ;;; ----------------------------------------------------------------
86
87 (fset '\` 'backquote)
88
89 (defmacro backquote (template)
90 "Expand the internal representation of a backquoted TEMPLATE into a lisp form.
91
92 The backquote character is like the quote character in that it prevents the
93 template which follows it from being evaluated, except that backquote
94 permits you to evaluate portions of the quoted template. A comma character
95 inside TEMPLATE indicates that the following item should be evaluated. A
96 comma character may be followed by an at-sign, which indicates that the form
97 which follows should be evaluated and inserted and \"spliced\" into the
98 template. Forms following ,@ must evaluate to lists.
99
100 Here is how to use backquotes:
101 (setq p 'b
102 q '(c d e))
103 `(a ,p ,@q) -> (a b c d e)
104 `(a . b) -> (a . b)
105 `(a . ,p) -> (a . b)
106
107 The XEmacs lisp reader expands lisp backquotes as it reads them.
108 Examples:
109 `atom is read as (backquote atom)
110 `(a ,b ,@(c d e)) is read as (backquote (a (\\, b) (\\,\\@ (c d e))))
111 `(a . ,p) is read as (backquote (a \\, p))
112
113 \(backquote TEMPLATE) is a macro that produces code to construct TEMPLATE.
114 Note that this is very slow in interpreted code, but fast if you compile.
115 TEMPLATE is one or more nested lists or vectors, which are `almost quoted'.
116 They are copied recursively, with elements preceded by comma evaluated.
117 (backquote (a b)) == (list 'a 'b)
118 (backquote (a [b c])) == (list 'a (vector 'b 'c))
119
120 However, certain special lists are not copied. They specify substitution.
121 Lists that look like (\\, EXP) are evaluated and the result is substituted.
122 (backquote (a (\\, (+ x 5)))) == (list 'a (+ x 5))
123
124 Elements of the form (\\,\\@ EXP) are evaluated and then all the elements
125 of the result are substituted. This result must be a list; it may
126 be `nil'.
127
128 Elements of the form (\\,\\. EXP) are evaluated and then all the elements
129 of the result are concatenated to the list of preceding elements in the list.
130 They must occur as the last element of a list (not a vector).
131 EXP may evaluate to nil.
132
133 As an example, a simple macro `push' could be written:
134 (defmacro push (v l)
135 `(setq ,l (cons ,@(list v l))))
136 or as
137 (defmacro push (v l)
138 `(setq ,l (cons ,v ,l)))
139
140 For backwards compatibility, old-style emacs-lisp backquotes are still read.
141 OLD STYLE NEW STYLE
142 (` (foo (, bar) (,@ bing))) `(foo ,bar ,@bing)
143
144 Because of the old-style backquote support, you cannot use a new-style
145 backquoted form as the first element of a list. Perhaps some day this
146 restriction will go away, but for now you should be wary of it:
147 (`(this ,will ,@fail))
148 ((` (but (, this) will (,@ work))))
149 This is an extremely rare thing to need to do in lisp."
150 (bq-process template))
151
152 ;;; ----------------------------------------------------------------
153
154 (defconst bq-comma-flag 'unquote)
155 (defconst bq-at-flag 'unquote-splicing)
156 (defconst bq-dot-flag 'unquote-nconc-splicing)
157
158 (defun bq-process (form)
159 (let* ((flag-result (bq-process-2 form))
160 (flag (car flag-result))
161 (result (cdr flag-result)))
162 (cond ((eq flag bq-at-flag)
163 (error ",@ after ` in form: %s" form))
164 ((eq flag bq-dot-flag)
165 (error ",. after ` in form: %s" form))
166 (t
167 (bq-process-1 flag result)))))
168
169 ;;; ----------------------------------------------------------------
170
171 (defun bq-vector-contents (vec)
172 (let ((contents nil)
173 (n (length vec)))
174 (while (> n 0)
175 (setq n (1- n))
176 (setq contents (cons (aref vec n) contents)))
177 contents))
178
179 ;;; This does the expansion from table 2.
180 (defun bq-process-2 (code)
181 (cond ((vectorp code)
182 (let* ((dflag-d
183 (bq-process-2 (bq-vector-contents code))))
184 (cons 'vector (bq-process-1 (car dflag-d) (cdr dflag-d)))))
185 ((atom code)
186 (cond ((null code) (cons nil nil))
187 ((or (numberp code) (eq code t))
188 (cons t code))
189 (t (cons 'quote code))))
190 ((eq (car code) bq-at-marker)
191 (cons bq-at-flag (nth 1 code)))
192 ((eq (car code) bq-dot-marker)
193 (cons bq-dot-flag (nth 1 code)))
194 ((eq (car code) bq-comma-marker)
195 (bq-comma (nth 1 code)))
196 ((or (eq (car code) bq-backquote-marker)
197 (eq (car code) bq-backtick-marker)) ; old lossage
198 (bq-process-2 (bq-process (nth 1 code))))
199 (t (let* ((aflag-a (bq-process-2 (car code)))
200 (aflag (car aflag-a))
201 (a (cdr aflag-a)))
202 (let* ((dflag-d (bq-process-2 (cdr code)))
203 (dflag (car dflag-d))
204 (d (cdr dflag-d)))
205 (if (eq dflag bq-at-flag)
206 ;; get the errors later.
207 (error ",@ after dot in %s" code))
208 (if (eq dflag bq-dot-flag)
209 (error ",. after dot in %s" code))
210 (cond
211 ((eq aflag bq-at-flag)
212 (if (null dflag)
213 (bq-comma a)
214 (cons 'append
215 (cond ((eq dflag 'append)
216 (cons a d ))
217 (t (list a (bq-process-1 dflag d)))))))
218 ((eq aflag bq-dot-flag)
219 (if (null dflag)
220 (bq-comma a)
221 (cons 'nconc
222 (cond ((eq dflag 'nconc)
223 (cons a d))
224 (t (list a (bq-process-1 dflag d)))))))
225 ((null dflag)
226 (if (memq aflag '(quote t nil))
227 (cons 'quote (list a))
228 (cons 'list (list (bq-process-1 aflag a)))))
229 ((memq dflag '(quote t))
230 (if (memq aflag '(quote t nil))
231 (cons 'quote (cons a d ))
232 (cons 'list* (list (bq-process-1 aflag a)
233 (bq-process-1 dflag d)))))
234 (t (setq a (bq-process-1 aflag a))
235 (if (memq dflag '(list list*))
236 (cons dflag (cons a d))
237 (cons 'list*
238 (list a (bq-process-1 dflag d)))))))))))
239
240 ;;; This handles the <hair> cases
241 (defun bq-comma (code)
242 (cond ((atom code)
243 (cond ((null code)
244 (cons nil nil))
245 ((or (numberp code) (eq code 't))
246 (cons t code))
247 (t (cons bq-comma-flag code))))
248 ((eq (car code) 'quote)
249 (cons (car code) (car (cdr code))))
250 ((memq (car code) '(append list list* nconc))
251 (cons (car code) (cdr code)))
252 ((eq (car code) 'cons)
253 (cons 'list* (cdr code)))
254 (t (cons bq-comma-flag code))))
255
256 ;;; This handles table 1.
257 (defun bq-process-1 (flag thing)
258 (cond ((or (eq flag bq-comma-flag)
259 (memq flag '(t nil)))
260 thing)
261 ((eq flag 'quote)
262 (list 'quote thing))
263 ((eq flag 'vector)
264 (list 'apply '(function vector) thing))
265 (t (cons (cdr
266 (assq flag
267 '((cons . cons)
268 (list* . bq-list*)
269 (list . list)
270 (append . append)
271 (nconc . nconc))))
272 thing))))
273
274 ;;; ----------------------------------------------------------------
275
276 (defmacro bq-list* (&rest args)
277 "Returns a list of its arguments with last cons a dotted pair."
278 (setq args (reverse args))
279 (let ((result (car args)))
280 (setq args (cdr args))
281 (while args
282 (setq result (list 'cons (car args) result))
283 (setq args (cdr args)))
284 result))
285
286 (provide 'backquote)
287