diff options
-rw-r--r-- | doc/ref/api-macros.texi | 71 | ||||
-rw-r--r-- | module/ice-9/local-eval.scm | 8 | ||||
-rw-r--r-- | module/ice-9/psyntax-pp.scm | 227 | ||||
-rw-r--r-- | module/ice-9/psyntax.scm | 110 | ||||
-rw-r--r-- | test-suite/tests/syntax.test | 106 |
5 files changed, 423 insertions, 99 deletions
diff --git a/doc/ref/api-macros.texi b/doc/ref/api-macros.texi index a3fa83f5a..0d604004f 100644 --- a/doc/ref/api-macros.texi +++ b/doc/ref/api-macros.texi @@ -136,7 +136,7 @@ same @var{letrec-syntax}. @code{syntax-rules} macros are simple, pattern-driven syntax transformers, with a beauty worthy of Scheme. -@deffn {Syntax} syntax-rules literals (pattern template)... +@deffn {Syntax} syntax-rules literals (pattern template) @dots{} Create a syntax transformer that will rewrite an expression using the rules embodied in the @var{pattern} and @var{template} clauses. @end deffn @@ -363,6 +363,26 @@ Cast into this form, our @code{when} example is significantly shorter: (if c (begin e ...))) @end example +@subsubsection Specifying a Custom Ellipsis Identifier + +When writing macros that generate macro definitions, it is convenient to +use a different ellipsis identifier at each level. Guile allows the +desired ellipsis identifier to be specified as the first operand to +@code{syntax-rules}, as per R7RS. For example: + +@example +(define-syntax define-quotation-macros + (syntax-rules () + ((_ (macro-name head-symbol) ...) + (begin (define-syntax macro-name + (syntax-rules ::: () + ((_ x :::) + (quote (head-symbol x :::))))) + ...)))) +(define-quotation-macros (quote-a a) (quote-b b) (quote-c c)) +(quote-a 1 2 3) @result{} (a 1 2 3) +@end example + @subsubsection Further Information For a formal definition of @code{syntax-rules} and its pattern language, see @@ -389,7 +409,7 @@ Primer for the Merely Eccentric}. @code{syntax-case} macros are procedural syntax transformers, with a power worthy of Scheme. -@deffn {Syntax} syntax-case syntax literals (pattern [guard] exp)... +@deffn {Syntax} syntax-case syntax literals (pattern [guard] exp) @dots{} Match the syntax object @var{syntax} against the given patterns, in order. If a @var{pattern} matches, return the result of evaluating the associated @var{exp}. @end deffn @@ -631,9 +651,9 @@ variable environment, and we can do so using @code{syntax-case} itself: However there are easier ways to write this. @code{with-syntax} is often convenient: -@deffn {Syntax} with-syntax ((pat val)...) exp... +@deffn {Syntax} with-syntax ((pat val) @dots{}) exp @dots{} Bind patterns @var{pat} from their corresponding values @var{val}, within the -lexical context of @var{exp...}. +lexical context of @var{exp} @enddots{}. @example ;; better @@ -681,6 +701,42 @@ edition 3 or 4, in the chapter on syntax. Dybvig was the primary author of the @code{syntax-case} system. The book itself is available online at @uref{http://scheme.com/tspl4/}. +@subsubsection Custom Ellipsis Identifiers for syntax-case Macros + +When writing procedural macros that generate macro definitions, it is +convenient to use a different ellipsis identifier at each level. Guile +supports this for procedural macros using the @code{with-ellipsis} +special form: + +@deffn {Syntax} with-ellipsis ellipsis body @dots{} +@var{ellipsis} must be an identifier. Evaluate @var{body} in a special +lexical environment such that all macro patterns and templates within +@var{body} will use @var{ellipsis} as the ellipsis identifier instead of +the usual three dots (@code{...}). +@end deffn + +For example: + +@example +(define-syntax define-quotation-macros + (lambda (x) + (syntax-case x () + ((_ (macro-name head-symbol) ...) + #'(begin (define-syntax macro-name + (lambda (x) + (with-ellipsis ::: + (syntax-case x () + ((_ x :::) + #'(quote (head-symbol x :::))))))) + ...))))) +(define-quotation-macros (quote-a a) (quote-b b) (quote-c c)) +(quote-a 1 2 3) @result{} (a 1 2 3) +@end example + +Note that @code{with-ellipsis} does not affect the ellipsis identifier +of the generated code, unless @code{with-ellipsis} is included around +the generated code. + @node Syntax Transformer Helpers @subsection Syntax Transformer Helpers @@ -740,8 +796,11 @@ of @code{eq?}) identifying this binding. A syntax transformer, either local or global. The value is the transformer procedure. @item pattern-variable -A pattern variable, bound via syntax-case. The value is an opaque -object, internal to the expander. +A pattern variable, bound via @code{syntax-case}. The value is an +opaque object, internal to the expander. +@item ellipsis +An internal binding, bound via @code{with-ellipsis}. The value is the +(anti-marked) local ellipsis identifier. @item displaced-lexical A lexical variable that has gone out of scope. This can happen if a badly-written procedural macro saves a syntax object, then attempts to diff --git a/module/ice-9/local-eval.scm b/module/ice-9/local-eval.scm index 28f30b991..bd3588bc3 100644 --- a/module/ice-9/local-eval.scm +++ b/module/ice-9/local-eval.scm @@ -1,6 +1,6 @@ ;;; -*- mode: scheme; coding: utf-8; -*- ;;; -;;; Copyright (C) 2012 Free Software Foundation, Inc. +;;; Copyright (C) 2012, 2013 Free Software Foundation, Inc. ;;; ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Lesser General Public @@ -179,6 +179,12 @@ (cdr val) t) patterns)))) + ((ellipsis) + (lp ids capture formals + (cons (lambda (x) + #`(with-ellipsis #,val #,x)) + wrappers) + patterns)) (else (error "what" type val)))))))))) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index 98a106e53..36cf45c1c 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -285,7 +285,7 @@ (if (null? r) '() (let ((a (car r))) - (if (eq? (cadr a) 'macro) + (if (memq (cadr a) '(macro ellipsis)) (cons a (macros-only-env (cdr r))) (macros-only-env (cdr r))))))) (lookup @@ -1098,9 +1098,17 @@ (syntax-violation #f "nonprocedure transformer" p))))) (expand-void (lambda () (build-void #f))) (ellipsis? - (lambda (x) - (and (nonsymbol-id? x) - (free-id=? x '#(syntax-object ... ((top)) (hygiene guile)))))) + (lambda (e r mod) + (and (nonsymbol-id? e) + (let* ((id (make-syntax-object + '#{ $sc-ellipsis }# + (syntax-object-wrap e) + (syntax-object-module e))) + (n (id-var-name id '(()))) + (b (lookup n r mod))) + (if (eq? (car b) 'ellipsis) + (bound-id=? e (cdr b)) + (free-id=? e '#(syntax-object ... ((top)) (hygiene guile)))))))) (lambda-formals (lambda (orig-args) (letrec* @@ -1569,14 +1577,15 @@ (let ((var.lev (cdr b))) (gen-ref src (car var.lev) (cdr var.lev) maps))) (lambda (var maps) (values (list 'ref var) maps)))) - ((ellipsis? e) (syntax-violation 'syntax "misplaced ellipsis" src)) + ((ellipsis? e r mod) + (syntax-violation 'syntax "misplaced ellipsis" src)) (else (values (list 'quote e) maps)))) (let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(any any)))) - (if (and tmp-1 (apply (lambda (dots e) (ellipsis? dots)) tmp-1)) - (apply (lambda (dots e) (gen-syntax src e r maps (lambda (x) #f) mod)) + (if (and tmp-1 (apply (lambda (dots e) (ellipsis? dots r mod)) tmp-1)) + (apply (lambda (dots e) (gen-syntax src e r maps (lambda (e r mod) #f) mod)) tmp-1) (let ((tmp-1 ($sc-dispatch tmp '(any any . any)))) - (if (and tmp-1 (apply (lambda (x dots y) (ellipsis? dots)) tmp-1)) + (if (and tmp-1 (apply (lambda (x dots y) (ellipsis? dots r mod)) tmp-1)) (apply (lambda (x dots y) (let f ((y y) (k (lambda (maps) @@ -1587,7 +1596,7 @@ (syntax-violation 'syntax "extra ellipsis" src) (values (gen-map x (car maps)) (cdr maps)))))))) (let* ((tmp y) (tmp ($sc-dispatch tmp '(any . any)))) - (if (and tmp (apply (lambda (dots y) (ellipsis? dots)) tmp)) + (if (and tmp (apply (lambda (dots y) (ellipsis? dots r mod)) tmp)) (apply (lambda (dots y) (f y (lambda (maps) @@ -1812,6 +1821,30 @@ (syntax-violation 'case-lambda "bad case-lambda*" e)))))))) (global-extend 'core + 'with-ellipsis + (lambda (e r w s mod) + (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ any any . each-any)))) + (if (and tmp (apply (lambda (dots e1 e2) (id? dots)) tmp)) + (apply (lambda (dots e1 e2) + (let ((id (if (symbol? dots) + '#{ $sc-ellipsis }# + (make-syntax-object + '#{ $sc-ellipsis }# + (syntax-object-wrap dots) + (syntax-object-module dots))))) + (let ((ids (list id)) + (labels (list (gen-label))) + (bindings (list (cons 'ellipsis (source-wrap dots w s mod))))) + (let ((nw (make-binding-wrap ids labels w)) + (nr (extend-env labels bindings r))) + (expand-body (cons e1 e2) (source-wrap e nw s mod) nr nw mod))))) + tmp) + (syntax-violation + 'with-ellipsis + "bad syntax" + (source-wrap e w s mod)))))) + (global-extend + 'core 'let (letrec* ((expand-let @@ -2071,7 +2104,7 @@ 'syntax-case (letrec* ((convert-pattern - (lambda (pattern keys) + (lambda (pattern keys ellipsis?) (letrec* ((cvt* (lambda (p* n ids) (let* ((tmp p*) (tmp ($sc-dispatch tmp '(any . any)))) @@ -2165,9 +2198,10 @@ (gen-clause (lambda (x keys clauses r pat fender exp mod) (call-with-values - (lambda () (convert-pattern pat keys)) + (lambda () + (convert-pattern pat keys (lambda (e) (ellipsis? e r mod)))) (lambda (p pvars) - (cond ((not (and-map (lambda (x) (not (ellipsis? (car x)))) pvars)) + (cond ((not (and-map (lambda (x) (not (ellipsis? (car x) r mod))) pvars)) (syntax-violation 'syntax-case "misplaced ellipsis" pat)) ((not (distinct-bound-ids? (map car pvars))) (syntax-violation 'syntax-case "duplicate pattern variable" pat)) @@ -2247,7 +2281,7 @@ (tmp ($sc-dispatch tmp-1 '(_ any each-any . each-any)))) (if tmp (apply (lambda (val key m) - (if (and-map (lambda (x) (and (id? x) (not (ellipsis? x)))) key) + (if (and-map (lambda (x) (and (id? x) (not (ellipsis? x r mod)))) key) (let ((x (gen-var 'tmp))) (build-application s @@ -2363,6 +2397,13 @@ ((memv key '(syntax)) (values 'pattern-variable value)) ((memv key '(displaced-lexical)) (values 'displaced-lexical #f)) ((memv key '(global)) (values 'global (cons value (cdr mod)))) + ((memv key '(ellipsis)) + (values + 'ellipsis + (make-syntax-object + (syntax-object-expression value) + (anti-mark (syntax-object-wrap value)) + (syntax-object-module value)))) (else (values 'other #f))))))))))) (syntax-locally-bound-identifiers (lambda (id) @@ -2549,56 +2590,116 @@ 'syntax-rules 'macro (lambda (xx) - (let ((tmp-1 xx)) - (let ((tmp ($sc-dispatch tmp-1 '(_ each-any . #(each ((any . any) any)))))) - (if tmp - (apply (lambda (k keyword pattern template) - (list '#(syntax-object lambda ((top)) (hygiene guile)) - '(#(syntax-object x ((top)) (hygiene guile))) - (vector - '(#(syntax-object macro-type ((top)) (hygiene guile)) - . - #(syntax-object syntax-rules ((top)) (hygiene guile))) - (cons '#(syntax-object patterns ((top)) (hygiene guile)) pattern)) - (cons '#(syntax-object syntax-case ((top)) (hygiene guile)) - (cons '#(syntax-object x ((top)) (hygiene guile)) - (cons k - (map (lambda (tmp-1 tmp) - (list (cons '#(syntax-object dummy ((top)) (hygiene guile)) tmp) - (list '#(syntax-object syntax ((top)) (hygiene guile)) - tmp-1))) - template - pattern)))))) - tmp) - (let ((tmp ($sc-dispatch tmp-1 '(_ each-any any . #(each ((any . any) any)))))) - (if (if tmp - (apply (lambda (k docstring keyword pattern template) - (string? (syntax->datum docstring))) - tmp) - #f) - (apply (lambda (k docstring keyword pattern template) - (list '#(syntax-object lambda ((top)) (hygiene guile)) - '(#(syntax-object x ((top)) (hygiene guile))) - docstring - (vector - '(#(syntax-object macro-type ((top)) (hygiene guile)) - . - #(syntax-object syntax-rules ((top)) (hygiene guile))) - (cons '#(syntax-object patterns ((top)) (hygiene guile)) pattern)) - (cons '#(syntax-object syntax-case ((top)) (hygiene guile)) - (cons '#(syntax-object x ((top)) (hygiene guile)) - (cons k - (map (lambda (tmp-1 tmp) - (list (cons '#(syntax-object dummy ((top)) (hygiene guile)) tmp) - (list '#(syntax-object syntax ((top)) (hygiene guile)) - tmp-1))) - template - pattern)))))) - tmp) - (syntax-violation - #f - "source expression failed to match any pattern" - tmp-1))))))))) + (letrec* + ((expand-syntax-rules + (lambda (dots keys docstrings clauses) + (let ((tmp-1 (list keys docstrings clauses))) + (let ((tmp ($sc-dispatch tmp-1 '(each-any each-any #(each ((any . any) any)))))) + (if tmp + (apply (lambda (k docstring keyword pattern template) + (let ((tmp (cons '#(syntax-object lambda ((top)) (hygiene guile)) + (cons '(#(syntax-object x ((top)) (hygiene guile))) + (append + docstring + (list (vector + '(#(syntax-object macro-type ((top)) (hygiene guile)) + . + #(syntax-object syntax-rules ((top)) (hygiene guile))) + (cons '#(syntax-object patterns ((top)) (hygiene guile)) + pattern)) + (cons '#(syntax-object syntax-case ((top)) (hygiene guile)) + (cons '#(syntax-object x ((top)) (hygiene guile)) + (cons k + (map (lambda (tmp-1 tmp) + (list (cons '#(syntax-object + dummy + ((top)) + (hygiene guile)) + tmp) + (list '#(syntax-object + syntax + ((top)) + (hygiene guile)) + tmp-1))) + template + pattern)))))))))) + (let ((form tmp)) + (if dots + (let ((tmp dots)) + (let ((dots tmp)) + (list '#(syntax-object with-ellipsis ((top)) (hygiene guile)) + dots + form))) + form)))) + tmp) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp-1))))))) + (let ((tmp xx)) + (let ((tmp-1 ($sc-dispatch tmp '(_ each-any . #(each ((any . any) any)))))) + (if tmp-1 + (apply (lambda (k keyword pattern template) + (expand-syntax-rules + #f + k + '() + (map (lambda (tmp-2 tmp-1 tmp) (list (cons tmp tmp-1) tmp-2)) + template + pattern + keyword))) + tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '(_ each-any any . #(each ((any . any) any)))))) + (if (if tmp-1 + (apply (lambda (k docstring keyword pattern template) + (string? (syntax->datum docstring))) + tmp-1) + #f) + (apply (lambda (k docstring keyword pattern template) + (expand-syntax-rules + #f + k + (list docstring) + (map (lambda (tmp-2 tmp-1 tmp) (list (cons tmp tmp-1) tmp-2)) + template + pattern + keyword))) + tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '(_ any each-any . #(each ((any . any) any)))))) + (if (if tmp-1 + (apply (lambda (dots k keyword pattern template) (identifier? dots)) + tmp-1) + #f) + (apply (lambda (dots k keyword pattern template) + (expand-syntax-rules + dots + k + '() + (map (lambda (tmp-2 tmp-1 tmp) (list (cons tmp tmp-1) tmp-2)) + template + pattern + keyword))) + tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '(_ any each-any any . #(each ((any . any) any)))))) + (if (if tmp-1 + (apply (lambda (dots k docstring keyword pattern template) + (if (identifier? dots) (string? (syntax->datum docstring)) #f)) + tmp-1) + #f) + (apply (lambda (dots k docstring keyword pattern template) + (expand-syntax-rules + dots + k + (list docstring) + (map (lambda (tmp-2 tmp-1 tmp) (list (cons tmp tmp-1) tmp-2)) + template + pattern + keyword))) + tmp-1) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp)))))))))))))) (define define-syntax-rule (make-syntax-transformer diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index 7574f5430..69d336017 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -42,6 +42,9 @@ ;;; Modified by Andy Wingo <wingo@pobox.com> according to the Git ;;; revision control logs corresponding to this file: 2009, 2010. +;;; Modified by Mark H Weaver <mhw@netris.org> according to the Git +;;; revision control logs corresponding to this file: 2012, 2013. + ;;; This code is based on "Syntax Abstraction in Scheme" ;;; by R. Kent Dybvig, Robert Hieb, and Carl Bruggeman. @@ -509,6 +512,7 @@ ;; (syntax . (<var> . <level>)) pattern variables ;; (global) assumed global variable ;; (lexical . <var>) lexical variables + ;; (ellipsis . <identifier>) custom ellipsis ;; (displaced-lexical) displaced lexicals ;; <level> ::= <nonnegative integer> ;; <var> ::= variable returned by build-lexical-var @@ -528,6 +532,9 @@ ;; a lexical variable is a lambda- or letrec-bound variable. + ;; an ellipsis binding is introduced by the 'with-ellipsis' special + ;; form. + ;; a displaced-lexical identifier is a lexical identifier removed from ;; it's scope by the return of a syntax object containing the identifier. ;; a displaced lexical can also appear when a letrec-syntax-bound @@ -569,7 +576,7 @@ (if (null? r) '() (let ((a (car r))) - (if (eq? (cadr a) 'macro) + (if (memq (cadr a) '(macro ellipsis)) (cons a (macros-only-env (cdr r))) (macros-only-env (cdr r))))))) @@ -1576,9 +1583,22 @@ (build-void no-source))) (define ellipsis? - (lambda (x) - (and (nonsymbol-id? x) - (free-id=? x #'(... ...))))) + (lambda (e r mod) + (and (nonsymbol-id? e) + ;; If there is a binding for the special identifier + ;; #{ $sc-ellipsis }# in the lexical environment of E, + ;; and if the associated binding type is 'ellipsis', + ;; then the binding's value specifies the custom ellipsis + ;; identifier within that lexical environment, and the + ;; comparison is done using 'bound-id=?'. + (let* ((id (make-syntax-object '#{ $sc-ellipsis }# + (syntax-object-wrap e) + (syntax-object-module e))) + (n (id-var-name id empty-wrap)) + (b (lookup n r mod))) + (if (eq? (binding-type b) 'ellipsis) + (bound-id=? e (binding-value b)) + (free-id=? e #'(... ...))))))) (define lambda-formals (lambda (orig-args) @@ -1903,17 +1923,17 @@ (let ((var.lev (binding-value b))) (gen-ref src (car var.lev) (cdr var.lev) maps))) (lambda (var maps) (values `(ref ,var) maps))) - (if (ellipsis? e) + (if (ellipsis? e r mod) (syntax-violation 'syntax "misplaced ellipsis" src) (values `(quote ,e) maps))))) (syntax-case e () ((dots e) - (ellipsis? #'dots) - (gen-syntax src #'e r maps (lambda (x) #f) mod)) + (ellipsis? #'dots r mod) + (gen-syntax src #'e r maps (lambda (e r mod) #f) mod)) ((x dots . y) ;; this could be about a dozen lines of code, except that we ;; choose to handle #'(x ... ...) forms - (ellipsis? #'dots) + (ellipsis? #'dots r mod) (let f ((y #'y) (k (lambda (maps) (call-with-values @@ -1928,7 +1948,7 @@ (cdr maps)))))))) (syntax-case y () ((dots . y) - (ellipsis? #'dots) + (ellipsis? #'dots r mod) (f #'y (lambda (maps) (call-with-values @@ -2121,6 +2141,25 @@ #'((args e1 e2 ...) ...))) (_ (syntax-violation 'case-lambda "bad case-lambda*" e))))) + (global-extend 'core 'with-ellipsis + (lambda (e r w s mod) + (syntax-case e () + ((_ dots e1 e2 ...) + (id? #'dots) + (let ((id (if (symbol? #'dots) + '#{ $sc-ellipsis }# + (make-syntax-object '#{ $sc-ellipsis }# + (syntax-object-wrap #'dots) + (syntax-object-module #'dots))))) + (let ((ids (list id)) + (labels (list (gen-label))) + (bindings (list (make-binding 'ellipsis (source-wrap #'dots w s mod))))) + (let ((nw (make-binding-wrap ids labels w)) + (nr (extend-env labels bindings r))) + (expand-body #'(e1 e2 ...) (source-wrap e nw s mod) nr nw mod))))) + (_ (syntax-violation 'with-ellipsis "bad syntax" + (source-wrap e w s mod)))))) + (global-extend 'core 'let (let () (define (expand-let e r w s mod constructor ids vals exps) @@ -2340,7 +2379,7 @@ (define convert-pattern ;; accepts pattern & keys ;; returns $sc-dispatch pattern & ids - (lambda (pattern keys) + (lambda (pattern keys ellipsis?) (define cvt* (lambda (p* n ids) (syntax-case p* () @@ -2429,10 +2468,10 @@ (define gen-clause (lambda (x keys clauses r pat fender exp mod) (call-with-values - (lambda () (convert-pattern pat keys)) + (lambda () (convert-pattern pat keys (lambda (e) (ellipsis? e r mod)))) (lambda (p pvars) (cond - ((not (and-map (lambda (x) (not (ellipsis? (car x)))) pvars)) + ((not (and-map (lambda (x) (not (ellipsis? (car x) r mod))) pvars)) (syntax-violation 'syntax-case "misplaced ellipsis" pat)) ((not (distinct-bound-ids? (map car pvars))) (syntax-violation 'syntax-case "duplicate pattern variable" pat)) @@ -2502,7 +2541,7 @@ (let ((e (source-wrap e w s mod))) (syntax-case e () ((_ val (key ...) m ...) - (if (and-map (lambda (x) (and (id? x) (not (ellipsis? x)))) + (if (and-map (lambda (x) (and (id? x) (not (ellipsis? x r mod)))) #'(key ...)) (let ((x (gen-var 'tmp))) ;; fat finger binding and references to temp variable x @@ -2606,6 +2645,11 @@ ((syntax) (values 'pattern-variable value)) ((displaced-lexical) (values 'displaced-lexical #f)) ((global) (values 'global (cons value (cdr mod)))) + ((ellipsis) + (values 'ellipsis + (make-syntax-object (syntax-object-expression value) + (anti-mark (syntax-object-wrap value)) + (syntax-object-module value)))) (else (values 'other #f)))))))) (define (syntax-locally-bound-identifiers id) @@ -2799,25 +2843,35 @@ (define-syntax syntax-rules (lambda (xx) + (define (expand-syntax-rules dots keys docstrings clauses) + (with-syntax + (((k ...) keys) + ((docstring ...) docstrings) + ((((keyword . pattern) template) ...) clauses)) + (with-syntax + ((form #'(lambda (x) + docstring ... ; optional docstring + #((macro-type . syntax-rules) + (patterns pattern ...)) ; embed patterns as procedure metadata + (syntax-case x (k ...) + ((dummy . pattern) #'template) + ...)))) + (if dots + (with-syntax ((dots dots)) + #'(with-ellipsis dots form)) + #'form)))) (syntax-case xx () ((_ (k ...) ((keyword . pattern) template) ...) - #'(lambda (x) - ;; embed patterns as procedure metadata - #((macro-type . syntax-rules) - (patterns pattern ...)) - (syntax-case x (k ...) - ((dummy . pattern) #'template) - ...))) + (expand-syntax-rules #f #'(k ...) #'() #'(((keyword . pattern) template) ...))) ((_ (k ...) docstring ((keyword . pattern) template) ...) (string? (syntax->datum #'docstring)) - #'(lambda (x) - ;; the same, but allow a docstring - docstring - #((macro-type . syntax-rules) - (patterns pattern ...)) - (syntax-case x (k ...) - ((dummy . pattern) #'template) - ...)))))) + (expand-syntax-rules #f #'(k ...) #'(docstring) #'(((keyword . pattern) template) ...))) + ((_ dots (k ...) ((keyword . pattern) template) ...) + (identifier? #'dots) + (expand-syntax-rules #'dots #'(k ...) #'() #'(((keyword . pattern) template) ...))) + ((_ dots (k ...) docstring ((keyword . pattern) template) ...) + (and (identifier? #'dots) (string? (syntax->datum #'docstring))) + (expand-syntax-rules #'dots #'(k ...) #'(docstring) #'(((keyword . pattern) template) ...)))))) (define-syntax define-syntax-rule (lambda (x) diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test index 6fac0ba34..c68a66a58 100644 --- a/test-suite/tests/syntax.test +++ b/test-suite/tests/syntax.test @@ -1,7 +1,7 @@ ;;;; syntax.test --- test suite for Guile's syntactic forms -*- scheme -*- ;;;; ;;;; Copyright (C) 2001, 2003, 2004, 2005, 2006, 2009, 2010, -;;;; 2011, 2012 Free Software Foundation, Inc. +;;;; 2011, 2012, 2013 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -19,6 +19,7 @@ (define-module (test-suite test-syntax) #:use-module (ice-9 regex) + #:use-module (ice-9 local-eval) #:use-module (test-suite lib)) @@ -1172,6 +1173,44 @@ (r 'outer)) #t))) +(with-test-prefix "syntax-rules" + + (pass-if-equal "custom ellipsis within normal ellipsis" + '((((a x) (a y) (a …)) + ((b x) (b y) (b …)) + ((c x) (c y) (c …))) + (((a x) (b x) (c x)) + ((a y) (b y) (c y)) + ((a …) (b …) (c …)))) + (let () + (define-syntax foo + (syntax-rules () + ((_ y ...) + (syntax-rules … () + ((_ x …) + '((((x y) ...) …) + (((x y) …) ...))))))) + (define-syntax bar (foo x y …)) + (bar a b c))) + + (pass-if-equal "normal ellipsis within custom ellipsis" + '((((a x) (a y) (a z)) + ((b x) (b y) (b z)) + ((c x) (c y) (c z))) + (((a x) (b x) (c x)) + ((a y) (b y) (c y)) + ((a z) (b z) (c z)))) + (let () + (define-syntax foo + (syntax-rules … () + ((_ y …) + (syntax-rules () + ((_ x ...) + '((((x y) …) ...) + (((x y) ...) …))))))) + (define-syntax bar (foo x y z)) + (bar a b c)))) + (with-test-prefix "syntax-case" (pass-if-syntax-error "duplicate pattern variable" @@ -1225,6 +1264,71 @@ ((x ... y ... z ...) #f))) (interaction-environment))))) +(with-test-prefix "with-ellipsis" + + (pass-if-equal "simple" + '(a 1 2 3) + (let () + (define-syntax define-quotation-macros + (lambda (x) + (syntax-case x () + ((_ (macro-name head-symbol) ...) + #'(begin (define-syntax macro-name + (lambda (x) + (with-ellipsis … + (syntax-case x () + ((_ x …) + #'(quote (head-symbol x …))))))) + ...))))) + (define-quotation-macros (quote-a a) (quote-b b)) + (quote-a 1 2 3))) + + (pass-if-equal "disables normal ellipsis" + '(a ...) + (let () + (define-syntax foo + (lambda (x) + (with-ellipsis … + (syntax-case x () + ((_) + #'(quote (a ...))))))) + (foo))) + + (pass-if-equal "doesn't affect ellipsis for generated code" + '(a b c) + (let () + (define-syntax quotation-macro + (lambda (x) + (with-ellipsis … + (syntax-case x () + ((_) + #'(lambda (x) + (syntax-case x () + ((_ x ...) + #'(quote (x ...)))))))))) + (define-syntax kwote (quotation-macro)) + (kwote a b c))) + + (pass-if-equal "propagates into syntax binders" + '(a b c) + (let () + (with-ellipsis … + (define-syntax kwote + (lambda (x) + (syntax-case x () + ((_ x …) + #'(quote (x …)))))) + (kwote a b c)))) + + (pass-if-equal "works with local-eval" + 5 + (let ((env (with-ellipsis … (the-environment)))) + (local-eval '(syntax-case #'(a b c d e) () + ((x …) + (length #'(x …)))) + env)))) + ;;; Local Variables: ;;; eval: (put 'pass-if-syntax-error 'scheme-indent-function 1) +;;; eval: (put 'with-ellipsis 'scheme-indent-function 1) ;;; End: |