#|$ACL2s-Preamble$;

(include-book "diff")
(begin-book t :ttags :all)

;$ACL2s-Preamble$|#

(in-package "M5")

(set-state-ok t)

; This system has to be defined in :program mode because it uses the ACL2 print
; facilities.

(acl2::program)

; Because this system is in :program mode it is possible to provoke hard Lisp
; errors by calling it on inappropriate input.  Without writing a bytecode
; verifier, we can't avoid these errors.

; -----------------------------------------------------------------

; We first implement a recognizer for states.  We don't recognize them
; perfectly!  We just recognize enough about them to insure that we
; can use the standard accessor functions.  We thus call these states
; pseudo-states or ps-states.

; Some state-like objects fail to be states for the simple
; reasons that
; (a) there is only one thread but its id is nil.  This would
;     happen if the user typed (modify nil nil ...).
; (b) there is only one thread but its stat is nil.  This
;     would happen if the user failed to specify :stat.

; If an object is otherwise a pseudo-state but suffers failings
; (a) and/or (b), we call it a fixable ps-state.

; The function fix-ps-state will take such a state and produce a
; ps-state by setting the id to 0 and the stat to 'active,
; appropriately.

; Keytuple-shapep recognizes the shape of a given keytuple.

(defun keytuple-shapep1 (slotnames x)
  (cond ((atom slotnames) (equal x nil))
        ((atom x) nil)
        ((and (true-listp (car x))
              (equal (len (car x)) 2)
              (equal (car (car x))
                     (car slotnames)))
         (keytuple-shapep1 (cdr slotnames) (cdr x)))
        (t nil)))

(defun keytuple-shapep (name slotnames x)
  (and (true-listp x)
       (equal (len x) (+ 1 (len slotnames)))
       (equal (car x) name)
       (keytuple-shapep1 slotnames (cdr x))))

; We now define, bottom up, the notion of a pseudo-state.  This is a
; state, at least in shape, but without necessarily the correct
; relationships between components.  The prefix ps- (``pseudo'') below
; indicates that there is some aspect of complete well-formedness not
; being checked.

(defun ps-instructionp (inst)
  (and (true-listp inst)
       (consp inst)
       (symbolp (car inst))
       (<= (len inst) 4)))

(defun ps-codep (lst)
  (cond ((atom lst) (equal lst nil))
        (t (and (ps-instructionp (car lst))
                (ps-codep (cdr lst))))))
         
(defun exception-tablep (tbl max-pc)
  (cond ((atom tbl) (equal tbl nil))
        (t (and (true-listp (car tbl))
                (let ((pc1 (nth 0 (car tbl)))
                      (pc2 (nth 1 (car tbl)))
                      (pc3 (nth 2 (car tbl)))
                      (class (nth 3 (car tbl))))
                  (and (integerp pc1)
                       (integerp pc2)
                       (integerp pc3)
                       (<= 0 pc1)
                       (<= pc1 pc2)
                       (<= pc2 max-pc)
                       (<= 0 pc3)
                       (<= pc3 max-pc)
                       (stringp class)))
                (exception-tablep (cdr tbl) max-pc)))))

(defun ps-methodp (x)

; (defkeytuple method (name formals sync code xtbl))

  (and (keytuple-shapep 'method
                        '(:name :formals :sync :code :xtbl)
                        x)
       (stringp (name x))
       (symbol-listp (formals x))
       (no-duplicatesp (formals x))
       (member (sync x) '(t nil))
       (ps-codep (code x))
       (exception-tablep (xtbl x) (- (len (code x)) 1))))

(defun ps-method-listp (lst)
  (cond ((endp lst) t)
        (t (and (ps-methodp (car lst))
                (ps-method-listp (cdr lst))))))
  
(defun ps-classp (x)

; (defkeytuple class (name supers fields methods))

  (and (keytuple-shapep 'class '(:name :supers :fields :methods) x)
       (stringp (name x))
       (if (equal (name x) "Object")
           (equal (supers x) nil)
         (and (string-listp (supers x))
              (equal (car (last (supers x))) "Object")))
       (string-listp (fields x))
       (no-duplicatesp (fields x))
       (ps-method-listp (methods x))))

(defun ps-ctp1 (x)
  (cond ((atom x) (equal x nil))
        (t (and (ps-classp (car x))
                (ps-ctp1 (cdr x))))))

(defun ps-ctp (x fixablep)
  (if (ps-ctp1 x)
      (if (find :name "Object" x)
          (if (find :name "Thread" x)
              t
            fixablep)
        fixablep)
    nil))

(defun ps-method-locatorp (mloc)
  (and (true-listp mloc)
       (equal (len mloc) 3)
       (stringp (nth 0 mloc))
       (stringp (nth 1 mloc))
       (natp (nth 2 mloc))))

(defun ps-framep (x)

; (defkeytuple frame (pc locs stk mloc) ...)

  (and (keytuple-shapep 'frame '(:pc :locs :stk :mloc) x)
       (natp (pc x))
       (true-listp (locs x))
       (true-listp (stk x))
       (ps-method-locatorp (mloc x))))

(defun ps-csp (x)
  (cond ((atom x) (equal x nil))
        (t (and (ps-framep (car x))
                (ps-csp (cdr x))))))

(defun ps-refp (x)
  (and (true-listp x)
       (equal (len x) 2)
       (equal (car x) 'REF)
       (natp (cadr x))))

(defun ps-threadp (x)

; (defkeytuple thread (id cs stat ref) ...)

  (and (keytuple-shapep
        'thread '(:id :cs :stat :ref)
        x)
       (natp (id x))
       (ps-csp (cs x))
       (member (stat x) '(active inactive))
       (or (null (ref x))
           (ps-refp (ref x)))))

(defun ps-ttp (x)
  (cond ((atom x) (equal x nil))
        (t (and (ps-threadp (car x))
                (ps-ttp (cdr x))))))

(defun string-doublet-alistp (x)
  (cond ((atom x) (equal x nil))
        (t (and (true-listp (car x))
                (equal (len (car x)) 2)
                (stringp (car (car x)))
                (string-doublet-alistp (cdr x))))))

(defun ps-objectp (x)
  (cond ((atom x) (equal x nil))
        (t (and (true-listp (car x))
                (equal (len (car x)) 2)
                (stringp (car (car x)))
                (string-doublet-alistp (cadr (car x)))
                (ps-objectp (cdr x))))))

(defun ps-hpp (x)
  (cond ((atom x) (equal x nil))
        (t (and (true-listp (car x))
                (equal (len (car x)) 2)               ; (car x) of form (key val)
                (true-listp (car (car x)))
                (equal (len (car (car x))) 2)         ; key of form (REF i)
                (equal (car (car (car x))) 'REF)
                (natp (cadr (car (car x))))
                (ps-objectp (cadr (car x)))           ; val is a pseudo object
                (ps-hpp (cdr x))))))

; See ps-statep for an explanation of the fixablep flag.

(defun ps-statep1 (x fixablep)

; (defkeytuple state (tt hp ct) ...)

  (and (keytuple-shapep 'state '(:tt :hp :ct) x)
       (if fixablep
           (or (ps-ttp (tt x))
               (and (equal (len (tt x)) 1)
                    (let ((th (car (tt x))))
                      (and
                       (keytuple-shapep
                        'thread
                        '(:id :cs :stat :ref)
                        th)
                       (or (natp (id th))
                           (null (id th)))
                       (ps-csp (cs th))
                       (member (stat th) '(active inactive nil))
                       (or (null (ref th))
                           (ps-refp (ref th)))))))
         (ps-ttp (tt x)))
       (ps-hpp (hp x))
       (ps-ctp (ct x) fixablep)))

; We define three concepts.  If (ps-statep x) is t, then x is a
; pseudo-state.  If (ps-statep x) is nil but (fixable-ps-statep x) is
; t, then x is not a pseudo-state but is fixable.  To be fixable, a
; state has to miss being a pseudo-state by having nil for the single
; id and/or having nil for the single thread's stat and/or
; be missing "Object" and/or "Thread" class descriptions.  If a
; state is fixable, (fix-ps-state x) returns a pseudo-state.  That is,
; is should be the case that (fixable-ps-statep x) implies (ps-statep
; (fix-ps-state x)).

(defun ps-statep (x)
  (ps-statep1 x nil))

(defun fixable-ps-statep (x)
  (ps-statep1 x t))

(defun fix-ct1 (class ct)
  (if (find :name (name class) ct)
      ct
    (cons class ct)))

(defun fix-ct (ct)

; Ct may be missing classes "Object" and/or "Thread".  We add them if
; necessary.  We use the definitions of those classes in
; *base-classes*.  Note that ct could be supplied with different base
; classes and if so we leave them as supplied.

  (fix-ct1
   (nth 0 *base-classes*)        ; "Object"
   (fix-ct1
    (nth 1 *base-classes*)       ; "Thread"
    ct)))

(defun fix-ps-state (x)
  (let ((th (car (tt x))))
    (make state
          :tt
          (list (make thread
                      :id (if (null (id th))
                                     0
                                   (id th))
                      :cs (cs th)
                      :stat (if (null (stat th))
                                  'active
                                (stat th))
                      :ref (ref th)))
          :hp (hp x)
          :ct
          (fix-ct (ct x)))))

; -----------------------------------------------------------------


(defun past-state (sense-flg irun-hist)

; When we print scenes we do it with respect to some past state.
; But there are several choices of past state:
; sense-flg

;  prev         the state before this one in the history
;               or proto-init if the history has only one state

;  init         the first state in the history

;  proto-init   an indeterminate state that looks like a single-
;               threaded state with an empty hp and the class
;               table of init.

;  empty        the empty state, except the class table is the
;               the one in init.

; Note: The reason all the states have the current class table is that
; the function diff will return :unrelated if we try to use an old
; state with a different class table.  However, we can tack on a class
; table to the output of diff, which we sometimes do.

  (case sense-flg
    (prev (cond ((null (cdr irun-hist))
                 (past-state 'proto-init irun-hist))
                (t (nth 2 (cadr irun-hist)))))
    (init (nth 2 (car (last irun-hist))))
    (proto-init
     (make state
           :tt
           (list (make :thread
                       :id 0
                       :cs
                       (push (make frame
                                   :pc '?
                                   :locs '?
                                   :stk '?
                                   :mloc '?)
                             nil)
                       :stat 'active
                       :ref nil))
           :hp nil
           :ct (ct (nth 2 (car irun-hist)))))
    (otherwise
     (make state
           :tt nil
           :hp nil
           :ct (ct (nth 2 (car irun-hist)))))))

(defun tack-on-ct (expr ct)
; If ct is non-nil, we tack on
;   :CT ct
; to the final MODIFY expression, if we can find the appropriate
; modify.  If ct is nil, we tack on nothing.

  (cond ((null ct) expr)
        ((atom expr) expr)
        ((and (equal (car expr) 'let*)
              (null (cdddr expr))) 
         (list 'let* (cadr expr)
               (tack-on-ct (caddr expr) ct)))
        ((equal (car expr) 'modify)
         (append expr `(:ct ,ct)))
        (t expr)))

(defun describe-state (sense-flg ct-flg irun-hist)

; We return a MODIFY expression that expresses new-state in terms
; of some specified previous state.  The sense-flg indicates
; which past state is used: PREV, INIT, PROTO-INIT, or EMPTY.
; (See past-state.)  The ct-flg is nil, SYMBOLIC, or EXPLICIT.
; If nil, no :ct is specified; if SYMBOLIC, the expression -ct-
; is used; and if EXPLICIT, the actual quoted constant is used.
; It is an error to specify nil for the ct if you specify EMPTY
; for the past state.  In that case, we ignore ct-flg and we use
; EXPLICIT.

; If the state being described is the same as INIT, we describe it
; with respect to PROTO-INIT.

; The spec for this function is that the value of the MODIFY
; expression will be new-state, in the environment established by
; irun.

  (let* ((s (nth 2 (car irun-hist)))
         (sense-flg (if (equal s (nth 2 (car (last irun-hist))))
                        'PROTO-INIT
                      sense-flg))
         (ct-flg
          (if (and (null ct-flg)
                   (equal sense-flg 'EMPTY))
              'EXPLICIT
            ct-flg))
         (ct (cond ((null ct-flg) nil)
                   ((eq ct-flg 'SYMBOLIC) '-ct-)
                   (t (kwote (ct s))))))
    (tack-on-ct
     (diff (cond ((eq sense-flg 'prev)
                  (cond ((null (cdr irun-hist)) '(s proto))
                        (t `(s ,(nth 0 (car (cdr irun-hist)))))))
                 ((eq sense-flg 'init)
                  '(s 0))
                 ((eq sense-flg 'proto-init)
                  '(s proto))
                 (t '(s empty)))
           (past-state sense-flg irun-hist)
           s)
     ct)))

(defun eval-condp (id s cond)
  (case (car cond)
    (WHILE-DEPTH
     (not (equal (len (cst id s)) (cadr cond))))
    (UNTIL-DEPTH
     (equal (len (cst id s)) (cadr cond)))
    (TO-POINT
     (and (equal (len (cst id s)) (cadr cond))
          (equal (pc (top-frame id s)) (caddr cond))))
    (otherwise nil)))

(defun run-cond (id sk k max cond)

; We step thread id in s until condition cond is satisfied, the
; machine halts or max steps have been taken.

; We return (mv reason sk sk1 k) where reason is one of the symbols
; MAX, COND, or SPIN and indicates why we stopped.  If reason is
; SPIN it means that cond was not satisfied but sk is sk1.  This
; could be a nice halt, but it could also be a deadlock or just
; waiting for another thread.

; If reason is MAX, the other values are all nil.

; Otherwise, we took k steps from the initial state to get to state
; sk, sk1 is one step beyond sk, and sk1 is the first state we saw
; satisfying cond (or else sk and sk1 are the same).

; The conditions tested are

; '(WHILE-DEPTH d) - true when the step makes the cs
;                       depth something other than d.
; '(UNTIL-DEPTH d) - true when cs depth is d
; '(TO-POINT d pc) - true when cs depth is d and pc is pc

  (declare (xargs :mode :program))
  (cond
   ((zp max) (mv 'max nil nil nil))
   (t (let ((sk1 (step id sk)))
        (cond
         ((eval-condp id sk1 cond)
          (mv 'cond sk sk1 k))
         ((equal sk sk1) (mv 'spin sk sk1 k))
         (t (run-cond id sk1 (+ k 1) (- max 1) cond)))))))

(defun fms1 (str alist channel acl2::state evisc-tuple)

; This is like fms but assumes the cursor is in col 0.  Fms achieves
; this by doing a newline.

  (declare (xargs :mode :program))
  (mv-let (col acl2::state)
          (fmt1 str alist 0 channel acl2::state evisc-tuple)
          (declare (ignore col))
          acl2::state))

(defun fms-max-msg (max cmd acl2::state)
  (declare (xargs :mode :program))
  (fms1 "~x0 steps were taken by ~x1 and the terminal condition ~
          was never reached.  The current state is still that of ~
          Scene ~x2.  To reach the state at which ~x1 gave up, ~
          try :STEPN ~x0.  To change the maximum number of steps allowed, ~
          use the command :SET-MAX k."
        (list (cons #\0 max)
              (cons #\1 cmd)
              (cons #\2 (nth 0 (car (@ irun-hist)))))
        *standard-co* acl2::state nil))

(defun add-to-sched-alist (id k sched-alist)
  (cond ((equal k 0) sched-alist)
        ((equal (car (car sched-alist)) id)
         (cons (cons id (+ k (cdr (car sched-alist))))
               (cdr sched-alist)))
        (t (cons (cons id k) sched-alist))))

(defun append-schedule-to-sched-alist (sched sched-alist)
  (cond ((endp sched) sched-alist)
        ((equal (car sched) (car (car sched-alist)))
         (append-schedule-to-sched-alist
          (cdr sched)
          (cons (cons (car sched)
                      (+ 1 (cdr (car sched-alist))))
                (cdr sched-alist))))
        (t (append-schedule-to-sched-alist
            (cdr sched)
            (cons (cons (car sched) 1)
                  sched-alist)))))

(defun convert-sched-alist-to-expr1 (sched-alist ans)
  (cond ((endp sched-alist) ans)
        (t (convert-sched-alist-to-expr1
            (cdr sched-alist)
            (cons `(repeat ,(car (car sched-alist))
                           ,(cdr (car sched-alist)))
                  ans)))))

(defun convert-sched-alist-to-expr (sched-alist)
  (let ((lst (convert-sched-alist-to-expr1 sched-alist nil)))
    (cond ((null lst) nil)
          ((null (cdr lst)) (car lst))
          (t (cons 'append lst)))))
                 
(defmacro cid (k)
  `(nth 1 (assoc-equal ,k (@ irun-hist))))

(defmacro s (k)
  (cond ((equal k 'proto)
         '(past-state 'proto-init (@ irun-hist)))
        ((equal k 'empty)
         '(past-state 'empty (@ irun-hist)))
        (t `(nth 2 (assoc-equal ,k (@ irun-hist))))))

(defmacro value (x)
  `(acl2::value ,x))

; -----------------------------------------------------------------
; The :frame command

(defun tilde-@-code-phrase1 (pc prog i)
  (cond ((endp prog) nil)
        (t (cons (acl2::msg (if (equal i pc)
                                "~f0~t1; ~c2 <- pc"
                              "~f0~t1; ~c2")
                            (car prog)
                            40
                            (cons i 4))
                 (tilde-@-code-phrase1 pc (cdr prog) (+ 1 i))))))

(defun tilde-@-code-phrase (pc prog)
  (acl2::msg "(~*0)"
             (list "" "~@*~% " "~@*~% " "~@*~% "
                   (tilde-@-code-phrase1 pc prog 0))))

(defun frame-cmd-fn (acl2::state)
  (let ((id (nth 1 (car (@ irun-hist))))
        (s  (nth 2 (car (@ irun-hist)))))
    (pprogn
     (fms1 "Locs:  ~x0~%~
            Stk:   ~x1~%~
            MLoc:  ~x2~%~
            Code:~%~
            ~@3~%~
            Exception Table:~%~
            ~x4~%"
           (list (cons #\0 (locs (top-frame id s)))
                 (cons #\1 (stk (top-frame id s)))
                 (cons #\2 (mloc (top-frame id s)))
                 (cons #\3
                       (tilde-@-code-phrase
                        (pc (top-frame id s))
                        (code
                         (get-method (mloc (top-frame id s))
                                     (ct s)))))
                 (cons #\4 (xtbl
                            (get-method (mloc (top-frame id s))
                                        (ct s)))))
           *standard-co* acl2::state nil)
     (value :invisible))))

; For every keyword command, e.g., :code, we define a macro of the
; appropriate number of arguments and with a name ending in `-cmd',
; e.g., code-cmd.  We then bind the keyword command to the macro
; name in the keyword aliases table.  The reason we use the -cmd
; convention is so that we don't redefine standard M5 function like
; step.

(defmacro frame-cmd () '(frame-cmd-fn acl2::state))

; -----------------------------------------------------------------
; The :scene command

(defun tilde-@-scene-phrase (bannerp sense-flg ct-flg irun-hist)

; If bannerp is t we print a line of hyphens before the scene.

  (let ((scene-no (nth 0 (car irun-hist)))
        (id (nth 1 (car irun-hist))))
    (acl2::msg
     "~#0~[-----------------------------------------------------------------~
      ~%~/~]~
      Scene ~x1~%~
      ~#2~[Current class table = (@ ct)~%~/~]~
      Current thread = (cid ~x1) = ~x3~%~
      Current state  = (s   ~x1) = ~%~x4~%"
     (if bannerp 0 1)
     scene-no
     (if (eq ct-flg 'symbolic)
         0 1)
     id
     (describe-state sense-flg ct-flg irun-hist))))

(defun scene-cmd-fn (bannerp sense-flg ct-flg acl2::state)
  (pprogn
   (fms1 "~@0"
         (list
          (cons #\0
                (tilde-@-scene-phrase
                 bannerp                         ; banner
                 sense-flg
                 ct-flg
                 (@ irun-hist))))
         *standard-co* acl2::state nil)
   (value :invisible)))

; Note: The PREV below is treated like PROTO-INIT if this is scene 0!

(defmacro scene-cmd () '(scene-cmd-fn nil 'PREV nil acl2::state))

; -----------------------------------------------------------------
; The :scene! command

(defmacro scene!-cmd () '(scene-cmd-fn nil 'INIT 'SYMBOLIC acl2::state))

; -----------------------------------------------------------------
; The :scene!! command

(defmacro scene!!-cmd () '(scene-cmd-fn nil 'EMPTY 'EXPLICIT acl2::state))

; -----------------------------------------------------------------
; The :step command

(defun step-cmd-fn (acl2::state)
  (let* ((scene-no (nth 0 (car (@ irun-hist))))
         (id       (nth 1 (car (@ irun-hist))))
         (s        (nth 2 (car (@ irun-hist))))
         (sa       (nth 3 (car (@ irun-hist))))
         (k        1)
         (new-s (run (repeat id k) s)))
    (cond ((equal new-s s)
           (pprogn
            (fms1 "no change" nil *standard-co* acl2::state nil)
            (value :invisible)))
          (t 
           (er-progn
            (assign irun-hist (cons (list (+ 1 scene-no)
                                          id
                                          new-s
                                          (add-to-sched-alist id k sa))
                                    (@ irun-hist)))
            (scene-cmd-fn t 'PREV nil acl2::state))))))

(defmacro step-cmd ()
  '(step-cmd-fn acl2::state))

; -----------------------------------------------------------------
; The :u command

(defun u-cmd-fn (acl2::state)
  (let* ((old-hist (cdr (@ irun-hist))))
    (cond
     ((null old-hist)
      (pprogn
       (fms1 "no change" nil *standard-co* acl2::state nil)
       (value :invisible)))
     (t (er-progn
         (assign irun-hist old-hist)
         (scene-cmd-fn t
                       (if (equal (nth 0 (car old-hist)) 0)
                           'PROTO-INIT
                         'INIT)
                       nil acl2::state))))))

(defmacro u-cmd ()
  '(u-cmd-fn acl2::state))

; -----------------------------------------------------------------
; The :ubt n command

(defun ubt-cmd-fn (n acl2::state)

; Undo back through scene n.

  (let* ((old-hist (cdr (member (assoc-equal n (@ irun-hist))
                                (@ irun-hist)))))
    (cond
     ((or (not (natp n))
          (equal n 0))
      (er soft 'irun
          "The :ubt command expects one argument, n, which must be ~
           a non-0 number of some previous scene."))
     ((null old-hist)
      (pprogn
       (fms1 "no change" nil *standard-co* acl2::state nil)
       (value :invisible)))
     (t (er-progn
         (assign irun-hist old-hist)
         (scene-cmd-fn t
                       (if (equal (nth 0 (car old-hist)) 0)
                             'PROTO-INIT
                           'INIT)
                       nil acl2::state))))))

(defmacro ubt-cmd (n)
  `(ubt-cmd-fn ,n acl2::state))

; -----------------------------------------------------------------
; The :stepn n command

(defun stepn-cmd-fn (n acl2::state)
  (cond
   ((not (natp n))
    (er soft 'irun
        "The :stepn command expects one argument, n, which ~
         must be a natural number of steps to take."))
   (t
    (let* ((scene-no (nth 0 (car (@ irun-hist))))
           (id       (nth 1 (car (@ irun-hist))))
           (s        (nth 2 (car (@ irun-hist))))
           (sa       (nth 3 (car (@ irun-hist))))
           (new-s    (run (repeat id n) s)))
      (cond ((equal new-s s)
             (pprogn
              (fms1 "no change" nil *standard-co* acl2::state nil)
              (value :invisible)))
            (t 
             (er-progn
              (assign irun-hist
                      (cons (list (+ 1 scene-no)
                                  id
                                  new-s
                                  (add-to-sched-alist id n sa))
                            (@ irun-hist)))
              (scene-cmd-fn t 'PREV nil acl2::state))))))))

(defmacro stepn-cmd (n)
  `(stepn-cmd-fn ,n acl2::state))  

; -----------------------------------------------------------------
; The :big-step command

(defun big-step-cmd-fn (acl2::state)
  (let* ((scene-no (nth 0 (car (@ irun-hist))))
         (id       (nth 1 (car (@ irun-hist))))
         (s        (nth 2 (car (@ irun-hist))))
         (sa       (nth 3 (car (@ irun-hist)))))
    (cond
     ((member (op-code (next-inst id s))
              '(INVOKEVIRTUAL
                INVOKESTATIC
                INVOKESPECIAL))
      (mv-let (reason sk sk1 k)
              (run-cond id (step id s) 1 (@ irun-max)
                        `(UNTIL-DEPTH ,(len (cst id s))))
              (declare (ignore sk))
              (cond
               ((equal reason 'max)
                (pprogn
                 (fms-max-msg (@ irun-max) :big-step acl2::state)
                 (value :invisible)))
               ((equal sk1 s)
                (pprogn
                 (fms1 "no change" nil *standard-co* acl2::state nil)
                 (value :invisible)))
               (t 
                (er-progn
                 (assign irun-hist
                         (cons (list (+ 1 scene-no)
                                     id
                                     sk1
                                     (add-to-sched-alist id (+ k 1) sa))
                               (@ irun-hist)))
                 (if (equal reason 'spin)
                     (pprogn
                      (fms1 "~%Note:  The state below was reached ~
                             from the invocation, but is now stuck!  ~
                             :Big-Step did not get back to the ~
                             caller's frame!~%"                             
                            nil *standard-co* acl2::state nil)
                      (value :invisible))
                   (value :invisible))
                 (scene-cmd-fn t 'PREV nil acl2::state))))))
     (t (step-cmd)))))

(defmacro big-step-cmd ()
  '(big-step-cmd-fn acl2::state))

; -----------------------------------------------------------------
; The :run-frame command

(defun run-frame-cmd-fn (acl2::state)
  (let* ((scene-no (nth 0 (car (@ irun-hist))))
         (id       (nth 1 (car (@ irun-hist))))
         (s        (nth 2 (car (@ irun-hist))))
         (sa       (nth 3 (car (@ irun-hist)))))
    (mv-let (reason sk sk1 k)
            (run-cond id s 0 (@ irun-max)
                      `(WHILE-DEPTH ,(len (cst id s))))
            (declare (ignore sk1))
            (cond
             ((equal reason 'max)
              (pprogn
               (fms-max-msg (@ irun-max) :run-frame acl2::state)
               (value :invisible)))
             ((equal sk s)
              (pprogn
               (fms1 "no change" nil *standard-co* acl2::state nil)
               (value :invisible)))
             (t 
              (er-progn
               (assign irun-hist
                       (cons (list (+ 1 scene-no)
                                   id
                                   sk
                                   (add-to-sched-alist id k sa))
                             (@ irun-hist)))
               (scene-cmd-fn t 'PREV nil acl2::state)))))))

(defmacro run-frame-cmd ()
  '(run-frame-cmd-fn acl2::state))

; -----------------------------------------------------------------
; The :ret command

(defun ret-cmd-fn (acl2::state)
  (let* ((scene-no (nth 0 (car (@ irun-hist))))
         (id       (nth 1 (car (@ irun-hist))))
         (s        (nth 2 (car (@ irun-hist))))
         (sa       (nth 3 (car (@ irun-hist)))))
    (mv-let (reason sk sk1 k)
            (run-cond id s 0 (@ irun-max)
                      `(UNTIL-DEPTH ,(- (len (cst id s)) 1)))
            (declare (ignore sk))
            (cond
             ((equal reason 'max)
              (pprogn
               (fms-max-msg (@ irun-max) :ret acl2::state)
               (value :invisible)))
             ((equal sk1 s)
              (pprogn
               (fms1 "no change" nil *standard-co* acl2::state nil)
               (value :invisible)))
             (t (er-progn
                 (assign irun-hist
                         (cons (list (+ 1 scene-no)
                                     id
                                     sk1
                                     (add-to-sched-alist id (+ k 1) sa))
                               (@ irun-hist)))
                 (if (equal reason 'spin)
                     (pprogn
                      (fms1 "~%Note:  The state below is stuck!  ~
                             :Ret did not get back to the ~
                             caller's frame!~%" 
                             nil *standard-co* acl2::state nil)
                      (value :invisible))
                   (value :invisible))
                 (scene-cmd-fn t 'PREV nil acl2::state)))))))

(defmacro ret-cmd ()
  '(ret-cmd-fn acl2::state))

; -----------------------------------------------------------------
; The :do command

(defun do-cmd-fn (inst acl2::state)
  (cond
   ((not (ps-instructionp inst))
    (er soft 'irun
        "The :do command expects one argument, inst, which ~
         supposed to be an instruction."))
   (t
    (let* ((scene-no (nth 0 (car (@ irun-hist))))
           (id       (nth 1 (car (@ irun-hist))))
           (s        (nth 2 (car (@ irun-hist))))
           (sa       (nth 3 (car (@ irun-hist))))
           (new-s    (do-inst inst id s)))
      (cond ((equal new-s s)
             (pprogn
              (fms1 "no change" nil *standard-co* acl2::state nil)
              (value :invisible)))
            (t 
             (er-progn
              (assign irun-hist
                      (cons (list (+ 1 scene-no)
                                  id
                                  new-s
                                  sa)
                            (@ irun-hist)))
              (scene-cmd-fn t 'PREV nil acl2::state))))))))

(defmacro do-cmd (inst)
  `(do-cmd-fn ,inst acl2::state))  

; -----------------------------------------------------------------
; The :show-sched command

(defun show-sched-cmd-fn (acl2::state)
  (pprogn
   (fms1 "~x0"
         (list
          (cons #\0
                (convert-sched-alist-to-expr
                 (nth 3 (car (@ irun-hist))))))
         *standard-co* acl2::state nil)
   (value :invisible)))

(defmacro show-sched-cmd ()
  '(show-sched-cmd-fn acl2::state))

; -----------------------------------------------------------------
; The :run expr command

(defun list-of-natsp (x)
  (if (atom x)
      (equal x nil)
    (and (natp (car x))
         (list-of-natsp (cdr x)))))

(defun run-cmd-fn (expr acl2::state)
  (let* ((scene-no (nth 0 (car (@ irun-hist))))
         (id       (nth 1 (car (@ irun-hist))))
         (s        (nth 2 (car (@ irun-hist))))
         (sa       (nth 3 (car (@ irun-hist)))))
    (acl2::state-global-let*
     ((acl2::guard-checking-on nil))
     (mv-let (erp pair acl2::state)
             (acl2::simple-translate-and-eval
              expr
              nil
              nil
              (acl2::msg "The schedule expression ~x0" expr)
              'irun
              (w acl2::state)
              acl2::state)
             (cond
              (erp (value :invisible))
              (t (let ((sched (cdr pair)))
                   (cond
                    ((list-of-natsp sched)
                     (let* ((new-s (run sched s)))
                       (cond
                        ((equal new-s s)
                         (pprogn
                          (fms1 "no change" nil *standard-co* acl2::state nil)
                          (value :invisible)))
                        (t (er-progn
                            (assign
                             irun-hist
                             (cons
                              (list
                               (+ 1 scene-no)
                               id
                               new-s
                               (append-schedule-to-sched-alist sched sa))
                              (@ irun-hist)))
                            (scene-cmd-fn t 'PREV nil acl2::state))))))
                    (t
                     (er soft 'irun
                         "The :run command expects one argument, an ~
                          expression which evaluates to a list of ~
                          natural numbers to use as a schedule.  But the ~
                          expression ~x0 evaluates to ~X12."
                         expr
                         sched
                         nil))))))))))

(defmacro run-cmd (expr)
  `(run-cmd-fn ,expr acl2::state))

; -----------------------------------------------------------------
; The :set-thread id command

(defun set-thread-cmd-fn (new-id acl2::state)
  (let* ((scene-no (nth 0 (car (@ irun-hist))))
         (id       (nth 1 (car (@ irun-hist))))
         (s        (nth 2 (car (@ irun-hist))))
         (sa       (nth 3 (car (@ irun-hist)))))
    (cond
     ((natp new-id)
      (cond ((equal new-id id)
             (pprogn
              (fms1 "no change" nil *standard-co* acl2::state nil)
              (value :invisible)))
            (t
             (er-progn
              (assign irun-hist
                      (cons (list (+ 1 scene-no)
                                  new-id
                                  s
                                  sa)
                            (@ irun-hist)))
              (scene-cmd-fn t 'PREV nil acl2::state)))))
     (t (er soft 'irun
            "The :set-thread command expects one argument, n, which ~
             must be a natural number.")))))

(defmacro set-thread-cmd (new-id)
  `(set-thread-cmd-fn ,new-id acl2::state))

; -----------------------------------------------------------------
; The :set-max m command

(defun set-max-cmd-fn (new-max acl2::state)
  (cond
   ((and (natp new-max)
         (<= 1 new-max))
    (cond ((equal new-max (@ irun-max))
           (pprogn
            (fms1 "no change" nil *standard-co* acl2::state nil)
            (value :invisible)))
          (t
           (er-progn
            (assign irun-max new-max)
            (value :invisible)))))
   (t (er soft 'irun
          "The :set-max command expects one argument, n, which ~
             must be a non-0 natural number."))))

(defmacro set-max-cmd (new-max)
  `(set-max-cmd-fn ,new-max acl2::state))

; -----------------------------------------------------------------
; The :show-max command

(defun show-max-cmd-fn (acl2::state)
  (@ irun-max))

(defmacro show-max-cmd ()
  '(show-max-cmd-fn acl2::state))

; -----------------------------------------------------------------
; The :help command

(defun help-cmd-fn (acl2::state)
  (pprogn
   (fms1
    "Legal irun commands:~%~
     ~  :step          - step current thread once~%~
     ~  :stepn n       - step current thread n times, where (natp n)~%~
     ~  :big-step      - if next instr is an invoke, run until control~%~
     ~                    returns to this frame; else same as :step~%~
     ~  :run expr      - evaluate expr to obtain a schedule and then~%~
     ~                    run that schedule~%~
     ~  :run-frame     - run current thread until control is about~%~
     ~                    to leave current frame (via invoke or return)~%~
     ~  :ret           - run until this frame returns to its caller~%~
     ~  :do inst       - execute inst - THIS AFFECTS THE PC TOO!~%~
     ~  :set-thread n  - set current thread to n, where (natp n)~%~
     ~  :set-max n     - set max steps to n~%~
     ~  :show-max      - print value of max steps allowed~%~
     ~  :scene         - print current scene relative to previous state~%~
     ~  :scene!        - print current scene relative to initial state~%~
     ~  :scene!!       - print current scene relative to empty state~%~
     ~  :show-sched    - print description of schedule from (s 0) to here~%~
     ~  :frame         - print information from the current frame~%~
     ~  :u             - undo last state transition~%~
     ~  :ubt n         - undo back through Scene n~%~
     ~  :q             - quit irun; to resume type (irun)~%~
     ~  :help          - print this help~%~
     ~  other          - any other cmd is treated as an ACL2 expression~%~
     ~                    and the value is printed~%"
    nil *standard-co* acl2::state nil)
   (value :invisible)))

(defmacro help-cmd ()
  '(help-cmd-fn acl2::state))

; -----------------------------------------------------------------
; A list of all irun keyword commands

(defconst *irun-keyword-cmds*
  '((:frame 0 frame-cmd)
    (:scene   0 scene-cmd)
    (:scene!  0 scene!-cmd)
    (:scene!! 0 scene!!-cmd)
    (:step    0 step-cmd)
    (:stepn   1 stepn-cmd)
    (:big-step 0 big-step-cmd)
    (:run-frame 0 run-frame-cmd)
    (:ret 0 ret-cmd)
    (:run 1 run-cmd)
    (:do  1 do-cmd)
    (:show-sched 0 show-sched-cmd)
    (:set-thread 1 set-thread-cmd)
    (:set-max 1 set-max-cmd)
    (:show-max 0 show-max-cmd)    

    (:u       0 u-cmd)
    (:ubt     1 ubt-cmd)
    (:help    0 help-cmd)))

(defun irun-prompt (ch acl2::state)
  (pprogn (fms "cmd: " nil ch acl2::state nil)
          (mv 5 acl2::state)))

; -----------------------------------------------------------------

(defmacro irun (&optional s)
  `(er-progn
    (assign irun-arg ,s)
    (cond ((null (@ irun-arg)) (value nil))
          ((ps-statep (@ irun-arg)) (value nil))
          ((fixable-ps-statep (@ irun-arg))
           (assign irun-arg
                   (fix-ps-state (@ irun-arg))))
          (t (er soft 'irun
                 "The state you provided was not well formed.")))
    (acl2::state-global-let*
     ((acl2::guard-checking-on :none))
     (er-progn
      (ld (cons '(let ((s (@ irun-arg)))
                   (er-progn
                    (if s
                        (assign irun-hist
                                (list (list 0 0 s nil)))
                      (value nil))
                    (if s
                        (assign ct (ct s))
                      (value nil))
                    (if (boundp-global 'irun-max acl2::state)
                        (value nil)
                      (assign irun-max 100))
                    (pprogn
                     (fms "Welcome to irun.  Type :help for help.~%"
                          nil *standard-co* acl2::state nil)
                     (er-progn
                      (scene-cmd-fn t 'PROTO-INIT NIL acl2::state)
                      (acl2::set-ld-prompt 'irun-prompt acl2::state)
                      (value :invisible)))))
                *standard-oi*)
          :ld-prompt nil
          :ld-verbose nil
          :ld-error-action :continue
          :ld-keyword-aliases *irun-keyword-cmds*)
      (pprogn
       (fms1 "To re-enter this scene, type (irun).~%~%"
             nil *standard-co* acl2::state nil)
       (value :invisible))))))

#|

(include-book "m5-examples")
(irun (make state
            :tt
            (list (make thread
                        :id 0
                        :cs
                        (push (make frame
                                    :pc 0
                                    :locs nil
                                    :stk nil
                                    :mloc
                                    '("Math" "main" 2))
                              nil)
                        :stat 'active
                        :ref nil))
            :hp nil
            :ct *math-ct*))

|#