[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[PATCH] Implement R7RS 'syntax-error'
|
From: |
Mark H Weaver |
|
Subject: |
[PATCH] Implement R7RS 'syntax-error' |
|
Date: |
Thu, 19 Dec 2013 13:38:51 -0500 |
This patch implements the R7RS 'syntax-error' macro, which supports
improved error reporting from within 'syntax-rules' macros.
For 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 ...))))
(define (foo x)
(simple-let ((y (* x x))
((z1 z2) (values x x)))
(+ y 1)))
=>
While compiling expression:
ERROR: Syntax error:
unknown location: simple-let: expected an identifier but got (z1 z2) in form
(simple-let ((y (* x x)) ((z1 z2) (values x x))) (+ y 1))
This patch assumes that my earlier "custom ellipses" patch has already
been applied. I'd like to push these to stable-2.0.
Comments and suggestions welcome.
Mark
>From 9f4f8641d0218525a2fc58ef6f8c6728145f0def Mon Sep 17 00:00:00 2001
From: Mark H Weaver <address@hidden>
Date: Thu, 19 Dec 2013 13:22:50 -0500
Subject: [PATCH] Implement R7RS 'syntax-error'.
* module/ice-9/psyntax.scm (syntax-error): New macro.
(syntax-rules): Handle 'syntax-error' templates specially
for improved error reporting.
* module/ice-9/psyntax-pp.scm: Regenerate.
* doc/ref/api-macros.texi (Syntax Rules): Add docs.
* test-suite/tests/syntax.test: Add tests.
---
doc/ref/api-macros.texi | 24 +++++++++++
module/ice-9/psyntax-pp.scm | 90 +++++++++++++++++++++++++++++++++--------
module/ice-9/psyntax.scm | 38 ++++++++++++++++-
test-suite/tests/syntax.test | 41 +++++++++++++++++++
4 files changed, 172 insertions(+), 21 deletions(-)
diff --git a/doc/ref/api-macros.texi b/doc/ref/api-macros.texi
index 61137f0..72dd0df 100644
--- a/doc/ref/api-macros.texi
+++ b/doc/ref/api-macros.texi
@@ -363,6 +363,30 @@ 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
+
@subsubsection Specifying a custom ellipsis identifier
When writing macros that generate macro definitions, it is convenient to
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index a9015b2..e2c6b00 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -2583,18 +2583,85 @@
"source expression failed to match any pattern"
tmp)))))))))))
+(define syntax-error
+ (make-syntax-transformer
+ 'syntax-error
+ 'macro
+ (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 '(_ any . each-any))))
+ (if (if tmp
+ (apply (lambda (message arg) (string? (syntax->datum
message))) tmp)
+ #f)
+ (apply (lambda (message arg)
+ (cons '#(syntax-object syntax-error ((top)) (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-syntax-rules
+ ((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)))
- (let ((tmp ($sc-dispatch tmp-1 '(each-any each-any #(each ((any
. any) any))))))
+ (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)
+ (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
@@ -2607,20 +2674,7 @@
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))))))))))
+ (cons k
clause)))))))))
(let ((form tmp))
(if dots
(let ((tmp dots))
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 143d4c7..1ec6498 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -2839,21 +2839,53 @@
#'(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 ...)
+ (and (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))
+ ((((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 ...)
- ((dummy . pattern) #'template)
- ...))))
+ clause ...))))
(if dots
(with-syntax ((dots dots))
#'(with-ellipsis dots form))
diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test
index 142e2e5..093453b 100644
--- a/test-suite/tests/syntax.test
+++ b/test-suite/tests/syntax.test
@@ -1211,6 +1211,47 @@
(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"
--
1.7.5.4
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [PATCH] Implement R7RS 'syntax-error',
Mark H Weaver <=