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

Implement R7RS 'syntax-error'.

Browse source 
* 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 new subsection "Reporting
  Syntax Errors in Macros".

* test-suite/tests/syntax.test: Add tests.
This commit is contained in:
Mark H Weaver 2013-12-19 13:22:50 -05:00
parent 1624e149f7
commit 0e18163366
4 changed files with 172 additions and 21 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -363,6 +363,30 @@ 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

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

@ -2585,18 +2585,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
(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))))))
((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 (k docstring keyword pattern template)
(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
@ -2609,20 +2676,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))

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

@ -2841,21 +2841,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 ...)
(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))

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

@ -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"