git.chise.org Git - chise/xemacs-chise.git.1/blob - lisp/backquote.el

   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 ;; wing@666.com; 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