Initial revision

lisp/emacs-lisp/backquote.el

+;; 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)))