--- /dev/null
+;;; backquote.el --- Full backquote support for elisp. Reverse compatible too.
+
+;; Copyright (C) 1997 Free Software Foundation, Inc.
+
+;; Maintainer: XEmacs Development Team
+;; Keywords: extensions, dumped
+
+;; This file is part of XEmacs.
+
+;; XEmacs 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)
+;; any later version.
+
+;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the Free
+;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+;; 02111-1307, USA.
+
+;;; Synched up with: Not synched with FSF.
+
+;;; Commentary:
+
+;; This file is dumped with XEmacs.
+
+;; The bulk of the code is originally from CMU Common Lisp (original notice
+;; below).
+
+;; It correctly supports nested backquotes and backquoted vectors.
+
+;; Converted to work with elisp by Miles Bader <miles@cogsci.ed.ac.uk>
+
+;; Changes by Jonathan Stigelman <Stig@hackvan.com>:
+;; - Documentation added
+;; - support for old-backquote-compatibility-hook nixed because the
+;; old-backquote compatibility is now done in the reader...
+;; - nixed support for |,.| because
+;; (a) it's not in CLtl2
+;; (b) ",.foo" is the same as ". ,foo"
+;; (c) because RMS isn't interested in using this version of backquote.el
+;;
+;; ben@xemacs.org added ,. support back in:
+;; (a) yes, it is in CLtl2. Read closely on page 529.
+;; (b) RMS in 19.30 adds C support for ,. even if it's not really
+;; handled.
+;;
+;; **********************************************************************
+;; This code was written as part of the CMU Common Lisp project at
+;; Carnegie Mellon University, and has been placed in the public domain.
+;; If you want to use this code or any part of CMU Common Lisp, please contact
+;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;
+;; **********************************************************************
+;;
+;; BACKQUOTE: Code Spice Lispified by Lee Schumacher.
+;;
+;; The flags passed back by BQ-PROCESS-2 can be interpreted as follows:
+;;
+;; |`,|: [a] => a
+;; NIL: [a] => a ;the NIL flag is used only when a is NIL
+;; T: [a] => a ;the T flag is used when a is self-evaluating
+;; QUOTE: [a] => (QUOTE a)
+;; APPEND: [a] => (APPEND . a)
+;; NCONC: [a] => (NCONC . a)
+;; LIST: [a] => (LIST . a)
+;; LIST*: [a] => (LIST* . a)
+;;
+;; The flags are combined according to the following set of rules:
+;; ([a] means that a should be converted according to the previous table)
+;;
+;; \ car || otherwise | QUOTE or | |`,@| | |`,.|
+;;cdr \ || | T or NIL | |
+;;============================================================================
+;; |`,| ||LIST* ([a] [d]) |LIST* ([a] [d]) |APPEND (a [d]) |NCONC (a [d])
+;; NIL ||LIST ([a]) |QUOTE (a) |<hair> a |<hair> a
+;;QUOTE or T||LIST* ([a] [d]) |QUOTE (a . d) |APPEND (a [d]) |NCONC (a [d])
+;; APPEND ||LIST* ([a] [d]) |LIST* ([a] [d]) |APPEND (a . d) |NCONC (a [d])
+;; NCONC ||LIST* ([a] [d]) |LIST* ([a] [d]) |APPEND (a [d]) |NCONC (a . d)
+;; LIST ||LIST ([a] . d) |LIST ([a] . d) |APPEND (a [d]) |NCONC (a [d])
+;; LIST* ||LIST* ([a] . d) |LIST* ([a] . d) |APPEND (a [d]) |NCONC (a [d])
+;;
+;;<hair> involves starting over again pretending you had read ".,a)" instead
+;; of ",@a)"
+;;
+
+;; These are the forms it expects: |backquote| |`| |,| |,@| and |,.|.
+
+;;; Code:
+
+(defconst bq-backquote-marker 'backquote)
+(defconst bq-backtick-marker '\`) ; remnant of the old lossage
+(defconst bq-comma-marker '\,)
+(defconst bq-at-marker '\,@)
+(defconst bq-dot-marker '\,\.)
+
+;;; ----------------------------------------------------------------
+
+(fset '\` 'backquote)
+
+(defmacro backquote (template)
+ "Expand the internal representation of a backquoted TEMPLATE into a lisp form.
+
+The backquote character is like the quote character in that it prevents the
+template which follows it from being evaluated, except that backquote
+permits you to evaluate portions of the quoted template. A comma character
+inside TEMPLATE indicates that the following item should be evaluated. A
+comma character may be followed by an at-sign, which indicates that the form
+which follows should be evaluated and inserted and \"spliced\" into the
+template. Forms following ,@ must evaluate to lists.
+
+Here is how to use backquotes:
+ (setq p 'b
+ q '(c d e))
+ `(a ,p ,@q) -> (a b c d e)
+ `(a . b) -> (a . b)
+ `(a . ,p) -> (a . b)
+
+The XEmacs lisp reader expands lisp backquotes as it reads them.
+Examples:
+ `atom is read as (backquote atom)
+ `(a ,b ,@(c d e)) is read as (backquote (a (\\, b) (\\,\\@ (c d e))))
+ `(a . ,p) is read as (backquote (a \\, p))
+
+\(backquote TEMPLATE) is a macro that produces code to construct TEMPLATE.
+Note that this is very slow in interpreted code, but fast if you compile.
+TEMPLATE is one or more nested lists or vectors, which are `almost quoted'.
+They are copied recursively, with elements preceded by comma evaluated.
+ (backquote (a b)) == (list 'a 'b)
+ (backquote (a [b c])) == (list 'a (vector 'b 'c))
+
+However, certain special lists are not copied. They specify substitution.
+Lists that look like (\\, EXP) are evaluated and the result is substituted.
+ (backquote (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'.
+
+Elements of the form (\\,\\. EXP) are evaluated and then all the elements
+of the result are concatenated to the list of preceding elements in the list.
+They must occur as the last element of a list (not a vector).
+EXP may evaluate to 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)))
+
+For backwards compatibility, old-style emacs-lisp backquotes are still read.
+ OLD STYLE NEW STYLE
+ (` (foo (, bar) (,@ bing))) `(foo ,bar ,@bing)
+
+Because of the old-style backquote support, you cannot use a new-style
+backquoted form as the first element of a list. Perhaps some day this
+restriction will go away, but for now you should be wary of it:
+ (`(this ,will ,@fail))
+ ((` (but (, this) will (,@ work))))
+This is an extremely rare thing to need to do in lisp."
+ (bq-process template))
+
+;;; ----------------------------------------------------------------
+
+(defconst bq-comma-flag 'unquote)
+(defconst bq-at-flag 'unquote-splicing)
+(defconst bq-dot-flag 'unquote-nconc-splicing)
+
+(defun bq-process (form)
+ (let* ((flag-result (bq-process-2 form))
+ (flag (car flag-result))
+ (result (cdr flag-result)))
+ (cond ((eq flag bq-at-flag)
+ (error ",@ after ` in form: %s" form))
+ ((eq flag bq-dot-flag)
+ (error ",. after ` in form: %s" form))
+ (t
+ (bq-process-1 flag result)))))
+
+;;; ----------------------------------------------------------------
+
+(defun bq-vector-contents (vec)
+ (let ((contents nil)
+ (n (length vec)))
+ (while (> n 0)
+ (setq n (1- n))
+ (setq contents (cons (aref vec n) contents)))
+ contents))
+
+;;; This does the expansion from table 2.
+(defun bq-process-2 (code)
+ (cond ((vectorp code)
+ (let* ((dflag-d
+ (bq-process-2 (bq-vector-contents code))))
+ (cons 'vector (bq-process-1 (car dflag-d) (cdr dflag-d)))))
+ ((atom code)
+ (cond ((null code) (cons nil nil))
+ ((or (numberp code) (eq code t))
+ (cons t code))
+ (t (cons 'quote code))))
+ ((eq (car code) bq-at-marker)
+ (cons bq-at-flag (nth 1 code)))
+ ((eq (car code) bq-dot-marker)
+ (cons bq-dot-flag (nth 1 code)))
+ ((eq (car code) bq-comma-marker)
+ (bq-comma (nth 1 code)))
+ ((or (eq (car code) bq-backquote-marker)
+ (eq (car code) bq-backtick-marker)) ; old lossage
+ (bq-process-2 (bq-process (nth 1 code))))
+ (t (let* ((aflag-a (bq-process-2 (car code)))
+ (aflag (car aflag-a))
+ (a (cdr aflag-a)))
+ (let* ((dflag-d (bq-process-2 (cdr code)))
+ (dflag (car dflag-d))
+ (d (cdr dflag-d)))
+ (if (eq dflag bq-at-flag)
+ ;; get the errors later.
+ (error ",@ after dot in %s" code))
+ (if (eq dflag bq-dot-flag)
+ (error ",. after dot in %s" code))
+ (cond
+ ((eq aflag bq-at-flag)
+ (if (null dflag)
+ (bq-comma a)
+ (cons 'append
+ (cond ((eq dflag 'append)
+ (cons a d ))
+ (t (list a (bq-process-1 dflag d)))))))
+ ((eq aflag bq-dot-flag)
+ (if (null dflag)
+ (bq-comma a)
+ (cons 'nconc
+ (cond ((eq dflag 'nconc)
+ (cons a d))
+ (t (list a (bq-process-1 dflag d)))))))
+ ((null dflag)
+ (if (memq aflag '(quote t nil))
+ (cons 'quote (list a))
+ (cons 'list (list (bq-process-1 aflag a)))))
+ ((memq dflag '(quote t))
+ (if (memq aflag '(quote t nil))
+ (cons 'quote (cons a d ))
+ (cons 'list* (list (bq-process-1 aflag a)
+ (bq-process-1 dflag d)))))
+ (t (setq a (bq-process-1 aflag a))
+ (if (memq dflag '(list list*))
+ (cons dflag (cons a d))
+ (cons 'list*
+ (list a (bq-process-1 dflag d)))))))))))
+
+;;; This handles the <hair> cases
+(defun bq-comma (code)
+ (cond ((atom code)
+ (cond ((null code)
+ (cons nil nil))
+ ((or (numberp code) (eq code 't))
+ (cons t code))
+ (t (cons bq-comma-flag code))))
+ ((eq (car code) 'quote)
+ (cons (car code) (car (cdr code))))
+ ((memq (car code) '(append list list* nconc))
+ (cons (car code) (cdr code)))
+ ((eq (car code) 'cons)
+ (cons 'list* (cdr code)))
+ (t (cons bq-comma-flag code))))
+
+;;; This handles table 1.
+(defun bq-process-1 (flag thing)
+ (cond ((or (eq flag bq-comma-flag)
+ (memq flag '(t nil)))
+ thing)
+ ((eq flag 'quote)
+ (list 'quote thing))
+ ((eq flag 'vector)
+ (list 'apply '(function vector) thing))
+ (t (cons (cdr
+ (assq flag
+ '((cons . cons)
+ (list* . bq-list*)
+ (list . list)
+ (append . append)
+ (nconc . nconc))))
+ thing))))
+
+;;; ----------------------------------------------------------------
+
+(defmacro bq-list* (&rest args)
+ "Return a list of its arguments with last cons a dotted pair."
+ (setq args (reverse args))
+ (let ((result (car args)))
+ (setq args (cdr args))
+ (while args
+ (setq result (list 'cons (car args) result))
+ (setq args (cdr args)))
+ result))
+
+(provide 'backquote)
+
+;;; backquote.el ends here
projects / chise / xemacs-chise.git / blobdiff