-;; backquote.el --- backquoting for Emacs Lisp macros
-
-;; Copyright (C) 1985 Free Software Foundation, Inc.
-
-;; Author: Dick King (king@kestrel).
-;; Keywords: extensions
-
-;; 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 2, 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.
-
-;;; Commentary:
-
- ;;; 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?
-
-;;; 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
- ;;; 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
-;;;###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 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)
- (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
+;;; backquote.el --- implement the ` Lisp construct
+
+;;; Copyright (C) 1990, 1992, 1994 Free Software Foundation, Inc.
+
+;; Author: Rick Sladkey <jrs@world.std.com>
+;; Maintainer: FSF
+;; Keywords: extensions, internal
+
+;; 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 2, 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, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; This backquote will generate calls to the backquote-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:
+
+(provide 'backquote)
+
+;; function and macro versions of backquote-list*
+
+(defun backquote-list*-function (first &rest list)
+ "Like `list' but the last argument is the tail of the new list.
+
+For example (backquote-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 backquote-list*-macro (first &rest list)
+ "Like `list' but the last argument is the tail of the new list.
+
+For example (backquote-list* 'a 'b 'c) => (a 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))
+
+(defalias 'backquote-list* (symbol-function 'backquote-list*-macro))
+
+;; A few advertised variables that control which symbols are used
+;; to represent the backquote, unquote, and splice operations.
+(defconst backquote-backquote-symbol '\`
+ "*Symbol used to represent a backquote or nested backquote.")
+
+(defconst backquote-unquote-symbol ',
+ "*Symbol used to represent an unquote inside a backquote.")
+
+(defconst backquote-splice-symbol ',@
+ "*Symbol used to represent a splice inside a backquote.")
+
+;;;###autoload
+(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."
+ (cdr (backquote-process arg)))
+
+;; GNU Emacs has no reader macros
+
+;;;###autoload
+(defalias '\` (symbol-function 'backquote))
+
+;; backquote-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 backquote-process (s)
+ (cond
+ ((vectorp s)
+ (let ((n (backquote-process (append s ()))))
+ (if (= (car n) 0)
+ (cons 0 s)
+ (cons 1 (cond
+ ((not (listp (cdr n)))
+ (list 'vconcat (cdr n)))
+ ((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)
+ (backquote-process (cdr (backquote-process (nth 1 s)))))
+ (t
+ (let ((rest s)
+ item firstlist list lists expression)
+ ;; Scan this list-level, setting LISTS to a list of forms,
+ ;; each of which produces a list of elements
+ ;; that should go in this level.
+ ;; The order of LISTS is backwards.
+ ;; If there are non-splicing elements (constant or variable)
+ ;; at the beginning, put them in FIRSTLIST,
+ ;; as a list of tagged values (TAG . FORM).
+ ;; If there are any at the end, they go in LIST, likewise.
+ (while (consp rest)
+ ;; Turn . (, foo) into (,@ foo).
+ (if (eq (car rest) backquote-unquote-symbol)
+ (setq rest (list (list backquote-splice-symbol (nth 1 rest)))))
+ (setq item (backquote-process (car rest)))
+ (cond
+ ((= (car item) 2)
+ ;; Put the nonspliced items before the first spliced item
+ ;; into FIRSTLIST.
+ (if (null lists)
+ (setq firstlist list
+ list nil))
+ ;; Otherwise, put any preceding nonspliced items into LISTS.
+ (if list
+ (setq lists (cons (backquote-listify list '(0 . nil)) lists)))
+ (setq lists (cons (cdr item) lists))
+ (setq list nil))
+ (t
+ (setq list (cons item list))))
+ (setq rest (cdr rest)))
+ ;; Handle nonsplicing final elements, and the tail of the list
+ ;; (which remains in REST).
+ (if (or rest list)
+ (setq lists (cons (backquote-listify list (backquote-process rest))
+ lists)))
+ ;; Turn LISTS into a form that produces the combined list.
+ (setq expression
+ (if (or (cdr lists)
+ (eq (car-safe (car lists)) backquote-splice-symbol))
+ (cons 'append (nreverse lists))
+ (car lists)))
+ ;; Tack on any initial elements.
+ (if firstlist
+ (setq expression (backquote-listify firstlist (cons 1 expression))))
+ (if (eq (car-safe expression) 'quote)
+ (cons 0 (list 'quote s))
+ (cons 1 expression))))))
+
+;; backquote-listify takes (tag . structure) pairs from backquote-process
+;; and decides between append, list, backquote-list*, and cons depending
+;; on which tags are in the list.
+
+(defun backquote-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* 'backquote-list* 'cons)
+ (append heads (list tail))))
+ tail))
+ (t (cons 'list heads)))))
+
+;;; backquote.el ends here
HCoop / bpt / emacs.git / blobdiff