* error now calls raise after constructing a proper condition object.

* old "error-handler" parameter is gone.
* new-cafe now uses with-exception-handler to trap errors.
This commit is contained in:
Abdulaziz Ghuloum 2007-10-23 23:55:57 -04:00
parent 5678066f0d
commit 6853d2f750
6 changed files with 33 additions and 39 deletions

Binary file not shown.

View File

@ -25,23 +25,11 @@ description:
(library (ikarus cafe)
(export new-cafe)
(import
(only (rnrs) with-exception-handler)
(only (ikarus exceptions) print-condition)
(only (psyntax expander) eval-top-level)
(except (ikarus) new-cafe))
(define with-error-handler
(lambda (p thunk)
(let ([old-error-handler (error-handler)])
(dynamic-wind
(lambda ()
(error-handler
(lambda args
(error-handler old-error-handler)
(apply p args)
(apply error args))))
thunk
(lambda ()
(error-handler old-error-handler))))))
(define eval-depth 0)
(define display-prompt
@ -66,10 +54,11 @@ description:
(lambda (eval-proc escape-k)
(call/cc
(lambda (k)
(with-error-handler
(lambda args
(with-exception-handler
(lambda (con)
(reset-input-port! (console-input-port))
(apply print-error args)
(flush-output-port (console-output-port))
(print-condition con)
(k (void)))
(lambda ()
(display-prompt 0)

View File

@ -1,11 +1,13 @@
(library (ikarus exceptions)
(export with-exception-handler raise raise-continuable)
(export with-exception-handler raise raise-continuable error
print-condition)
(import
(only (rnrs) condition make-non-continuable-violation
make-message-condition)
make-message-condition make-error make-who-condition
make-irritants-condition)
(except (ikarus)
with-exception-handler raise raise-continuable))
with-exception-handler raise raise-continuable error))
(define (print-condition x)
(printf "CONDITION: ~s\n" x))
@ -43,5 +45,22 @@
(condition
(make-non-continuable-violation)
(make-message-condition "handler returned")))))))
(define (error who msg . irritants)
(unless (string? msg)
(error 'error "message ~s is not a string" msg))
(raise
(if who
(condition
(make-error)
(make-who-condition who)
(make-message-condition msg)
(make-irritants-condition irritants))
(condition
(make-error)
(make-message-condition msg)
(make-irritants-condition irritants)))))
)

View File

@ -296,6 +296,8 @@
(let ([d i1] [v (cadr i2)])
(cons (reloc-word+ v d) ac))]
[(and (int? i2) (obj? i1)) (IMM32*2 i2 i1 ac)]
[(and (int? i1) (int? i2))
(IMM32 i1 (IMM32 i2 ac))]
[else (error 'assemble "IMM32*2 ~s ~s" i1 i2)])))
(define CODErd

View File

@ -1,7 +1,6 @@
(library (ikarus writer)
(export write display format printf print-error error-handler
error print-unicode print-graph)
(export write display format printf print-error print-unicode print-graph)
(import
(rnrs hashtables)
(ikarus system $chars)
@ -13,8 +12,7 @@
(ikarus system $bytevectors)
(ikarus system $transcoders)
(only (ikarus unicode-data) unicode-printable-char?)
(except (ikarus) write display format printf print-error
error-handler error print-unicode print-graph))
(except (ikarus) write display format printf print-error print-unicode print-graph))
(define print-unicode
(make-parameter #t))
@ -740,18 +738,5 @@
(lambda (who fmt . args)
(display-error "Warning" who fmt args)))
(define error-handler
(make-parameter
(lambda args
(apply print-error args)
(flush-output-port (console-output-port))
(exit -1))
(lambda (x)
(if (procedure? x)
x
(error 'error-handler "~s is not a procedure" x)))))
(define error
(lambda args
(apply (error-handler) args))))
)

View File

@ -336,7 +336,6 @@
[make-parameter i parameters]
[call/cf i]
[print-error i]
[error-handler i]
[interrupt-handler i]
[assembler-output i]
[new-cafe i]