450 lines
15 KiB
Scheme
450 lines
15 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))
|
|
(import (chicken file))
|
|
(import (chicken process))
|
|
(import (chicken process-context))
|
|
(import (chicken time posix))
|
|
(import (chicken io))
|
|
(define (get-u8 port) (read-byte port))
|
|
(define (open-rom path) (open-input-file path #:binary))
|
|
(define (get-date-time)
|
|
(let* ((v (seconds->local-time))
|
|
(y (vector-ref v 5)))
|
|
(vector-set! v 5 (+ y 1900)) v))
|
|
|
|
;; ;; 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)))
|
|
;; (define (get-date-time)
|
|
;; (let* ((v (localtime (current-time)))
|
|
;; (y (vector-ref v 5))
|
|
;; (tz (vector-ref v 8)))
|
|
;; (vector-set! v 5 (+ y 1900))
|
|
;; (vector-set! v 8 (not (= tz 0)))
|
|
;; v))
|
|
|
|
;; ;; chibi scheme, invoke with chibi-scheme vm.scm ROM ...
|
|
;; (import (scheme base) (scheme bitwise) (scheme file) (scheme process-context))
|
|
;; (import (chibi io) (chibi process) (chibi time))
|
|
;; (define (get-u8 port) (read-u8 port))
|
|
;; (define (open-rom path) (open-input-file path))
|
|
;; (define display write-string)
|
|
;; (define (command-line-arguments) (cdr (command-line)))
|
|
;; (define (get-date-time)
|
|
;; (let ((t (seconds->time (current-seconds))))
|
|
;; (vector
|
|
;; (time-second t) (time-minute t) (time-hour t)
|
|
;; (time-day t) (+ (time-month t) 1) (+ (time-year t) 1900)
|
|
;; (time-day-of-week t) (time-day-of-year t) (not (= (time-dst? t) 0)))))
|
|
|
|
;; ;; 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)))
|
|
;; (define (get-date-time)
|
|
;; (let ((t (current-date)))
|
|
;; (vector
|
|
;; (date-second t) (date-minute t) (date-hour t)
|
|
;; (date-day t) (date-month t) (date-year t)
|
|
;; (date-week-day t) (date-year-day t) (date-dst? t))))
|
|
|
|
;; === 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)
|
|
(define raw-tty #f)
|
|
(define saved-tty '())
|
|
|
|
;; 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 (u16 n)) (_push1 (u8 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 lim) (if _2 (_read2 addr lim) (_read1 addr)))
|
|
(define (_read1 addr) (_push1 (vector-ref mem addr)))
|
|
(define (_read2 addr lim) (_read1 addr) (_read1 (modulo (+ addr 1) lim)))
|
|
|
|
;; write value to memory
|
|
;; uses _2 to respect instruction modes
|
|
(define (_write addr n lim)
|
|
(if _2 (begin
|
|
(vector-set! mem addr (u16->hi n))
|
|
(vector-set! mem (modulo (+ addr 1) lim) (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 (u16 (+ pc 1)))))
|
|
(s16 (hilo->u16 hi lo))))
|
|
|
|
;; restore a stack pointer when in keep mode
|
|
(define (restore k)
|
|
(if (null? k)
|
|
'()
|
|
(set-car! _wst k)))
|
|
|
|
;; 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))
|
|
(impl (if k (car _wst) '()))))
|
|
|
|
(define (jmp n)
|
|
(set! pc (if _2 n (+ pc (s8 n)))))
|
|
|
|
(define (jmi)
|
|
(let ((offset (_load-s16)))
|
|
(set! pc (+ pc offset 2))))
|
|
|
|
;; base instruction implementations
|
|
;;
|
|
;; these assume that _2, _wst, and _rst are correctly set
|
|
;; according to the instruction's mode flags.
|
|
;;
|
|
;; BRK, LIT, and immediate instructions ignore keep.
|
|
(define (brk-impl k) (set! done #t))
|
|
(define (jci-impl k) (if (= 0 (_pop1)) (set! pc (+ pc 2)) (jmi)))
|
|
(define (jmi-impl k) (jmi))
|
|
(define (jsi-impl k) (_rpush2 (+ pc 2)) (jmi))
|
|
(define (lit-impl k) (_read pc 65536) (set! pc (+ pc (if _2 2 1))))
|
|
(define (inc-impl k) (let* ((a (_pop))) (restore k) (_push (+ a 1))))
|
|
(define (pop-impl k) (_pop) (restore k))
|
|
(define (nip-impl k) (let* ((a (_pop)) (_ (_pop))) (restore k) (_push a)))
|
|
(define (swp-impl k) (let* ((b (_pop)) (a (_pop))) (restore k) (_push b) (_push a)))
|
|
(define (rot-impl k) (let* ((c (_pop)) (b (_pop)) (a (_pop))) (restore k) (_push b) (_push c) (_push a)))
|
|
(define (dup-impl k) (let* ((a (_pop))) (restore k) (_push a) (_push a)))
|
|
(define (ovr-impl k) (let* ((b (_pop)) (a (_pop))) (restore k) (_push a) (_push b) (_push a)))
|
|
(define (equ-impl k) (let* ((b (_pop)) (a (_pop))) (restore k) (_push1 (if (= a b) 1 0))))
|
|
(define (neq-impl k) (let* ((b (_pop)) (a (_pop))) (restore k) (_push1 (if (= a b) 0 1))))
|
|
(define (gth-impl k) (let* ((b (_pop)) (a (_pop))) (restore k) (_push1 (if (> a b) 1 0))))
|
|
(define (lth-impl k) (let* ((b (_pop)) (a (_pop))) (restore k) (_push1 (if (< a b) 1 0))))
|
|
(define (jmp-impl k) (let ((n (_pop))) (restore k) (jmp n)))
|
|
(define (jcn-impl k) (let ((n (_pop))) (restore k) (if (= 0 (_pop1)) '() (jmp n))))
|
|
(define (jsr-impl k) (_rpush2 pc) (jmp-impl k))
|
|
(define (sth-impl k) (let* ((a (_pop))) (restore k) (_rpush a)))
|
|
(define (ldz-impl k) (let* ((zp (_pop1))) (restore k) (_read zp 256)))
|
|
(define (stz-impl k) (let* ((zp (_pop1)) (n (_pop))) (restore k) (_write zp n 256)))
|
|
(define (ldr-impl k) (let* ((r (_pop1))) (restore k) (_read (+ pc (s8 r)) 65536)))
|
|
(define (str-impl k) (let* ((r (_pop1)) (n (_pop))) (restore k) (_write (+ pc (s8 r)) n 65536)))
|
|
(define (lda-impl k) (let ((n (_pop2))) (restore k) (_read n 65536)))
|
|
(define (sta-impl k) (let* ((addr (_pop2)) (n (_pop))) (restore k) (_write addr n 65536)))
|
|
(define (add-impl k) (let* ((b (_pop)) (a (_pop))) (restore k) (_push (+ a b))))
|
|
(define (sub-impl k) (let* ((b (_pop)) (a (_pop))) (restore k) (_push (- a b))))
|
|
(define (mul-impl k) (let* ((b (_pop)) (a (_pop))) (restore k) (_push (* a b))))
|
|
(define (div-impl k) (let* ((b (_pop)) (a (_pop))) (restore k) (_push (if (= b 0) 0 (quotient a b)))))
|
|
(define (and-impl k) (let* ((b (_pop)) (a (_pop))) (restore k) (_push (bitwise-and a b))))
|
|
(define (ora-impl k) (let* ((b (_pop)) (a (_pop))) (restore k) (_push (bitwise-ior a b))))
|
|
(define (eor-impl k) (let* ((b (_pop)) (a (_pop))) (restore k) (_push (bitwise-xor a b))))
|
|
|
|
;; DEI base instruction implementation
|
|
(define (dei-impl k)
|
|
(let ((port (_pop1)))
|
|
(restore k)
|
|
(if _2
|
|
(let ((hi (_dei port))
|
|
(lo (_dei (u8 (+ port 1)))))
|
|
(_push1 hi) (_push1 lo))
|
|
(_push1 (_dei port)))))
|
|
(define (_dei port)
|
|
(cond
|
|
((= 4 port) (+ (car wst) 1))
|
|
((= 5 port) (+ (car rst) 1))
|
|
((and (<= 192 port) (< port 208)) (_datetime (- port 192)))
|
|
(* (u8 (vector-ref dev port)))))
|
|
|
|
;; (0:seconds 1:minutes 2:hours 3:mday 4:month 5:year 6:wday 7:yday 8:dstflag 9:timezone)
|
|
(define (_datetime field)
|
|
(u8 (let ((t (get-date-time)))
|
|
(cond
|
|
((= field 0) (u16->hi (vector-ref t 5))) ; year hi
|
|
((= field 1) (u16->lo (vector-ref t 5))) ; year lo
|
|
((= field 2) (vector-ref t 4)) ; month
|
|
((= field 3) (vector-ref t 3)) ; day of month
|
|
((= field 4) (vector-ref t 2)) ; hours
|
|
((= field 5) (vector-ref t 1)) ; minutes
|
|
((= field 6) (vector-ref t 0)) ; seconds
|
|
((= field 7) (vector-ref t 6)) ; day of week
|
|
((= field 8) (u16->hi (vector-ref t 7))) ; day of year hi
|
|
((= field 9) (u16->lo (vector-ref t 7))) ; day of year lo
|
|
((= field 10) (if (vector-ref t 8) 1 0)) ; is dst
|
|
(* (vector-ref dev (+ 192 field))))))) ; device memory
|
|
|
|
;; DEO base instruction implementation
|
|
(define (deo-impl k)
|
|
(let* ((dev (_pop1)) (n (_pop)))
|
|
(restore k)
|
|
(if _2
|
|
(begin
|
|
(_deo (u16->hi n) dev)
|
|
(_deo (u16->lo n) (u8 (+ dev 1))))
|
|
(_deo n dev))))
|
|
(define (_deo byte port)
|
|
(vector-set! dev port (u8 byte))
|
|
(cond
|
|
((= 4 port) (set-car! wst byte))
|
|
((= 5 port) (set-car! rst byte))
|
|
((= 14 port) (u:debug))
|
|
((= 24 port) (write-byte byte (current-output-port)))
|
|
((= 25 port) (write-byte byte (current-error-port)))
|
|
(* '())))
|
|
|
|
(define (u:debug)
|
|
(u:debug-stack "WST" wst) (u:debug-stack "RST" rst))
|
|
|
|
(define (u:debug-stack label st)
|
|
(let* ((cells (cdr st))
|
|
(limit (car st))
|
|
(i (u8 (- limit 8)))
|
|
(port (current-output-port)))
|
|
(display label port)
|
|
(u:debug-cells cells i limit port)))
|
|
|
|
(define (u:debug-cells cells i limit port)
|
|
(display (if (= i 0) "|" " ") port)
|
|
(if (= i limit) (display "<\n")
|
|
(begin
|
|
(emit-u8 (vector-ref cells i) port)
|
|
(u:debug-cells cells (u8 (+ i 1)) limit port))))
|
|
|
|
(define (emit-u8 n port)
|
|
(display (number->string (quotient n 16) 16) port)
|
|
(display (number->string (modulo n 16) 16) port))
|
|
|
|
;; SFT base instruction implementation
|
|
(define (sft-impl k)
|
|
(let* ((n (_pop1))
|
|
(a (_pop))
|
|
(left (bitwise-and (b>> n 4) 15))
|
|
(right (bitwise-and n 15)))
|
|
(restore k)
|
|
(_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 #f #t #t)) ; -kr
|
|
(vector-set! instructions (+ base 224) (op impl #t #t #t))) ; 2kr
|
|
|
|
;; hardcoded instructions for base 0x00
|
|
(vector-set! instructions 0 (op brk-impl #f #f #f)) ; BRK
|
|
(vector-set! instructions 32 (op jci-impl #f #f #f)) ; JCI
|
|
(vector-set! instructions 64 (op jmi-impl #f #f #f)) ; JMI
|
|
(vector-set! instructions 96 (op jsi-impl #f #f #f)) ; 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)))
|
|
(set! pc (+ pc 1))
|
|
(fn)
|
|
(u:eval))))
|
|
|
|
(define (u:exit n) (u:restore-tty) (exit n))
|
|
|
|
(define (u:run addr)
|
|
(set! done #f)
|
|
(set! pc addr)
|
|
(u:eval)
|
|
(let ((n (vector-ref dev 15)))
|
|
(if (= n 0) '()
|
|
(u:exit (bitwise-and n 127)))))
|
|
|
|
(define (u:read-args args)
|
|
(if (null? args)
|
|
(u:send-input 10 4)
|
|
(begin
|
|
(u:read-arg (string->list (car args)))
|
|
(if (null? (cdr args)) '() (u:send-input 10 3))
|
|
(u:read-args (cdr args)))))
|
|
|
|
(define (u:read-arg chars)
|
|
(if (null? chars) '()
|
|
(begin
|
|
(u:send-input (char->integer (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, or end of stdin
|
|
(define (u:send-input n 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 n))
|
|
(vector-set! dev 23 (u8 type))
|
|
(u:run addr)))))
|
|
|
|
(define (u:read-stdin port)
|
|
(let ((byte (read-byte port)))
|
|
(if (eof-object? byte)
|
|
(u:send-input 10 4)
|
|
(begin
|
|
(u:send-input byte 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))))))
|
|
|
|
(define (u:read-cmd cmd)
|
|
(with-input-from-pipe cmd (lambda () (read-string #f (current-input-port)))))
|
|
|
|
(define (u:usage)
|
|
(display "usage: ./vm [-raw] ROM [ARGS...]\n")
|
|
(exit))
|
|
|
|
(define (u:parse-args args)
|
|
(if (null? args) (u:usage))
|
|
(if (equal? (car args) "-raw")
|
|
(begin (set! raw-tty #t)
|
|
(u:parse-args (cdr args)))
|
|
args))
|
|
|
|
(define (u:check-rom path)
|
|
(if (and (file-exists? path) (file-readable? path)) '()
|
|
(begin (display "ERROR: cannot open ROM '")
|
|
(display path)
|
|
(display "'\n")
|
|
(u:usage))))
|
|
|
|
(define (u:set-tty)
|
|
(if raw-tty (begin (set! saved-tty (u:read-cmd "stty -g"))
|
|
(system* "stty raw -echo"))))
|
|
|
|
(define (u:restore-tty)
|
|
(if raw-tty (system* (string-append "stty " saved-tty))))
|
|
|
|
(let* ((prog-args (u:parse-args (command-line-arguments)))
|
|
(_ (u:set-tty))
|
|
(rom-path (car prog-args))
|
|
(rom-args (cdr prog-args))
|
|
(_ (u:check-rom rom-path))
|
|
(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)
|
|
(if (null? rom-args) '() (u:read-args rom-args))
|
|
(u:read-stdin (current-input-port))
|
|
(u:exit 0))
|