330 lines
11 KiB
Scheme
330 lines
11 KiB
Scheme
; basic varvara emulator implementation in scheme
|
|
;
|
|
; does not currently use any macros or advanced features. the first
|
|
; stanza defines non-portable functions across a variety of scheme
|
|
; implementations.
|
|
|
|
; === implementation-dependent functions; uncomment one stanza
|
|
|
|
; chicken scheme
|
|
(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)))
|
|
|
|
; global state for the virtual machine
|
|
;
|
|
; 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)))
|
|
(define rst (cons 0 (make-vector 256 0)))
|
|
(define pc 256)
|
|
(define done #f)
|
|
|
|
; instruction modes
|
|
(define _2 #f)
|
|
(define _wst wst)
|
|
(define _rst rst)
|
|
|
|
; convert numbers to 8-bit and 16-bit values
|
|
(define (u8 n) (modulo n 256))
|
|
(define (s8 n) (- (u8 (+ n 128)) 128))
|
|
(define (u16 n) (modulo n 65536))
|
|
(define (s16 n) (- (u16 (+ n 32768)) 32768))
|
|
|
|
(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
|
|
(define (_pop) (if _2 (_pop2) (_pop1)))
|
|
(define (_pop1)
|
|
(let* ((i (u8 (- (car _wst) 1)))
|
|
(n (vector-ref (cdr _wst) i)))
|
|
(set-car! _wst i)
|
|
n))
|
|
(define (_pop2)
|
|
(let* ((lo (_pop1)) (hi (_pop1))) (hilo->u16 hi lo)))
|
|
|
|
; push value to active stack
|
|
; uses _2, _wst, and _rst to respect instruction modes
|
|
(define (_push n) (if _2 (_push2 n) (_push1 n)))
|
|
(define (_push1 n) (_xpush1 _wst n))
|
|
(define (_push2 n) (_xpush2 _wst n))
|
|
|
|
; push value to passive stack
|
|
; uses _2, _wst, and _rst to respect instruction modes
|
|
(define (_rpush n) (if _2 (_rpush2 n) (_xpush1 _rst n)))
|
|
(define (_rpush2 n) (_xpush2 _rst n))
|
|
|
|
; push value to the given stack
|
|
(define (_xpush1 st n)
|
|
(let ((i (car st)))
|
|
(vector-set! (cdr st) i (u8 n))
|
|
(set-car! st (u8 (+ i 1)))))
|
|
(define (_xpush2 st n)
|
|
(_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
|
|
(define (_read addr) (if _2 (_read2 addr) (_read1 addr)))
|
|
(define (_read1 addr) (_push1 (vector-ref mem addr)))
|
|
(define (_read2 addr) (_read1 addr) (_read1 (+ addr 1)))
|
|
|
|
; write value to memory
|
|
; uses _2 to respect instruction modes
|
|
(define (_write addr n)
|
|
(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))
|
|
(lo (vector-ref mem (+ pc 1))))
|
|
(s16 (hilo->u16 hi lo))))
|
|
|
|
; load 8 variants of an instruction
|
|
(define (op impl s k r)
|
|
(lambda ()
|
|
(set! _2 s)
|
|
(set! _wst (if r _rst _wst))
|
|
(set! _rst (if r _wst _rst))
|
|
(if k
|
|
(let ((i (car _wst))) (impl) (set-car! _wst i))
|
|
(impl))))
|
|
|
|
; base instruction implementations
|
|
;
|
|
; these assume that _2, _wst, and _rst are correctly set
|
|
; according to the instruction's mode flags.
|
|
(define (brk-impl) (set! done #t))
|
|
(define (jci-impl) (if (= 0 (_pop1)) (set! pc (+ pc 2)) (jmi-impl)))
|
|
(define (jmi-impl) (let ((off (_load-s16))) (set! pc (+ pc off 2))))
|
|
(define (jsi-impl) (_rpush2 (+ pc 2)) (jmi-impl))
|
|
(define (lit-impl) (_read pc) (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 (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 (ldr-impl) (_read (+ pc (s8 (_pop1)))))
|
|
(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 (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)
|
|
(let ((port (_pop1)))
|
|
(if _2
|
|
(let ((hi (_dei port))
|
|
(lo (_dei (+ port 1))))
|
|
(_push2 (hilo->u16 hi lo)))
|
|
(_push1 (_dei port)))))
|
|
(define (_dei port)
|
|
(u8 (vector-ref dev port)))
|
|
|
|
; DEO base instruction implementation
|
|
(define (deo-impl)
|
|
(let* ((dev (_pop1)) (n (_pop)))
|
|
(if _2
|
|
(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)))
|
|
(* '())))
|
|
|
|
; SFT base instruction implementation
|
|
(define (sft-impl)
|
|
(let* ((n (_pop1))
|
|
(a (_pop))
|
|
(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
|
|
; flags: 2 (32, 0x20), k (128, 0x80), r (64, 0x40).
|
|
(define (add-op base impl)
|
|
(vector-set! instructions (+ base 0) (op impl #f #f #f)) ; ---
|
|
(vector-set! instructions (+ base 32) (op impl #t #f #f)) ; 2--
|
|
(vector-set! instructions (+ base 64) (op impl #f #f #t)) ; --r
|
|
(vector-set! instructions (+ base 96) (op impl #t #f #t)) ; 2-r
|
|
(vector-set! instructions (+ base 128) (op impl #f #t #f)) ; -k-
|
|
(vector-set! instructions (+ base 160) (op impl #t #t #f)) ; 2k-
|
|
(vector-set! instructions (+ base 192) (op impl #t #f #t)) ; 2-r
|
|
(vector-set! instructions (+ base 224) (op impl #t #t #t))) ; 2kr
|
|
|
|
; hardcoded instructions for base 0x00
|
|
(vector-set! instructions 0 brk-impl) ; BRK
|
|
(vector-set! instructions 32 jci-impl) ; JCI
|
|
(vector-set! instructions 64 jmi-impl) ; JMI
|
|
(vector-set! instructions 96 jsi-impl) ; JSI
|
|
(vector-set! instructions 128 (op lit-impl #f #f #f)) ; LIT
|
|
(vector-set! instructions 160 (op lit-impl #t #f #f)) ; LIT2
|
|
(vector-set! instructions 192 (op lit-impl #f #f #t)) ; LITr
|
|
(vector-set! instructions 224 (op lit-impl #t #f #t)) ; LIT2r
|
|
|
|
; add instructions for base 0x01 through 0x1f
|
|
(add-op 1 inc-impl)
|
|
(add-op 2 pop-impl)
|
|
(add-op 3 nip-impl)
|
|
(add-op 3 nip-impl)
|
|
(add-op 4 swp-impl)
|
|
(add-op 5 rot-impl)
|
|
(add-op 6 dup-impl)
|
|
(add-op 7 ovr-impl)
|
|
(add-op 8 equ-impl)
|
|
(add-op 9 neq-impl)
|
|
(add-op 10 gth-impl)
|
|
(add-op 11 lth-impl)
|
|
(add-op 12 jmp-impl)
|
|
(add-op 13 jcn-impl)
|
|
(add-op 14 jsr-impl)
|
|
(add-op 15 sth-impl)
|
|
(add-op 16 ldz-impl)
|
|
(add-op 17 stz-impl)
|
|
(add-op 18 ldr-impl)
|
|
(add-op 19 str-impl)
|
|
(add-op 20 lda-impl)
|
|
(add-op 21 sta-impl)
|
|
(add-op 22 dei-impl)
|
|
(add-op 23 deo-impl)
|
|
(add-op 24 add-impl)
|
|
(add-op 25 sub-impl)
|
|
(add-op 26 mul-impl)
|
|
(add-op 27 div-impl)
|
|
(add-op 28 and-impl)
|
|
(add-op 29 ora-impl)
|
|
(add-op 30 eor-impl)
|
|
(add-op 31 sft-impl)
|
|
|
|
; evaluation loop
|
|
(define (u:eval)
|
|
(if done '()
|
|
(let* ((byte (vector-ref mem pc))
|
|
(fn (vector-ref instructions byte)))
|
|
;; (display "*** ")
|
|
;; (display byte)
|
|
;; (display "\n")
|
|
(set! pc (+ pc 1))
|
|
(fn)
|
|
(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)
|
|
(let ((byte (get-u8 rom)))
|
|
(if (eof-object? byte)
|
|
'()
|
|
(begin (vector-set! mem addr (u8 byte))
|
|
(u:load-rom rom (+ addr 1))))))
|
|
|
|
(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))))
|