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

Defining quasisyntax in terms of syntax-case



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