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))) 137