From 9338012d15a300ea98060e5a5323be4240dd8650 Mon Sep 17 00:00:00 2001 From: d_m Date: Tue, 21 Jan 2025 22:12:05 -0500 Subject: [PATCH] get datetime working in guile too --- vm.scm | 114 +++++++++++++++++++++++++++++---------------------------- 1 file changed, 59 insertions(+), 55 deletions(-) diff --git a/vm.scm b/vm.scm index ae13654..5eff5b2 100644 --- a/vm.scm +++ b/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)