From 00dc02757b9fe61a8ad6caa6e4b2c616120c0c2a Mon Sep 17 00:00:00 2001
From: Jan Nieuwenhuizen <janneke@gnu.org>
Date: Sat, 20 Oct 2018 18:24:37 +0200
Subject: [PATCH] mes: Print backtrace upon exception.

* mes/module/mes/catch.mes (display-backtrace,
frame-function): New function.
(%eh): Use them.
---
 mes/module/mes/catch.mes | 15 +++++++++++++++
 tests/catch.test         | 25 ++++++++++++-------------
 2 files changed, 27 insertions(+), 13 deletions(-)

diff --git a/mes/module/mes/catch.mes b/mes/module/mes/catch.mes
index 7048bc3d..9df895fe 100644
--- a/mes/module/mes/catch.mes
+++ b/mes/module/mes/catch.mes
@@ -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)
@@ -54,3 +56,16 @@
     (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)))
diff --git a/tests/catch.test b/tests/catch.test
index a8ed5a25..29ef9f79 100755
--- a/tests/catch.test
+++ b/tests/catch.test
@@ -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)