get datetime working with chez scheme
This commit is contained in:
parent
9338012d15
commit
c3886f44f2
44
vm.scm
44
vm.scm
|
@ -11,13 +11,23 @@
|
||||||
(define (get-u8 port)
|
(define (get-u8 port)
|
||||||
(let ((c (read-char port))) (if (eof-object? c) c (char->integer c))))
|
(let ((c (read-char port))) (if (eof-object? c) c (char->integer c))))
|
||||||
(define (open-rom path) (open-input-file path #:binary))
|
(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 ...
|
;; ;; guile, invoke with guile vm.scm ROM ...
|
||||||
;; (use-modules (srfi srfi-60) (ice-9 binary-ports))
|
;; (use-modules (srfi srfi-60) (ice-9 binary-ports))
|
||||||
;; (define (open-rom path) (open-input-file path))
|
;; (define (open-rom path) (open-input-file path))
|
||||||
;; (define (command-line-arguments) (cdr (command-line)))
|
;; (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 ???
|
;; ;; chibi scheme, invoke with ???
|
||||||
;; (import (scheme base) (scheme bitwise) (scheme file))
|
;; (import (scheme base) (scheme bitwise) (scheme file))
|
||||||
|
@ -29,6 +39,12 @@
|
||||||
;; ;; 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 (open-rom path) (open-file-input-port path))
|
||||||
;; (define (command-line-arguments) (cdr (command-line)))
|
;; (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
|
;; === portable scheme code follows
|
||||||
|
|
||||||
|
@ -194,8 +210,8 @@
|
||||||
(define (_datetime field)
|
(define (_datetime field)
|
||||||
(u8 (let ((t (get-date-time)))
|
(u8 (let ((t (get-date-time)))
|
||||||
(cond
|
(cond
|
||||||
((= field 0) (u16->hi (+ 1900 (vector-ref t 5)))) ; year hi
|
((= field 0) (u16->hi (vector-ref t 5))) ; year hi
|
||||||
((= field 1) (u16->lo (+ 1900 (vector-ref t 5)))) ; year lo
|
((= field 1) (u16->lo (vector-ref t 5))) ; year lo
|
||||||
((= field 2) (vector-ref t 4)) ; month
|
((= field 2) (vector-ref t 4)) ; month
|
||||||
((= field 3) (vector-ref t 3)) ; day of month
|
((= field 3) (vector-ref t 3)) ; day of month
|
||||||
((= field 4) (vector-ref t 2)) ; hours
|
((= field 4) (vector-ref t 2)) ; hours
|
||||||
|
@ -204,9 +220,7 @@
|
||||||
((= field 7) (vector-ref t 6)) ; day of week
|
((= field 7) (vector-ref t 6)) ; day of week
|
||||||
((= field 8) (u16->hi (vector-ref t 7))) ; day of year hi
|
((= 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 9) (u16->lo (vector-ref t 7))) ; day of year lo
|
||||||
((= field 10)
|
((= field 10) (if (vector-ref t 8) 1 0)) ; is dst
|
||||||
(let ((x (vector-ref t 8)))
|
|
||||||
(cond ((not x) 0) ((= x 0) 0) (* 1)))) ; is dst
|
|
||||||
(* (vector-ref dev (+ 192 field))))))) ; device memory
|
(* (vector-ref dev (+ 192 field))))))) ; device memory
|
||||||
|
|
||||||
;; DEO base instruction implementation
|
;; DEO base instruction implementation
|
||||||
|
@ -223,24 +237,24 @@
|
||||||
(cond
|
(cond
|
||||||
((= 4 port) (set-car! wst byte))
|
((= 4 port) (set-car! wst byte))
|
||||||
((= 5 port) (set-car! rst byte))
|
((= 5 port) (set-car! rst byte))
|
||||||
((= 14 port) (debug))
|
((= 14 port) (u:debug))
|
||||||
((= 24 port) (write-char (integer->char byte) (current-output-port)))
|
((= 24 port) (write-char (integer->char byte) (current-output-port)))
|
||||||
((= 25 port) (write-char (integer->char byte) (current-error-port)))
|
((= 25 port) (write-char (integer->char byte) (current-error-port)))
|
||||||
(* '())))
|
(* '())))
|
||||||
|
|
||||||
(define (debug)
|
(define (u:debug)
|
||||||
(debug-stack "WST" wst) (debug-stack "RST" rst))
|
(u:debug-stack "WST" wst) (u:debug-stack "RST" rst))
|
||||||
|
|
||||||
(define (debug-stack label st)
|
(define (u:debug-stack label st)
|
||||||
(display label)
|
(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)
|
(display (if (= i 0) "|" " ") port)
|
||||||
(if (= i limit) (display "<\n")
|
(if (= i limit) (display "<\n")
|
||||||
(begin
|
(begin
|
||||||
(emit-u8 (vector-ref cells i) port)
|
(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)
|
(define (emit-u8 n port)
|
||||||
(display (number->string (quotient n 16) 16) port)
|
(display (number->string (quotient n 16) 16) port)
|
||||||
|
@ -361,7 +375,7 @@
|
||||||
(define (u:read-stdin port)
|
(define (u:read-stdin port)
|
||||||
(let ((c (read-char port)))
|
(let ((c (read-char port)))
|
||||||
(if (eof-object? c)
|
(if (eof-object? c)
|
||||||
(u:send-input #\null 4)
|
(u:send-input #\newline 4)
|
||||||
(begin
|
(begin
|
||||||
(u:send-input c 1)
|
(u:send-input c 1)
|
||||||
(u:read-stdin port)))))
|
(u:read-stdin port)))))
|
||||||
|
|
Loading…
Reference in New Issue