summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--starling/repl.scm74
1 files 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))))