(define version
  "$LastChangedDate: 2006-03-20 23:05:26 -0500 (Mon, 20 Mar 2006) $")

(require (only mzscheme print-struct))
(print-struct #t)

(define ^32 (expt 2 32))
(define ^31 (expt 2 31))
(define ^28 (expt 2 28))
(define ^24 (expt 2 24))
(define ^16 (expt 2 16))
(define ^15 (expt 2 15))
(define ^8  (expt 2 8 ))

;; Machine capacities

; registers : integer
(define registers 32) ; we have 32 registers

; register? : value -> boolean
(define register?
  (lambda (i)
    (and (integer? i)
         (<= 0 i (- registers 1)))))

; constant? : value -> boolean
(define constant? ; a constant (used in the "li" instruction) is 16 bits
  (lambda (i)
    (and (integer? i)
         (<= (- ^15) i (- ^15 1)))))

; word? : value -> boolean
(define word? ; a word is 32 bits
  (lambda (i)
    (and (integer? i)
         (<= (- ^31) i (- ^31 1)))))

; boolean->word : boolean -> word
(define boolean->word
  (lambda (b)
    (if b 1 0)))

; integer->word : number -> word
(define integer->word
  (lambda (i)
    (- (modulo (+ i ^31) ^32) ^31)))

;; Machine instructions

(define-datatype mi mi?
  (add-mi   (dest register?) (source1 register?) (source2 register?))
  (sub-mi   (dest register?) (source1 register?) (source2 register?))
  (mul-mi   (dest register?) (source1 register?) (source2 register?))
  (div-mi   (dest register?) (source1 register?) (source2 register?))
  (quo-mi   (dest register?) (source1 register?) (source2 register?))
  (rem-mi   (dest register?) (source1 register?) (source2 register?))
  (seq-mi   (dest register?) (source1 register?) (source2 register?))
  (sne-mi   (dest register?) (source1 register?) (source2 register?))
  (slt-mi   (dest register?) (source1 register?) (source2 register?))
  (sgt-mi   (dest register?) (source1 register?) (source2 register?))
  (sle-mi   (dest register?) (source1 register?) (source2 register?))
  (sge-mi   (dest register?) (source1 register?) (source2 register?))
  (ld-mi    (dest register?)                     (address register?))
  (st-mi    (source register?)                   (address register?))
  (li-mi    (dest register?)                     (const   constant?))
  (read-mi  (dest register?))
  (write-mi (source register?))
  (jeqz-mi  (source register?)                   (address register?))
  (j-mi                                          (address register?))
  (halt-mi))

(define nth-element
  (lambda (n lst)
    (if (zero? n) (car lst) (nth-element (- n 1) (cdr lst)))))

; word->mi : word -> mi
; Decode a word into a machine instruction
(define word->mi
  (let ((instr1 (list add-mi sub-mi mul-mi div-mi quo-mi rem-mi))
        (instr2 (list seq-mi sne-mi slt-mi sgt-mi sle-mi sge-mi)))
    (lambda (word)
      (let* ((error (lambda () (eopl:error 'word->mi "Cannot decode ~s" word)))
             (front  (quotient  word ^28))
             (rear   (remainder word ^28))
             (instr  (quotient  rear ^24))
             (rear   (remainder rear ^24))
             (field1 (quotient  rear ^16))
             (rear   (remainder rear ^16)))
        (case front
          ((1 2)
           (let* ((field2 (quotient  rear ^8))
                  (field3 (remainder rear ^8)))
             ((nth-element instr (if (= front 1) instr1 instr2))
              field1 field2 field3)))
          ((0)
           (case instr
             ((1) (ld-mi field1 rear))
             ((2) (st-mi field1 rear))
             ((3) (li-mi field1 (- (modulo (+ rear ^15) ^16) ^15)))
             ((4) (read-mi field1))
             ((5) (write-mi field1))
             ((6) (jeqz-mi field1 rear))
             ((7) (j-mi rear))
             ((0) (halt-mi))
             (else (error))))
          (else (error)))))))

; mi->word : mi -> word
; Encode a machine instruction into a word
(define mi->word
  (lambda (instr)
    (cases mi instr
      (add-mi   (f1 f2 f3) (+ (* 1 ^28)           (* f1 ^16) (* f2 ^8) f3))
      (sub-mi   (f1 f2 f3) (+ (* 1 ^28) (* 1 ^24) (* f1 ^16) (* f2 ^8) f3))
      (mul-mi   (f1 f2 f3) (+ (* 1 ^28) (* 2 ^24) (* f1 ^16) (* f2 ^8) f3))
      (div-mi   (f1 f2 f3) (+ (* 1 ^28) (* 3 ^24) (* f1 ^16) (* f2 ^8) f3))
      (quo-mi   (f1 f2 f3) (+ (* 1 ^28) (* 4 ^24) (* f1 ^16) (* f2 ^8) f3))
      (rem-mi   (f1 f2 f3) (+ (* 1 ^28) (* 5 ^24) (* f1 ^16) (* f2 ^8) f3))
      (seq-mi   (f1 f2 f3) (+ (* 2 ^28)           (* f1 ^16) (* f2 ^8) f3))
      (sne-mi   (f1 f2 f3) (+ (* 2 ^28) (* 1 ^24) (* f1 ^16) (* f2 ^8) f3))
      (slt-mi   (f1 f2 f3) (+ (* 2 ^28) (* 2 ^24) (* f1 ^16) (* f2 ^8) f3))
      (sgt-mi   (f1 f2 f3) (+ (* 2 ^28) (* 3 ^24) (* f1 ^16) (* f2 ^8) f3))
      (sle-mi   (f1 f2 f3) (+ (* 2 ^28) (* 4 ^24) (* f1 ^16) (* f2 ^8) f3))
      (sge-mi   (f1 f2 f3) (+ (* 2 ^28) (* 5 ^24) (* f1 ^16) (* f2 ^8) f3))
      (ld-mi    (f1 rear ) (+           (* 1 ^24) (* f1 ^16)         rear))
      (st-mi    (f1 rear ) (+           (* 2 ^24) (* f1 ^16)         rear))
      (li-mi    (f1 rear ) (+           (* 3 ^24) (* f1 ^16) (modulo rear ^16)))
      (read-mi  (f1      ) (+           (* 4 ^24) (* f1 ^16)             ))
      (write-mi (f1      ) (+           (* 5 ^24) (* f1 ^16)             ))
      (jeqz-mi  (f1 rear ) (+           (* 6 ^24) (* f1 ^16)         rear))
      (j-mi     (   rear ) (+           (* 7 ^24)                    rear))
      (halt-mi  (        ) 0                                             ))))

;; Assembly language

(define the-lexical-spec
  '((whitespace (whitespace)                                   skip)
    (comment    (";" (arbno (not #\newline)))                  skip)
    (identifier (letter (arbno (or letter digit "_" "-" "?"))) symbol)
    (number     (digit (arbno digit))                          number)
    (number     ("-" digit (arbno digit))                      number)))

(define the-grammar
  '((program ((arbno allocation) (arbno label-ai) (arbno test)) a-program)

    (allocation ("allocate-registers" identifier (arbno "," identifier)) alloc)

    (label-ai ((arbno identifier ":") ai) label)

    (ai ("add"   field "," field "," field) add-ai)
    (ai ("sub"   field "," field "," field) sub-ai)
    (ai ("mul"   field "," field "," field) mul-ai)
    (ai ("div"   field "," field "," field) div-ai)
    (ai ("quo"   field "," field "," field) quo-ai)
    (ai ("rem"   field "," field "," field) rem-ai)
    (ai ("seq"   field "," field "," field) seq-ai)
    (ai ("sne"   field "," field "," field) sne-ai)
    (ai ("slt"   field "," field "," field) slt-ai)
    (ai ("sgt"   field "," field "," field) sgt-ai)
    (ai ("sle"   field "," field "," field) sle-ai)
    (ai ("sge"   field "," field "," field) sge-ai)
    (ai ("ld"    field "," indirect-field ) ld-ai)
    (ai ("st"    field "," indirect-field ) st-ai)
    (ai ("li"    field "," field          ) li-ai)
    (ai ("read"  field                    ) read-ai)
    (ai ("write" field                    ) write-ai)
    (ai ("jeqz"  field "," indirect-field ) jeqz-ai)
    (ai ("j"     indirect-field           ) j-ai)
    (ai ("halt"                           ) halt-ai)

    (indirect-field (    field    ) indirect-field)
    (indirect-field ("[" field "]") indirect-field)

    (field (number    ) numeric-field)
    (field (identifier) symbolic-field)

    (test ("test" identifier (arbno action)) a-test)

    (action (number) write-action)
    (action (">>>" number) read-action)))

(sllgen:make-define-datatypes the-lexical-spec the-grammar)
(define indirect-field (lambda (f) f)) ; overwrite define-datatype
(define indirect-field? field?)        ; overwrite define-datatype

(define show-the-datatypes
  (lambda () (sllgen:list-define-datatypes the-lexical-spec the-grammar)))

(define scan&parse
  (sllgen:make-string-parser the-lexical-spec the-grammar))

(define just-scan
  (sllgen:make-string-scanner the-lexical-spec the-grammar))

; unparse-program : program -> string
(define unparse-program
  (lambda (pgm)
    (cases program pgm
      (a-program (header body tests) ; ignore tests for unparsing for now
        (string-append
          (apply string-append (map unparse-allocation header))
          (apply string-append (unparse-body body)))))))

; unparse-allocation : allocation -> string
(define unparse-allocation
  (lambda (a)
    (cases allocation a
      (alloc (id ids)
        (string-append
          "allocate-registers "
          (symbol->string id)
          (apply string-append (map (lambda (id)
                                      (string-append ", " (symbol->string id)))
                                    ids))
          "\n")))))

; unparse-body : list-of label-ai -> list-of string
(define unparse-body
  (lambda (body)
    (let loop ((body body) (addr 0))
      (if (null? body)
        '()
        (let* ((str (unparse-label-ai (car body)))
               (len (string-length str)))
          (append (list str
                        (make-string
                          (let loop ((i (- len 1)))
                            (if (eqv? (string-ref str i) #\tab)
                              (- 13 (- len i))
                              (loop (- i 1))))
                          #\space)
                        ";"
                        (number->string addr)
                        "\n")
                  (loop (cdr body) (+ 1 addr))))))))

; unparse-label-ai : label-ai -> string
(define unparse-label-ai
  (lambda (label-instr)
    (cases label-ai label-instr
      (label (ids instr)
        (string-append
          (apply string-append (map (lambda (id)
                                      (string-append (symbol->string id) ":\n"))
                                    ids))
          (unparse-ai instr))))))

; unparse-ai : ai -> string
(define unparse-ai
  (let ((u (lambda (name . fields)
             (string-append
               "\t"
               name
               "\t"
               (if (null? fields) ""
                 (string-append
                   (unparse-field (car fields))
                   (apply string-append
                     (map (lambda (f) (string-append ", " (unparse-field f)))
                          (cdr fields)))))))))
    (lambda (instr)
      (cases ai instr
        (add-ai   (f1 f2 f3) (u "add"   f1 f2 f3))
        (sub-ai   (f1 f2 f3) (u "sub"   f1 f2 f3))
        (mul-ai   (f1 f2 f3) (u "mul"   f1 f2 f3))
        (div-ai   (f1 f2 f3) (u "div"   f1 f2 f3))
        (quo-ai   (f1 f2 f3) (u "quo"   f1 f2 f3))
        (rem-ai   (f1 f2 f3) (u "rem"   f1 f2 f3))
        (seq-ai   (f1 f2 f3) (u "seq"   f1 f2 f3))
        (sne-ai   (f1 f2 f3) (u "sne"   f1 f2 f3))
        (slt-ai   (f1 f2 f3) (u "slt"   f1 f2 f3))
        (sgt-ai   (f1 f2 f3) (u "sgt"   f1 f2 f3))
        (sle-ai   (f1 f2 f3) (u "sle"   f1 f2 f3))
        (sge-ai   (f1 f2 f3) (u "sge"   f1 f2 f3))
        (ld-ai    (f1 f2)    (u "ld"    f1 f2   ))
        (st-ai    (f1 f2)    (u "st"    f1 f2   ))
        (li-ai    (f1 f2)    (u "li"    f1 f2   ))
        (read-ai  (f1)       (u "read"  f1      ))
        (write-ai (f1)       (u "write" f1      ))
        (jeqz-ai  (f1 f2)    (u "jeqz"  f1 f2   ))
        (j-ai     (f1)       (u "j"     f1      ))
        (halt-ai  ()         (u "halt"          ))))))

; unparse-field : field -> string
(define unparse-field
  (lambda (f)
    (cases field f
      (numeric-field (n) (number->string n))
      (symbolic-field (id) (symbol->string id)))))

; slurp-file : string -> string
; Read a file into a string
(define slurp-file
  (lambda (str)
    (call-with-input-file str
      (lambda (port)
        (let loop ((r (read-char port)))
          (if (eof-object? r)
            ""
            (string-append (string r) (loop (read-char port)))))))))

; allocate-registers : list-of allocation -> list-of (pair-of identifier number)
(define allocate-registers
  (lambda (as)
    (let ((identifiers
           (apply append
              (map (lambda (a)
                     (cases allocation a
                       (alloc (id ids) (cons id ids))))
                   as)))
          (start 0) ; for complexity, use 2
          (step 1)) ; for complexity, use 17
      (let loop ((ids identifiers) (i start))
        (cond
          ((null? ids) '())
          ((and (eq? i start) (not (eq? ids identifiers)))
           (eopl:error 'allocate-registers
                       "Cannot allocate more than ~s registers" registers))
          (else (cons (cons (car ids) i)
                      (loop (cdr ids) (remainder (+ i step) registers)))))))))

; resolve-labels : list-of label-ai -> list-of (pair-of identifier number)
(define resolve-labels
  (lambda (is)
    (let loop ((is is) (addr 0))
      (if (null? is)
        '()
        (append (cases label-ai (car is)
                  (label (ids instr) (map (lambda (id) (cons id addr)) ids)))
                (loop (cdr is) (+ 1 addr)))))))

; name-clash : list-of (pair-of identifier number) -> symbol or #f
(define name-clash
  (lambda (alist)
    (cond
      ((null? alist) #f)
      ((assv (caar alist) (cdr alist)) (caar alist))
      (else (name-clash (cdr alist))))))

; assemble : program -> list-of mi
(define assemble
  (lambda (prog)
    (cases program prog
      (a-program (as is tests)
        (let* ((alist (append (allocate-registers as) (resolve-labels is)))
               (clash (name-clash alist)))
          (if clash
            (eopl:error 'assemble "The name ~s is defined more than once" clash)
            (assemble-ais
              (lambda (id)
                (cond
                  ((assv id alist) => cdr)
                  (else (eopl:error 'assemble "The name ~s is undefined" id))))
              is)))))))

; assemble-ais : (symbol -> number) * list-of label-ai -> list-of mi
(define assemble-ais
  (lambda (symbol->number is)
    (map (lambda (label-instr) (assemble-ai symbol->number label-instr)) is)))

; assemble-ai : (symbol -> number) * label-ai -> mi
(define assemble-ai
  (lambda (symbol->number label-instr)
    (let* ((field->number
            (lambda (f)
              (cases field f
                (numeric-field (n) n)
                (symbolic-field (id) (symbol->number id)))))
           (make-mi
            (lambda (constructor . fields)
              (apply constructor (map field->number fields)))))
      (cases label-ai label-instr
        (label (ids instr)
          (cases ai instr
            (add-ai   (f1 f2 f3) (make-mi add-mi   f1 f2 f3))
            (sub-ai   (f1 f2 f3) (make-mi sub-mi   f1 f2 f3))
            (mul-ai   (f1 f2 f3) (make-mi mul-mi   f1 f2 f3))
            (div-ai   (f1 f2 f3) (make-mi div-mi   f1 f2 f3))
            (quo-ai   (f1 f2 f3) (make-mi quo-mi   f1 f2 f3))
            (rem-ai   (f1 f2 f3) (make-mi rem-mi   f1 f2 f3))
            (seq-ai   (f1 f2 f3) (make-mi seq-mi   f1 f2 f3))
            (sne-ai   (f1 f2 f3) (make-mi sne-mi   f1 f2 f3))
            (slt-ai   (f1 f2 f3) (make-mi slt-mi   f1 f2 f3))
            (sgt-ai   (f1 f2 f3) (make-mi sgt-mi   f1 f2 f3))
            (sle-ai   (f1 f2 f3) (make-mi sle-mi   f1 f2 f3))
            (sge-ai   (f1 f2 f3) (make-mi sge-mi   f1 f2 f3))
            (ld-ai    (f1 f2)    (make-mi ld-mi    f1 f2   ))
            (st-ai    (f1 f2)    (make-mi st-mi    f1 f2   ))
            (li-ai    (f1 f2)    (make-mi li-mi    f1 f2   ))
            (read-ai  (f1)       (make-mi read-mi  f1      ))
            (write-ai (f1)       (make-mi write-mi f1      ))
            (jeqz-ai  (f1 f2)    (make-mi jeqz-mi  f1 f2   ))
            (j-ai     (f1)       (make-mi j-mi     f1      ))
            (halt-ai  ()         (make-mi halt-mi          ))))))))

; disassemble : list-of mi -> program
(define disassemble
  (lambda (mis)
    (a-program '() (disassemble-mis mis) '())))

; disassemble-mis : list-of mi -> list-of label-ai
(define disassemble-mis
  (lambda (mis)
    (map disassemble-mi mis)))

; disassemble-mi : mi -> label-ai
(define disassemble-mi
  (let ((make-ai (lambda (constructor . fields)
                   (apply constructor (map numeric-field fields)))))
    (lambda (instr)
      (label '()
        (cases mi instr
          (add-mi   (dest src1 src2) (make-ai add-ai   dest src1 src2))
          (sub-mi   (dest src1 src2) (make-ai sub-ai   dest src1 src2))
          (mul-mi   (dest src1 src2) (make-ai mul-ai   dest src1 src2))
          (div-mi   (dest src1 src2) (make-ai div-ai   dest src1 src2))
          (quo-mi   (dest src1 src2) (make-ai quo-ai   dest src1 src2))
          (rem-mi   (dest src1 src2) (make-ai rem-ai   dest src1 src2))
          (seq-mi   (dest src1 src2) (make-ai seq-ai   dest src1 src2))
          (sne-mi   (dest src1 src2) (make-ai sne-ai   dest src1 src2))
          (slt-mi   (dest src1 src2) (make-ai slt-ai   dest src1 src2))
          (sgt-mi   (dest src1 src2) (make-ai sgt-ai   dest src1 src2))
          (sle-mi   (dest src1 src2) (make-ai sle-ai   dest src1 src2))
          (sge-mi   (dest src1 src2) (make-ai sge-ai   dest src1 src2))
          (ld-mi    (dest address  ) (make-ai ld-ai    dest address  ))
          (st-mi    (src address   ) (make-ai st-ai    src address   ))
          (li-mi    (dest const    ) (make-ai li-ai    dest const    ))
          (read-mi  (dest          ) (make-ai read-ai  dest          ))
          (write-mi (src           ) (make-ai write-ai src           ))
          (jeqz-mi  (src address   ) (make-ai jeqz-ai  src address   ))
          (j-mi     (address       ) (make-ai j-ai     address       ))
          (halt-mi  (              ) (make-ai halt-ai                )))))))

; Execution

(define-datatype result result?
  (halt-result)
  (read-result
    ; The continue procedure for a read-result takes a number as an argument
    (continue procedure?))
  (write-result
    (output number?)
    ; The continue procedure for a write-result takes no argument
    (continue procedure?)))

; run : list-of word * monitor -> result
; Run the given list of code words.

; The monitor argument is a function that takes four arguments: the
; program counter (an integer), the registers (a vector of 32 integers,
; mostly zero), the code memory (a vector of integers), and the data
; memory (a vector of 1000 integers, mostly zero).  This function is
; invoked before executing every instruction.  It may do nothing, or it
; may print some debugging output.

(define run
  (lambda (code-words monitor)
    (let ((code (list->vector code-words))
          (data (make-vector 1000 0))
          (regs (make-vector registers 0)))
      (let loop ((pc 0))
        (monitor pc regs code data)
        (cases mi (word->mi (vector-ref code pc))

          (add-mi (dest source1 source2)
            (vector-set! regs dest (integer->word
              (+ (vector-ref regs source1) (vector-ref regs source2))))
            (loop (+ 1 pc)))
          (sub-mi (dest source1 source2)
            (vector-set! regs dest (integer->word
              (- (vector-ref regs source1) (vector-ref regs source2))))
            (loop (+ 1 pc)))
          (mul-mi (dest source1 source2)
            (vector-set! regs dest (integer->word
              (* (vector-ref regs source1) (vector-ref regs source2))))
            (loop (+ 1 pc)))
          (div-mi (dest source1 source2)
            (vector-set! regs dest (integer->word
              (quotient (vector-ref regs source1) (vector-ref regs source2))))
            (loop (+ 1 pc)))
          (quo-mi (dest source1 source2)
            (vector-set! regs dest (integer->word
              (quotient (vector-ref regs source1) (vector-ref regs source2))))
            (loop (+ 1 pc)))
          (rem-mi (dest source1 source2)
            (vector-set! regs dest (integer->word
              (remainder (vector-ref regs source1) (vector-ref regs source2))))
            (loop (+ 1 pc)))

          (seq-mi (dest source1 source2)
            (vector-set! regs dest (boolean->word
              (= (vector-ref regs source1) (vector-ref regs source2))))
            (loop (+ 1 pc)))
          (sne-mi (dest source1 source2)
            (vector-set! regs dest (boolean->word
              (not (= (vector-ref regs source1) (vector-ref regs source2)))))
            (loop (+ 1 pc)))
          (slt-mi (dest source1 source2)
            (vector-set! regs dest (boolean->word
              (< (vector-ref regs source1) (vector-ref regs source2))))
            (loop (+ 1 pc)))
          (sgt-mi (dest source1 source2)
            (vector-set! regs dest (boolean->word
              (> (vector-ref regs source1) (vector-ref regs source2))))
            (loop (+ 1 pc)))
          (sle-mi (dest source1 source2)
            (vector-set! regs dest (boolean->word
              (<= (vector-ref regs source1) (vector-ref regs source2))))
            (loop (+ 1 pc)))
          (sge-mi (dest source1 source2)
            (vector-set! regs dest (boolean->word
              (>= (vector-ref regs source1) (vector-ref regs source2))))
            (loop (+ 1 pc)))

          (ld-mi (dest address)
            (vector-set! regs dest
                         (vector-ref data (vector-ref regs address)))
            (loop (+ 1 pc)))
          (st-mi (source address)
            (vector-set! data (vector-ref regs address)
                         (vector-ref regs source))
            (loop (+ 1 pc)))
          (li-mi (dest const)
            (vector-set! regs dest const)
            (loop (+ 1 pc)))
          (read-mi (dest)
            (read-result (lambda (input)
                           (vector-set! regs dest (integer->word input))
                           (loop (+ 1 pc)))))
          (write-mi (source)
            (write-result (vector-ref regs source)
                          (lambda () (loop (+ 1 pc)))))
          (jeqz-mi (source address)
            (loop (if (zero? (vector-ref regs source))
                    (vector-ref regs address)
                    (+ 1 pc))))
          (j-mi (address)
            (loop (vector-ref regs address)))
          (halt-mi ()
            (halt-result))

          )))))

; with-debugging, without-debugging: integer * vector-of integer
;                        * vector-of integer * vector-of integer -> garbage
; These are two functions that can be passed to "run" as the monitor argument.
(define with-debugging
  (lambda (pc regs code data)
    (eopl:printf "PC=~s R=~s M=~s~n" pc regs data)))
(define without-debugging
  (lambda (pc regs code data)
    'garbage))

; interact : result -> symbol
; The "interact" function takes as input a result returned by the "run"
; function.  It lets the user use the machine interactively.  When the
; machine halts, it returns the symbol done.
(define interact
  (lambda (res)
    (cases result res
      (halt-result () 'done)
      (read-result (continue)
       (display ">>> ")
       (let ((input (read)))
         (if (integer? input)
           (interact (continue input))
           (eopl:error 'interact "The input ~s is not an integer" input))))
      (write-result (output continue)
       (display output)
       (newline)
       (interact (continue))))))

; batch : result * script -> boolean
; The "batch" function takes as input a result returned by the "run"
; function.  It checks whether this "result" works as specified in the
; "script"
(define batch
  (lambda (res script)
    (if (null? script)
      (cases result res
        (halt-result () #t)
        (else #f))
      (cases action (car script)
        (write-action (desired-output)
         (cases result res
           (write-result (actual-output continue)
             (and (= desired-output actual-output)
                  (batch (continue) (cdr script))))
           (else #f)))
        (read-action (input)
         (cases result res
           (read-result (continue)
             (batch (continue input) (cdr script)))
           (else #f)))))))

; load-file : string -> list-of word
; Test the assembler, disassembler, and emulator on the code from the file with
; the given name, then return list of code words
(define load-file
  (lambda (file-name)
    (let* ((concrete-syntax (slurp-file file-name))
           (abstract-syntax (scan&parse concrete-syntax))
           (assembly (assemble abstract-syntax))
           (code-words (map mi->word assembly))
           (assembly-1 (map word->mi code-words))
           (disassembly (unparse-program (disassemble assembly-1)))
           (assembly-2 (assemble (scan&parse disassembly))))
      (if (not (equal? assembly assembly-1))
          (eopl:error 'test-file "mi->word word->mi roundtrip failed"))
      (if (not (equal? assembly assembly-2))
          (eopl:error 'test-file "disassemble assemble roundtrip failed"))
      (display disassembly)
      code-words)))

; test-file : string -> list-of symbol
; This function loads SLIM code from a file and runs batch tests on it.
; It returns a list of names of tests that failed.
(define test-file
  (lambda (file-name)
    (let* ((abstract-syntax (scan&parse (slurp-file file-name)))
           (code-words (map mi->word (assemble abstract-syntax))))
      (cases program abstract-syntax
        (a-program (as is tests)
         (let loop ((tests tests))
           (if (null? tests)
             '()
             (cases test (car tests)
               (a-test (name script)
                (if (batch (run code-words without-debugging) script)
                  (loop (cdr tests))
                  (cons name (loop (cdr tests)))))))))))))

; run-file : string -> symbol
; This function loads SLIM code from a file and runs it interactively.
; When the machine halts, it returns the symbol done.
(define run-file
  (lambda (file-name)
    (interact (run (load-file file-name) without-debugging))))

; debug-file : string -> symbol
; This function loads SLIM code from a file and runs it interactively
; with debugging output.  When the machine halts, it returns the symbol
; done.
(define debug-file
  (lambda (file-name)
    (interact (run (load-file file-name) with-debugging))))

; main : list-of string -> garbage
; This function is intended for use with the mzscheme command-line option -C
(define main
  (lambda (argv)
    (case (length argv)
      ((0 1)
       (eopl:error 'main "Specify the file name of the SLIM program to run"))
      ((2)
       (run-file (cadr argv)))
      ((3)
       ((case (string->symbol (caddr argv))
          ((run) run-file)
          ((debug) debug-file)
          ((test) (lambda (file-name)
                    (eopl:printf "~a failed tests: ~s~n"
                                 file-name (test-file file-name)))))
        (cadr argv)))
      (else
       (eopl:error 'main "Specify the file name of the SLIM program to run")))))

; Identify this version
(eopl:printf "SLIM emulator ~a~n" version)