summaryrefslogtreecommitdiff
path: root/starling/repl-server.scm
diff options
context:
space:
mode:
Diffstat (limited to 'starling/repl-server.scm')
-rw-r--r--starling/repl-server.scm99
1 files changed, 99 insertions, 0 deletions
diff --git a/starling/repl-server.scm b/starling/repl-server.scm
new file mode 100644
index 0000000..b546a0f
--- /dev/null
+++ b/starling/repl-server.scm
@@ -0,0 +1,99 @@
+;;; 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 server for live hacking and debugging from Emacs or whatever.
+;;
+;;; Code:
+
+(define-module (starling repl-server)
+ #:use-module (oop goops)
+ #:use-module (ice-9 match)
+ #:use-module (starling node)
+ #:use-module (system repl coop-server)
+ #:use-module (system repl debug)
+ #:use-module (system repl repl)
+ #:export (<repl-server>
+ repl-server
+ repl-debug
+ repl-debugging?
+ on-error
+ debugger))
+
+(define-class <repl-server> (<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-server>))
+ (set! (repl-server repl) (spawn-coop-repl-server)))
+
+(define-method (on-error (repl <repl-server>) 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)
+ (match args
+ ((subr message . args)
+ (display-error (stack-ref stack 0) port subr message 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))
+ (usleep 160000)
+ #t)
+ (set! (repl-debug repl) #f)
+ (display " done!\n")))
+
+(define-method (update (repl <repl-server>) dt)
+ (poll-coop-repl-server (repl-server repl)))
+
+(define-method (debugger (repl <repl-server>))
+ (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")))