scm-to-vm/scmvm.scm

#! /bin/sh
exec guile -L . -e main -s "$0" "$@"
!#
(use-modules (rnrs bytevectors)
             (ice-9 binary-ports)
             (ice-9 format)
             (srfi srfi-11)
             (srfi srfi-26)
             (srfi srfi-43)
             (scmvm vm)
             (oop goops)
             (g-golf))

(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-syntax-rule (named-lambda lambda-name args body ...)
  (lambda args #((name . lambda-name)) body ...))

(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: