428
+ − 1 ;;; backquote.el --- Full backquote support for elisp. Reverse compatible too.
+ − 2
+ − 3 ;; Copyright (C) 1997 Free Software Foundation, Inc.
+ − 4
+ − 5 ;; Maintainer: XEmacs Development Team
+ − 6 ;; Keywords: extensions, dumped
+ − 7
+ − 8 ;; This file is part of XEmacs.
+ − 9
+ − 10 ;; XEmacs is free software; you can redistribute it and/or modify it
+ − 11 ;; under the terms of the GNU General Public License as published by
+ − 12 ;; the Free Software Foundation; either version 2, or (at your option)
+ − 13 ;; any later version.
+ − 14
+ − 15 ;; XEmacs is distributed in the hope that it will be useful, but
+ − 16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
+ − 17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ − 18 ;; General Public License for more details.
+ − 19
+ − 20 ;; You should have received a copy of the GNU General Public License
+ − 21 ;; along with XEmacs; see the file COPYING. If not, write to the Free
+ − 22 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+ − 23 ;; 02111-1307, USA.
+ − 24
+ − 25 ;;; Synched up with: Not synched with FSF.
+ − 26
+ − 27 ;;; Commentary:
+ − 28
+ − 29 ;; This file is dumped with XEmacs.
+ − 30
+ − 31 ;; The bulk of the code is originally from CMU Common Lisp (original notice
+ − 32 ;; below).
+ − 33
+ − 34 ;; It correctly supports nested backquotes and backquoted vectors.
+ − 35
+ − 36 ;; Converted to work with elisp by Miles Bader <miles@cogsci.ed.ac.uk>
+ − 37
+ − 38 ;; Changes by Jonathan Stigelman <Stig@hackvan.com>:
+ − 39 ;; - Documentation added
+ − 40 ;; - support for old-backquote-compatibility-hook nixed because the
+ − 41 ;; old-backquote compatibility is now done in the reader...
+ − 42 ;; - nixed support for |,.| because
+ − 43 ;; (a) it's not in CLtl2
+ − 44 ;; (b) ",.foo" is the same as ". ,foo"
+ − 45 ;; (c) because RMS isn't interested in using this version of backquote.el
+ − 46 ;;
+ − 47 ;; ben@xemacs.org added ,. support back in:
+ − 48 ;; (a) yes, it is in CLtl2. Read closely on page 529.
+ − 49 ;; (b) RMS in 19.30 adds C support for ,. even if it's not really
+ − 50 ;; handled.
+ − 51 ;;
+ − 52 ;; **********************************************************************
+ − 53 ;; This code was written as part of the CMU Common Lisp project at
+ − 54 ;; Carnegie Mellon University, and has been placed in the public domain.
+ − 55 ;; If you want to use this code or any part of CMU Common Lisp, please contact
+ − 56 ;; Scott Fahlman or slisp-group@cs.cmu.edu.
+ − 57 ;;
+ − 58 ;; **********************************************************************
+ − 59 ;;
+ − 60 ;; BACKQUOTE: Code Spice Lispified by Lee Schumacher.
+ − 61 ;;
+ − 62 ;; The flags passed back by BQ-PROCESS-2 can be interpreted as follows:
+ − 63 ;;
+ − 64 ;; |`,|: [a] => a
+ − 65 ;; NIL: [a] => a ;the NIL flag is used only when a is NIL
+ − 66 ;; T: [a] => a ;the T flag is used when a is self-evaluating
+ − 67 ;; QUOTE: [a] => (QUOTE a)
+ − 68 ;; APPEND: [a] => (APPEND . a)
+ − 69 ;; NCONC: [a] => (NCONC . a)
+ − 70 ;; LIST: [a] => (LIST . a)
+ − 71 ;; LIST*: [a] => (LIST* . a)
+ − 72 ;;
+ − 73 ;; The flags are combined according to the following set of rules:
+ − 74 ;; ([a] means that a should be converted according to the previous table)
+ − 75 ;;
+ − 76 ;; \ car || otherwise | QUOTE or | |`,@| | |`,.|
+ − 77 ;;cdr \ || | T or NIL | |
+ − 78 ;;============================================================================
+ − 79 ;; |`,| ||LIST* ([a] [d]) |LIST* ([a] [d]) |APPEND (a [d]) |NCONC (a [d])
+ − 80 ;; NIL ||LIST ([a]) |QUOTE (a) |<hair> a |<hair> a
+ − 81 ;;QUOTE or T||LIST* ([a] [d]) |QUOTE (a . d) |APPEND (a [d]) |NCONC (a [d])
+ − 82 ;; APPEND ||LIST* ([a] [d]) |LIST* ([a] [d]) |APPEND (a . d) |NCONC (a [d])
+ − 83 ;; NCONC ||LIST* ([a] [d]) |LIST* ([a] [d]) |APPEND (a [d]) |NCONC (a . d)
+ − 84 ;; LIST ||LIST ([a] . d) |LIST ([a] . d) |APPEND (a [d]) |NCONC (a [d])
+ − 85 ;; LIST* ||LIST* ([a] . d) |LIST* ([a] . d) |APPEND (a [d]) |NCONC (a [d])
+ − 86 ;;
+ − 87 ;;<hair> involves starting over again pretending you had read ".,a)" instead
+ − 88 ;; of ",@a)"
+ − 89 ;;
+ − 90
+ − 91 ;; These are the forms it expects: |backquote| |`| |,| |,@| and |,.|.
+ − 92
+ − 93 ;;; Code:
+ − 94
+ − 95 (defconst bq-backquote-marker 'backquote)
+ − 96 (defconst bq-backtick-marker '\`) ; remnant of the old lossage
+ − 97 (defconst bq-comma-marker '\,)
+ − 98 (defconst bq-at-marker '\,@)
+ − 99 (defconst bq-dot-marker '\,\.)
+ − 100
+ − 101 ;;; ----------------------------------------------------------------
+ − 102
+ − 103 (fset '\` 'backquote)
+ − 104
+ − 105 (defmacro backquote (template)
+ − 106 "Expand the internal representation of a backquoted TEMPLATE into a lisp form.
+ − 107
+ − 108 The backquote character is like the quote character in that it prevents the
+ − 109 template which follows it from being evaluated, except that backquote
+ − 110 permits you to evaluate portions of the quoted template. A comma character
+ − 111 inside TEMPLATE indicates that the following item should be evaluated. A
+ − 112 comma character may be followed by an at-sign, which indicates that the form
+ − 113 which follows should be evaluated and inserted and \"spliced\" into the
+ − 114 template. Forms following ,@ must evaluate to lists.
+ − 115
+ − 116 Here is how to use backquotes:
+ − 117 (setq p 'b
+ − 118 q '(c d e))
+ − 119 `(a ,p ,@q) -> (a b c d e)
+ − 120 `(a . b) -> (a . b)
+ − 121 `(a . ,p) -> (a . b)
+ − 122
+ − 123 The XEmacs lisp reader expands lisp backquotes as it reads them.
+ − 124 Examples:
+ − 125 `atom is read as (backquote atom)
+ − 126 `(a ,b ,@(c d e)) is read as (backquote (a (\\, b) (\\,\\@ (c d e))))
+ − 127 `(a . ,p) is read as (backquote (a \\, p))
+ − 128
+ − 129 \(backquote TEMPLATE) is a macro that produces code to construct TEMPLATE.
+ − 130 Note that this is very slow in interpreted code, but fast if you compile.
+ − 131 TEMPLATE is one or more nested lists or vectors, which are `almost quoted'.
+ − 132 They are copied recursively, with elements preceded by comma evaluated.
+ − 133 (backquote (a b)) == (list 'a 'b)
+ − 134 (backquote (a [b c])) == (list 'a (vector 'b 'c))
+ − 135
+ − 136 However, certain special lists are not copied. They specify substitution.
+ − 137 Lists that look like (\\, EXP) are evaluated and the result is substituted.
+ − 138 (backquote (a (\\, (+ x 5)))) == (list 'a (+ x 5))
+ − 139
+ − 140 Elements of the form (\\,\\@ EXP) are evaluated and then all the elements
+ − 141 of the result are substituted. This result must be a list; it may
+ − 142 be `nil'.
+ − 143
+ − 144 Elements of the form (\\,\\. EXP) are evaluated and then all the elements
+ − 145 of the result are concatenated to the list of preceding elements in the list.
+ − 146 They must occur as the last element of a list (not a vector).
+ − 147 EXP may evaluate to nil.
+ − 148
+ − 149 As an example, a simple macro `push' could be written:
+ − 150 (defmacro push (v l)
+ − 151 `(setq ,l (cons ,@(list v l))))
+ − 152 or as
+ − 153 (defmacro push (v l)
+ − 154 `(setq ,l (cons ,v ,l)))
+ − 155
+ − 156 For backwards compatibility, old-style emacs-lisp backquotes are still read.
+ − 157 OLD STYLE NEW STYLE
+ − 158 (` (foo (, bar) (,@ bing))) `(foo ,bar ,@bing)
+ − 159
+ − 160 Because of the old-style backquote support, you cannot use a new-style
+ − 161 backquoted form as the first element of a list. Perhaps some day this
+ − 162 restriction will go away, but for now you should be wary of it:
+ − 163 (`(this ,will ,@fail))
+ − 164 ((` (but (, this) will (,@ work))))
+ − 165 This is an extremely rare thing to need to do in lisp."
+ − 166 (bq-process template))
+ − 167
+ − 168 ;;; ----------------------------------------------------------------
+ − 169
+ − 170 (defconst bq-comma-flag 'unquote)
+ − 171 (defconst bq-at-flag 'unquote-splicing)
+ − 172 (defconst bq-dot-flag 'unquote-nconc-splicing)
+ − 173
+ − 174 (defun bq-process (form)
+ − 175 (let* ((flag-result (bq-process-2 form))
+ − 176 (flag (car flag-result))
+ − 177 (result (cdr flag-result)))
+ − 178 (cond ((eq flag bq-at-flag)
+ − 179 (error ",@ after ` in form: %s" form))
+ − 180 ((eq flag bq-dot-flag)
+ − 181 (error ",. after ` in form: %s" form))
+ − 182 (t
+ − 183 (bq-process-1 flag result)))))
+ − 184
+ − 185 ;;; ----------------------------------------------------------------
+ − 186
+ − 187 (defun bq-vector-contents (vec)
+ − 188 (let ((contents nil)
+ − 189 (n (length vec)))
+ − 190 (while (> n 0)
+ − 191 (setq n (1- n))
+ − 192 (setq contents (cons (aref vec n) contents)))
+ − 193 contents))
+ − 194
+ − 195 ;;; This does the expansion from table 2.
+ − 196 (defun bq-process-2 (code)
+ − 197 (cond ((vectorp code)
+ − 198 (let* ((dflag-d
+ − 199 (bq-process-2 (bq-vector-contents code))))
+ − 200 (cons 'vector (bq-process-1 (car dflag-d) (cdr dflag-d)))))
+ − 201 ((atom code)
+ − 202 (cond ((null code) (cons nil nil))
+ − 203 ((or (numberp code) (eq code t))
+ − 204 (cons t code))
+ − 205 (t (cons 'quote code))))
+ − 206 ((eq (car code) bq-at-marker)
+ − 207 (cons bq-at-flag (nth 1 code)))
+ − 208 ((eq (car code) bq-dot-marker)
+ − 209 (cons bq-dot-flag (nth 1 code)))
+ − 210 ((eq (car code) bq-comma-marker)
+ − 211 (bq-comma (nth 1 code)))
+ − 212 ((or (eq (car code) bq-backquote-marker)
+ − 213 (eq (car code) bq-backtick-marker)) ; old lossage
+ − 214 (bq-process-2 (bq-process (nth 1 code))))
+ − 215 (t (let* ((aflag-a (bq-process-2 (car code)))
+ − 216 (aflag (car aflag-a))
+ − 217 (a (cdr aflag-a)))
+ − 218 (let* ((dflag-d (bq-process-2 (cdr code)))
+ − 219 (dflag (car dflag-d))
+ − 220 (d (cdr dflag-d)))
+ − 221 (if (eq dflag bq-at-flag)
+ − 222 ;; get the errors later.
+ − 223 (error ",@ after dot in %s" code))
+ − 224 (if (eq dflag bq-dot-flag)
+ − 225 (error ",. after dot in %s" code))
+ − 226 (cond
+ − 227 ((eq aflag bq-at-flag)
+ − 228 (if (null dflag)
+ − 229 (bq-comma a)
+ − 230 (cons 'append
+ − 231 (cond ((eq dflag 'append)
+ − 232 (cons a d ))
+ − 233 (t (list a (bq-process-1 dflag d)))))))
+ − 234 ((eq aflag bq-dot-flag)
+ − 235 (if (null dflag)
+ − 236 (bq-comma a)
+ − 237 (cons 'nconc
+ − 238 (cond ((eq dflag 'nconc)
+ − 239 (cons a d))
+ − 240 (t (list a (bq-process-1 dflag d)))))))
+ − 241 ((null dflag)
+ − 242 (if (memq aflag '(quote t nil))
+ − 243 (cons 'quote (list a))
+ − 244 (cons 'list (list (bq-process-1 aflag a)))))
+ − 245 ((memq dflag '(quote t))
+ − 246 (if (memq aflag '(quote t nil))
+ − 247 (cons 'quote (cons a d ))
+ − 248 (cons 'list* (list (bq-process-1 aflag a)
+ − 249 (bq-process-1 dflag d)))))
+ − 250 (t (setq a (bq-process-1 aflag a))
+ − 251 (if (memq dflag '(list list*))
+ − 252 (cons dflag (cons a d))
+ − 253 (cons 'list*
+ − 254 (list a (bq-process-1 dflag d)))))))))))
+ − 255
+ − 256 ;;; This handles the <hair> cases
+ − 257 (defun bq-comma (code)
+ − 258 (cond ((atom code)
+ − 259 (cond ((null code)
+ − 260 (cons nil nil))
+ − 261 ((or (numberp code) (eq code 't))
+ − 262 (cons t code))
+ − 263 (t (cons bq-comma-flag code))))
+ − 264 ((eq (car code) 'quote)
+ − 265 (cons (car code) (car (cdr code))))
+ − 266 ((memq (car code) '(append list list* nconc))
+ − 267 (cons (car code) (cdr code)))
+ − 268 ((eq (car code) 'cons)
+ − 269 (cons 'list* (cdr code)))
+ − 270 (t (cons bq-comma-flag code))))
+ − 271
+ − 272 ;;; This handles table 1.
+ − 273 (defun bq-process-1 (flag thing)
+ − 274 (cond ((or (eq flag bq-comma-flag)
+ − 275 (memq flag '(t nil)))
+ − 276 thing)
+ − 277 ((eq flag 'quote)
+ − 278 (list 'quote thing))
+ − 279 ((eq flag 'vector)
+ − 280 (list 'apply '(function vector) thing))
+ − 281 (t (cons (cdr
+ − 282 (assq flag
+ − 283 '((cons . cons)
+ − 284 (list* . bq-list*)
+ − 285 (list . list)
+ − 286 (append . append)
+ − 287 (nconc . nconc))))
+ − 288 thing))))
+ − 289
+ − 290 ;;; ----------------------------------------------------------------
+ − 291
+ − 292 (defmacro bq-list* (&rest args)
+ − 293 "Return a list of its arguments with last cons a dotted pair."
+ − 294 (setq args (reverse args))
+ − 295 (let ((result (car args)))
+ − 296 (setq args (cdr args))
+ − 297 (while args
+ − 298 (setq result (list 'cons (car args) result))
+ − 299 (setq args (cdr args)))
+ − 300 result))
+ − 301
+ − 302 (provide 'backquote)
+ − 303
+ − 304 ;;; backquote.el ends here