(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)