mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 03:30:27 +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

90
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
((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
@ -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))