This page is part of the web mail archives of SRFI 93 from before July 7th, 2015. The new archives for SRFI 93 contain all messages, not just those from before July 7th, 2015.
Apologies for the multiple postings. I have added a number of test cases andfixed a few bugs. Here is the updated implementation. Any additional test cases are welcome.
Andre
;;;=========================================================
;;;
;;; Quasisyntax in terms of SRFI-93 syntax-case.;;;
;;; Andre van Tonder
;;;
;;;=========================================================
;;;
;;; To make nested unquote-splicing behave in a useful way,
;;; the R5RS-compatible extension of quasiquote in appendix B
;;; of the following paper is here ported to quasisyntax:
;;;
;;; Alan Bawden - Quasiquotation in Lisp
;;; http://citeseer.ist.psu.edu/bawden99quasiquotation.html
;;;
;;; The algorithm converts a quasisyntax expression to an
;;; equivalent with-syntax expression.
;;; For example:
;;;
;;; (quasisyntax (set! ,a ,b))
;;; ==> (with-syntax ((t0 a)
;;; (t1 b))
;;; (syntax (set! t0 t1)))
;;;
;;; (quasisyntax (list ,@args))
;;; ==> (with-syntax (((t ...) args))
;;; (syntax (list t ...)))
;;;
;;; Note that quasisyntax is expanded first, before any
;;; ellipses act. For example:
;;;
;;; (quasisyntax (f ((b ,a) ...))
;;; ==> (with-syntax ((t a))
;;; (syntax (f ((b t) ...))))
;;;
;;; so that
;;;
;;; (let-syntax ((test-ellipses-over-unsyntax
;;; (lambda (e)
;;; (let ((a (syntax a)))
;;; (with-syntax (((b ...) (syntax (1 2 3))))
;;; (quasisyntax
;;; (quote ((b ,a) ...))))))))
;;; (test-ellipses-over-unsyntax))
;;;
;;; ==> ((1 a) (2 a) (3 a))
(define-syntax quasisyntax
(lambda (e)
(define (expand-quasisyntax x)
;; Expand returns a syntax object of the form
;; (template[t/e, ...] (replacement ...))
;; Here template[t/e ...] denotes the original template
;; with unquoted expressions e replaced by fresh
;; variables t, followed by the appropriate ellipses
;; if e is also spliced.
;; The second part of the return value is the list of
;; replacements, each of the form (t e) if e is just
;; unquoted, or ((t ...) e) if e is also spliced.
;; This will be the list of bindings of the resulting
;; with-syntax expression.
(define (expand x level)
(syntax-case x (quasisyntax unquote unquote-splicing)
((quasisyntax e)
(with-syntax (((k _) x) ; Original must be copied
((rest bs) (expand (syntax e) (+ level 1))))
(syntax
((k rest) bs))))
((unquote e)
(= level 0)
(with-syntax (((t) (generate-temporaries '(t))))
(syntax (t ((t e))))))
(((unquote e ...) . r)
(= level 0)
(with-syntax (((rest (b ...)) (expand (syntax r) 0))
((t ...) (generate-temporaries (syntax (e
...)))))
(syntax
((t ... . rest)
((t e) ... b ...)))))
(((unquote-splicing e ...) . r)
(= level 0)
(with-syntax (((rest (b ...)) (expand (syntax r) 0))
((t ...) (generate-temporaries (syntax (e
...)))))
(with-syntax ((((t ...) ...) (syntax ((t (... ...)) ...))))
(syntax
((t ... ... . rest)
(((t ...) e) ... b ...))))))
((k . r)
(and (> level 0)
(identifier? (syntax k))
(or (free-identifier=? (syntax k) (syntax unquote))
(free-identifier=? (syntax k) (syntax unquote-splicing))))
(with-syntax (((rest bs) (expand (syntax r) (- level 1))))
(syntax
((k . rest) bs))))
((h . t)
(with-syntax (((head (b1 ...)) (expand (syntax h) level))
((tail (b2 ...)) (expand (syntax t) level)))
(syntax
((head . tail)
(b1 ... b2 ...)))))
(#(e ...)
(with-syntax ((((e* ...) bs)
(expand (vector->list (syntax #(e ...))) level)))
(syntax
(#(e* ...) bs))))
(other
(syntax (other ())))))
(with-syntax (((template bindings) (expand x 0)))
(syntax
(with-syntax bindings (syntax template)))))
(syntax-case e ()
((k template)
(expand-quasisyntax (syntax template))))))
;;;==========================================================================
;;;
;;; Tests:
;;;
;;;==========================================================================
(define-syntax swap!
(lambda (e)
(syntax-case e ()
((_ a b)
(let ((a (syntax a))
(b (syntax b)))
(quasisyntax
(let ((temp ,a))
(set! ,a ,b)
(set! ,b temp))))))))
(let ((temp 1)
(set! 2))
(swap! set! temp)
(values temp set!)) ;==> 2 1
(define-syntax case
(lambda (x)
(syntax-case x ()
((_ e c1 c2 ...)
(quasisyntax
(let ((t e))
,(let f ((c1 (syntax c1)) (cmore (syntax (c2 ...))))
(if (null? cmore)
(syntax-case c1 (else)
((else e1 e2 ...) (syntax (begin e1 e2 ...)))
(((k ...) e1 e2 ...) (syntax (if (memv t '(k ...))
(begin e1 e2 ...)))))
(syntax-case c1 ()
(((k ...) e1 e2 ...)
(quasisyntax
(if (memv t '(k ...))
(begin e1 e2 ...)
,(f (car cmore) (cdr cmore))))))))))))))
(case 'a
((b c) 'no)
((d a) 'yes))
(define-syntax let-in-order
(lambda (form)
(syntax-case form ()
((_ ((i e) ...) e0 e1 ...)
(let f ((ies (syntax ((i e) ...)))
(its (syntax ())))
(syntax-case ies ()
(() (quasisyntax (let ,its e0 e1 ...)))
(((i e) . ies) (with-syntax (((t) (generate-temporaries '(t))))
(quasisyntax
(let ((t e))
,(f (syntax ies)
(quasisyntax
((i t) ,@its)))))))))))))
(let-in-order ((x 1)
(y 2))
(+ x y)) ;==> 3
(let-syntax ((test-ellipses-over-unsyntax
(lambda (e)
(let ((a (syntax a)))
(with-syntax (((b ...) (syntax (1 2 3))))
(quasisyntax
(quote ((b ,a) ...))))))))
(test-ellipses-over-unsyntax))
;==> ((1 a) (2 a) (3 a))
;; Some tests found online (Guile?)
(let-syntax ((test
(lambda (_)
(quasisyntax
'(list ,(+ 1 2) 4)))))
(test))
;==> (list 3 4)
(let-syntax ((test
(lambda (_)
(let ((name (syntax a)))
(quasisyntax '(list ,name ',name))))))
(test))
;==> (list a 'a)
(let-syntax ((test
(lambda (_)
(quasisyntax '(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b)))))
(test))
;==> (a 3 4 5 6 b)
(let-syntax ((test
(lambda (_)
(quasisyntax '((foo ,(- 10 3)) ,@(cdr '(5)) . ,(car '(7)))))))
(test))
;==> ((foo 7) . 7)
(let-syntax ((test
(lambda (_)
(quasisyntax '#(10 5 ,(sqrt 4) ,@(map sqrt '(16 9)) 8)))))
(test))
;==> #6(10 5 2 4 3 8)
(let-syntax ((test
(lambda (_)
(quasisyntax ,(+ 2 3)))))
(test))
;==> 5
(let-syntax ((test
(lambda (_)
(quasisyntax
'(a (quasisyntax (b ,(+ 1 2) ,(foo ,(+ 1 3) d) e)) f)))))
(test))
;==> (a (quasisyntax (b ,(+ 1 2) ,(foo 4
d) e)) f)
(let-syntax ((test
(lambda (_)
(let ((name1 #'x) (name2 #'y))
(quasisyntax
'(a (quasisyntax (b ,,name1 ,#',name2 d)) e))))))
(test))
;==> (a (quasisyntax (b ,x ,#'y d)) e)
;; Bawden's extensions:
(let-syntax ((test
(lambda (_)
(quasisyntax '(a (unquote 1 2) b)))))
(test))
;==> (a 1 2 b)
(let-syntax ((test
(lambda (_)
(quasisyntax '(a (unquote-splicing '(1 2) '(3 4)) b)))))
(test))
;==> (a 1 2 3 4 b)
(let-syntax ((test
(lambda (_)
(let ((x #'(a b c)))
(quasisyntax '(quasisyntax (,,x ,@,x ,,@x ,@,@x)))))))
(test))
;==> (quasisyntax (,(a b c) ,@(a b c) (unquote a b c) (unquote-splicing
a b c)))
; which is equivalent to
; (quasisyntax (,(a b c) ,@(a b c) ,a ,b ,c ,@a ,@b ,@c)
; in the Bawden prescription