diff options
Diffstat (limited to 'lisp/emacs-lisp/backquote.el')
| -rw-r--r-- | lisp/emacs-lisp/backquote.el | 525 |
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 |