added a "warning" procedure, that's like assertion-violation and

error except that it throws a warning via raise-continuable.
This commit is contained in:
Abdulaziz Ghuloum 2009-08-03 10:36:18 +03:00
parent a884cc9ff7
commit 22dc82567d
5 changed files with 19 additions and 25 deletions

View File

@ -16,14 +16,14 @@
(library (ikarus exceptions)
(export with-exception-handler raise raise-continuable
error assertion-violation die)
error warning assertion-violation die)
(import
(only (rnrs) condition make-non-continuable-violation
make-message-condition make-error make-who-condition
make-irritants-condition make-assertion-violation)
(except (ikarus)
with-exception-handler raise raise-continuable
error assertion-violation die))
error warning assertion-violation die))
(define handlers
(make-parameter
@ -60,28 +60,24 @@
(make-non-continuable-violation)
(make-message-condition "handler returned")))))))
(define (error who msg . irritants)
(unless (string? msg)
(assertion-violation 'error "message is not a string" msg))
(raise
(define (err who* raise* cond* who msg irritants)
(unless (string? msg)
(assertion-violation who* "message is not a string" msg))
(raise*
(condition
(make-error)
(cond*)
(if who (make-who-condition who) (condition))
(make-message-condition msg)
(make-irritants-condition irritants))))
(define (assertion-violation who msg . irritants)
(unless (string? msg)
(assertion-violation 'assertion-violation "message is not a string" msg))
(raise
(condition
(make-assertion-violation)
(if who (make-who-condition who) (condition))
(make-message-condition msg)
(make-irritants-condition irritants))))
(define die assertion-violation)
(define (error who msg . irritants)
(err 'error raise make-error who msg irritants))
(define (assertion-violation who msg . irritants)
(err 'assertion-violation raise make-assertion-violation who msg irritants))
(define (warning who msg . irritants)
(err 'warning raise-continuable make-warning who msg irritants))
(define (die who msg . irritants)
(err 'die raise make-assertion-violation who msg irritants))
)

View File

@ -29,7 +29,8 @@
input-port-column-number)
(except (ikarus) read-char read read-token comment-handler get-datum
read-annotated read-script-annotated annotation?
annotation-expression annotation-source annotation-stripped))
annotation-expression annotation-source annotation-stripped
input-port-column-number))
(define (die/lex id pos who msg arg*)
(raise

View File

@ -790,10 +790,6 @@
(lambda (who fmt . args)
(display-error "Error" who fmt args)))
(define warning
(lambda (who fmt . args)
(display-error "Warning" who fmt args)))
(define (assert-open-textual-output-port p who)
(unless (output-port? p)
(die who "not an output port" p))

View File

@ -1 +1 @@
1841
1842

View File

@ -735,6 +735,7 @@
[equal? i r ba se]
[eqv? i r ba se]
[error i r ba]
[warning i]
[die i]
[even? i r ba se]
[exact i r ba]