Mercurial > hg > xemacs-beta

comparison lisp/backquote.el @ 209:41ff10fd062f r20-4b3

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