From 94b7c205cff23ec39402fc7a6a12e58877bd962b Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson2@worcester.edu>
Date: Mon, 10 Oct 2022 09:12:06 -0400
Subject: Update error handling to use new exception API.

---
 starling/kernel.scm      |  6 ++---
 starling/repl-server.scm | 65 ++++++++++++++++++++++++------------------------
 2 files changed, 36 insertions(+), 35 deletions(-)

diff --git a/starling/kernel.scm b/starling/kernel.scm
index 6f72b6d..66c1788 100644
--- a/starling/kernel.scm
+++ b/starling/kernel.scm
@@ -320,13 +320,13 @@
           (+ (* (- (elapsed-time) start-time) 0.1)
              (* (avg-frame-time kernel) 0.9)))))
 
-(define-method (on-error (kernel <kernel>) stack key args)
+(define-method (on-error (kernel <kernel>) e stack)
   (if developer-mode?
       (let ((title (sdl2:window-title (window kernel))))
         (sdl2:set-window-title! (window kernel) (string-append "[ERROR] " title))
-        (on-error (& kernel repl-server) stack key args)
+        (on-error (& kernel repl-server) e stack)
         (sdl2:set-window-title! (window kernel) title))
-      (apply throw key args)))
+      (raise-exception e)))
 
 (define-method (on-scenes-empty (kernel <kernel>))
   (abort-game))
diff --git a/starling/repl-server.scm b/starling/repl-server.scm
index b546a0f..2229c29 100644
--- a/starling/repl-server.scm
+++ b/starling/repl-server.scm
@@ -22,6 +22,7 @@
 
 (define-module (starling repl-server)
   #:use-module (oop goops)
+  #:use-module (ice-9 exceptions)
   #:use-module (ice-9 match)
   #:use-module (starling node)
   #:use-module (system repl coop-server)
@@ -42,39 +43,39 @@
 (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))
+(define-method (on-error (repl <repl-server>) e stack)
   ;; 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))
+  (let* ((frame (stack-ref stack 0))
+         (error-string
+          (format #f "~a: In procedure: ~a:~%In procedure: ~a: ~a~%"
+                  (match (frame-source frame)
+                    ((_ file-name line . column)
+                     (format #f "~a:~a:~a"
+                             (if file-name
+                                 (basename file-name)
+                                 "unknown file")
+                             line column))
+                    (_ "unknown"))
+                  (or (frame-procedure-name frame)
+                      "unknown")
+                  (or (and (exception-with-origin? e)
+                           (exception-origin e))
+                      "unknown")
+                  (if (and (exception-with-message? e)
+                           (exception-with-irritants? e))
+                      (apply format #f (exception-message e)
+                             (exception-irritants e))
+                      ""))))
+    ;; 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)
+      (display error-string port)
+      (newline port))
+    (set! (repl-debug repl)
+          (make-debug (narrow-stack->vector stack 0) 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))
-- 
cgit v1.2.3