with-syntax now gives more informative error messages:

> (with-syntax ([(x y) #'(a 1)] [(q) #'(a b c)]) 12)
Unhandled exception
 Condition components:
   1. &assertion
   2. &who: with-syntax
   3. &message: "pattern does not match value"
   4. &irritants: ((q) #<syntax (a b c)>)

instead of the previous behavior:

> (with-syntax ([(x y) #'(a 1)] [(q) #'(a b c)]) 12)
Unhandled exception
 Condition components:
    1. &message: "invalid syntax"
    2. &syntax:
        form: ((a 1) (a b c))
        subform: #f
This commit is contained in:
Abdulaziz Ghuloum 2008-05-03 06:23:35 -04:00
parent 373edfc969
commit 3f9b567a5b
2 changed files with 26 additions and 7 deletions

View File

@ -1 +1 @@
1465
1466

View File

@ -29,6 +29,7 @@
interaction-environment
ellipsis-map)
(import
(only (ikarus) printf)
(except (rnrs)
environment environment? identifier?
eval generate-temporaries free-identifier=?
@ -1121,11 +1122,29 @@
(define with-syntax-macro
(lambda (e)
(syntax-match e ()
((_ ((fml* expr*) ...) b b* ...)
(bless
`(syntax-case (list . ,expr*) ()
(,fml* (begin ,b . ,b*))))))))
((_ ((pat* expr*) ...) b b* ...)
(let ([idn*
(let f ([pat* pat*])
(cond
[(null? pat*) '()]
[else
(let-values ([(pat idn*) (convert-pattern (car pat*) '())])
(append idn* (f (cdr pat*))))]))])
(verify-formals (map car idn*) e)
(let ([t* (generate-temporaries expr*)])
(bless
`(let ,(map list t* expr*)
,(let f ([pat* pat*] [t* t*])
(cond
[(null? pat*) `(begin #f ,b . ,b*)]
[else
`(syntax-case ,(car t*) ()
[,(car pat*) ,(f (cdr pat*) (cdr t*))]
[_ (assertion-violation 'with-syntax
"pattern does not match value"
',(car pat*)
,(car t*))])]))))))))))
(define (invalid-fmls-error stx fmls)
(syntax-match fmls ()
[(id* ... . last)
@ -3767,7 +3786,7 @@
(assertion-violation 'bound-identifier=? "not an identifier" y))
(assertion-violation 'bound-identifier=? "not an identifier" x))))
(define (extract-position-condition x)
(define (extract-position-condition x)
(define-condition-type &source-information &condition
make-source-condition source-condition?
(file-name source-filename)