~ chicken-core (chicken-5) 5efc89a4687e0a11fbcb5342b07d1d8cf1a7de49
commit 5efc89a4687e0a11fbcb5342b07d1d8cf1a7de49
Author: felix <felix@y.(none)>
AuthorDate: Sun Aug 22 23:41:42 2010 +0200
Commit: felix <felix@y.(none)>
CommitDate: Sun Aug 22 23:41:42 2010 +0200
fetch call-chain in exception-handler and print that one in the REPL's error message (suggested by Commander Keen)
diff --git a/csi.scm b/csi.scm
index 704cb6cc..d70301ab 100644
--- a/csi.scm
+++ b/csi.scm
@@ -670,7 +670,11 @@ EOF
(let loop ((props (##sys#slot x 2)))
(unless (null? props)
(when (eq? k (caar props))
- (fprintf out "\t~s: ~s~%" (cdar props) (cadr props)) )
+ (##sys#with-print-length-limit
+ 100
+ (lambda ()
+ (fprintf out "\t~s: ~s" (cdar props) (cadr props)) ))
+ (newline out))
(loop (cddr props)) ) ) )
(##sys#slot x 1) ) ]
[(and (##sys#structure? x 'meroon-instance) (provided? 'meroon)) ; XXX put this into meroon egg (really!)
diff --git a/eval.scm b/eval.scm
index 400b60e2..4b724679 100644
--- a/eval.scm
+++ b/eval.scm
@@ -1540,7 +1540,15 @@
(##sys#write-char-0 #\newline ##sys#standard-error)
(write-err args) ) )
(set! ##sys#repl-recent-call-chain
- (print-call-chain ##sys#standard-error))
+ (or (and-let* ((lexn ##sys#last-exception) ;XXX not really right
+ ((##sys#structure? lexn 'condition))
+ (a (member '(exn . call-chain) (##sys#slot lexn 2))))
+ (let ((ct (cadr a)))
+ (##sys#really-print-call-chain
+ ##sys#standard-error ct
+ "\n\tCall history:\n")
+ ct))
+ (print-call-chain ##sys#standard-error)))
(flush-output ##sys#standard-error) ) ) )
(lambda ()
(let loop ()
diff --git a/library.scm b/library.scm
index a6961e6f..dc019efb 100644
--- a/library.scm
+++ b/library.scm
@@ -3579,6 +3579,7 @@ EOF
[else '(exn)] )
(list '(exn . message) msg
'(exn . arguments) args
+ '(exn . call-chain) (##sys#get-call-chain)
'(exn . location) loc) ) ) ) ] ) )
(define (##sys#abort x)
Trap