>From 8ba4d813fd20a7eb214e41fbfdf81674070ab91a Mon Sep 17 00:00:00 2001 From: Evan Hanson Date: Mon, 7 Aug 2017 21:38:58 +1200 Subject: [PATCH] Move `print-error-message' into (chicken condition) --- chicken.condition.import.scm | 1 + chicken.import.scm | 1 - library.scm | 161 ++++++++++++++++++++++--------------------- tests/port-tests.scm | 2 +- types.db | 2 +- 5 files changed, 84 insertions(+), 83 deletions(-) diff --git a/chicken.condition.import.scm b/chicken.condition.import.scm index effe0685..6f669be7 100644 --- a/chicken.condition.import.scm +++ b/chicken.condition.import.scm @@ -31,6 +31,7 @@ (current-exception-handler . chicken.condition#current-exception-handler) (get-call-chain . chicken.condition#get-call-chain) (print-call-chain . chicken.condition#print-call-chain) + (print-error-message . chicken.condition#print-error-message) (with-exception-handler . chicken.condition#with-exception-handler) (make-property-condition . chicken.condition#make-property-condition) (make-composite-condition . chicken.condition#make-composite-condition) diff --git a/chicken.import.scm b/chicken.import.scm index 563cf7ff..c81b8304 100644 --- a/chicken.import.scm +++ b/chicken.import.scm @@ -148,7 +148,6 @@ (provided? . chicken.load#provided?) print (print-call-chain . chicken.condition#print-call-chain) - print-error-message print* procedure-information program-name diff --git a/library.scm b/library.scm index a75e77a9..99c32b7a 100644 --- a/library.scm +++ b/library.scm @@ -4448,7 +4448,7 @@ EOF ;; NOTE: We don't emit the import lib. Due to syntax exports, it ;; has to be a hardcoded primitive module. (abort signal current-exception-handler get-call-chain - print-call-chain with-exception-handler + print-call-chain print-error-message with-exception-handler ;; [syntax] condition-case handle-exceptions @@ -4778,6 +4778,86 @@ EOF ((apply condition-property-accessor kind prop err-def) c))) +;;; Convenient error printing: + +(define print-error-message + (let* ((display display) + (newline newline) + (write write) + (string-append string-append) + (errmsg (condition-property-accessor 'exn 'message #f)) + (errloc (condition-property-accessor 'exn 'location #f)) + (errargs (condition-property-accessor 'exn 'arguments #f)) + (writeargs + (lambda (args port) + (##sys#for-each + (lambda (x) + (##sys#with-print-length-limit 80 (lambda () (write x port))) + (newline port) ) + args) ) ) ) + (lambda (ex . args) + (let-optionals args ((port ##sys#standard-output) + (header "Error")) + (##sys#check-output-port port #t 'print-error-message) + (newline port) + (display header port) + (cond ((and (not (##sys#immediate? ex)) (eq? 'condition (##sys#slot ex 0))) + (cond ((errmsg ex) => + (lambda (msg) + (display ": " port) + (let ((loc (errloc ex))) + (when (and loc (symbol? loc)) + (display (string-append "(" (##sys#symbol->qualified-string loc) ") ") port) ) ) + (display msg port) ) ) + (else + (let ((kinds (##sys#slot ex 1))) + (if (equal? '(user-interrupt) kinds) + (display ": *** user interrupt ***" port) + (begin + (display ": " port) + (display (##sys#slot ex 1) port) ) ) ) ) ) + (let ((args (errargs ex))) + (cond + ((not args)) + ((fx= 1 (length args)) + (display ": " port) + (writeargs args port)) + (else + (newline port) + (writeargs args port))))) + ((string? ex) + (display ": " port) + (display ex port) + (newline port)) + (else + (display ": uncaught exception: " port) + (writeargs (list ex) port) ) ) ) ) ) ) + + +;;; Show exception message and backtrace as warning +;;; (used for threads and finalizers) + +(define ##sys#show-exception-warning + (let ((print-error-message print-error-message) + (display display) + (write-char write-char) + (print-call-chain print-call-chain) + (open-output-string open-output-string) + (get-output-string get-output-string) ) + (lambda (exn cause #!optional (thread ##sys#current-thread)) + (when ##sys#warnings-enabled + (let ((o (open-output-string))) + (display "Warning" o) + (when thread + (display " (" o) + (display thread o) + (write-char #\) o)) + (display ": " o) + (display cause o) + (print-error-message exn ##sys#standard-error (get-output-string o)) + (print-call-chain ##sys#standard-error 0 thread) ) )))) + + ;;; Error hook (called by runtime-system): (define ##sys#error-hook @@ -5456,85 +5536,6 @@ EOF (##sys#make-promise (lambda () obj)))) -;;; Convenient error printing: - -(define print-error-message - (let* ([display display] - [newline newline] - [write write] - [string-append string-append] - [errmsg (condition-property-accessor 'exn 'message #f)] - [errloc (condition-property-accessor 'exn 'location #f)] - [errargs (condition-property-accessor 'exn 'arguments #f)] - [writeargs - (lambda (args port) - (##sys#for-each - (lambda (x) - (##sys#with-print-length-limit 80 (lambda () (write x port))) - (newline port) ) - args) ) ] ) - (lambda (ex . args) - (let-optionals args ([port ##sys#standard-output] - [header "Error"] ) - (##sys#check-output-port port #t 'print-error-message) - (newline port) - (display header port) - (cond [(and (not (##sys#immediate? ex)) (eq? 'condition (##sys#slot ex 0))) - (cond ((errmsg ex) => - (lambda (msg) - (display ": " port) - (let ([loc (errloc ex)]) - (when (and loc (symbol? loc)) - (display (string-append "(" (##sys#symbol->qualified-string loc) ") ") port) ) ) - (display msg port) ) ) - (else - (let ((kinds (##sys#slot ex 1))) - (if (equal? '(user-interrupt) kinds) - (display ": *** user interrupt ***" port) - (begin - (display ": " port) - (display (##sys#slot ex 1) port) ) ) ) ) ) - (and-let* ([args (errargs ex)]) - (if (fx= 1 (length args)) - (begin - (display ": " port) - (writeargs args port) ) - (begin - (newline port) - (writeargs args port) ) ) ) ] - [(string? ex) - (display ": " port) - (display ex port) - (newline port) ] - [else - (display ": uncaught exception: " port) - (writeargs (list ex) port) ] ) ) ) ) ) - - -;;; Show exception message and backtrace as warning -;;; (used for threads and finalizers) - -(define ##sys#show-exception-warning - (let ((print-error-message print-error-message) - (display display) - (write-char write-char) - (print-call-chain print-call-chain) - (open-output-string open-output-string) - (get-output-string get-output-string) ) - (lambda (exn cause #!optional (thread ##sys#current-thread)) - (when ##sys#warnings-enabled - (let ((o (open-output-string))) - (display "Warning" o) - (when thread - (display " (" o) - (display thread o) - (write-char #\) o)) - (display ": " o) - (display cause o) - (print-error-message exn ##sys#standard-error (get-output-string o)) - (print-call-chain ##sys#standard-error 0 thread) ) )))) - - ;;; We need this here so `location' works: (define (##sys#make-locative obj index weak? loc) diff --git a/tests/port-tests.scm b/tests/port-tests.scm index 9211bd7f..bb12da54 100644 --- a/tests/port-tests.scm +++ b/tests/port-tests.scm @@ -1,4 +1,4 @@ -(require-extension data-structures file flonum format io port posix srfi-4 tcp) +(require-extension chicken.condition data-structures file flonum format io port posix srfi-4 tcp) (include "test.scm") (test-begin) diff --git a/types.db b/types.db index 7e685404..9ac85708 100644 --- a/types.db +++ b/types.db @@ -969,6 +969,7 @@ (chicken.condition#get-condition-property (#(procedure #:clean #:enforce) chicken.condition#get-condition-property ((struct condition) * * #!optional *) *)) (chicken.condition#make-composite-condition (#(procedure #:clean #:enforce) chicken.condition#make-composite-condition (#!rest (struct condition)) (struct condition))) (chicken.condition#make-property-condition (#(procedure #:clean #:enforce) chicken.condition#make-property-condition (* #!rest *) (struct condition))) +(chicken.condition#print-error-message (#(procedure #:clean #:enforce) chicken.condition#print-error-message (* #!optional output-port string) undefined)) (chicken.condition#with-exception-handler (#(procedure #:enforce) chicken.condition#with-exception-handler ((procedure (*) . *) (procedure () . *)) . *)) (chicken.condition#signal (procedure chicken.condition#signal (*) . *)) @@ -1282,7 +1283,6 @@ (print (procedure print (#!rest *) undefined)) (print-call-chain (#(procedure #:clean #:enforce) print-call-chain (#!optional output-port fixnum * string) undefined)) -(print-error-message (#(procedure #:clean #:enforce) print-error-message (* #!optional output-port string) undefined)) (print* (procedure print* (#!rest) undefined)) (procedure-information (#(procedure #:clean #:enforce) procedure-information (procedure) *)) (program-name (#(procedure #:clean #:enforce) program-name (#!optional string) string)) -- 2.11.0