[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

Re: Defining quasisyntax in terms of syntax-case



Apologies for the multiple postings.  I have added a number of test cases and
fixed 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