From ce963c498c09622d6cdd59e8adaef6307d9e2b8d Mon Sep 17 00:00:00 2001
From: Dane Johnson <daneallenjohnson@protonmail.com>
Date: Sun, 15 Jun 2025 13:02:56 -0500
Subject: [PATCH] Better breakpoints

---
 scmvm/debugger.scm | 63 +++++++++++++++++++++++++++-------------------
 1 file changed, 37 insertions(+), 26 deletions(-)

diff --git a/scmvm/debugger.scm b/scmvm/debugger.scm
index 51ae903..2e427d2 100644
--- a/scmvm/debugger.scm
+++ b/scmvm/debugger.scm
@@ -1,16 +1,17 @@
 (define-module (scmvm debugger)
   #:use-module (scmvm assembler)
   #:use-module (scmvm vm)
+  #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
   #:use-module (ice-9 control)
   #:use-module (ice-9 binary-ports)
   #:use-module (ice-9 exceptions)
-  #:export ((make-debugger* . make-debugger)
-            debugger-vm
-            debugger-source
+  #:use-module (ice-9 match)
+  #:export ((make-debugger* . make-debugger) debugger-vm debugger-source
             debugger-breakpoints debugger-breakpoints-set!
             debugger-breakpoint-add! debugger-breakpoint-ref
             debugger-breakpoint-enable! debugger-breakpoint-disable!
+            debugger-breakpoint-delete!
             debugger-continue))
 
 (define-record-type <debugger>
@@ -18,9 +19,29 @@
   debugger?
   (vm debugger-vm)
   (source debugger-source)
-  (breakpoints debugger-breakpoints debugger-breakpoints-set!)
+  (breakpoints debugger-breakpoints)
   (continuation debugger-continuation debugger-continuation-set!))
 
+(define (make-breakpoints labels)
+  (define the-breakpoints '())
+  (define (->index index/label)
+    (if (number? index/label)
+        index/label
+        (assq-ref labels index/label)))
+  (define-syntax-rule (ilambda (i) e ...)
+    (lambda (v) (let ([i (->index v)]) e ...)))
+  (match-lambda
+    ['add
+     (ilambda (i) (set! the-breakpoints (acons i #t the-breakpoints)))]
+    ['delete
+     (ilambda (i) (set! the-breakpoints (assq-remove! the-breakpoints i)))]
+    ['enable
+     (ilambda (i) (set! the-breakpoints (assq-set! the-breakpoints i #t)))]
+    ['disable
+     (ilambda (i) (set! the-breakpoints (assq-set! the-breakpoints i #f)))]
+    ['ref
+     (ilambda (i) (assq-ref the-breakpoints i))]))
+
 (define (make-debugger* source)
   (define-values (prgm symbols)
     (call-with-values open-bytevector-output-port
@@ -30,39 +51,29 @@
   (define the-debugger #f)
   (define (debug)
     (shift k
-           (debugger-continuation-set! the-debugger k)
-           (when (not (assq-ref (debugger-breakpoints the-debugger)
-                                (vm-pc (debugger-vm the-debugger))))
-             (k))))
+      (if (((debugger-breakpoints the-debugger) 'ref) (vm-pc (debugger-vm the-debugger)))
+          (debugger-continuation-set! the-debugger k)
+          (k))))
   (define vm (make-vm #:debugger debug))
   (vm-load-program! vm prgm)
-  (set! the-debugger (make-debugger vm source '((1 . #t)) #f))
+  (set! the-debugger (make-debugger vm source (make-breakpoints symbols) #f))
   (reset (run-vm vm))
   the-debugger)
 
 (define (debugger-continue debugger)
   ((debugger-continuation debugger)))
 
-(define* (debugger-breakpoint-add! debugger breakpoint #:key (enabled? #f))
-  (debugger-breakpoints-set!
-   debugger
-   (assq-set! (debugger-breakpoints debugger) breakpoint enabled?)))
+(define (debugger-breakpoint-add! debugger breakpoint)
+  (((debugger-breakpoints debugger) 'add) breakpoint))
 
 (define (debugger-breakpoint-ref debugger breakpoint)
-  (assq breakpoint (debugger-breakpoints debugger)))
+  (((debugger-breakpoints debugger) 'ref) breakpoint))
 
 (define (debugger-breakpoint-enable! debugger breakpoint)
-  (define breakpoints (debugger-breakpoints debugger))
-  (if (pair? (assq breakpoints breakpoint))
-      (assq-set! breakpoints breakpoint #t)
-      (raise-exception (make-exception
-                        (make-error)
-                        (make-exception-with-message "Cannot enable nonexistant breakpoint")))))
+  (((debugger-breakpoints debugger) 'enable) breakpoint))
 
 (define (debugger-breakpoint-disable! debugger breakpoint)
-  (define breakpoints (debugger-breakpoints debugger))
-  (if (pair? (assq breakpoints breakpoint))
-      (assq-set! breakpoints breakpoint #f)
-      (raise-exception (make-exception
-                        (make-error)
-                        (make-exception-with-message "Cannot disable nonexistant breakpoint")))))
+  (((debugger-breakpoints debugger) 'disable) breakpoint))
+
+(define (debugger-breakpoint-delete! debugger breakpoint)
+  (((debugger-breakpoints debugger) 'delete) breakpoint))