retro Ngaro vm implementation first shot added by C-Keen on Mon Nov 14 21:32:07 2011
(use numbers extras srfi-1 stty)
;; machine declarations
(define *m* (make-vector 1000000 0))
(define *data* (make-vector 1024 0))
(define *addr* (make-vector 128 0))
(define *ip* 0)
(define *dataptr* 0)
(define *addrptr* 0)
;; convenience procedures
(define (dataptr+)
(set! *dataptr* (add1 *dataptr*)))
(define (dataptr-)
(set! *dataptr* (sub1 *dataptr*)))
(define (tos) (vector-ref *data* (sub1 *dataptr*)))
(define (ip #!optional (addr *ip*))
(vector-ref *m* addr))
(define (ip+)
(if (> (add1 *ip*)
1000000)
(error "out of memory")
(set! *ip* (add1 *ip*))))
(define (ip-)
(set! *ip* (sub1 *ip*)))
(define (pushd x)
; (fprintf (current-error-port) "~s -> ~s~%" x (normalize x))
(vector-set! *data* *dataptr* (normalize x))
(dataptr+))
(define (popd)
(dataptr-)
(vector-ref *data* *dataptr*))
(define (toas)
(vector-ref *addr* (sub1 *addrptr*)))
(define (addrptr+)
(set! *addrptr* (add1 *addrptr*)))
(define (addrptr-)
(set! *addrptr* (sub1 *addrptr*)))
(define (pusha x)
(vector-set! *addr* *addrptr* (normalize x))
(addrptr+))
(define (popa)
(addrptr-)
(vector-ref *addr* *addrptr*))
(define *ports* (make-vector 12 0))
(define (bytes->cell b1 b2 b3 b4)
; (fprintf (current-error-port) b1 " " b2 " " b3 " " b4)
(normalize (+ b1
(* b2 256)
(* b3 256 256)
(* b4 256 256 256))))
(define (load-image filename)
(fprintf (current-error-port) "Loading file ~s~%" filename)
(with-input-from-file
filename
(lambda ()
(let loop ()
(let* ((b1 (read-byte))
(b2 (read-byte))
(b3 (read-byte))
(b4 (read-byte)))
(if (not (eof-object? b4))
(begin
(vector-set! *m* *ip* (bytes->cell b1 b2 b3 b4))
(ip+)
(loop))))))))
(define (normalize val)
(if (< #x7fffffff val)
(inexact->exact (sub1 (- #xffffffff val)))
val))
(define (string-from-memory ptr)
(let loop ((i ptr)
(res '()))
(let ((c (vector-ref *m* ptr)))
(case c
((#\0) (list->string (reverse res)))
(else (loop (add1 i) (cons c res)))))))
(define (push-string str addr)
(for-each (lambda (c a)
(vector-set! *m* a (char->integer)))
(string->list str)
(iota (string-length str) addr))
(vector-set! (+ addr (string-length str))
0))
(define (display-cell c)
(if (> c 0)
(display (integer->char c))
(display "\x1b[2J\x1b[1;1H"))
(flush-output (current-output-port))
(when (= c 8)
(display (integer->char 32))
(flush-output (current-output-port))
(display (integer->char 8)))
(flush-output (current-output-port)))
(define (read-to-cell)
(let ((c (read-char)))
(if (eof-object? c)
(exit 0)
(begin
(flush-output)
(char->integer c)))))
;;I/O ports
(define (process-port p)
(let ((op (vector-ref *ports* p)))
(case p
((0) 0)
((1) (fprintf (current-error-port) "read!~%") (read-to-cell))
((2) (fprintf (current-error-port) "char ~s!~%" (tos)) (display-cell (popd)) 0)
((3) (flush-output) 0) ;; refresh video XXX implement me please!
((4) 0) ;; file i/o
((5) ; query VM
(case op
((-1) 1000000) ; memsize
((-2) 0) ; canvas exist?
((-3) 0) ; canvas width
((-4) 0) ; canvas height
((-5) *dataptr*) ; data stack depth
((-6) *addrptr*) ; address stack depth
((-7) 0) ; mouse?
((-8) (current-seconds))
((-9) (set! *ip* 1000000))
((-10)(list (or
(get-environment-variable (string-from-memory (popd)))
"")
(popd)))
((-11) 0) ; terminal width
((-12) 0) ; terminal height
(else (fprintf (current-error-port) "unknown operation ~s on port ~s~%" op p )
0)))
((6) 0) ;; XXX canvas
((7) 0) ;; XXX mouse
(else (fprintf (current-error-port) "Unknown port ~s~%" p) 0)
)))
(define (process-ports)
(fprintf (current-error-port) "ports ~a~%" *ports*)
(if (= 0 (vector-ref *ports* 0))
(begin
(do ((i 0 (add1 i)))
((> i 7) #t)
(fprintf (current-error-port) "i: ~s~%" i)
(if (not (equal? 0 (vector-ref *ports* i)))
(begin
(fprintf (current-error-port) "Processing port ~s~%" i)
(vector-set! *ports* i (process-port i))
(fprintf (current-error-port) "result ~s~%" (vector-ref *ports* i))
(vector-set! *ports* 0 1)))))
(fprintf (current-error-port) "nothing to do!~%")))
(define (read-from-port p)
(fprintf (current-error-port) "read from port ~s~%" p)
(let ((res (vector-ref *ports* p)))
(fprintf (current-error-port) "~s~%" res)
(cond ((pair? res)
(fprintf (current-error-port) "pushing pair~%")
(for-each pushd res))
((string? res)
(fprintf (current-error-port) "pushing string~%")
(push-string res))
(else
(fprintf (current-error-port) "pushing ~s on stack~%" res)
(pushd res))))
(vector-set! *ports* p 0))
;; Instructions
(define (process-instruction)
(case (ip)
((0)
(fprintf (current-error-port) "NOP~%")
#t) ; NOP
((1)
(fprintf (current-error-port) "LIT ~s~%" (ip (add1 *ip*)))
(ip+)
(pushd (ip))) ; LIT
((2)
(fprintf (current-error-port) "DUP~%")
(pushd (tos))) ; DUP
((3)
(fprintf (current-error-port) "DROP~%")
(popd)) ; DROP
((4)
(fprintf (current-error-port) "SWAP~%")
(let* ((d1 (popd))
(d2 (popd)))
(pushd d1)
(pushd d2))) ; SWAP
((5)
(fprintf (current-error-port) "PUSH ~s~%" (tos))
(pusha (popd))) ; PUSH
((6)
(fprintf (current-error-port) "POP ~s~%" (toas))
(pushd (popa))) ; POP
((7)
(fprintf (current-error-port) "LOOP~%")
(ip+)
(if (< 0 (tos))
(set! *ip* (ip))
(popd))) ; LOOP
((8)
(fprintf (current-error-port) "JUMP~%")
(ip+)
(set! *ip* (sub1 (ip)))) ; JUMP
((9)
(fprintf (current-error-port) "RETURN ~s~%" (toas))
(set! *ip* (popa))) ; RETURN
((10)
(fprintf (current-error-port) "LT_JUMP~%")
(ip+)
(let* ((a (popd))
(b (popd)))
(if (< a b)
(set! *ip* (sub1 (ip)))))) ; LT_JUMP
((11)
(fprintf (current-error-port) "GT_JUMP~%")
(ip+)
(let* ((a (popd))
(b (popd)))
(if (> a b)
(set! *ip* (sub1 (ip)))))) ; GT_JUMP
((12)
(fprintf (current-error-port) "NE_JUMP~%")
(ip+)
(let* ((a (popd))
(b (popd)))
(if (not (= a b))
(set! *ip* (sub1 (ip)))))) ; NE_JUMP
((13)
(fprintf (current-error-port) "EQ_JUMP~%")
(ip+)
(let* ((a (popd))
(b (popd)))
(if (= a b)
(set! *ip* (sub1 (ip)))))) ; EQ_JUMP
((14)
(fprintf (current-error-port) "FETCH~%")
(pushd (ip (popd)))) ; FETCH
((15)
(fprintf (current-error-port) "STORE~%")
(let* ((addr (popd))
(val (popd)))
(fprintf (current-error-port) "addr ~s val ~s~%" addr val)
(vector-set! *m* addr val))) ; STORE
((16)
(fprintf (current-error-port) "ADD~%")
(pushd (normalize (+ (popd) (popd))))) ; ADD
((17)
(fprintf (current-error-port) "SUB~%")
(pushd (normalize (- (popd) (popd))))) ; SUB
((18)
(fprintf (current-error-port) "MUL~%")
(pushd (normalize (* (popd) (popd))))) ; MUL
((19)
(fprintf (current-error-port) "DIVMOD~%")
(let* ((b (popd))
(a (popd)))
(pushd (remainder a b))
(pushd (quotient a b)))) ; DIVMOD
((20)
(fprintf (current-error-port) "AND~%")
(pushd (bitwise-and (popd) (popd)))) ; AND
((21)
(fprintf (current-error-port) "OR~%")
(pushd (bitwise-or (popd) (popd)))) ; OR
((22)
(fprintf (current-error-port) "XOR~%")
(pushd (bitwise-xor (popd) (popd)))) ; XOR
((23)
(fprintf (current-error-port) "SHL~%")
(let* ((b (popd))
(a (popd)))
(pushd (normalize (arithmetic-shift a b))))) ; SHL
((24)
(fprintf (current-error-port) "SHR~%")
(let* ((b (popd))
(a (popd)))
(pushd (normalize (arithmetic-shift a (- b)))))) ; SHR
((25)
(fprintf (current-error-port) "ZERO_EXIT~%")
(if (zero? (tos))
(begin
(popd)
(set! *ip* (popa))))) ; ZERO_EXIT
((26)
(fprintf (current-error-port) "INC~%")
(pushd (normalize (add1 (popd))))) ; INC
((27)
(fprintf (current-error-port) "DEC~%")
(pushd (normalize (sub1 (popd))))) ; DEC
((28)
(fprintf (current-error-port) "IN~%")
(read-from-port (popd))) ; IN
((29)
(fprintf (current-error-port) "OUT~%")
(let* ((p (popd))
(val (popd)))
(fprintf (current-error-port) "p ~s val ~s~%" p val)
(vector-set! *ports* p val))) ; OUT
((30)
(fprintf (current-error-port) "WAIT~%")
(process-ports)) ; WAIT
(else
(fprintf (current-error-port) "impl. CALL~%")
(pusha *ip*) ; implicit call
(set! *ip* (sub1 (ip))))))
(define (run)
(set! *ip* 0)
(let loop ()
(when (< *ip* 1000000)
(fprintf (current-error-port) "ip ~s: ~s stack ptr ~s: ~s~%" *ip* (ip) *dataptr* (if (< 0 *dataptr*) (tos) "<>"))
(process-instruction)
(ip+)
(loop))))
(let ((old-attrs (get-terminal-attributes (current-input-port))))
(on-exit (lambda () (set-terminal-attributes! (current-input-port) TCSADRAIN old-attrs)))
(stty '(not brkint istrip ixon ixoff))
(stty '(ignbrk ignpar))
(stty '(not icanon isig echo iexten))
(set-buffering-mode! (current-input-port) #:none)
(set-buffering-mode! (current-output-port) #:none))
(load-image (cadr (argv)))
(run)