diff options
| -rw-r--r-- | catbird/repl.scm | 58 |
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 |