![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to backquote.el CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Apple XNU] / GNUtools / emacs / lisp|
Return to backquote.el CVS log | Up to [Apple XNU] / GNUtools / emacs / lisp |
1.1 root 1: ;; Copyright (C) 1985 Free Software Foundation, Inc.
2: ;; Written by Dick King (king@kestrel).
3:
4: ;; This file is part of GNU Emacs.
5:
6: ;; GNU Emacs is free software; you can redistribute it and/or modify
7: ;; it under the terms of the GNU General Public License as published by
8: ;; the Free Software Foundation; either version 1, or (at your option)
9: ;; any later version.
10:
11: ;; GNU Emacs is distributed in the hope that it will be useful,
12: ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13: ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14: ;; GNU General Public License for more details.
15:
16: ;; You should have received a copy of the GNU General Public License
17: ;; along with GNU Emacs; see the file COPYING. If not, write to
18: ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
19:
20:
21: ;;; This is a rudimentry backquote package written by D. King,
22: ;;; king@kestrel, on 8/31/85. (` x) is a macro
23: ;;; that expands to a form that produces x. (` (a b ..)) is
24: ;;; a macro that expands into a form that produces a list of what a b
25: ;;; etc. would have produced. Any element can be of the form
26: ;;; (, <form>) in which case the resulting form evaluates
27: ;;; <form> before putting it into place, or (,@ <form>), in which
28: ;;; case the evaluation of <form> is arranged for and each element
29: ;;; of the result (which must be a (possibly null) list) is inserted.
30: ;;; As an example, the immediately following macro push (v l) could
31: ;;; have been written
32: ;;; (defmacro push (v l)
33: ;;; (` (setq (, l) (cons (,@ (list v l))))))
34: ;;; although
35: ;;; (defmacro push (v l)
36: ;;; (` (setq (, l) (cons (, v) (, l)))))
37: ;;; is far more natural. The magic atoms ,
38: ;;; and ,@ are user-settable and list-valued. We recommend that
39: ;;; things never be removed from this list lest you break something
40: ;;; someone else wrote in the dim past that comes to be recompiled in
41: ;;; the distant future.
42:
43: ;;; LIMITATIONS: tail consing is not handled correctly. Do not say
44: ;;; (` (a . (, b))) - say (` (a (,@ b)))
45: ;;; which works even if b is not list-valued.
46: ;;; No attempt is made to handle vectors. (` [a (, b) c]) doesn't work.
47: ;;; Sorry, you must say things like
48: ;;; (` (a (,@ 'b))) to get (a . b) and
49: ;;; (` ((, ',) c)) to get (, c) - [(` (a , b)) will work but is a bad habit]
50: ;;; I haven't taught it the joys of nconc.
51: ;;; (` atom) dies. (` (, atom)) or anything else is okay.
52:
53: ;;; BEWARE BEWARE BEWARE
54: ;;; inclusion of (,atom) rather than (, atom) or (,@atom) rather than
55: ;;; (,@ atom) will result in errors that will show up very late.
56: ;;; This is so crunchy that I am considering including a check for
57: ;;; this or changing the syntax to ... ,(<form>). RMS: opinion?
58:
59:
60: (provide 'backquote)
61:
62: ;;; a raft of general-purpose macros follows. See the nearest
63: ;;; Commonlisp manual.
64: (defmacro bq-push (v l)
65: "Pushes evaluated first form onto second unevaluated object
66: a list-value atom"
67: (list 'setq l (list 'cons v l)))
68:
69: (defmacro bq-caar (l)
70: (list 'car (list 'car l)))
71:
72: (defmacro bq-cadr (l)
73: (list 'car (list 'cdr l)))
74:
75: (defmacro bq-cdar (l)
76: (list 'cdr (list 'car l)))
77:
78:
79: ;;; These two advertised variables control what characters are used to
80: ;;; unquote things. I have included , and ,@ as the unquote and
81: ;;; splice operators, respectively, to give users of MIT CADR machine
82: ;;; derivitive machines a warm, cosy feeling.
83:
84: (defconst backquote-unquote '(,)
85: "*A list of all objects that stimulate unquoting in `. Memq test.")
86:
87:
88: (defconst backquote-splice '(,@)
89: "*A list of all objects that stimulate splicing in `. Memq test.")
90:
91:
92: ;;; This is the interface
93: (defmacro ` (form)
94: "(` FORM) Expands to a form that will generate FORM.
95: FORM is `almost quoted' -- see backquote.el for a description."
96: (bq-make-maker form))
97:
98: ;;; We develop the method for building the desired list from
99: ;;; the end towards the beginning. The contract is that there be a
100: ;;; variable called state and a list called tailmaker, and that the form
101: ;;; (cons state tailmaker) deliver the goods. Exception - if the
102: ;;; state is quote the tailmaker is the form itself.
103: ;;; This function takes a form and returns what I will call a maker in
104: ;;; what follows. Evaluating the maker would produce the form,
105: ;;; properly evaluated according to , and ,@ rules.
106: ;;; I work backwards - it seemed a lot easier. The reason for this is
107: ;;; if I'm in some sort of a routine building a maker and I switch
108: ;;; gears, it seemed to me easier to jump into some other state and
109: ;;; glue what I've already done to the end, than to to prepare that
110: ;;; something and go back to put things together.
111: (defun bq-make-maker (form)
112: "Given one argument, a `mostly quoted' object, produces a maker.
113: See backquote.el for details"
114: (let ((tailmaker (quote nil)) (qc 0) (ec 0) (state nil))
115: (mapcar 'bq-iterative-list-builder (reverse form))
116: (and state
117: (cond ((eq state 'quote)
118: (list state tailmaker))
119: ((= (length tailmaker) 1)
120: (funcall (bq-cadr (assq state bq-singles)) tailmaker))
121: (t (cons state tailmaker))))))
122:
123: ;;; There are exceptions - we wouldn't want to call append of one
124: ;;; argument, for example.
125: (defconst bq-singles '((quote bq-quotecar)
126: (append car)
127: (list bq-make-list)
128: (cons bq-id)))
129:
130: (defun bq-id (x) x)
131:
132: (defun bq-quotecar (x) (list 'quote (car x)))
133:
134: (defun bq-make-list (x) (cons 'list x))
135:
136: ;;; fr debugging use only
137: ;(defun funcalll (a b) (funcall a b))
138: ;(defun funcalll (a b) (debug nil 'enter state tailmaker a b)
139: ; (let ((ans (funcall a b))) (debug nil 'leave state tailmaker)
140: ; ans))
141:
142: ;;; Given a state/tailmaker pair that already knows how to make a
143: ;;; partial tail of the desired form, this function knows how to add
144: ;;; yet another element to the burgening list. There are four cases;
145: ;;; the next item is an atom (which will certainly be quoted); a
146: ;;; (, xxx), which will be evaluated and put into the list at the top
147: ;;; level; a (,@ xxx), which will be evaluated and spliced in, or
148: ;;; some other list, in which case we first compute the form's maker,
149: ;;; and then we either launch into the quoted case if the maker's
150: ;;; top level function is quote, or into the comma case if it isn't.
151: ;;; The fourth case reduces to one of the other three, so here we have
152: ;;; a choice of three ways to build tailmaker, and cit turns out we
153: ;;; use five possible values of state (although someday I'll add
154: ;;; nconcto the possible values of state).
155: ;;; This maintains the invariant that (cons state tailmaker) is the
156: ;;; maker for the elements of the tail we've eaten so far.
157: (defun bq-iterative-list-builder (form)
158: "Called by bq-make-maker. Adds a new item form to tailmaker,
159: changing state if need be, so tailmaker and state constitute a recipie
160: for making the list so far."
161: (cond ((atom form)
162: (funcall (bq-cadr (assq state bq-quotefns)) form))
163: ((memq (car form) backquote-unquote)
164: (funcall (bq-cadr (assq state bq-evalfns)) (bq-cadr form)))
165: ((memq (car form) backquote-splice)
166: (funcall (bq-cadr (assq state bq-splicefns)) (bq-cadr form)))
167: (t
168: (let ((newform (bq-make-maker form)))
169: (if (and (listp newform) (eq (car newform) 'quote))
170: (funcall (bq-cadr (assq state bq-quotefns)) (bq-cadr newform))
171: (funcall (bq-cadr (assq state bq-evalfns)) newform))))
172: ))
173:
174: ;;; We do a 2-d branch on the form of splicing and the old state.
175: ;;; Here's fifteen functions' names...
176: (defconst bq-splicefns '((nil bq-splicenil)
177: (append bq-spliceappend)
178: (list bq-splicelist)
179: (quote bq-splicequote)
180: (cons bq-splicecons)))
181:
182: (defconst bq-evalfns '((nil bq-evalnil)
183: (append bq-evalappend)
184: (list bq-evallist)
185: (quote bq-evalquote)
186: (cons bq-evalcons)))
187:
188: (defconst bq-quotefns '((nil bq-quotenil)
189: (append bq-quoteappend)
190: (list bq-quotelist)
191: (quote bq-quotequote)
192: (cons bq-quotecons)))
193:
194: ;;; The name of each function is
195: ;;; (concat 'bq- <type-of-element-addition> <old-state>)
196: ;;; I'll comment the non-obvious ones before the definitions...
197: ;;; In what follows, uppercase letters and form will always be
198: ;;; metavariables that don't need commas in backquotes, and I will
199: ;;; assume the existence of something like matches that takes a
200: ;;; backquote-like form and a value, binds metavariables and returns
201: ;;; t if the pattern match is successful, returns nil otherwise. I
202: ;;; will write such a goodie someday.
203:
204: ;;; (setq tailmaker
205: ;;; (if (matches ((quote X) Y) tailmaker)
206: ;;; (` ((quote (form X)) Y))
207: ;;; (` ((list form (quote X)) Y))))
208: ;;; (setq state 'append)
209: (defun bq-quotecons (form)
210: (if (and (listp (car tailmaker))
211: (eq (bq-caar tailmaker) 'quote))
212: (setq tailmaker
213: (list (list 'quote (list form (bq-cadr (car tailmaker))))
214: (bq-cadr tailmaker)))
215: (setq tailmaker
216: (list (list 'list
217: (list 'quote form)
218: (car tailmaker))
219: (bq-cadr tailmaker))))
220: (setq state 'append))
221:
222: (defun bq-quotequote (form)
223: (bq-push form tailmaker))
224:
225: ;;; Could be improved to convert (list 'a 'b 'c .. 'w x)
226: ;;; to (append '(a b c .. w) x)
227: ;;; when there are enough elements
228: (defun bq-quotelist (form)
229: (bq-push (list 'quote form) tailmaker))
230:
231: ;;; (setq tailmaker
232: ;;; (if (matches ((quote X) (,@ Y)))
233: ;;; (` ((quote (, (cons form X))) (,@ Y)))))
234: (defun bq-quoteappend (form)
235: (cond ((and (listp tailmaker)
236: (listp (car tailmaker))
237: (eq (bq-caar tailmaker) 'quote))
238: (rplaca (bq-cdar tailmaker)
239: (cons form (car (bq-cdar tailmaker)))))
240: (t (bq-push (list 'quote (list form)) tailmaker))))
241:
242: (defun bq-quotenil (form)
243: (setq tailmaker (list form))
244: (setq state 'quote))
245:
246: ;;; (if (matches (X Y) tailmaker) ; it must
247: ;;; (` ((list form X) Y)))
248: (defun bq-evalcons (form)
249: (setq tailmaker
250: (list (list 'list form (car tailmaker))
251: (bq-cadr tailmaker)))
252: (setq state 'append))
253:
254: ;;; (if (matches (X Y Z (,@ W)))
255: ;;; (progn (setq state 'append)
256: ;;; (` ((list form) (quote (X Y Z (,@ W))))))
257: ;;; (progn (setq state 'list)
258: ;;; (list form 'X 'Y .. ))) ; quote each one there is
259: (defun bq-evalquote (form)
260: (cond ((< (length tailmaker) 3)
261: (setq tailmaker
262: (cons form
263: (mapcar (function (lambda (x)
264: (list 'quote x)))
265: tailmaker)))
266: (setq state 'list))
267: (t
268: (setq tailmaker
269: (list (list 'list form)
270: (list 'quote tailmaker)))
271: (setq state 'append))))
272:
273: (defun bq-evallist (form)
274: (bq-push form tailmaker))
275:
276: ;;; (cond ((matches ((list (,@ X)) (,@ Y)))
277: ;;; (` ((list form (,@ X)) (,@ Y))))
278: ;;; ((matches (X))
279: ;;; (` (form (,@ X))) (setq state 'cons))
280: ;;; ((matches ((,@ X)))
281: ;;; (` (form (,@ X)))))
282: (defun bq-evalappend (form)
283: (cond ((and (listp tailmaker)
284: (listp (car tailmaker))
285: (eq (bq-caar tailmaker) 'list))
286: (rplacd (car tailmaker)
287: (cons form (bq-cdar tailmaker))))
288: ((= (length tailmaker) 1)
289: (setq tailmaker (cons form tailmaker))
290: (setq state 'cons))
291: (t (bq-push (list 'list form) tailmaker))))
292:
293: (defun bq-evalnil (form)
294: (setq tailmaker (list form))
295: (setq state 'list))
296:
297: ;;; (if (matches (X Y)) ; it must
298: ;;; (progn (setq state 'append)
299: ;;; (` (form (cons X Y))))) ; couldn't think of anything clever
300: (defun bq-splicecons (form)
301: (setq tailmaker
302: (list form
303: (list 'cons (car tailmaker) (bq-cadr tailmaker))))
304: (setq state 'append))
305:
306: (defun bq-splicequote (form)
307: (setq tailmaker (list form (list 'quote (list tailmaker))))
308: (setq state 'append))
309:
310: (defun bq-splicelist (form)
311: (setq tailmaker (list form (cons 'list tailmaker)))
312: (setq state 'append))
313:
314: (defun bq-spliceappend (form)
315: (bq-push form tailmaker))
316:
317: (defun bq-splicenil (form)
318: (setq state 'append)
319: (setq tailmaker (list form)))
320:
321:
322:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.