summaryrefslogtreecommitdiff
path: root/lisp/emacs-lisp/backquote.el
blob: 715a794d5fe6897ab3e18ac50432b4ca28d23483 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
;; Copyright (C) 1985 Free Software Foundation, Inc.
;; Written by Dick King (king@kestrel).

;; This file is part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 1, or (at your option)
;; any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.


;;; This is a rudimentry backquote package written by D. King,
 ;;; king@kestrel, on 8/31/85.  (` x) is a macro
 ;;; that expands to a form that produces x.  (` (a b ..)) is
 ;;; a macro that expands into a form that produces a list of what a b
 ;;; etc. would have produced.  Any element can be of the form
 ;;; (, <form>) in which case the resulting form evaluates
 ;;; <form> before putting it into place, or (,@ <form>), in which
 ;;; case the evaluation of <form> is arranged for and each element
 ;;; of the result (which must be a (possibly null) list) is inserted.
;;; As an example, the immediately following macro push (v l) could
 ;;; have been written 
;;;    (defmacro push (v l)
;;;         (` (setq (, l) (cons (,@ (list v l))))))
 ;;; although
;;;    (defmacro push (v l)
;;;         (` (setq (, l) (cons (, v) (, l)))))
 ;;; is far more natural.  The magic atoms ,
 ;;; and ,@ are user-settable and list-valued.  We recommend that
 ;;; things never be removed from this list lest you break something
 ;;; someone else wrote in the dim past that comes to be recompiled in
 ;;; the distant future.

;;; LIMITATIONS: tail consing is not handled correctly.  Do not say
 ;;; (` (a . (, b))) - say (` (a (,@ b)))
 ;;; which works even if b is not list-valued.
;;; No attempt is made to handle vectors.  (` [a (, b) c]) doesn't work.
;;; Sorry, you must say things like
 ;;; (` (a (,@ 'b))) to get (a . b) and 
 ;;; (` ((, ',) c)) to get (, c) - [(` (a , b)) will work but is a bad habit]
;;; I haven't taught it the joys of nconc.
;;; (` atom) dies.  (` (, atom)) or anything else is okay.

;;; BEWARE BEWARE BEWARE
 ;;; inclusion of (,atom) rather than (, atom) or (,@atom) rather than
 ;;; (,@ atom) will result in errors that will show up very late.
 ;;; This is so crunchy that I am considering including a check for
 ;;; this or changing the syntax to ... ,(<form>).  RMS: opinion?


(provide 'backquote)

;;; a raft of general-purpose macros follows.  See the nearest
 ;;; Commonlisp manual.
(defmacro bq-push (v l)
  "Pushes evaluated first form onto second unevaluated object
a list-value atom"
  (list 'setq l (list 'cons v l)))

(defmacro bq-caar (l)
  (list 'car (list 'car l)))

(defmacro bq-cadr (l)
  (list 'car (list 'cdr l)))

(defmacro bq-cdar (l)
  (list 'cdr (list 'car l)))


;;; These two advertised variables control what characters are used to
 ;;; unquote things.  I have included , and ,@ as the unquote and
 ;;; splice operators, respectively, to give users of MIT CADR machine
 ;;; derivitive machines a warm, cosy feeling.

(defconst backquote-unquote '(,)
  "*A list of all objects that stimulate unquoting in `.  Memq test.")


(defconst backquote-splice '(,@)
  "*A list of all objects that stimulate splicing in `.  Memq test.")


;;; This is the interface 
(defmacro ` (form)
  "(` FORM)  is a macro that expands to code to construct FORM.
Note that this is very slow in interpreted code, but fast if you compile.
FORM is one or more nested lists, which are `almost quoted':
They are copied recursively, with non-lists used unchanged in the copy.
 (` a b) == (list 'a 'b)  constructs a new list with two elements, `a' and `b'.
 (` a (b c)) == (list 'a (list 'b 'c))  constructs two nested new lists.

However, certain special lists are not copied.  They specify substitution.
Lists that look like (, EXP) are evaluated and the result is substituted.
 (` a (, (+ x 5))) == (list 'a (+ x 5))

Elements of the form (,@ EXP) are evaluated and then all the elements
of the result are substituted.  This result must be a list; it may
be `nil'.

As an example, a simple macro `push' could be written:
   (defmacro push (v l)
        (` (setq (, l) (cons (,@ (list v l))))))
or as
   (defmacro push (v l)
        (` (setq (, l) (cons (, v) (, l)))))

LIMITATIONS: \"dotted lists\" are not allowed in FORM.
The ultimate cdr of each list scanned by ` must be `nil'.
\(This does not apply to constants inside expressions to be substituted.)

Substitution elements are not allowed as the cdr
of a cons cell.  For example, (` (A . (, B))) does not work.
Instead, write (` (A (,@ B))).

You cannot construct vectors, only lists.  Vectors are treated as
constants.

BEWARE BEWARE BEWARE
Inclusion of (,ATOM) rather than (, ATOM)
or of (,@ATOM) rather than (,@ ATOM)
will result in errors that will show up very late."
  (bq-make-maker form))

;;; We develop the method for building the desired list from
 ;;; the end towards the beginning.  The contract is that there be a
 ;;; variable called state and a list called tailmaker, and that the form
 ;;; (cons state tailmaker) deliver the goods.  Exception - if the
 ;;; state is quote the tailmaker is the form itself.
;;; This function takes a form and returns what I will call a maker in
 ;;; what follows.  Evaluating the maker would produce the form,
 ;;; properly evaluated according to , and ,@ rules.
;;; I work backwards - it seemed a lot easier.  The reason for this is
 ;;; if I'm in some sort of a routine building a maker and I switch
 ;;; gears, it seemed to me easier to jump into some other state and
 ;;; glue what I've already done to the end, than to to prepare that
 ;;; something and go back to put things together.
(defun bq-make-maker (form)
  "Given one argument, a `mostly quoted' object, produces a maker.
See backquote.el for details"
  (let ((tailmaker (quote nil)) (qc 0) (ec 0) (state nil))
    (mapcar 'bq-iterative-list-builder (reverse form))
    (and state
	 (cond ((eq state 'quote)
		(list state tailmaker))
	       ((= (length tailmaker) 1)
		(funcall (bq-cadr (assq state bq-singles)) tailmaker))
	       (t (cons state tailmaker))))))

;;; There are exceptions - we wouldn't want to call append of one
 ;;; argument, for example.
(defconst bq-singles '((quote bq-quotecar)
		       (append car)
		       (list bq-make-list)
		       (cons bq-id)))

(defun bq-id (x) x)

(defun bq-quotecar (x) (list 'quote (car x)))

(defun bq-make-list (x) (cons 'list x))

;;; fr debugging use only
;(defun funcalll (a b) (funcall a b))
;(defun funcalll (a b) (debug nil 'enter state tailmaker a b)
;  (let ((ans (funcall a b))) (debug  nil 'leave state tailmaker)
;       ans))

;;; Given a state/tailmaker pair that already knows how to make a
 ;;; partial tail of the desired form, this function knows how to add
 ;;; yet another element to the burgening list.  There are four cases;
 ;;; the next item is an atom (which will certainly be quoted); a 
 ;;; (, xxx), which will be evaluated and put into the list at the top
 ;;; level; a (,@ xxx), which will be evaluated and spliced in, or
 ;;; some other list, in which case we first compute the form's maker,
 ;;; and then we either launch into the quoted case if the maker's
 ;;; top level function is quote, or into the comma case if it isn't.
;;; The fourth case reduces to one of the other three, so here we have
 ;;; a choice of three ways to build tailmaker, and cit turns out we
 ;;; use five possible values of state (although someday I'll add
 ;;; nconcto the possible values of state).
;;; This maintains the invariant that (cons state tailmaker) is the
 ;;; maker for the elements of the tail we've eaten so far.
(defun bq-iterative-list-builder (form)
  "Called by `bq-make-maker'.  Adds a new item form to tailmaker, 
changing state if need be, so tailmaker and state constitute a recipe
for making the list so far."
  (cond ((atom form)
	 (funcall (bq-cadr (assq state bq-quotefns)) form))
	((memq (car form) backquote-unquote)
	 (funcall (bq-cadr (assq state bq-evalfns)) (bq-cadr form)))
	((memq (car form) backquote-splice)
	 (funcall (bq-cadr (assq state bq-splicefns)) (bq-cadr form)))
	(t
	 (let ((newform (bq-make-maker form)))
	   (if (and (listp newform) (eq (car newform) 'quote))
	       (funcall (bq-cadr (assq state bq-quotefns)) (bq-cadr newform))
	     (funcall (bq-cadr (assq state bq-evalfns)) newform))))
	))

;;; We do a 2-d branch on the form of splicing and the old state.
 ;;; Here's fifteen functions' names...
(defconst bq-splicefns '((nil bq-splicenil)
			 (append bq-spliceappend)
			 (list bq-splicelist)
			 (quote bq-splicequote)
			 (cons bq-splicecons)))

(defconst bq-evalfns '((nil bq-evalnil)
		       (append bq-evalappend)
		       (list bq-evallist)
		       (quote bq-evalquote)
		       (cons bq-evalcons)))

(defconst bq-quotefns '((nil bq-quotenil)
			(append bq-quoteappend)
			(list bq-quotelist)
			(quote bq-quotequote)
			(cons bq-quotecons)))

;;; The name of each function is
 ;;; (concat 'bq- <type-of-element-addition> <old-state>)
;;; I'll comment the non-obvious ones before the definitions...
 ;;; In what follows, uppercase letters and form will always be
 ;;; metavariables that don't need commas in backquotes, and I will
 ;;; assume the existence of something like matches that takes a
 ;;; backquote-like form and a value, binds metavariables and returns
 ;;; t if the pattern match is successful, returns nil otherwise.  I
 ;;; will write such a goodie someday.

;;;   (setq tailmaker
 ;;;      (if (matches ((quote X) Y) tailmaker)
 ;;;          (` ((quote (form X)) Y))
 ;;;        (` ((list form (quote X)) Y))))
 ;;;  (setq state 'append)
(defun bq-quotecons (form)
  (if (and (listp (car tailmaker))
	   (eq (bq-caar tailmaker) 'quote))
      (setq tailmaker
	    (list (list 'quote (list form (bq-cadr (car tailmaker))))
		  (bq-cadr tailmaker))) 
    (setq tailmaker
	  (list (list 'list
		      (list 'quote form)
		      (car tailmaker))
		(bq-cadr tailmaker))))
  (setq state 'append))

(defun bq-quotequote (form)
  (bq-push form tailmaker))

;;; Could be improved to convert (list 'a 'b 'c .. 'w x) 
 ;;;                          to (append '(a b c .. w) x)
 ;;; when there are enough elements
(defun bq-quotelist (form)
  (bq-push (list 'quote form) tailmaker))

;;; (setq tailmaker
 ;;;  (if (matches ((quote X) (,@ Y)))
 ;;;      (` ((quote (, (cons form X))) (,@ Y)))))
(defun bq-quoteappend (form)
  (cond ((and (listp tailmaker)
	   (listp (car tailmaker))
	   (eq (bq-caar tailmaker) 'quote))
	 (rplaca (bq-cdar tailmaker)
		 (cons form (car (bq-cdar tailmaker)))))
	(t (bq-push (list 'quote (list form)) tailmaker))))

(defun bq-quotenil (form)
  (setq tailmaker (list form))
  (setq state 'quote))

;;; (if (matches (X Y) tailmaker)  ; it must
 ;;;    (` ((list form X) Y)))
(defun bq-evalcons (form)
  (setq tailmaker
	(list (list 'list form (car tailmaker))
	      (bq-cadr tailmaker)))
  (setq state 'append))

;;;  (if (matches (X Y Z (,@ W)))
 ;;;     (progn (setq state 'append)
 ;;;            (` ((list form) (quote (X Y Z (,@ W))))))
 ;;;     (progn (setq state 'list)
 ;;;            (list form 'X 'Y .. )))  ;  quote each one there is
(defun bq-evalquote (form)
  (cond ((< (length tailmaker) 3)
	 (setq tailmaker
	       (cons form
		     (mapcar (function (lambda (x)
					 (list 'quote x)))
			     tailmaker)))
	 (setq state 'list))
	(t
	 (setq tailmaker
	       (list (list 'list form)
		     (list 'quote tailmaker)))
	 (setq state 'append))))

(defun bq-evallist (form)
  (bq-push form tailmaker))

;;;  (cond ((matches ((list (,@ X)) (,@ Y)))
 ;;;        (` ((list form  (,@ X)) (,@ Y))))
 ;;;       ((matches (X))
 ;;;        (` (form (,@ X))) (setq state 'cons))
 ;;;       ((matches ((,@ X)))
 ;;;        (` (form (,@ X)))))
(defun bq-evalappend (form)
  (cond ((and (listp tailmaker)
	   (listp (car tailmaker))
	   (eq (bq-caar tailmaker) 'list))
	 (rplacd (car tailmaker)
		 (cons form (bq-cdar tailmaker))))
	((= (length tailmaker) 1)
	 (setq tailmaker (cons form tailmaker)
	       state 'cons))
	(t (bq-push (list 'list form) tailmaker))))

(defun bq-evalnil (form)
  (setq tailmaker (list form)
	state 'list))

;;; (if (matches (X Y))  ; it must
 ;;;    (progn (setq state 'append)
 ;;;           (` (form (cons X Y)))))   ; couldn't think of anything clever
(defun bq-splicecons (form)
  (setq tailmaker
	(list form
	      (list 'cons (car tailmaker) (bq-cadr tailmaker)))
	state 'append))

(defun bq-splicequote (form)
  (setq tailmaker (list form (list 'quote tailmaker))
	state 'append))

(defun bq-splicelist (form)
  (setq tailmaker (list form (cons 'list tailmaker))
	state 'append))

(defun bq-spliceappend (form)
  (bq-push form tailmaker))

(defun bq-splicenil (form)
  (setq state 'append
	tailmaker (list form)))