Backquote algorithm

[Jonathan A Rees <JAR@MIT-MC.ARPA>]

    Date: 20 Nov 1985 0950-CST
    From: David Bartley <Bartley%CSL60%ti-csl.csnet at CSNET-RELAY.ARPA>

    I'd appreciate it if you'd send me a copy of your quasiquote expander.

Actually I think it'll be easier if I send it to everyone.  I hope
people who don't care about this don't mind if I clutter their mailboxes
with it.

I won't guarantee that this 100% works, but I've tested it a little.

  - Jonathan


;;; An expansion of `x or (#!quasiquote x) is obtained by calling
;;; the procedure EXPAND-QUASIQUOTE with argument x.

;;; The expansion involves only QUOTE forms and calls to LIST, APPEND,
;;; and CONS*.  CONS* is the only nonstandard procedure, and its
;;; semantics could be given by
;;;   (define (cons* x . rest)
;;;     (if (null? rest) x (cons x (apply cons* rest))))
;;; It should be pretty easy to eliminate the use of CONS*, if that's
;;; desirable.

(define (expand-quasiquote x)

  (define quasiquote-marker '#!quasiquote)
  (define unquote-marker    '#!unquote)
  (define splice-marker     '#!unquote-splice)

  (define (finalize-quasiquote mode arg)
    (cond ((eq? mode 'quote) `',arg)
	  ((eq? mode 'unquote) arg)
	  ((eq? mode 'splice)
	   (error ",@ in illegal context"
		   arg))
	  (else `(,mode ,@arg))))

  ;; The continuation argument c is passed two values, mode and arg.
  ;; These are interpreted as follows:
  ;;    mode    arg          meaning
  ;;    QUOTE   x            'x
  ;;    UNQUOTE x            x
  ;;    LIST    (x1 x2 ...)  (LIST x1 x2 ...)
  ;;    CONS*   (x1 x2 ...)  (CONS* x1 x2 ...)
  ;;    APPEND  (x1 x2 ...)  (APPEND x1 x2 ...)

  (define (descend-quasiquote x level c)
    (cond ((not (pair? x)) (c 'quote x))
	  ((interesting-to-quasiquote? x quasiquote-marker)
	   (descend-quasiquote-pair x (1+ level) c))
	  ((interesting-to-quasiquote? x unquote-marker)
	   (cond ((= level 0)
		  (c 'unquote (cadr x)))
		 (else
		  (descend-quasiquote-pair x (- level 1) c))))
	  ((interesting-to-quasiquote? x splice-marker)
	   (cond ((= level 0)
		  (c 'splice (cadr x)))
		 (else
		  (descend-quasiquote-pair x (- level 1) c))))
	  (else
	   (descend-quasiquote-pair x level c))))

  ;; It would be simple to make this generate only a correct expansion;
  ;; most of the complexity here is in order to generate an
  ;; "optimized" expansion.

  (define (descend-quasiquote-pair x level c)
    (descend-quasiquote (car x) level
      (lambda (car-mode car-arg)
	(descend-quasiquote (cdr x) level
	  (lambda (cdr-mode cdr-arg)
	    (cond ((and (eq? car-mode 'quote) (eq? cdr-mode 'quote))
		   (c 'quote x))
		  ((eq? car-mode 'splice)
		   (cond ((and (eq? cdr-mode 'quote) (null? cdr-arg))
			  (c 'unquote
			     car-arg))
			 ((eq? cdr-mode 'append)
			  (c 'append
			     (cons car-arg cdr-arg)))
			 (else
			  (c 'append
			     (list car-arg
				   (finalize-quasiquote cdr-mode cdr-arg))))))
		  ((and (eq? cdr-mode 'quote) (null? cdr-arg))
		   (c 'list
		      (list (finalize-quasiquote car-mode car-arg))))
		  ((or (eq? cdr-mode 'list) (eq? cdr-mode 'cons*))
		   (c cdr-mode
		      (cons (finalize-quasiquote car-mode car-arg)
			    cdr-arg)))
		  (else
		   (c 'cons*
		      (list (finalize-quasiquote car-mode car-arg)
			    (finalize-quasiquote cdr-mode cdr-arg))))))))))

  (define (interesting-to-quasiquote? x marker)
    (and (pair? x)
	 (eq? (car x) marker)
	 (pair? (cdr x))
	 (null? (cddr x))))

  (descend-quasiquote x 0 finalize-quasiquote))