#lang br/quicklang

(provide cpy jnz inc dec
         ops pc a b c d result
         ops! a! b! c! d!
         next
         compile run
         read-syntax
         #%module-begin
         (all-from-out br/quicklang)    ; basically racket/base
         )

;;; support for: #lang reader "12i.rkt"

(module+ reader
  (provide read-syntax))

(define (read-syntax path port)
  (define ops (compile port))
  (datum->syntax #f `(module cpu-mod "12i.rkt"
                       (provide pc a b c d result)
                       (run (list ,@ops)))))

(define (compile port)
  (for/list ([line (in-lines port)]
             #:when (non-empty-string? line))
    (format-datum '(~a) line)))

(define (run opcodes [initial-values #f])
  ;; TODO
  ;; (displayln opcodes)
  ;; (set! opcodes (for/list ([op (in-list opcodes)])
  ;;                 (if (procedure? op)
  ;;                     op
  ;;                     ;; Unfortunately, (expand op) does this:
  ;;                     ;;
  ;;                     ;; (inc a) -> (#<syntax:... (#%app (#%top . inc) (#%top ....>)
  ;;                     (expand op))))
  ;; (displayln opcodes)

  (ops! opcodes)
  ;; (when initial-values ; TODO
  ;;   (set! pc (list-ref initial-values 0))
  ;;   (set! a  (list-ref initial-values 1))
  ;;   (set! b  (list-ref initial-values 2))
  ;;   (set! c  (list-ref initial-values 3))
  ;;   (set! d  (list-ref initial-values 4)))
  (void (next))
  (set! result `((pc ,pc) (a ,a) (b ,b) (c ,c) (d ,d)))
  result
  )

;;; registers & memory

(define result #f)
(define ops #f)
(define ops-max #f)
(define-values (pc a b c d) (values 0 0 0 0 0))

(define (ops! v)
  (set!-values (pc a b c d) (values 0 0 0 0 0))
  (set! ops (list->vector v))
  (set! ops-max (vector-length ops)))
(define (pc+ n) (set! pc (+ pc n)))
(define (pc++) (pc+ 1))
(define (a! v) (set! a v))
(define (b! v) (set! b v))
(define (c! v) (set! c v))
(define (d! v) (set! d v))

;;; macros for ops

(begin-for-syntax
  (define (setter id) (format-id id "~a!" id)))

(define-syntax (cpy stx)
  (syntax-case stx ()
    [(cpy A B) #`(thunk (#,(setter #'B) A)        (pc++) (next))]))

(define-syntax-rule (jnz A B)
  (thunk                (pc+ (if (zero? A) 1 B))         (next)))

(define-syntax (inc stx)
  (syntax-case stx ()
    [(inc A)   #`(thunk (#,(setter #'A) (add1 A)) (pc++) (next))]))

(define-syntax (dec stx)
  (syntax-case stx ()
    [(_ A)     #`(thunk (#,(setter #'A) (sub1 A)) (pc++) (next))]))

(define (next)
  (and (< pc ops-max) ((vector-ref ops pc))))

(module* test racket
  (require rackunit)
  (require check-sexp-equal)
  (require br)
  (require (prefix-in my/ (submod "..")))

  (check-equal? (my/compile (open-input-string "inc a"))
                '((inc a)))

  ;; Have I wired up my module the way I thought?
  (check-sexp-equal? (test-reader my/read-syntax "inc a\ndec z")
                '(module cpu-mod "12i.rkt"
                   (provide pc a b c d result)
                   (run (list (inc a) (dec z)))))

  ;; does this work in the slightest?
  (check-sexp-equal? (eval `(begin
                              ,(test-reader my/read-syntax "inc a")
                              (dynamic-require ''cpu-mod 'result)))
                     '((pc 1) (a 1) (b 0) (c 0) (d 0)))

  ;; does this reset properly?
  (check-sexp-equal? (eval `(begin
                              ,(test-reader my/read-syntax "inc b\ninc b")
                              (dynamic-require ''cpu-mod 'result)))
                     '((pc 2) (a 0) (b 2) (c 0) (d 0)))

  ;;; FAILS: because passing '((inc a)) instead of expanded thunks
  (check-equal? (my/run (my/compile (open-input-string "inc a")))
                '((pc 1) (a 1) (b 0) (c 0) (d 0)))

  (displayln 'done))