mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-20 11:40:18 +02:00
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.
(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
parent
8de355d08e
commit
1624e149f7
5 changed files with 423 additions and 99 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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))))))))))
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
@ -1810,6 +1819,30 @@
|
|||
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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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:
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue