<<>>
<<;;; Quasiquote.scheme>>
<<;;; Copyright Ó 1988, 1989, 1991 by Xerox Corporation.  All rights reserved.>>
<<;;; Last changed by Pavel on June 1, 1988 6:23:26 pm PDT>>
<<;;; Michael Plass, January 20, 1989 10:48:55 pm PST>>
<<>>
<<(herald>>
<<(export scheme>>
<<quasiquote unquote unquote-splicing))>>

(export (quasiquote-expansion-function)
(define (quasiquote-expansion-function arg)
"Expansion function for quasiquote"
(qq arg 0 #f))

(define (qq arg level in-vector?)
(cond
((pair? arg)
(if (and (not in-vector?)
      (null? (cdr (last-pair arg)))
   (= (length arg) 2)
(memq (car arg) '(unquote quasiquote)))
;; This is either something like `,foo or ``foo or
;; possibly the end of `(x x . ,x) or `(x x . `x)
(if (eq? (car arg) 'unquote)
(if (zero? level)
(cadr arg)
(qq-cons '(quote unquote)
(qq (cdr arg) (- level 1) in-vector?)))
(qq-cons '(quote quasiquote)
(qq (cdr arg) (+ level 1) in-vector?)))
;; Nope, it's really a list of items
(let ((item (car arg))
   (tail (cdr arg)))
(if (and (pair? item)
      (or (eq? (car item) 'unquote-splicing)
       (and (eq? (car item) 'unquote)
         (zero? level)))
(null? (cdr (last-pair item)))
(= (length item) 2))
;; The first item in the list is something we should unquote
(case (car item)
((unquote)
(qq-cons (cadr item)
      (qq tail level in-vector?)))
((unquote-splicing)
(if (zero? level)
(qq-append (cadr item)
        (qq tail level in-vector?))
(qq-cons (qq-cons '(quote unquote-splicing)
               (qq (cdr item)
                (- level 1)
             in-vector?))
(qq tail level in-vector?)))))
;; The first item is to be treated normally
(qq-cons (qq item level in-vector?)
      (qq tail level in-vector?))))))
((vector? arg)
(qq-vector (qq (vector->list arg) level #t)))
(else
(qq-quote arg))))

(define (qq-quote value)
(kwote value))

(define (quoted? form)
(and (pair? form)
  (eq? (car form) 'quote)))

(define (qq-cons arg1 arg2)
;; Construct a call to CONS of arg1 and arg2, optimizing where possible.
(cond
;; (cons 'foo 'bar) => '(foo . bar)
((and (quoted? arg1)
   (quoted? arg2))
(qq-quote (cons (cadr arg1) (cadr arg2))))
;; (cons foo '()) => (list foo)
((equal? arg2 '(quote ()))
(list 'list arg1))
;; (cons foo (list ...)) => (list foo ...)
((and (pair? arg2)
   (eq? (car arg2) 'list))
(cons 'list (cons arg1 (cdr arg2))))
(else
(list 'cons arg1 arg2))))

(define (qq-append arg1 arg2)
;; Construct a call to APPEND of arg1 and arg2, optimizing where possible.
(cond
;; (append (cons x y) z) => (cons x (append y z))
((and (pair? arg1)
   (eq? (car arg1) 'cons))
(qq-cons (cadr arg1) (qq-append (caddr arg1) arg2)))
;; (append (list x) y) => (cons x y)
;; (append (list x . y) z) => (cons x (append (list . y) z))
((and (pair? arg1)
   (eq? (car arg1) 'list))
(if (null? (cddr arg1))
(qq-cons (cadr arg1) arg2)
(qq-cons (cadr arg1)
      (qq-append (cons 'list (cddr arg1))
              arg2))))
;; (append x (append . y)) => (append x . y)
((and (pair? arg2)
   (eq? (car arg2) 'append))
(cons 'append (cons arg1 (cdr arg2))))
;; (append x (quote ())) => x
((equal? arg2 '(quote ()))
arg1)
(else
(list 'append arg1 arg2))))

(define (qq-vector arg)
;; Construct a call to LIST->VECTOR, optimizing where possible
(if (quoted? arg)
(qq-quote (list->vector (cadr arg)))
(list 'list->vector arg)))
)

(define quasiquote
(make-syntax quasiquote-expansion-function))

(define unquote
(make-syntax
(lambda (arg)
(error "UNQUOTE appears outside of a QUASIQUOTE"))))

(define unquote-splicing
(make-syntax
(lambda (arg)
(error "UNQUOTE-SPLICING appears outside of a QUASIQUOTE"))))