conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

assert now gives source information when available.

This commit is contained in:
Abdulaziz Ghuloum 2008-07-29 11:04:52 -07:00
parent 5aa6e1b05e
commit 959082d12d
3 changed files with 28 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
scheme/last-revision
View File

@ -1 +1 @@
1560
1561

1
scheme/makefile.ss
View File

@ -634,6 +634,7 @@
[apply i r ba se]
[asin i r ba se]
[assert i r ba]
[assertion-error ]
[assertion-violation i r ba]
[atan i r ba se]
[boolean=? i r ba]

38
scheme/psyntax.expander.ss
View File

@ -30,7 +30,7 @@
compile-r6rs-top-level boot-library-expand
null-environment scheme-report-environment
interaction-environment
ellipsis-map)
ellipsis-map assertion-error)
(import
(except (rnrs)
environment environment? identifier?
@ -1435,8 +1435,10 @@
(lambda (stx)
(syntax-match stx ()
((_ expr)
(bless `(unless ,expr
(assertion-violation 'assert "assertion failed" ',expr)))))))
(let ([pos (or (expression-position stx)
(expression-position expr))])
(bless
`(unless ,expr (assertion-error ',expr ',pos))))))))
(define endianness-macro
(lambda (stx)
@ -3843,20 +3845,32 @@
(assertion-violation 'bound-identifier=? "not an identifier" y))
(assertion-violation 'bound-identifier=? "not an identifier" x))))
(define (extract-position-condition x)
(define (make-source-condition x)
(define-condition-type &source-information &condition
make-source-condition source-condition?
(file-name source-filename)
(character source-character))
(if (stx? x)
(if (pair? x)
(make-source-condition (car x) (cdr x))
(condition)))
(define (extract-position-condition x)
(make-source-condition (expression-position x)))
(define (expression-position x)
(and (stx? x)
(let ([x (stx-expr x)])
(if (annotation? x)
(let ([src (annotation-source x)])
(if (pair? src)
(make-source-condition (car src) (cdr src))
(condition)))
(condition)))
(condition)))
(and (annotation? x)
(annotation-source x)))))
(define (assertion-error expr pos)
(raise
(condition
(make-assertion-violation)
(make-who-condition 'assert)
(make-message-condition "assertion failed")
(make-irritants-condition (list expr))
(make-source-condition pos))))
(define syntax-error
(lambda (x . args)