[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-591-gb958141
|
From: |
Mark H Weaver |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-591-gb958141 |
|
Date: |
Tue, 14 Jan 2014 06:57:44 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=b958141cdb081ceb16ca5828abda71f772fe0c57
The branch, master has been updated
via b958141cdb081ceb16ca5828abda71f772fe0c57 (commit)
via c9d55a7e4ec079a735af40df6e652db5585e6826 (commit)
via 7af706e36ee5c866edc5c0749cf0f49d7531bba0 (commit)
via 63d869e74c183faf8e73c73908ef912fdb20198e (commit)
via f974224d97bce334b6dcf20ecd8ffa84d270e0cd (commit)
via cc1cd04f8111c306cf48b93e131d5c1765c808a3 (commit)
via 0e18163366c2f2a0caecde18241dbd7987b4db7c (commit)
via 1624e149f75747310c9ce15db7db5324a538f8f8 (commit)
via 8de355d08e25a877326489c4b0eb09d313c548dc (commit)
from bdad13401611db73c57dcf8a1285b37e9b2ea31e (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit b958141cdb081ceb16ca5828abda71f772fe0c57
Merge: bdad134 c9d55a7
Author: Mark H Weaver <address@hidden>
Date: Tue Jan 14 01:16:42 2014 -0500
Merge branch 'stable-2.0'
Conflicts:
libguile/hash.c
module/ice-9/psyntax-pp.scm
module/ice-9/psyntax.scm
test-suite/tests/r6rs-ports.test
-----------------------------------------------------------------------
Summary of changes:
doc/ref/api-macros.texi | 95 +++++++++++-
doc/ref/guile.texi | 2 +-
libguile/hash.c | 2 +-
libguile/r6rs-ports.c | 17 ++-
module/ice-9/command-line.scm | 4 +-
module/ice-9/local-eval.scm | 8 +-
module/ice-9/psyntax-pp.scm | 325 +++++++++++++++++++++++++++++---------
module/ice-9/psyntax.scm | 161 +++++++++++++++----
module/system/repl/common.scm | 4 +-
test-suite/tests/hash.test | 15 ++-
test-suite/tests/numbers.test | 2 +-
test-suite/tests/r6rs-ports.test | 12 ++-
test-suite/tests/syntax.test | 147 +++++++++++++++++-
13 files changed, 660 insertions(+), 134 deletions(-)
diff --git a/doc/ref/api-macros.texi b/doc/ref/api-macros.texi
index 07fde8f..d4dbd8f 100644
--- a/doc/ref/api-macros.texi
+++ b/doc/ref/api-macros.texi
@@ -137,7 +137,7 @@ same @var{letrec-syntax}.
@code{syntax-rules} macros are simple, pattern-driven syntax transformers, with
a beauty worthy of Scheme.
address@hidden {Syntax} syntax-rules literals (pattern template)...
address@hidden {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
@@ -364,6 +364,50 @@ Cast into this form, our @code{when} example is
significantly shorter:
(if c (begin e ...)))
@end example
address@hidden Reporting Syntax Errors in Macros
+
address@hidden {Syntax} syntax-error message [arg ...]
+Report an error at macro-expansion time. @var{message} must be a string
+literal, and the optional @var{arg} operands can be arbitrary expressions
+providing additional information.
address@hidden deffn
+
address@hidden is intended to be used within @code{syntax-rules}
+templates. For example:
+
address@hidden
+(define-syntax simple-let
+ (syntax-rules ()
+ ((_ (head ... ((x . y) val) . tail)
+ body1 body2 ...)
+ (syntax-error
+ "expected an identifier but got"
+ (x . y)))
+ ((_ ((name val) ...) body1 body2 ...)
+ ((lambda (name ...) body1 body2 ...)
+ val ...))))
address@hidden example
+
address@hidden 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
address@hidden, as per R7RS. For example:
+
address@hidden
+(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)
address@hidden example
+
@subsubsection Further Information
For a formal definition of @code{syntax-rules} and its pattern language, see
@@ -390,7 +434,7 @@ Primer for the Merely Eccentric}.
@code{syntax-case} macros are procedural syntax transformers, with a power
worthy of Scheme.
address@hidden {Syntax} syntax-case syntax literals (pattern [guard] exp)...
address@hidden {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
@@ -632,9 +676,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:
address@hidden {Syntax} with-syntax ((pat val)...) exp...
address@hidden {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
@@ -682,6 +726,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/}.
address@hidden 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:
+
address@hidden {Syntax} with-ellipsis ellipsis body @dots{}
address@hidden must be an identifier. Evaluate @var{body} in a special
+lexical environment such that all macro patterns and templates within
address@hidden will use @var{ellipsis} as the ellipsis identifier instead of
+the usual three dots (@code{...}).
address@hidden deffn
+
+For example:
+
address@hidden
+(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)
address@hidden 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
@@ -747,8 +827,11 @@ value will not be returned. Pass
@code{#:resolve-syntax-parameters? #f}
to indicate that you are interested in syntax parameters. The value is
the default transformer procedure, as in @code{macro}.
@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.
address@hidden 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/doc/ref/guile.texi b/doc/ref/guile.texi
index c3170ce..c43873c 100644
--- a/doc/ref/guile.texi
+++ b/doc/ref/guile.texi
@@ -14,7 +14,7 @@
This manual documents Guile version @value{VERSION}.
Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2009,
-2010, 2011, 2012, 2013 Free Software Foundation.
+2010, 2011, 2012, 2013, 2014 Free Software Foundation.
Permission is granted to copy, distribute and/or modify this document
under the terms of the GNU Free Documentation License, Version 1.3 or
diff --git a/libguile/hash.c b/libguile/hash.c
index 740dac1..0ac67fa 100644
--- a/libguile/hash.c
+++ b/libguile/hash.c
@@ -1,6 +1,6 @@
/* Copyright (C) 1995, 1996, 1997, 2000, 2001, 2003, 2004, 2006, 2008,
* 2009, 2010, 2011, 2012 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 License
* as published by the Free Software Foundation; either version 3 of
diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c
index 3f936e7..fc67689 100644
--- a/libguile/r6rs-ports.c
+++ b/libguile/r6rs-ports.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2009, 2010, 2011, 2013 Free Software Foundation, Inc.
+/* Copyright (C) 2009, 2010, 2011, 2013, 2014 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 License
@@ -216,10 +216,14 @@ cbp_seek (SCM port, scm_t_off offset, int whence)
result = scm_call_0 (get_position_proc);
else
scm_wrong_type_arg_msg (FUNC_NAME, 0, port,
- "R6RS custom binary port does not "
- "support `port-position'");
-
- offset += scm_to_int (result);
+ "R6RS custom binary port with "
+ "`port-position' support");
+ c_result = scm_to_int (result);
+ if (offset == 0)
+ /* We just want to know the current position. */
+ break;
+
+ offset += c_result;
/* Fall through. */
}
@@ -232,8 +236,7 @@ cbp_seek (SCM port, scm_t_off offset, int whence)
result = scm_call_1 (set_position_proc, scm_from_int (offset));
else
scm_wrong_type_arg_msg (FUNC_NAME, 0, port,
- "R6RS custom binary port does not "
- "support `set-port-position!'");
+ "seekable R6RS custom binary port");
/* Assuming setting the position succeeded. */
c_result = offset;
diff --git a/module/ice-9/command-line.scm b/module/ice-9/command-line.scm
index 7da0a6b..b387eb3 100644
--- a/module/ice-9/command-line.scm
+++ b/module/ice-9/command-line.scm
@@ -1,6 +1,6 @@
;;; Parsing Guile's command-line
-;;; Copyright (C) 1994-1998, 2000-2011, 2012, 2013 Free Software Foundation,
Inc.
+;;; Copyright (C) 1994-1998, 2000-2011, 2012, 2013, 2014 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
@@ -66,7 +66,7 @@ There is NO WARRANTY, to the extent permitted by law."))
(define* (version-etc package version #:key
(port (current-output-port))
;; FIXME: authors
- (copyright-year 2013)
+ (copyright-year 2014)
(copyright-holder "Free Software Foundation, Inc.")
(copyright (format #f "Copyright (C) ~a ~a"
copyright-year copyright-holder))
diff --git a/module/ice-9/local-eval.scm b/module/ice-9/local-eval.scm
index 493dbed..b81daf3 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
;; Interestingly, this case can include globals (and
;; global macros), now that Guile tracks which globals it
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index 0684890..7ad8a70 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -276,7 +276,7 @@
(if (null? r)
'()
(let ((a (car r)))
- (if (memq (cadr a) '(macro syntax-parameter))
+ (if (memq (cadr a) '(macro syntax-parameter ellipsis))
(cons a (macros-only-env (cdr r)))
(macros-only-env (cdr r)))))))
(global-extend
@@ -591,7 +591,14 @@
(let ((x (build-global-definition s var
(expand e r w mod))))
(top-level-eval-hook x mod)
(lambda () x))
- (lambda () (build-global-definition s
var (expand e r w mod)))))))
+ (call-with-values
+ (lambda () (resolve-identifier id
'(()) r mod #t))
+ (lambda (type* value* mod*)
+ (if (eq? type* 'macro)
+ (top-level-eval-hook
+ (build-global-definition s var
(build-void s))
+ mod))
+ (lambda () (build-global-definition
s var (expand e r w mod)))))))))
((memv key '(define-syntax-form
define-syntax-parameter-form))
(let* ((id (wrap value w mod))
(label (gen-label))
@@ -1129,9 +1136,23 @@
(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)
+ (call-with-values
+ (lambda ()
+ (resolve-identifier
+ (make-syntax-object
+ '#{ $sc-ellipsis }#
+ (syntax-object-wrap e)
+ (syntax-object-module e))
+ '(())
+ r
+ mod
+ #f))
+ (lambda (type value mod)
+ (if (eq? type 'ellipsis)
+ (bound-id=? e value)
+ (free-id=? e '#(syntax-object ... ((top)) (hygiene
guile)))))))))
(lambda-formals
(lambda (orig-args)
(letrec*
@@ -1607,14 +1628,15 @@
(call-with-values
(lambda () (gen-ref src (car value) (cdr value)
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)
@@ -1625,7 +1647,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)
@@ -1849,6 +1871,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
@@ -2103,7 +2149,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))))
@@ -2197,9 +2243,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))
@@ -2276,7 +2323,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-call
s
@@ -2401,6 +2448,13 @@
(if (equal? mod '(primitive))
(values 'primitive value)
(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)
@@ -2582,80 +2636,197 @@
"source expression failed to match any pattern"
tmp)))))))))))
-(define syntax-rules
+(define syntax-error
(make-syntax-transformer
- 'syntax-rules
+ 'syntax-error
'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)
- #(ribcage
- #(syntax-rules)
- #((top))
- #(((hygiene guile)
- .
- #(syntax-object syntax-rules ((top))
(hygiene guile))))))
- (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 _ ((top)) (hygiene guile)) tmp)
- (list
'#(syntax-object syntax ((top)) (hygiene guile))
- tmp-1)))
- template
- pattern))))))
+ (lambda (x)
+ (let ((tmp-1 x))
+ (let ((tmp ($sc-dispatch tmp-1 '(_ (any . any) any . each-any))))
+ (if (if tmp
+ (apply (lambda (keyword operands message arg)
+ (string? (syntax->datum message)))
+ tmp)
+ #f)
+ (apply (lambda (keyword operands message arg)
+ (syntax-violation
+ (syntax->datum keyword)
+ (string-join
+ (cons (syntax->datum message)
+ (map (lambda (x) (object->string (syntax->datum
x))) arg)))
+ (if (syntax->datum keyword) (cons keyword operands)
#f)))
tmp)
- (let ((tmp ($sc-dispatch tmp-1 '(_ each-any any . #(each ((any .
any) any))))))
+ (let ((tmp ($sc-dispatch tmp-1 '(_ any . each-any))))
(if (if tmp
- (apply (lambda (k docstring keyword pattern template)
- (string? (syntax->datum docstring)))
- tmp)
+ (apply (lambda (message arg) (string? (syntax->datum
message))) 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)
- #(ribcage
- #(syntax-rules)
- #((top))
- #(((hygiene guile)
- .
- #(syntax-object syntax-rules
((top)) (hygiene guile))))))
- (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 _ ((top)) (hygiene guile)) tmp)
- (list
'#(syntax-object syntax ((top)) (hygiene guile))
- tmp-1)))
- template
- pattern))))))
+ (apply (lambda (message arg)
+ (cons '#(syntax-object
+ syntax-error
+ ((top)
+ #(ribcage
+ #(syntax-error)
+ #((top))
+ #(((hygiene guile)
+ .
+ #(syntax-object syntax-error ((top))
(hygiene guile))))))
+ (hygiene guile))
+ (cons '(#f) (cons message arg))))
tmp)
(syntax-violation
#f
"source expression failed to match any pattern"
tmp-1)))))))))
+(define syntax-rules
+ (make-syntax-transformer
+ 'syntax-rules
+ 'macro
+ (lambda (xx)
+ (letrec*
+ ((expand-clause
+ (lambda (clause)
+ (let ((tmp-1 clause))
+ (let ((tmp ($sc-dispatch
+ tmp-1
+ '((any . any)
+ (#(free-id #(syntax-object syntax-error ((top))
(hygiene guile)))
+ any
+ .
+ each-any)))))
+ (if (if tmp
+ (apply (lambda (keyword pattern message arg)
+ (string? (syntax->datum message)))
+ tmp)
+ #f)
+ (apply (lambda (keyword pattern message arg)
+ (list (cons '#(syntax-object dummy ((top))
(hygiene guile)) pattern)
+ (list '#(syntax-object syntax ((top))
(hygiene guile))
+ (cons '#(syntax-object syntax-error
((top)) (hygiene guile))
+ (cons (cons '#(syntax-object
dummy ((top)) (hygiene guile)) pattern)
+ (cons message arg))))))
+ tmp)
+ (let ((tmp ($sc-dispatch tmp-1 '((any . any) any))))
+ (if tmp
+ (apply (lambda (keyword pattern template)
+ (list (cons '#(syntax-object dummy ((top))
(hygiene guile)) pattern)
+ (list '#(syntax-object syntax ((top))
(hygiene guile)) template)))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1))))))))
+ (expand-syntax-rules
+ (lambda (dots keys docstrings clauses)
+ (let ((tmp-1 (list keys docstrings clauses (map expand-clause
clauses))))
+ (let ((tmp ($sc-dispatch
+ tmp-1
+ '(each-any each-any #(each ((any . any) any))
each-any))))
+ (if tmp
+ (apply (lambda (k docstring keyword pattern template clause)
+ (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)
+ #(ribcage
+
#(syntax-rules)
+ #((top))
+
#(((hygiene guile)
+ .
+
#(syntax-object
+
syntax-rules
+
((top))
+
(hygiene guile))))))
+ (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
clause)))))))))
+ (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
'define-syntax-rule
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index cfcea4b..f7c5c0e 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -42,6 +42,9 @@
;;; Modified by Andy Wingo <address@hidden> according to the Git
;;; revision control logs corresponding to this file: 2009, 2010.
+;;; Modified by Mark H Weaver <address@hidden> 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.
@@ -511,6 +514,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
@@ -530,6 +534,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
@@ -571,7 +578,7 @@
(if (null? r)
'()
(let ((a (car r)))
- (if (memq (cadr a) '(macro syntax-parameter))
+ (if (memq (cadr a) '(macro syntax-parameter ellipsis))
(cons a (macros-only-env (cdr r)))
(macros-only-env (cdr r)))))))
@@ -1086,8 +1093,17 @@
(let ((x (build-global-definition s var (expand e r
w mod))))
(top-level-eval-hook x mod)
(lambda () x))
- (lambda ()
- (build-global-definition s var (expand e r w
mod)))))))
+ (call-with-values
+ (lambda () (resolve-identifier id empty-wrap r
mod #t))
+ (lambda (type* value* mod*)
+ ;; If the identifier to be bound is currently
bound to a
+ ;; macro, then immediately discard that binding.
+ (if (eq? type* 'macro)
+ (top-level-eval-hook (build-global-definition
+ s var (build-void s))
+ mod))
+ (lambda ()
+ (build-global-definition s var (expand e r w
mod)))))))))
((define-syntax-form define-syntax-parameter-form)
(let* ((id (wrap value w mod))
(label (gen-label))
@@ -1124,8 +1140,8 @@
(parse #'(e1 ...) r w s m esew mod))))
((local-syntax-form)
(expand-local-syntax value e r w s mod
- (lambda (forms r w s mod)
- (parse forms r w s m esew mod))))
+ (lambda (forms r w s mod)
+ (parse forms r w s m esew mod))))
((eval-when-form)
(syntax-case e ()
((_ (x ...) e1 e2 ...)
@@ -1675,9 +1691,24 @@
(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=?'.
+ (call-with-values
+ (lambda () (resolve-identifier
+ (make-syntax-object '#{ $sc-ellipsis }#
+ (syntax-object-wrap e)
+ (syntax-object-module e))
+ empty-wrap r mod #f))
+ (lambda (type value mod)
+ (if (eq? type 'ellipsis)
+ (bound-id=? e value)
+ (free-id=? e #'(... ...))))))))
(define lambda-formals
(lambda (orig-args)
@@ -2010,17 +2041,17 @@
(lambda (var maps)
(values `(ref ,var) maps))))
(else
- (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
@@ -2035,7 +2066,7 @@
(cdr maps))))))))
(syntax-case y ()
((dots . y)
- (ellipsis? #'dots)
+ (ellipsis? #'dots r mod)
(f #'y
(lambda (maps)
(call-with-values
@@ -2226,6 +2257,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)
@@ -2438,7 +2488,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* ()
@@ -2528,10 +2578,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))
@@ -2597,7 +2647,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
@@ -2708,6 +2758,11 @@
(if (equal? mod '(primitive))
(values 'primitive value)
(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)
@@ -2899,27 +2954,69 @@
#'(syntax-case (list in ...) ()
((out ...) (let () e1 e2 ...)))))))
+(define-syntax syntax-error
+ (lambda (x)
+ (syntax-case x ()
+ ;; Extended internal syntax which provides the original form
+ ;; as the first operand, for improved error reporting.
+ ((_ (keyword . operands) message arg ...)
+ (string? (syntax->datum #'message))
+ (syntax-violation (syntax->datum #'keyword)
+ (string-join (cons (syntax->datum #'message)
+ (map (lambda (x)
+ (object->string
+ (syntax->datum x)))
+ #'(arg ...))))
+ (and (syntax->datum #'keyword)
+ #'(keyword . operands))))
+ ;; Standard R7RS syntax
+ ((_ message arg ...)
+ (string? (syntax->datum #'message))
+ #'(syntax-error (#f) message arg ...)))))
+
(define-syntax syntax-rules
(lambda (xx)
+ (define (expand-clause clause)
+ ;; Convert a 'syntax-rules' clause into a 'syntax-case' clause.
+ (syntax-case clause (syntax-error)
+ ;; If the template is a 'syntax-error' form, use the extended
+ ;; internal syntax, which adds the original form as the first
+ ;; operand for improved error reporting.
+ (((keyword . pattern) (syntax-error message arg ...))
+ (string? (syntax->datum #'message))
+ #'((dummy . pattern) #'(syntax-error (dummy . pattern) message arg
...)))
+ ;; Normal case
+ (((keyword . pattern) template)
+ #'((dummy . pattern) #'template))))
+ (define (expand-syntax-rules dots keys docstrings clauses)
+ (with-syntax
+ (((k ...) keys)
+ ((docstring ...) docstrings)
+ ((((keyword . pattern) template) ...) clauses)
+ ((clause ...) (map expand-clause clauses)))
+ (with-syntax
+ ((form #'(lambda (x)
+ docstring ... ; optional docstring
+ #((macro-type . syntax-rules)
+ (patterns pattern ...)) ; embed patterns as procedure
metadata
+ (syntax-case x (k ...)
+ clause ...))))
+ (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 ...)
- ((_ . 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 ...)
- ((_ . 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/module/system/repl/common.scm b/module/system/repl/common.scm
index 0a38710..f0e6e03 100644
--- a/module/system/repl/common.scm
+++ b/module/system/repl/common.scm
@@ -1,7 +1,7 @@
;;; Repl common routines
;; Copyright (C) 2001, 2008, 2009, 2010, 2011, 2012,
-;; 2013 Free Software Foundation, Inc.
+;; 2013, 2014 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
@@ -41,7 +41,7 @@
(define *version*
(format #f "GNU Guile ~A
-Copyright (C) 1995-2013 Free Software Foundation, Inc.
+Copyright (C) 1995-2014 Free Software Foundation, Inc.
Guile comes with ABSOLUTELY NO WARRANTY; for details type `,show w'.
This program is free software, and you are welcome to redistribute it
diff --git a/test-suite/tests/hash.test b/test-suite/tests/hash.test
index ad247f5..64d10bb 100644
--- a/test-suite/tests/hash.test
+++ b/test-suite/tests/hash.test
@@ -1,6 +1,7 @@
;;;; hash.test --- test guile hashing -*- scheme -*-
;;;;
-;;;; Copyright (C) 2004, 2005, 2006, 2008, 2011, 2012 Free Software
Foundation, Inc.
+;;;; Copyright (C) 2004, 2005, 2006, 2008, 2011, 2012,
+;;;; 2014 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
@@ -36,7 +37,17 @@
(pass-if (= 0 (hash noop 1)))
(pass-if (= 0 (hash +inf.0 1)))
(pass-if (= 0 (hash -inf.0 1)))
- (pass-if (= 0 (hash +nan.0 1))))
+ (pass-if (= 0 (hash +nan.0 1)))
+ (pass-if (= 0 (hash '#() 1)))
+
+ (pass-if "cyclic vectors"
+ (let ()
+ (define (cyclic-vector n)
+ (let ((v (make-vector n)))
+ (vector-fill! v v)
+ v))
+ (and (= 0 (hash (cyclic-vector 3) 1))
+ (= 0 (hash (cyclic-vector 10) 1))))))
;;;
;;; hashv
diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test
index e91bc52..847f939 100644
--- a/test-suite/tests/numbers.test
+++ b/test-suite/tests/numbers.test
@@ -1808,7 +1808,7 @@
(pass-if (not (integer? (current-input-port)))))
;;;
-;;; integer?
+;;; exact-integer?
;;;
(with-test-prefix "exact-integer?"
diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test
index d0ae9d3..abd5d6f 100644
--- a/test-suite/tests/r6rs-ports.test
+++ b/test-suite/tests/r6rs-ports.test
@@ -1,6 +1,7 @@
;;;; r6rs-ports.test --- R6RS I/O port tests. -*- coding: utf-8; -*-
;;;;
-;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013,
+;;;; 2014 Free Software Foundation, Inc.
;;;; Ludovic Courtès
;;;;
;;;; This library is free software; you can redistribute it and/or
@@ -410,6 +411,15 @@
(not (or (port-has-port-position? port)
(port-has-set-port-position!? port)))))
+ (pass-if-equal "custom binary input port supports `port-position', \
+not `set-port-position!'"
+ 42
+ (let ((port (make-custom-binary-input-port "the port" (const 0)
+ (const 42) #f #f)))
+ (and (port-has-port-position? port)
+ (not (port-has-set-port-position!? port))
+ (port-position port))))
+
(pass-if "custom binary input port supports `port-position'"
(let* ((str "Hello Port!")
(source (open-bytevector-input-port
diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test
index 8b8c9d9..4bde635 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))
@@ -1238,6 +1239,85 @@
(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-error"
+
+ (pass-if-syntax-error "outside of macro without args"
+ "test error"
+ (eval '(syntax-error "test error")
+ (interaction-environment)))
+
+ (pass-if-syntax-error "outside of macro with args"
+ "test error x \\(y z\\)"
+ (eval '(syntax-error "test error" x (y z))
+ (interaction-environment)))
+
+ (pass-if-equal "within macro"
+ '(simple-let
+ "expected an identifier but got (z1 z2)"
+ (simple-let ((y (* x x))
+ ((z1 z2) (values x x)))
+ (+ y 1)))
+ (catch 'syntax-error
+ (lambda ()
+ (eval '(let ()
+ (define-syntax simple-let
+ (syntax-rules ()
+ ((_ (head ... ((x . y) val) . tail)
+ body1 body2 ...)
+ (syntax-error
+ "expected an identifier but got"
+ (x . y)))
+ ((_ ((name val) ...) body1 body2 ...)
+ ((lambda (name ...) body1 body2 ...)
+ val ...))))
+ (define (foo x)
+ (simple-let ((y (* x x))
+ ((z1 z2) (values x x)))
+ (+ y 1)))
+ foo)
+ (interaction-environment))
+ (error "expected syntax-error exception"))
+ (lambda (k who what where form . maybe-subform)
+ (list who what form)))))
+
(with-test-prefix "syntax-case"
(pass-if-syntax-error "duplicate pattern variable"
@@ -1291,6 +1371,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:
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-591-gb958141,
Mark H Weaver <=