From b1e037442859ecc75a6465022c71b13b87baa7e0 Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson@vistahigherlearning.com>
Date: Sun, 11 Oct 2020 20:49:49 -0400
Subject: repl: Print backtrace on error.

---
 starling/repl.scm | 74 +++++++++++++++++++++++++++++++++++++------------------
 1 file changed, 50 insertions(+), 24 deletions(-)

diff --git a/starling/repl.scm b/starling/repl.scm
index b972b5f..bd8f504 100644
--- a/starling/repl.scm
+++ b/starling/repl.scm
@@ -82,34 +82,60 @@
            (set! (text label) (ring-buffer-ref log i))
            (loop (+ i 1) rest)))))))
 
+(define-method (print-backtrace (repl <repl>) stack)
+  (let loop ((i (- (stack-length stack) 1)))
+    (when (>= i 0)
+      (let ((frame (stack-ref stack i)))
+        (print repl
+               (match (frame-source frame)
+                 ((_ file line . column)
+                  (format #f "~d: In ~a:~%  ~d:~d ~a"
+                          i file line column
+                          (frame-procedure-name frame)))
+                 (#f
+                  (format #f "~d: In unknown file:~%  ~a"
+                          i
+                          (frame-procedure-name frame)))))
+        (loop (- i 1))))))
+
 (define-method (eval-user-text (repl <repl>))
   (let ((result *unspecified*))
-    (values (with-output-to-string
-              (lambda ()
-                (set! result
-                  (let/ec cancel
-                    (start-stack 'repl-stack
-                                 (with-exception-handler (lambda (exception)
-                                                           ;;(backtrace)
-                                                           (display exception)
-                                                           (cancel *unspecified*))
-                                   (lambda ()
-                                     (eval-string (user-text repl)
-                                                  #:module (module repl)))))))))
-            result)))
+    (let/ec cancel
+      (with-exception-handler
+          (lambda (exception)
+            (print repl
+                   (with-output-to-string
+                     (lambda ()
+                       (print-exception (current-output-port) #f
+                                        (exception-kind exception)
+                                        (exception-args exception))
+                       (newline))))
+            (let ((tag (match (fluid-ref %stacks)
+                         ((_ . tag) tag)
+                         (_ 0))))
+              (print-backtrace repl (make-stack #t 3 tag)))
+            (cancel))
+        (lambda ()
+          (print repl
+                 (with-output-to-string
+                   (lambda ()
+                     (start-stack 'repl-stack
+                                  (set! result
+                                    (eval-string (user-text repl)
+                                                 #:module (module repl))))))))))
+    result))
 
 (define-method (eval-and-print (repl <repl>))
-  (call-with-values (lambda () (eval-user-text repl))
-    (lambda (output result)
-      (print repl (text (& repl prompt)))
-      (print repl output)
-      (unless (unspecified? result)
-        (print repl (with-output-to-string
-                      (lambda ()
-                        (display "=> ")
-                        (write result)))))
-      (flush-log repl)
-      (modify-user-text repl ""))))
+  (print repl (text (& repl prompt)))
+  (let ((result (eval-user-text repl)))
+    ;;(print repl output)
+    (unless (unspecified? result)
+      (print repl (with-output-to-string
+                    (lambda ()
+                      (display "=> ")
+                      (write result)))))
+    (flush-log repl)
+    (modify-user-text repl "")))
 
 (define-method (on-boot (repl <repl>))
   (let* ((res (resolution (car (cameras repl))))
-- 
cgit v1.2.3