Complete rewrite by Sladkey.

1 files changed, 186 insertions, 339 deletions

diff --git a/lisp/emacs-lisp/backquote.el b/lisp/emacs-lisp/backquote.el
index ef5d4a02c99..419e5ca02ba 100644
--- a/lisp/emacs-lisp/backquote.el
+++ b/lisp/emacs-lisp/backquote.el
@@ -1,15 +1,16 @@
-;;; backquote.el --- backquoting for Emacs Lisp macros
+;;; New backquote for GNU Emacs.
+;;; Copyright (C) 1990, 1992 Free Software Foundation, Inc.
 
-;; Copyright (C) 1985 Free Software Foundation, Inc.
+;; Author: Rick Sladkey <jrs@world.std.com>
+;; Maintainer: FSF
+;; Keywords: extensions, internal
 
-;; Author: Dick King (king@kestrel).
-;; Keywords: extensions
-
-;; This file is part of GNU Emacs.
+;; This file is not part of GNU Emacs but is distributed under
+;; the same conditions as 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 2, or (at your option)
+;; 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,
@@ -21,340 +22,186 @@
 ;; along with GNU Emacs; see the file COPYING.  If not, write to
 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
 
-;;; Commentary:
-
- ;;; This is a rudimentary 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?
+;; This is a new backquote for GNU Emacs written by
+;; Rick Sladkey <jrs@world.std.com>.  It has the following
+;; features compared to the version 18 backquote:
+
+;; Correctly handles nested backquotes.
+;; Correctly handles constants after a splice.
+;; Correctly handles top-level atoms and unquotes.
+;; Correctly handles unquote after dot.
+;; Understands vectors.
+;; Minimizes gratuitous consing.
+;; Faster operation with simpler semantics.
+;; Generates faster run-time expressions.
+;; One third fewer calories than our regular beer.
+
+;; This backquote will generate calls to the list* form.
+;; Both a function version and a macro version are included.
+;; The macro version is used by default because it is faster
+;; and needs no run-time support.  It should really be a subr.
 
 ;;; Code:
 
-;;; 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
- ;;; derivative 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 
-;;;###autoload
-(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 argument FORM, 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 (if (equal form tailmaker) form 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 burgeoning 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)
-  (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)))
-
 (provide 'backquote)
 
-;;; backquote.el ends here
+;; function and macro versions of list*
+
+(defun list*-function (first &rest list)
+  "Like `list' but the last argument is the tail of the new list.
+
+For example (list* 'a 'b 'c) => (a b . c)"
+  (if list
+      (let* ((rest list) (newlist (cons first nil)) (last newlist))
+        (while (cdr rest)
+          (setcdr last (cons (car rest) nil))
+          (setq last (cdr last)
+                rest (cdr rest)))
+        (setcdr last (car rest))
+        newlist)
+    first))
+
+(defmacro list*-macro (first &rest list)
+  "Like `cons' but accepts more arguments.
+
+For example (list* 'a 'b 'c) == (cons 'a (cons 'b 'c))"
+  (setq list (reverse (cons first list))
+        first (car list)
+        list (cdr list))
+  (if list
+      (let* ((second (car list))
+             (rest (cdr list))
+             (newlist (list 'cons second first)))
+        (while rest
+          (setq newlist (list 'cons (car rest) newlist)
+                rest (cdr rest)))
+        newlist)
+    first))
+
+(fset 'list* (symbol-function 'list*-macro))
+
+;; A few advertised variables that control which symbols are used
+;; to represent the backquote, unquote, and splice operations.
+
+(defvar backquote-backquote-symbol '`
+  "*Symbol used to represent a backquote or nested backquote (e.g. `).")
+
+(defvar backquote-unquote-symbol ',
+  "*Symbol used to represent an unquote (e.g. ,) inside a backquote.")
+
+(defvar backquote-splice-symbol ',@
+  "*Symbol used to represent a splice (e.g. ,@) inside a backquote.")
+
+(defmacro backquote (arg)
+  "Argument STRUCTURE describes a template to build.
+
+The whole structure acts as if it were quoted except for certain
+places where expressions are evaluated and inserted or spliced in.
+
+For example:
+
+b                 => (ba bb bc)         ; assume b has this value
+\(` (a b c))       => (a b c)           ; backquote acts like quote
+\(` (a (, b) c))   => (a (ba bb bc) c)  ; insert the value of b
+\(` (a (,@ b) c))  => (a ba bb bc c)    ; splice in the value of b
+
+Vectors work just like lists.  Nested backquotes are permitted.
+
+Variables: backquote-backquote-symbol, backquote-unquote-symbol,
+backquote-splice-symbol"
+  (cdr (bq-process arg)))
+
+;; GNU Emacs has no reader macros
+
+(fset backquote-backquote-symbol (symbol-function 'backquote))
+
+;; bq-process returns a dotted-pair of a tag (0, 1, or 2) and
+;; the backquote-processed structure.  0 => the structure is
+;; constant, 1 => to be unquoted, 2 => to be spliced in.
+;; The top-level backquote macro just discards the tag.
+
+(defun bq-process (s)
+  (cond
+   ((vectorp s)
+    (let ((n (bq-process (append s ()))))
+      (if (= (car n) 0)
+          (cons 0 s)
+        (cons 1 (cond
+                 ((eq (nth 1 n) 'list)
+                  (cons 'vector (nthcdr 2 n)))
+                 ((eq (nth 1 n) 'append)
+                  (cons 'vconcat (nthcdr 2 n)))
+                 (t
+                  (list 'apply '(function vector) (cdr n))))))))
+   ((atom s)
+    (cons 0 (if (or (null s) (eq s t) (not (symbolp s)))
+                s
+              (list 'quote s))))
+   ((eq (car s) backquote-unquote-symbol)
+    (cons 1 (nth 1 s)))
+   ((eq (car s) backquote-splice-symbol)
+    (cons 2 (nth 1 s)))
+   ((eq (car s) backquote-backquote-symbol)
+    (bq-process (cdr (bq-process (nth 1 s)))))
+   (t
+    (let ((rest s) (item nil) (firstlist nil) (list nil) (lists nil))
+      (while (consp rest)
+        (if (eq (car rest) backquote-unquote-symbol)
+            (setq rest (list (list backquote-splice-symbol (nth 1 rest)))))
+        (setq item (bq-process (car rest)))
+        (cond
+         ((= (car item) 2)
+          (if (null firstlist)
+              (setq firstlist list
+                    list nil))
+          (if list
+              (setq lists (cons (bq-listify list '(0 . nil)) lists)))
+          (setq lists (cons (cdr item) lists))
+          (setq list nil))
+         (t
+          (setq list (cons item list))))
+        (setq rest (cdr rest)))
+      (if (or rest list)
+          (setq lists (cons (bq-listify list (bq-process rest)) lists)))
+      (setq lists
+            (if (or (cdr lists)
+                    (and (consp (car lists))
+                         (eq (car (car lists)) backquote-splice-symbol)))
+                (cons 'append (nreverse lists))
+              (car lists)))
+      (if firstlist
+          (setq lists (bq-listify firstlist (cons 1 lists))))
+      (if (eq (car lists) 'quote)
+          (cons 0 (list 'quote s))
+        (cons 1 lists))))))
+
+;; bq-listify takes (tag . structure) pairs from bq-process
+;; and decides between append, list, list*, and cons depending
+;; on which tags are in the list.
+
+(defun bq-listify (list old-tail)
+  (let ((heads nil) (tail (cdr old-tail)) (list-tail list) (item nil))
+    (if (= (car old-tail) 0)
+        (setq tail (eval tail)
+              old-tail nil))
+    (while (consp list-tail)
+      (setq item (car list-tail))
+      (setq list-tail (cdr list-tail))
+      (if (or heads old-tail (/= (car item) 0))
+          (setq heads (cons (cdr item) heads))
+        (setq tail (cons (eval (cdr item)) tail))))
+    (cond
+     (tail
+      (if (null old-tail)
+          (setq tail (list 'quote tail)))
+      (if heads
+          (let ((use-list* (or (cdr heads)
+                               (and (consp (car heads))
+                                    (eq (car (car heads))
+                                        backquote-splice-symbol)))))
+            (cons (if use-list* 'list* 'cons)
+                  (append heads (list tail))))
+        tail))
+     (t (cons 'list heads)))))
+
+;; backquote.el ends here