d6
/
uxn-scm
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

basically working

This commit is contained in:
~d6 2025-01-18 23:03:06 -05:00
parent 1827ee1e22
commit b2baf9d186
5 changed files with 218 additions and 91 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
.gitignore vendored Normal file
View File

@ -0,0 +1,20 @@
# use glob syntax.
syntax: glob
*.pyc
*.pyo
*~
TAGS
*.rom
img
etc
test-roms
junk
img
.theme
.snarf
*.sym
wave
*.mp3
*.wav
*.mp4
scratch

15
Makefile Normal file
View File

@ -0,0 +1,15 @@
vm: vm.scm
csc -o vm vm.scm
hello.rom: hello.tal
uxnasm hello.tal hello.rom
run: hello.rom vm
./vm hello.rom aa bb cc
clean:
rm -f hello.rom
rm -f vm
.DEFAULT: run
.PHONY: clean run

29
README.md
View File

@ -0,0 +1,29 @@
# vm.scm
Scheme implementation of Varvara.
It is closely based on [uxnmin.c](https://wiki.xxiivv.com/etc/uxnmin.c.txt).
Currently it supports:
* console stdin, stdout, and stderr
* command-line arguments
# goals
The main goals of this project are:
* portability across Scheme implementations
* implementations simplicity and correctness
* support bootstrapping uxn
Secondary goals are:
* supporting more devices
* emulator performance
# scheme dialects
The default dialect used is [Chicken Scheme](http://www.call-cc.org/).
The source code contains shims for [Guile](https://www.gnu.org/software/guile/), [Chibi-scheme](http://synthcode.com/scheme/chibi), and [Chez Scheme](https://cisco.github.io/ChezScheme/). By commenting out the Chicken stanza and uncommenting a different one other Scheme dialects may be supported.

17
hello.tal Normal file
View File

@ -0,0 +1,17 @@
|100
;on-input #10 DEO2
#0123 INC2 #45 INC POP2 POP
LIT "h #18 DEO
LIT "e #18 DEO
LIT "l #18 DEO
LIT "l #18 DEO
LIT "o #18 DEO
#0a18 DEO
( #830f DEO )
BRK
@on-input
#010e DEO
#17 DEI LIT "0 ADD #18 DEO
#12 DEI #18 DEO
BRK

224
vm.scm
View File

@ -1,33 +1,43 @@
; basic varvara emulator implementation in scheme
;
; does not currently use any macros or advanced features.
; first stanza defines non-portable bit-related functions.
; does not currently use any macros or advanced features. the first
; stanza defines non-portable functions across a variety of scheme
; implementations.
; implementation-dependent features which differ between scheme impls
; === implementation-dependent functions; uncomment one stanza
; chicken scheme
(import chicken.bitwise)
(define (b-and x y) (bitwise-and x y))
(define (b-or x y) (bitwise-ior x y))
(define (b-xor x y) (bitwise-xor x y))
(import (chicken bitwise) (chicken process-context))
(define (get-u8 port)
(let ((c (read-char port))) (if (eof-object? c) c (char->integer c))))
(define (open-rom path) (open-input-file path #:binary))
;; ; guile, invoke with guile vm.scm ROM ...
;; (use-modules (srfi srfi-60) (ice-9 binary-ports))
;; (define (open-rom path) (open-input-file path))
;; (define (command-line-arguments) (cdr (command-line)))
;; ; chibi scheme, invoke with ???
;; (import (scheme base) (scheme bitwise) (scheme file))
;; (import (chibi io) (chibi process))
;; (define (get-u8 port) (read-u8 port))
;; (define (open-rom path) (open-input-file path))
;; (define (display s) (write-string s))
;; ; chez scheme, invoke with chezscheme --script vm.scm ROM ...
;; (define (open-rom path) (open-file-input-port path))
;; (define (command-line-arguments) (cdr (command-line)))
; === portable scheme code follows
(define (b<< n s) (arithmetic-shift n s))
(define (b>> n s) (arithmetic-shift n (- s)))
(define (b-read-u8 port) (u8 (char->integer (read-char port))))
;; ; guile
;; (use-modules (srfi srfi-60))
;; (use-modules (ice-9 binary-ports))
;; (define (b-and x y) (bitwise-and x y))
;; (define (b-or x y) (bitwise-ior x y))
;; (define (b-xor x y) (bitwise-xor x y))
;; (define (b<< n s) (arithmetic-shift n s))
;; (define (b>> n s) (arithmetic-shift n (- s)))
;; (define (b-read-u8 port) (u8 (get-u8 port)))
; portable scheme code follows
; global state for the virtual machine
(define instructions (make-vector 256 (lambda () (display "!!! no instruction\n"))))
;
; we use vectors to simulate memory addresses
; we use mutable cons cells for pointer+stack pairs
(define instructions (make-vector 256))
(define mem (make-vector 65536 0))
(define dev (make-vector 256 0))
(define wst (cons 0 (make-vector 256 0)))
@ -46,22 +56,9 @@
(define (u16 n) (modulo n 65536))
(define (s16 n) (- (u16 (+ n 32768)) 32768))
; convert a cons cell of two bytes to one short
; (0 . 0) -> 0
; (1 . 1) -> 257
; (2 . 2) -> 514
(define (join-u16 parts)
(let ((hi (car parts))
(lo (cdr parts)))
(+ (* 256 hi) lo)))
; convert a short to a cons cell of two bytes
; 12 -> (0 . 12)
; 257 -> (1 . 1)
(define (tear-u16 n)
(let ((n2 (modulo n 256))
(n1 (floor (/ n 256))))
(cons n1 n2)))
(define (u16->lo n) (modulo n 256))
(define (u16->hi n) (quotient n 256))
(define (hilo->u16 hi lo) (+ (* 256 hi) lo))
; pop from active stack, returning value
; uses _2, _wst, and _rst to respect instruction modes
@ -72,9 +69,7 @@
(set-car! _wst i)
n))
(define (_pop2)
(let* ((hi (_pop1))
(lo (_pop1)))
(join-u16 (cons hi lo))))
(let* ((lo (_pop1)) (hi (_pop1))) (hilo->u16 hi lo)))
; push value to active stack
; uses _2, _wst, and _rst to respect instruction modes
@ -84,8 +79,7 @@
; push value to passive stack
; uses _2, _wst, and _rst to respect instruction modes
(define (_rpush n) (if _2 (_rpush2 n) (_rpush1 n)))
(define (_rpush1 n) (_xpush1 _rst n))
(define (_rpush n) (if _2 (_rpush2 n) (_xpush1 _rst n)))
(define (_rpush2 n) (_xpush2 _rst n))
; push value to the given stack
@ -94,9 +88,8 @@
(vector-set! (cdr st) i (u8 n))
(set-car! st (u8 (+ i 1)))))
(define (_xpush2 st n)
(let ((parts (tear-u16 n)))
(_xpush1 st (car parts))
(_xpush1 st (cdr parts))))
(_xpush1 st (u16->hi n))
(_xpush1 st (u16->lo n)))
; read value from memory onto active stack
; uses _2, _wst, and _rst to respect instruction modes
@ -107,19 +100,16 @@
; write value to memory
; uses _2 to respect instruction modes
(define (_write addr n)
(if _2 (_write2 addr n) (_write1 addr n)))
(define (_write1 addr n)
(vector-set! mem addr n))
(define (_write2 addr n)
(let ((parts (tear-u16 n)))
(vector-set! mem addr (car parts))
(vector-set! mem (+ addr 1) (cdr parts))))
(if _2 (begin
(vector-set! mem addr (u16->hi n))
(vector-set! mem (+ addr 1) (u16->lo n)))
(vector-set! mem addr n)))
; load signed 16-bit value from memory, returning value
(define (_load-s16)
(let ((hi (vector-ref mem (+ pc 1)))
(lo (vector-ref mem (+ pc 2))))
(s16 (join-u16 (cons hi lo)))))
(s16 (hilo->u16 hi lo))))
; load 8 variants of an instruction
(define (op impl s k r)
@ -142,32 +132,32 @@
(define (lit-impl) (_read (+ pc 1)) (set! pc (+ pc (if _2 2 1))))
(define (inc-impl) (_push (+ (_pop) 1)))
(define (pop-impl) (_pop))
(define (nip-impl) (let ((a (_pop))) (_pop) (_push a)))
(define (swp-impl) (let ((b (_pop)) (a (_pop))) (_push b) (_push a)))
(define (rot-impl) (let ((c (_pop)) (b (_pop)) (a (_pop))) (_push b) (_push c) (_push a)))
(define (dup-impl) (let ((a (_pop))) (_push a) (_push a)))
(define (ovr-impl) (let ((b (_pop)) (a (_pop))) (_push a) (_push b) (_push a)))
(define (equ-impl) (let ((b (_pop)) (a (_pop))) (_push1 (if (= a b) 1 0))))
(define (neq-impl) (let ((b (_pop)) (a (_pop))) (_push1 (if (not (= a b)) 0 1))))
(define (gth-impl) (let ((b (_pop)) (a (_pop))) (_push1 (if (> a b) 0 1))))
(define (lth-impl) (let ((b (_pop)) (a (_pop))) (_push1 (if (< a b) 0 1))))
(define (nip-impl) (let* ((a (_pop))) (_pop) (_push a)))
(define (swp-impl) (let* ((b (_pop)) (a (_pop))) (_push b) (_push a)))
(define (rot-impl) (let* ((c (_pop)) (b (_pop)) (a (_pop))) (_push b) (_push c) (_push a)))
(define (dup-impl) (let* ((a (_pop))) (_push a) (_push a)))
(define (ovr-impl) (let* ((b (_pop)) (a (_pop))) (_push a) (_push b) (_push a)))
(define (equ-impl) (let* ((b (_pop)) (a (_pop))) (_push1 (if (= a b) 1 0))))
(define (neq-impl) (let* ((b (_pop)) (a (_pop))) (_push1 (if (not (= a b)) 0 1))))
(define (gth-impl) (let* ((b (_pop)) (a (_pop))) (_push1 (if (> a b) 0 1))))
(define (lth-impl) (let* ((b (_pop)) (a (_pop))) (_push1 (if (< a b) 0 1))))
(define (jmp-impl) (let ((n (_pop))) (set! pc (if _2 n (+ pc (s8 n))))))
(define (jcn-impl) (if (= 0 (_pop1)) (_pop) (jmp-impl)))
(define (jsr-impl) (_rpush2 pc) (jmp-impl))
(define (sth-impl) (_rpush (_pop)))
(define (ldz-impl) (_read (_pop1)))
(define (stz-impl) (let ((zp (_pop1)) (n (_pop))) (_write zp n)))
(define (stz-impl) (let* ((zp (_pop1)) (n (_pop))) (_write zp n)))
(define (ldr-impl) (_read (+ pc (s8 (_pop1)))))
(define (str-impl) (let ((off (_pop1)) (n (_pop))) (_write (+ pc (s8 off)) n)))
(define (str-impl) (let* ((off (_pop1)) (n (_pop))) (_write (+ pc (s8 off)) n)))
(define (lda-impl) (_read (_pop2)))
(define (sta-impl) (let ((addr (_pop2)) (n (_pop))) (_write addr n)))
(define (add-impl) (let ((b (_pop)) (a (_pop))) (_push (+ a b))))
(define (sub-impl) (let ((b (_pop)) (a (_pop))) (_push (- a b))))
(define (mul-impl) (let ((b (_pop)) (a (_pop))) (_push (* a b))))
(define (div-impl) (let ((b (_pop)) (a (_pop))) (_push (quotient a b))))
(define (and-impl) (let ((b (_pop)) (a (_pop))) (_push (b-and a b))))
(define (ora-impl) (let ((b (_pop)) (a (_pop))) (_push (b-or a b))))
(define (eor-impl) (let ((b (_pop)) (a (_pop))) (_push (b-xor a b))))
(define (sta-impl) (let* ((addr (_pop2)) (n (_pop))) (_write addr n)))
(define (add-impl) (let* ((b (_pop)) (a (_pop))) (_push (+ a b))))
(define (sub-impl) (let* ((b (_pop)) (a (_pop))) (_push (- a b))))
(define (mul-impl) (let* ((b (_pop)) (a (_pop))) (_push (* a b))))
(define (div-impl) (let* ((b (_pop)) (a (_pop))) (_push (quotient a b))))
(define (and-impl) (let* ((b (_pop)) (a (_pop))) (_push (bitwise-and a b))))
(define (ora-impl) (let* ((b (_pop)) (a (_pop))) (_push (bitwise-ior a b))))
(define (eor-impl) (let* ((b (_pop)) (a (_pop))) (_push (bitwise-xor a b))))
; DEI base instruction implementation
(define (dei-impl)
@ -175,31 +165,32 @@
(if _2
(let ((hi (_dei port))
(lo (_dei (+ port 1))))
(_push2 (join-u16 (cons hi lo))))
(_push2 (hilo->u16 hi lo)))
(_push1 (_dei port)))))
(define (_dei port)
(_push1 (vector-ref dev port)))
(u8 (vector-ref dev port)))
; DEO base instruction implementation
(define (deo-impl)
(let ((dev (_pop1)) (n (_pop)))
(let* ((dev (_pop1)) (n (_pop)))
(if _2
(let ((parts (tear-u16 n)))
(_deo (car parts) dev)
(_deo (cdr parts) (+ dev 1)))
(begin
(_deo (u16->hi n) dev)
(_deo (u16->lo n) (+ dev 1)))
(_deo n dev))))
(define (_deo byte port)
(vector-set! dev port (u8 byte))
(cond
((= 24 port) (write-char (integer->char byte) (current-output-port)))
((= 25 port) (write-char (integer->char byte) (current-error-port)))))
((= 25 port) (write-char (integer->char byte) (current-error-port)))
(* '())))
; SFT base instruction implementation
(define (sft-impl)
(let ((n (_pop1))
(let* ((n (_pop1))
(a (_pop))
(left (b-and (b>> n 4) 15))
(right (b-and n 15)))
(left (bitwise-and (b>> n 4) 15))
(right (bitwise-and n 15)))
(_push (b<< (b>> a right) left))))
; add 8 variants for a given instruction base
@ -267,14 +258,69 @@
(set! pc (+ pc 1))
(u:eval))))
(define (u:run addr)
(set! done #f)
(set! pc addr)
(u:eval)
(let ((n (vector-ref dev 15)))
(if (= n 0) '()
(exit (bitwise-and n 127)))))
(define (u:read-args args)
(if (null? args)
(u:send-input #\newline 4)
(begin
(u:read-arg (string->list (car args)))
(if (null? (cdr args)) '() (u:send-input #\newline 3))
(u:read-args (cdr args)))))
(define (u:read-arg chars)
(if (null? chars) '()
(begin
(u:send-input (car chars) 2)
(u:read-arg (cdr chars)))))
; send a character of console input with type
; types are:
; - 1 stdin
; - 2 argument data
; - 3 spacer between arguments
; - 4 spacer after arguments
(define (u:send-input c type)
(let* ((hi (vector-ref dev 16))
(lo (vector-ref dev 17))
(addr (hilo->u16 hi lo)))
(if (= 0 addr) '()
(begin
(vector-set! dev 18 (u8 (char->integer c)))
(vector-set! dev 23 (u8 type))
(u:run addr)))))
(define (u:read-stdin port)
(let ((c (read-char port)))
(if (eof-object? c) '()
(begin
(u:send-input c 1)
(u:read-stdin port)))))
; load a ROM from a file, byte-by-byte
(define (u:load-rom rom addr)
(if (eof-object? (peek-char rom))
(let ((byte (get-u8 rom)))
(if (eof-object? byte)
'()
(begin (vector-set! mem addr (b-read-u8 rom))
(u:load-rom rom (+ addr 1)))))
(begin (vector-set! mem addr (u8 byte))
(u:load-rom rom (+ addr 1))))))
; load the rom and begin evaluation
(let ((rom (open-input-file "hello.rom")))
(u:load-rom rom 256)
(u:eval))
(let ((prog-args (command-line-arguments)))
(if (null? prog-args)
(begin (display "usage: ./vm ROM [ARGS...]\n") (exit))
(let* ((rom-path (car prog-args))
(rom-args (cdr prog-args))
(rom (open-rom rom-path))
(start 256))
(vector-set! dev 23 (if (null? rom-args) 0 1))
(u:load-rom rom start)
(u:run start)
(u:read-args rom-args)
(u:read-stdin (current-input-port))
(exit 0))))