#|
(include-book "problem-set-1-answers")
(certify-book "new-m1" 1)
|#

(in-package "M1")

; --- this section defines the modify and defsem macros ---

(defmacro modify (s &rest args)
     (list 'make-state
           (if (suppliedp :pc args)
               (actual :pc args)
             (list '+ 1 (list 'pc s)))
           (if (suppliedp :locals args)
               (actual :locals args)
             (list 'locals s))
           (if (suppliedp :stack args)
               (actual :stack args)
             (list 'stack s))
           (if (suppliedp :program args)
               (actual :program args)
             (list 'program s))))

(defun pattern-bindings (vars arg-expressions)
  (if (endp vars)
      nil
    (cons (list (car vars) (car arg-expressions))
          (pattern-bindings (cdr vars) (cdr arg-expressions)))))

(defmacro semantics (pattern body)
  (list 'let (app (pattern-bindings (cdr pattern)
                                    '((arg1 inst)
                                      (arg2 inst)
                                      (arg3 inst)))
                  '((-pc- (pc s))
                    (-locals- (locals s))
                    (-stack- (stack s))
                    (-program- (program s))))
        body))

(defun concat-symbols (part1 part2)
  (intern-in-package-of-symbol
   (coerce
    (app (coerce (symbol-name part1) 'list)
         (coerce (symbol-name part2) 'list))
    'string)
   'run))

(defun make-defun (name args dcl body)
  (if dcl
      (list 'defun name args dcl body)
    (list 'defun name args body)))

(defmacro defsem (pattern body)
  (make-defun (concat-symbols 'execute- (car pattern))
              '(inst s)
              (if (equal (len pattern) 1)
                  '(declare (ignore inst))
                nil)
              (list 'semantics pattern body)))

(acl2::set-ignore-ok t)

; --- end of macro definitions ---

; --- Here is the definition of m1 in this new notation ---

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

(defsem (ICONST c)
  (modify s
          :stack (push c -stack-)))

(defsem (ILOAD k)
  (modify s
          :stack (push (nth k -locals-) -stack-)))

(defsem (IADD)
  (modify s
          :stack (push (+ (top (pop -stack-))
                          (top -stack-))
                       (pop (pop -stack-)))))
  
(defsem (ISTORE k)
  (modify s
          :locals (update-nth k (top -stack-) -locals-)
          :stack (pop -stack-)))

(defsem (ISUB)
  (modify s 
          :stack (push (- (top (pop -stack-))
                          (top -stack-))
                       (pop (pop -stack-)))))

(defsem (IMUL)
  (modify s 
          :stack (push (* (top (pop -stack-))
                          (top -stack-))
                       (pop (pop -stack-)))))

(defsem (GOTO delta)
  (modify s
          :pc (+ delta -pc-)))

(defsem (IFLE delta)
  (modify s
          :pc (if (<= (top -stack-) 0)
                  (+ delta -pc-)
                (+ 1 -pc-))
          :stack (pop -stack-)))

(defun do-inst (inst s)
  (case (op-code inst)
    (ICONST (execute-ICONST  inst s))
    (ILOAD  (execute-ILOAD   inst s))
    (ISTORE (execute-ISTORE  inst s))
    (IADD   (execute-IADD    inst s))
    (ISUB   (execute-ISUB    inst s))
    (IMUL   (execute-IMUL    inst s))
    (GOTO   (execute-GOTO    inst s))
    (IFLE   (execute-IFLE    inst s))
    (otherwise s)))

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

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