diff options
Diffstat (limited to 'lisp/backquote.el')
| -rw-r--r-- | lisp/backquote.el | 322 |
1 files changed, 322 insertions, 0 deletions
diff --git a/lisp/backquote.el b/lisp/backquote.el new file mode 100644 index 00000000000..fa979a54079 --- /dev/null +++ b/lisp/backquote.el @@ -0,0 +1,322 @@ +;; 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) Expands to a form that will generate FORM. +FORM is `almost quoted' -- see backquote.el for a description." + (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 recipie +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)) + (setq state 'cons)) + (t (bq-push (list 'list form) tailmaker)))) + +(defun bq-evalnil (form) + (setq tailmaker (list form)) + (setq 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)))) + (setq state 'append)) + +(defun bq-splicequote (form) + (setq tailmaker (list form (list 'quote (list tailmaker)))) + (setq state 'append)) + +(defun bq-splicelist (form) + (setq tailmaker (list form (cons 'list tailmaker))) + (setq state 'append)) + +(defun bq-spliceappend (form) + (bq-push form tailmaker)) + +(defun bq-splicenil (form) + (setq state 'append) + (setq tailmaker (list form))) + + + |