summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--catbird/repl.scm58
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