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