summaryrefslogtreecommitdiff
path: root/chickadee.scm
diff options
context:
space:
mode:
Diffstat (limited to 'chickadee.scm')
-rw-r--r--chickadee.scm122
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))))))