module/ice-9/quasisyntax.scm

   1 ;; Quasisyntax in terms of syntax-case.
   2 ;;
   3 ;; Code taken from
   4 ;; <http://www.het.brown.edu/people/andre/macros/index.html>;
   5 ;; Copyright (c) 2006 Andre van Tonder. All Rights Reserved.
   6 ;;
   7 ;; Permission is hereby granted, free of charge, to any person
   8 ;; obtaining a copy of this software and associated documentation
   9 ;; files (the "Software"), to deal in the Software without
  10 ;; restriction, including without limitation the rights to use, copy,
  11 ;; modify, merge, publish, distribute, sublicense, and/or sell copies
  12 ;; of the Software, and to permit persons to whom the Software is
  13 ;; furnished to do so, subject to the following conditions:
  14 ;;
  15 ;; The above copyright notice and this permission notice shall be
  16 ;; included in all copies or substantial portions of the Software.
  17 ;;
  18 ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  19 ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  20 ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
  21 ;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
  22 ;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
  23 ;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
  24 ;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
  25 ;; SOFTWARE.
  26
  27 ;;=========================================================
  28 ;;
  29 ;; To make nested unquote-splicing behave in a useful way,
  30 ;; the R5RS-compatible extension of quasiquote in appendix B
  31 ;; of the following paper is here ported to quasisyntax:
  32 ;;
  33 ;; Alan Bawden - Quasiquotation in Lisp
  34 ;; http://citeseer.ist.psu.edu/bawden99quasiquotation.html
  35 ;;
  36 ;; The algorithm converts a quasisyntax expression to an
  37 ;; equivalent with-syntax expression.
  38 ;; For example:
  39 ;;
  40 ;; (quasisyntax (set! #,a #,b))
  41 ;;   ==> (with-syntax ((t0 a)
  42 ;;                     (t1 b))
  43 ;;         (syntax (set! t0 t1)))
  44 ;;
  45 ;; (quasisyntax (list #,@args))
  46 ;;   ==> (with-syntax (((t ...) args))
  47 ;;         (syntax (list t ...)))
  48 ;;
  49 ;; Note that quasisyntax is expanded first, before any
  50 ;; ellipses act.  For example:
  51 ;;
  52 ;; (quasisyntax (f ((b #,a) ...))
  53 ;;   ==> (with-syntax ((t a))
  54 ;;         (syntax (f ((b t) ...))))
  55 ;;
  56 ;; so that
  57 ;;
  58 ;; (let-syntax ((test-ellipses-over-unsyntax
  59 ;;               (lambda (e)
  60 ;;                 (let ((a (syntax a)))
  61 ;;                   (with-syntax (((b ...) (syntax (1 2 3))))
  62 ;;                     (quasisyntax
  63 ;;                      (quote ((b #,a) ...))))))))
  64 ;;   (test-ellipses-over-unsyntax))
  65 ;;
  66 ;;     ==> ((1 a) (2 a) (3 a))
  67 (define-syntax quasisyntax
  68   (lambda (e)
  69
  70     ;; Expand returns a list of the form
  71     ;;    [template[t/e, ...] (replacement ...)]
  72     ;; Here template[t/e ...] denotes the original template
  73     ;; with unquoted expressions e replaced by fresh
  74     ;; variables t, followed by the appropriate ellipses
  75     ;; if e is also spliced.
  76     ;; The second part of the return value is the list of
  77     ;; replacements, each of the form (t e) if e is just
  78     ;; unquoted, or ((t ...) e) if e is also spliced.
  79     ;; This will be the list of bindings of the resulting
  80     ;; with-syntax expression.
  81
  82     (define (expand x level)
  83       (syntax-case x (quasisyntax unsyntax unsyntax-splicing)
  84         ((quasisyntax e)
  85          (with-syntax (((k _)     x) ;; original identifier must be copied
  86                        ((e* reps) (expand (syntax e) (+ level 1))))
  87            (syntax ((k e*) reps))))
  88         ((unsyntax e)
  89          (= level 0)
  90          (with-syntax (((t) (generate-temporaries '(t))))
  91            (syntax (t ((t e))))))
  92         (((unsyntax e ...) . r)
  93          (= level 0)
  94          (with-syntax (((r* (rep ...)) (expand (syntax r) 0))
  95                        ((t ...)        (generate-temporaries (syntax (e ...)))))
  96            (syntax ((t ... . r*)
  97                     ((t e) ... rep ...)))))
  98         (((unsyntax-splicing e ...) . r)
  99          (= level 0)
 100          (with-syntax (((r* (rep ...)) (expand (syntax r) 0))
 101                        ((t ...)        (generate-temporaries (syntax (e ...)))))
 102            (with-syntax ((((t ...) ...) (syntax ((t (... ...)) ...))))
 103              (syntax ((t ... ... . r*)
 104                       (((t ...) e) ... rep ...))))))
 105         ((k . r)
 106          (and (> level 0)
 107               (identifier? (syntax k))
 108               (or (free-identifier=? (syntax k) (syntax unsyntax))
 109                   (free-identifier=? (syntax k) (syntax unsyntax-splicing))))
 110          (with-syntax (((r* reps) (expand (syntax r) (- level 1))))
 111            (syntax ((k . r*) reps))))
 112         ((h . t)
 113          (with-syntax (((h* (rep1 ...)) (expand (syntax h) level))
 114                        ((t* (rep2 ...)) (expand (syntax t) level)))
 115            (syntax ((h* . t*)
 116                     (rep1 ... rep2 ...)))))
 117         (#(e ...)
 118          (with-syntax ((((e* ...) reps)
 119                         (expand (vector->list (syntax #(e ...))) level)))
 120            (syntax (#(e* ...) reps))))
 121         (other
 122          (syntax (other ())))))
 123
 124     (syntax-case e ()
 125       ((_ template)
 126        (with-syntax (((template* replacements) (expand (syntax template) 0)))
 127          (syntax
 128           (with-syntax replacements (syntax template*))))))))
 129
 130 (define-syntax unsyntax
 131   (lambda (e)
 132     (syntax-violation 'unsyntax "Invalid expression" e)))
 133
 134 (define-syntax unsyntax-splicing
 135   (lambda (e)
 136     (syntax-violation 'unsyntax "Invalid expression" e)))