get datetime working in guile too
This commit is contained in:
parent
a59959bcd9
commit
9338012d15
114
vm.scm
114
vm.scm
|
|
@ -1,42 +1,44 @@
|
|||
; 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.
|
||||
;; 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
|
||||
;; === implementation-dependent functions; uncomment one stanza
|
||||
|
||||
; chicken scheme
|
||||
;; chicken scheme
|
||||
(import (chicken bitwise) (chicken process-context) (chicken time posix))
|
||||
(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))
|
||||
(define (get-date-time) (seconds->local-time))
|
||||
|
||||
;; ; guile, invoke with guile vm.scm ROM ...
|
||||
;; ;; 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) (localtime (current-time)))
|
||||
|
||||
;; ; chibi scheme, invoke with ???
|
||||
;; ;; 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 ...
|
||||
;; ;; 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
|
||||
;; === 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
|
||||
;; 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))
|
||||
|
|
@ -45,12 +47,12 @@
|
|||
(define pc 256)
|
||||
(define done #f)
|
||||
|
||||
; instruction modes
|
||||
;; instruction modes
|
||||
(define _2 #f)
|
||||
(define _wst wst)
|
||||
(define _rst rst)
|
||||
|
||||
; convert numbers to 8-bit and 16-bit values
|
||||
;; 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))
|
||||
|
|
@ -60,8 +62,8 @@
|
|||
(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
|
||||
;; 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)))
|
||||
|
|
@ -71,18 +73,18 @@
|
|||
(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
|
||||
;; 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
|
||||
;; 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
|
||||
;; push value to the given stack
|
||||
(define (_xpush1 st n)
|
||||
(let ((i (car st)))
|
||||
(vector-set! (cdr st) i (u8 n))
|
||||
|
|
@ -91,33 +93,33 @@
|
|||
(_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
|
||||
;; 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
|
||||
;; 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
|
||||
;; 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
|
||||
;; restore a stack pointer when in keep mode
|
||||
(define (restore k)
|
||||
(if (null? k)
|
||||
'()
|
||||
(set-car! _wst k)))
|
||||
|
||||
; load 8 variants of an instruction
|
||||
;; load 8 variants of an instruction
|
||||
(define (op impl s k r)
|
||||
(lambda ()
|
||||
(set! _2 s)
|
||||
|
|
@ -132,12 +134,12 @@
|
|||
(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.
|
||||
;; 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))
|
||||
|
|
@ -172,7 +174,7 @@
|
|||
(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
|
||||
;; DEI base instruction implementation
|
||||
(define (dei-impl k)
|
||||
(let ((port (_pop1)))
|
||||
(restore k)
|
||||
|
|
@ -188,9 +190,9 @@
|
|||
((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)
|
||||
;; (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 (seconds->local-time)))
|
||||
(u8 (let ((t (get-date-time)))
|
||||
(cond
|
||||
((= field 0) (u16->hi (+ 1900 (vector-ref t 5)))) ; year hi
|
||||
((= field 1) (u16->lo (+ 1900 (vector-ref t 5)))) ; year lo
|
||||
|
|
@ -202,10 +204,12 @@
|
|||
((= 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
|
||||
((= field 10)
|
||||
(let ((x (vector-ref t 8)))
|
||||
(cond ((not x) 0) ((= x 0) 0) (* 1)))) ; is dst
|
||||
(* (vector-ref dev (+ 192 field))))))) ; device memory
|
||||
|
||||
; DEO base instruction implementation
|
||||
;; DEO base instruction implementation
|
||||
(define (deo-impl k)
|
||||
(let* ((dev (_pop1)) (n (_pop)))
|
||||
(restore k)
|
||||
|
|
@ -242,7 +246,7 @@
|
|||
(display (number->string (quotient n 16) 16) port)
|
||||
(display (number->string (modulo n 16) 16) port))
|
||||
|
||||
; SFT base instruction implementation
|
||||
;; SFT base instruction implementation
|
||||
(define (sft-impl k)
|
||||
(let* ((n (_pop1))
|
||||
(a (_pop))
|
||||
|
|
@ -251,8 +255,8 @@
|
|||
(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).
|
||||
;; 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--
|
||||
|
|
@ -263,7 +267,7 @@
|
|||
(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
|
||||
;; 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
|
||||
|
|
@ -273,7 +277,7 @@
|
|||
(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 instructions for base 0x01 through 0x1f
|
||||
(add-op 1 inc-impl)
|
||||
(add-op 2 pop-impl)
|
||||
(add-op 3 nip-impl)
|
||||
|
|
@ -307,7 +311,7 @@
|
|||
(add-op 30 eor-impl)
|
||||
(add-op 31 sft-impl)
|
||||
|
||||
; evaluation loop
|
||||
;; evaluation loop
|
||||
(define (u:eval)
|
||||
(if done '()
|
||||
(let* ((byte (vector-ref mem pc))
|
||||
|
|
@ -338,12 +342,12 @@
|
|||
(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, or end of stdin
|
||||
;; 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 c type)
|
||||
(let* ((hi (vector-ref dev 16))
|
||||
(lo (vector-ref dev 17))
|
||||
|
|
@ -362,7 +366,7 @@
|
|||
(u:send-input c 1)
|
||||
(u:read-stdin port)))))
|
||||
|
||||
; load a ROM from a file, byte-by-byte
|
||||
;; load a ROM from a file, byte-by-byte
|
||||
(define (u:load-rom rom addr)
|
||||
(let ((byte (get-u8 rom)))
|
||||
(if (eof-object? byte)
|
||||
|
|
|
|||
Loading…
Reference in New Issue