From 619bb46010696f232f09f124049739becfe94611 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Wed, 18 Dec 2013 18:49:37 -0500 Subject: [PATCH] psyntax: custom ellipses using 'with-ellipsis' or R7RS syntax-rules. * module/ice-9/psyntax.scm (binding-type): Update the header comment to mention the new 'ellipsis' binding type. (ellipsis?): Add 'r' and 'mod' as arguments. Search the lexical environment for an ellipsis binding, and use it. (gen-syntax): Adapt to the additional arguments of 'ellipsis?'. (with-ellipsis): New core syntax. (convert-pattern): Add unary 'ellipsis?' procedure as an argument. (gen-clause): Adapt to the additional arguments of 'ellipsis?'. Pass unary 'ellipsis?' procedure to 'convert-pattern'. (syntax-case): Adapt to the additional arguments of 'ellipsis?'. (syntax-local-binding): Support new 'ellipsis' binding type. (syntax-rules): Add support for a custom ellipsis identifier as the first operand, as per R7RS. Collect common code within new local procedure 'expand-syntax-rules'. * module/ice-9/psyntax-pp.scm: Regenerate. * module/ice-9/local-eval.scm (analyze-identifiers): Add support for 'ellipsis' binding type. * doc/ref/api-macros.texi (Syntax Rules): Add docs for R7RS custom ellipsis syntax. Use @dots{}. (Syntax Case): Add docs for 'with-ellipsis'. Use @dots{}. (Syntax Transformer Helpers): Update to include new 'ellipsis' binding type. * test-suite/tests/syntax.test: Add tests. --- doc/ref/api-macros.texi | 73 +++++++++++++- module/ice-9/local-eval.scm | 8 ++- module/ice-9/psyntax-pp.scm | 225 ++++++++++++++++++++++++++++++------------ module/ice-9/psyntax.scm | 108 +++++++++++++++----- test-suite/tests/syntax.test | 106 ++++++++++++++++++++- 5 files changed, 423 insertions(+), 97 deletions(-) diff --git a/doc/ref/api-macros.texi b/doc/ref/api-macros.texi index a3fa83f..61137f0 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,44 @@ 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 the effect of @code{with-ellipsis} does not propagate within +nested syntax binding forms such as @code{define-syntax}, +@code{let-syntax}, or @code{letrec-syntax}. It also 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 +798,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 28f30b9..bd3588b 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 f5f764b..a9015b2 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1096,9 +1096,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* @@ -1567,14 +1575,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) @@ -1585,7 +1594,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) @@ -1810,6 +1819,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 @@ -2069,7 +2102,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)))) @@ -2163,9 +2196,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)) @@ -2245,7 +2279,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 @@ -2361,6 +2395,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) @@ -2547,56 +2588,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 fa009d2..143d4c7 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -42,6 +42,9 @@ ;;; Modified by Andy Wingo according to the Git ;;; revision control logs corresponding to this file: 2009, 2010. +;;; Modified by Mark H Weaver 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 . ( . )) pattern variables ;; (global) assumed global variable ;; (lexical . ) lexical variables + ;; (ellipsis . ) custom ellipsis ;; (displaced-lexical) displaced lexicals ;; ::= ;; ::= 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 @@ -1574,9 +1581,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) @@ -1901,17 +1921,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 @@ -1926,7 +1946,7 @@ (cdr maps)))))))) (syntax-case y () ((dots . y) - (ellipsis? #'dots) + (ellipsis? #'dots r mod) (f #'y (lambda (maps) (call-with-values @@ -2119,6 +2139,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) @@ -2338,7 +2377,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* () @@ -2427,10 +2466,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)) @@ -2500,7 +2539,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 @@ -2604,6 +2643,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) @@ -2797,25 +2841,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 6fac0ba..142e2e5 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 "doesn't propagate 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: -- 1.7.5.4