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