[COMSAT: Msg of Monday, 22 December 1986 16:31-EST]

[Jonathan A Rees <JAR@AI.AI.MIT.EDU>]

Date: Thu, 25 Dec 86 21:08:55 EST
From: Communications Satellite <COMSAT at AI.AI.MIT.EDU>
To:   JAR at AI.AI.MIT.EDU
Re:   Msg of Monday, 22 December 1986 16:31-EST
Message-ID: <134306.861225@AI.AI.MIT.EDU>

FAILED: rrrs-authors at MC.LCS.MIT.EDU; Host appears to be permanently down or not accepting mail.
 Failed message follows:
-------
Date: Mon, 22 Dec 86 16:31:02 EST
From: Jonathan A Rees <JAR@AI.AI.MIT.EDU>
Subject:  New, improved quasiquote
To: bartley%home%ti-csl.csnet@RELAY.CS.NET
cc: rrrs-authors@MC.LCS.MIT.EDU
In-reply-to: Msg of Wed 17 Dec 86 16:40:28 cst from David Bartley <bartley%home%ti-csl.csnet at RELAY.CS.NET>
Message-ID: <133673.861222.JAR@AI.AI.MIT.EDU>

    Date: Wed, 17 Dec 86 16:40:28 cst
    From: David Bartley <bartley%home%ti-csl.csnet at RELAY.CS.NET>

    You mailed out a copy of your expand-quasiquote procedure at my
    request 13 months ago.  Do you have an updated version you could be
    persuaded to make public?  We never switched over to your algorithm,
    but the recent changes to the specification mean we have to rewrite
    our quasiquote handler anyway, so it would be nice to continue our
    grand tradition of "borrowing" from university sources!

I have several versions.  Here is one from which I have removed several
different optimizations.  I did this in an attempt to make the code as
simple as possible, without sacrificing too much efficiency.  Simpler
versions are possible, as are more optimal ones.  E.g. this one won't
generate (vector ...) or (list ...), but it does do maximal sharing of
constant substructure.

You can do (define (system x) x) to get this to work, although in the
Scheme implementation from which this was taken I actually make this
return a funny expression which is an absolute reference to x, so that
things like (let ((cons +)) `(,a b)) works.

- Jonathan

;;; Quasiquote

(define-rewriter 'quasiquote
  (lambda (x)
    (expand-quasiquote x 0)))

(define (expand-quasiquote x level)
  (descend-quasiquote x level finalize-quasiquote))

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

(define (descend-quasiquote x level return)
  (cond ((vector? x)
	 (descend-quasiquote-vector x level return))
	((not (pair? x))
	 (return 'quote x))
	((interesting-to-quasiquote? x 'quasiquote)
	 (descend-quasiquote-pair x (1+ level) return))
	((interesting-to-quasiquote? x 'unquote)
	 (cond ((= level 0)
		(return 'unquote (cadr x)))
	       (else
		(descend-quasiquote-pair x (- level 1) return))))
	((interesting-to-quasiquote? x 'unquote-splicing)
	 (cond ((= level 0)
		(return 'unquote-splicing (cadr x)))
	       (else
		(descend-quasiquote-pair x (- level 1) return))))
        (else
	 (descend-quasiquote-pair x level return))))

(define (descend-quasiquote-pair x level return)
  (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))
		 (return 'quote x))
		((eq? car-mode 'unquote-splicing)
		 ;; (,@mumble ...)
		 (cond ((and (eq? cdr-mode 'quote) (null? cdr-arg))
			(return 'unquote
				car-arg))
		       (else
			(return (system 'append)
				(list car-arg (finalize-quasiquote cdr-mode cdr-arg))))))
		(else
		 (return (system 'cons)
			 (list (finalize-quasiquote car-mode car-arg)
			       (finalize-quasiquote cdr-mode cdr-arg))))))))))

(define (descend-quasiquote-vector x level return)
  (descend-quasiquote (vector->list x) level
    (lambda (mode arg)
      (case mode
	((quote) (return 'quote x))
	(else (return (system 'list->vector)
		      (list (finalize-quasiquote mode arg))))))))

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