diff --git a/scmvm.scm b/scmvm.scm index bffeaa3..074306e 100755 --- a/scmvm.scm +++ b/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 )) + (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 #:name name)) + (add-action action-group action) + (connect action 'activate (lambda (a v) (callback)))) + +(define (activate app) + (define win (make + #:application app + #:title "Scheme Compiler")) + + ;; All this to make a menu... + (let ([app-action-group (make )] + [menu (make )] + [file-menu (make )]) + (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 )) + (connect app 'activate activate) + (let ([status (run app args)]) + (exit status))) ;; Local Variables: ;; mode: scheme diff --git a/scmvm/vm.scm b/scmvm/vm.scm index 3c72a3c..e3128b2 100644 --- a/scmvm/vm.scm +++ b/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)))