diff options
author | David Thompson <dthompson2@worcester.edu> | 2022-10-08 09:24:43 -0400 |
---|---|---|
committer | David Thompson <dthompson2@worcester.edu> | 2022-10-08 09:24:43 -0400 |
commit | f782e70390525fa2e5bfdf8e2ff249ece1640a98 (patch) | |
tree | f32636a96e590ec98d52d72c7e86ecc70ab18c45 /chickadee | |
parent | 1578a7025c3c70cbbdb110aa42125c9acb57aeda (diff) |
Update error handling to use Guile's new exception API.
Diffstat (limited to 'chickadee')
-rw-r--r-- | chickadee/cli/play.scm | 45 | ||||
-rw-r--r-- | chickadee/game-loop.scm | 23 |
2 files changed, 33 insertions, 35 deletions
diff --git a/chickadee/cli/play.scm b/chickadee/cli/play.scm index 7745008..4e18b31 100644 --- a/chickadee/cli/play.scm +++ b/chickadee/cli/play.scm @@ -21,6 +21,7 @@ #:use-module (chickadee async-repl) #:use-module (chickadee cli) #:use-module (chickadee config) + #:use-module (ice-9 exceptions) #:use-module (ice-9 format) #:use-module (ice-9 match) #:use-module (srfi srfi-1) @@ -195,29 +196,24 @@ Resume the game loop without entering a debugger." (repl-opt (set! repl (make-async-repl)) (start-async-repl repl abort-game))))))))) - (define (handle-error stack key args) + (define (handle-error e stack) ;; Setup the REPL debug object. - (let* ((tag (and (pair? (fluid-ref %stacks)) - (cdr (fluid-ref %stacks)))) - (stack (narrow-stack->vector - stack - ;; Take the stack from the given frame, cutting 0 - ;; frames. - 0 - ;; Narrow the end of the stack to the most recent - ;; start-stack. - ;;tag - ;; And one more frame, because %start-stack - ;; invoking the start-stack thunk has its own frame - ;; too. - 0 (and tag 1) - )) - (error-string (call-with-output-string - (lambda (port) - (let ((frame (and (< 0 (vector-length stack)) - (vector-ref stack 0)))) - (print-exception port frame key args)))))) - (set! debug (make-debug stack 0 error-string)) + (let* ((frame (stack-ref stack 0)) + (error-string + (format #f "~a: In procedure: ~a:~%In procedure: ~a: ~a~%" + (match (frame-source frame) + ((_ file-name line . column) + (format #f "~a:~a:~a" (basename file-name) line column)) + (_ "unknown")) + (frame-procedure-name frame) + (if (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)) + "")))) + (set! debug (make-debug (narrow-stack->vector stack 0) 0 error-string)) ;; Just update the REPL endlessly until the developer says to ;; resume. (let* ((window (current-window)) @@ -264,7 +260,10 @@ Resume the game loop without entering a debugger." button) #:controller-move (trampoline controller-move controller axis value) - #:error (if repl handle-error #f)) + #:error (if (or (assq-ref opts 'repl) + (assq-ref opts 'repl-server)) + handle-error + #f)) (when (async-repl? repl) (close-async-repl repl)))) diff --git a/chickadee/game-loop.scm b/chickadee/game-loop.scm index 76e649a..d0bd287 100644 --- a/chickadee/game-loop.scm +++ b/chickadee/game-loop.scm @@ -26,17 +26,19 @@ ;;; (define (call-with-error-handling handler thunk) + "Call THUNK and respond to any exceptions with HANDLER. Return #t if +an error was handled." (if handler (let ((stack #f)) - (catch #t - (lambda () - (thunk) - #f) - (lambda (key . args) - (handler stack key args) - #t) - (lambda (key . args) - (set! stack (make-stack #t 3))))) + (define (pre-unwind-handler . args) + (set! stack (make-stack #t 4))) + (define (throw-handler) + (with-throw-handler #t thunk pre-unwind-handler) + #f) + (define (exception-handler e) + (handler e stack) + #t) + (with-exception-handler exception-handler throw-handler #:unwind? #t)) (begin (thunk) #f))) @@ -44,9 +46,6 @@ (define-syntax-rule (with-error-handling handler body ...) (call-with-error-handling handler (lambda () body ...))) -(define (default-error-handler stack key args) - (apply throw key args)) - ;;; ;;; Game loop kernel |