diff options
| -rw-r--r-- | chickadee.scm | 138 |
1 files changed, 73 insertions, 65 deletions
diff --git a/chickadee.scm b/chickadee.scm index f847915..e59ba12 100644 --- a/chickadee.scm +++ b/chickadee.scm @@ -44,6 +44,7 @@ controller-press-hook controller-release-hook controller-move-hook + error-handler run-game abort-game time)) @@ -65,6 +66,10 @@ (define controller-press-hook (make-hook 2)) (define controller-release-hook (make-hook 2)) (define controller-move-hook (make-hook 3)) +(define error-handler (lambda args (apply throw args))) + +(define-syntax-rule (with-error-handling body ...) + (catch #t (lambda () body ...) error-handler)) (define open-controller (@@ (chickadee input controller) open-controller)) (define close-controller (@@ (chickadee input controller) close-controller)) @@ -90,66 +95,67 @@ ;; left so we need to invert Y coordinates that SDL gives us. (- window-height y)) (define (process-event event) - (cond - ((quit-event? event) - (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))) - ((keyboard-up-event? 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))) - ((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)))) - ((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)))) - ((mouse-motion-event? event) - (run-hook mouse-move-hook - (mouse-motion-event-x event) - (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)))) - ((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) - (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))) - ((controller-button-up-event? 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))))) + (with-error-handling + (cond + ((quit-event? event) + (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))) + ((keyboard-up-event? 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))) + ((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)))) + ((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)))) + ((mouse-motion-event? event) + (run-hook mouse-move-hook + (mouse-motion-event-x event) + (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)))) + ((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) + (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))) + ((controller-button-up-event? 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)))))) (with-window window (let ((update-interval (round (/ 1000 update-hz))) (default-viewport @@ -162,7 +168,7 @@ (sigaction SIGINT (lambda (signum) (abort-game))) - (run-hook load-hook) + (with-error-handling (run-hook load-hook)) (let loop ((previous-time (sdl-ticks)) (lag 0)) (let* ((current-time (sdl-ticks)) @@ -176,22 +182,24 @@ (process-event event) (loop (poll-event)))) ;; Advance the simulation. - (run-hook update-hook update-interval) + (with-error-handling + (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) + (with-error-handling (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)))) + (with-error-handling + (run-hook draw-hook (/ lag update-interval))))) (swap-buffers window) - (run-hook after-draw-hook) + (with-error-handling (run-hook after-draw-hook)) (loop current-time lag))))))) (lambda (cont callback) #f)))))) |