![[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] / 43BSDReno / contrib / emacs-18.55 / lisp|
Return to backquote.el CVS log | Up to [CSRG BSD Unix] / 43BSDReno / contrib / emacs-18.55 / 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 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 bq-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 bq-caar (l)
71: (list 'car (list 'car l)))
72:
73: (defmacro bq-cadr (l)
74: (list 'car (list 'cdr l)))
75:
76: (defmacro bq-cdar (l)
77: (list 'cdr (list 'car l)))
78:
79:
80: ;;; These two advertised variables control what characters are used to
81: ;;; unquote things. I have included , and ,@ as the unquote and
82: ;;; splice operators, respectively, to give users of MIT CADR machine
83: ;;; derivitive machines a warm, cosy feeling.
84:
85: (defconst backquote-unquote '(,)
86: "*A list of all objects that stimulate unquoting in `. Memq test.")
87:
88:
89: (defconst backquote-splice '(,@)
90: "*A list of all objects that stimulate splicing in `. Memq test.")
91:
92:
93: ;;; This is the interface
94: (defmacro ` (form)
95: "(` FORM) Expands to a form that will generate FORM.
96: FORM is `almost quoted' -- see backquote.el for a description."
97: (bq-make-maker form))
98:
99: ;;; We develop the method for building the desired list from
100: ;;; the end towards the beginning. The contract is that there be a
101: ;;; variable called state and a list called tailmaker, and that the form
102: ;;; (cons state tailmaker) deliver the goods. Exception - if the
103: ;;; state is quote the tailmaker is the form itself.
104: ;;; This function takes a form and returns what I will call a maker in
105: ;;; what follows. Evaluating the maker would produce the form,
106: ;;; properly evaluated according to , and ,@ rules.
107: ;;; I work backwards - it seemed a lot easier. The reason for this is
108: ;;; if I'm in some sort of a routine building a maker and I switch
109: ;;; gears, it seemed to me easier to jump into some other state and
110: ;;; glue what I've already done to the end, than to to prepare that
111: ;;; something and go back to put things together.
112: (defun bq-make-maker (form)
113: "Given one argument, a `mostly quoted' object, produces a maker.
114: See backquote.el for details"
115: (let ((tailmaker (quote nil)) (qc 0) (ec 0) (state nil))
116: (mapcar 'bq-iterative-list-builder (reverse form))
117: (and state
118: (cond ((eq state 'quote)
119: (list state tailmaker))
120: ((= (length tailmaker) 1)
121: (funcall (bq-cadr (assq state bq-singles)) tailmaker))
122: (t (cons state tailmaker))))))
123:
124: ;;; There are exceptions - we wouldn't want to call append of one
125: ;;; argument, for example.
126: (defconst bq-singles '((quote bq-quotecar)
127: (append car)
128: (list bq-make-list)
129: (cons bq-id)))
130:
131: (defun bq-id (x) x)
132:
133: (defun bq-quotecar (x) (list 'quote (car x)))
134:
135: (defun bq-make-list (x) (cons 'list x))
136:
137: ;;; fr debugging use only
138: ;(defun funcalll (a b) (funcall a b))
139: ;(defun funcalll (a b) (debug nil 'enter state tailmaker a b)
140: ; (let ((ans (funcall a b))) (debug nil 'leave state tailmaker)
141: ; ans))
142:
143: ;;; Given a state/tailmaker pair that already knows how to make a
144: ;;; partial tail of the desired form, this function knows how to add
145: ;;; yet another element to the burgening list. There are four cases;
146: ;;; the next item is an atom (which will certainly be quoted); a
147: ;;; (, xxx), which will be evaluated and put into the list at the top
148: ;;; level; a (,@ xxx), which will be evaluated and spliced in, or
149: ;;; some other list, in which case we first compute the form's maker,
150: ;;; and then we either launch into the quoted case if the maker's
151: ;;; top level function is quote, or into the comma case if it isn't.
152: ;;; The fourth case reduces to one of the other three, so here we have
153: ;;; a choice of three ways to build tailmaker, and cit turns out we
154: ;;; use five possible values of state (although someday I'll add
155: ;;; nconcto the possible values of state).
156: ;;; This maintains the invariant that (cons state tailmaker) is the
157: ;;; maker for the elements of the tail we've eaten so far.
158: (defun bq-iterative-list-builder (form)
159: "Called by bq-make-maker. Adds a new item form to tailmaker,
160: changing state if need be, so tailmaker and state constitute a recipie
161: for making the list so far."
162: (cond ((atom form)
163: (funcall (bq-cadr (assq state bq-quotefns)) form))
164: ((memq (car form) backquote-unquote)
165: (funcall (bq-cadr (assq state bq-evalfns)) (bq-cadr form)))
166: ((memq (car form) backquote-splice)
167: (funcall (bq-cadr (assq state bq-splicefns)) (bq-cadr form)))
168: (t
169: (let ((newform (bq-make-maker form)))
170: (if (and (listp newform) (eq (car newform) 'quote))
171: (funcall (bq-cadr (assq state bq-quotefns)) (bq-cadr newform))
172: (funcall (bq-cadr (assq state bq-evalfns)) newform))))
173: ))
174:
175: ;;; We do a 2-d branch on the form of splicing and the old state.
176: ;;; Here's fifteen functions' names...
177: (defconst bq-splicefns '((nil bq-splicenil)
178: (append bq-spliceappend)
179: (list bq-splicelist)
180: (quote bq-splicequote)
181: (cons bq-splicecons)))
182:
183: (defconst bq-evalfns '((nil bq-evalnil)
184: (append bq-evalappend)
185: (list bq-evallist)
186: (quote bq-evalquote)
187: (cons bq-evalcons)))
188:
189: (defconst bq-quotefns '((nil bq-quotenil)
190: (append bq-quoteappend)
191: (list bq-quotelist)
192: (quote bq-quotequote)
193: (cons bq-quotecons)))
194:
195: ;;; The name of each function is
196: ;;; (concat 'bq- <type-of-element-addition> <old-state>)
197: ;;; I'll comment the non-obvious ones before the definitions...
198: ;;; In what follows, uppercase letters and form will always be
199: ;;; metavariables that don't need commas in backquotes, and I will
200: ;;; assume the existence of something like matches that takes a
201: ;;; backquote-like form and a value, binds metavariables and returns
202: ;;; t if the pattern match is successful, returns nil otherwise. I
203: ;;; will write such a goodie someday.
204:
205: ;;; (setq tailmaker
206: ;;; (if (matches ((quote X) Y) tailmaker)
207: ;;; (` ((quote (form X)) Y))
208: ;;; (` ((list form (quote X)) Y))))
209: ;;; (setq state 'append)
210: (defun bq-quotecons (form)
211: (if (and (listp (car tailmaker))
212: (eq (bq-caar tailmaker) 'quote))
213: (setq tailmaker
214: (list (list 'quote (list form (bq-cadr (car tailmaker))))
215: (bq-cadr tailmaker)))
216: (setq tailmaker
217: (list (list 'list
218: (list 'quote form)
219: (car tailmaker))
220: (bq-cadr tailmaker))))
221: (setq state 'append))
222:
223: (defun bq-quotequote (form)
224: (bq-push form tailmaker))
225:
226: ;;; Could be improved to convert (list 'a 'b 'c .. 'w x)
227: ;;; to (append '(a b c .. w) x)
228: ;;; when there are enough elements
229: (defun bq-quotelist (form)
230: (bq-push (list 'quote form) tailmaker))
231:
232: ;;; (setq tailmaker
233: ;;; (if (matches ((quote X) (,@ Y)))
234: ;;; (` ((quote (, (cons form X))) (,@ Y)))))
235: (defun bq-quoteappend (form)
236: (cond ((and (listp tailmaker)
237: (listp (car tailmaker))
238: (eq (bq-caar tailmaker) 'quote))
239: (rplaca (bq-cdar tailmaker)
240: (cons form (car (bq-cdar tailmaker)))))
241: (t (bq-push (list 'quote (list form)) tailmaker))))
242:
243: (defun bq-quotenil (form)
244: (setq tailmaker (list form))
245: (setq state 'quote))
246:
247: ;;; (if (matches (X Y) tailmaker) ; it must
248: ;;; (` ((list form X) Y)))
249: (defun bq-evalcons (form)
250: (setq tailmaker
251: (list (list 'list form (car tailmaker))
252: (bq-cadr tailmaker)))
253: (setq state 'append))
254:
255: ;;; (if (matches (X Y Z (,@ W)))
256: ;;; (progn (setq state 'append)
257: ;;; (` ((list form) (quote (X Y Z (,@ W))))))
258: ;;; (progn (setq state 'list)
259: ;;; (list form 'X 'Y .. ))) ; quote each one there is
260: (defun bq-evalquote (form)
261: (cond ((< (length tailmaker) 3)
262: (setq tailmaker
263: (cons form
264: (mapcar (function (lambda (x)
265: (list 'quote x)))
266: tailmaker)))
267: (setq state 'list))
268: (t
269: (setq tailmaker
270: (list (list 'list form)
271: (list 'quote tailmaker)))
272: (setq state 'append))))
273:
274: (defun bq-evallist (form)
275: (bq-push form tailmaker))
276:
277: ;;; (cond ((matches ((list (,@ X)) (,@ Y)))
278: ;;; (` ((list form (,@ X)) (,@ Y))))
279: ;;; ((matches (X))
280: ;;; (` (form (,@ X))) (setq state 'cons))
281: ;;; ((matches ((,@ X)))
282: ;;; (` (form (,@ X)))))
283: (defun bq-evalappend (form)
284: (cond ((and (listp tailmaker)
285: (listp (car tailmaker))
286: (eq (bq-caar tailmaker) 'list))
287: (rplacd (car tailmaker)
288: (cons form (bq-cdar tailmaker))))
289: ((= (length tailmaker) 1)
290: (setq tailmaker (cons form tailmaker))
291: (setq state 'cons))
292: (t (bq-push (list 'list form) tailmaker))))
293:
294: (defun bq-evalnil (form)
295: (setq tailmaker (list form))
296: (setq state 'list))
297:
298: ;;; (if (matches (X Y)) ; it must
299: ;;; (progn (setq state 'append)
300: ;;; (` (form (cons X Y))))) ; couldn't think of anything clever
301: (defun bq-splicecons (form)
302: (setq tailmaker
303: (list form
304: (list 'cons (car tailmaker) (bq-cadr tailmaker))))
305: (setq state 'append))
306:
307: (defun bq-splicequote (form)
308: (setq tailmaker (list form (list 'quote (list tailmaker))))
309: (setq state 'append))
310:
311: (defun bq-splicelist (form)
312: (setq tailmaker (list form (cons 'list tailmaker)))
313: (setq state 'append))
314:
315: (defun bq-spliceappend (form)
316: (bq-push form tailmaker))
317:
318: (defun bq-splicenil (form)
319: (setq state 'append)
320: (setq tailmaker (list form)))
321:
322:
323:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.