summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--catbird/repl.scm101
1 files changed, 65 insertions, 36 deletions
diff --git a/catbird/repl.scm b/catbird/repl.scm
index 3c56f35..c281411 100644
--- a/catbird/repl.scm
+++ b/catbird/repl.scm
@@ -114,11 +114,32 @@
(beautify-user-module! module)
module))
+(define-class <repl-debug> ()
+ (stack #:accessor stack #:init-keyword #:stack))
+
+(define-class <repl-level> ()
+ (depth #:accessor depth #:init-keyword #:depth #:init-value 0)
+ (language #:accessor language #:init-keyword #:language
+ #:init-value (lookup-language 'scheme))
+ (module #:accessor module #:init-keyword #:module
+ #:init-thunk make-user-module)
+ (debug #:accessor debug #:init-keyword #:debug #:init-value #f))
+
(define-class <repl> (<node-2d>)
- (language #:accessor language #:init-value (lookup-language 'scheme))
- (module #:accessor module #:init-thunk make-user-module)
- (max-line-length #:accessor max-line-length #:init-value 256)
- (log-lines #:accessor log-lines #:init-form (make-ring-buffer 64)))
+ (level #:accessor level #:init-form (make <repl-level>))
+ (level-stack #:accessor level-stack #:init-value '()))
+
+(define-method (language (repl <repl>))
+ (language (level repl)))
+
+(define-method (module (repl <repl>))
+ (module (level repl)))
+
+(define-method (depth (repl <repl>))
+ (depth (level repl)))
+
+(define-method (debug (repl <repl>))
+ (debug (level repl)))
(define-method (initialize (repl <repl>) initargs)
(next-method)
@@ -134,6 +155,17 @@
(log-append repl "Enter ',help' for help.")
(refresh-prompt repl))
+(define-method (push-repl-level (repl <repl>) (new-level <repl-level>))
+ (set! (level-stack repl) (cons (level repl) (level-stack repl)))
+ (set! (level repl) new-level))
+
+(define-method (pop-repl-level (repl <repl>))
+ (match (level-stack repl)
+ (() (detach repl))
+ ((prev . rest)
+ (set! (level repl) prev)
+ (set! (level-stack repl) rest))))
+
(define-method (log-append (repl <repl>) node)
(let ((container (make <margin-container>
#:margin 2.0
@@ -154,9 +186,14 @@
(define-method (refresh-prompt (repl <repl>))
(set! (prompt (& repl editor))
- (format #f "~a@~a> "
- (language-name (language repl))
- (module-name (module repl)))))
+ (if (= (depth repl) 0)
+ (format #f "~a@~a> "
+ (language-name (language repl))
+ (module-name (module repl)))
+ (format #f "~a@~a [~a]> "
+ (language-name (language repl))
+ (module-name (module repl))
+ (depth repl)))))
(define-method (resize-repl (repl <repl>) w h)
(let ((bg (& repl background)))
@@ -188,33 +225,25 @@
(define-method (with-error-handling (repl <repl>) thunk)
(let ((stack #f))
(define (handle-error e)
- (let ((frame (stack-ref stack 0)))
- (log-append repl
- (format #f "~a: In procedure: ~a:"
- (match (frame-source frame)
- ((_ file-name line . column)
- (format #f "~a:~a:~a"
- (if file-name
- (basename file-name)
- "unknown file")
- line column))
- (_ "unknown"))
- (or (frame-procedure-name frame)
- "unknown")))
- (log-append repl
- (format #f "In procedure: ~a: ~a"
- (or (and (exception-with-origin? e)
- (exception-origin e))
- "unknown")
- (if (and (exception-with-message? e)
- (exception-with-irritants? e))
- (apply format #f (exception-message e)
- (exception-irritants e))
- "")))
- (with-output-to-log repl
- (lambda ()
- (display-backtrace stack
- (current-output-port))))))
+ (let* ((key (exception-kind e))
+ (args (exception-args e))
+ (frame (and stack (stack-ref stack 0))))
+ (define (enter-debugger)
+ (print-exception (current-output-port)
+ frame key args)
+ (newline)
+ (display "Entering a new prompt. ")
+ (display "Type `,bt' for a backtrace or `,q' to continue.")
+ (newline)
+ (push-repl-level repl (make <repl-level>
+ #:language (language repl)
+ #:module (module repl)
+ #:depth (+ (depth repl) 1)
+ #:debug (make <repl-debug>
+ #:stack stack)))
+ ;; So nothing gets printed as a return value.
+ *unspecified*)
+ (with-output-to-log repl enter-debugger)))
(define (pre-unwind-handler . args)
(set! stack (make-stack #t 4)))
(define (throw-handler)
@@ -381,7 +410,7 @@
(define-meta-command ((quit q) system repl)
"- Quit program."
- (abort-game))
+ (pop-repl-level repl))
(define-meta-command ((import use) module repl module-name)
"MODULE - Import a module."
@@ -390,7 +419,7 @@
(define-meta-command ((module m) module repl #:optional module-name*)
"[MODULE] - Change current module or show current module."
(if module-name*
- (set! (module repl) (resolve-module module-name*))
+ (set! (module (level repl)) (resolve-module module-name*))
(log-append repl (format #f "~a" (module-name (module repl))))))