home *** CD-ROM | disk | FTP | other *** search
/ Mac Mania 2 / MacMania 2.toast / Demo's / Tools&Utilities / Programming / PowerLisp 1.1 / Library / backquote.lisp < prev    next >
Encoding:
Text File  |  1994-02-25  |  5.5 KB  |  199 lines  |  [TEXT/ROSA]
  1. ;;;
  2. ;;;        Redefine the backquote facility here to handle
  3. ;;;        nested backquotes correctly.
  4. ;;;
  5. ;;;        Code from Appendix C of Guy Steele's Common Lisp, the Language,
  6. ;;;        second edition, pp. 960-967
  7. ;;;
  8.  
  9. (provide :backquote)
  10.  
  11. ;; this gets executed before the macro version of in-package is 
  12. ;; defined
  13. (eval-when (:compile-toplevel :load-toplevel :execute)
  14.     (in-package :common-lisp)) 
  15.  
  16. (defvar *comma* (make-symbol "COMMA"))
  17. (defvar *comma-atsign* (make-symbol "COMMA-ATSIGN"))
  18. (defvar *comma-dot* (make-symbol "COMMA-DOT"))
  19. (defvar *bq-list* (make-symbol "BQ-LIST"))
  20. (defvar *bq-append* (make-symbol "BQ-APPEND"))
  21. (defvar *bq-list** (make-symbol "BQ-LIST*"))
  22. (defvar *bq-nconc* (make-symbol "BQ-NCONC"))
  23. (defvar *bq-clobberable* (make-symbol "BQ-CLOBBERABLE"))
  24. (defvar *bq-quote* (make-symbol "BQ-QUOTE"))
  25. (defvar *bq-quote-nil* (list *bq-quote* nil))
  26.  
  27. (set-macro-character #\`
  28.     #'(lambda (stream char)
  29.         (declare (ignore char))
  30.         (list 'backquote (read stream t nil t))))
  31.         
  32. (set-macro-character #\,
  33.     #'(lambda (stream char)
  34.         (declare (ignore char))
  35.             (case (peek-char nil stream t nil t)
  36.                 (#\@ (read-char stream t nil t)
  37.                     (list *comma-atsign* (read stream t nil t)))
  38.                 (#\. (read-char stream t nil t)
  39.                     (list *comma-dot* (read stream t nil t)))
  40.                 (otherwise (list *comma* (read stream t nil t))))))
  41.  
  42. (defparameter *bq-simplify* t)
  43.  
  44. (defmacro backquote (x)
  45.     (bq-completely-process x))
  46.                 
  47. (defun bq-completely-process (x)
  48.     (let ((raw-result (bq-process x)))
  49.         (bq-remove-tokens (if *bq-simplify*
  50.                             (bq-simplify raw-result)
  51.                             raw-result))))
  52.  
  53. (defun bq-process (x)
  54.     (cond ((atom x)
  55.             (list *bq-quote* x))
  56.           ((eq (car x) 'backquote)
  57.               (bq-process (bq-completely-process (cadr x))))
  58.           ((eq (car x) *comma*) (cadr x))
  59.           ((eq (car x) *comma-atsign*)
  60.               (error ",@~S after `" (cadr x)))
  61.           ((eq (car x) *comma-dot*)
  62.               (error ",.~S after `" (cadr x)))
  63.           (t (do ((p x (cdr p))
  64.                     (q '() (cons (bracket (car p)) q)))
  65.                  ((atom p)
  66.                   (cons *bq-append* 
  67.                           (nreconc q (list (list *bq-quote* p)))))
  68.                 (when (eq (car p) *comma*)
  69.                     (unless (null (cddr p)) (error "Malformed ,~S" p))
  70.                     (return (cons *bq-append*
  71.                         (nreconc q (list (cadr p))))))
  72.                 (when (eq (car p) *comma-atsign*)
  73.                     (error "Dotted ,@~S" p))
  74.                 (when (eq (car p) *comma-dot*)
  75.                     (error "Dotted ,.~S" p))))))
  76.                     
  77. (defun bracket (x)
  78.     (cond ((atom x)
  79.             (list *bq-list* (bq-process x)))
  80.           ((eq (car x) *comma*)
  81.               (list *bq-list* (cadr x)))
  82.           ((eq (car x) *comma-atsign*)
  83.               (cadr x))
  84.           ((eq (car x) *comma-dot*)
  85.               (list *bq-clobberable* (cadr x)))
  86.           (t (list *bq-list* (bq-process x)))))
  87.           
  88. (defun maptree (fn x)
  89.     (if (atom x)
  90.         (funcall fn x)
  91.         (let ((a (funcall fn (car x)))
  92.               (d (maptree fn (cdr x))))
  93.             (if (and (eql a (car x)) (eql d (cdr x)))
  94.                 x
  95.                 (cons a d)))))
  96.  
  97. (defun bq-splicing-frob (x)
  98.     (and (consp x)
  99.         (or (eq (car x) *comma-atsign*)
  100.             (eq (car x) *comma-dot*))))
  101.  
  102. (defun bq-frob (x)
  103.     (and (consp x)
  104.         (or (eq (car x) *comma*)
  105.             (eq (car x) *comma-atsign*)
  106.             (eq (car x) *comma-dot*))))
  107.  
  108. (defun bq-simplify (x)
  109.     (if (atom x)
  110.         x
  111.         (let ((x (if (eq (car x) *bq-quote*)
  112.                     x
  113.                     (maptree #'bq-simplify x))))
  114.             (if (not (eq (car x) *bq-append*))
  115.                 x
  116.                 (bq-simplify-args x)))))
  117.  
  118. (defun bq-simplify-args (x)
  119.     (do ((args (reverse (cdr x)) (cdr args))
  120.          (result
  121.             nil
  122.             (cond ((atom (car args))
  123.                    (bq-attach-append *bq-append* (car args) result))
  124.                   ((and (eq (caar args) *bq-list*)
  125.                         (notany #'bq-splicing-frob (cdar args)))
  126.                    (bq-attach-conses (cdar args) result))
  127.                   ((and (eq (caar args) *bq-list**)
  128.                         (notany #'bq-splicing-frob (cdar args)))
  129.                    (bq-attach-conses
  130.                         (reverse (cdr (reverse (cdar args))))
  131.                         (bq-attach-append *bq-append*
  132.                             (car (last (car args)))
  133.                             result)))
  134.                   ((and (eq (caar args) *bq-quote*)
  135.                         (consp (cadar args))
  136.                         (not (bq-frob (cadar args)))
  137.                         (null (cddar args)))
  138.                    (bq-attach-conses (list (list *bq-quote*
  139.                                                 (caadar args)))
  140.                                      result))
  141.                   ((eq (caar args) *bq-clobberable*)
  142.                    (bq-attach-append *bq-nconc* (cadar args) result))
  143.                   (t (bq-attach-append *bq-append* (car args) result)))))
  144.         ((null args) result)))
  145.  
  146. (defun null-or-quoted (x)
  147.     (or (null x) (and (consp x) (eq (car x) *bq-quote*))))
  148.  
  149. (defun bq-attach-append (op item result)
  150.     (cond ((and (null-or-quoted item) (null-or-quoted result))
  151.            (list *bq-quote* (append (cadr item) (cadr result))))
  152.           ((or (null result) (equal result *bq-quote-nil*))
  153.            (if (bq-splicing-frob item) (list op item) item))
  154.           ((and (consp result) (eq (car result) op))
  155.            (list* (car result) item (cdr result)))
  156.           (t (list op item result))))
  157.  
  158. (defun bq-attach-conses (items result)
  159.     (cond
  160.         ((and (every #'null-or-quoted items)
  161.               (null-or-quoted result))
  162.          (list *bq-quote* (append (mapcar #'cadr items) (cadr result))))
  163.         ((or (null result) (equal result *bq-quote-nil*))
  164.          (cons *bq-list* items))
  165.         ((and (consp result)
  166.               (or (eq (car result) *bq-list*)
  167.                   (eq (car result) *bq-list**)))
  168.          (cons (car result) (append items (cdr result))))
  169.         (t (cons *bq-list** (append items (list result))))))
  170.  
  171.  
  172. (defun bq-remove-tokens (x)
  173.     (cond
  174.         ((eq x *bq-list*) 'list)
  175.         ((eq x *bq-append*) 'append)
  176.         ((eq x *bq-nconc*) 'nconc)
  177.         ((eq x *bq-list**) 'list*)
  178.         ((eq x *bq-quote*) 'quote)
  179.         ((atom x) x)
  180.         ((eq (car x) *bq-clobberable*)
  181.          (bq-remove-tokens (cadr x)))
  182.         ((and (eq (car x) *bq-list**)
  183.             (consp (cddr x))
  184.             (null (cdddr x)))
  185.          (cons 'cons (maptree #'bq-remove-tokens (cdr x))))
  186.         (t (maptree #'bq-remove-tokens x))))
  187.  
  188.  
  189.  
  190.  
  191.  
  192.  
  193.  
  194.  
  195.  
  196.  
  197.  
  198.  
  199.