home *** CD-ROM | disk | FTP | other *** search
/ Mac-Source 1994 July / Mac-Source_July_1994.iso / Other Langs / PowerLisp 1.01 / examples / backquote.lisp < prev    next >
Encoding:
Text File  |  1992-10-23  |  2.9 KB  |  104 lines  |  [TEXT/ROSA]
  1. ;
  2. ;        Code from Appendix C of Guy Steele's Common Lisp, the Language,
  3. ;        second edition, pp. 960-967
  4. ;
  5.  
  6. (defvar *comma* (make-symbol "COMMA"))
  7. (defvar *comma-atsign* (make-symbol "COMMA-ATSIGN"))
  8. (defvar *comma-dot* (make-symbol "COMMA-DOT"))
  9. (defvar *bq-list* (make-symbol "BQ-LIST"))
  10. (defvar *bq-append* (make-symbol "BQ-APPEND"))
  11. (defvar *bq-list** (make-symbol "BQ-LIST*"))
  12. (defvar *bq-nconc* (make-symbol "BQ-NCONC"))
  13. (defvar *bq-clobberable* (make-symbol "BQ-CLOBBERABLE"))
  14. (defvar *bq-quote* (make-symbol "BQ-QUOTE"))
  15. (defvar *bq-quote-nil* (list *bq-quote* nil))
  16.  
  17. (set-macro-character #\`
  18.     #'(lambda (stream char)
  19.         (declare (ignore char))
  20.         (list 'backquote (read stream t nil t))))
  21.         
  22. (set-macro-character #\,
  23.     #'(lambda (stream char)
  24.         (declare (ignore char))
  25.             (case (peek-char nil stream t nil t)
  26.                 (#\@ (read-char stream t nil t)
  27.                     (list *comma-atsign* (read stream t nil t)))
  28.                 (#\. (read-char stream t nil t)
  29.                     (list *comma-dot* (read stream t nil t)))
  30.                 (otherwise (list *comma* (read stream t nil t))))))
  31.                 
  32. (defparameter *bq-simplify* nil)
  33.  
  34. (defmacro backquote (x)
  35.     (bq-completely-process x))
  36.  
  37. (defun bq-completely-process (x)
  38.     (let ((raw-result (bq-process x)))
  39.         (bq-remove-tokens (if *bq-simplify*
  40.                               (bq-simplify raw-result)
  41.                               raw-result))))
  42.                               
  43. (defun bq-process (x)
  44.     (cond ((atom x)
  45.             (list *bq-quote* x))
  46.           ((eq (car x) 'backquote)
  47.               (bq-process (bq-completely-process (cadr x))))
  48.           ((eq (car x) *comma*) (cadr x))
  49.           ((eq (car x) *comma-atsign*)
  50.               (error ",@~S after `" (cadr x)))
  51.           ((eq (car x) *comma-dot*)
  52.               (error ",.~S after `" (cadr x)))
  53.           (t (do ((p x (cdr p))
  54.                     (q '() (cons (bracket (car p)) q)))
  55.                  ((atom p)
  56.                   (cons *bq-append* 
  57.                           (nreconc q (list (list *bq-quote* p)))))
  58.                 (when (eq (car p) *comma*)
  59.                     (unless (null (cddr p)) (error "Malformed ,~S" p))
  60.                     (return (cons *bq-append*
  61.                         (nreconc q (list (cadr p))))))
  62.                 (when (eq (car p) *comma-atsign*)
  63.                     (error "Dotted ,@~S" p))
  64.                 (when (eq (car p) *comma-dot*)
  65.                     (error "Dotted ,.~S" p))))))
  66.                     
  67. (defun bracket (x)
  68.     (cond ((atom x)
  69.             (list *bq-list* (bq-process x)))
  70.           ((eq (car x) *comma*)
  71.               (list *bq-list* (cadr x)))
  72.           ((eq (car x) *comma-atsign*)
  73.               (cadr x))
  74.           ((eq (car x) *comma-dot*)
  75.               (list *bq-clobberable* (cadr x)))
  76.           (t (list *bq-list* (bq-process x)))))
  77.           
  78. (defun maptree (fn x)
  79.     (if (atom x)
  80.         (funcall fn x)
  81.         (let ((a (funcall fn (car x)))
  82.               (d (maptree fn (cdr x))))
  83.             (if (and (eql a (car x)) (eql d (cdr x)))
  84.                 x
  85.                 (cons a d)))))
  86.                 
  87. (defun bq-remove-tokens (x)
  88.     (cond
  89.         ((eq x *bq-list*) 'list)
  90.         ((eq x *bq-append*) 'append)
  91.         ((eq x *bq-nconc*) 'nconc)
  92.         ((eq x *bq-list**) 'list*)
  93.         ((eq x *bq-quote*) 'quote)
  94.         ((atom x) x)
  95.         ((eq (car x) *bq-clobberable*)
  96.          (bq-remove-tokens (cadr x)))
  97.         ((and (eq (car x) *bq-list**)
  98.             (consp (cddr x))
  99.             (null (cdddr x)))
  100.          (cons 'cons (maptree #'bq-remove-tokens (cdr x))))
  101.         (t (maptree #'bq-remove-tokens x))))
  102.         
  103.  
  104.