Begin debugger

scmvm.scm

@@ -1,209 +1,26 @@
 #! /bin/sh
 exec guile -L . -e main -s "$0" "$@"
 !#
-(use-modules (rnrs bytevectors)
-             (ice-9 binary-ports)
-             (ice-9 format)
+
+(use-modules (scmvm vm)
+             (scmvm assembler)
              (srfi srfi-11)
              (srfi srfi-26)
-             (srfi srfi-43)
-             (scmvm vm)
-             (oop goops)
-             (g-golf))
+             (ice-9 control))
 
-(eval-when (expand load eval)
-  (g-irepository-require "Gtk" #:version "4.0")
-  (gi-import-by-name "Gdk" "keyval_name")
-  (for-each (lambda (name)
-              (gi-import-by-name "Gio" name))
-            '("SimpleAction"
-              "SimpleActionGroup"))
-  (for-each (lambda (name) (gi-import-by-name "Gtk" name))
-            '("Application"
-              "ApplicationWindow"
-              "Box"
-              "Button"
-              "CallbackAction"
-              "CssProvider"
-              "EventControllerKey"
-              "FileDialog"
-              "Frame"
-              "Label"
-              "TextView")))
-
-(define *css* "
-.mono {
-	font-family: monospace;
-}")
+(define (make-debugger source asm)
+  ())
 
-(define-syntax-rule (named-lambda lambda-name args body ...)
-  (lambda args #((name . lambda-name)) body ...))
+(define (debug file)
+  (let*-values ([(source) (open-file file)]
+                [(asm) (call-with-output-bytevector (cut assemble-file file <>))]
+                [(begin-debugger resume-debugger) (make-debugger source asm)])
+    (% (begin-debugger)
+       (resume-debugger))))
 
-(define %vm (make-vm #:memory-size 100))
-(define %program #f)
-(define %buffer-label #f)
-(define %selected-nibble 0)
-
-(define (nibble->byte+offset x)
-  (values (quotient x 2)
-          (remainder x 2)))
-
-(define (format-nibble val offset)
-  (string-upcase
-   (number->string
-    (if (zero? offset)
-        (ash val -4)
-        (logand val #x0F))
-    16)))
-
-(define (load-binary port)
-  (set! %program port))
-
-(define (update-memory-view!)
-  (when %buffer-label
-    (define ram (vm-memory %vm))
-    (define text
-      (let-values ([(byte offset) (nibble->byte+offset %selected-nibble)])
-       (vector-fold
-        (lambda (i s val)
-          (string-append
-           s
-           (cond
-            [(or (not (is-focus (get-parent %buffer-label)))
-                 (not (= i byte)))
-             (format #f "~:@(~2'0x~) " val)]
-            [(= offset 0)
-             (format #f "<span background=\"lightblue\">~a</span>~a "
-                     (format-nibble val 0)
-                     (format-nibble val 1))]
-            [(= offset 1)
-             (format #f "~a<span background=\"lightblue\">~a</span> "
-                     (format-nibble val 0)
-                     (format-nibble val 1))])))
-        ""
-        ram)))
-    (set-markup %buffer-label text)))
-
-(define (open-file win cb)
-  (define dialog (make <gtk-file-dialog>))
-  (define (cb-with-port dialog result data)
-    (catch #t
-      (lambda ()
-        (let ([path (open-finish dialog result)])
-          (displayln path)))
-      noop))
-  (open dialog win #f cb-with-port #f))
-
-(define (install-action action-group name callback)
-  (define action (make <g-simple-action> #:name name))
-  (add-action action-group action)
-  (connect action 'activate (lambda (a v) (callback))))
-
-(define (activate app)
-  (newline)
-  ;; Setup window
-  (define win (make <gtk-application-window>
-                #:application app
-                #:title "Scheme Compiler"))
-  (define css-provider (make <gtk-css-provider>))
-  (load-from-string css-provider *css*)
-  (gtk-style-context-add-provider-for-display
-   (gdk-display-get-default) css-provider #xffff)
-  (define box (make <gtk-box>
-                #:orientation 'vertical
-                #:focusable #t))
-  (set-child win box)
-  
-  ;; Setup menu
-  (let ([app-action-group (make <g-simple-action-group>)]
-        [menu (make <g-menu>)]
-        [file-menu (make <g-menu>)])
-    (append file-menu "Open..." "app.open-file")
-    (append-submenu menu "File" file-menu)
-    (set-menubar app menu)
-    (set-show-menubar win #t)
-    (insert-action-group win "app" app-action-group)
-    (install-action
-     app-action-group
-     "open-file"
-     (lambda () (open-file win load-binary))))
-  
-  ;; Setup buffer view
-  (set! %buffer-label (make <gtk-label>
-                        #:css-classes '("mono")
-                        #:wrap #t
-                        #:focusable #t))
-  (set-can-focus %buffer-label #t)
-  (set! %selected-nibble 0)
-  (define frame (make <gtk-frame>
-                  #:focusable #t))
-  (define buffer-controller (make <gtk-event-controller-key>))
-  (gtk-widget-add-controller frame buffer-controller)
-  (connect buffer-controller 'key-pressed handle-key-event)
-  (set-child frame %buffer-label)
-  (append box frame)
-  (grab-focus frame)
-  (update-memory-view!)
-
-  ;; Program view? (no disassembler atm...)
-  (define program-view (make <gtk-text-view>
-                         #:vexpand #t
-                         #:editable #f))
-  (append box program-view)
-
-  (define button-box (make <gtk-box>
-                       #:orientation 'horizontal))
-  (append button-box (make <gtk-button>
-                       #:label "Step"))
-  (append button-box (make <gtk-button>
-                       #:label "Finish"))
-  (append box button-box)
-  
-  ;; Present window
-  (present win))
-
-(define (move-focus . args)
-  (update-memory-view!)
-  #t)
-
-(define (handle-key-event e val code mod)
-  (let ([val (gdk-keyval-name val)])
-    (if
-     (cond
-       [(string= val "Left")
-        (set! %selected-nibble (max (1- %selected-nibble) 0))
-        #t]
-       [(string= val "Right")
-        (set! %selected-nibble (min (1+ %selected-nibble) 199))
-        #t]
-       [(string->number val 16)
-        (let-values ([(byte offset) (nibble->byte+offset %selected-nibble)]
-                     [(val) (string->number val 16)])
-          (vm-memory-set! %vm byte
-                          (if (zero? offset)
-                              (+ (logand (vm-memory-ref %vm byte) #x0f) (ash val 4))
-                              (+ (logand (vm-memory-ref %vm byte) #xf0) val))))
-        #t]
-       [else #f])
-     (begin (update-memory-view!) #t)
-     #f)))
-
-
-
-(define* (main #:optional args)
-  (define app (make <gtk-application>))
-  (connect app 'activate activate)
-  (let ([status (run app args)])
-    (exit status)))
-
-;;; DEBUG
-(use-modules (ice-9 threads))
-(define (debug)
-  (define app (make <gtk-application>))
-  (connect app 'activate activate)
-  (begin-thread
-   (run app '())))
-
-;; Local Variables:
-;; mode: scheme
-;; End:
+(define (main . args)
+  (when (null? args)
+    (usage))
+  (case (car args)
+    [(help) (usage)]
+    [(debug) (apply debug (cdr args))]))

scmvm/assembler.scm

@@ -5,7 +5,7 @@
   #:use-module (rnrs io ports)
   #:use-module ((scheme base)
                 #:select (write-u8 write-bytevector))
-  #:export (assemble))
+  #:export (assemble assemble-file))
 
 (define (lookup-instruction inst)
   (define inst-obj (assq inst *instruction-set*))
@@ -55,3 +55,12 @@
                   (write-word (cadr inst))
                   (write-word (assq-ref labels (cadr inst)))))
             (loop (cdr seq)))])))))
+
+(define (assemble-file file out)
+  (call-with-input-file file
+    (lambda (in)
+      (define (read-all next)
+        (if (eof-object? next)
+            '()
+            (cons next (read-all (read in)))))
+      (assemble (read-all (read in)) out))))

scmvm/vm.scm

@@ -127,7 +127,7 @@
 
 
 ;;; Execution
-(define* (make-vm #:key stack-size memory-size)
+(define* (make-vm #:key stack-size memory-size debugger)
   "Create a fresh VM, with optional stack and memory sizes"
   (define data-stack (if stack-size (make-stack stack-size) (make-stack)))
   (define ret-stack (if stack-size (make-stack stack-size) (make-stack)))
@@ -157,6 +157,8 @@
   (define (fetch-and-execute)
     (define exit? #f)
     (let lp ([op (fetch-byte)])
+      (when debugger
+        (debugger))
       (case (op-lookup op)
         [(push)
          (push data-stack (fetch-word))]