summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Makefile.am1
-rw-r--r--guix.scm4
-rw-r--r--starling/kernel.scm47
-rw-r--r--starling/repl.scm95
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 += \
diff --git a/guix.scm b/guix.scm
index 05161db..d2ed68d 100644
--- a/guix.scm
+++ b/guix.scm
@@ -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")))