Per Felix and Peter's recent proposal.
That post also mentions an "error-message" procedure that should be
moved, but I'm not sure what that refers to so haven't included it (is
that possibly a mistake, or maybe something that we decided to add to
the standard library but haven't gotten to yet?).
Cheers,
Evan
>From 8ba4d813fd20a7eb214e41fbfdf81674070ab91a Mon Sep 17 00:00:00 2001
From: Evan Hanson <ev...@foldling.org>
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 ": <condition> " 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 ": <condition> " 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
_______________________________________________
Chicken-hackers mailing list
Chicken-hackers@nongnu.org
https://lists.nongnu.org/mailman/listinfo/chicken-hackers
