mes: Print backtrace upon exception.
authorJan Nieuwenhuizen <janneke@gnu.org>
Sat, 20 Oct 2018 16:24:37 +0000 (18:24 +0200)
committerJan Nieuwenhuizen <janneke@gnu.org>
Sat, 20 Oct 2018 16:24:37 +0000 (18:24 +0200)
* mes/module/mes/catch.mes (display-backtrace,
frame-function): New function.
(%eh): Use them.

mes/module/mes/catch.mes
tests/catch.test

index 7048bc3d72b78e0a94c38f42c4ed8e750a94e29d..9df895fed4e02cb66df17be8da320472846f3f40 100644 (file)
@@ -31,6 +31,8 @@
                      (core:display-error ":")
                      (core:write-error args)
                      (core:display-error "\n")))
+               (core:display-error "Backtrace:\n")
+               (display-backtrace (make-stack) (current-error-port))
                (exit 1))))
 
 (define (catch key thunk handler)
     (apply handler (cons key args))))
 
 (define with-throw-handler catch) ; FIXME: hack for Nyacc 0.75
+
+(define (frame-procedure frame)
+  (struct-ref frame 3))
+
+(define (display-backtrace stack port . rest)
+  (let* ((frames (map (lambda (i) (stack-ref stack i)) (iota (stack-length stack))))
+         (call-frames (filter frame-procedure frames))
+         (display-frames (drop-right call-frames 2)))
+    (for-each (lambda (f)
+                (core:display-error "  ")
+                (core:display-error f)
+                (core:display-error "\n"))
+              display-frames)))
index a8ed5a25453c1f3c5b782647e217c9ef41dc9cef..29ef9f79a1b863ca82669c46c4e85bf5abf0a007 100755 (executable)
@@ -54,18 +54,17 @@ exec ${MES-src/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
     (lambda (key . args)
       789)))
 
-(if mes?
-    (pass-if-equal "catch feel"
-        1
-      (let ((save-exit exit))
-        (set! exit (lambda (x)
-                     (set! exit save-exit)
-                     1))
-        (catch 'boo
-          (lambda ()
-            (throw-22)
-            11)
-          (lambda (key . args)
-            22)))))
+(pass-if-equal "catch feel"
+               1
+               (catch 'twenty-two
+                 (lambda _
+                   (catch 'boo
+                     (lambda ()
+                       (throw-22)
+                       11)
+                     (lambda (key . args)
+                       (exit 1))))
+                 (lambda (key . args)
+                   1)))
 
 (result 'report)