diff --git a/scheme/ikarus.boot.orig b/scheme/ikarus.boot.orig index e7300bd..8e5e157 100644 Binary files a/scheme/ikarus.boot.orig and b/scheme/ikarus.boot.orig differ diff --git a/scheme/ikarus.cafe.ss b/scheme/ikarus.cafe.ss index 154d9ac..88ebdb0 100644 --- a/scheme/ikarus.cafe.ss +++ b/scheme/ikarus.cafe.ss @@ -26,7 +26,6 @@ description: (export new-cafe) (import (only (rnrs) with-exception-handler) - (only (ikarus exceptions) print-condition) (only (psyntax expander) eval-top-level) (except (ikarus) new-cafe)) diff --git a/scheme/ikarus.conditions.ss b/scheme/ikarus.conditions.ss index b3cfbb3..85b5f99 100644 --- a/scheme/ikarus.conditions.ss +++ b/scheme/ikarus.conditions.ss @@ -1,7 +1,7 @@ (library (ikarus conditions) (export condition? simple-conditions condition-predicate - condition condition-accessor + condition condition-accessor print-condition ;;; too much junk make-message-condition message-condition? @@ -62,6 +62,7 @@ (only (ikarus records procedural) rtd? rtd-subtype?) (except (ikarus) define-condition-type condition? simple-conditions condition condition-predicate condition-accessor + print-condition ;;; more junk make-message-condition message-condition? @@ -300,5 +301,19 @@ (define-condition-type &no-nans &implementation-restriction make-no-nans-violation no-nans-violation?) + (define print-condition + (let () + (define (print-condition x p) + (display "CONDITION: " p) + (write x p) + (newline p)) + (case-lambda + [(x) + (print-condition x (console-output-port))] + [(x port) + (if (output-port? port) + (print-condition x port) + (error 'print-condition "~s is not an output port" port))]))) + ) diff --git a/scheme/ikarus.exceptions.ss b/scheme/ikarus.exceptions.ss index e60b6c6..b75a352 100644 --- a/scheme/ikarus.exceptions.ss +++ b/scheme/ikarus.exceptions.ss @@ -1,7 +1,6 @@ (library (ikarus exceptions) - (export with-exception-handler raise raise-continuable error - print-condition) + (export with-exception-handler raise raise-continuable error) (import (only (rnrs) condition make-non-continuable-violation make-message-condition make-error make-who-condition @@ -9,8 +8,6 @@ (except (ikarus) with-exception-handler raise raise-continuable error)) - (define (print-condition x) - (printf "CONDITION: ~s\n" x)) (define handlers (make-parameter @@ -50,16 +47,13 @@ (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))))) + (condition + (make-error) + (if who (make-who-condition who) (condition)) + (make-message-condition msg) + (if (null? irritants) + (condition) + (make-irritants-condition irritants))))) ) diff --git a/scheme/makefile.ss b/scheme/makefile.ss index 54e925e..96140e9 100755 --- a/scheme/makefile.ss +++ b/scheme/makefile.ss @@ -893,6 +893,7 @@ [utf8->string i r bv] [utf16->string r bv] [utf32->string r bv] + [print-condition i] [condition? r co] [&assertion r co] [assertion-violation? r co]