diff --git a/scmvm.scm b/scmvm.scm
index d8902cd..fe5a6f5 100755
--- a/scmvm.scm
+++ b/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 "~a~a "
- (format-nibble val 0)
- (format-nibble val 1))]
- [(= offset 1)
- (format #f "~a~a "
- (format-nibble val 0)
- (format-nibble val 1))])))
- ""
- ram)))
- (set-markup %buffer-label text)))
-
-(define (open-file win cb)
- (define dialog (make ))
- (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 #:name name))
- (add-action action-group action)
- (connect action 'activate (lambda (a v) (callback))))
-
-(define (activate app)
- (newline)
- ;; Setup window
- (define win (make
- #:application app
- #:title "Scheme Compiler"))
- (define css-provider (make ))
- (load-from-string css-provider *css*)
- (gtk-style-context-add-provider-for-display
- (gdk-display-get-default) css-provider #xffff)
- (define box (make
- #:orientation 'vertical
- #:focusable #t))
- (set-child win box)
-
- ;; Setup 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))))
-
- ;; Setup buffer view
- (set! %buffer-label (make
- #:css-classes '("mono")
- #:wrap #t
- #:focusable #t))
- (set-can-focus %buffer-label #t)
- (set! %selected-nibble 0)
- (define frame (make
- #:focusable #t))
- (define buffer-controller (make ))
- (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
- #:vexpand #t
- #:editable #f))
- (append box program-view)
-
- (define button-box (make
- #:orientation 'horizontal))
- (append button-box (make
- #:label "Step"))
- (append button-box (make
- #: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 ))
- (connect app 'activate activate)
- (let ([status (run app args)])
- (exit status)))
-
-;;; DEBUG
-(use-modules (ice-9 threads))
-(define (debug)
- (define app (make ))
- (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))]))
diff --git a/scmvm/assembler.scm b/scmvm/assembler.scm
index 1ec2d85..d9c8ca6 100644
--- a/scmvm/assembler.scm
+++ b/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))))
diff --git a/scmvm/vm.scm b/scmvm/vm.scm
index cbf5d75..d9af273 100644
--- a/scmvm/vm.scm
+++ b/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))]