116 lines
3.2 KiB
Scheme
Executable File
116 lines
3.2 KiB
Scheme
Executable File
#! /bin/sh
|
||
exec guile -L . -e main -s "$0" "$@"
|
||
!#
|
||
(use-modules (rnrs bytevectors)
|
||
(ice-9 binary-ports)
|
||
(ice-9 format)
|
||
(srfi srfi-26)
|
||
(srfi srfi-43)
|
||
(scmvm vm)
|
||
(oop goops)
|
||
(g-golf))
|
||
|
||
(eval-when (expand load eval)
|
||
(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"
|
||
"Box"
|
||
"TextView"
|
||
"CssProvider")))
|
||
|
||
(define *css* "
|
||
.mono {
|
||
font-family: monospace;
|
||
}")
|
||
|
||
(define %vm (make-vm #:memory-size 100))
|
||
(define %program #f)
|
||
(define %buffer #f)
|
||
|
||
(define (load-binary port)
|
||
(set! %program port))
|
||
|
||
(define (update-memory-buffer!)
|
||
(when (and %buffer %vm)
|
||
(define ram (vm-memory %vm))
|
||
(set-text %buffer "" 0)
|
||
(vector-for-each
|
||
(lambda (_ byte)
|
||
(insert-at-cursor %buffer (format #f "~:@(~2'0x~) " byte) -1))
|
||
ram)))
|
||
|
||
(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))
|
||
|
||
(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"))
|
||
(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)
|
||
|
||
;; 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))))
|
||
|
||
(define box (make <gtk-box>
|
||
#:orientation 'vertical))
|
||
(define textview (make <gtk-text-view>
|
||
#:vexpand #t
|
||
#:editable #f
|
||
#:cursor-visible #f
|
||
#:wrap-mode 'word
|
||
#:css-classes '("mono")))
|
||
(set! %buffer (get-buffer textview))
|
||
(update-memory-buffer!)
|
||
(append box textview)
|
||
(set-child win box)
|
||
|
||
(present win))
|
||
|
||
(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:
|