mes: Print backtrace upon exception.

* mes/module/mes/catch.mes (display-backtrace,
frame-function): New function.
(%eh): Use them.

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)))

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"
-    (pass-if-equal "catch feel"
+               1
-        1
+               (catch 'twenty-two
-      (let ((save-exit exit))
+                 (lambda _
-        (set! exit (lambda (x)
+                   (catch 'boo
-                     (set! exit save-exit)
+                     (lambda ()
-                     1))
+                       (throw-22)
-        (catch 'boo
+                       11)
-          (lambda ()
+                     (lambda (key . args)
-            (throw-22)
+                       (exit 1))))
-            11)
+                 (lambda (key . args)
-          (lambda (key . args)
+                   1)))
-            22)))))
 
 (result 'report)