Defining quasisyntax in terms of syntax-case Andre van Tonder (30 Jun 2006 02:30 UTC)
Re: Defining quasisyntax in terms of syntax-case Andre van Tonder (30 Jun 2006 11:25 UTC)
Re: Defining quasisyntax in terms of syntax-case David Feuer (30 Jun 2006 11:43 UTC)
Re: Defining quasisyntax in terms of syntax-case Andre van Tonder (30 Jun 2006 13:56 UTC)
Re: Defining quasisyntax in terms of syntax-case Andre van Tonder (30 Jun 2006 19:06 UTC)

Defining quasisyntax in terms of syntax-case Andre van Tonder 30 Jun 2006 02:30 UTC

Here is a macro that defines quasisyntax in terms of the
current SRFI.  It has been tested on the few examples
below on Petite Chez and seems to work fine.

Andre

;;;=========================================================
;;;
;;; Implementation of Quasisyntax:
;;;
;;; Requires syntax-case as described in SRFI-93.
;;; Tested on Petite Chez.
;;;
;;; Andre van Tonder
;;;
;;;=========================================================

(define-syntax quasisyntax
   (lambda (e)

     ;; Delegates handling of ellipses to native |syntax| as follows:
     ;; If a subexpression contains a level 0 unquote or unquote-splicing,
     ;; expand as one would a quasisyntax and recurse.
     ;; If not, wrap whole subexpression in a single |syntax|.

     (define (expand-quasisyntax x)

       (define (expand x level)
         (if (not (contains-unquoted? x level))
             (with-syntax ((x x))
               (syntax (syntax x)))
             (syntax-case x (quasisyntax unsyntax unsyntax-splicing)
               ((quasisyntax e)
                (with-syntax ((rest (expand (syntax e) (+ level 1))))
                  (syntax
                   (list (syntax quasisyntax) rest))))
               ((unsyntax e)
                (= level 0)
                (syntax e))
               (((unsyntax . r0) . r1)
                ( = level 0)
                (with-syntax ((rest (expand (syntax r1) 0)))
                  (syntax
                   (append (list . r0) rest))))
               (((unsyntax-splicing . r0) . r1)
                (= level 0)
                (with-syntax ((rest (expand (syntax r1) 0)))
                  (syntax
                   (append (append . r0) rest))))
               ((k . r)
                (and (> level 0)
                     (or (free-identifier=? (syntax k) (syntax unsyntax))
                         (free-identifier=? (syntax k) (syntax
unsyntax-splicing))))
                (with-syntax ((rest (expand (syntax r) (- level 1))))
                  (syntax
                   (cons (syntax k) rest))))
               ((h . t)
                (with-syntax ((head (expand (syntax h) level))
                              (tail (expand (syntax t) level)))
                  (syntax
                   (cons head tail))))
               (()
                (syntax (syntax ())))
               (id
                (identifier? (syntax id))
                (syntax (syntax id)))
               (#(e ...)
                (with-syntax ((ls (expand (vector->list (syntax #(e ...))
level))))
                  (syntax
                   (list->vector ls))))
               (_ x))))

       (expand x 0))

     ;; Checks if a subexpression contains a level 0 unquote or unquote-splicing.

     (define (contains-unquoted? x level)
       (syntax-case x (quasisyntax unsyntax unsyntax-splicing)
         ((quasisyntax e)
          (contains-unquoted? (syntax e) (+ level 1)))
         ((unsyntax e)
          (= level 0) #t)
         (((unsyntax . r0) . r1)
          (= level 0)
          #t)
         (((unsyntax-splicing . r0) . r1)
          (= level 0)
          #t)
         ((k . r)
          (and (> level 0)
               (or (free-identifier=? (syntax k) (syntax unsyntax))
                   (free-identifier=? (syntax k) (syntax unsyntax-splicing))))
          (contains-unquoted? (syntax r) (- level 1)))
         ((h . t)
          (or (contains-unquoted? (syntax h) level)
              (contains-unquoted? (syntax t) level)))
         (() #f)
         (id
          (identifier? (syntax id))
          #f)
         (#(e ...)
          (contains-unquoted? (vector->list (syntax #(e ...)) level))
          (_ #f))))

     (syntax-case e ()
       ((k template)
        (expand-quasisyntax (syntax template))))))

;;;===================================================================
;;;
;;; Some tests:
;;;
;;;===================================================================

(define-syntax swap!
   (lambda (e)
     (syntax-case e ()
       ((_ a b)
        (let ((a (syntax a))
              (b (syntax b)))
          (quasisyntax
           (let ((temp (unsyntax a)))
             (set! (unsyntax a) (unsyntax b))
             (set! (unsyntax 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))
           (unsyntax
            (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 ...)
                          (unsyntax (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 (unsyntax its) e0 e1 ...)))
            (((i e) . ies) (with-syntax ((t (car (generate-temporaries '(t)))))
                             (quasisyntax
                              (let ((t e))
                                (unsyntax
                                 (f (syntax ies)
                                    (quasisyntax ((i t)
                                                  (unsyntax-splicing
its)))))))))))))))

(let-in-order ((x 1)
                (y 2))
    (+ x y))                ;==> 3