* 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:
parent
5678066f0d
commit
6853d2f750
Binary file not shown.
|
@ -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)
|
||||
|
|
|
@ -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)))))
|
||||
|
||||
|
||||
)
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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))))
|
||||
)
|
||||
|
||||
|
|
|
@ -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]
|
||||
|
|
Loading…
Reference in New Issue