xlisponly/lsp/backquot.lsp

   1 ;;; Backquote Implementation from Common Lisp
   2 ;;; Author: Guy L. Steele Jr.  Date: 27 December 1985
   3 ;;; This software is in the public domain
   4
   5
   6 ;;; TAA notes:
   7 ;;; Converted to XLISP from the CLtL book, July, 1991, by Tom Almy
   8 ;;; Expression simplification code removed.
   9
  10 ;;; Reader Macros -- already exist for ` , and ,@ that generate correct
  11 ;;;  code for this backquote implementation.
  12
  13 ;;; This implementation will execute far slower than the XLISP original,
  14 ;;; but since macros expansions can replace the original code
  15 ;;; (at least with my modified XLISP implementation)
  16 ;;; most applications will run at their full speed after the macros have
  17 ;;; been expanded once.
  18
  19
  20 (in-package :xlisp)
  21
  22 (defmacro backquote (x)
  23           (bq-process x))
  24
  25 (defun bq-process (x)
  26        (cond ((atom x) (list 'quote x))
  27              ((eq (car x) 'backquote)
  28               (bq-process (bq-process (cadr x))))
  29              ((eq (car x) 'comma) (cadr x))
  30              ((eq (car x) 'comma-at)
  31               (error ",@ after ` in ~s" (cadr x)))
  32              (t (do ((p x (cdr p))
  33                      (q '() (cons (bq-bracket (car p)) q)))
  34                     ((atom p)
  35                      (if (null p)       ;; simplify if proper list TAA MOD
  36                          (cons 'append (nreverse q))
  37                          (cons 'append
  38                                (nconc (nreverse q) (list (list 'quote p))))))
  39                     (when (eq (car p) 'comma)
  40                           (unless (null (cddr p)) (error "Malformed: ~s" p))
  41                           (return (cons 'append
  42                                         (nconc (nreverse q)
  43                                                (list (cadr p))))))
  44                     (when (eq (car p) 'comma-at)
  45                           (error "Dotted ,@ in ~s" p))
  46                     ))))
  47
  48 (defun bq-bracket (x)
  49        (cond ((atom x)
  50               (list 'list (list 'quote x)))
  51              ((eq (car x) 'comma)
  52               (list 'list (cadr x)))
  53              ((eq (car x) 'comma-at)
  54               (cadr x))
  55              (t (list 'list (bq-process x)))))
  56
  57 (setq *features* (cons :backquote *features*))