(define qq (expand-defmacro '(define-macro quasiquote (lambda (form) (let ([normal (lambda (x old) (if (eq? x old) (if (null? x) x (list 'quote x)) x))]) (normal (let qq ([x form][level 0]) (let ([qq-list (lambda (x level) (let* ([old-first (car x)] [old-second (cdr x)] [first (qq old-first level)] [second (qq old-second level)]) (if (and (eq? first old-first) (eq? second old-second)) x (list 'cons (normal first old-first) (normal second old-second)))))]) (cond [(pair? x) (let ([first (car x)]) (cond [(and (eq? first 'unquote) (list? x)) (let ([rest (cdr x)]) (if (or (not (pair? rest)) (not (null? (cdr rest)))) (raise-syntax-error 'unquote "takes exactly one expression" (list 'quasiquote form))) (if (zero? level) (car rest) (qq-list x (sub1 level))))] [(and (eq? first 'quasiquote) (list? x)) (qq-list x (add1 level))] [(and (eq? first 'unquote-splicing) (list? x)) (raise-syntax-error 'unquote-splicing "invalid context within quasiquote" (list 'quasiquote form))] [(and (pair? first) (eq? (car first) 'unquote-splicing) (list? first)) (let ([rest (cdr first)]) (if (or (not (pair? rest)) (not (null? (cdr rest)))) (raise-syntax-error 'unquote-splicing "takes exactly one expression" (list 'quasiquote form))) (let ([uqsd (car rest)] [old-l (cdr x)] [l (qq (cdr x) level)]) (if (zero? level) (let* ([l (normal l old-l)]) (list 'append uqsd l)) (let* ([restx (qq-list rest (sub1 level))]) (if (and (eq? l old-l) (eq? restx rest)) x (list 'cons (list 'cons (list 'quote 'unquote-splicing) (normal restx rest)) (normal l old-l)))))))] [else (qq-list x level)]))] [(vector? x) (let* ([l (vector->list x)] [l2 (qq l level)]) (if (eq? l l2) x (list 'list->vector l2)))] [(box? x) (let* ([v (unbox x)] [qv (qq v level)]) (if (eq? v qv) x (list 'box qv)))] [else x]))) form))))))