Beginnings of a debugger

scmvm.scm

@@ -1,36 +1,69 @@
 #! /bin/sh
 exec guile -L . -e main -s "$0" "$@"
 !#
-(use-modules (ice-9 getopt-long)
+(use-modules (rnrs bytevectors)
+             (ice-9 binary-ports)
+             (srfi srfi-26)
              (scmvm vm))
 
-(define *options-spec*
-  '((output (single-char #\o)
-            (value #t))
-    (help (single-char #\h)
-          (value #f))
-    (stack-size (value #t))
-    (memory-size (value #t))))
+(define the-vm #f)
+(define the-program #f)
 
-(define parse-options
-  (lambda (options)
-    (getopt-long options *options-spec*)))
+(define (load-binary port)
+  (set! the-vm (make-vm))
+  (set! the-program port))
 
-(define (usage)
-  (format #t "Usage: scmvm.scm [-o outfile] mode infile
-Compile or run Scheme programs
+(eval-when (expand load eval)
+  (use-modules (oop goops)
+               (g-golf))
+  (g-irepository-require "Gtk" #:version "4.0")
+  (for-each (lambda (name)
+              (gi-import-by-name "Gio" name))
+            '("SimpleAction"
+              "SimpleActionGroup"))
+  (for-each (lambda (name) (gi-import-by-name "Gtk" name))
+            '("Application"
+              "ApplicationWindow"
+              "CallbackAction"
+              "FileDialog")))
 
-Commands:
-\tcompile\t Compile the source into an object file
-\trun\t Run the object file
+(define (open-file win cb)
+  (define dialog (make <gtk-file-dialog>))
+  (define (cb-with-port dialog result data)
+    (call-with-input-file (get-path (open-finish dialog result)) cb))
+  (open dialog win #f cb-with-port #f))
 
-Yes the VM runs on Scheme, no that doesn't make any sense\n")
-  (exit))
+(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)
+  (define win (make <gtk-application-window>
+                #:application app
+                #:title "Scheme Compiler"))
+
+  ;; All this to make a 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))))
+  (present win))
 
 (define* (main #:optional args)
-  (define options (parse-options args))
-  (when (option-ref options 'help #f)
-    (usage)))
+  (define app (make <gtk-application>))
+  (connect app 'activate activate)
+  (let ([status (run app args)])
+    (exit status)))
 
 ;; Local Variables:
 ;; mode: scheme

scmvm/vm.scm

@@ -4,7 +4,7 @@
   #:use-module (rnrs bytevectors)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
-  #:export (make-vm run-vm vm-memory-ref vm-memory-set!
+  #:export (make-vm run-vm vm-memory-ref vm-memory-set! vm-memory
             *instruction-set* instruction-type instruction-code))
 
 ;;; Data Structures
@@ -65,7 +65,7 @@
   ((stack 'ref) k))
 
 (define* (make-ram #:optional (memory-size *memory-size*))
-  (make-vector memory-size))
+  (make-vector memory-size #x00))
 
 (define (ram-ref ram k)
   (vector-ref ram k))
@@ -189,6 +189,7 @@
   (lambda (x)
     (case x
       [(run) fetch-and-execute]
+      [(vm-memory) (lambda () ram)]
       [(vm-memory-ref) (cute ram-ref ram <>)]
       [(vm-memory-set!) (lambda (k v) (ram-set! ram k v))])))
 
@@ -200,6 +201,10 @@
   "Externally set VM memory at k to v"
   ((vm 'vm-memory-set!) k v))
 
+(define (vm-memory vm)
+  "Just get the memory vector"
+  ((vm 'vm-memory)))
+
 (define (run-vm vm port)
   "Read and execute instructions read from port on VM"
   (with-input-from-port port (vm 'run)))