mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

psyntax: custom ellipses using 'with-ellipsis' or R7RS syntax-rules.

Browse source 
* module/ice-9/psyntax.scm (binding-type): Update the header comment
  to mention the new 'ellipsis' binding type.
  (macros-only-env): Preserve ellipsis bindings.
  (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.
This commit is contained in:
Mark H Weaver 2013-12-18 18:49:37 -05:00
parent 8de355d08e
commit 1624e149f7
5 changed files with 423 additions and 99 deletions
Download patch file Download diff file Expand all files Collapse all files

71
doc/ref/api-macros.texi
View file

@ -136,7 +136,7 @@ same @var{letrec-syntax}.
@code{syntax-rules} macros are simple, pattern-driven syntax transformers, with @code{syntax-rules} macros are simple, pattern-driven syntax transformers, with
a beauty worthy of Scheme. 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 Create a syntax transformer that will rewrite an expression using the rules
embodied in the @var{pattern} and @var{template} clauses. embodied in the @var{pattern} and @var{template} clauses.
@end deffn @end deffn
@ -363,6 +363,26 @@ Cast into this form, our @code{when} example is significantly shorter:
(if c (begin e ...))) (if c (begin e ...)))
@end example @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 @subsubsection Further Information
For a formal definition of @code{syntax-rules} and its pattern language, see 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 @code{syntax-case} macros are procedural syntax transformers, with a power
worthy of Scheme. 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 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}. @var{pattern} matches, return the result of evaluating the associated @var{exp}.
@end deffn @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 However there are easier ways to write this. @code{with-syntax} is often
convenient: 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 Bind patterns @var{pat} from their corresponding values @var{val}, within the
lexical context of @var{exp...}. lexical context of @var{exp} @enddots{}.
@example @example
;; better ;; 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 @code{syntax-case} system. The book itself is available online at
@uref{http://scheme.com/tspl4/}. @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 @node Syntax Transformer Helpers
@subsection 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 A syntax transformer, either local or global. The value is the
transformer procedure. transformer procedure.
@item pattern-variable @item pattern-variable
A pattern variable, bound via syntax-case. The value is an opaque A pattern variable, bound via @code{syntax-case}. The value is an
object, internal to the expander. 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 @item displaced-lexical
A lexical variable that has gone out of scope. This can happen if a 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 badly-written procedural macro saves a syntax object, then attempts to

8
module/ice-9/local-eval.scm
View file

@ -1,6 +1,6 @@
;;; -*- mode: scheme; coding: utf-8; -*- ;;; -*- 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 ;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public ;;; modify it under the terms of the GNU Lesser General Public
@ -179,6 +179,12 @@
(cdr val) (cdr val)
t) t)
patterns)))) patterns))))
((ellipsis)
(lp ids capture formals
(cons (lambda (x)
#`(with-ellipsis #,val #,x))
wrappers)
patterns))
(else (else
(error "what" type val)))))))))) (error "what" type val))))))))))

227
module/ice-9/psyntax-pp.scm
View file

@ -285,7 +285,7 @@
(if (null? r) (if (null? r)
'() '()
(let ((a (car r))) (let ((a (car r)))
(if (eq? (cadr a) 'macro) (if (memq (cadr a) '(macro ellipsis))
(cons a (macros-only-env (cdr r))) (cons a (macros-only-env (cdr r)))
(macros-only-env (cdr r))))))) (macros-only-env (cdr r)))))))
(lookup (lookup
@ -1098,9 +1098,17 @@
(syntax-violation #f "nonprocedure transformer" p))))) (syntax-violation #f "nonprocedure transformer" p)))))
(expand-void (lambda () (build-void #f))) (expand-void (lambda () (build-void #f)))
(ellipsis? (ellipsis?
(lambda (x) (lambda (e r mod)
(and (nonsymbol-id? x) (and (nonsymbol-id? e)
(free-id=? x '#(syntax-object ... ((top)) (hygiene guile)))))) (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-formals
(lambda (orig-args) (lambda (orig-args)
(letrec* (letrec*
@ -1569,14 +1577,15 @@
(let ((var.lev (cdr b))) (let ((var.lev (cdr b)))
(gen-ref src (car var.lev) (cdr var.lev) maps))) (gen-ref src (car var.lev) (cdr var.lev) maps)))
(lambda (var maps) (values (list 'ref var) 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)))) (else (values (list 'quote e) maps))))
(let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(any any)))) (let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(any any))))
(if (and tmp-1 (apply (lambda (dots e) (ellipsis? dots)) tmp-1)) (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 (x) #f) mod)) (apply (lambda (dots e) (gen-syntax src e r maps (lambda (e r mod) #f) mod))
tmp-1) tmp-1)
(let ((tmp-1 ($sc-dispatch tmp '(any any . any)))) (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) (apply (lambda (x dots y)
(let f ((y y) (let f ((y y)
(k (lambda (maps) (k (lambda (maps)
@ -1587,7 +1596,7 @@
(syntax-violation 'syntax "extra ellipsis" src) (syntax-violation 'syntax "extra ellipsis" src)
(values (gen-map x (car maps)) (cdr maps)))))))) (values (gen-map x (car maps)) (cdr maps))))))))
(let* ((tmp y) (tmp ($sc-dispatch tmp '(any . any)))) (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) (apply (lambda (dots y)
(f y (f y
(lambda (maps) (lambda (maps)
@ -1810,6 +1819,30 @@
args))) args)))
tmp) tmp)
(syntax-violation 'case-lambda "bad case-lambda*" e)))))))) (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 (global-extend
'core 'core
'let 'let
@ -2071,7 +2104,7 @@
'syntax-case 'syntax-case
(letrec* (letrec*
((convert-pattern ((convert-pattern
(lambda (pattern keys) (lambda (pattern keys ellipsis?)
(letrec* (letrec*
((cvt* (lambda (p* n ids) ((cvt* (lambda (p* n ids)
(let* ((tmp p*) (tmp ($sc-dispatch tmp '(any . any)))) (let* ((tmp p*) (tmp ($sc-dispatch tmp '(any . any))))
@ -2165,9 +2198,10 @@
(gen-clause (gen-clause
(lambda (x keys clauses r pat fender exp mod) (lambda (x keys clauses r pat fender exp mod)
(call-with-values (call-with-values
(lambda () (convert-pattern pat keys)) (lambda ()
(convert-pattern pat keys (lambda (e) (ellipsis? e r mod))))
(lambda (p pvars) (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)) (syntax-violation 'syntax-case "misplaced ellipsis" pat))
((not (distinct-bound-ids? (map car pvars))) ((not (distinct-bound-ids? (map car pvars)))
(syntax-violation 'syntax-case "duplicate pattern variable" pat)) (syntax-violation 'syntax-case "duplicate pattern variable" pat))
@ -2247,7 +2281,7 @@
(tmp ($sc-dispatch tmp-1 '(_ any each-any . each-any)))) (tmp ($sc-dispatch tmp-1 '(_ any each-any . each-any))))
(if tmp (if tmp
(apply (lambda (val key m) (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))) (let ((x (gen-var 'tmp)))
(build-application (build-application
s s
@ -2363,6 +2397,13 @@
((memv key '(syntax)) (values 'pattern-variable value)) ((memv key '(syntax)) (values 'pattern-variable value))
((memv key '(displaced-lexical)) (values 'displaced-lexical #f)) ((memv key '(displaced-lexical)) (values 'displaced-lexical #f))
((memv key '(global)) (values 'global (cons value (cdr mod)))) ((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))))))))))) (else (values 'other #f)))))))))))
(syntax-locally-bound-identifiers (syntax-locally-bound-identifiers
(lambda (id) (lambda (id)
@ -2549,56 +2590,116 @@
'syntax-rules 'syntax-rules
'macro 'macro
(lambda (xx) (lambda (xx)
(let ((tmp-1 xx)) (letrec*
(let ((tmp ($sc-dispatch tmp-1 '(_ each-any . #(each ((any . any) any)))))) ((expand-syntax-rules
(if tmp (lambda (dots keys docstrings clauses)
(apply (lambda (k keyword pattern template) (let ((tmp-1 (list keys docstrings clauses)))
(list '#(syntax-object lambda ((top)) (hygiene guile)) (let ((tmp ($sc-dispatch tmp-1 '(each-any each-any #(each ((any . any) any))))))
'(#(syntax-object x ((top)) (hygiene guile))) (if tmp
(vector (apply (lambda (k docstring keyword pattern template)
'(#(syntax-object macro-type ((top)) (hygiene guile)) (let ((tmp (cons '#(syntax-object lambda ((top)) (hygiene guile))
. (cons '(#(syntax-object x ((top)) (hygiene guile)))
#(syntax-object syntax-rules ((top)) (hygiene guile))) (append
(cons '#(syntax-object patterns ((top)) (hygiene guile)) pattern)) docstring
(cons '#(syntax-object syntax-case ((top)) (hygiene guile)) (list (vector
(cons '#(syntax-object x ((top)) (hygiene guile)) '(#(syntax-object macro-type ((top)) (hygiene guile))
(cons k .
(map (lambda (tmp-1 tmp) #(syntax-object syntax-rules ((top)) (hygiene guile)))
(list (cons '#(syntax-object dummy ((top)) (hygiene guile)) tmp) (cons '#(syntax-object patterns ((top)) (hygiene guile))
(list '#(syntax-object syntax ((top)) (hygiene guile)) pattern))
tmp-1))) (cons '#(syntax-object syntax-case ((top)) (hygiene guile))
template (cons '#(syntax-object x ((top)) (hygiene guile))
pattern)))))) (cons k
tmp) (map (lambda (tmp-1 tmp)
(let ((tmp ($sc-dispatch tmp-1 '(_ each-any any . #(each ((any . any) any)))))) (list (cons '#(syntax-object
(if (if tmp dummy
(apply (lambda (k docstring keyword pattern template) ((top))
(string? (syntax->datum docstring))) (hygiene guile))
tmp) tmp)
#f) (list '#(syntax-object
(apply (lambda (k docstring keyword pattern template) syntax
(list '#(syntax-object lambda ((top)) (hygiene guile)) ((top))
'(#(syntax-object x ((top)) (hygiene guile))) (hygiene guile))
docstring tmp-1)))
(vector template
'(#(syntax-object macro-type ((top)) (hygiene guile)) pattern))))))))))
. (let ((form tmp))
#(syntax-object syntax-rules ((top)) (hygiene guile))) (if dots
(cons '#(syntax-object patterns ((top)) (hygiene guile)) pattern)) (let ((tmp dots))
(cons '#(syntax-object syntax-case ((top)) (hygiene guile)) (let ((dots tmp))
(cons '#(syntax-object x ((top)) (hygiene guile)) (list '#(syntax-object with-ellipsis ((top)) (hygiene guile))
(cons k dots
(map (lambda (tmp-1 tmp) form)))
(list (cons '#(syntax-object dummy ((top)) (hygiene guile)) tmp) form))))
(list '#(syntax-object syntax ((top)) (hygiene guile)) tmp)
tmp-1))) (syntax-violation
template #f
pattern)))))) "source expression failed to match any pattern"
tmp) tmp-1)))))))
(syntax-violation (let ((tmp xx))
#f (let ((tmp-1 ($sc-dispatch tmp '(_ each-any . #(each ((any . any) any))))))
"source expression failed to match any pattern" (if tmp-1
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 (define define-syntax-rule
(make-syntax-transformer (make-syntax-transformer

110
module/ice-9/psyntax.scm
View file

@ -42,6 +42,9 @@
;;; Modified by Andy Wingo <wingo@pobox.com> according to the Git ;;; Modified by Andy Wingo <wingo@pobox.com> according to the Git
;;; revision control logs corresponding to this file: 2009, 2010. ;;; 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" ;;; This code is based on "Syntax Abstraction in Scheme"
;;; by R. Kent Dybvig, Robert Hieb, and Carl Bruggeman. ;;; by R. Kent Dybvig, Robert Hieb, and Carl Bruggeman.
@ -509,6 +512,7 @@
;; (syntax . (<var> . <level>)) pattern variables ;; (syntax . (<var> . <level>)) pattern variables
;; (global) assumed global variable ;; (global) assumed global variable
;; (lexical . <var>) lexical variables ;; (lexical . <var>) lexical variables
;; (ellipsis . <identifier>) custom ellipsis
;; (displaced-lexical) displaced lexicals ;; (displaced-lexical) displaced lexicals
;; <level> ::= <nonnegative integer> ;; <level> ::= <nonnegative integer>
;; <var> ::= variable returned by build-lexical-var ;; <var> ::= variable returned by build-lexical-var
@ -528,6 +532,9 @@
;; a lexical variable is a lambda- or letrec-bound variable. ;; 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 ;; a displaced-lexical identifier is a lexical identifier removed from
;; it's scope by the return of a syntax object containing the identifier. ;; it's scope by the return of a syntax object containing the identifier.
;; a displaced lexical can also appear when a letrec-syntax-bound ;; a displaced lexical can also appear when a letrec-syntax-bound
@ -569,7 +576,7 @@
(if (null? r) (if (null? r)
'() '()
(let ((a (car r))) (let ((a (car r)))
(if (eq? (cadr a) 'macro) (if (memq (cadr a) '(macro ellipsis))
(cons a (macros-only-env (cdr r))) (cons a (macros-only-env (cdr r)))
(macros-only-env (cdr r))))))) (macros-only-env (cdr r)))))))
@ -1576,9 +1583,22 @@
(build-void no-source))) (build-void no-source)))
(define ellipsis? (define ellipsis?
(lambda (x) (lambda (e r mod)
(and (nonsymbol-id? x) (and (nonsymbol-id? e)
(free-id=? x #'(... ...))))) ;; 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 (define lambda-formals
(lambda (orig-args) (lambda (orig-args)
@ -1903,17 +1923,17 @@
(let ((var.lev (binding-value b))) (let ((var.lev (binding-value b)))
(gen-ref src (car var.lev) (cdr var.lev) maps))) (gen-ref src (car var.lev) (cdr var.lev) maps)))
(lambda (var maps) (values `(ref ,var) maps))) (lambda (var maps) (values `(ref ,var) maps)))
(if (ellipsis? e) (if (ellipsis? e r mod)
(syntax-violation 'syntax "misplaced ellipsis" src) (syntax-violation 'syntax "misplaced ellipsis" src)
(values `(quote ,e) maps))))) (values `(quote ,e) maps)))))
(syntax-case e () (syntax-case e ()
((dots e) ((dots e)
(ellipsis? #'dots) (ellipsis? #'dots r mod)
(gen-syntax src #'e r maps (lambda (x) #f) mod)) (gen-syntax src #'e r maps (lambda (e r mod) #f) mod))
((x dots . y) ((x dots . y)
;; this could be about a dozen lines of code, except that we ;; this could be about a dozen lines of code, except that we
;; choose to handle #'(x ... ...) forms ;; choose to handle #'(x ... ...) forms
(ellipsis? #'dots) (ellipsis? #'dots r mod)
(let f ((y #'y) (let f ((y #'y)
(k (lambda (maps) (k (lambda (maps)
(call-with-values (call-with-values
@ -1928,7 +1948,7 @@
(cdr maps)))))))) (cdr maps))))))))
(syntax-case y () (syntax-case y ()
((dots . y) ((dots . y)
(ellipsis? #'dots) (ellipsis? #'dots r mod)
(f #'y (f #'y
(lambda (maps) (lambda (maps)
(call-with-values (call-with-values
@ -2121,6 +2141,25 @@
#'((args e1 e2 ...) ...))) #'((args e1 e2 ...) ...)))
(_ (syntax-violation 'case-lambda "bad case-lambda*" e))))) (_ (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 (global-extend 'core 'let
(let () (let ()
(define (expand-let e r w s mod constructor ids vals exps) (define (expand-let e r w s mod constructor ids vals exps)
@ -2340,7 +2379,7 @@
(define convert-pattern (define convert-pattern
;; accepts pattern & keys ;; accepts pattern & keys
;; returns $sc-dispatch pattern & ids ;; returns $sc-dispatch pattern & ids
(lambda (pattern keys) (lambda (pattern keys ellipsis?)
(define cvt* (define cvt*
(lambda (p* n ids) (lambda (p* n ids)
(syntax-case p* () (syntax-case p* ()
@ -2429,10 +2468,10 @@
(define gen-clause (define gen-clause
(lambda (x keys clauses r pat fender exp mod) (lambda (x keys clauses r pat fender exp mod)
(call-with-values (call-with-values
(lambda () (convert-pattern pat keys)) (lambda () (convert-pattern pat keys (lambda (e) (ellipsis? e r mod))))
(lambda (p pvars) (lambda (p pvars)
(cond (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)) (syntax-violation 'syntax-case "misplaced ellipsis" pat))
((not (distinct-bound-ids? (map car pvars))) ((not (distinct-bound-ids? (map car pvars)))
(syntax-violation 'syntax-case "duplicate pattern variable" pat)) (syntax-violation 'syntax-case "duplicate pattern variable" pat))
@ -2502,7 +2541,7 @@
(let ((e (source-wrap e w s mod))) (let ((e (source-wrap e w s mod)))
(syntax-case e () (syntax-case e ()
((_ val (key ...) m ...) ((_ 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 ...)) #'(key ...))
(let ((x (gen-var 'tmp))) (let ((x (gen-var 'tmp)))
;; fat finger binding and references to temp variable x ;; fat finger binding and references to temp variable x
@ -2606,6 +2645,11 @@
((syntax) (values 'pattern-variable value)) ((syntax) (values 'pattern-variable value))
((displaced-lexical) (values 'displaced-lexical #f)) ((displaced-lexical) (values 'displaced-lexical #f))
((global) (values 'global (cons value (cdr mod)))) ((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)))))))) (else (values 'other #f))))))))
(define (syntax-locally-bound-identifiers id) (define (syntax-locally-bound-identifiers id)
@ -2799,25 +2843,35 @@
(define-syntax syntax-rules (define-syntax syntax-rules
(lambda (xx) (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 () (syntax-case xx ()
((_ (k ...) ((keyword . pattern) template) ...) ((_ (k ...) ((keyword . pattern) template) ...)
#'(lambda (x) (expand-syntax-rules #f #'(k ...) #'() #'(((keyword . pattern) template) ...)))
;; embed patterns as procedure metadata
#((macro-type . syntax-rules)
(patterns pattern ...))
(syntax-case x (k ...)
((dummy . pattern) #'template)
...)))
((_ (k ...) docstring ((keyword . pattern) template) ...) ((_ (k ...) docstring ((keyword . pattern) template) ...)
(string? (syntax->datum #'docstring)) (string? (syntax->datum #'docstring))
#'(lambda (x) (expand-syntax-rules #f #'(k ...) #'(docstring) #'(((keyword . pattern) template) ...)))
;; the same, but allow a docstring ((_ dots (k ...) ((keyword . pattern) template) ...)
docstring (identifier? #'dots)
#((macro-type . syntax-rules) (expand-syntax-rules #'dots #'(k ...) #'() #'(((keyword . pattern) template) ...)))
(patterns pattern ...)) ((_ dots (k ...) docstring ((keyword . pattern) template) ...)
(syntax-case x (k ...) (and (identifier? #'dots) (string? (syntax->datum #'docstring)))
((dummy . pattern) #'template) (expand-syntax-rules #'dots #'(k ...) #'(docstring) #'(((keyword . pattern) template) ...))))))
...))))))
(define-syntax define-syntax-rule (define-syntax define-syntax-rule
(lambda (x) (lambda (x)

106
test-suite/tests/syntax.test
View file

@ -1,7 +1,7 @@
;;;; syntax.test --- test suite for Guile's syntactic forms -*- scheme -*- ;;;; syntax.test --- test suite for Guile's syntactic forms -*- scheme -*-
;;;; ;;;;
;;;; Copyright (C) 2001, 2003, 2004, 2005, 2006, 2009, 2010, ;;;; 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 ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -19,6 +19,7 @@
(define-module (test-suite test-syntax) (define-module (test-suite test-syntax)
#:use-module (ice-9 regex) #:use-module (ice-9 regex)
#:use-module (ice-9 local-eval)
#:use-module (test-suite lib)) #:use-module (test-suite lib))
@ -1172,6 +1173,44 @@
(r 'outer)) (r 'outer))
#t))) #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" (with-test-prefix "syntax-case"
(pass-if-syntax-error "duplicate pattern variable" (pass-if-syntax-error "duplicate pattern variable"
@ -1225,6 +1264,71 @@
((x ... y ... z ...) #f))) ((x ... y ... z ...) #f)))
(interaction-environment))))) (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: ;;; Local Variables:
;;; eval: (put 'pass-if-syntax-error 'scheme-indent-function 1) ;;; eval: (put 'pass-if-syntax-error 'scheme-indent-function 1)
;;; eval: (put 'with-ellipsis 'scheme-indent-function 1)
;;; End: ;;; End: