repl: Add ,bt command and better stack narrowing.

1 files changed, 51 insertions, 7 deletions

diff --git a/catbird/repl.scm b/catbird/repl.scm
index 98798e6..1a77aa9 100644
--- a/catbird/repl.scm
+++ b/catbird/repl.scm
@@ -42,7 +42,9 @@
   #:use-module (srfi srfi-9)
   #:use-module (system base compile)
   #:use-module (system base language)
+  #:use-module (system vm frame)
   #:use-module (system vm loader)
+  #:use-module (system vm program)
   #:export (<repl>
             <repl-mode>
             resize-repl
@@ -51,6 +53,8 @@
 ;; TODO: $number values like regular Guile REPL
 ;; TODO: Debugger
 ;; TODO: Switching languages
+;; TODO: Describe, apropos commands
+;; TODO: <node-2d> printer
 
 
 ;;;
@@ -246,12 +250,23 @@
                                   #:debug (make <repl-debug>
                                             #:stack stack)))
           ;; So nothing gets printed as a return value.
-          *unspecified*)
+          (values))
         (with-output-to-log repl enter-debugger)))
     (define (pre-unwind-handler . args)
-      (set! stack (make-stack #t 4)))
+      ;; Get stack tag.
+      (let ((tag (and (pair? (fluid-ref %stacks))
+                      (cdr (fluid-ref %stacks)))))
+        (set! stack (make-stack #t
+                                ;; Remove 3 inner stack frames added by the
+                                ;; error handling code.
+                                3
+                                ;; Remove outer stack frames up to the
+                                ;; start of the most recent stack.
+                                tag))))
     (define (throw-handler)
-      (with-throw-handler #t thunk pre-unwind-handler))
+      (with-throw-handler #t
+        (lambda () (start-stack #t (thunk)))
+        pre-unwind-handler))
     (define (exception-handler e)
       (if (quit-exception? e)
           (raise-exception e)
@@ -269,14 +284,12 @@
     (save-module-excursion
      (lambda ()
        (set-current-module (module repl))
-       (call-with-values thunk list))))
+       (call-with-values (lambda () (with-error-handling repl thunk)) list))))
   (define (compile-line)
     (append-map (lambda (exp)
                   (compile-and-eval exp))
                 (repl-read-expressions repl line)))
-  (with-error-handling repl
-    (lambda ()
-      (with-output-to-log repl compile-line))))
+  (with-output-to-log repl compile-line))
 
 (define-method (write-value-to-log (repl <repl>) x)
   (unless (unspecified? x)
@@ -435,6 +448,37 @@
       (set! (module (level repl)) (resolve-module module-name*))
       (log-append repl (format #f "~a" (module-name (module repl))))))
 
+(define-meta-command ((backtrace bt) debug repl)
+  "Print a backtrace."
+  (let ((dbg (debug repl)))
+    (if dbg
+        (let ((stack (stack dbg)))
+          (let loop ((i (- (stack-length stack) 1))
+                     (prev-file ""))
+            (when (>= i 0)
+              (let* ((frame (stack-ref stack i))
+                     (source (frame-source frame))
+                     (file (or (and source (source:file source)) "<unknown port>")))
+                (unless (string=? file prev-file)
+                  (log-append repl (format #f "In ~a:" file)))
+                (if source
+                    (let ((text (format #f "  ~a:~a ~a ~a"
+                                        (source:line-for-user source)
+                                        (source:column source)
+                                        i
+                                        (frame-call-representation frame)))
+                          (uri (format #f "file://~a:~a:~a"
+                                       (%search-load-path file)
+                                       (source:line-for-user source)
+                                       (source:column source))))
+                      (log-append repl (make <link>
+                                         #:uri uri
+                                         #:text text)))
+                    (log-append repl (format #f "      ~a ~a" i
+                                             (frame-procedure-name frame))))
+                (loop (- i 1) file)))))
+        (log-append repl "not in a debugger"))))
+
 
 ;;;
 ;;; REPL major mode