From 2e5403f74a3ece7568ee77748ec56ee29f99cb7a Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
Date: Fri, 5 Jun 2020 23:21:06 +0200
Subject: Change top error handler.

---
 module/main.scm | 44 ++++++++++++++++++++++----------------------
 1 file changed, 22 insertions(+), 22 deletions(-)

(limited to 'module/main.scm')

diff --git a/module/main.scm b/module/main.scm
index 331268f8..31d6957c 100644
--- a/module/main.scm
+++ b/module/main.scm
@@ -169,29 +169,29 @@
                                  (string->symbol stprof)))))
 
 
-(use-modules (system vm frame))
+(define logport (make-parameter (open-file "/tmp/calp.xml" "a")))
 
 (define (main args)
+
+  (when (zero? (ftell (logport)))
+    (format (logport) "<?xml version=\"1.0\" encoding=\"UTF-8\"?>~%"))
+
+  (format (logport) "<run><start>~a</start>~%"
+          ((@ (datetime util) datetime->string)
+           ((@ (datetime) current-datetime))))
   (report-time! "Program start")
   ;; ((@ (util config) print-configuration-documentation))
-  (with-throw-handler #t
-    (lambda () (dynamic-wind (lambda () 'noop)
-                        (lambda () (catch 'return (lambda () (wrapped-main args)) values))
-                        (lambda () (run-hook shutdown-hook))
-                        ))
-    (lambda (err . args)
-      (define stack (make-stack #t))
-      (with-output-to-port (current-error-port)
-        (lambda ()
-          (format #t "bindings = ")
-          (let loop ((frame (stack-ref stack 0)))
-            (when frame
-              (format #t "~{~a~^ ~}" (map binding-name (frame-bindings frame)))
-              (let ((event (and=> (frame-lookup-binding frame 'event)
-                                  binding-ref)))
-                (when event
-                  (format (current-error-port) "event = ~a~%" event)))
-
-              (loop (frame-previous frame))))
-          (format #t "~%")
-          )))))
+  (let ((stack #f))
+    (catch #t
+      (lambda () (dynamic-wind (lambda () 'noop)
+                          (lambda () (catch 'return (lambda () (wrapped-main args)) values))
+                          (lambda () (run-hook shutdown-hook))
+                          ))
+      (lambda (err raiser fmt . args)
+        (format #t "Calp has crashed with [~a],
+~?~%See ~a for full backtrace~%"
+                err fmt args (port-filename (logport)))
+        (format (logport) "<trace>~%<![CDATA[~%")
+        (display-backtrace stack (logport))
+        (format (logport) "]]></trace></run>~%"))
+      (lambda _ (set! stack (make-stack #t))))))
-- 
cgit v1.2.3