assembunny.ss

(define (assembunny input)
  (define ip 0)
  (define status 'ok)
  (define memory (make-fxvector 4 0))
  (define program (list->vector input))
  (define N (vector-length program))
  (define clock-signal '())
  (define (symbol->register r)
    (case r ((a) 0) ((b) 1) ((c) 2) ((d) 3)))
  (define (val x)
    (if (integer? x) x
	(fxvector-ref memory (symbol->register x))))
  (define (step)
    (if (not (fx<= 0 ip (fx1- N)))
	(set! status 'done)
	(match (vector-ref program ip)
	  (('cpy x y)
	   (when (symbol? y)
	     (fxvector-set! memory (symbol->register y) (val x)))
	   (inc! ip))
	  (('inc x)
	   (fxvector-modify! memory (symbol->register x) fx1+)
	   (inc! ip))
	  (('dec x)
	   (fxvector-modify! memory (symbol->register x) fx1-)
	   (inc! ip))
	  (('jnz x y)
	   (if (fxzero? (val x))
	       (inc! ip)
	       (inc! ip (val y))))
	  (('out x)
	   (push! (val x) clock-signal)
	   (set! status 'ready)
	   (inc! ip))
	  (('tgl x)
	   (let ((ix (fx+ ip (val x))))
	     (inc! ip)
	     (when (fx<= 0 ix (fx1- N))
	       (match (vector-ref program ix)
		 (('inc x)
		  (vector-set! program ix `(dec ,x)))
		 ((_ x)
		  (vector-set! program ix `(inc ,x)))
		 (('jnz x y)
		  (vector-set! program ix `(cpy ,x ,y)))
		 ((_ x y)
		  (vector-set! program ix `(jnz ,x ,y))))))))))
  (define (set-register! x v)
    (fxvector-set! memory (symbol->register x) v))
  (define (get-register x)
    (fxvector-ref memory (symbol->register x)))
  (define (read-clock)
    (set! status 'ok)
    (car clock-signal))

  (lambda (me . args)
    (case me
      ((status) status)
      ((step) (step))
      ((read-clock) (read-clock))
      ((set-register!) (apply set-register! args))
      ((get-register) (apply get-register args)))))

(define (step machine)
  (machine 'step))

(define (status machine)
  (machine 'status))

(define (set-register! machine register value)
  (machine 'set-register! register value))

(define (get-register machine register)
  (machine 'get-register register))

(define (read-clock machine)
  (machine 'read-clock))

(define (run-until-halt machine)
  (let lp ()
    (unless (eq? 'done (status machine))
      (step machine)
      (lp))))

(define (run-until-clock machine)
  (let lp ()
    (unless (eq? 'ready (status machine))
      (step machine)
      (lp))))