diff options
Diffstat (limited to 'chickadee.scm')
| -rw-r--r-- | chickadee.scm | 122 |
1 files changed, 75 insertions, 47 deletions
diff --git a/chickadee.scm b/chickadee.scm index 3e9a4dc..e604113 100644 --- a/chickadee.scm +++ b/chickadee.scm @@ -44,6 +44,7 @@ controller-press-hook controller-release-hook controller-move-hook + error-hook run-game abort-game time)) @@ -65,6 +66,7 @@ (define controller-press-hook (make-hook 2)) (define controller-release-hook (make-hook 2)) (define controller-move-hook (make-hook 3)) +(define error-hook (make-hook 1)) (define open-controller (@@ (chickadee input controller) open-controller)) (define close-controller (@@ (chickadee input controller) close-controller)) @@ -72,6 +74,32 @@ (define game-loop-prompt-tag (make-prompt-tag 'game-loop)) +(define (display-game-loop-error stack key args) + (let ((port (current-error-port))) + (display "Backtrace:\n" port) + (display-backtrace stack port) + (newline port) + (apply display-error (stack-ref stack 0) port args) + (newline port))) + +(define (call-with-error-handling thunk) + (let ((stack #f)) + (catch #t + thunk + (lambda (key . args) + (if (hook-empty? error-hook) + (apply throw key args) + (begin + (display-game-loop-error stack key args) + (run-hook error-hook stack)))) + (lambda (key . args) + (set! stack (make-stack #t 3)))))) + +(define-syntax-rule (run-hook* args ...) + (call-with-error-handling + (lambda () + (run-hook args ...)))) + (define* (run-game #:key (window-title "Chickadee!") (window-width 640) @@ -92,64 +120,64 @@ (define (process-event event) (cond ((quit-event? event) - (run-hook quit-hook)) + (run-hook* quit-hook)) ((keyboard-down-event? event) - (run-hook key-press-hook - (keyboard-event-key event) - (keyboard-event-scancode event) - (keyboard-event-modifiers event) - (keyboard-event-repeat? event))) + (run-hook* key-press-hook + (keyboard-event-key event) + (keyboard-event-scancode event) + (keyboard-event-modifiers event) + (keyboard-event-repeat? event))) ((keyboard-up-event? event) - (run-hook key-release-hook - (keyboard-event-key event) - (keyboard-event-scancode event) - (keyboard-event-modifiers event))) + (run-hook* key-release-hook + (keyboard-event-key event) + (keyboard-event-scancode event) + (keyboard-event-modifiers event))) ((text-input-event? event) - (run-hook text-input-hook (text-input-event-text event))) + (run-hook* text-input-hook (text-input-event-text event))) ((mouse-button-down-event? event) - (run-hook mouse-press-hook - (mouse-button-event-button event) - (mouse-button-event-clicks event) - (mouse-button-event-x event) - (invert-y (mouse-button-event-y event)))) + (run-hook* mouse-press-hook + (mouse-button-event-button event) + (mouse-button-event-clicks event) + (mouse-button-event-x event) + (invert-y (mouse-button-event-y event)))) ((mouse-button-up-event? event) - (run-hook mouse-release-hook - (mouse-button-event-button event) - (mouse-button-event-x event) - (invert-y (mouse-button-event-y event)))) + (run-hook* mouse-release-hook + (mouse-button-event-button event) + (mouse-button-event-x event) + (invert-y (mouse-button-event-y event)))) ((mouse-motion-event? event) - (run-hook mouse-move-hook - (mouse-motion-event-x event) - (invert-y (mouse-motion-event-y event)) - (mouse-motion-event-x-rel event) - (- (mouse-motion-event-y-rel event)) - (mouse-motion-event-buttons event))) + (run-hook* mouse-move-hook + (mouse-motion-event-x event) + (invert-y (mouse-motion-event-y event)) + (mouse-motion-event-x-rel event) + (- (mouse-motion-event-y-rel event)) + (mouse-motion-event-buttons event))) ((and (controller-device-event? event) (eq? (controller-device-event-action event) 'added)) - (run-hook controller-add-hook - (open-controller (controller-device-event-which event)))) + (run-hook* controller-add-hook + (open-controller (controller-device-event-which event)))) ((and (controller-device-event? event) (eq? (controller-device-event-action event) 'removed)) (let ((controller (lookup-controller (controller-device-event-which event)))) - (run-hook controller-remove-hook controller) + (run-hook* controller-remove-hook controller) (close-controller controller))) ((controller-button-down-event? event) - (run-hook controller-press-hook - (lookup-controller - (controller-button-event-which event)) - (controller-button-event-button event))) + (run-hook* controller-press-hook + (lookup-controller + (controller-button-event-which event)) + (controller-button-event-button event))) ((controller-button-up-event? event) - (run-hook controller-release-hook - (lookup-controller - (controller-button-event-which event)) - (controller-button-event-button event))) + (run-hook* controller-release-hook + (lookup-controller + (controller-button-event-which event)) + (controller-button-event-button event))) ((controller-axis-event? event) - (run-hook controller-move-hook - (lookup-controller - (controller-axis-event-which event)) - (controller-axis-event-axis event) - (/ (controller-axis-event-value event) 32768.0))))) + (run-hook* controller-move-hook + (lookup-controller + (controller-axis-event-which event)) + (controller-axis-event-axis event) + (/ (controller-axis-event-value event) 32768.0))))) (with-window window (let ((update-interval (round (/ 1000 update-hz))) (default-viewport @@ -162,7 +190,7 @@ (sigaction SIGINT (lambda (signum) (abort-game))) - (run-hook load-hook) + (run-hook* load-hook) (let loop ((previous-time (sdl-ticks)) (lag 0)) (let* ((current-time (sdl-ticks)) @@ -176,22 +204,22 @@ (process-event event) (loop (poll-event)))) ;; Advance the simulation. - (run-hook update-hook update-interval) + (run-hook* update-hook update-interval) ;; Free any GPU resources that have been GC'd. (gpu-reap!) (update-loop (- lag update-interval))) (begin ;; Render a frame. - (run-hook before-draw-hook) + (run-hook* before-draw-hook) ;; Switch to the null viewport to ensure that ;; the default viewport will be re-applied and ;; clear the screen. (gpu-state-set! *viewport-state* null-viewport) (with-viewport default-viewport (with-projection default-projection - (run-hook draw-hook (/ lag update-interval)))) + (run-hook* draw-hook (/ lag update-interval)))) (swap-buffers window) - (run-hook after-draw-hook) + (run-hook* after-draw-hook) (loop current-time lag))))))) (lambda (cont callback) #f)))))) |