diff options
| -rw-r--r-- | Makefile.am | 1 | ||||
| -rw-r--r-- | guix.scm | 4 | ||||
| -rw-r--r-- | starling/kernel.scm | 47 | ||||
| -rw-r--r-- | starling/repl.scm | 95 |
4 files changed, 142 insertions, 5 deletions
diff --git a/Makefile.am b/Makefile.am index e80b15e..49313d9 100644 --- a/Makefile.am +++ b/Makefile.am @@ -40,6 +40,7 @@ godir=$(libdir)/guile/$(GUILE_EFFECTIVE_VERSION)/site-ccache SOURCES = \ starling/node.scm \ starling/node-2d.scm \ + starling/repl.scm \ starling/kernel.scm EXTRA_DIST += \ @@ -117,7 +117,7 @@ SDL2 C shared library via the foreign function interface.") (license lgpl3+)))) (define chickadee - (let ((commit "8163e4b415bcf1f6a696ccbf06e3136aea1a261f")) + (let ((commit "7d64cb370bd5abcdaed9215a33bc450c0bb21bf4")) (package (name "chickadee") (version "0.1") @@ -128,7 +128,7 @@ SDL2 C shared library via the foreign function interface.") (commit commit))) (sha256 (base32 - "0wsn01mxvmkgfmc7s97hq5vwi86p5qn0bylxi3ilbp0b7i9g7x50")))) + "1369ij1xyqzjgp7fxsx76h1imhhvj722yvrw6rgv1723rgw5ppcq")))) (build-system gnu-build-system) (arguments '(#:make-flags '("GUILE_AUTO_COMPILE=0") diff --git a/starling/kernel.scm b/starling/kernel.scm index caab692..1ff6b1a 100644 --- a/starling/kernel.scm +++ b/starling/kernel.scm @@ -24,6 +24,7 @@ (define-module (starling kernel) #:use-module (chickadee) + #:use-module (chickadee render gpu) #:use-module (ice-9 match) #:use-module (oop goops) #:use-module (sdl2) @@ -34,6 +35,8 @@ #:use-module (sdl2 mixer) #:use-module (sdl2 video) #:use-module (starling node) + #:use-module (starling repl) + #:use-module (system repl command) #:export (on-quit on-key-press on-key-release @@ -56,6 +59,7 @@ update-hz window gl-context + current-kernel boot-kernel) #:re-export (abort-game)) @@ -106,9 +110,11 @@ (name #:accessor name #:init-form "starling-kernel") (window-config #:accessor window-config #:init-form (make <window-config>)) (update-hz #:accessor update-hz #:init-form 60) + (developer-mode? #:getter developer-mode? #:init-form #t) (window #:accessor window) (gl-context #:accessor gl-context) - (controllers #:accessor controllers #:init-thunk make-hash-table)) + (controllers #:accessor controllers #:init-thunk make-hash-table) + (repl #:accessor repl)) (define current-kernel (make-parameter #f)) @@ -134,6 +140,10 @@ (add-controller kernel i)) (loop (+ i 1))))) +(define-method (on-boot (kernel <kernel>)) + (when (developer-mode? kernel) + (attach-to kernel (make <repl> #:name 'repl #:rank 9999)))) + (define-method (update* (kernel <kernel>) dt) (define (invert-y y) ;; SDL's origin is the top-left, but our origin is the bottom @@ -214,7 +224,7 @@ controller (controller-axis-event-axis event) (/ (controller-axis-event-value event) 32768.0))))))) - ;; Process all pending events. + ;; Process all pending events before we update any other node. (let loop ((event (poll-event))) (when event (process-event event) @@ -222,6 +232,18 @@ ;; Proceed with standard update procedure. (next-method)) +(define-method (update (kernel <kernel>) dt) + ;; Free any GPU resources that have been GC'd. + (gpu-reap!)) + +(define-method (on-error (kernel <kernel>) stack key args) + (if (developer-mode? kernel) + (let ((title (window-title (window kernel)))) + (set-window-title! (window kernel) (string-append "[ERROR] " title)) + (on-error (& kernel repl) stack key args) + (set-window-title! (window kernel) title)) + (apply throw key args))) + (define (boot-kernel kernel first-node) (sdl-init) ;; This will throw an error if any audio subsystem is unavailable, @@ -240,17 +262,36 @@ #:size (list (width wc) (height wc)) #:fullscreen? (fullscreen? wc))) (set! (gl-context kernel) (make-gl-context (window kernel))) + ;; Attempt to activate vsync, if possible. Some systems do + ;; not support setting the OpenGL swap interval. + (catch #t + (lambda () + (set-gl-swap-interval! 'vsync)) + (lambda args + (display "warning: could not enable vsync\n" + (current-error-port)))) (dynamic-wind (const #t) (lambda () (parameterize ((current-kernel kernel)) (attach-to kernel first-node) (activate kernel) - ;; TODO: Add error handler (run-game #:update (lambda (dt) (update* kernel dt)) #:render (lambda (alpha) (render* kernel alpha)) + #:error (lambda (stack key args) + (on-error kernel stack key args)) #:time sdl-ticks #:update-hz (update-hz kernel)))) (lambda () (deactivate kernel) (close-window! (window kernel)))))) + +(define-meta-command ((debug-game starling) repl) + "debug-game +Enter a debugger for the current game loop error." + (debugger (& (current-kernel) repl))) + +(define-meta-command ((resume-game starling) repl) + "resume-game +Resume the game loop without entering a debugger." + (set! (repl-debugging? (& (current-kernel) repl)) #f)) diff --git a/starling/repl.scm b/starling/repl.scm new file mode 100644 index 0000000..994ddbc --- /dev/null +++ b/starling/repl.scm @@ -0,0 +1,95 @@ +;;; Starling Game Engine +;;; Copyright © 2018 David Thompson <davet@gnu.org> +;;; +;;; This program is free software: you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License as +;;; published by the Free Software Foundation, either version 3 of the +;;; License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Starling. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; REPL for live hacking and debugging. +;; +;;; Code: + +(define-module (starling repl) + #:use-module (oop goops) + #:use-module (starling node) + #:use-module (system repl coop-server) + #:use-module (system repl debug) + #:use-module (system repl repl) + #:export (<repl> + repl-server + repl-debug + repl-debugging? + on-error + debugger)) + +(define-class <repl> (<node>) + (repl-server #:accessor repl-server) + (repl-debug #:accessor repl-debug #:init-form #f) + (repl-debugging? #:accessor repl-debugging? #:init-form #f)) + +(define-method (on-boot (repl <repl>)) + (set! (repl-server repl) (spawn-coop-repl-server))) + +(define-method (on-error (repl <repl>) stack key args) + ;; Display backtrace. + (let ((port (current-error-port))) + (display "an error has occurred!\n\n" port) + (display "Backtrace:\n" port) + (display-backtrace stack port) + (newline port) + (apply display-error (stack-ref stack 0) port args) + (newline port)) + ;; 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! (repl-debug repl) (make-debug stack 0 error-string)) + (set! (repl-debugging? repl) #t) + ;; Wait for the user to exit the debugger. + (display "waiting for developer to debug..." (current-error-port)) + (while (repl-debugging? repl) + (poll-coop-repl-server (repl-server repl)) + #t) + (set! (repl-debug repl) #f) + (display " done!\n"))) + +(define-method (update (repl <repl>) dt) + (poll-coop-repl-server (repl-server repl))) + +(define-method (debugger (repl <repl>)) + (if (repl-debug repl) + (begin + (format #t "~a~%" (debug-error-message (repl-debug repl))) + (format #t "Entering a new prompt. ") + (format #t "Type `,bt' for a backtrace or `,q' to resume the game loop.\n") + (start-repl #:debug (repl-debug repl)) + (set! (repl-debugging? repl) #f)) + (display "nothing to debug!\n"))) |