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

Defining quasisyntax in terms of syntax-case

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.



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