summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--doc/ref/api-macros.texi95
-rw-r--r--doc/ref/guile.texi2
-rw-r--r--libguile/hash.c2
-rw-r--r--libguile/r6rs-ports.c17
-rw-r--r--module/ice-9/command-line.scm4
-rw-r--r--module/ice-9/local-eval.scm8
-rw-r--r--module/ice-9/psyntax-pp.scm325
-rw-r--r--module/ice-9/psyntax.scm161
-rw-r--r--module/system/repl/common.scm4
-rw-r--r--test-suite/tests/hash.test15
-rw-r--r--test-suite/tests/numbers.test2
-rw-r--r--test-suite/tests/r6rs-ports.test12
-rw-r--r--test-suite/tests/syntax.test147
13 files changed, 660 insertions, 134 deletions
diff --git a/doc/ref/api-macros.texi b/doc/ref/api-macros.texi
index 07fde8f86..d4dbd8f79 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.
-@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
@@ -364,6 +364,50 @@ Cast into this form, our @code{when} example is significantly shorter:
(if c (begin e ...)))
@end example
+@subsubsection Reporting Syntax Errors in Macros
+
+@deffn {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.
+@end deffn
+
+@code{syntax-error} is intended to be used within @code{syntax-rules}
+templates. For example:
+
+@example
+(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 ...))))
+@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
@@ -390,7 +434,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
@@ -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:
-@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
@@ -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/}.
+@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
@@ -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.
+@item ellipsis
+An internal binding, bound via @code{with-ellipsis}. The value is the
+(anti-marked) local ellipsis identifier.
@item displaced-lexical
A lexical variable that has gone out of scope. This can happen if a
badly-written procedural macro saves a syntax object, then attempts to
diff --git a/doc/ref/guile.texi b/doc/ref/guile.texi
index c3170ce46..c43873cff 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 740dac11f..0ac67fa1f 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 3f936e71b..fc676895d 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 7da0a6b15..b387eb350 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 493dbed0d..b81daf3e8 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 0684890ed..7ad8a7018 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 cfcea4b26..f7c5c0ee6 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -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.
@@ -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 0a38710af..f0e6e03a0 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 ad247f50a..64d10bb38 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 e91bc5240..847f93962 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 d0ae9d395..abd5d6ff9 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 8b8c9d954..4bde635d8 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: