1 files changed, 99 insertions, 0 deletions
diff --git a/lisparuga/repl.scm b/lisparuga/repl.scm
new file mode 100644
index 0000000..8951793
--- /dev/null
+++ b/lisparuga/repl.scm
@@ -0,0 +1,99 @@
+;;; Lisparuga
+;;; Copyright © 2020 David Thompson <dthompson2@worcester.edu>
+;;;
+;;; Lisparuga 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.
+;;;
+;;; Lisparuga 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 Lisparuga.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; REPL for live hacking and debugging.
+;;
+;;; Code:
+
+(define-module (lisparuga repl)
+  #:use-module (oop goops)
+  #:use-module (ice-9 match)
+  #:use-module (lisparuga 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)
+    (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>) 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")))