#|$ACL2s-Preamble$;
#+acl2s-startup (er-progn (assign fmt-error-msg "Problem loading the CCG book.~%Please recertify in your ACL2 image/version and retry.") (value :invisible))
(include-book "ccg" :uncertified-okp nil :load-compiled-file :comp :dir :acl2s :ttags ((ccg)))
(set-ccg-termination t)
;$ACL2s-SMode$;ACL2s
(include-book "problem-set-1-answers")

(begin-book t :ttags :all);$ACL2s-Preamble$|#




(in-package "M1")

; Here is the semantics of the M1 machine.  In addition to the ACL2 primitive
; functions in the "M1" package, we take advantage of the following
; functions defined in "problem-set-1-answers.lisp":

; push, top, pop,     - intro material of Problem Set 1
; nth                 - intro material of Problem Set 1
; update-nth          - Problem 1-14
; make-state, pc, etc - intro material of Problem Set 1
; opcode, arg1, arg2  - Problem 1-4

(defun next-inst (s)
  (nth (pc s) (program s)))

; Now we define the semantics of each instruction.  These
; functions are called ``semantic functions.''

(defun execute-ILOAD (inst s)
  (make-state (+ 1 (pc s))
              (locals s)
              (push (nth (arg1 inst)
                         (locals s))
                    (stack s))
              (program s)))

(defun execute-ICONST (inst s)
  (make-state (+ 1 (pc s))
              (locals s)
              (push (arg1 inst) (stack s))
              (program s)))

(defun execute-IADD (inst s)
  (declare (ignore inst))
  (make-state (+ 1 (pc s))
              (locals s)
              (push (+ (top (pop (stack s)))
                       (top (stack s)))
                    (pop (pop (stack s))))
              (program s)))

(defun execute-ISTORE (inst s)
  (make-state (+ 1 (pc s))
              (update-nth (arg1 inst) (top (stack s)) (locals s))
              (pop (stack s))
              (program s)))

(defun execute-ISUB (inst s)
  (declare (ignore inst))
  (make-state (+ 1 (pc s))
              (locals s)
              (push (- (top (pop (stack s)))
                       (top (stack s)))
                    (pop (pop (stack s))))
              (program s)))

(defun execute-IMUL (inst s)
  (declare (ignore inst))
  (make-state (+ 1 (pc s))
              (locals s)
              (push (* (top (pop (stack s)))
                       (top (stack s)))
                    (pop (pop (stack s))))
              (program s)))

(defun execute-GOTO (inst s)
  (make-state (+ (arg1 inst) (pc s))
              (locals s)
              (stack s)
              (program s)))

(defun execute-IFLE (inst s)
  (make-state (if (<= (top (stack s)) 0)
                  (+ (arg1 inst) (pc s))
                (+ 1 (pc s)))
              (locals s)
              (pop (stack s))
              (program s)))

(defun do-inst (inst s)
  (if (equal (op-code inst) 'ICONST)
      (execute-ICONST  inst s)
    (if (equal (op-code inst) 'ILOAD)
        (execute-ILOAD  inst s)
      (if (equal (op-code inst) 'ISTORE)
          (execute-ISTORE  inst s)
        (if (equal (op-code inst) 'IADD)
            (execute-IADD   inst s)
          (if (equal (op-code inst) 'ISUB)
              (execute-ISUB   inst s)
            (if (equal (op-code inst) 'IMUL)
                (execute-IMUL   inst s)
              (if (equal (op-code inst) 'GOTO)
                  (execute-GOTO   inst s)
                (if (equal (op-code inst) 'IFLE)
                    (execute-IFLE   inst s)
                  s)))))))))


(defun step (s)
     (do-inst (next-inst s) s))

(defun run (sched s)
     (if (endp sched)
         s
       (run (cdr sched) (step s))))