@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
(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
@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
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
@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
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
;;; -*- 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
(cdr val)
t)
patterns))))
+ ((ellipsis)
+ (lp ids capture formals
+ (cons (lambda (x)
+ #`(with-ellipsis #,val #,x))
+ wrappers)
+ patterns))
(else
(error "what" type val))))))))))
(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
(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*
(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)
(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)
args)))
tmp)
(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
'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))))
(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))
(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
((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)
'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
;;; 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.
;; (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
;; 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
(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)))))))
(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)
(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
(cdr maps))))))))
(syntax-case y ()
((dots . y)
- (ellipsis? #'dots)
+ (ellipsis? #'dots r mod)
(f #'y
(lambda (maps)
(call-with-values
#'((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)
(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* ()
(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))
(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
((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)
(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)
;;;; 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
(define-module (test-suite test-syntax)
#:use-module (ice-9 regex)
+ #:use-module (ice-9 local-eval)
#:use-module (test-suite lib))
(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"
((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:
HCoop / bpt / guile.git / commitdiff