diff --git a/vm.scm b/vm.scm index 5eff5b2..b7b1e26 100644 --- a/vm.scm +++ b/vm.scm @@ -11,13 +11,23 @@ (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)) +(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) (localtime (current-time))) +;; (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 ??? ;; (import (scheme base) (scheme bitwise) (scheme file)) @@ -29,6 +39,12 @@ ;; ;; 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 @@ -194,20 +210,18 @@ (define (_datetime field) (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 - ((= 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) - (let ((x (vector-ref t 8))) - (cond ((not x) 0) ((= x 0) 0) (* 1)))) ; is dst - (* (vector-ref dev (+ 192 field))))))) ; device memory + ((= 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) @@ -223,24 +237,24 @@ (cond ((= 4 port) (set-car! wst byte)) ((= 5 port) (set-car! rst byte)) - ((= 14 port) (debug)) + ((= 14 port) (u:debug)) ((= 24 port) (write-char (integer->char byte) (current-output-port))) ((= 25 port) (write-char (integer->char byte) (current-error-port))) (* '()))) -(define (debug) - (debug-stack "WST" wst) (debug-stack "RST" rst)) +(define (u:debug) + (u:debug-stack "WST" wst) (u:debug-stack "RST" rst)) -(define (debug-stack label st) +(define (u:debug-stack label st) (display label) - (debug-cells (cdr st) (u8 (- (car st) 8)) (car st) (current-output-port))) + (u:debug-cells (cdr st) (u8 (- (car st) 8)) (car st) (current-output-port))) -(define (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) - (debug-cells cells (u8 (+ i 1)) limit port)))) + (u:debug-cells cells (u8 (+ i 1)) limit port)))) (define (emit-u8 n port) (display (number->string (quotient n 16) 16) port) @@ -361,7 +375,7 @@ (define (u:read-stdin port) (let ((c (read-char port))) (if (eof-object? c) - (u:send-input #\null 4) + (u:send-input #\newline 4) (begin (u:send-input c 1) (u:read-stdin port)))))