dane/scm-to-vm
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Styling etc

Browse Source
This commit is contained in:
Dane Johnson 2025-01-15 14:43:25 -06:00
parent feb07d43c8
commit 7ea50f95ef
1 changed files with 26 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
scmvm.scm
View File

@ -6,11 +6,11 @@ exec guile -L . -e main -s "$0" "$@"
(ice-9 format) (ice-9 format)
(srfi srfi-26) (srfi srfi-26)
(srfi srfi-43) (srfi srfi-43)
(scmvm vm)) (scmvm vm)
(oop goops)
(g-golf))
(eval-when (expand load eval) (eval-when (expand load eval)
(use-modules (oop goops)
(g-golf))
(g-irepository-require "Gtk" #:version "4.0") (g-irepository-require "Gtk" #:version "4.0")
(for-each (lambda (name) (for-each (lambda (name)
(gi-import-by-name "Gio" name)) (gi-import-by-name "Gio" name))
@ -22,7 +22,13 @@ exec guile -L . -e main -s "$0" "$@"
"CallbackAction" "CallbackAction"
"FileDialog" "FileDialog"
"Box" "Box"
"TextView"))) "TextView"
"CssProvider")))
(define *css* "
.mono {
font-family: monospace;
}")
(define %vm (make-vm #:memory-size 100)) (define %vm (make-vm #:memory-size 100))
(define %program #f) (define %program #f)
@ -37,7 +43,7 @@ exec guile -L . -e main -s "$0" "$@"
(set-text %buffer "" 0) (set-text %buffer "" 0)
(vector-for-each (vector-for-each
(lambda (_ byte) (lambda (_ byte)
(insert-at-cursor %buffer (format #f "~2'0x " byte) 3)) (insert-at-cursor %buffer (format #f "~:@(~2'0x~) " byte) -1))
ram))) ram)))
(define (open-file win cb) (define (open-file win cb)
@ -55,6 +61,10 @@ exec guile -L . -e main -s "$0" "$@"
(define win (make <gtk-application-window> (define win (make <gtk-application-window>
#:application app #:application app
#:title "Scheme Compiler")) #: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... ;; All this to make a menu...
(let ([app-action-group (make <g-simple-action-group>)] (let ([app-action-group (make <g-simple-action-group>)]
@ -77,19 +87,28 @@ exec guile -L . -e main -s "$0" "$@"
#:vexpand #t #:vexpand #t
#:editable #f #:editable #f
#:cursor-visible #f #:cursor-visible #f
#:wrap-mode 'word)) #:wrap-mode 'word
#:css-classes '("mono")))
(set! %buffer (get-buffer textview)) (set! %buffer (get-buffer textview))
(update-memory-buffer!) (update-memory-buffer!)
(append box textview) (append box textview)
(set-child win box) (set-child win box)
(present win)) (present win))
(define* (main #:optional args) (define* (main #:optional args)
(define app (make <gtk-application>)) (define app (make <gtk-application>))
(connect app 'activate activate) (connect app 'activate activate)
(let ([status (run app args)]) (let ([status (run app args)])
(exit status))) (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: ;; Local Variables:
;; mode: scheme ;; mode: scheme