#|
 Copyright (C) 1994 by Computational Logic, Inc.  All Rights Reserved.

 You may copy and distribute verbatim copies of this Nqthm-1992 event script as
 you receive it, in any medium, including embedding it verbatim in derivative
 works, provided that you conspicuously and appropriately publish on each copy
 a valid copyright notice "Copyright (C) 1994 by Computational Logic, Inc.  All
 Rights Reserved."

 NO WARRANTY

 Computational Logic, Inc. PROVIDES ABSOLUTELY NO WARRANTY.  THE EVENT SCRIPT
 IS PROVIDED "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESS OR IMPLIED,
 INCLUDING, BUT NOT LIMITED TO, ANY IMPLIED WARRANTIES OF MERCHANTABILITY AND
 FITNESS FOR A PARTICULAR PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND
 PERFORMANCE OF THE SCRIPT IS WITH YOU.  SHOULD THE SCRIPT PROVE DEFECTIVE, YOU
 ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION.

 IN NO EVENT WILL Computational Logic, Inc. BE LIABLE TO YOU FOR ANY DAMAGES,
 ANY LOST PROFITS, LOST MONIES, OR OTHER SPECIAL, INCIDENTAL OR CONSEQUENTIAL
 DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THIS SCRIPT (INCLUDING BUT
 NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES
 SUSTAINED BY THIRD PARTIES), EVEN IF YOU HAVE ADVISED US OF THE POSSIBILITY OF
 SUCH DAMAGES, OR FOR ANY CLAIM BY ANY OTHER PARTY.
|#

; FM9001 Piton 

; J Strother Moore
; October, 1991

; History 

; This file contains the complete script of the events establishing
; that Piton is correctly implemented on top of the FM9001.  The
; original correctness proof for Piton was done for the FM8502 and is
; reported accurately and completely in CLI Tech Report 22.  That
; report is still basically accurate.  FM9001 differs from FM8502
; primarily in that instructions are in a slightly different format
; and the instruction set is slightly different.  However, when Hunt
; and Brock developed FM9001 from FM8502 they explicitly considered
; Piton's use of the FM8502 instruction set.  For each FM8502
; instruction-instance used by the Piton compiler, they included an
; FM9001 instruction that could provide the same functionality.  Thus,
; to port the Piton implementation from FM8502 to FM9001 it was only
; necessary to change the code linkers, essentially from
; LINK-INSTR-WORD on down.

; However, porting the proof from FM8502 to FM9001 was harder than
; suggested by the instruction set changes alone.  FM9001 uses a
; different formal representation of memory -- a binary tree instead
; of a linear list -- and uses a different formalization of bit
; vectors -- lists of Booleans instead of the BITV shell.  But most
; dramatically, the FM8502 proof used an experimental version of NQTHM
; that was supposed to become the released version.  That experimental
; NQTHM, called XNQTHM, provided "books".  Indeed, it was the FM8502
; Piton effort that caused books to be invented in the first place.
; With books, the XNQTHM user could develop a large body of lemmas in
; one session and then, in the course of later sessions, extract
; selected results to build upon.  Thus, books were incremental as
; opposed to the monolithic "core dump" view of state saving provided
; by NQTHM's lib files.  The FM8502 Piton proofs used four different
; (major) books: one to handle the p->r diagram, one for r->i, one for
; i->m (where we also handled m=FM8502), and then one in which the
; main correctness result was derived by extracting the key theorems
; from the three preceding books.  In addition, the original
; development devoted a book each to the definitions of the various
; machines (p, r, i, and m) and to the implementation of the compiler
; and link-assembler so they could be loaded and run in isolation from
; the correctness proof.  (This was in fact necessary since, for
; example, both the p->r book and the r->i book both needed access to
; the definition of the r machine and the implementation.)  Finally, I
; redid the FM8502 correctness proof in book form so that Piton could
; build on the definition of FM8502 without the clutter of its
; correctness proof or gate-level implementation.

; In the summer of 1989, Boyer and I began the process of "blessing"
; XNQTHM in preparation for its release as the new NQTHM.  However,
; after several months of trying to combine macros and books, we
; decided to start afresh.  We thereby embarked on the NTHM Project,
; where books are central to the whole design.  That is another story.
; However, one impact of the decision not to release XNQTHM was the
; need to reproduce the Piton proofs in a publicly available NQTHM.  I
; decided to wait until FM9001 was done and then to do the new Piton
; in NQTHM (rather than XNQTHM).

; This has had a major detrimental effect on the readability of the
; proof script.  Books allowed a clean hierarchical decomposition of
; the various layers of the problem.  This was lost when I
; (essentially) just concatenated the event lists from all of the
; Piton books into one massive script.  Of course, I had to start this
; proof effort in the library file created for the FM9001 correctness
; proof, the only NQTHM file containing "the" correct definition of
; FM9001.  To achieve the effect of isolation provided by books, each
; major section is separated from the others by thousands of DISABLE
; events which effectively erase the rule base developed thus far.  In
; addition, some names had to be changed because of clashes which were
; allowed under the book mechanism.  In short, the "new" proof of
; Piton is, in many ways, a step backward from the original one.  This
; was particularly frustrating for me since NTHM's books (which are
; implemented and seem to work) provide even greater functionality
; than XNQTHM's books.  The ideal thing to have done would have been
; for everybody else to take ten years' vacation while Boyer and I
; perfected and released NTHM, and then to develop the new FM9001 stack
; in NTHM.

; I ported the first of Piton's 3 commutative diagrams to the FM9001
; in May, 1991.  At that time, the FM9001 correctness proof was not
; completed.  I "borrowed" a lib file from Bishop that contained the
; majority of the proof and did the bottom-most diagram in that lib.
; Actually, I introduced a fourth layer to Piton: the link from M to
; FM9001 (the corresponding level in the FM8502 proof was an equality)
; has become a full-fledged commutative diagram that handles the
; memory.  See M->FM9001, which is now the fourth application in LOAD,
; and ONE-WAY-CORRESPONDENCE-M-FM9001.  In one week in May, I
; successfully proved that the M machine was implemented on FM9001.  I
; then waited until my decks were clear (October, 1991) to port the
; rest of the proof.  It has taken roughly 2 weeks to do the rest.

; A major new proof burden was introduced by the new memory representation.
; See the events surrounding PLAUSIBLE-DATA-LINK-TABLEP.  The basic problem
; was that in order to display the FM9001 memory to recover the M memory (i.e.,
; to get the "up" arrow in the bottom-most diagram), it was necessary to know
; that no address exceeded the size the of FM9001 memory.  This in turn
; required showing that the size of the final memory was the same as that
; for the initial memory.  This in turn forced us to prove the analogous
; fact all the way up, i.e., for M, I, R, and P.  At the higher levels, of
; course, what we proved was that the machines preserved the "signatures"
; of the program and data segments.  While this work could have been
; rather naturally done at the time we were dealing with the respective
; machines in their component diagrams, we did not recognize the need for the
; theorems until we had redone all of the old diagrams and were trying to
; combine everything at the very end.  Thus, you will see at the end of this
; script some hideous lemmas about the r and p machines where we tediously
; enable things that were "naturally" enabled earlier in the script.

; The book structure of the original proof can be seen by searching
; for comments of the form "; Book:".

; November, 1991: After the first successful port to FM9001 a new
; patch was installed: The loader was changed to allow us to specify
; the location at which the Piton data segment was laid down in
; memory.  This was done so that part of the data segment could be
; memory mapped to allow us to do some output from Piton.  This was
; achieved by swapping the positions of the prog segment and the data
; segment (in the original Piton work, the prog segment was laid out
; first, followed by the data segment and then the system data).  Now
; the data segment is laid out first, then the program segment, and
; then the system data segment.  Furthermore, all of this is laid out
; starting at a given location, generally named the LOAD-ADDR, and the
; contents of memory below that point is specified by an oracle,
; generally named BOOT-LST.

; This change has had drastic effects rippling through the Piton
; proof.

; This takes roughly 8 hours on a Sparc 2 in AKCL and generates 30Mb
; of .proof output and a .lib file of about 20Mb.

(note-lib "fm9001-replay" t)

(set-status close-data-base-1 t ((boot-strap initial)
                                 (add-shell enable)
                                 ((defn *1*defn) enable)
                                 (otherwise disable)))

; Book:  Implementation.events

; We first define the implementation of Piton.  It is odd that we
; start there rather than with the semantics of the P machine.
; Logically and historically we started with the semantics.  But we
; are building the proof from the bottom up and in the beginning all
; we have is FM9001 and the implementation and we will build the m
; machine to explain the link part of the implementation, the i
; machine to build the code generator part, etc.

(DEFN INCR (C X)
  (IF (NLISTP X)
      NIL
      (CONS (XOR C (CAR X))
            (INCR (AND C (CAR X)) (CDR X)))))

(DEFN BITN (X N)
  (COND ((ZEROP N) F)
        ((EQUAL N 1) (CAR X))
        (T (BITN (CDR X) (SUB1 N)))))

(ADD-SHELL P-STATE NIL P-STATEP
           ((P-PC (NONE-OF) ZERO)
            (P-CTRL-STK (NONE-OF) ZERO)
            (P-TEMP-STK (NONE-OF) ZERO)
            (P-PROG-SEGMENT (NONE-OF) ZERO)
            (P-DATA-SEGMENT (NONE-OF) ZERO)
            (P-MAX-CTRL-STK-SIZE (NONE-OF) ZERO)
            (P-MAX-TEMP-STK-SIZE (NONE-OF) ZERO)
            (P-WORD-SIZE (NONE-OF) ZERO)
            (P-PSW (NONE-OF) ZERO)))

(DEFN ERRORP
      (PSW)
      (AND (NOT (EQUAL PSW 'RUN))
           (NOT (EQUAL PSW 'HALT))))

(DEFN DEFINITION
      (NAME ALIST)
      (ASSOC NAME ALIST))

(DEFN STRIP-CDRS
      (ALIST)
      (IF (NLISTP ALIST)
          NIL
          (CONS (CDAR ALIST)
                (STRIP-CDRS (CDR ALIST)))))

(DEFN NAME (D) (CAR D))

(DEFN FORMAL-VARS (D) (CADR D))

(DEFN TEMP-VAR-DCLS (D) (CADDR D))

(DEFN PROGRAM-BODY (D) (CDDDR D))

(DEFN LOCAL-VARS
      (D)
      (APPEND (FORMAL-VARS D)
              (STRIP-CARS (TEMP-VAR-DCLS D))))

(DEFN ADP-NAME (ADP) (CAR ADP))

(DEFN ADP-OFFSET (ADP) (CDR ADP))

(DEFN SUB-ADP
      (ADP N)
      (CONS (ADP-NAME ADP)
            (DIFFERENCE (ADP-OFFSET ADP) N)))

(DEFN GET
      (N LST)
      (IF (ZEROP N)
          (CAR LST)
          (GET (SUB1 N) (CDR LST))))

(DEFN TAG (TYPE OBJ) (LIST TYPE OBJ))

(DEFN TYPE (CONST) (CAR CONST))

(DEFN UNTAG (CONST) (CADR CONST))

(DEFN AREA-NAME
      (X)
      (ADP-NAME (UNTAG X)))

(DEFN SUB-ADDR
      (ADDR N)
      (TAG (TYPE ADDR)
           (SUB-ADP (UNTAG ADDR) N)))

(DEFN TOP (STK) (CAR STK))

(DEFN POP (STK) (CDR STK))

(DEFN DL
      (LAB COMMENT INS)
      (LIST 'DL LAB COMMENT INS))

(DEFN LABELLEDP
      (X)
      (EQUAL (CAR X) 'DL))

(DEFN UNLABEL
      (X)
      (IF (LABELLEDP X) (CADDDR X) X))

(DEFN FIND-LABEL
      (X LST)
      (COND ((NLISTP LST) 0)
            ((AND (LABELLEDP (CAR LST))
                  (EQUAL X (CADAR LST)))
             0)
            (T (ADD1 (FIND-LABEL X (CDR LST))))))

(DEFN PC
      (LAB PROGRAM)
      (TAG 'PC
           (CONS (NAME PROGRAM)
                 (FIND-LABEL LAB
                             (PROGRAM-BODY PROGRAM)))))

(DEFN BINDINGS (FRAME) (CAR FRAME))

(DEFN RET-PC (FRAME) (CADR FRAME))

(DEFN P-FRAME-SIZE
      (FRAME)
      (PLUS 2 (LENGTH (BINDINGS FRAME))))

(DEFN P-CTRL-STK-SIZE
      (CTRL-STK)
      (IF (NLISTP CTRL-STK)
          0
          (PLUS (P-FRAME-SIZE (TOP CTRL-STK))
                (P-CTRL-STK-SIZE (CDR CTRL-STK)))))

(DEFN ICODE-CALL
      (INS PCN PROGRAM)
      (LIST '(CPUSH_*)
            (TAG 'PC
                 (CONS (NAME PROGRAM) (ADD1 PCN)))
            '(JUMP_*)
            (TAG 'PC
                 (CONS (CADR INS) '(PRELUDE)))))

(DEFN GENERATE-PRELUDE1
      (TEMP-VAR-DCLS)
      (IF (NLISTP TEMP-VAR-DCLS)
          NIL
          (CONS '(CPUSH_*)
                (CONS (CADAR TEMP-VAR-DCLS)
                      (GENERATE-PRELUDE1 (CDR TEMP-VAR-DCLS))))))

(DEFN GENERATE-PRELUDE2
      (FORMAL-VARS)
      (IF (NLISTP FORMAL-VARS)
          NIL
          (CONS '(CPUSH_<TSP>+)
                (GENERATE-PRELUDE2 (CDR FORMAL-VARS)))))

(DEFN GENERATE-PRELUDE
      (PROGRAM)
      (APPEND (CONS (DL (CONS (NAME PROGRAM) '(PRELUDE))
                        '(PRELUDE)
                        '(CPUSH_CFP))
                    '((MOVE_CFP_CSP)))
              (APPEND (GENERATE-PRELUDE1 (REVERSE (TEMP-VAR-DCLS PROGRAM)))
                      (GENERATE-PRELUDE2 (FORMAL-VARS PROGRAM)))))

(DEFN FIND-POSITION-OF-VAR
      (VAR LST)
      (COND ((NLISTP LST) 0)
            ((EQUAL VAR (CAR LST)) 0)
            (T (ADD1 (FIND-POSITION-OF-VAR VAR
                                           (CDR LST))))))

(DEFN OFFSET-FROM-CSP
      (VAR PROGRAM)
      (FIND-POSITION-OF-VAR VAR
                            (LOCAL-VARS PROGRAM)))

(DEFN GENERATE-POSTLUDE
      (PROGRAM)
      (CONS (DL (CONS (NAME PROGRAM)
                      (LENGTH (PROGRAM-BODY PROGRAM)))
                '(POSTLUDE)
                '(MOVE_CSP_CFP))
            '((CPOP_CFP) (CPOP_PC))))

(DEFN ICODE-RET
      (INS PCN PROGRAM)
      (LIST '(JUMP_*)
            (TAG 'PC
                 (CONS (NAME PROGRAM)
                       (LENGTH (PROGRAM-BODY PROGRAM))))))

(DEFN ICODE-LOCN
      (INS PCN PROGRAM)
      (CONS '(MOVE_X_*)
            (CONS (TAG 'NAT
                       (OFFSET-FROM-CSP (CADR INS) PROGRAM))
                  '((ADD_X{N}_CSP)
                    (MOVE_X_<X{S}>)
                    (ADD_X{N}_CSP)
                    (TPUSH_<X{S}>)))))

(DEFN ICODE-PUSH-CONSTANT
      (INS PCN PROGRAM)
      (LIST '(TPUSH_*)
            (COND ((EQUAL (CADR INS) 'PC)
                   (TAG 'PC
                        (CONS (NAME PROGRAM) (ADD1 PCN))))
                  ((NLISTP (CADR INS))
                   (PC (CADR INS) PROGRAM))
                  (T (CADR INS)))))

(DEFN ICODE-PUSH-LOCAL
      (INS PCN PROGRAM)
      (CONS '(MOVE_X_*)
            (CONS (TAG 'NAT
                       (OFFSET-FROM-CSP (CADR INS) PROGRAM))
                  '((ADD_X{N}_CSP) (TPUSH_<X{S}>)))))

(DEFN ICODE-PUSH-GLOBAL
      (INS PCN PROGRAM)
      (CONS '(MOVE_X_*)
            (CONS (TAG 'ADDR (CONS (CADR INS) 0))
                  '((TPUSH_<X{A}>)))))

(DEFN ICODE-PUSH-CTRL-STK-FREE-SIZE
      (INS PCN PROGRAM)
      '((MOVE_X_*)
        (SYS-ADDR (FULL-CTRL-STK-ADDR . 0))
        (MOVE_X_<X{S}>)
        (TPUSH_CSP)
        (SUB_<TSP>{S}_X{S})))

(DEFN ICODE-PUSH-TEMP-STK-FREE-SIZE
      (INS PCN PROGRAM)
      '((MOVE_X_*)
        (SYS-ADDR (FULL-TEMP-STK-ADDR . 0))
        (MOVE_X_<X{S}>)
        (TPUSH_TSP)
        (SUB_<TSP>{S}_X{S})))

(DEFN ICODE-PUSH-TEMP-STK-INDEX
 (INS PCN PROGRAM)
 (CONS
      '(MOVE_Y_TSP)
      (CONS '(MOVE_X_*)
            (CONS '(SYS-ADDR (EMPTY-TEMP-STK-ADDR . 0))
                  (CONS '(MOVE_X_<X{S}>)
                        (CONS '(SUB_<Z>_X{S}_Y{S})
                              (CONS '(TPUSH_X)
                                    (CONS '(MOVE_X_*)
                                          (CONS (TAG 'NAT (ADD1 (CADR INS)))
                                                '((SUB_<TSP>{N}_X{N})))))))))))

(DEFN ICODE-JUMP-IF-TEMP-STK-FULL
      (INS PCN PROGRAM)
      (CONS '(MOVE_X_TSP)
            (CONS '(MOVE_Y_*)
                  (CONS '(SYS-ADDR (FULL-TEMP-STK-ADDR . 0))
                        (CONS '(MOVE_Y_<Y{S}>)
                              (CONS '(SUB_<Z>_X{S}_Y{S})
                                    (CONS '(MOVE_X_*)
                                          (CONS (PC (CADR INS) PROGRAM)
                                                '((JUMP-Z_X))))))))))

(DEFN ICODE-JUMP-IF-TEMP-STK-EMPTY
      (INS PCN PROGRAM)
      (CONS '(MOVE_Y_TSP)
            (CONS '(MOVE_X_*)
                  (CONS '(SYS-ADDR (EMPTY-TEMP-STK-ADDR . 0))
                        (CONS '(MOVE_X_<X{S}>)
                              (CONS '(SUB_<Z>_X{S}_Y{S})
                                    (CONS '(MOVE_X_*)
                                          (CONS (PC (CADR INS) PROGRAM)
                                                '((JUMP-Z_X))))))))))

(DEFN ICODE-POP
      (INS PCN PROGRAM)
      '((TPOP_X)))

(DEFN ICODE-POP*
      (INS PCN PROGRAM)
      (LIST '(ADD_TSP_*{N})
            (TAG 'NAT (CADR INS))))

(DEFN ICODE-POPN
      (INS PCN PROGRAM)
      '((TPOP_X) (ADD_TSP_X{N})))

(DEFN ICODE-POP-LOCAL
      (INS PCN PROGRAM)
      (CONS '(MOVE_X_*)
            (CONS (TAG 'NAT
                       (OFFSET-FROM-CSP (CADR INS) PROGRAM))
                  '((ADD_X{N}_CSP) (TPOP_<X{S}>)))))

(DEFN ICODE-POP-GLOBAL
      (INS PCN PROGRAM)
      (CONS '(MOVE_X_*)
            (CONS (TAG 'ADDR (CONS (CADR INS) 0))
                  '((TPOP_<X{A}>)))))

(DEFN ICODE-POP-LOCN
      (INS PCN PROGRAM)
      (CONS '(MOVE_X_*)
            (CONS (TAG 'NAT
                       (OFFSET-FROM-CSP (CADR INS) PROGRAM))
                  '((ADD_X{N}_CSP)
                    (MOVE_X_<X{S}>)
                    (ADD_X{N}_CSP)
                    (TPOP_<X{S}>)))))

(DEFN ICODE-POP-CALL
      (INS PCN PROGRAM)
      (CONS '(TPOP_X)
            (CONS '(CPUSH_*)
                  (CONS (TAG 'PC
                             (CONS (NAME PROGRAM) (ADD1 PCN)))
                        '((JUMP_X{SUBR}))))))

(DEFN ICODE-FETCH-TEMP-STK
      (INS PCN PROGRAM)
      '((TPOP_Y)
        (INCR_Y_Y{N})
        (MOVE_X_*)
        (SYS-ADDR (EMPTY-TEMP-STK-ADDR . 0))
        (MOVE_X_<X{S}>)
        (SUB_X{S}_Y{N})
        (TPUSH_<X{S}>)))

(DEFN ICODE-DEPOSIT-TEMP-STK
      (INS PCN PROGRAM)
      '((TPOP_Y)
        (INCR_Y_Y{N})
        (MOVE_X_*)
        (SYS-ADDR (EMPTY-TEMP-STK-ADDR . 0))
        (MOVE_X_<X{S}>)
        (SUB_X{S}_Y{N})
        (TPOP_<X{S}>)))

(DEFN ICODE-JUMP
      (INS PCN PROGRAM)
      (LIST '(JUMP_*)
            (PC (CADR INS) PROGRAM)))

(DEFN JUMP_*-LST
      (LST PROGRAM)
      (IF (NLISTP LST)
          NIL
          (CONS '(JUMP_*)
                (CONS (PC (CAR LST) PROGRAM)
                      (JUMP_*-LST (CDR LST) PROGRAM)))))

(DEFN ICODE-JUMP-CASE
      (INS PCN PROGRAM)
      (APPEND '((TPOP_X) (ADD_X_X{N}) (ADD_PC_X{N}))
              (JUMP_*-LST (CDR INS) PROGRAM)))

(DEFN ICODE-PUSHJ
      (INS PCN PROGRAM)
      (LIST '(TPUSH_*)
            (TAG 'PC
                 (CONS (NAME PROGRAM) (ADD1 PCN)))
            '(JUMP_*)
            (PC (CADR INS) PROGRAM)))

(DEFN ICODE-POPJ
      (INS PCN PROGRAM)
      '((TPOP_PC)))

(DEFN ICODE-SET-LOCAL
      (INS PCN PROGRAM)
      (CONS '(MOVE_X_*)
            (CONS (TAG 'NAT
                       (OFFSET-FROM-CSP (CADR INS) PROGRAM))
                  '((ADD_X{N}_CSP)
                    (MOVE_<X{S}>_<TSP>)))))

(DEFN ICODE-SET-GLOBAL
      (INS PCN PROGRAM)
      (CONS '(MOVE_X_*)
            (CONS (TAG 'ADDR (CONS (CADR INS) 0))
                  '((MOVE_<X{A}>_<TSP>)))))

(DEFN ICODE-TEST-NAT-AND-JUMP
      (INS PCN PROGRAM)
      (IF (EQUAL (CADR INS) 'ZERO)
          (CONS '(TPOP{N}_<Z>_Y)
                (CONS '(MOVE_X_*)
                      (CONS (PC (CADDR INS) PROGRAM)
                            '((JUMP-Z_X)))))
          (CONS '(TPOP{N}_<Z>_Y)
                (CONS '(MOVE_X_*)
                      (CONS (PC (CADDR INS) PROGRAM)
                            '((JUMP-NZ_X)))))))

(DEFN ICODE-TEST-INT-AND-JUMP
      (INS PCN PROGRAM)
      (CASE (CAR (CDR INS))
            (ZERO (CONS '(TPOP{I}_<ZN>_Y)
                        (CONS '(MOVE_X_*)
                              (CONS (PC (CADDR INS) PROGRAM)
                                    '((JUMP-Z_X))))))
            (NOT-ZERO (CONS '(TPOP{I}_<ZN>_Y)
                            (CONS '(MOVE_X_*)
                                  (CONS (PC (CADDR INS) PROGRAM)
                                        '((JUMP-NZ_X))))))
            (NEG (CONS '(TPOP{I}_<ZN>_Y)
                       (CONS '(MOVE_X_*)
                             (CONS (PC (CADDR INS) PROGRAM)
                                   '((JUMP-N_X))))))
            (NOT-NEG (CONS '(TPOP{I}_<ZN>_Y)
                           (CONS '(MOVE_X_*)
                                 (CONS (PC (CADDR INS) PROGRAM)
                                       '((JUMP-NN_X))))))
            (POS (LIST '(TPOP{I}_<ZN>_Y)
                       '(MOVE_X_*)
                       (TAG 'PC
                            (CONS (NAME PROGRAM) (ADD1 PCN)))
                       '(JUMP-N_X)
                       '(JUMP-Z_X)
                       '(JUMP_*)
                       (PC (CADDR INS) PROGRAM)))
            (OTHERWISE (CONS '(TPOP{I}_<ZN>_Y)
                             (CONS '(MOVE_X_*)
                                   (CONS (PC (CADDR INS) PROGRAM)
                                         '((JUMP-N_X) (JUMP-Z_X))))))))

(DEFN ICODE-TEST-BOOL-AND-JUMP
      (INS PCN PROGRAM)
      (IF (EQUAL (CADR INS) 'T)
          (CONS '(TPOP{B}_<Z>_Y)
                (CONS '(MOVE_X_*)
                      (CONS (PC (CADDR INS) PROGRAM)
                            '((JUMP-NZ_X)))))
          (CONS '(TPOP{B}_<Z>_Y)
                (CONS '(MOVE_X_*)
                      (CONS (PC (CADDR INS) PROGRAM)
                            '((JUMP-Z_X)))))))

(DEFN ICODE-TEST-BITV-AND-JUMP
      (INS PCN PROGRAM)
      (IF (EQUAL (CADR INS) 'ALL-ZERO)
          (CONS '(TPOP{V}_<Z>_Y)
                (CONS '(MOVE_X_*)
                      (CONS (PC (CADDR INS) PROGRAM)
                            '((JUMP-Z_X)))))
          (CONS '(TPOP{V}_<Z>_Y)
                (CONS '(MOVE_X_*)
                      (CONS (PC (CADDR INS) PROGRAM)
                            '((JUMP-NZ_X)))))))

(DEFN ICODE-NO-OP
      (INS PCN PROGRAM)
      '((MOVE_X_X)))

(DEFN ICODE-ADD-ADDR
      (INS PCN PROGRAM)
      '((TPOP_X) (ADD_<TSP>{A}_X{N})))

(DEFN ICODE-SUB-ADDR
      (INS PCN PROGRAM)
      '((TPOP_X) (SUB_<TSP>{A}_X{N})))

(DEFN ICODE-EQ
      (INS PCN PROGRAM)
      '((TPOP_X)
        (XOR_<Z>_<TSP>_X)
        (XOR_<TSP>_<TSP>)
        (MOVE-Z_<TSP>_*)
        (BOOL T)))

(DEFN ICODE-LT-ADDR
      (INS PCN PROGRAM)
      '((TPOP_X)
        (SUB_<C>_<TSP>{A}_X{A})
        (XOR_<TSP>_<TSP>)
        (MOVE-C_<TSP>_*)
        (BOOL T)))

(DEFN ICODE-FETCH
      (INS PCN PROGRAM)
      '((TPOP_X) (TPUSH_<X{A}>)))

(DEFN ICODE-DEPOSIT
      (INS PCN PROGRAM)
      '((TPOP_X) (TPOP_<X{A}>)))

(DEFN ICODE-ADD-INT
      (INS PCN PROGRAM)
      '((TPOP_X) (ADD_<TSP>{I}_X{I})))

(DEFN ICODE-ADD-INT-WITH-CARRY
      (INS PCN PROGRAM)
      '((TPOP_X)
        (TPOP_Y)
        (ASR_<C>_<TSP>_<TSP>{B})
        (ADDC_<V>_X{I}_Y{I})
        (MOVE-V_<TSP>_*)
        (BOOL T)
        (TPUSH_X)))

(DEFN ICODE-ADD1-INT
      (INS PCN PROGRAM)
      '((INCR_<TSP>_<TSP>{I})))

(DEFN ICODE-SUB-INT
      (INS PCN PROGRAM)
      '((TPOP_X) (SUB_<TSP>{I}_X{I})))

(DEFN ICODE-SUB-INT-WITH-CARRY
      (INS PCN PROGRAM)
      '((TPOP_Y)
        (TPOP_X)
        (ASR_<C>_<TSP>_<TSP>{B})
        (SUBB_<V>_X{I}_Y{I})
        (MOVE-V_<TSP>_*)
        (BOOL T)
        (TPUSH_X)))

(DEFN ICODE-SUB1-INT
      (INS PCN PROGRAM)
      '((DECR_<TSP>_<TSP>{I})))

(DEFN ICODE-NEG-INT
      (INS PCN PROGRAM)
      '((NEG_<TSP>_<TSP>{I})))

(DEFN ICODE-LT-INT
      (INS PCN PROGRAM)
      '((TPOP_X)
        (SUB_<NV>_<TSP>{I}_X{I})
        (MOVE_<TSP>_*)
        (BOOL F)
        (MOVE-V_<TSP>_*)
        (BOOL T)
        (MOVE_X_*)
        (BOOL F)
        (MOVE-N_X_*)
        (BOOL T)
        (XOR_<TSP>{B}_X{B})))

(DEFN ICODE-INT-TO-NAT
      (INS PCN PROGRAM)
      '((INT-TO-NAT)))

(DEFN ICODE-ADD-NAT
      (INS PCN PROGRAM)
      '((TPOP_X) (ADD_<TSP>{N}_X{N})))

(DEFN ICODE-ADD-NAT-WITH-CARRY
      (INS PCN PROGRAM)
      '((TPOP_X)
        (TPOP_Y)
        (ASR_<C>_<TSP>_<TSP>{B})
        (ADDC_<C>_X{N}_Y{N})
        (MOVE-C_<TSP>_*)
        (BOOL T)
        (TPUSH_X)))

(DEFN ICODE-ADD1-NAT
      (INS PCN PROGRAM)
      '((INCR_<TSP>_<TSP>{N})))

(DEFN ICODE-SUB-NAT
      (INS PCN PROGRAM)
      '((TPOP_X) (SUB_<TSP>{N}_X{N})))

(DEFN ICODE-SUB-NAT-WITH-CARRY
      (INS PCN PROGRAM)
      '((TPOP_Y)
        (TPOP_X)
        (ASR_<C>_<TSP>_<TSP>{B})
        (SUBB_<C>_X{N}_Y{N})
        (MOVE-C_<TSP>_*)
        (BOOL T)
        (TPUSH_X)))

(DEFN ICODE-SUB1-NAT
      (INS PCN PROGRAM)
      '((DECR_<TSP>_<TSP>{N})))

(DEFN ICODE-LT-NAT
      (INS PCN PROGRAM)
      '((TPOP_X)
        (SUB_<C>_<TSP>{N}_X{N})
        (XOR_<TSP>_<TSP>)
        (MOVE-C_<TSP>_*)
        (BOOL T)))

(DEFN ICODE-MULT2-NAT
      (INS PCN PROGRAM)
      '((ADD_<TSP>_<TSP>{N})))

(DEFN ICODE-MULT2-NAT-WITH-CARRY-OUT
      (INS PCN PROGRAM)
      '((TPOP_X)
        (ADD_<C>_X_X{N})
        (TPUSH_*)
        (BOOL F)
        (MOVE-C_<TSP>_*)
        (BOOL T)
        (TPUSH_X)))

(DEFN ICODE-DIV2-NAT
      (INS PCN PROGRAM)
      '((TPOP_<C>_X)
        (LSR_<C>_X_X{N})
        (TPUSH_X)
        (TPUSH_*)
        (NAT 0)
        (MOVE-C_<TSP>_*)
        (NAT 1)))

(DEFN ICODE-OR-BITV
      (INS PCN PROGRAM)
      '((TPOP_X) (OR_<TSP>{V}_X{V})))

(DEFN ICODE-AND-BITV
      (INS PCN PROGRAM)
      '((TPOP_X) (AND_<TSP>{V}_X{V})))

(DEFN ICODE-NOT-BITV
      (INS PCN PROGRAM)
      '((NOT_<TSP>_<TSP>{V})))

(DEFN ICODE-XOR-BITV
      (INS PCN PROGRAM)
      '((TPOP_X) (XOR_<TSP>{V}_X{V})))

(DEFN ICODE-RSH-BITV
      (INS PCN PROGRAM)
      '((LSR_<TSP>_<TSP>{V})))

(DEFN ICODE-LSH-BITV
      (INS PCN PROGRAM)
      '((ADD_<TSP>_<TSP>{V})))

(DEFN ICODE-OR-BOOL
      (INS PCN PROGRAM)
      '((TPOP_X) (OR_<TSP>{B}_X{B})))

(DEFN ICODE-AND-BOOL
      (INS PCN PROGRAM)
      '((TPOP_X) (AND_<TSP>{B}_X{B})))

(DEFN ICODE-NOT-BOOL
      (INS PCN PROGRAM)
      '((XOR_<TSP>{B}_*{B}) (BOOL T)))

(DEFN ICODE1
      (INS PCN PROG)
      (CASE (CAR INS)
            (CALL (ICODE-CALL INS PCN PROG))
            (RET (ICODE-RET INS PCN PROG))
            (LOCN (ICODE-LOCN INS PCN PROG))
            (PUSH-CONSTANT (ICODE-PUSH-CONSTANT INS PCN PROG))
            (PUSH-LOCAL (ICODE-PUSH-LOCAL INS PCN PROG))
            (PUSH-GLOBAL (ICODE-PUSH-GLOBAL INS PCN PROG))
            (PUSH-CTRL-STK-FREE-SIZE (ICODE-PUSH-CTRL-STK-FREE-SIZE INS PCN
                                                                    PROG))
            (PUSH-TEMP-STK-FREE-SIZE (ICODE-PUSH-TEMP-STK-FREE-SIZE INS PCN
                                                                    PROG))
            (PUSH-TEMP-STK-INDEX (ICODE-PUSH-TEMP-STK-INDEX INS PCN PROG))
            (JUMP-IF-TEMP-STK-FULL (ICODE-JUMP-IF-TEMP-STK-FULL INS PCN PROG))
            (JUMP-IF-TEMP-STK-EMPTY (ICODE-JUMP-IF-TEMP-STK-EMPTY INS PCN
                                                                  PROG))
            (POP (ICODE-POP INS PCN PROG))
            (POP* (ICODE-POP* INS PCN PROG))
            (POPN (ICODE-POPN INS PCN PROG))
            (POP-LOCAL (ICODE-POP-LOCAL INS PCN PROG))
            (POP-GLOBAL (ICODE-POP-GLOBAL INS PCN PROG))
            (POP-LOCN (ICODE-POP-LOCN INS PCN PROG))
            (POP-CALL (ICODE-POP-CALL INS PCN PROG))
            (FETCH-TEMP-STK (ICODE-FETCH-TEMP-STK INS PCN PROG))
            (DEPOSIT-TEMP-STK (ICODE-DEPOSIT-TEMP-STK INS PCN PROG))
            (JUMP (ICODE-JUMP INS PCN PROG))
            (JUMP-CASE (ICODE-JUMP-CASE INS PCN PROG))
            (PUSHJ (ICODE-PUSHJ INS PCN PROG))
            (POPJ (ICODE-POPJ INS PCN PROG))
            (SET-LOCAL (ICODE-SET-LOCAL INS PCN PROG))
            (SET-GLOBAL (ICODE-SET-GLOBAL INS PCN PROG))
            (TEST-NAT-AND-JUMP (ICODE-TEST-NAT-AND-JUMP INS PCN PROG))
            (TEST-INT-AND-JUMP (ICODE-TEST-INT-AND-JUMP INS PCN PROG))
            (TEST-BOOL-AND-JUMP (ICODE-TEST-BOOL-AND-JUMP INS PCN PROG))
            (TEST-BITV-AND-JUMP (ICODE-TEST-BITV-AND-JUMP INS PCN PROG))
            (NO-OP (ICODE-NO-OP INS PCN PROG))
            (ADD-ADDR (ICODE-ADD-ADDR INS PCN PROG))
            (SUB-ADDR (ICODE-SUB-ADDR INS PCN PROG))
            (EQ (ICODE-EQ INS PCN PROG))
            (LT-ADDR (ICODE-LT-ADDR INS PCN PROG))
            (FETCH (ICODE-FETCH INS PCN PROG))
            (DEPOSIT (ICODE-DEPOSIT INS PCN PROG))
            (ADD-INT (ICODE-ADD-INT INS PCN PROG))
            (ADD-INT-WITH-CARRY (ICODE-ADD-INT-WITH-CARRY INS PCN PROG))
            (ADD1-INT (ICODE-ADD1-INT INS PCN PROG))
            (SUB-INT (ICODE-SUB-INT INS PCN PROG))
            (SUB-INT-WITH-CARRY (ICODE-SUB-INT-WITH-CARRY INS PCN PROG))
            (SUB1-INT (ICODE-SUB1-INT INS PCN PROG))
            (NEG-INT (ICODE-NEG-INT INS PCN PROG))
            (LT-INT (ICODE-LT-INT INS PCN PROG))
            (INT-TO-NAT (ICODE-INT-TO-NAT INS PCN PROG))
            (ADD-NAT (ICODE-ADD-NAT INS PCN PROG))
            (ADD-NAT-WITH-CARRY (ICODE-ADD-NAT-WITH-CARRY INS PCN PROG))
            (ADD1-NAT (ICODE-ADD1-NAT INS PCN PROG))
            (SUB-NAT (ICODE-SUB-NAT INS PCN PROG))
            (SUB-NAT-WITH-CARRY (ICODE-SUB-NAT-WITH-CARRY INS PCN PROG))
            (SUB1-NAT (ICODE-SUB1-NAT INS PCN PROG))
            (LT-NAT (ICODE-LT-NAT INS PCN PROG))
            (MULT2-NAT (ICODE-MULT2-NAT INS PCN PROG))
            (MULT2-NAT-WITH-CARRY-OUT (ICODE-MULT2-NAT-WITH-CARRY-OUT INS PCN
                                                                      PROG))
            (DIV2-NAT (ICODE-DIV2-NAT INS PCN PROG))
            (OR-BITV (ICODE-OR-BITV INS PCN PROG))
            (AND-BITV (ICODE-AND-BITV INS PCN PROG))
            (NOT-BITV (ICODE-NOT-BITV INS PCN PROG))
            (XOR-BITV (ICODE-XOR-BITV INS PCN PROG))
            (RSH-BITV (ICODE-RSH-BITV INS PCN PROG))
            (LSH-BITV (ICODE-LSH-BITV INS PCN PROG))
            (OR-BOOL (ICODE-OR-BOOL INS PCN PROG))
            (AND-BOOL (ICODE-AND-BOOL INS PCN PROG))
            (NOT-BOOL (ICODE-NOT-BOOL INS PCN PROG))
            (OTHERWISE '((ERROR)))))

(DEFN DL-BLOCK
      (LAB COMMENT BLOCK)
      (CONS (DL LAB COMMENT (CAR BLOCK))
            (CDR BLOCK)))

(DEFN ICODE
      (INS PCN PROGRAM)
      (DL-BLOCK (CONS (NAME PROGRAM) PCN)
                INS
                (ICODE1 (UNLABEL INS) PCN PROGRAM)))

(DEFN ICOMPILE-PROGRAM-BODY
      (LST PCN PROGRAM)
      (IF (NLISTP LST)
          NIL
          (APPEND (ICODE (CAR LST) PCN PROGRAM)
                  (ICOMPILE-PROGRAM-BODY (CDR LST)
                                         (ADD1 PCN)
                                         PROGRAM))))

(DEFN ICOMPILE-PROGRAM
      (PROGRAM)
      (CONS (NAME PROGRAM)
            (APPEND (GENERATE-PRELUDE PROGRAM)
                    (APPEND (ICOMPILE-PROGRAM-BODY (PROGRAM-BODY PROGRAM)
                                                   0 PROGRAM)
                            (GENERATE-POSTLUDE PROGRAM)))))

(DEFN ICOMPILE
      (PROGRAMS)
      (IF (NLISTP PROGRAMS)
          NIL
          (CONS (ICOMPILE-PROGRAM (CAR PROGRAMS))
                (ICOMPILE (CDR PROGRAMS)))))

(DEFN SEGMENT-LENGTH
      (SEGMENT)
      (IF (NLISTP SEGMENT)
          0
          (PLUS (LENGTH (CDAR SEGMENT))
                (SEGMENT-LENGTH (CDR SEGMENT)))))

(DEFN TOTAL-P-SYSTEM-SIZE (P LOAD-ADDR)
      (PLUS LOAD-ADDR
            (SEGMENT-LENGTH (P-DATA-SEGMENT P))
            (SEGMENT-LENGTH (ICOMPILE (P-PROG-SEGMENT P)))
            (ADD1 (P-MAX-CTRL-STK-SIZE P))
            (ADD1 (P-MAX-TEMP-STK-SIZE P))
            3))

(DEFN P-LOADABLEP (P LOAD-ADDR)
      (LESSP (TOTAL-P-SYSTEM-SIZE P LOAD-ADDR)
             (EXP 2 (P-WORD-SIZE P))))

(ADD-SHELL R-STATE NIL R-STATEP
           ((R-PC (NONE-OF) ZERO)
            (R-CFP (NONE-OF) ZERO)
            (R-CSP (NONE-OF) ZERO)
            (R-TSP (NONE-OF) ZERO)
            (R-X (NONE-OF) ZERO)
            (R-Y (NONE-OF) ZERO)
            (R-C-FLG (NONE-OF) ZERO)
            (R-V-FLG (NONE-OF) ZERO)
            (R-N-FLG (NONE-OF) ZERO)
            (R-Z-FLG (NONE-OF) ZERO)
            (R-PROG-SEGMENT (NONE-OF) ZERO)
            (R-USR-DATA-SEGMENT (NONE-OF) ZERO)
            (R-SYS-DATA-SEGMENT (NONE-OF) ZERO)
            (R-WORD-SIZE (NONE-OF) ZERO)
            (R-PSW (NONE-OF) ZERO)))

(DEFN NAT-0S
      (N)
      (IF (ZEROP N)
          NIL
          (CONS (TAG 'NAT 0)
                (NAT-0S (SUB1 N)))))

(DEFN P->R_TEMP-STK
      (TEMP-STK MAX-TEMP-STK-SIZE)
      (CONS 'TSTK
            (APPEND (NAT-0S (DIFFERENCE MAX-TEMP-STK-SIZE
                                        (LENGTH TEMP-STK)))
                    (APPEND TEMP-STK
                            (LIST (TAG 'NAT 0))))))

(DEFN P->R_CSP
      (STK MAX)
      (TAG 'SYS-ADDR
           (CONS 'CSTK
                 (DIFFERENCE MAX
                             (P-CTRL-STK-SIZE STK)))))

(DEFN P->R_CFP
      (STK MAX)
      (SUB-ADDR (P->R_CSP (POP STK) MAX) 2))

(DEFN P->R_P-FRAME
      (PFRAME STK MAX)
      (APPEND (STRIP-CDRS (BINDINGS PFRAME))
              (LIST (P->R_CFP STK MAX)
                    (RET-PC PFRAME))))

(DEFN P->R_CTRL-STK1
      (STK MAX)
      (IF (NLISTP STK)
          NIL
          (APPEND (P->R_P-FRAME (TOP STK) (POP STK) MAX)
                  (P->R_CTRL-STK1 (POP STK) MAX))))

(DEFN P->R_CTRL-STK
      (STK MAX)
      (CONS 'CSTK
            (APPEND (NAT-0S (DIFFERENCE MAX
                                        (P-CTRL-STK-SIZE STK)))
                    (APPEND (P->R_CTRL-STK1 STK MAX)
                            (LIST (TAG 'NAT 0))))))

(DEFN P->R_SYS-DATA-SEGMENT
      (CTRL-STK MAX-CTRL-STK-SIZE TEMP-STK MAX-TEMP-STK-SIZE)
      (LIST (P->R_CTRL-STK CTRL-STK MAX-CTRL-STK-SIZE)
            (P->R_TEMP-STK TEMP-STK MAX-TEMP-STK-SIZE)
            (LIST 'FULL-CTRL-STK-ADDR
                  (TAG 'SYS-ADDR '(CSTK . 0)))
            (LIST 'FULL-TEMP-STK-ADDR
                  (TAG 'SYS-ADDR '(TSTK . 0)))
            (LIST 'EMPTY-TEMP-STK-ADDR
                  (TAG 'SYS-ADDR
                       (CONS 'TSTK MAX-TEMP-STK-SIZE)))))

(DEFN P->R_TSP
      (STK MAX)
      (TAG 'SYS-ADDR
           (CONS 'TSTK
                 (DIFFERENCE MAX (LENGTH STK)))))

(DEFN P->R
      (P)
      (R-STATE (P-PC P)
               (P->R_CFP (P-CTRL-STK P)
                         (P-MAX-CTRL-STK-SIZE P))
               (P->R_CSP (P-CTRL-STK P)
                         (P-MAX-CTRL-STK-SIZE P))
               (P->R_TSP (P-TEMP-STK P)
                         (P-MAX-TEMP-STK-SIZE P))
               '(NAT 0)
               '(NAT 0)
               '(BOOL F)
               '(BOOL F)
               '(BOOL F)
               '(BOOL F)
               (P-PROG-SEGMENT P)
               (P-DATA-SEGMENT P)
               (P->R_SYS-DATA-SEGMENT (P-CTRL-STK P)
                                      (P-MAX-CTRL-STK-SIZE P)
                                      (P-TEMP-STK P)
                                      (P-MAX-TEMP-STK-SIZE P))
               (P-WORD-SIZE P)
               (P-PSW P)))

(ADD-SHELL I-STATE NIL I-STATEP
           ((I-PC (NONE-OF) ZERO)
            (I-CFP (NONE-OF) ZERO)
            (I-CSP (NONE-OF) ZERO)
            (I-TSP (NONE-OF) ZERO)
            (I-X (NONE-OF) ZERO)
            (I-Y (NONE-OF) ZERO)
            (I-C-FLG (NONE-OF) ZERO)
            (I-V-FLG (NONE-OF) ZERO)
            (I-N-FLG (NONE-OF) ZERO)
            (I-Z-FLG (NONE-OF) ZERO)
            (I-PROG-SEGMENT (NONE-OF) ZERO)
            (I-USR-DATA-SEGMENT (NONE-OF) ZERO)
            (I-SYS-DATA-SEGMENT (NONE-OF) ZERO)
            (I-WORD-SIZE (NONE-OF) ZERO)
            (I-PSW (NONE-OF) ZERO)))

(DEFN R->I_PC
      (PC PROGRAMS)
      (TAG 'IPC
           (CONS (AREA-NAME PC)
                 (FIND-LABEL (UNTAG PC)
                             (CDR (ICOMPILE-PROGRAM (DEFINITION (AREA-NAME PC)
                                                                PROGRAMS)))))))

(DEFN R->I_PSW
      (PSW)
      (IF (EQUAL PSW 'HALT) 'RUN PSW))

(DEFN R->I
      (R)
      (I-STATE (R->I_PC (R-PC R) (R-PROG-SEGMENT R))
               (R-CFP R)
               (R-CSP R)
               (R-TSP R)
               (R-X R)
               (R-Y R)
               (R-C-FLG R)
               (R-V-FLG R)
               (R-N-FLG R)
               (R-Z-FLG R)
               (ICOMPILE (R-PROG-SEGMENT R))
               (R-USR-DATA-SEGMENT R)
               (R-SYS-DATA-SEGMENT R)
               (R-WORD-SIZE R)
               (R->I_PSW (R-PSW R))))

(ADD-SHELL M-STATE NIL M-STATEP
           ((M-REGS (NONE-OF) ZERO)
            (M-C-FLG (NONE-OF) ZERO)
            (M-V-FLG (NONE-OF) ZERO)
            (M-N-FLG (NONE-OF) ZERO)
            (M-Z-FLG (NONE-OF) ZERO)
            (M-MEM (NONE-OF) ZERO)))

(DEFN LINK-TABLE-FOR-SEGMENT (SEGMENT ADDR0)
      (IF (NLISTP SEGMENT)
          NIL
          (CONS (CONS (CAAR SEGMENT) ADDR0)
                (LINK-TABLE-FOR-SEGMENT (CDR SEGMENT)
                                        (PLUS ADDR0
                                              (LENGTH (CDAR SEGMENT)))))))

(DEFN LINK-TABLE-FOR-LABELS
      (LST ADDR0)
      (COND ((NLISTP LST) NIL)
            ((LABELLEDP (CAR LST))
             (CONS (CONS (CADAR LST) ADDR0)
                   (LINK-TABLE-FOR-LABELS (CDR LST)
                                          (ADD1 ADDR0))))
            (T (LINK-TABLE-FOR-LABELS (CDR LST)
                                      (ADD1 ADDR0)))))

(DEFN LINK-TABLE-FOR-PROG-LABELS
      (SEGMENT ADDR0)
      (IF (NLISTP SEGMENT)
          NIL
          (CONS (CONS (CAAR SEGMENT)
                      (LINK-TABLE-FOR-LABELS (CDAR SEGMENT)
                                             ADDR0))
                (LINK-TABLE-FOR-PROG-LABELS (CDR SEGMENT)
                                            (PLUS ADDR0
                                                  (LENGTH (CDAR SEGMENT)))))))

(DEFN I-LINK-TABLES (I LOAD-ADDR)
  (LIST
   (LINK-TABLE-FOR-SEGMENT (I-PROG-SEGMENT I)
                           (PLUS LOAD-ADDR
                                 (SEGMENT-LENGTH (I-USR-DATA-SEGMENT I))))
   (LINK-TABLE-FOR-PROG-LABELS (I-PROG-SEGMENT I)
                               (PLUS LOAD-ADDR
                                     (SEGMENT-LENGTH (I-USR-DATA-SEGMENT I))))
   (LINK-TABLE-FOR-SEGMENT (I-USR-DATA-SEGMENT I)
                           LOAD-ADDR)
   (LINK-TABLE-FOR-SEGMENT (I-SYS-DATA-SEGMENT I)
                           (PLUS LOAD-ADDR
                                 (SEGMENT-LENGTH (I-PROG-SEGMENT I))
                                 (SEGMENT-LENGTH (I-USR-DATA-SEGMENT I))))))

(DEFN PROG-LINKS
      (LINK-TABLES)
      (CAR LINK-TABLES))

(DEFN PROG-LABEL-TABLES
      (LINK-TABLES)
      (CADR LINK-TABLES))

(DEFN USR-DATA-LINKS
      (LINK-TABLES)
      (CADDR LINK-TABLES))

(DEFN SYS-DATA-LINKS
      (LINK-TABLES)
      (CADDDR LINK-TABLES))

(DEFN LABEL-LINKS
      (LABEL PROG-LABEL-TABLES)
      (CDR (ASSOC (ADP-NAME LABEL)
                  PROG-LABEL-TABLES)))

(DEFN BASE-ADDRESS
      (NAME LINK-TABLE)
      (CDR (ASSOC NAME LINK-TABLE)))

(DEFN FIND-CONTAINING-AREA-NAME
      (N LINK-TABLE)
      (COND ((NLISTP LINK-TABLE) 0)
            ((NLISTP (CDR LINK-TABLE))
             (CAAR LINK-TABLE))
            ((AND (NOT (LESSP N (CDAR LINK-TABLE)))
                  (LESSP N (CDADR LINK-TABLE)))
             (CAAR LINK-TABLE))
            (T (FIND-CONTAINING-AREA-NAME N
                                          (CDR LINK-TABLE)))))

(DEFN INVERT-BASE-ADDRESS
      (N LINK-TABLE)
      (FIND-CONTAINING-AREA-NAME N LINK-TABLE))

(DEFN LABEL-ADDRESS
      (LABEL PROG-LABEL-TABLES)
      (BASE-ADDRESS LABEL
                    (LABEL-LINKS LABEL PROG-LABEL-TABLES)))

(DEFN ASSOC-CDRP
      (N ALIST)
      (COND ((NLISTP ALIST) F)
            ((EQUAL N (CDAR ALIST)) T)
            (T (ASSOC-CDRP N (CDR ALIST)))))

(DEFN FIND-CONTAINING-LABEL-TABLE
      (N LABEL-TABLES)
      (COND ((NLISTP LABEL-TABLES) F)
            ((ASSOC-CDRP N (CDAR LABEL-TABLES))
             (CDAR LABEL-TABLES))
            (T (FIND-CONTAINING-LABEL-TABLE N
                                            (CDR LABEL-TABLES)))))

(DEFN INVERT-LABEL-ADDRESS
      (N PROG-LABEL-TABLES)
      (INVERT-BASE-ADDRESS N
                           (FIND-CONTAINING-LABEL-TABLE N PROG-LABEL-TABLES)))

(DEFN ABSOLUTE-ADDRESS
      (ADP LINK-TABLE)
      (PLUS (BASE-ADDRESS (ADP-NAME ADP)
                          LINK-TABLE)
            (ADP-OFFSET ADP)))

(DEFN INVERT-ABSOLUTE-ADDRESS
      (N LINK-TABLE)
      (CONS (FIND-CONTAINING-AREA-NAME N LINK-TABLE)
            (DIFFERENCE N
                        (BASE-ADDRESS (FIND-CONTAINING-AREA-NAME N LINK-TABLE)
                                      LINK-TABLE))))

(DEFN BITV-TO-V (LST WORD-SIZE)
  (IF (ZEROP WORD-SIZE)
      NIL
      (APPEND (BITV-TO-V (CDR LST)
                         (SUB1 WORD-SIZE))
              (LIST (IF (EQUAL (CAR LST) 0) F T)))))

(DEFN V-TO-BITV (V)
      (IF (NLISTP V)
          NIL
          (APPEND (V-TO-BITV (CDR V))
                  (LIST (IF (CAR V) 1 0)))))

(DEFN BOOL-TO-V
      (B WORD-SIZE)
      (IF (EQUAL B 'F)
          (NAT-TO-V 0 WORD-SIZE)
          (NAT-TO-V 1 WORD-SIZE)))

(DEFN V-TO-BOOL (V)
  (IF (CAR V) 'T 'F))

(DEFN ADDR-TO-V
      (ADP USR-DATA-LINKS WORD-SIZE)
      (NAT-TO-V (ABSOLUTE-ADDRESS ADP USR-DATA-LINKS)
                 WORD-SIZE))

(DEFN V-TO-ADDR
      (V USR-DATA-LINKS)
      (INVERT-ABSOLUTE-ADDRESS (V-TO-NAT V)
                               USR-DATA-LINKS))

(DEFN SUBR-TO-V
      (SUBR PROG-LINKS WORD-SIZE)
      (NAT-TO-V (BASE-ADDRESS SUBR PROG-LINKS)
                 WORD-SIZE))

(DEFN V-TO-SUBR
      (V PROG-LINKS)
      (INVERT-BASE-ADDRESS (V-TO-NAT V)
                           PROG-LINKS))

(DEFN SYS-ADDR-TO-V
      (ADP SYS-DATA-LINKS WORD-SIZE)
      (NAT-TO-V (ABSOLUTE-ADDRESS ADP SYS-DATA-LINKS)
                 WORD-SIZE))

(DEFN V-TO-SYS-ADDR
      (V SYS-DATA-LINKS)
      (INVERT-ABSOLUTE-ADDRESS (V-TO-NAT V)
                               SYS-DATA-LINKS))

(DEFN LABEL-TO-V
      (ILAB PROG-LABEL-TABLES WORD-SIZE)
      (NAT-TO-V (LABEL-ADDRESS ILAB PROG-LABEL-TABLES)
                 WORD-SIZE))

(DEFN V-TO-LABEL
      (V PROG-LABEL-TABLES)
      (INVERT-LABEL-ADDRESS (V-TO-NAT V)
                            PROG-LABEL-TABLES))

(DEFN IPC-TO-V
      (PCPP PROG-LINKS WORD-SIZE)
      (NAT-TO-V (ABSOLUTE-ADDRESS PCPP PROG-LINKS)
                 WORD-SIZE))

(DEFN LINK-DATA-WORD
      (X LINK-TABLES WORD-SIZE)
      (CASE (TYPE X)
            (NAT (NAT-TO-V (UNTAG X) WORD-SIZE))
            (INT (INT-TO-V (UNTAG X) WORD-SIZE))
            (BITV (BITV-TO-V (UNTAG X) WORD-SIZE))
            (BOOL (BOOL-TO-V (UNTAG X) WORD-SIZE))
            (ADDR (ADDR-TO-V (UNTAG X)
                              (USR-DATA-LINKS LINK-TABLES)
                              WORD-SIZE))
            (SUBR (SUBR-TO-V (UNTAG X)
                              (PROG-LINKS LINK-TABLES)
                              WORD-SIZE))
            (SYS-ADDR (SYS-ADDR-TO-V (UNTAG X)
                                      (SYS-DATA-LINKS LINK-TABLES)
                                      WORD-SIZE))
            (PC (LABEL-TO-V (UNTAG X)
                             (PROG-LABEL-TABLES LINK-TABLES)
                             WORD-SIZE))
            (IPC (IPC-TO-V (UNTAG X)
                            (PROG-LINKS LINK-TABLES)
                            WORD-SIZE))
            (OTHERWISE (NAT-TO-V 0 WORD-SIZE))))

(DEFN UNLINK-DATA-WORD
      (TYPE V LINK-TABLES)
      (CASE TYPE
            (NAT (TAG 'NAT (V-TO-NAT V)))
            (INT (TAG 'INT (V-TO-INT V)))
            (BITV (TAG 'BITV (V-TO-BITV V)))
            (BOOL (TAG 'BOOL (V-TO-BOOL V)))
            (ADDR (TAG 'ADDR
                       (V-TO-ADDR V
                                   (USR-DATA-LINKS LINK-TABLES))))
            (SUBR (TAG 'SUBR
                       (V-TO-SUBR V
                                   (PROG-LINKS LINK-TABLES))))
            (SYS-ADDR (TAG 'SYS-ADDR
                           (V-TO-SYS-ADDR V
                                           (SYS-DATA-LINKS LINK-TABLES))))
            (PC (TAG 'PC
                     (V-TO-LABEL V
                                  (PROG-LABEL-TABLES LINK-TABLES))))
            (OTHERWISE '(UNRECOGNIZED I-LEVEL TYPE))))

(DEFN LINK-INSTRUCTION-ALIST
      NIL
      '((ADD_<C>_X_X{N} (ADD (C) X X))
        (ADD_<TSP>_<TSP>{V} (ADD NIL (TSP) (TSP)))
        (ADD_<TSP>_<TSP>{N} (ADD NIL (TSP) (TSP)))
        (ADD_<TSP>{A}_X{N} (ADD NIL (TSP) X))
        (ADD_TSP_*{N} (ADD NIL TSP (PC 1)))
        (ADD_TSP_X{N} (ADD NIL TSP X))
        (ADD_<TSP>{I}_X{I} (ADD NIL (TSP) X))
        (ADD_<TSP>{N}_X{N} (ADD NIL (TSP) X))
        (ADD_PC_X{N} (ADD NIL PC X))
        (ADD_X_X{N} (ADD NIL X X))
        (ADD_X{N}_CSP (ADD NIL X CSP))
        (ADDC_<C>_X{N}_Y{N} (ADDC (C) X Y))
        (ADDC_<V>_X{I}_Y{I} (ADDC (V) X Y))
        (AND_<TSP>{V}_X{V} (AND NIL (TSP) X))
        (AND_<TSP>{B}_X{B} (AND NIL (TSP) X))
        (ASR_<C>_<TSP>_<TSP>{B} (ASR (C) (TSP) (TSP)))
        (CPOP_CFP (MOVE NIL CFP (CSP 1)))
        (CPOP_PC (MOVE NIL PC (CSP 1)))
        (CPUSH_* (MOVE NIL (-1 CSP) (PC 1)))
        (CPUSH_<TSP>+ (MOVE NIL (-1 CSP) (TSP 1)))
        (CPUSH_CFP (MOVE NIL (-1 CSP) CFP))
        (DECR_<TSP>_<TSP>{I} (DECR NIL (TSP) (TSP)))
        (DECR_<TSP>_<TSP>{N} (DECR NIL (TSP) (TSP)))
        (INCR_<TSP>_<TSP>{I} (INCR NIL (TSP) (TSP)))
        (INCR_<TSP>_<TSP>{N} (INCR NIL (TSP) (TSP)))
        (INCR_Y_Y{N} (INCR NIL Y Y))
        (INT-TO-NAT (MOVE NIL X X))
        (JUMP-N_X (MOVE-N NIL PC X))
        (JUMP-NN_X (MOVE-NN NIL PC X))
        (JUMP-NZ_X (MOVE-NZ NIL PC X))
        (JUMP-Z_X (MOVE-Z NIL PC X))
        (JUMP_* (MOVE NIL PC (PC)))
        (JUMP_X{SUBR} (MOVE NIL PC X))
        (LSR_<C>_X_X{N} (LSR (C) X X))
        (LSR_<TSP>_<TSP>{V} (LSR NIL (TSP) (TSP)))
        (MOVE-C_<TSP>_* (MOVE-C NIL (TSP) (PC 1)))
        (MOVE-V_<TSP>_* (MOVE-V NIL (TSP) (PC 1)))
        (MOVE-Z_<TSP>_* (MOVE-Z NIL (TSP) (PC 1)))
        (MOVE-N_X_* (MOVE-N NIL X (PC 1)))
        (MOVE_<TSP>_* (MOVE NIL (TSP) (PC 1)))
        (MOVE_<X{A}>_<TSP> (MOVE NIL (X) (TSP)))
        (MOVE_<X{S}>_<TSP> (MOVE NIL (X) (TSP)))
        (MOVE_CFP_CSP (MOVE NIL CFP CSP))
        (MOVE_CSP_CFP (MOVE NIL CSP CFP))
        (MOVE_X_* (MOVE NIL X (PC 1)))
        (MOVE_X_<X{S}> (MOVE NIL X (X)))
        (MOVE_X_TSP (MOVE NIL X TSP))
        (MOVE_X_X (MOVE NIL X X))
        (MOVE_Y_* (MOVE NIL Y (PC 1)))
        (MOVE_Y_<Y{S}> (MOVE NIL Y (Y)))
        (MOVE_Y_TSP (MOVE NIL Y TSP))
        (NEG_<TSP>_<TSP>{I} (NEG NIL (TSP) (TSP)))
        (NOT_<TSP>_<TSP>{V} (NOT NIL (TSP) (TSP)))
        (OR_<TSP>{V}_X{V} (OR NIL (TSP) X))
        (OR_<TSP>{B}_X{B} (OR NIL (TSP) X))
        (SUB_<C>_<TSP>{A}_X{A} (SUB (C) (TSP) X))
        (SUB_<C>_<TSP>{N}_X{N} (SUB (C) (TSP) X))
        (SUB_<NV>_<TSP>{I}_X{I} (SUB (N V) (TSP) X))
        (SUB_<TSP>{A}_X{N} (SUB NIL (TSP) X))
        (SUB_X{S}_Y{N} (SUB NIL X Y))
        (SUB_<TSP>{I}_X{I} (SUB NIL (TSP) X))
        (SUB_<TSP>{N}_X{N} (SUB NIL (TSP) X))
        (SUB_<TSP>{S}_X{S} (SUB NIL (TSP) X))
        (SUB_<Z>_X{S}_Y{S} (SUB (Z) X Y))
        (SUBB_<C>_X{N}_Y{N} (SUBB (C) X Y))
        (SUBB_<V>_X{I}_Y{I} (SUBB (V) X Y))
        (TPOP_<C>_X (MOVE (C) X (TSP 1)))
        (TPOP_<X{A}> (MOVE NIL (X) (TSP 1)))
        (TPOP_<X{S}> (MOVE NIL (X) (TSP 1)))
        (TPOP_PC (MOVE NIL PC (TSP 1)))
        (TPOP_X (MOVE NIL X (TSP 1)))
        (TPOP_Y (MOVE NIL Y (TSP 1)))
        (TPOP{V}_<Z>_Y (MOVE (Z) Y (TSP 1)))
        (TPOP{B}_<Z>_Y (MOVE (Z) Y (TSP 1)))
        (TPOP{I}_<ZN>_Y (MOVE (Z N) Y (TSP 1)))
        (TPOP{N}_<Z>_Y (MOVE (Z) Y (TSP 1)))
        (TPUSH_* (MOVE NIL (-1 TSP) (PC 1)))
        (TPUSH_<X{A}> (MOVE NIL (-1 TSP) (X)))
        (TPUSH_<X{S}> (MOVE NIL (-1 TSP) (X)))
        (TPUSH_CSP (MOVE NIL (-1 TSP) CSP))
        (TPUSH_TSP (MOVE NIL (-1 TSP) TSP))
        (TPUSH_X (MOVE NIL (-1 TSP) X))
        (XOR_<TSP>_<TSP> (XOR NIL (TSP) (TSP)))
        (XOR_<TSP>{V}_X{V} (XOR NIL (TSP) X))
        (XOR_<TSP>{B}_*{B} (XOR NIL (TSP) (PC 1)))
        (XOR_<TSP>{B}_X{B} (XOR NIL (TSP) X))
        (XOR_<Z>_<TSP>_X (XOR (Z) (TSP) X))))

(DEFN PACK-INSTRUCTION
      (OP MOVE-BITS CVNZ MODE-B REG-B MODE-A REG-A WORD-SIZE)
      (NAT-TO-V (PLUS (TIMES OP (EXP 2 24))
                      (TIMES MOVE-BITS (EXP 2 20))
                      (TIMES CVNZ (EXP 2 16))
                      (TIMES MODE-B (EXP 2 14))
                      (TIMES REG-B (EXP 2 10))
;                     (TIMES 0000 (EXP 2 6))
                      (TIMES MODE-A (EXP 2 4))
                      REG-A)
                 WORD-SIZE))

(DEFN EXTRACT-OP
      (OPCODE)
      (CADR (ASSOC OPCODE
                   '((INCR 1)
                     (ADDC 2)
                     (ADD 3)
                     (NEG 4)
                     (DECR 5)
                     (SUBB 6)
                     (SUB 7)
                     (ROR 8)
                     (ASR 9)
                     (LSR 10)
                     (XOR 11)
                     (OR 12)
                     (AND 13)
                     (NOT 14)
                     (MOVE 15)
                     (MOVE-NC 15)
                     (MOVE-C 15)
                     (MOVE-NV 15)
                     (MOVE-V 15)
                     (MOVE-NZ 15)
                     (MOVE-Z 15)
                     (MOVE-NN 15)
                     (MOVE-N 15)))))

(DEFN EXTRACT-MOVE-BITS (OPCODE)
  (CASE OPCODE
        (MOVE 14)
        (MOVE-NC 0)
        (MOVE-C 1)
        (MOVE-NV 2)
        (MOVE-V 3)
        (MOVE-NZ 6)
        (MOVE-Z 7)
        (MOVE-NN 4)
        (MOVE-N 5)
        (OTHERWISE 14)))

(DEFN EXTRACT-MODE
      (REG-SPEC)
      (COND ((LITATOM REG-SPEC) 0)
            ((EQUAL (CDR REG-SPEC) NIL) 1)
            ((EQUAL (CAR REG-SPEC) -1) 2)
            (T 3)))

(DEFN EXTRACT-CVNZ
      (FLG-NAMES)
      (PLUS (TIMES (IF (MEMBER 'C FLG-NAMES) 1 0)
                   (EXP 2 3))
            (TIMES (IF (MEMBER 'V FLG-NAMES) 1 0)
                   (EXP 2 2))
            (TIMES (IF (MEMBER 'N FLG-NAMES) 1 0)
                   (EXP 2 1))
            (TIMES (IF (MEMBER 'Z FLG-NAMES) 1 0)
                   (EXP 2 0))))

(DEFN EXTRACT-REG1
      (REG-SPEC)
      (COND ((LITATOM REG-SPEC) REG-SPEC)
            ((EQUAL (CDR REG-SPEC) NIL)
             (CAR REG-SPEC))
            ((EQUAL (CAR REG-SPEC) -1)
             (CADR REG-SPEC))
            (T (CAR REG-SPEC))))

(DEFN EXTRACT-REG
      (REG-SPEC)
      (CADR (ASSOC (EXTRACT-REG1 REG-SPEC)
                   '((PC 15)
                     (CFP 1)
                     (CSP 2)
                     (TSP 3)
                     (X 4)
                     (Y 5)))))

(DEFN MCI
      (INS WORD-SIZE)
      (PACK-INSTRUCTION (EXTRACT-OP (CAR INS))
                        (EXTRACT-MOVE-BITS (CAR INS))
                        (EXTRACT-CVNZ (CADR INS))
                        (EXTRACT-MODE (CADDR INS))
                        (EXTRACT-REG (CADDR INS))
                        (EXTRACT-MODE (CADDDR INS))
                        (EXTRACT-REG (CADDDR INS))
                        WORD-SIZE))

(DEFN ICODE-INSTRUCTIONP
      (INS)
      (EQUAL (CDR INS) NIL))

(DEFN LINK-INSTR-WORD
      (INS WORD-SIZE)
      (MCI (CADR (ASSOC (CAR INS)
                        (LINK-INSTRUCTION-ALIST)))
           WORD-SIZE))

(DEFN LINK-WORD
      (X LINK-TABLES WORD-SIZE)
      (IF (ICODE-INSTRUCTIONP X)
          (LINK-INSTR-WORD X WORD-SIZE)
          (LINK-DATA-WORD X LINK-TABLES WORD-SIZE)))

(DEFN LINK-AREA
      (LST LINK-TABLES WORD-SIZE)
      (IF (NLISTP LST)
          NIL
          (CONS (LINK-WORD (UNLABEL (CAR LST))
                           LINK-TABLES WORD-SIZE)
                (LINK-AREA (CDR LST)
                           LINK-TABLES WORD-SIZE))))

(DEFN LINK-SEGMENT
      (SEGMENT LINK-TABLES WORD-SIZE)
      (IF (NLISTP SEGMENT)
          NIL
          (APPEND (LINK-AREA (CDAR SEGMENT)
                             LINK-TABLES WORD-SIZE)
                  (LINK-SEGMENT (CDR SEGMENT)
                                LINK-TABLES WORD-SIZE))))

(defn boot-code (lst n word-size)
  (if (zerop n)
      nil
      (cons (nat-to-v (car lst) word-size)
            (boot-code (cdr lst) (sub1 n) word-size))))

(DEFN LINK-MEM (boot-lst LOAD-ADDR USR-DATA-SEGMENT PROG-SEGMENT SYS-DATA-SEGMENT
                         LINK-TABLES WORD-SIZE)
  (append
   (boot-code boot-lst load-addr word-size)
   (APPEND (LINK-SEGMENT USR-DATA-SEGMENT LINK-TABLES WORD-SIZE)
           (APPEND (LINK-SEGMENT PROG-SEGMENT LINK-TABLES WORD-SIZE)
                   (LINK-SEGMENT SYS-DATA-SEGMENT LINK-TABLES WORD-SIZE)))))

(DEFN BOOL-TO-LOGICAL
      (B)
      (IF (EQUAL B 'F) F T))

(DEFN I->M (I BOOT-LST LOAD-ADDR)
  (LET ((TABLES (I-LINK-TABLES I LOAD-ADDR))
        (W (I-WORD-SIZE I)))
  (M-STATE (LIST (LINK-WORD '(NAT 0) TABLES W)
                 (LINK-WORD (I-CFP I) TABLES W)
                 (LINK-WORD (I-CSP I) TABLES W)
                 (LINK-WORD (I-TSP I) TABLES W)
                 (LINK-WORD (I-X I) TABLES W)
                 (LINK-WORD (I-Y I) TABLES W)
                 (LINK-WORD '(NAT 0) TABLES W)
                 (LINK-WORD '(NAT 0) TABLES W)
                 (LINK-WORD '(NAT 0) TABLES W)
                 (LINK-WORD '(NAT 0) TABLES W)
                 (LINK-WORD '(NAT 0) TABLES W)
                 (LINK-WORD '(NAT 0) TABLES W)
                 (LINK-WORD '(NAT 0) TABLES W)
                 (LINK-WORD '(NAT 0) TABLES W)
                 (LINK-WORD '(NAT 0) TABLES W)
                 (LINK-WORD (I-PC I) TABLES W))
           (BOOL-TO-LOGICAL (UNTAG (I-C-FLG I)))
           (BOOL-TO-LOGICAL (UNTAG (I-V-FLG I)))
           (BOOL-TO-LOGICAL (UNTAG (I-N-FLG I)))
           (BOOL-TO-LOGICAL (UNTAG (I-Z-FLG I)))
           (LINK-MEM BOOT-LST
                     LOAD-ADDR
                     (I-USR-DATA-SEGMENT I)
                     (I-PROG-SEGMENT I)
                     (I-SYS-DATA-SEGMENT I)
                     TABLES
                     W))))

(PROVE-LEMMA MY-LESSP-QUOTIENT (REWRITE)
             (IMPLIES (AND (NUMBERP SIZE)
                           (NOT (EQUAL SIZE 0)))
                      (LESSP (QUOTIENT SIZE 2) SIZE)))

(DEFN RAM-TREE (LST SIZE)
  (COND ((ZEROP SIZE) (STUB (NAT-TO-V 0 32)))   ; never happens
        ((NLISTP LST) (STUB (NAT-TO-V 0 32)))
        ((EQUAL SIZE 1) (RAM (CAR LST)))
        (T (CONS (RAM-TREE (FIRSTN (QUOTIENT SIZE 2) LST) (QUOTIENT SIZE 2))
                 (RAM-TREE (RESTN (QUOTIENT SIZE 2) LST)  (QUOTIENT SIZE 2)))))
  ((LESSP (COUNT SIZE))))

(DEFN FM-STATE (REGS C V N Z MEM)
  (LIST (LIST (RAM-TREE REGS 16)
              (LIST Z N V C))
        (RAM-TREE MEM (EXP 2 32))))

(DEFN M->FM9001 (M)
  (LIST (LIST (RAM-TREE (M-REGS M) 16)
              (LIST (M-Z-FLG M)
                    (M-N-FLG M)
                    (M-V-FLG M)
                    (M-C-FLG M)))
        (RAM-TREE (M-MEM M) (EXP 2 32))))

(DEFN LOAD (P boot-lst LOAD-ADDR) (M->FM9001 (I->M (R->I (P->R P)) boot-lst LOAD-ADDR)))

(DEFN LINK-TABLES (P LOAD-ADDR)
      (I-LINK-TABLES (R->I (P->R P)) LOAD-ADDR))

(DEFN TYPE-LST
      (LST)
      (IF (NLISTP LST)
          NIL
          (CONS (TYPE (CAR LST))
                (TYPE-LST (CDR LST)))))

(DEFN AREA-TYPE-SPECIFICATION
      (AREA)
      (CONS (CAR AREA)
            (TYPE-LST (CDR AREA))))

(DEFN TYPE-SPECIFICATION
      (SEGMENT)
      (IF (NLISTP SEGMENT)
          NIL
          (CONS (AREA-TYPE-SPECIFICATION (CAR SEGMENT))
                (TYPE-SPECIFICATION (CDR SEGMENT)))))

(DEFN DISPLAY-FM9001-ARRAY (TYPE-LST N FM-MEM LINK-TABLES)
  (IF (NLISTP TYPE-LST)
      NIL
      (CONS (UNLINK-DATA-WORD (CAR TYPE-LST)
                              (READ-MEM (NAT-TO-V N 32) FM-MEM)
                              LINK-TABLES)
            (DISPLAY-FM9001-ARRAY (CDR TYPE-LST)
                                  (ADD1 N)
                                  FM-MEM LINK-TABLES))))

(DEFN DISPLAY-FM9001-DATA-AREA (AREA-TYPE-SPEC FM-MEM LINK-TABLES)
  (CONS (CAR AREA-TYPE-SPEC)
        (DISPLAY-FM9001-ARRAY (CDR AREA-TYPE-SPEC)
                              (BASE-ADDRESS (CAR AREA-TYPE-SPEC)
                                            (USR-DATA-LINKS LINK-TABLES))
                              FM-MEM LINK-TABLES)))

(DEFN DISPLAY-FM9001-DATA-SEGMENT1 (TYPE-SPEC FM-MEM LINK-TABLES)
  (IF (NLISTP TYPE-SPEC)
      NIL
      (CONS (DISPLAY-FM9001-DATA-AREA (CAR TYPE-SPEC) FM-MEM LINK-TABLES)
            (DISPLAY-FM9001-DATA-SEGMENT1 (CDR TYPE-SPEC) FM-MEM LINK-TABLES))))

(DEFN DISPLAY-FM9001-DATA-SEGMENT (FM-STATE TYPE-SPEC LINK-TABLES)
      (DISPLAY-FM9001-DATA-SEGMENT1 TYPE-SPEC
                                    (CADR FM-STATE)
                                    LINK-TABLES))

; Book:  m.events.  Now we define the m machine.

(DEFN V-NTH1 (V-N LST)
  (IF (LESSP (V-TO-NAT V-N) (LENGTH LST))
      (NTH (V-TO-NAT V-N) LST)
      (NAT-TO-V 0 32)))

(DEFN CURRENT-INSTRUCTION (REGS MEM)
  (V-NTH1 (V-NTH1 (NAT-TO-V 15 4) REGS) MEM))

(DEFN M-STORE-RESULTP (STORE-CC C V N Z)
  (CASE STORE-CC
        ((*1*FALSE *1*FALSE *1*FALSE *1*FALSE)
         (NOT C))
        ((*1*TRUE *1*FALSE *1*FALSE *1*FALSE)
         C)
        ((*1*FALSE *1*TRUE *1*FALSE *1*FALSE)
         (NOT V))
        ((*1*TRUE *1*TRUE *1*FALSE *1*FALSE)
         V)
        ((*1*FALSE *1*FALSE *1*TRUE *1*FALSE)
         (NOT N))
        ((*1*TRUE *1*FALSE *1*TRUE *1*FALSE)
         N)
        ((*1*FALSE *1*TRUE *1*TRUE *1*FALSE)
         (NOT Z))
        ((*1*TRUE *1*TRUE *1*TRUE *1*FALSE)
         Z)
        ((*1*FALSE *1*FALSE *1*FALSE *1*TRUE)
         (AND (NOT C)
              (NOT Z)))
        ((*1*TRUE *1*FALSE *1*FALSE *1*TRUE)
         (OR C Z))
        ((*1*FALSE *1*TRUE *1*FALSE *1*TRUE)
         (OR (AND N V)
             (AND (NOT N)
                  (NOT V))))
        ((*1*TRUE *1*TRUE *1*FALSE *1*TRUE)
         (OR (AND N
                  (NOT V))
             (AND (NOT N)
                  V)))
        ((*1*FALSE *1*FALSE *1*TRUE *1*TRUE)
         (OR (AND N
                  V
                  (NOT Z))
             (AND (NOT N)
                  (NOT V)
                  (NOT Z))))
        ((*1*TRUE *1*FALSE *1*TRUE *1*TRUE)
         (OR Z
             (AND N
                  (NOT V))
             (AND (NOT N)
                  V)))
        ((*1*FALSE *1*TRUE *1*TRUE *1*TRUE) T)
        (OTHERWISE F)))

(PROVE-LEMMA M-STORE-RESULTP-IS-STORE-RESULTP (REWRITE)
  (EQUAL (M-STORE-RESULTP STORE-CC C V N Z)
         (STORE-RESULTP STORE-CC (LIST Z N V C))))

(DISABLE M-STORE-RESULTP)
(DISABLE STORE-RESULTP)

(DEFN M-ALU-OPERATION (REGS C V N Z MEM INS OPERAND-A OPERAND-B B-ADDRESS)
  (M-STATE (IF (AND (M-STORE-RESULTP (STORE-CC INS) C V N Z)
                      (REG-DIRECT-P (MODE-B INS)))
                (UPDATE-V-NTH (RN-B INS)
                              REGS
                              (BV (V-ALU C
                                         OPERAND-A OPERAND-B
                                         (OP-CODE INS))))
                REGS)
           (B-IF (C-SET (SET-FLAGS INS))
                 (C (V-ALU C
                           OPERAND-A OPERAND-B
                           (OP-CODE INS)))
                 C)
           (B-IF (V-SET (SET-FLAGS INS))
                 (V (V-ALU C
                           OPERAND-A OPERAND-B
                           (OP-CODE INS)))
                 V)
           (B-IF (N-SET (SET-FLAGS INS))
                 (N (V-ALU C
                           OPERAND-A OPERAND-B
                           (OP-CODE INS)))
                 N)
           (B-IF (Z-SET (SET-FLAGS INS))
                 (ZB (V-ALU C
                            OPERAND-A OPERAND-B
                            (OP-CODE INS)))
                 Z)
           (IF (AND (M-STORE-RESULTP (STORE-CC INS) C V N Z)
                      (NOT (REG-DIRECT-P (MODE-B INS))))
                (UPDATE-V-NTH B-ADDRESS MEM
                              (BV (V-ALU C
                                         OPERAND-A OPERAND-B
                                         (OP-CODE INS))))
                MEM)))

(DEFN READ-MEM1-RAM-TREE-HINT (RADDR LST)
  (COND ((NLISTP RADDR) T)
        ((CAR RADDR)
         (READ-MEM1-RAM-TREE-HINT (CDR RADDR)
                                  (RESTN (EXP 2 (LENGTH (CDR RADDR))) LST)))
        (T (READ-MEM1-RAM-TREE-HINT (CDR RADDR)
                                    (FIRSTN (EXP 2 (LENGTH (CDR RADDR))) LST)))))

(DEFN REV (X)
  (IF (NLISTP X)
      NIL
      (APPEND (REV (CDR X)) (LIST (CAR X)))))

(ENABLE APPEND)

(PROVE-LEMMA REV1-IS-REV (REWRITE)
  (EQUAL (REV1 X A) (APPEND (REV X) A)))

(PROVE-LEMMA APPEND-NIL (REWRITE)
  (IMPLIES (PROPERP X) (EQUAL (APPEND X NIL) X)))

(PROVE-LEMMA PROPERP-REV (REWRITE) (PROPERP (REV X)))

(PROVE-LEMMA READ-MEM1-REV-RAM-TREE-LEMMA1 (REWRITE)
  (IMPLIES (STUBP (RAM-TREE LST N))
           (EQUAL (STUB-GUTS (RAM-TREE LST N)) (NAT-TO-V 0 32))))

(ENABLE PLUS-0)
(ENABLE PLUS-ADD1-SUB1)
(ENABLE PLUS-ADD1)
(enable ASSOCIATIVITY-OF-PLUS)
(enable commutativity-of-plus)
(ENABLE TIMES-COMMUTES)
(ENABLE TIMES-ADD1-AGAIN)
(ENABLE TIMES-1)
(enable times-distributes-over-plus)
(enable ASSOCIATIVITY-OF-TIMES)


(PROVE-LEMMA MY-V-TO-NAT-APPEND (REWRITE)
  (EQUAL (V-TO-NAT (APPEND A B))
         (PLUS (V-TO-NAT A) (TIMES (EXP 2 (LENGTH A)) (V-TO-NAT B)))))

(ENABLE PLUS)

(ENABLE DIFFERENCE)

(PROVE-LEMMA DIFFERENCE-ADD1-ADD1-X-2 (REWRITE)
  (EQUAL (DIFFERENCE (ADD1 (ADD1 X)) 2) (FIX X)))

(enable QUOTIENT-PLUS-X-X-2)

(ENABLE LENGTH-FIRSTN)

(ENABLE LENGTH-RESTN)

(PROVE-LEMMA my-LESSP-V-TO-NAT-EXP (REWRITE)
  (IMPLIES (EQUAL N (LENGTH V))
           (LESSP (V-TO-NAT V) (EXP 2 N))))

(PROVE-LEMMA LENGTH-REV (REWRITE) (EQUAL (LENGTH (REV X)) (LENGTH X)))

(PROVE-LEMMA NTH-FIRSTN (REWRITE)
  (IMPLIES (LESSP I N)
           (EQUAL (NTH I (FIRSTN N LST)) (NTH I LST))))

(PROVE-LEMMA LESSP-DIFFERENCE (REWRITE)
  (EQUAL (LESSP V (DIFFERENCE L E))
         (IF (LESSP E L)
             (LESSP (PLUS E V) L)
             F)))

(PROVE-LEMMA NTH-RESTN-PLUS (REWRITE)
  (IMPLIES (LESSP I (LENGTH LST))
           (EQUAL (NTH N
                       (RESTN I LST))
                  (NTH (PLUS I N)
                       LST))))

(PROVE-LEMMA READ-MEM1-REV-RAM-TREE NIL
  (IMPLIES (NOT (LESSP (EXP 2 (LENGTH RADDR)) (LENGTH LST)))
           (EQUAL (V-NTH1 (REV RADDR) LST)
                  (READ-MEM1 RADDR (RAM-TREE LST (EXP 2 (LENGTH RADDR))))))
  ((INDUCT (READ-MEM1-RAM-TREE-HINT RADDR LST))))

(PROVE-LEMMA REV-APPEND (REWRITE)
  (EQUAL (REV (APPEND A B)) (APPEND (REV B) (REV A))))

(PROVE-LEMMA V-TO-NAT-REV-REV (REWRITE)
  (EQUAL (V-TO-NAT (REV (REV ADDR))) (V-TO-NAT ADDR)))

(PROVE-LEMMA READ-MEM-RAM-TREE (REWRITE)
  (IMPLIES (AND (EQUAL E (EXP 2 (LENGTH ADDR)))
                (NOT (LESSP E (LENGTH LST))))
           (EQUAL (V-NTH1 ADDR LST)
                  (READ-MEM ADDR (RAM-TREE LST E))))
  ((USE (READ-MEM1-REV-RAM-TREE (RADDR (REV ADDR))))))

(DISABLE V-NTH1)
(DISABLE READ-MEM)

(PROVE-LEMMA RESTN-UPDATE-NTH-PLUS (REWRITE)
  (EQUAL (RESTN E (UPDATE-NTH (PLUS V E) L VAL))
         (UPDATE-NTH V (RESTN E L) VAL)))

(PROVE-LEMMA FIRSTN-UPDATE-NTH-PLUS (REWRITE)
  (EQUAL (FIRSTN E (UPDATE-NTH (PLUS V E) L VAL))
         (FIRSTN E L)))

(PROVE-LEMMA RESTN-UPDATE-NTH (REWRITE)
  (IMPLIES (LESSP V E)
           (EQUAL (RESTN E (UPDATE-NTH V L VAL))
                  (RESTN E L))))

(PROVE-LEMMA FIRSTN-UPDATE-NTH (REWRITE)
  (IMPLIES (LESSP V E)
           (EQUAL (FIRSTN E (UPDATE-NTH V L VAL))
                  (UPDATE-NTH V (FIRSTN E L) VAL))))

(PROVE-LEMMA WRITE-MEM1-REV-RAM-TREE NIL
  (IMPLIES (NOT (LESSP (EXP 2 (LENGTH RADDR)) (LENGTH LST)))
           (EQUAL (RAM-TREE (UPDATE-V-NTH (REV RADDR) LST VAL)
                            (EXP 2 (LENGTH RADDR)))
                  (WRITE-MEM1 RADDR (RAM-TREE LST (EXP 2 (LENGTH RADDR))) VAL)))
  ((INDUCT (READ-MEM1-RAM-TREE-HINT RADDR LST))))

(PROVE-LEMMA WRITE-MEM-RAM-TREE (REWRITE)
  (IMPLIES (AND (EQUAL E (EXP 2 (LENGTH ADDR)))
                (NOT (LESSP E (LENGTH LST))))
           (EQUAL (RAM-TREE (UPDATE-V-NTH ADDR LST VAL) E)
                  (WRITE-MEM ADDR (RAM-TREE LST E) VAL)))
  ((USE (WRITE-MEM1-REV-RAM-TREE (RADDR (REV ADDR))))))

(DISABLE UPDATE-V-NTH)
(DISABLE WRITE-MEM)

(PROVE-LEMMA LENGTH-RN-B (REWRITE)
  (EQUAL (LENGTH (RN-B INS)) 4)
  ((ENABLE LENGTH-SUBRANGE)))

(PROVE-LEMMA M-ALU-OPERATION-IS-FM9001-ALU-OPERATION (REWRITE)
   (IMPLIES (AND (EQUAL (LENGTH B-ADDRESS) 32)
                 (EQUAL (LENGTH REGS) 16)
                 (NOT (LESSP (EXP 2 32) (LENGTH MEM))))
            (EQUAL (M->FM9001
                    (M-ALU-OPERATION REGS C V N Z MEM
                                     INS OPERAND-A OPERAND-B B-ADDRESS))
                   (FM9001-ALU-OPERATION (RAM-TREE REGS 16)
                                         (LIST Z N V C)
                                         (RAM-TREE MEM (EXP 2 32))
                                         INS OPERAND-A OPERAND-B B-ADDRESS)))
   ((DISABLE REG-DIRECT-P STORE-CC MODE-B RN-B BV V-ALU OP-CODE C-SET
             V-SET N-SET Z-SET SET-FLAGS)))

(DEFN BVP-LISTP (LST)
  (IF (NLISTP LST)
      (EQUAL LST NIL)
      (AND (BVP (CAR LST))
           (EQUAL (LENGTH (CAR LST)) 32)
           (BVP-LISTP (CDR LST)))))

(DEFN PROPER-M-STATEP (M)
  (AND (M-STATEP M)
       (BVP-LISTP (M-REGS M))
       (BVP-LISTP (M-MEM M))
       (EQUAL (LENGTH (M-REGS M)) 16)
       (NOT (LESSP (EXP 2 32) (LENGTH (M-MEM M))))))

(PROVE-LEMMA LENGTH-NTH (REWRITE)
  (IMPLIES (AND (BVP-LISTP LST)
                (LESSP N (LENGTH LST)))
           (AND (BVP (NTH N LST))
                (EQUAL (LENGTH (NTH N LST)) 32))))

(PROVE-LEMMA LENGTH-V-NTH1 (REWRITE)
  (IMPLIES (BVP-LISTP LST)
           (AND (BVP (V-NTH1 ADDR LST))
                (EQUAL (LENGTH (V-NTH1 ADDR LST)) 32)))
  ((ENABLE V-NTH1)))

(PROVE-LEMMA LENGTH-READ-MEM (REWRITE)
  (IMPLIES (AND (BVP-LISTP LST)
                (EQUAL K (EXP 2 (LENGTH ADDR)))
                (NOT (LESSP K (LENGTH LST))))
           (AND (BVP (READ-MEM ADDR (RAM-TREE LST K)))
                (EQUAL (LENGTH (READ-MEM ADDR (RAM-TREE LST K))) 32)))
  ((ENABLE READ-MEM)
   (DISABLE READ-MEM-RAM-TREE)
   (USE (READ-MEM-RAM-TREE (E (EXP 2 (LENGTH ADDR)))))))

(PROVE-LEMMA BVP-LISTP-UPDATE-NTH (REWRITE)
  (IMPLIES (AND (BVP VAL)
                (EQUAL (LENGTH VAL) 32)
                (BVP-LISTP LST))
           (BVP-LISTP (UPDATE-NTH N LST VAL))))

(PROVE-LEMMA BVP-LISTP-UPDATE-V-NTH (REWRITE)
  (IMPLIES (AND (BVP VAL)
                (EQUAL (LENGTH VAL) 32)
                (BVP-LISTP LST))
           (BVP-LISTP (UPDATE-V-NTH ADDR LST VAL)))
  ((ENABLE UPDATE-V-NTH)))

(ENABLE BVP-BV-V-ALU)

(PROVE-LEMMA LENGTH-BV-V-ALU (REWRITE)
  (IMPLIES (AND (EQUAL (LENGTH A) (LENGTH B))
                (LISTP A))
           (EQUAL (LENGTH (BV (V-ALU C A B OP))) (LENGTH A)))
  ((DISABLE V-BUF V-NOT V-AND V-OR V-XOR V-LSR V-ASR V-ROR V-SUBTRACTER-OUTPUT
            V-ADDER-OUTPUT)
   (ENABLE LENGTH-V-BUF LENGTH-V-NOT LENGTH-V-AND LENGTH-V-OR LENGTH-V-XOR
           LENGTH-V-LSR LENGTH-V-ASR LENGTH-V-ROR LENGTH-OF-V-ADDER-OUTPUT
           LENGTH-OF-V-SUBTRACTER-OUTPUT LENGTH-NAT-TO-V)))

(PROVE-LEMMA LENGTH-UPDATE-NTH (REWRITE)
  (EQUAL (LENGTH (UPDATE-NTH I LST VAL)) (LENGTH LST)))

(PROVE-LEMMA LENGTH-UPDATE-V-NTH (REWRITE)
  (EQUAL (LENGTH (UPDATE-V-NTH V LST VAL)) (LENGTH LST))
  ((ENABLE UPDATE-V-NTH)))

(PROVE-LEMMA M-ALU-OPERATION-PRESERVES-HYPS (REWRITE)
  (IMPLIES
   (AND (BVP-LISTP MEM)
        (BVP-LISTP REGS)
        (BVP OPERAND-A)
        (EQUAL (LENGTH OPERAND-A) 32)
        (EQUAL (LENGTH OPERAND-B) 32)
        (LISTP OPERAND-A)
        (EQUAL (LENGTH B-ADDRESS) 32)
        (EQUAL (LENGTH REGS) 16)
        (NOT (LESSP (EXP 2 32) (LENGTH MEM))))
   (PROPER-M-STATEP (M-ALU-OPERATION REGS C V N Z MEM
                                     INS OPERAND-A OPERAND-B B-ADDRESS)))
  ((DISABLE REG-DIRECT-P STORE-CC MODE-B RN-B BV V-ALU OP-CODE C-SET
            V-SET N-SET Z-SET SET-FLAGS)))

(DISABLE M-ALU-OPERATION)
(DISABLE FM9001-ALU-OPERATION)

(DEFN M-OPERAND-B (REGS C V N Z MEM INS OPERAND-A)
  (M-ALU-OPERATION (IF (PRE-DEC-P (MODE-B INS))
                       (UPDATE-V-NTH (RN-B INS)
                                     REGS
                                     (V-DEC (V-NTH1 (RN-B INS) REGS)))
                       (IF (POST-INC-P (MODE-B INS))
                           (UPDATE-V-NTH (RN-B INS)
                                         REGS
                                         (V-INC (V-NTH1 (RN-B INS) REGS)))
                           REGS))
                   C V N Z MEM INS OPERAND-A
                   (IF (REG-DIRECT-P (MODE-B INS))
                       (V-NTH1 (RN-B INS) REGS)
                       (V-NTH1 (IF (PRE-DEC-P (MODE-B INS))
                                   (V-DEC (V-NTH1 (RN-B INS) REGS))
                                   (V-NTH1 (RN-B INS) REGS))
                               MEM))
                   (IF (PRE-DEC-P (MODE-B INS))
                       (V-DEC (V-NTH1 (RN-B INS) REGS))
                       (V-NTH1 (RN-B INS) REGS))))

(ENABLE LENGTH-V-NOT)

(PROVE-LEMMA LENGTH-V-ADDER (REWRITE)
  (EQUAL (LENGTH (V-ADDER C A B)) (ADD1 (LENGTH A))))

(ENABLE LENGTH-NAT-TO-V)

(PROVE-LEMMA LENGTH-V-DEC (REWRITE)
             (EQUAL (LENGTH (V-DEC V)) (LENGTH V)))

(PROVE-LEMMA M-OPERAND-B-IS-FM9001-OPERAND-B (REWRITE)
  (IMPLIES (AND (BVP-LISTP REGS)
                (EQUAL (LENGTH REGS) 16)
                (NOT (LESSP (EXP 2 32) (LENGTH MEM))))
           (EQUAL (M->FM9001 (M-OPERAND-B REGS C V N Z MEM INS OPERAND-A))
                  (FM9001-OPERAND-B (RAM-TREE REGS 16)
                                    (LIST Z N V C)
                                    (RAM-TREE MEM (EXP 2 32))
                                    INS OPERAND-A)))
  ((DISABLE M->FM9001 PRE-DEC-P MODE-B RN-B V-DEC POST-INC-P V-INC REG-DIRECT-P)))

(PROVE-LEMMA LENGTH-V-INC (REWRITE)
  (EQUAL (LENGTH (V-INC V)) (LENGTH V)))
  
(PROVE-LEMMA BVP-FIRSTN-V-ADDER (REWRITE)
  (IMPLIES (EQUAL N (LENGTH A))
           (BVP (FIRSTN N (V-ADDER C A B)))))

(PROVE-LEMMA BVP-V-DEC (REWRITE)
  (BVP (V-DEC V)))

(PROVE-LEMMA BVP-V-INC (REWRITE)
  (BVP (V-INC V)))

(PROVE-LEMMA BVP-LISTP-IF (REWRITE)
  (IMPLIES (AND (BVP-LISTP B)
                (BVP-LISTP C))
           (BVP-LISTP (IF A B C))))

(enable LENGTH-IF)

(PROVE-LEMMA LISTP-OPERAND-A NIL
  (IMPLIES (EQUAL (LENGTH OPERAND-A) 32)
           (LISTP OPERAND-A)))

(PROVE-LEMMA M-OPERAND-B-PRESERVES-HYPS (REWRITE)
  (IMPLIES
   (AND (BVP-LISTP REGS)
        (BVP-LISTP MEM)
        (BVP OPERAND-A)
        (EQUAL (LENGTH OPERAND-A) 32)
        (EQUAL (LENGTH REGS) 16)
        (NOT (LESSP (EXP 2 32) (LENGTH MEM))))
   (PROPER-M-STATEP (M-OPERAND-B REGS C V N Z MEM INS OPERAND-A)))
  ((USE (LISTP-OPERAND-A))
   (DISABLE M->FM9001 PRE-DEC-P MODE-B RN-B V-DEC POST-INC-P V-INC REG-DIRECT-P)))

(DISABLE M-OPERAND-B)
(DISABLE FM9001-OPERAND-B)

(DEFN M-OPERAND-A (REGS C V N Z MEM INS)
  (M-OPERAND-B
   (IF (A-IMMEDIATE-P INS)
       REGS
       (IF (PRE-DEC-P (MODE-A INS))
           (UPDATE-V-NTH (RN-A INS)
                         REGS
                         (V-DEC (V-NTH1 (RN-A INS) REGS)))
           (IF (POST-INC-P (MODE-A INS))
               (UPDATE-V-NTH (RN-A INS)
                             REGS
                             (V-INC (V-NTH1 (RN-A INS) REGS)))
               REGS)))
   C V N Z MEM INS
   (IF (A-IMMEDIATE-P INS)
       (SIGN-EXTEND (A-IMMEDIATE INS) 32)
       (IF (REG-DIRECT-P (MODE-A INS))
           (V-NTH1 (RN-A INS) REGS)
           (IF (PRE-DEC-P (MODE-A INS))
               (V-NTH1 (V-DEC (V-NTH1 (RN-A INS) REGS))
                       MEM)
               (V-NTH1 (V-NTH1 (RN-A INS) REGS)
                       MEM))))))

(PROVE-LEMMA LENGTH-RN-A (REWRITE)
  (EQUAL (LENGTH (RN-A INS)) 4)
  ((ENABLE LENGTH-SUBRANGE)))

(PROVE-LEMMA M-OPERAND-A-IS-FM9001-OPERAND-A (REWRITE)
  (IMPLIES
   (AND (BVP-LISTP REGS)
        (EQUAL (LENGTH REGS) 16)
        (NOT (LESSP (EXP 2 32) (LENGTH MEM))))
   (EQUAL (M->FM9001 (M-OPERAND-A REGS C V N Z MEM INS))
          (FM9001-OPERAND-A (RAM-TREE REGS 16)
                            (LIST Z N V C)
                            (RAM-TREE MEM (EXP 2 32))
                            INS)))
  ((DISABLE M->FM9001 A-IMMEDIATE-P PRE-DEC-P MODE-A RN-A RN-B
            V-DEC POST-INC-P V-INC SIGN-EXTEND A-IMMEDIATE REG-DIRECT-P)))

(PROVE-LEMMA M-OPERAND-A-PRESERVES-HYPS (REWRITE)
  (IMPLIES
   (AND (BVP-LISTP REGS)
        (BVP-LISTP MEM)
        (EQUAL (LENGTH REGS) 16)
        (NOT (LESSP (EXP 2 32) (LENGTH MEM))))
   (PROPER-M-STATEP (M-OPERAND-A REGS C V N Z MEM INS)))
  ((ENABLE BVP-SIGN-EXTEND LENGTH-SIGN-EXTEND)
   (DISABLE M->FM9001 A-IMMEDIATE-P PRE-DEC-P MODE-A RN-A RN-B
            V-DEC POST-INC-P V-INC SIGN-EXTEND A-IMMEDIATE REG-DIRECT-P)))


(DISABLE M-OPERAND-A)
(DISABLE FM9001-OPERAND-A)

(DEFN M-STEP1 (CURRENT-INSTRUCTION M)
  (M-OPERAND-A (UPDATE-V-NTH (NAT-TO-V 15 4) (M-REGS M)
                             (V-INC (V-NTH1 (NAT-TO-V 15 4) (M-REGS M))))
               (M-C-FLG M)
               (M-V-FLG M)
               (M-N-FLG M)
               (M-Z-FLG M)
               (M-MEM M)
               CURRENT-INSTRUCTION))

(DEFN M-STEP (M)
  (M-STEP1 (CURRENT-INSTRUCTION (M-REGS M)
                                (M-MEM M))
           M))

(PROVE-LEMMA M-STEP-IS-FM9001-STEP (REWRITE)
  (IMPLIES
   (AND
    (BVP-LISTP (M-REGS M))
    (EQUAL (LENGTH (M-REGS M)) 16)
    (NOT (LESSP (EXP 2 32) (LENGTH (M-MEM M)))))
   (EQUAL (M->FM9001 (M-STEP M))
          (FM9001-STEP (M->FM9001 M) (NAT-TO-V 15 4))))
((EXPAND (M->FM9001 M))
 (DISABLE M->FM9001 V-INC V-DEC  RN-A RN-B)))

(PROVE-LEMMA M-STEP-PRESERVES-HYPS (REWRITE)
  (IMPLIES
   (AND
    (BVP-LISTP (M-REGS M))
    (BVP-LISTP (M-MEM M))
    (EQUAL (LENGTH (M-REGS M)) 16)
    (NOT (LESSP (EXP 2 32) (LENGTH (M-MEM M)))))
   (PROPER-M-STATEP (M-STEP M))))

(DISABLE M-STEP)
(DISABLE M->FM9001)
(DISABLE FM9001-STEP)

(DEFN M (M N)
  (IF (ZEROP N)
      M
      (M (M-STEP M) (SUB1 N))))

(PROVE-LEMMA ONE-WAY-CORRESPONDENCE-M-FM9001 (REWRITE)
  (IMPLIES (PROPER-M-STATEP M)
           (EQUAL (M->FM9001 (M M N))
                  (FM9001 (M->FM9001 M) N)))
  ((INDUCT (M M N))
   (DISABLE NAT-TO-V *1*NAT-TO-V)))

; Book:  i.events.  Now we move up to the i machine.

(set-status close-data-base-2 t ((boot-strap initial)
                                 (add-shell enable)
                                 ((defn *1*defn) enable)
                                 (otherwise disable)))

(DEFN PUT-ASSOC
      (VAL NAME ALIST)
      (COND ((NLISTP ALIST) ALIST)
            ((EQUAL NAME (CAAR ALIST))
             (CONS (CONS NAME VAL) (CDR ALIST)))
            (T (CONS (CAR ALIST)
                     (PUT-ASSOC VAL NAME (CDR ALIST))))))

(DEFN DEFINEDP
      (NAME ALIST)
      (COND ((NLISTP ALIST) F)
            ((EQUAL NAME (CAAR ALIST)) T)
            (T (DEFINEDP NAME (CDR ALIST)))))

; DEFINIENS, below, used to be named VALUE but that name is now used
; in FM9001.

(DEFN DEFINIENS
      (NAME ALIST)
      (CDR (DEFINITION NAME ALIST)))

(DEFN PUT-VALUE
      (VAL NAME ALIST)
      (PUT-ASSOC VAL NAME ALIST))

(DEFN ADPP
      (X SEGMENT)
      (AND (LISTP X)
           (NUMBERP (ADP-OFFSET X))
           (DEFINEDP (ADP-NAME X) SEGMENT)
           (LESSP (ADP-OFFSET X)
                  (LENGTH (definiens (ADP-NAME X) SEGMENT)))))

(DEFN ADD-ADP
      (ADP N)
      (CONS (ADP-NAME ADP)
            (PLUS (ADP-OFFSET ADP) N)))

(DEFN ADD1-ADP (ADP) (ADD-ADP ADP 1))

(DEFN SUB1-ADP (ADP) (SUB-ADP ADP 1))

(DEFN PUT
      (VAL N LST)
      (IF (ZEROP N)
          (IF (LISTP LST)
              (CONS VAL (CDR LST))
              (LIST VAL))
          (CONS (CAR LST)
                (PUT VAL (SUB1 N) (CDR LST)))))

(DEFN FETCH-ADP
      (ADP SEGMENT)
      (GET (ADP-OFFSET ADP)
           (definiens (ADP-NAME ADP) SEGMENT)))

(DEFN DEPOSIT-ADP
      (VAL ADP SEGMENT)
      (PUT-VALUE (PUT VAL
                      (ADP-OFFSET ADP)
                      (definiens (ADP-NAME ADP) SEGMENT))
                 (ADP-NAME ADP)
                 SEGMENT))

(DEFN ADDRESSP
      (X SEGMENT)
      (ADPP (UNTAG X) SEGMENT))

(DEFN OFFSET
      (X)
      (ADP-OFFSET (UNTAG X)))

(DEFN ADD-ADDR
      (ADDR N)
      (TAG (TYPE ADDR)
           (ADD-ADP (UNTAG ADDR) N)))

(DEFN ADD1-ADDR
      (ADDR)
      (ADD-ADDR ADDR 1))

(DEFN SUB1-ADDR
      (ADDR)
      (SUB-ADDR ADDR 1))

(DEFN FETCH
      (ADDR SEGMENT)
      (FETCH-ADP (UNTAG ADDR) SEGMENT))

(DEFN DEPOSIT
      (VAL ADDR SEGMENT)
      (DEPOSIT-ADP VAL
                   (UNTAG ADDR)
                   SEGMENT))

(DEFN BOOLEANP
      (X)
      (OR (EQUAL X 'T) (EQUAL X 'F)))

(DEFN BOOL
      (X)
      (TAG 'BOOL (IF X 'T 'F)))

(DEFN OR-BOOL
      (X Y)
      (IF (EQUAL X 'F) Y 'T))

(DEFN AND-BOOL
      (X Y)
      (IF (EQUAL X 'F) 'F Y))

(DEFN XOR-BOOL
      (X Y)
      (COND ((EQUAL X 'F) Y)
            ((EQUAL Y 'F) 'T)
            (T 'F)))

(DEFN SMALL-NATURALP
      (I WORD-SIZE)
      (AND (NUMBERP I)
           (LESSP I (EXP 2 WORD-SIZE))))

(DEFN BOOL-TO-NAT
      (FLG)
      (IF (EQUAL FLG 'F) 0 1))

(DEFN FIX-SMALL-NATURAL
      (N WORD-SIZE)
      (REMAINDER N (EXP 2 WORD-SIZE)))

(DEFN SMALL-INTEGERP
      (I WORD-SIZE)
      (AND (INTEGERP I)
           (NOT (ILESSP I
                        (MINUS (EXP 2 (SUB1 WORD-SIZE)))))
           (ILESSP I (EXP 2 (SUB1 WORD-SIZE)))))

(DEFN INEGATE
      (I)
      (COND ((NEGATIVEP I) (NEGATIVE-GUTS I))
            ((ZEROP I) 0)
            (T (MINUS I))))

(DEFN FIX-SMALL-INTEGER
      (I WORD-SIZE)
      (COND ((SMALL-INTEGERP I WORD-SIZE) I)
            ((NEGATIVEP I)
             (IPLUS I (EXP 2 WORD-SIZE)))
            (T (IPLUS I (MINUS (EXP 2 WORD-SIZE))))))

(DEFN BITP
      (X)
      (OR (EQUAL X 0) (EQUAL X 1)))

(DEFN BIT-VECTORP
      (X N)
      (IF (NLISTP X)
          (AND (EQUAL X NIL) (ZEROP N))
          (AND (NOT (ZEROP N))
               (BITP (CAR X))
               (BIT-VECTORP (CDR X) (SUB1 N)))))

(DEFN OR-BIT
      (BIT1 BIT2)
      (IF (EQUAL BIT1 0)
          (IF (EQUAL BIT2 0) 0 1)
          1))

(DEFN NOT-BIT
      (BIT)
      (IF (EQUAL BIT 0) 1 0))

(DEFN AND-BIT
      (BIT1 BIT2)
      (COND ((EQUAL BIT1 0) 0)
            ((EQUAL BIT2 0) 0)
            (T 1)))

(DEFN XOR-BIT
      (BIT1 BIT2)
      (COND ((EQUAL BIT1 0)
             (IF (EQUAL BIT2 0) 0 1))
            ((EQUAL BIT2 0) 1)
            (T 0)))

(DEFN OR-BITV
      (A B)
      (IF (NLISTP A)
          NIL
          (CONS (OR-BIT (CAR A) (CAR B))
                (OR-BITV (CDR A) (CDR B)))))

(DEFN NOT-BITV
      (A)
      (IF (NLISTP A)
          NIL
          (CONS (NOT-BIT (CAR A))
                (NOT-BITV (CDR A)))))

(DEFN AND-BITV
      (A B)
      (IF (NLISTP A)
          NIL
          (CONS (AND-BIT (CAR A) (CAR B))
                (AND-BITV (CDR A) (CDR B)))))

(DEFN XOR-BITV
      (A B)
      (IF (NLISTP A)
          NIL
          (CONS (XOR-BIT (CAR A) (CAR B))
                (XOR-BITV (CDR A) (CDR B)))))

(DEFN ALL-BUT-LAST
      (A)
      (COND ((NLISTP A) NIL)
            ((NLISTP (CDR A)) NIL)
            (T (CONS (CAR A)
                     (ALL-BUT-LAST (CDR A))))))

(DEFN RSH-BITV
      (A)
      (CONS 0 (ALL-BUT-LAST A)))

(DEFN LSH-BITV
      (A)
      (APPEND (CDR A) '(0)))

(DEFN ALL-ZERO-BITVP
      (A)
      (IF (LISTP A)
          (AND (EQUAL (CAR A) 0)
               (ALL-ZERO-BITVP (CDR A)))
          T))

(DEFN FIND-LABELP
      (X LST)
      (COND ((NLISTP LST) F)
            ((AND (LABELLEDP (CAR LST))
                  (EQUAL X (CADAR LST)))
             T)
            (T (FIND-LABELP X (CDR LST)))))

(DEFN X-Y-ERROR-MSG
      (X Y)
      (PACK (APPEND (UNPACK 'ILLEGAL-)
                    (APPEND (UNPACK Y)
                            (CDR (UNPACK 'G-INSTRUCTION))))))

(DEFN CSTKP
      (X SEGMENT)
      (AND (EQUAL (TYPE X) 'SYS-ADDR)
           (ADDRESSP X SEGMENT)
           (EQUAL (AREA-NAME X) 'CSTK)
           (EQUAL (CDDR X) NIL)))

(DEFN TSTKP
      (X SEGMENT)
      (AND (EQUAL (TYPE X) 'SYS-ADDR)
           (ADDRESSP X SEGMENT)
           (EQUAL (AREA-NAME X) 'TSTK)
           (EQUAL (CDDR X) NIL)))

(DEFN PUSH-STK
      (SYS-ADDR)
      (SUB1-ADDR SYS-ADDR))

(DEFN POP-STK
      (SYS-ADDR)
      (ADD1-ADDR SYS-ADDR))

(DEFN STK-LENGTH
      (ADDR SEGMENT)
      (SUB1 (DIFFERENCE (LENGTH (definiens (AREA-NAME ADDR) SEGMENT))
                        (OFFSET ADDR))))

(DEFN EMPTY-STKP
      (ADDR SEGMENT)
      (ZEROP (STK-LENGTH ADDR SEGMENT)))

(DEFN FREE-STK-SIZE
      (ADDR)
      (OFFSET ADDR))

(DEFN ICODE-LABELP
      (LAB SEGMENT)
      (AND (DEFINEDP (ADP-NAME LAB) SEGMENT)
           (FIND-LABELP LAB
                        (definiens (ADP-NAME LAB) SEGMENT))))

(DEFN I-OBJECTP
      (X I)
      (AND (LISTP X)
           (EQUAL (CDDR X) NIL)
           (CASE (TYPE X)
                 (NAT (SMALL-NATURALP (UNTAG X)
                                      (I-WORD-SIZE I)))
                 (INT (SMALL-INTEGERP (UNTAG X)
                                      (I-WORD-SIZE I)))
                 (BITV (BIT-VECTORP (UNTAG X)
                                    (I-WORD-SIZE I)))
                 (BOOL (BOOLEANP (UNTAG X)))
                 (ADDR (ADPP (UNTAG X)
                             (I-USR-DATA-SEGMENT I)))
                 (PC (ICODE-LABELP (UNTAG X)
                                   (I-PROG-SEGMENT I)))
                 (SUBR (ADPP (CONS (UNTAG X) 0)
                             (I-PROG-SEGMENT I)))
                 (SYS-ADDR (ADPP (UNTAG X)
                                 (I-SYS-DATA-SEGMENT I)))
                 (IPC (ADPP (UNTAG X) (I-PROG-SEGMENT I)))
                 (OTHERWISE F))))

(DEFN I-OBJECTP-TYPE
      (TYPE X I)
      (AND (EQUAL TYPE (TYPE X))
           (I-OBJECTP X I)))

(DEFN I-USR-DATA-TYPEP
      (TYPE)
      (MEMBER TYPE
              '(NAT INT BITV BOOL ADDR SUBR PC)))

(DEFN I-USR-DATA-OBJECTP
      (X I)
      (AND (I-OBJECTP X I)
           (I-USR-DATA-TYPEP (TYPE X))))

(DEFN TOTAL-I-SYSTEM-SIZE
      (I load-addr)
      (PLUS load-addr
            (SEGMENT-LENGTH (I-USR-DATA-SEGMENT I))
            (SEGMENT-LENGTH (I-PROG-SEGMENT I))
            (SEGMENT-LENGTH (I-SYS-DATA-SEGMENT I))))

(DEFN I-LOADABLEP
      (I load-addr)
      (LESSP (TOTAL-I-SYSTEM-SIZE I load-addr)
             (EXP 2 (I-WORD-SIZE I))))

(DEFN I-STATE-OKP
      (I load-addr)
      (AND (I-STATEP I)
           (I-OBJECTP-TYPE 'IPC (I-PC I) I)
           (CSTKP (I-CFP I)
                  (I-SYS-DATA-SEGMENT I))
           (CSTKP (I-CSP I)
                  (I-SYS-DATA-SEGMENT I))
           (TSTKP (I-TSP I)
                  (I-SYS-DATA-SEGMENT I))
           (I-OBJECTP-TYPE 'BOOL (I-C-FLG I) I)
           (I-OBJECTP-TYPE 'BOOL (I-V-FLG I) I)
           (I-OBJECTP-TYPE 'BOOL (I-N-FLG I) I)
           (I-OBJECTP-TYPE 'BOOL (I-Z-FLG I) I)
           (I-LOADABLEP I load-addr)))

(DEFN ALL-I-USR-DATA-OBJECTPS
      (LST I)
      (IF (NLISTP LST)
          (EQUAL LST NIL)
          (AND (I-USR-DATA-OBJECTP (CAR LST) I)
               (ALL-I-USR-DATA-OBJECTPS (CDR LST)
                                        I))))

(DEFN PROPER-I-USR-DATA-AREA
      (AREA I)
      (AND (LITATOM (CAR AREA))
           (LISTP (CDR AREA))
           (ALL-I-USR-DATA-OBJECTPS (CDR AREA)
                                    I)))

(DEFN PROPER-I-USR-DATA-SEGMENTP
      (DATA-SEGMENT I)
      (IF (NLISTP DATA-SEGMENT)
          (EQUAL DATA-SEGMENT NIL)
          (AND (PROPER-I-USR-DATA-AREA (CAR DATA-SEGMENT)
                                       I)
               (NOT (DEFINEDP (CAAR DATA-SEGMENT)
                              (CDR DATA-SEGMENT)))
               (PROPER-I-USR-DATA-SEGMENTP (CDR DATA-SEGMENT)
                                           I))))

(DEFN ADD1-I-PC
      (I)
      (ADD1-ADDR (I-PC I)))

(DEFN ADD1-I-PCP
      (I)
      (ADDRESSP (ADD1-I-PC I)
                (I-PROG-SEGMENT I)))

(DEFN ADD2-I-PC
      (I)
      (ADD1-ADDR (ADD1-ADDR (I-PC I))))

(DEFN ADD2-I-PCP
      (I)
      (ADDRESSP (ADD2-I-PC I)
                (I-PROG-SEGMENT I)))

(DEFN I-CURRENT-INSTRUCTION
      (I)
      (UNLABEL (FETCH (I-PC I) (I-PROG-SEGMENT I))))

(DEFN I-NEXTWORD
      (I)
      (UNLABEL (FETCH (ADD1-I-PC I)
                      (I-PROG-SEGMENT I))))

(DEFN IPC
      (LAB PROGRAM)
      (TAG 'IPC
           (CONS (NAME PROGRAM)
                 (FIND-LABEL LAB (CDR PROGRAM)))))

(DEFN I-HALT
      (I PSW)
      (I-STATE (I-PC I)
               (I-CFP I)
               (I-CSP I)
               (I-TSP I)
               (I-X I)
               (I-Y I)
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (I-SYS-DATA-SEGMENT I)
               (I-WORD-SIZE I)
               PSW))

(DEFN XOR-XXX (OBJ1 OBJ2 I LOAD-ADDR)
      (XOR-BITV (V-TO-BITV (LINK-DATA-WORD OBJ1
                                            (I-LINK-TABLES I LOAD-ADDR)
                                            (I-WORD-SIZE I)))
                (V-TO-BITV (LINK-DATA-WORD OBJ2
                                            (I-LINK-TABLES I LOAD-ADDR)
                                            (I-WORD-SIZE I)))))

(DEFN I-ADD_<C>_X_X{N}-OKP
      (I)
      (AND (ADD1-I-PCP I)
           (I-OBJECTP-TYPE 'NAT (I-X I) I)))

(DEFN I-ADD_<C>_X_X{N}-STEP
      (I)
      (I-STATE (ADD1-I-PC I)
               (I-CFP I)
               (I-CSP I)
               (I-TSP I)
               (TAG 'NAT
                    (FIX-SMALL-NATURAL (TIMES 2 (UNTAG (I-X I)))
                                       (I-WORD-SIZE I)))
               (I-Y I)
               (BOOL (NOT (SMALL-NATURALP (TIMES 2 (UNTAG (I-X I)))
                                          (I-WORD-SIZE I))))
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (I-SYS-DATA-SEGMENT I)
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-ADD_<TSP>_<TSP>{V}-OKP
      (I)
      (AND (ADD1-I-PCP I)
           (NOT (EMPTY-STKP (I-TSP I)
                            (I-SYS-DATA-SEGMENT I)))
           (I-OBJECTP-TYPE 'BITV
                           (FETCH (I-TSP I)
                                  (I-SYS-DATA-SEGMENT I))
                           I)))

(DEFN I-ADD_<TSP>_<TSP>{V}-STEP
      (I)
      (I-STATE (ADD1-I-PC I)
               (I-CFP I)
               (I-CSP I)
               (I-TSP I)
               (I-X I)
               (I-Y I)
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (DEPOSIT (TAG 'BITV
                             (LSH-BITV (UNTAG (FETCH (I-TSP I)
                                                     (I-SYS-DATA-SEGMENT I)))))
                        (I-TSP I)
                        (I-SYS-DATA-SEGMENT I))
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-ADD_<TSP>_<TSP>{N}-OKP
      (I)
      (AND (ADD1-I-PCP I)
           (NOT (EMPTY-STKP (I-TSP I)
                            (I-SYS-DATA-SEGMENT I)))
           (I-OBJECTP-TYPE 'NAT
                           (FETCH (I-TSP I)
                                  (I-SYS-DATA-SEGMENT I))
                           I)
           (SMALL-NATURALP (TIMES 2
                                  (UNTAG (FETCH (I-TSP I)
                                                (I-SYS-DATA-SEGMENT I))))
                           (I-WORD-SIZE I))))

(DEFN I-ADD_<TSP>_<TSP>{N}-STEP
      (I)
      (I-STATE (ADD1-I-PC I)
               (I-CFP I)
               (I-CSP I)
               (I-TSP I)
               (I-X I)
               (I-Y I)
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (DEPOSIT (TAG 'NAT
                             (TIMES 2
                                    (UNTAG (FETCH (I-TSP I)
                                                  (I-SYS-DATA-SEGMENT I)))))
                        (I-TSP I)
                        (I-SYS-DATA-SEGMENT I))
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-ADD_<TSP>{A}_X{N}-OKP
      (I)
      (AND (ADD1-I-PCP I)
           (NOT (EMPTY-STKP (I-TSP I)
                            (I-SYS-DATA-SEGMENT I)))
           (I-OBJECTP-TYPE 'NAT (I-X I) I)
           (I-OBJECTP-TYPE 'ADDR
                           (FETCH (I-TSP I)
                                  (I-SYS-DATA-SEGMENT I))
                           I)
           (I-OBJECTP-TYPE 'ADDR
                           (ADD-ADDR (FETCH (I-TSP I)
                                            (I-SYS-DATA-SEGMENT I))
                                     (UNTAG (I-X I)))
                           I)))

(DEFN I-ADD_<TSP>{A}_X{N}-STEP
      (I)
      (I-STATE (ADD1-I-PC I)
               (I-CFP I)
               (I-CSP I)
               (I-TSP I)
               (I-X I)
               (I-Y I)
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (DEPOSIT (ADD-ADDR (FETCH (I-TSP I)
                                         (I-SYS-DATA-SEGMENT I))
                                  (UNTAG (I-X I)))
                        (I-TSP I)
                        (I-SYS-DATA-SEGMENT I))
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-ADD_TSP_*{N}-OKP
      (I)
      (AND (ADD2-I-PCP I)
           (I-OBJECTP-TYPE 'NAT
                           (I-NEXTWORD I)
                           I)
           (ADDRESSP (ADD-ADDR (I-TSP I)
                               (UNTAG (I-NEXTWORD I)))
                     (I-SYS-DATA-SEGMENT I))))

(DEFN I-ADD_TSP_*{N}-STEP
      (I)
      (I-STATE (ADD2-I-PC I)
               (I-CFP I)
               (I-CSP I)
               (ADD-ADDR (I-TSP I)
                         (UNTAG (I-NEXTWORD I)))
               (I-X I)
               (I-Y I)
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (I-SYS-DATA-SEGMENT I)
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-ADD_TSP_X{N}-OKP
      (I)
      (AND (ADD1-I-PCP I)
           (I-OBJECTP-TYPE 'NAT (I-X I) I)
           (ADDRESSP (ADD-ADDR (I-TSP I) (UNTAG (I-X I)))
                     (I-SYS-DATA-SEGMENT I))))

(DEFN I-ADD_TSP_X{N}-STEP
      (I)
      (I-STATE (ADD1-I-PC I)
               (I-CFP I)
               (I-CSP I)
               (ADD-ADDR (I-TSP I) (UNTAG (I-X I)))
               (I-X I)
               (I-Y I)
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (I-SYS-DATA-SEGMENT I)
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-ADD_<TSP>{I}_X{I}-OKP
      (I)
      (AND (ADD1-I-PCP I)
           (NOT (EMPTY-STKP (I-TSP I)
                            (I-SYS-DATA-SEGMENT I)))
           (I-OBJECTP-TYPE 'INT (I-X I) I)
           (I-OBJECTP-TYPE 'INT
                           (FETCH (I-TSP I)
                                  (I-SYS-DATA-SEGMENT I))
                           I)
           (SMALL-INTEGERP (IPLUS (UNTAG (FETCH (I-TSP I)
                                                (I-SYS-DATA-SEGMENT I)))
                                  (UNTAG (I-X I)))
                           (I-WORD-SIZE I))))

(DEFN I-ADD_<TSP>{I}_X{I}-STEP
      (I)
      (I-STATE (ADD1-I-PC I)
               (I-CFP I)
               (I-CSP I)
               (I-TSP I)
               (I-X I)
               (I-Y I)
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (DEPOSIT (TAG 'INT
                             (IPLUS (UNTAG (FETCH (I-TSP I)
                                                  (I-SYS-DATA-SEGMENT I)))
                                    (UNTAG (I-X I))))
                        (I-TSP I)
                        (I-SYS-DATA-SEGMENT I))
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-ADD_<TSP>{N}_X{N}-OKP
      (I)
      (AND (ADD1-I-PCP I)
           (NOT (EMPTY-STKP (I-TSP I)
                            (I-SYS-DATA-SEGMENT I)))
           (I-OBJECTP-TYPE 'NAT (I-X I) I)
           (I-OBJECTP-TYPE 'NAT
                           (FETCH (I-TSP I)
                                  (I-SYS-DATA-SEGMENT I))
                           I)
           (SMALL-NATURALP (PLUS (UNTAG (FETCH (I-TSP I)
                                               (I-SYS-DATA-SEGMENT I)))
                                 (UNTAG (I-X I)))
                           (I-WORD-SIZE I))))

(DEFN I-ADD_<TSP>{N}_X{N}-STEP
      (I)
      (I-STATE (ADD1-I-PC I)
               (I-CFP I)
               (I-CSP I)
               (I-TSP I)
               (I-X I)
               (I-Y I)
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (DEPOSIT (TAG 'NAT
                             (PLUS (UNTAG (FETCH (I-TSP I)
                                                 (I-SYS-DATA-SEGMENT I)))
                                   (UNTAG (I-X I))))
                        (I-TSP I)
                        (I-SYS-DATA-SEGMENT I))
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-ADD_PC_X{N}-OKP
      (I)
      (AND (I-OBJECTP-TYPE 'NAT (I-X I) I)
           (ADDRESSP (ADD-ADDR (I-PC I)
                               (ADD1 (UNTAG (I-X I))))
                     (I-PROG-SEGMENT I))))

(DEFN I-ADD_PC_X{N}-STEP
      (I)
      (I-STATE (ADD-ADDR (I-PC I)
                         (ADD1 (UNTAG (I-X I))))
               (I-CFP I)
               (I-CSP I)
               (I-TSP I)
               (I-X I)
               (I-Y I)
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (I-SYS-DATA-SEGMENT I)
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-ADD_X_X{N}-OKP
      (I)
      (AND (ADD1-I-PCP I)
           (I-OBJECTP-TYPE 'NAT (I-X I) I)
           (SMALL-NATURALP (TIMES 2 (UNTAG (I-X I)))
                           (I-WORD-SIZE I))))

(DEFN I-ADD_X_X{N}-STEP
      (I)
      (I-STATE (ADD1-I-PC I)
               (I-CFP I)
               (I-CSP I)
               (I-TSP I)
               (TAG 'NAT (TIMES 2 (UNTAG (I-X I))))
               (I-Y I)
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (I-SYS-DATA-SEGMENT I)
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-ADD_X{N}_CSP-OKP
      (I)
      (AND (ADD1-I-PCP I)
           (I-OBJECTP-TYPE 'NAT (I-X I) I)
           (ADDRESSP (ADD-ADDR (I-CSP I) (UNTAG (I-X I)))
                     (I-SYS-DATA-SEGMENT I))))

(DEFN I-ADD_X{N}_CSP-STEP
      (I)
      (I-STATE (ADD1-I-PC I)
               (I-CFP I)
               (I-CSP I)
               (I-TSP I)
               (ADD-ADDR (I-CSP I) (UNTAG (I-X I)))
               (I-Y I)
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (I-SYS-DATA-SEGMENT I)
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-ADDC_<C>_X{N}_Y{N}-OKP
      (I)
      (AND (ADD1-I-PCP I)
           (I-OBJECTP-TYPE 'NAT (I-X I) I)
           (I-OBJECTP-TYPE 'NAT (I-Y I) I)))

(DEFN I-ADDC_<C>_X{N}_Y{N}-STEP
    (I)
    (I-STATE (ADD1-I-PC I)
             (I-CFP I)
             (I-CSP I)
             (I-TSP I)
             (TAG 'NAT
                  (FIX-SMALL-NATURAL (PLUS (BOOL-TO-NAT (UNTAG (I-C-FLG I)))
                                           (UNTAG (I-Y I))
                                           (UNTAG (I-X I)))
                                     (I-WORD-SIZE I)))
             (I-Y I)
             (BOOL (NOT (SMALL-NATURALP (PLUS (BOOL-TO-NAT (UNTAG (I-C-FLG I)))
                                              (UNTAG (I-Y I))
                                              (UNTAG (I-X I)))
                                        (I-WORD-SIZE I))))
             (I-V-FLG I)
             (I-N-FLG I)
             (I-Z-FLG I)
             (I-PROG-SEGMENT I)
             (I-USR-DATA-SEGMENT I)
             (I-SYS-DATA-SEGMENT I)
             (I-WORD-SIZE I)
             'RUN))

(DEFN I-ADDC_<V>_X{I}_Y{I}-OKP
      (I)
      (AND (ADD1-I-PCP I)
           (I-OBJECTP-TYPE 'INT (I-X I) I)
           (I-OBJECTP-TYPE 'INT (I-Y I) I)))

(DEFN I-ADDC_<V>_X{I}_Y{I}-STEP
   (I)
   (I-STATE (ADD1-I-PC I)
            (I-CFP I)
            (I-CSP I)
            (I-TSP I)
            (TAG 'INT
                 (FIX-SMALL-INTEGER (IPLUS (BOOL-TO-NAT (UNTAG (I-C-FLG I)))
                                           (IPLUS (UNTAG (I-Y I))
                                                  (UNTAG (I-X I))))
                                    (I-WORD-SIZE I)))
            (I-Y I)
            (I-C-FLG I)
            (BOOL (NOT (SMALL-INTEGERP (IPLUS (BOOL-TO-NAT (UNTAG (I-C-FLG I)))
                                              (IPLUS (UNTAG (I-Y I))
                                                     (UNTAG (I-X I))))
                                       (I-WORD-SIZE I))))
            (I-N-FLG I)
            (I-Z-FLG I)
            (I-PROG-SEGMENT I)
            (I-USR-DATA-SEGMENT I)
            (I-SYS-DATA-SEGMENT I)
            (I-WORD-SIZE I)
            'RUN))

(DEFN I-AND_<TSP>{V}_X{V}-OKP
      (I)
      (AND (ADD1-I-PCP I)
           (NOT (EMPTY-STKP (I-TSP I)
                            (I-SYS-DATA-SEGMENT I)))
           (I-OBJECTP-TYPE 'BITV (I-X I) I)
           (I-OBJECTP-TYPE 'BITV
                           (FETCH (I-TSP I)
                                  (I-SYS-DATA-SEGMENT I))
                           I)))

(DEFN I-AND_<TSP>{V}_X{V}-STEP
      (I)
      (I-STATE (ADD1-I-PC I)
               (I-CFP I)
               (I-CSP I)
               (I-TSP I)
               (I-X I)
               (I-Y I)
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (DEPOSIT (TAG 'BITV
                             (AND-BITV (UNTAG (FETCH (I-TSP I)
                                                     (I-SYS-DATA-SEGMENT I)))
                                       (UNTAG (I-X I))))
                        (I-TSP I)
                        (I-SYS-DATA-SEGMENT I))
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-AND_<TSP>{B}_X{B}-OKP
      (I)
      (AND (ADD1-I-PCP I)
           (NOT (EMPTY-STKP (I-TSP I)
                            (I-SYS-DATA-SEGMENT I)))
           (I-OBJECTP-TYPE 'BOOL (I-X I) I)
           (I-OBJECTP-TYPE 'BOOL
                           (FETCH (I-TSP I)
                                  (I-SYS-DATA-SEGMENT I))
                           I)))

(DEFN I-AND_<TSP>{B}_X{B}-STEP
      (I)
      (I-STATE (ADD1-I-PC I)
               (I-CFP I)
               (I-CSP I)
               (I-TSP I)
               (I-X I)
               (I-Y I)
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (DEPOSIT (TAG 'BOOL
                             (AND-BOOL (UNTAG (FETCH (I-TSP I)
                                                     (I-SYS-DATA-SEGMENT I)))
                                       (UNTAG (I-X I))))
                        (I-TSP I)
                        (I-SYS-DATA-SEGMENT I))
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-ASR_<C>_<TSP>_<TSP>{B}-OKP
      (I)
      (AND (ADD1-I-PCP I)
           (NOT (EMPTY-STKP (I-TSP I)
                            (I-SYS-DATA-SEGMENT I)))
           (I-OBJECTP-TYPE 'BOOL
                           (FETCH (I-TSP I)
                                  (I-SYS-DATA-SEGMENT I))
                           I)))

(DEFN I-ASR_<C>_<TSP>_<TSP>{B}-STEP
      (I)
      (I-STATE (ADD1-I-PC I)
               (I-CFP I)
               (I-CSP I)
               (I-TSP I)
               (I-X I)
               (I-Y I)
               (FETCH (I-TSP I)
                      (I-SYS-DATA-SEGMENT I))
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (DEPOSIT (TAG 'BOOL 'F)
                        (I-TSP I)
                        (I-SYS-DATA-SEGMENT I))
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-CPOP_CFP-OKP
      (I)
      (AND (ADD1-I-PCP I)
           (NOT (EMPTY-STKP (I-CSP I)
                            (I-SYS-DATA-SEGMENT I)))
           (CSTKP (FETCH (I-CSP I)
                         (I-SYS-DATA-SEGMENT I))
                  (I-SYS-DATA-SEGMENT I))))

(DEFN I-CPOP_CFP-STEP
      (I)
      (I-STATE (ADD1-I-PC I)
               (FETCH (I-CSP I)
                      (I-SYS-DATA-SEGMENT I))
               (POP-STK (I-CSP I))
               (I-TSP I)
               (I-X I)
               (I-Y I)
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (I-SYS-DATA-SEGMENT I)
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-CPOP_PC-OKP
      (I)
      (AND (NOT (EMPTY-STKP (I-CSP I)
                            (I-SYS-DATA-SEGMENT I)))
           (I-OBJECTP-TYPE 'PC
                           (FETCH (I-CSP I)
                                  (I-SYS-DATA-SEGMENT I))
                           I)))

(DEFN I-CPOP_PC-STEP
      (I)
      (I-STATE (IPC (UNTAG (FETCH (I-CSP I)
                                  (I-SYS-DATA-SEGMENT I)))
                    (DEFINITION (AREA-NAME (FETCH (I-CSP I)
                                                  (I-SYS-DATA-SEGMENT I)))
                                (I-PROG-SEGMENT I)))
               (I-CFP I)
               (POP-STK (I-CSP I))
               (I-TSP I)
               (I-X I)
               (I-Y I)
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (I-SYS-DATA-SEGMENT I)
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-CPUSH_*-OKP
      (I)
      (AND (ADD2-I-PCP I)
           (I-OBJECTP (I-NEXTWORD I) I)
           (NOT (ZEROP (FREE-STK-SIZE (I-CSP I))))))

(DEFN I-CPUSH_*-STEP
      (I)
      (I-STATE (ADD2-I-PC I)
               (I-CFP I)
               (PUSH-STK (I-CSP I))
               (I-TSP I)
               (I-X I)
               (I-Y I)
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (DEPOSIT (I-NEXTWORD I)
                        (PUSH-STK (I-CSP I))
                        (I-SYS-DATA-SEGMENT I))
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-CPUSH_<TSP>+-OKP
      (I)
      (AND (ADD1-I-PCP I)
           (NOT (EMPTY-STKP (I-TSP I)
                            (I-SYS-DATA-SEGMENT I)))
           (NOT (ZEROP (FREE-STK-SIZE (I-CSP I))))))

(DEFN I-CPUSH_<TSP>+-STEP
      (I)
      (I-STATE (ADD1-I-PC I)
               (I-CFP I)
               (PUSH-STK (I-CSP I))
               (POP-STK (I-TSP I))
               (I-X I)
               (I-Y I)
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (DEPOSIT (FETCH (I-TSP I)
                               (I-SYS-DATA-SEGMENT I))
                        (PUSH-STK (I-CSP I))
                        (I-SYS-DATA-SEGMENT I))
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-CPUSH_CFP-OKP
      (I)
      (AND (ADD1-I-PCP I)
           (NOT (ZEROP (FREE-STK-SIZE (I-CSP I))))))

(DEFN I-CPUSH_CFP-STEP
      (I)
      (I-STATE (ADD1-I-PC I)
               (I-CFP I)
               (PUSH-STK (I-CSP I))
               (I-TSP I)
               (I-X I)
               (I-Y I)
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (DEPOSIT (I-CFP I)
                        (PUSH-STK (I-CSP I))
                        (I-SYS-DATA-SEGMENT I))
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-DECR_<TSP>_<TSP>{I}-OKP
      (I)
      (AND (ADD1-I-PCP I)
           (NOT (EMPTY-STKP (I-TSP I)
                            (I-SYS-DATA-SEGMENT I)))
           (I-OBJECTP-TYPE 'INT
                           (FETCH (I-TSP I)
                                  (I-SYS-DATA-SEGMENT I))
                           I)
           (SMALL-INTEGERP (IDIFFERENCE (UNTAG (FETCH (I-TSP I)
                                                      (I-SYS-DATA-SEGMENT I)))
                                        1)
                           (I-WORD-SIZE I))))

(DEFN I-DECR_<TSP>_<TSP>{I}-STEP
     (I)
     (I-STATE (ADD1-I-PC I)
              (I-CFP I)
              (I-CSP I)
              (I-TSP I)
              (I-X I)
              (I-Y I)
              (I-C-FLG I)
              (I-V-FLG I)
              (I-N-FLG I)
              (I-Z-FLG I)
              (I-PROG-SEGMENT I)
              (I-USR-DATA-SEGMENT I)
              (DEPOSIT (TAG 'INT
                            (IDIFFERENCE (UNTAG (FETCH (I-TSP I)
                                                       (I-SYS-DATA-SEGMENT I)))
                                         1))
                       (I-TSP I)
                       (I-SYS-DATA-SEGMENT I))
              (I-WORD-SIZE I)
              'RUN))

(DEFN I-DECR_<TSP>_<TSP>{N}-OKP
      (I)
      (AND (ADD1-I-PCP I)
           (NOT (EMPTY-STKP (I-TSP I)
                            (I-SYS-DATA-SEGMENT I)))
           (I-OBJECTP-TYPE 'NAT
                           (FETCH (I-TSP I)
                                  (I-SYS-DATA-SEGMENT I))
                           I)
           (NOT (ZEROP (UNTAG (FETCH (I-TSP I)
                                     (I-SYS-DATA-SEGMENT I)))))))

(DEFN I-DECR_<TSP>_<TSP>{N}-STEP
      (I)
      (I-STATE (ADD1-I-PC I)
               (I-CFP I)
               (I-CSP I)
               (I-TSP I)
               (I-X I)
               (I-Y I)
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (DEPOSIT (TAG 'NAT
                             (SUB1 (UNTAG (FETCH (I-TSP I)
                                                 (I-SYS-DATA-SEGMENT I)))))
                        (I-TSP I)
                        (I-SYS-DATA-SEGMENT I))
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-INCR_<TSP>_<TSP>{I}-OKP
      (I)
      (AND (ADD1-I-PCP I)
           (NOT (EMPTY-STKP (I-TSP I)
                            (I-SYS-DATA-SEGMENT I)))
           (I-OBJECTP-TYPE 'INT
                           (FETCH (I-TSP I)
                                  (I-SYS-DATA-SEGMENT I))
                           I)
           (SMALL-INTEGERP (IPLUS (UNTAG (FETCH (I-TSP I)
                                                (I-SYS-DATA-SEGMENT I)))
                                  1)
                           (I-WORD-SIZE I))))

(DEFN I-INCR_<TSP>_<TSP>{I}-STEP
      (I)
      (I-STATE (ADD1-I-PC I)
               (I-CFP I)
               (I-CSP I)
               (I-TSP I)
               (I-X I)
               (I-Y I)
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (DEPOSIT (TAG 'INT
                             (IPLUS (UNTAG (FETCH (I-TSP I)
                                                  (I-SYS-DATA-SEGMENT I)))
                                    1))
                        (I-TSP I)
                        (I-SYS-DATA-SEGMENT I))
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-INCR_<TSP>_<TSP>{N}-OKP
      (I)
      (AND (ADD1-I-PCP I)
           (NOT (EMPTY-STKP (I-TSP I)
                            (I-SYS-DATA-SEGMENT I)))
           (I-OBJECTP-TYPE 'NAT
                           (FETCH (I-TSP I)
                                  (I-SYS-DATA-SEGMENT I))
                           I)
           (SMALL-NATURALP (ADD1 (UNTAG (FETCH (I-TSP I)
                                               (I-SYS-DATA-SEGMENT I))))
                           (I-WORD-SIZE I))))

(DEFN I-INCR_<TSP>_<TSP>{N}-STEP
      (I)
      (I-STATE (ADD1-I-PC I)
               (I-CFP I)
               (I-CSP I)
               (I-TSP I)
               (I-X I)
               (I-Y I)
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (DEPOSIT (TAG 'NAT
                             (ADD1 (UNTAG (FETCH (I-TSP I)
                                                 (I-SYS-DATA-SEGMENT I)))))
                        (I-TSP I)
                        (I-SYS-DATA-SEGMENT I))
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-INCR_Y_Y{N}-OKP
      (I)
      (AND (ADD1-I-PCP I)
           (I-OBJECTP-TYPE 'NAT (I-Y I) I)
           (SMALL-NATURALP (ADD1 (UNTAG (I-Y I)))
                           (I-WORD-SIZE I))))

(DEFN I-INCR_Y_Y{N}-STEP
      (I)
      (I-STATE (ADD1-I-PC I)
               (I-CFP I)
               (I-CSP I)
               (I-TSP I)
               (I-X I)
               (TAG 'NAT (ADD1 (UNTAG (I-Y I))))
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (I-SYS-DATA-SEGMENT I)
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-INT-TO-NAT-OKP
      (I)
      (AND (ADD1-I-PCP I)
           (NOT (EMPTY-STKP (I-TSP I)
                            (I-SYS-DATA-SEGMENT I)))
           (I-OBJECTP-TYPE 'INT
                           (FETCH (I-TSP I)
                                  (I-SYS-DATA-SEGMENT I))
                           I)
           (NOT (NEGATIVEP (UNTAG (FETCH (I-TSP I)
                                         (I-SYS-DATA-SEGMENT I)))))))

(DEFN I-INT-TO-NAT-STEP
      (I)
      (I-STATE (ADD1-I-PC I)
               (I-CFP I)
               (I-CSP I)
               (I-TSP I)
               (I-X I)
               (I-Y I)
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (DEPOSIT (TAG 'NAT
                             (UNTAG (FETCH (I-TSP I)
                                           (I-SYS-DATA-SEGMENT I))))
                        (I-TSP I)
                        (I-SYS-DATA-SEGMENT I))
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-JUMP-N_X-OKP
      (I)
      (IF (EQUAL (UNTAG (I-N-FLG I)) 'F)
          (ADD1-I-PCP I)
          (I-OBJECTP-TYPE 'PC (I-X I) I)))

(DEFN I-JUMP-N_X-STEP
      (I)
      (I-STATE (IF (EQUAL (UNTAG (I-N-FLG I)) 'F)
                   (ADD1-I-PC I)
                   (IPC (UNTAG (I-X I))
                        (DEFINITION (AREA-NAME (I-X I))
                                    (I-PROG-SEGMENT I))))
               (I-CFP I)
               (I-CSP I)
               (I-TSP I)
               (I-X I)
               (I-Y I)
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (I-SYS-DATA-SEGMENT I)
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-JUMP-NN_X-OKP
      (I)
      (IF (EQUAL (UNTAG (I-N-FLG I)) 'F)
          (I-OBJECTP-TYPE 'PC (I-X I) I)
          (ADD1-I-PCP I)))

(DEFN I-JUMP-NN_X-STEP
      (I)
      (I-STATE (IF (EQUAL (UNTAG (I-N-FLG I)) 'F)
                   (IPC (UNTAG (I-X I))
                        (DEFINITION (AREA-NAME (I-X I))
                                    (I-PROG-SEGMENT I)))
                   (ADD1-I-PC I))
               (I-CFP I)
               (I-CSP I)
               (I-TSP I)
               (I-X I)
               (I-Y I)
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (I-SYS-DATA-SEGMENT I)
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-JUMP-NZ_X-OKP
      (I)
      (IF (EQUAL (UNTAG (I-Z-FLG I)) 'F)
          (I-OBJECTP-TYPE 'PC (I-X I) I)
          (ADD1-I-PCP I)))

(DEFN I-JUMP-NZ_X-STEP
      (I)
      (I-STATE (IF (EQUAL (UNTAG (I-Z-FLG I)) 'F)
                   (IPC (UNTAG (I-X I))
                        (DEFINITION (AREA-NAME (I-X I))
                                    (I-PROG-SEGMENT I)))
                   (ADD1-I-PC I))
               (I-CFP I)
               (I-CSP I)
               (I-TSP I)
               (I-X I)
               (I-Y I)
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (I-SYS-DATA-SEGMENT I)
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-JUMP-Z_X-OKP
      (I)
      (IF (EQUAL (UNTAG (I-Z-FLG I)) 'F)
          (ADD1-I-PCP I)
          (I-OBJECTP-TYPE 'PC (I-X I) I)))

(DEFN I-JUMP-Z_X-STEP
      (I)
      (I-STATE (IF (EQUAL (UNTAG (I-Z-FLG I)) 'F)
                   (ADD1-I-PC I)
                   (IPC (UNTAG (I-X I))
                        (DEFINITION (AREA-NAME (I-X I))
                                    (I-PROG-SEGMENT I))))
               (I-CFP I)
               (I-CSP I)
               (I-TSP I)
               (I-X I)
               (I-Y I)
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (I-SYS-DATA-SEGMENT I)
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-JUMP_*-OKP
      (I)
      (AND (ADD1-I-PCP I)
           (I-OBJECTP-TYPE 'PC
                           (I-NEXTWORD I)
                           I)))

(DEFN I-JUMP_*-STEP
      (I)
      (I-STATE (IPC (UNTAG (I-NEXTWORD I))
                    (DEFINITION (AREA-NAME (I-NEXTWORD I))
                                (I-PROG-SEGMENT I)))
               (I-CFP I)
               (I-CSP I)
               (I-TSP I)
               (I-X I)
               (I-Y I)
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (I-SYS-DATA-SEGMENT I)
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-JUMP_X{SUBR}-OKP
      (I)
      (I-OBJECTP-TYPE 'SUBR (I-X I) I))

(DEFN I-JUMP_X{SUBR}-STEP
      (I)
      (I-STATE (TAG 'IPC (CONS (UNTAG (I-X I)) 0))
               (I-CFP I)
               (I-CSP I)
               (I-TSP I)
               (I-X I)
               (I-Y I)
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (I-SYS-DATA-SEGMENT I)
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-LSR_<C>_X_X{N}-OKP
      (I)
      (AND (ADD1-I-PCP I)
           (I-OBJECTP-TYPE 'NAT (I-X I) I)))

(DEFN I-LSR_<C>_X_X{N}-STEP
      (I)
      (I-STATE (ADD1-I-PC I)
               (I-CFP I)
               (I-CSP I)
               (I-TSP I)
               (TAG 'NAT
                    (QUOTIENT (UNTAG (I-X I)) 2))
               (I-Y I)
               (BOOL (EQUAL (REMAINDER (UNTAG (I-X I)) 2)
                            1))
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (I-SYS-DATA-SEGMENT I)
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-LSR_<TSP>_<TSP>{V}-OKP
      (I)
      (AND (ADD1-I-PCP I)
           (NOT (EMPTY-STKP (I-TSP I)
                            (I-SYS-DATA-SEGMENT I)))
           (I-OBJECTP-TYPE 'BITV
                           (FETCH (I-TSP I)
                                  (I-SYS-DATA-SEGMENT I))
                           I)))

(DEFN I-LSR_<TSP>_<TSP>{V}-STEP
      (I)
      (I-STATE (ADD1-I-PC I)
               (I-CFP I)
               (I-CSP I)
               (I-TSP I)
               (I-X I)
               (I-Y I)
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (DEPOSIT (TAG 'BITV
                             (RSH-BITV (UNTAG (FETCH (I-TSP I)
                                                     (I-SYS-DATA-SEGMENT I)))))
                        (I-TSP I)
                        (I-SYS-DATA-SEGMENT I))
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-MOVE-C_<TSP>_*-OKP
      (I)
      (AND (ADD2-I-PCP I)
           (I-OBJECTP (I-NEXTWORD I) I)
           (NOT (EMPTY-STKP (I-TSP I)
                            (I-SYS-DATA-SEGMENT I)))))

(DEFN I-MOVE-C_<TSP>_*-STEP
      (I)
      (I-STATE (ADD2-I-PC I)
               (I-CFP I)
               (I-CSP I)
               (I-TSP I)
               (I-X I)
               (I-Y I)
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (IF (EQUAL (UNTAG (I-C-FLG I)) 'F)
                   (I-SYS-DATA-SEGMENT I)
                   (DEPOSIT (I-NEXTWORD I)
                            (I-TSP I)
                            (I-SYS-DATA-SEGMENT I)))
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-MOVE-V_<TSP>_*-OKP
      (I)
      (AND (ADD2-I-PCP I)
           (I-OBJECTP (I-NEXTWORD I) I)
           (NOT (EMPTY-STKP (I-TSP I)
                            (I-SYS-DATA-SEGMENT I)))))

(DEFN I-MOVE-V_<TSP>_*-STEP
      (I)
      (I-STATE (ADD2-I-PC I)
               (I-CFP I)
               (I-CSP I)
               (I-TSP I)
               (I-X I)
               (I-Y I)
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (IF (EQUAL (UNTAG (I-V-FLG I)) 'F)
                   (I-SYS-DATA-SEGMENT I)
                   (DEPOSIT (I-NEXTWORD I)
                            (I-TSP I)
                            (I-SYS-DATA-SEGMENT I)))
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-MOVE-Z_<TSP>_*-OKP
      (I)
      (AND (ADD2-I-PCP I)
           (I-OBJECTP (I-NEXTWORD I) I)
           (NOT (EMPTY-STKP (I-TSP I)
                            (I-SYS-DATA-SEGMENT I)))))

(DEFN I-MOVE-Z_<TSP>_*-STEP
      (I)
      (I-STATE (ADD2-I-PC I)
               (I-CFP I)
               (I-CSP I)
               (I-TSP I)
               (I-X I)
               (I-Y I)
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (IF (EQUAL (UNTAG (I-Z-FLG I)) 'F)
                   (I-SYS-DATA-SEGMENT I)
                   (DEPOSIT (I-NEXTWORD I)
                            (I-TSP I)
                            (I-SYS-DATA-SEGMENT I)))
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-MOVE-N_X_*-OKP
      (I)
      (AND (ADD2-I-PCP I)
           (I-OBJECTP (I-NEXTWORD I) I)))

(DEFN I-MOVE-N_X_*-STEP
      (I)
      (I-STATE (ADD2-I-PC I)
               (I-CFP I)
               (I-CSP I)
               (I-TSP I)
               (IF (EQUAL (UNTAG (I-N-FLG I)) 'F)
                   (I-X I)
                   (I-NEXTWORD I))
               (I-Y I)
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (I-SYS-DATA-SEGMENT I)
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-MOVE_<TSP>_*-OKP
      (I)
      (AND (ADD2-I-PCP I)
           (I-OBJECTP (I-NEXTWORD I) I)
           (NOT (EMPTY-STKP (I-TSP I)
                            (I-SYS-DATA-SEGMENT I)))))

(DEFN I-MOVE_<TSP>_*-STEP
      (I)
      (I-STATE (ADD2-I-PC I)
               (I-CFP I)
               (I-CSP I)
               (I-TSP I)
               (I-X I)
               (I-Y I)
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (DEPOSIT (I-NEXTWORD I)
                        (I-TSP I)
                        (I-SYS-DATA-SEGMENT I))
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-MOVE_<X{A}>_<TSP>-OKP
      (I)
      (AND (ADD1-I-PCP I)
           (NOT (EMPTY-STKP (I-TSP I)
                            (I-SYS-DATA-SEGMENT I)))
           (I-OBJECTP-TYPE 'ADDR (I-X I) I)))

(DEFN I-MOVE_<X{A}>_<TSP>-STEP
      (I)
      (I-STATE (ADD1-I-PC I)
               (I-CFP I)
               (I-CSP I)
               (I-TSP I)
               (I-X I)
               (I-Y I)
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (DEPOSIT (FETCH (I-TSP I)
                               (I-SYS-DATA-SEGMENT I))
                        (I-X I)
                        (I-USR-DATA-SEGMENT I))
               (I-SYS-DATA-SEGMENT I)
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-MOVE_<X{S}>_<TSP>-OKP
      (I)
      (AND (ADD1-I-PCP I)
           (NOT (EMPTY-STKP (I-TSP I)
                            (I-SYS-DATA-SEGMENT I)))
           (I-OBJECTP-TYPE 'SYS-ADDR
                           (I-X I)
                           I)))

(DEFN I-MOVE_<X{S}>_<TSP>-STEP
      (I)
      (I-STATE (ADD1-I-PC I)
               (I-CFP I)
               (I-CSP I)
               (I-TSP I)
               (I-X I)
               (I-Y I)
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (DEPOSIT (FETCH (I-TSP I)
                               (I-SYS-DATA-SEGMENT I))
                        (I-X I)
                        (I-SYS-DATA-SEGMENT I))
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-MOVE_CFP_CSP-OKP
      (I)
      (ADD1-I-PCP I))

(DEFN I-MOVE_CFP_CSP-STEP
      (I)
      (I-STATE (ADD1-I-PC I)
               (I-CSP I)
               (I-CSP I)
               (I-TSP I)
               (I-X I)
               (I-Y I)
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (I-SYS-DATA-SEGMENT I)
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-MOVE_CSP_CFP-OKP
      (I)
      (ADD1-I-PCP I))

(DEFN I-MOVE_CSP_CFP-STEP
      (I)
      (I-STATE (ADD1-I-PC I)
               (I-CFP I)
               (I-CFP I)
               (I-TSP I)
               (I-X I)
               (I-Y I)
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (I-SYS-DATA-SEGMENT I)
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-MOVE_X_*-OKP
      (I)
      (ADD2-I-PCP I))

(DEFN I-MOVE_X_*-STEP
      (I)
      (I-STATE (ADD2-I-PC I)
               (I-CFP I)
               (I-CSP I)
               (I-TSP I)
               (I-NEXTWORD I)
               (I-Y I)
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (I-SYS-DATA-SEGMENT I)
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-MOVE_X_<X{S}>-OKP
      (I)
      (AND (ADD1-I-PCP I)
           (I-OBJECTP-TYPE 'SYS-ADDR (I-X I) I)
           (I-OBJECTP (FETCH (I-X I) (I-SYS-DATA-SEGMENT I))
                      I)))

(DEFN I-MOVE_X_<X{S}>-STEP
      (I)
      (I-STATE (ADD1-I-PC I)
               (I-CFP I)
               (I-CSP I)
               (I-TSP I)
               (FETCH (I-X I) (I-SYS-DATA-SEGMENT I))
               (I-Y I)
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (I-SYS-DATA-SEGMENT I)
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-MOVE_X_TSP-OKP
      (I)
      (ADD1-I-PCP I))

(DEFN I-MOVE_X_TSP-STEP
      (I)
      (I-STATE (ADD1-I-PC I)
               (I-CFP I)
               (I-CSP I)
               (I-TSP I)
               (I-TSP I)
               (I-Y I)
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (I-SYS-DATA-SEGMENT I)
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-MOVE_X_X-OKP
      (I)
      (ADD1-I-PCP I))

(DEFN I-MOVE_X_X-STEP
      (I)
      (I-STATE (ADD1-I-PC I)
               (I-CFP I)
               (I-CSP I)
               (I-TSP I)
               (I-X I)
               (I-Y I)
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (I-SYS-DATA-SEGMENT I)
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-MOVE_Y_*-OKP
      (I)
      (ADD2-I-PCP I))

(DEFN I-MOVE_Y_*-STEP
      (I)
      (I-STATE (ADD2-I-PC I)
               (I-CFP I)
               (I-CSP I)
               (I-TSP I)
               (I-X I)
               (I-NEXTWORD I)
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (I-SYS-DATA-SEGMENT I)
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-MOVE_Y_<Y{S}>-OKP
      (I)
      (AND (ADD1-I-PCP I)
           (I-OBJECTP-TYPE 'SYS-ADDR (I-Y I) I)
           (I-OBJECTP (FETCH (I-Y I) (I-SYS-DATA-SEGMENT I))
                      I)))

(DEFN I-MOVE_Y_<Y{S}>-STEP
      (I)
      (I-STATE (ADD1-I-PC I)
               (I-CFP I)
               (I-CSP I)
               (I-TSP I)
               (I-X I)
               (FETCH (I-Y I) (I-SYS-DATA-SEGMENT I))
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (I-SYS-DATA-SEGMENT I)
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-MOVE_Y_TSP-OKP
      (I)
      (ADD1-I-PCP I))

(DEFN I-MOVE_Y_TSP-STEP
      (I)
      (I-STATE (ADD1-I-PC I)
               (I-CFP I)
               (I-CSP I)
               (I-TSP I)
               (I-X I)
               (I-TSP I)
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (I-SYS-DATA-SEGMENT I)
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-NEG_<TSP>_<TSP>{I}-OKP
      (I)
      (AND (ADD1-I-PCP I)
           (NOT (EMPTY-STKP (I-TSP I)
                            (I-SYS-DATA-SEGMENT I)))
           (I-OBJECTP-TYPE 'INT
                           (FETCH (I-TSP I)
                                  (I-SYS-DATA-SEGMENT I))
                           I)
           (SMALL-INTEGERP (INEGATE (UNTAG (FETCH (I-TSP I)
                                                  (I-SYS-DATA-SEGMENT I))))
                           (I-WORD-SIZE I))))

(DEFN I-NEG_<TSP>_<TSP>{I}-STEP
      (I)
      (I-STATE (ADD1-I-PC I)
               (I-CFP I)
               (I-CSP I)
               (I-TSP I)
               (I-X I)
               (I-Y I)
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (DEPOSIT (TAG 'INT
                             (INEGATE (UNTAG (FETCH (I-TSP I)
                                                    (I-SYS-DATA-SEGMENT I)))))
                        (I-TSP I)
                        (I-SYS-DATA-SEGMENT I))
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-NOT_<TSP>_<TSP>{V}-OKP
      (I)
      (AND (ADD1-I-PCP I)
           (NOT (EMPTY-STKP (I-TSP I)
                            (I-SYS-DATA-SEGMENT I)))
           (I-OBJECTP-TYPE 'BITV
                           (FETCH (I-TSP I)
                                  (I-SYS-DATA-SEGMENT I))
                           I)))

(DEFN I-NOT_<TSP>_<TSP>{V}-STEP
      (I)
      (I-STATE (ADD1-I-PC I)
               (I-CFP I)
               (I-CSP I)
               (I-TSP I)
               (I-X I)
               (I-Y I)
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (DEPOSIT (TAG 'BITV
                             (NOT-BITV (UNTAG (FETCH (I-TSP I)
                                                     (I-SYS-DATA-SEGMENT I)))))
                        (I-TSP I)
                        (I-SYS-DATA-SEGMENT I))
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-OR_<TSP>{V}_X{V}-OKP
      (I)
      (AND (ADD1-I-PCP I)
           (NOT (EMPTY-STKP (I-TSP I)
                            (I-SYS-DATA-SEGMENT I)))
           (I-OBJECTP-TYPE 'BITV (I-X I) I)
           (I-OBJECTP-TYPE 'BITV
                           (FETCH (I-TSP I)
                                  (I-SYS-DATA-SEGMENT I))
                           I)))

(DEFN I-OR_<TSP>{V}_X{V}-STEP
      (I)
      (I-STATE (ADD1-I-PC I)
               (I-CFP I)
               (I-CSP I)
               (I-TSP I)
               (I-X I)
               (I-Y I)
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (DEPOSIT (TAG 'BITV
                             (OR-BITV (UNTAG (FETCH (I-TSP I)
                                                    (I-SYS-DATA-SEGMENT I)))
                                      (UNTAG (I-X I))))
                        (I-TSP I)
                        (I-SYS-DATA-SEGMENT I))
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-OR_<TSP>{B}_X{B}-OKP
      (I)
      (AND (ADD1-I-PCP I)
           (NOT (EMPTY-STKP (I-TSP I)
                            (I-SYS-DATA-SEGMENT I)))
           (I-OBJECTP-TYPE 'BOOL (I-X I) I)
           (I-OBJECTP-TYPE 'BOOL
                           (FETCH (I-TSP I)
                                  (I-SYS-DATA-SEGMENT I))
                           I)))

(DEFN I-OR_<TSP>{B}_X{B}-STEP
      (I)
      (I-STATE (ADD1-I-PC I)
               (I-CFP I)
               (I-CSP I)
               (I-TSP I)
               (I-X I)
               (I-Y I)
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (DEPOSIT (TAG 'BOOL
                             (OR-BOOL (UNTAG (FETCH (I-TSP I)
                                                    (I-SYS-DATA-SEGMENT I)))
                                      (UNTAG (I-X I))))
                        (I-TSP I)
                        (I-SYS-DATA-SEGMENT I))
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-SUB_<C>_<TSP>{A}_X{A}-OKP
      (I)
      (AND (ADD1-I-PCP I)
           (NOT (EMPTY-STKP (I-TSP I)
                            (I-SYS-DATA-SEGMENT I)))
           (I-OBJECTP-TYPE 'ADDR (I-X I) I)
           (I-OBJECTP-TYPE 'ADDR
                           (FETCH (I-TSP I)
                                  (I-SYS-DATA-SEGMENT I))
                           I)
           (EQUAL (AREA-NAME (FETCH (I-TSP I)
                                    (I-SYS-DATA-SEGMENT I)))
                  (AREA-NAME (I-X I)))))

(DEFN I-SUB_<C>_<TSP>{A}_X{A}-STEP
 (I)
 (I-STATE
  (ADD1-I-PC I)
  (I-CFP I)
  (I-CSP I)
  (I-TSP I)
  (I-X I)
  (I-Y I)
  (BOOL (LESSP (OFFSET (FETCH (I-TSP I)
                              (I-SYS-DATA-SEGMENT I)))
               (OFFSET (I-X I))))
  (I-V-FLG I)
  (I-N-FLG I)
  (I-Z-FLG I)
  (I-PROG-SEGMENT I)
  (I-USR-DATA-SEGMENT I)
  (DEPOSIT
     (TAG 'NAT
          (IF (LESSP (OFFSET (FETCH (I-TSP I)
                                    (I-SYS-DATA-SEGMENT I)))
                     (OFFSET (I-X I)))
              (DIFFERENCE (EXP 2 (I-WORD-SIZE I))
                          (DIFFERENCE (OFFSET (I-X I))
                                      (OFFSET (FETCH (I-TSP I)
                                                     (I-SYS-DATA-SEGMENT I)))))
              (DIFFERENCE (OFFSET (FETCH (I-TSP I)
                                         (I-SYS-DATA-SEGMENT I)))
                          (OFFSET (I-X I)))))
     (I-TSP I)
     (I-SYS-DATA-SEGMENT I))
  (I-WORD-SIZE I)
  'RUN))

(DEFN I-SUB_<C>_<TSP>{N}_X{N}-OKP
      (I)
      (AND (ADD1-I-PCP I)
           (NOT (EMPTY-STKP (I-TSP I)
                            (I-SYS-DATA-SEGMENT I)))
           (I-OBJECTP-TYPE 'NAT (I-X I) I)
           (I-OBJECTP-TYPE 'NAT
                           (FETCH (I-TSP I)
                                  (I-SYS-DATA-SEGMENT I))
                           I)))

(DEFN I-SUB_<C>_<TSP>{N}_X{N}-STEP
 (I)
 (I-STATE
  (ADD1-I-PC I)
  (I-CFP I)
  (I-CSP I)
  (I-TSP I)
  (I-X I)
  (I-Y I)
  (BOOL (LESSP (UNTAG (FETCH (I-TSP I)
                             (I-SYS-DATA-SEGMENT I)))
               (UNTAG (I-X I))))
  (I-V-FLG I)
  (I-N-FLG I)
  (I-Z-FLG I)
  (I-PROG-SEGMENT I)
  (I-USR-DATA-SEGMENT I)
  (DEPOSIT
      (TAG 'NAT
           (IF (LESSP (UNTAG (FETCH (I-TSP I)
                                    (I-SYS-DATA-SEGMENT I)))
                      (UNTAG (I-X I)))
               (DIFFERENCE (EXP 2 (I-WORD-SIZE I))
                           (DIFFERENCE (UNTAG (I-X I))
                                       (UNTAG (FETCH (I-TSP I)
                                                     (I-SYS-DATA-SEGMENT I)))))
               (DIFFERENCE (UNTAG (FETCH (I-TSP I)
                                         (I-SYS-DATA-SEGMENT I)))
                           (UNTAG (I-X I)))))
      (I-TSP I)
      (I-SYS-DATA-SEGMENT I))
  (I-WORD-SIZE I)
  'RUN))

(DEFN I-SUB_<NV>_<TSP>{I}_X{I}-OKP
      (I)
      (AND (ADD1-I-PCP I)
           (I-OBJECTP-TYPE 'INT
                           (FETCH (I-TSP I)
                                  (I-SYS-DATA-SEGMENT I))
                           I)
           (I-OBJECTP-TYPE 'INT (I-X I) I)))

(DEFN I-SUB_<NV>_<TSP>{I}_X{I}-STEP
 (I)
 (I-STATE
  (ADD1-I-PC I)
  (I-CFP I)
  (I-CSP I)
  (I-TSP I)
  (I-X I)
  (I-Y I)
  (I-C-FLG I)
  (BOOL
       (NOT (SMALL-INTEGERP (IDIFFERENCE (UNTAG (FETCH (I-TSP I)
                                                       (I-SYS-DATA-SEGMENT I)))
                                         (UNTAG (I-X I)))
                            (I-WORD-SIZE I))))
  (BOOL
   (NEGATIVEP
         (FIX-SMALL-INTEGER (IDIFFERENCE (UNTAG (FETCH (I-TSP I)
                                                       (I-SYS-DATA-SEGMENT I)))
                                         (UNTAG (I-X I)))
                            (I-WORD-SIZE I))))
  (I-Z-FLG I)
  (I-PROG-SEGMENT I)
  (I-USR-DATA-SEGMENT I)
  (DEPOSIT
    (TAG 'INT
         (FIX-SMALL-INTEGER (IDIFFERENCE (UNTAG (FETCH (I-TSP I)
                                                       (I-SYS-DATA-SEGMENT I)))
                                         (UNTAG (I-X I)))
                            (I-WORD-SIZE I)))
    (I-TSP I)
    (I-SYS-DATA-SEGMENT I))
  (I-WORD-SIZE I)
  'RUN))

(DEFN I-SUB_<TSP>{A}_X{N}-OKP
      (I)
      (AND (ADD1-I-PCP I)
           (NOT (EMPTY-STKP (I-TSP I)
                            (I-SYS-DATA-SEGMENT I)))
           (I-OBJECTP-TYPE 'NAT (I-X I) I)
           (I-OBJECTP-TYPE 'ADDR
                           (FETCH (I-TSP I)
                                  (I-SYS-DATA-SEGMENT I))
                           I)
           (NOT (LESSP (OFFSET (FETCH (I-TSP I)
                                      (I-SYS-DATA-SEGMENT I)))
                       (UNTAG (I-X I))))))

(DEFN I-SUB_<TSP>{A}_X{N}-STEP
      (I)
      (I-STATE (ADD1-I-PC I)
               (I-CFP I)
               (I-CSP I)
               (I-TSP I)
               (I-X I)
               (I-Y I)
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (DEPOSIT (SUB-ADDR (FETCH (I-TSP I)
                                         (I-SYS-DATA-SEGMENT I))
                                  (UNTAG (I-X I)))
                        (I-TSP I)
                        (I-SYS-DATA-SEGMENT I))
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-SUB_X{S}_Y{N}-OKP
      (I)
      (AND (ADD1-I-PCP I)
           (I-OBJECTP-TYPE 'SYS-ADDR (I-X I) I)
           (I-OBJECTP-TYPE 'NAT (I-Y I) I)
           (NOT (LESSP (OFFSET (I-X I))
                       (UNTAG (I-Y I))))))

(DEFN I-SUB_X{S}_Y{N}-STEP
      (I)
      (I-STATE (ADD1-I-PC I)
               (I-CFP I)
               (I-CSP I)
               (I-TSP I)
               (SUB-ADDR (I-X I) (UNTAG (I-Y I)))
               (I-Y I)
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (I-SYS-DATA-SEGMENT I)
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-SUB_<TSP>{I}_X{I}-OKP
      (I)
      (AND (ADD1-I-PCP I)
           (NOT (EMPTY-STKP (I-TSP I)
                            (I-SYS-DATA-SEGMENT I)))
           (I-OBJECTP-TYPE 'INT (I-X I) I)
           (I-OBJECTP-TYPE 'INT
                           (FETCH (I-TSP I)
                                  (I-SYS-DATA-SEGMENT I))
                           I)
           (SMALL-INTEGERP (IDIFFERENCE (UNTAG (FETCH (I-TSP I)
                                                      (I-SYS-DATA-SEGMENT I)))
                                        (UNTAG (I-X I)))
                           (I-WORD-SIZE I))))

(DEFN I-SUB_<TSP>{I}_X{I}-STEP
     (I)
     (I-STATE (ADD1-I-PC I)
              (I-CFP I)
              (I-CSP I)
              (I-TSP I)
              (I-X I)
              (I-Y I)
              (I-C-FLG I)
              (I-V-FLG I)
              (I-N-FLG I)
              (I-Z-FLG I)
              (I-PROG-SEGMENT I)
              (I-USR-DATA-SEGMENT I)
              (DEPOSIT (TAG 'INT
                            (IDIFFERENCE (UNTAG (FETCH (I-TSP I)
                                                       (I-SYS-DATA-SEGMENT I)))
                                         (UNTAG (I-X I))))
                       (I-TSP I)
                       (I-SYS-DATA-SEGMENT I))
              (I-WORD-SIZE I)
              'RUN))

(DEFN I-SUB_<TSP>{N}_X{N}-OKP
      (I)
      (AND (ADD1-I-PCP I)
           (NOT (EMPTY-STKP (I-TSP I)
                            (I-SYS-DATA-SEGMENT I)))
           (I-OBJECTP-TYPE 'NAT (I-X I) I)
           (I-OBJECTP-TYPE 'NAT
                           (FETCH (I-TSP I)
                                  (I-SYS-DATA-SEGMENT I))
                           I)
           (NOT (LESSP (UNTAG (FETCH (I-TSP I)
                                     (I-SYS-DATA-SEGMENT I)))
                       (UNTAG (I-X I))))))

(DEFN I-SUB_<TSP>{N}_X{N}-STEP
      (I)
      (I-STATE (ADD1-I-PC I)
               (I-CFP I)
               (I-CSP I)
               (I-TSP I)
               (I-X I)
               (I-Y I)
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (DEPOSIT (TAG 'NAT
                             (DIFFERENCE (UNTAG (FETCH (I-TSP I)
                                                       (I-SYS-DATA-SEGMENT I)))
                                         (UNTAG (I-X I))))
                        (I-TSP I)
                        (I-SYS-DATA-SEGMENT I))
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-SUB_<TSP>{S}_X{S}-OKP
      (I)
      (AND (ADD1-I-PCP I)
           (NOT (EMPTY-STKP (I-TSP I)
                            (I-SYS-DATA-SEGMENT I)))
           (I-OBJECTP-TYPE 'SYS-ADDR (I-X I) I)
           (I-OBJECTP-TYPE 'SYS-ADDR
                           (FETCH (I-TSP I)
                                  (I-SYS-DATA-SEGMENT I))
                           I)
           (EQUAL (AREA-NAME (FETCH (I-TSP I)
                                    (I-SYS-DATA-SEGMENT I)))
                  (AREA-NAME (I-X I)))
           (NOT (LESSP (OFFSET (FETCH (I-TSP I)
                                      (I-SYS-DATA-SEGMENT I)))
                       (OFFSET (I-X I))))))

(DEFN I-SUB_<TSP>{S}_X{S}-STEP
     (I)
     (I-STATE (ADD1-I-PC I)
              (I-CFP I)
              (I-CSP I)
              (I-TSP I)
              (I-X I)
              (I-Y I)
              (I-C-FLG I)
              (I-V-FLG I)
              (I-N-FLG I)
              (I-Z-FLG I)
              (I-PROG-SEGMENT I)
              (I-USR-DATA-SEGMENT I)
              (DEPOSIT (TAG 'NAT
                            (DIFFERENCE (OFFSET (FETCH (I-TSP I)
                                                       (I-SYS-DATA-SEGMENT I)))
                                        (OFFSET (I-X I))))
                       (I-TSP I)
                       (I-SYS-DATA-SEGMENT I))
              (I-WORD-SIZE I)
              'RUN))

(DEFN I-SUB_<Z>_X{S}_Y{S}-OKP
      (I)
      (AND (ADD1-I-PCP I)
           (I-OBJECTP-TYPE 'SYS-ADDR (I-X I) I)
           (I-OBJECTP-TYPE 'SYS-ADDR (I-Y I) I)
           (EQUAL (AREA-NAME (I-Y I))
                  (AREA-NAME (I-X I)))
           (NOT (LESSP (OFFSET (I-X I))
                       (OFFSET (I-Y I))))))

(DEFN I-SUB_<Z>_X{S}_Y{S}-STEP
      (I)
      (I-STATE (ADD1-I-PC I)
               (I-CFP I)
               (I-CSP I)
               (I-TSP I)
               (TAG 'NAT
                    (DIFFERENCE (OFFSET (I-X I))
                                (OFFSET (I-Y I))))
               (I-Y I)
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (BOOL (EQUAL (OFFSET (I-X I))
                            (OFFSET (I-Y I))))
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (I-SYS-DATA-SEGMENT I)
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-SUBB_<C>_X{N}_Y{N}-OKP
      (I)
      (AND (ADD1-I-PCP I)
           (I-OBJECTP-TYPE 'NAT (I-X I) I)
           (I-OBJECTP-TYPE 'NAT (I-Y I) I)))

(DEFN I-SUBB_<C>_X{N}_Y{N}-STEP
 (I)
 (I-STATE
      (ADD1-I-PC I)
      (I-CFP I)
      (I-CSP I)
      (I-TSP I)
      (TAG 'NAT
           (IF (LESSP (UNTAG (I-X I))
                      (PLUS (UNTAG (I-Y I))
                            (BOOL-TO-NAT (UNTAG (I-C-FLG I)))))
               (DIFFERENCE (EXP 2 (I-WORD-SIZE I))
                           (DIFFERENCE (PLUS (UNTAG (I-Y I))
                                             (BOOL-TO-NAT (UNTAG (I-C-FLG I))))
                                       (UNTAG (I-X I))))
               (DIFFERENCE (UNTAG (I-X I))
                           (PLUS (UNTAG (I-Y I))
                                 (BOOL-TO-NAT (UNTAG (I-C-FLG I)))))))
      (I-Y I)
      (BOOL (LESSP (UNTAG (I-X I))
                   (PLUS (UNTAG (I-Y I))
                         (BOOL-TO-NAT (UNTAG (I-C-FLG I))))))
      (I-V-FLG I)
      (I-N-FLG I)
      (I-Z-FLG I)
      (I-PROG-SEGMENT I)
      (I-USR-DATA-SEGMENT I)
      (I-SYS-DATA-SEGMENT I)
      (I-WORD-SIZE I)
      'RUN))

(DEFN I-SUBB_<V>_X{I}_Y{I}-OKP
      (I)
      (AND (ADD1-I-PCP I)
           (I-OBJECTP-TYPE 'INT (I-X I) I)
           (I-OBJECTP-TYPE 'INT (I-Y I) I)))

(DEFN I-SUBB_<V>_X{I}_Y{I}-STEP
 (I)
 (I-STATE
  (ADD1-I-PC I)
  (I-CFP I)
  (I-CSP I)
  (I-TSP I)
  (TAG 'INT
     (FIX-SMALL-INTEGER (IDIFFERENCE (UNTAG (I-X I))
                                     (IPLUS (UNTAG (I-Y I))
                                            (BOOL-TO-NAT (UNTAG (I-C-FLG I)))))
                        (I-WORD-SIZE I)))
  (I-Y I)
  (I-C-FLG I)
  (BOOL
   (NOT (SMALL-INTEGERP (IDIFFERENCE (UNTAG (I-X I))
                                     (IPLUS (UNTAG (I-Y I))
                                            (BOOL-TO-NAT (UNTAG (I-C-FLG I)))))
                        (I-WORD-SIZE I))))
  (I-N-FLG I)
  (I-Z-FLG I)
  (I-PROG-SEGMENT I)
  (I-USR-DATA-SEGMENT I)
  (I-SYS-DATA-SEGMENT I)
  (I-WORD-SIZE I)
  'RUN))

(DEFN I-TPOP_<C>_X-OKP
      (I)
      (AND (ADD1-I-PCP I)
           (NOT (EMPTY-STKP (I-TSP I)
                            (I-SYS-DATA-SEGMENT I)))
           (I-OBJECTP (FETCH (I-TSP I)
                             (I-SYS-DATA-SEGMENT I))
                      I)))

(DEFN I-TPOP_<C>_X-STEP
      (I)
      (I-STATE (ADD1-I-PC I)
               (I-CFP I)
               (I-CSP I)
               (POP-STK (I-TSP I))
               (FETCH (I-TSP I)
                      (I-SYS-DATA-SEGMENT I))
               (I-Y I)
               (TAG 'BOOL 'F)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (I-SYS-DATA-SEGMENT I)
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-TPOP_<X{A}>-OKP
      (I)
      (AND (ADD1-I-PCP I)
           (NOT (EMPTY-STKP (I-TSP I)
                            (I-SYS-DATA-SEGMENT I)))
           (I-OBJECTP-TYPE 'ADDR (I-X I) I)))

(DEFN I-TPOP_<X{A}>-STEP
      (I)
      (I-STATE (ADD1-I-PC I)
               (I-CFP I)
               (I-CSP I)
               (POP-STK (I-TSP I))
               (I-X I)
               (I-Y I)
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (DEPOSIT (FETCH (I-TSP I)
                               (I-SYS-DATA-SEGMENT I))
                        (I-X I)
                        (I-USR-DATA-SEGMENT I))
               (I-SYS-DATA-SEGMENT I)
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-TPOP_<X{S}>-OKP
      (I)
      (AND (ADD1-I-PCP I)
           (NOT (EMPTY-STKP (I-TSP I)
                            (I-SYS-DATA-SEGMENT I)))
           (I-OBJECTP-TYPE 'SYS-ADDR
                           (I-X I)
                           I)))

(DEFN I-TPOP_<X{S}>-STEP
      (I)
      (I-STATE (ADD1-I-PC I)
               (I-CFP I)
               (I-CSP I)
               (POP-STK (I-TSP I))
               (I-X I)
               (I-Y I)
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (DEPOSIT (FETCH (I-TSP I)
                               (I-SYS-DATA-SEGMENT I))
                        (I-X I)
                        (I-SYS-DATA-SEGMENT I))
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-TPOP_PC-OKP
      (I)
      (AND (NOT (EMPTY-STKP (I-TSP I)
                            (I-SYS-DATA-SEGMENT I)))
           (I-OBJECTP-TYPE 'PC
                           (FETCH (I-TSP I)
                                  (I-SYS-DATA-SEGMENT I))
                           I)))

(DEFN I-TPOP_PC-STEP
      (I)
      (I-STATE (IPC (UNTAG (FETCH (I-TSP I)
                                  (I-SYS-DATA-SEGMENT I)))
                    (DEFINITION (AREA-NAME (FETCH (I-TSP I)
                                                  (I-SYS-DATA-SEGMENT I)))
                                (I-PROG-SEGMENT I)))
               (I-CFP I)
               (I-CSP I)
               (POP-STK (I-TSP I))
               (I-X I)
               (I-Y I)
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (I-SYS-DATA-SEGMENT I)
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-TPOP_X-OKP
      (I)
      (AND (ADD1-I-PCP I)
           (NOT (EMPTY-STKP (I-TSP I)
                            (I-SYS-DATA-SEGMENT I)))
           (I-OBJECTP (FETCH (I-TSP I)
                             (I-SYS-DATA-SEGMENT I))
                      I)))

(DEFN I-TPOP_X-STEP
      (I)
      (I-STATE (ADD1-I-PC I)
               (I-CFP I)
               (I-CSP I)
               (POP-STK (I-TSP I))
               (FETCH (I-TSP I)
                      (I-SYS-DATA-SEGMENT I))
               (I-Y I)
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (I-SYS-DATA-SEGMENT I)
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-TPOP_Y-OKP
      (I)
      (AND (ADD1-I-PCP I)
           (NOT (EMPTY-STKP (I-TSP I)
                            (I-SYS-DATA-SEGMENT I)))
           (I-OBJECTP (FETCH (I-TSP I)
                             (I-SYS-DATA-SEGMENT I))
                      I)))

(DEFN I-TPOP_Y-STEP
      (I)
      (I-STATE (ADD1-I-PC I)
               (I-CFP I)
               (I-CSP I)
               (POP-STK (I-TSP I))
               (I-X I)
               (FETCH (I-TSP I)
                      (I-SYS-DATA-SEGMENT I))
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (I-SYS-DATA-SEGMENT I)
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-TPOP{V}_<Z>_Y-OKP
      (I)
      (AND (ADD1-I-PCP I)
           (NOT (EMPTY-STKP (I-TSP I)
                            (I-SYS-DATA-SEGMENT I)))
           (I-OBJECTP-TYPE 'BITV
                           (FETCH (I-TSP I)
                                  (I-SYS-DATA-SEGMENT I))
                           I)))

(DEFN I-TPOP{V}_<Z>_Y-STEP
      (I)
      (I-STATE (ADD1-I-PC I)
               (I-CFP I)
               (I-CSP I)
               (POP-STK (I-TSP I))
               (I-X I)
               (FETCH (I-TSP I)
                      (I-SYS-DATA-SEGMENT I))
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (BOOL (ALL-ZERO-BITVP (UNTAG (FETCH (I-TSP I)
                                                   (I-SYS-DATA-SEGMENT I)))))
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (I-SYS-DATA-SEGMENT I)
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-TPOP{B}_<Z>_Y-OKP
      (I)
      (AND (ADD1-I-PCP I)
           (NOT (EMPTY-STKP (I-TSP I)
                            (I-SYS-DATA-SEGMENT I)))
           (I-OBJECTP-TYPE 'BOOL
                           (FETCH (I-TSP I)
                                  (I-SYS-DATA-SEGMENT I))
                           I)))

(DEFN I-TPOP{B}_<Z>_Y-STEP
      (I)
      (I-STATE (ADD1-I-PC I)
               (I-CFP I)
               (I-CSP I)
               (POP-STK (I-TSP I))
               (I-X I)
               (FETCH (I-TSP I)
                      (I-SYS-DATA-SEGMENT I))
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (BOOL (EQUAL (UNTAG (FETCH (I-TSP I)
                                          (I-SYS-DATA-SEGMENT I)))
                            'F))
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (I-SYS-DATA-SEGMENT I)
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-TPOP{I}_<ZN>_Y-OKP
      (I)
      (AND (ADD1-I-PCP I)
           (NOT (EMPTY-STKP (I-TSP I)
                            (I-SYS-DATA-SEGMENT I)))
           (I-OBJECTP-TYPE 'INT
                           (FETCH (I-TSP I)
                                  (I-SYS-DATA-SEGMENT I))
                           I)))

(DEFN I-TPOP{I}_<ZN>_Y-STEP
      (I)
      (I-STATE (ADD1-I-PC I)
               (I-CFP I)
               (I-CSP I)
               (POP-STK (I-TSP I))
               (I-X I)
               (FETCH (I-TSP I)
                      (I-SYS-DATA-SEGMENT I))
               (I-C-FLG I)
               (I-V-FLG I)
               (BOOL (NEGATIVEP (UNTAG (FETCH (I-TSP I)
                                              (I-SYS-DATA-SEGMENT I)))))
               (BOOL (EQUAL (UNTAG (FETCH (I-TSP I)
                                          (I-SYS-DATA-SEGMENT I)))
                            0))
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (I-SYS-DATA-SEGMENT I)
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-TPOP{N}_<Z>_Y-OKP
      (I)
      (AND (ADD1-I-PCP I)
           (NOT (EMPTY-STKP (I-TSP I)
                            (I-SYS-DATA-SEGMENT I)))
           (I-OBJECTP-TYPE 'NAT
                           (FETCH (I-TSP I)
                                  (I-SYS-DATA-SEGMENT I))
                           I)))

(DEFN I-TPOP{N}_<Z>_Y-STEP
      (I)
      (I-STATE (ADD1-I-PC I)
               (I-CFP I)
               (I-CSP I)
               (POP-STK (I-TSP I))
               (I-X I)
               (FETCH (I-TSP I)
                      (I-SYS-DATA-SEGMENT I))
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (BOOL (EQUAL (UNTAG (FETCH (I-TSP I)
                                          (I-SYS-DATA-SEGMENT I)))
                            0))
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (I-SYS-DATA-SEGMENT I)
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-TPUSH_*-OKP
      (I)
      (AND (ADD2-I-PCP I)
           (I-OBJECTP (I-NEXTWORD I) I)
           (NOT (ZEROP (FREE-STK-SIZE (I-TSP I))))))

(DEFN I-TPUSH_*-STEP
      (I)
      (I-STATE (ADD2-I-PC I)
               (I-CFP I)
               (I-CSP I)
               (PUSH-STK (I-TSP I))
               (I-X I)
               (I-Y I)
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (DEPOSIT (I-NEXTWORD I)
                        (PUSH-STK (I-TSP I))
                        (I-SYS-DATA-SEGMENT I))
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-TPUSH_<X{A}>-OKP
      (I)
      (AND (ADD1-I-PCP I)
           (NOT (ZEROP (FREE-STK-SIZE (I-TSP I))))
           (I-OBJECTP-TYPE 'ADDR (I-X I) I)
           (I-OBJECTP (FETCH (I-X I) (I-USR-DATA-SEGMENT I))
                      I)))

(DEFN I-TPUSH_<X{A}>-STEP
      (I)
      (I-STATE (ADD1-I-PC I)
               (I-CFP I)
               (I-CSP I)
               (PUSH-STK (I-TSP I))
               (I-X I)
               (I-Y I)
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (DEPOSIT (FETCH (I-X I) (I-USR-DATA-SEGMENT I))
                        (PUSH-STK (I-TSP I))
                        (I-SYS-DATA-SEGMENT I))
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-TPUSH_<X{S}>-OKP
      (I)
      (AND (ADD1-I-PCP I)
           (NOT (ZEROP (FREE-STK-SIZE (I-TSP I))))
           (I-OBJECTP-TYPE 'SYS-ADDR
                           (I-X I)
                           I)))

(DEFN I-TPUSH_<X{S}>-STEP
      (I)
      (I-STATE (ADD1-I-PC I)
               (I-CFP I)
               (I-CSP I)
               (PUSH-STK (I-TSP I))
               (I-X I)
               (I-Y I)
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (DEPOSIT (FETCH (I-X I) (I-SYS-DATA-SEGMENT I))
                        (PUSH-STK (I-TSP I))
                        (I-SYS-DATA-SEGMENT I))
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-TPUSH_CSP-OKP
      (I)
      (AND (ADD1-I-PCP I)
           (NOT (ZEROP (FREE-STK-SIZE (I-TSP I))))))

(DEFN I-TPUSH_CSP-STEP
      (I)
      (I-STATE (ADD1-I-PC I)
               (I-CFP I)
               (I-CSP I)
               (PUSH-STK (I-TSP I))
               (I-X I)
               (I-Y I)
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (DEPOSIT (I-CSP I)
                        (PUSH-STK (I-TSP I))
                        (I-SYS-DATA-SEGMENT I))
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-TPUSH_TSP-OKP
      (I)
      (AND (ADD1-I-PCP I)
           (NOT (ZEROP (FREE-STK-SIZE (I-TSP I))))))

(DEFN I-TPUSH_TSP-STEP
      (I)
      (I-STATE (ADD1-I-PC I)
               (I-CFP I)
               (I-CSP I)
               (PUSH-STK (I-TSP I))
               (I-X I)
               (I-Y I)
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (DEPOSIT (I-TSP I)
                        (PUSH-STK (I-TSP I))
                        (I-SYS-DATA-SEGMENT I))
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-TPUSH_X-OKP
      (I)
      (AND (ADD1-I-PCP I)
           (NOT (ZEROP (FREE-STK-SIZE (I-TSP I))))
           (I-OBJECTP (I-X I) I)))

(DEFN I-TPUSH_X-STEP
      (I)
      (I-STATE (ADD1-I-PC I)
               (I-CFP I)
               (I-CSP I)
               (PUSH-STK (I-TSP I))
               (I-X I)
               (I-Y I)
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (DEPOSIT (I-X I)
                        (PUSH-STK (I-TSP I))
                        (I-SYS-DATA-SEGMENT I))
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-XOR_<TSP>_<TSP>-OKP
      (I)
      (AND (ADD1-I-PCP I)
           (NOT (EMPTY-STKP (I-TSP I)
                            (I-SYS-DATA-SEGMENT I)))))

(DEFN I-XOR_<TSP>_<TSP>-STEP
      (I)
      (I-STATE (ADD1-I-PC I)
               (I-CFP I)
               (I-CSP I)
               (I-TSP I)
               (I-X I)
               (I-Y I)
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (DEPOSIT (TAG 'BOOL 'F)
                        (I-TSP I)
                        (I-SYS-DATA-SEGMENT I))
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-XOR_<TSP>{V}_X{V}-OKP
      (I)
      (AND (ADD1-I-PCP I)
           (NOT (EMPTY-STKP (I-TSP I)
                            (I-SYS-DATA-SEGMENT I)))
           (I-OBJECTP-TYPE 'BITV (I-X I) I)
           (I-OBJECTP-TYPE 'BITV
                           (FETCH (I-TSP I)
                                  (I-SYS-DATA-SEGMENT I))
                           I)))

(DEFN I-XOR_<TSP>{V}_X{V}-STEP
      (I)
      (I-STATE (ADD1-I-PC I)
               (I-CFP I)
               (I-CSP I)
               (I-TSP I)
               (I-X I)
               (I-Y I)
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (DEPOSIT (TAG 'BITV
                             (XOR-BITV (UNTAG (FETCH (I-TSP I)
                                                     (I-SYS-DATA-SEGMENT I)))
                                       (UNTAG (I-X I))))
                        (I-TSP I)
                        (I-SYS-DATA-SEGMENT I))
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-XOR_<TSP>{B}_*{B}-OKP
      (I)
      (AND (ADD2-I-PCP I)
           (NOT (EMPTY-STKP (I-TSP I)
                            (I-SYS-DATA-SEGMENT I)))
           (I-OBJECTP-TYPE 'BOOL
                           (FETCH (I-TSP I)
                                  (I-SYS-DATA-SEGMENT I))
                           I)
           (I-OBJECTP-TYPE 'BOOL
                           (I-NEXTWORD I)
                           I)))

(DEFN I-XOR_<TSP>{B}_*{B}-STEP
      (I)
      (I-STATE (ADD2-I-PC I)
               (I-CFP I)
               (I-CSP I)
               (I-TSP I)
               (I-X I)
               (I-Y I)
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (DEPOSIT (TAG 'BOOL
                             (XOR-BOOL (UNTAG (FETCH (I-TSP I)
                                                     (I-SYS-DATA-SEGMENT I)))
                                       (UNTAG (I-NEXTWORD I))))
                        (I-TSP I)
                        (I-SYS-DATA-SEGMENT I))
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-XOR_<TSP>{B}_X{B}-OKP
      (I)
      (AND (ADD1-I-PCP I)
           (NOT (EMPTY-STKP (I-TSP I)
                            (I-SYS-DATA-SEGMENT I)))
           (I-OBJECTP-TYPE 'BOOL
                           (FETCH (I-TSP I)
                                  (I-SYS-DATA-SEGMENT I))
                           I)
           (I-OBJECTP-TYPE 'BOOL (I-X I) I)))

(DEFN I-XOR_<TSP>{B}_X{B}-STEP
      (I)
      (I-STATE (ADD1-I-PC I)
               (I-CFP I)
               (I-CSP I)
               (I-TSP I)
               (I-X I)
               (I-Y I)
               (I-C-FLG I)
               (I-V-FLG I)
               (I-N-FLG I)
               (I-Z-FLG I)
               (I-PROG-SEGMENT I)
               (I-USR-DATA-SEGMENT I)
               (DEPOSIT (TAG 'BOOL
                             (XOR-BOOL (UNTAG (FETCH (I-TSP I)
                                                     (I-SYS-DATA-SEGMENT I)))
                                       (UNTAG (I-X I))))
                        (I-TSP I)
                        (I-SYS-DATA-SEGMENT I))
               (I-WORD-SIZE I)
               'RUN))

(DEFN I-XOR_<Z>_<TSP>_X-OKP
      (I)
      (AND (ADD1-I-PCP I)
           (NOT (EMPTY-STKP (I-TSP I)
                            (I-SYS-DATA-SEGMENT I)))
           (I-USR-DATA-OBJECTP (I-X I) I)
           (I-USR-DATA-OBJECTP (FETCH (I-TSP I)
                                      (I-SYS-DATA-SEGMENT I))
                               I)
           (EQUAL (TYPE (I-X I))
                  (TYPE (FETCH (I-TSP I)
                               (I-SYS-DATA-SEGMENT I))))))

; Note: This step function is different from all the others in that it
; takes a second argument!  The problem is that to xor any two
; addresses we must know where they are loaded to compute the
; resultant bit vector.  In the days before we added load-addr, the
; address 0 was built into this definition and this stepper was like
; all the others.  But now we have to supply it.  We could have made
; it part of the I state, but that would have required changing all
; the steppers to construct the new sized state and might have
; required other changes (e.g., in proving that it is unchanged?).  So
; we have just added it to this one stepper, which will be handled
; specially in by i-ins-step.  Of course, we have to add load-addr as
; an argument to the I machine itself.  Sigh.

(DEFN I-XOR_<Z>_<TSP>_X-STEP (I LOAD-ADDR)
  (I-STATE (ADD1-I-PC I)
           (I-CFP I)
           (I-CSP I)
           (I-TSP I)
           (I-X I)
           (I-Y I)
           (I-C-FLG I)
           (I-V-FLG I)
           (I-N-FLG I)
           (BOOL (EQUAL (FETCH (I-TSP I)
                               (I-SYS-DATA-SEGMENT I))
                        (I-X I)))
           (I-PROG-SEGMENT I)
           (I-USR-DATA-SEGMENT I)
           (DEPOSIT (TAG 'BITV
                         (XOR-XXX (FETCH (I-TSP I)
                                         (I-SYS-DATA-SEGMENT I))
                                  (I-X I)
                                  I
                                  LOAD-ADDR))
                    (I-TSP I)
                    (I-SYS-DATA-SEGMENT I))
           (I-WORD-SIZE I)
           'RUN))

(DEFN I-INS-OKP
      (INS I)
      (AND (EQUAL (CDR INS) NIL)
           (CASE (CAR INS)
                 (ADD_<C>_X_X{N} (I-ADD_<C>_X_X{N}-OKP I))
                 (ADD_<TSP>_<TSP>{V} (I-ADD_<TSP>_<TSP>{V}-OKP I))
                 (ADD_<TSP>_<TSP>{N} (I-ADD_<TSP>_<TSP>{N}-OKP I))
                 (ADD_<TSP>{A}_X{N} (I-ADD_<TSP>{A}_X{N}-OKP I))
                 (ADD_TSP_*{N} (I-ADD_TSP_*{N}-OKP I))
                 (ADD_TSP_X{N} (I-ADD_TSP_X{N}-OKP I))
                 (ADD_<TSP>{I}_X{I} (I-ADD_<TSP>{I}_X{I}-OKP I))
                 (ADD_<TSP>{N}_X{N} (I-ADD_<TSP>{N}_X{N}-OKP I))
                 (ADD_PC_X{N} (I-ADD_PC_X{N}-OKP I))
                 (ADD_X_X{N} (I-ADD_X_X{N}-OKP I))
                 (ADD_X{N}_CSP (I-ADD_X{N}_CSP-OKP I))
                 (ADDC_<C>_X{N}_Y{N} (I-ADDC_<C>_X{N}_Y{N}-OKP I))
                 (ADDC_<V>_X{I}_Y{I} (I-ADDC_<V>_X{I}_Y{I}-OKP I))
                 (AND_<TSP>{V}_X{V} (I-AND_<TSP>{V}_X{V}-OKP I))
                 (AND_<TSP>{B}_X{B} (I-AND_<TSP>{B}_X{B}-OKP I))
                 (ASR_<C>_<TSP>_<TSP>{B} (I-ASR_<C>_<TSP>_<TSP>{B}-OKP I))
                 (CPOP_CFP (I-CPOP_CFP-OKP I))
                 (CPOP_PC (I-CPOP_PC-OKP I))
                 (CPUSH_* (I-CPUSH_*-OKP I))
                 (CPUSH_<TSP>+ (I-CPUSH_<TSP>+-OKP I))
                 (CPUSH_CFP (I-CPUSH_CFP-OKP I))
                 (DECR_<TSP>_<TSP>{I} (I-DECR_<TSP>_<TSP>{I}-OKP I))
                 (DECR_<TSP>_<TSP>{N} (I-DECR_<TSP>_<TSP>{N}-OKP I))
                 (INCR_<TSP>_<TSP>{I} (I-INCR_<TSP>_<TSP>{I}-OKP I))
                 (INCR_<TSP>_<TSP>{N} (I-INCR_<TSP>_<TSP>{N}-OKP I))
                 (INCR_Y_Y{N} (I-INCR_Y_Y{N}-OKP I))
                 (INT-TO-NAT (I-INT-TO-NAT-OKP I))
                 (JUMP-N_X (I-JUMP-N_X-OKP I))
                 (JUMP-NN_X (I-JUMP-NN_X-OKP I))
                 (JUMP-NZ_X (I-JUMP-NZ_X-OKP I))
                 (JUMP-Z_X (I-JUMP-Z_X-OKP I))
                 (JUMP_* (I-JUMP_*-OKP I))
                 (JUMP_X{SUBR} (I-JUMP_X{SUBR}-OKP I))
                 (LSR_<C>_X_X{N} (I-LSR_<C>_X_X{N}-OKP I))
                 (LSR_<TSP>_<TSP>{V} (I-LSR_<TSP>_<TSP>{V}-OKP I))
                 (MOVE-C_<TSP>_* (I-MOVE-C_<TSP>_*-OKP I))
                 (MOVE-V_<TSP>_* (I-MOVE-V_<TSP>_*-OKP I))
                 (MOVE-Z_<TSP>_* (I-MOVE-Z_<TSP>_*-OKP I))
                 (MOVE-N_X_* (I-MOVE-N_X_*-OKP I))
                 (MOVE_<TSP>_* (I-MOVE_<TSP>_*-OKP I))
                 (MOVE_<X{A}>_<TSP> (I-MOVE_<X{A}>_<TSP>-OKP I))
                 (MOVE_<X{S}>_<TSP> (I-MOVE_<X{S}>_<TSP>-OKP I))
                 (MOVE_CFP_CSP (I-MOVE_CFP_CSP-OKP I))
                 (MOVE_CSP_CFP (I-MOVE_CSP_CFP-OKP I))
                 (MOVE_X_* (I-MOVE_X_*-OKP I))
                 (MOVE_X_<X{S}> (I-MOVE_X_<X{S}>-OKP I))
                 (MOVE_X_TSP (I-MOVE_X_TSP-OKP I))
                 (MOVE_X_X (I-MOVE_X_X-OKP I))
                 (MOVE_Y_* (I-MOVE_Y_*-OKP I))
                 (MOVE_Y_<Y{S}> (I-MOVE_Y_<Y{S}>-OKP I))
                 (MOVE_Y_TSP (I-MOVE_Y_TSP-OKP I))
                 (NEG_<TSP>_<TSP>{I} (I-NEG_<TSP>_<TSP>{I}-OKP I))
                 (NOT_<TSP>_<TSP>{V} (I-NOT_<TSP>_<TSP>{V}-OKP I))
                 (OR_<TSP>{V}_X{V} (I-OR_<TSP>{V}_X{V}-OKP I))
                 (OR_<TSP>{B}_X{B} (I-OR_<TSP>{B}_X{B}-OKP I))
                 (SUB_<C>_<TSP>{A}_X{A} (I-SUB_<C>_<TSP>{A}_X{A}-OKP I))
                 (SUB_<C>_<TSP>{N}_X{N} (I-SUB_<C>_<TSP>{N}_X{N}-OKP I))
                 (SUB_<NV>_<TSP>{I}_X{I} (I-SUB_<NV>_<TSP>{I}_X{I}-OKP I))
                 (SUB_<TSP>{A}_X{N} (I-SUB_<TSP>{A}_X{N}-OKP I))
                 (SUB_X{S}_Y{N} (I-SUB_X{S}_Y{N}-OKP I))
                 (SUB_<TSP>{I}_X{I} (I-SUB_<TSP>{I}_X{I}-OKP I))
                 (SUB_<TSP>{N}_X{N} (I-SUB_<TSP>{N}_X{N}-OKP I))
                 (SUB_<TSP>{S}_X{S} (I-SUB_<TSP>{S}_X{S}-OKP I))
                 (SUB_<Z>_X{S}_Y{S} (I-SUB_<Z>_X{S}_Y{S}-OKP I))
                 (SUBB_<C>_X{N}_Y{N} (I-SUBB_<C>_X{N}_Y{N}-OKP I))
                 (SUBB_<V>_X{I}_Y{I} (I-SUBB_<V>_X{I}_Y{I}-OKP I))
                 (TPOP_<C>_X (I-TPOP_<C>_X-OKP I))
                 (TPOP_<X{A}> (I-TPOP_<X{A}>-OKP I))
                 (TPOP_<X{S}> (I-TPOP_<X{S}>-OKP I))
                 (TPOP_PC (I-TPOP_PC-OKP I))
                 (TPOP_X (I-TPOP_X-OKP I))
                 (TPOP_Y (I-TPOP_Y-OKP I))
                 (TPOP{V}_<Z>_Y (I-TPOP{V}_<Z>_Y-OKP I))
                 (TPOP{B}_<Z>_Y (I-TPOP{B}_<Z>_Y-OKP I))
                 (TPOP{I}_<ZN>_Y (I-TPOP{I}_<ZN>_Y-OKP I))
                 (TPOP{N}_<Z>_Y (I-TPOP{N}_<Z>_Y-OKP I))
                 (TPUSH_* (I-TPUSH_*-OKP I))
                 (TPUSH_<X{A}> (I-TPUSH_<X{A}>-OKP I))
                 (TPUSH_<X{S}> (I-TPUSH_<X{S}>-OKP I))
                 (TPUSH_CSP (I-TPUSH_CSP-OKP I))
                 (TPUSH_TSP (I-TPUSH_TSP-OKP I))
                 (TPUSH_X (I-TPUSH_X-OKP I))
                 (XOR_<TSP>_<TSP> (I-XOR_<TSP>_<TSP>-OKP I))
                 (XOR_<TSP>{V}_X{V} (I-XOR_<TSP>{V}_X{V}-OKP I))
                 (XOR_<TSP>{B}_*{B} (I-XOR_<TSP>{B}_*{B}-OKP I))
                 (XOR_<TSP>{B}_X{B} (I-XOR_<TSP>{B}_X{B}-OKP I))
                 (XOR_<Z>_<TSP>_X (I-XOR_<Z>_<TSP>_X-OKP I))
                 (OTHERWISE F))))

(DEFN I-INS-STEP (INS I LOAD-ADDR)
      (CASE (CAR INS)
            (ADD_<C>_X_X{N} (I-ADD_<C>_X_X{N}-STEP I))
            (ADD_<TSP>_<TSP>{V} (I-ADD_<TSP>_<TSP>{V}-STEP I))
            (ADD_<TSP>_<TSP>{N} (I-ADD_<TSP>_<TSP>{N}-STEP I))
            (ADD_<TSP>{A}_X{N} (I-ADD_<TSP>{A}_X{N}-STEP I))
            (ADD_TSP_*{N} (I-ADD_TSP_*{N}-STEP I))
            (ADD_TSP_X{N} (I-ADD_TSP_X{N}-STEP I))
            (ADD_<TSP>{I}_X{I} (I-ADD_<TSP>{I}_X{I}-STEP I))
            (ADD_<TSP>{N}_X{N} (I-ADD_<TSP>{N}_X{N}-STEP I))
            (ADD_PC_X{N} (I-ADD_PC_X{N}-STEP I))
            (ADD_X_X{N} (I-ADD_X_X{N}-STEP I))
            (ADD_X{N}_CSP (I-ADD_X{N}_CSP-STEP I))
            (ADDC_<C>_X{N}_Y{N} (I-ADDC_<C>_X{N}_Y{N}-STEP I))
            (ADDC_<V>_X{I}_Y{I} (I-ADDC_<V>_X{I}_Y{I}-STEP I))
            (AND_<TSP>{V}_X{V} (I-AND_<TSP>{V}_X{V}-STEP I))
            (AND_<TSP>{B}_X{B} (I-AND_<TSP>{B}_X{B}-STEP I))
            (ASR_<C>_<TSP>_<TSP>{B} (I-ASR_<C>_<TSP>_<TSP>{B}-STEP I))
            (CPOP_CFP (I-CPOP_CFP-STEP I))
            (CPOP_PC (I-CPOP_PC-STEP I))
            (CPUSH_* (I-CPUSH_*-STEP I))
            (CPUSH_<TSP>+ (I-CPUSH_<TSP>+-STEP I))
            (CPUSH_CFP (I-CPUSH_CFP-STEP I))
            (DECR_<TSP>_<TSP>{I} (I-DECR_<TSP>_<TSP>{I}-STEP I))
            (DECR_<TSP>_<TSP>{N} (I-DECR_<TSP>_<TSP>{N}-STEP I))
            (INCR_<TSP>_<TSP>{I} (I-INCR_<TSP>_<TSP>{I}-STEP I))
            (INCR_<TSP>_<TSP>{N} (I-INCR_<TSP>_<TSP>{N}-STEP I))
            (INCR_Y_Y{N} (I-INCR_Y_Y{N}-STEP I))
            (INT-TO-NAT (I-INT-TO-NAT-STEP I))
            (JUMP-N_X (I-JUMP-N_X-STEP I))
            (JUMP-NN_X (I-JUMP-NN_X-STEP I))
            (JUMP-NZ_X (I-JUMP-NZ_X-STEP I))
            (JUMP-Z_X (I-JUMP-Z_X-STEP I))
            (JUMP_* (I-JUMP_*-STEP I))
            (JUMP_X{SUBR} (I-JUMP_X{SUBR}-STEP I))
            (LSR_<C>_X_X{N} (I-LSR_<C>_X_X{N}-STEP I))
            (LSR_<TSP>_<TSP>{V} (I-LSR_<TSP>_<TSP>{V}-STEP I))
            (MOVE-C_<TSP>_* (I-MOVE-C_<TSP>_*-STEP I))
            (MOVE-V_<TSP>_* (I-MOVE-V_<TSP>_*-STEP I))
            (MOVE-Z_<TSP>_* (I-MOVE-Z_<TSP>_*-STEP I))
            (MOVE-N_X_* (I-MOVE-N_X_*-STEP I))
            (MOVE_<TSP>_* (I-MOVE_<TSP>_*-STEP I))
            (MOVE_<X{A}>_<TSP> (I-MOVE_<X{A}>_<TSP>-STEP I))
            (MOVE_<X{S}>_<TSP> (I-MOVE_<X{S}>_<TSP>-STEP I))
            (MOVE_CFP_CSP (I-MOVE_CFP_CSP-STEP I))
            (MOVE_CSP_CFP (I-MOVE_CSP_CFP-STEP I))
            (MOVE_X_* (I-MOVE_X_*-STEP I))
            (MOVE_X_<X{S}> (I-MOVE_X_<X{S}>-STEP I))
            (MOVE_X_TSP (I-MOVE_X_TSP-STEP I))
            (MOVE_X_X (I-MOVE_X_X-STEP I))
            (MOVE_Y_* (I-MOVE_Y_*-STEP I))
            (MOVE_Y_<Y{S}> (I-MOVE_Y_<Y{S}>-STEP I))
            (MOVE_Y_TSP (I-MOVE_Y_TSP-STEP I))
            (NEG_<TSP>_<TSP>{I} (I-NEG_<TSP>_<TSP>{I}-STEP I))
            (NOT_<TSP>_<TSP>{V} (I-NOT_<TSP>_<TSP>{V}-STEP I))
            (OR_<TSP>{V}_X{V} (I-OR_<TSP>{V}_X{V}-STEP I))
            (OR_<TSP>{B}_X{B} (I-OR_<TSP>{B}_X{B}-STEP I))
            (SUB_<C>_<TSP>{A}_X{A} (I-SUB_<C>_<TSP>{A}_X{A}-STEP I))
            (SUB_<C>_<TSP>{N}_X{N} (I-SUB_<C>_<TSP>{N}_X{N}-STEP I))
            (SUB_<NV>_<TSP>{I}_X{I} (I-SUB_<NV>_<TSP>{I}_X{I}-STEP I))
            (SUB_<TSP>{A}_X{N} (I-SUB_<TSP>{A}_X{N}-STEP I))
            (SUB_X{S}_Y{N} (I-SUB_X{S}_Y{N}-STEP I))
            (SUB_<TSP>{I}_X{I} (I-SUB_<TSP>{I}_X{I}-STEP I))
            (SUB_<TSP>{N}_X{N} (I-SUB_<TSP>{N}_X{N}-STEP I))
            (SUB_<TSP>{S}_X{S} (I-SUB_<TSP>{S}_X{S}-STEP I))
            (SUB_<Z>_X{S}_Y{S} (I-SUB_<Z>_X{S}_Y{S}-STEP I))
            (SUBB_<C>_X{N}_Y{N} (I-SUBB_<C>_X{N}_Y{N}-STEP I))
            (SUBB_<V>_X{I}_Y{I} (I-SUBB_<V>_X{I}_Y{I}-STEP I))
            (TPOP_<C>_X (I-TPOP_<C>_X-STEP I))
            (TPOP_<X{A}> (I-TPOP_<X{A}>-STEP I))
            (TPOP_<X{S}> (I-TPOP_<X{S}>-STEP I))
            (TPOP_PC (I-TPOP_PC-STEP I))
            (TPOP_X (I-TPOP_X-STEP I))
            (TPOP_Y (I-TPOP_Y-STEP I))
            (TPOP{V}_<Z>_Y (I-TPOP{V}_<Z>_Y-STEP I))
            (TPOP{B}_<Z>_Y (I-TPOP{B}_<Z>_Y-STEP I))
            (TPOP{I}_<ZN>_Y (I-TPOP{I}_<ZN>_Y-STEP I))
            (TPOP{N}_<Z>_Y (I-TPOP{N}_<Z>_Y-STEP I))
            (TPUSH_* (I-TPUSH_*-STEP I))
            (TPUSH_<X{A}> (I-TPUSH_<X{A}>-STEP I))
            (TPUSH_<X{S}> (I-TPUSH_<X{S}>-STEP I))
            (TPUSH_CSP (I-TPUSH_CSP-STEP I))
            (TPUSH_TSP (I-TPUSH_TSP-STEP I))
            (TPUSH_X (I-TPUSH_X-STEP I))
            (XOR_<TSP>_<TSP> (I-XOR_<TSP>_<TSP>-STEP I))
            (XOR_<TSP>{V}_X{V} (I-XOR_<TSP>{V}_X{V}-STEP I))
            (XOR_<TSP>{B}_*{B} (I-XOR_<TSP>{B}_*{B}-STEP I))
            (XOR_<TSP>{B}_X{B} (I-XOR_<TSP>{B}_X{B}-STEP I))
            (XOR_<Z>_<TSP>_X (I-XOR_<Z>_<TSP>_X-STEP I LOAD-ADDR))
            (OTHERWISE (I-HALT I 'RUN))))

(DEFN I-STEP1
      (INS I load-addr)
      (IF (I-STATE-OKP I load-addr)
          (IF (I-INS-OKP INS I)
              (I-INS-STEP INS I load-addr)
              (I-HALT I
                      (X-Y-ERROR-MSG 'I (CAR INS))))
          (I-HALT I 'STATE-NOT-OKP)))

(DEFN I-STEP
      (I load-addr)
      (IF (EQUAL (I-PSW I) 'RUN)
          (I-STEP1 (I-CURRENT-INSTRUCTION I) I load-addr)
          I))

(DEFN I
      (I N load-addr)
      (IF (ZEROP N)
          I
          (I (I-STEP I load-addr) (SUB1 N) load-addr)))

(DEFN LIST-OF-NATS
      (LST)
      (IF (NLISTP LST)
          NIL
          (CONS (V-TO-NAT (CAR LST))
                (LIST-OF-NATS (CDR LST)))))

; Book: i-m.events.  We now develop the proof that the i machine is
; implemented on the m machine.

; I first develop the necessary rules about the FM9001 alu.

; Each of the alu theorems is about the bv-alu-cv function.
; That function returns a triple.  We are most interested in
; the bv and c components of the triple.  We are occasionally
; interested in the v component, but only for those instructions
; that we use that set the v flag.

; For each opcode op, each component, cmp, in {bv c v}
; and type, t, in {bitv nat tc} we have a theorem called
; alu-thm_t-cmp-op.  For example, we have alu-thm_BITV-BV-MOVE,
; which gives the BITV interpretation of the BV component of
; the alu on a MOVE opcode.  We omit some combinations because
; they do not make much sense.  Occasionally we have to prove
; conflicting rules -- rules that rewrite the same lhs.  This
; happens when the opcode has a natural interpretation for more
; than one type.  When it happens we note it.

(enable v-buf-works)

(prove-lemma alu-thm_bitv-bv-move-15 (rewrite)
  (implies (and (bvp a)
                (bvp b)
                (equal (length a) (length b))
                (boolp c))
           (equal (bv (v-alu c a b (list t t t t)))
                  a)))

(prove-lemma alu-thm_bitv-c-move-15 (rewrite)
  (implies (and (bvp a)
                (bvp b)
                (equal (length a) (length b))
                (boolp c))
           (equal (c (v-alu c a b (list t t t t)))
                  f)))

(prove-lemma alu-thm_bitv-bv-not (rewrite)
  (implies (and (bvp a)
                (bvp b)
                (equal (length a) (length b))
                (boolp c))
           (equal (bv (v-alu c a b (list f t t t)))
                  (v-not a))))

(prove-lemma alu-thm_bitv-c-not (rewrite)
  (implies (and (bvp a)
                (bvp b)
                (equal (length a) (length b))
                (boolp c))
           (equal (c (v-alu c a b (list f t t t)))
                  f)))

(prove-lemma alu-thm_bitv-bv-and (rewrite)
  (implies (and (bvp a)
                (bvp b)
                (equal (length a) (length b))
                (boolp c))
           (equal (bv (v-alu c a b (list t f t t)))
                  (v-and a b))))

(prove-lemma alu-thm_bitv-c-and (rewrite)
  (implies (and (bvp a)
                (bvp b)
                (equal (length a) (length b))
                (boolp c))
           (equal (c (v-alu c a b (list t f t t)))
                  f)))

(prove-lemma alu-thm_bitv-bv-or (rewrite)
  (implies (and (bvp a)
                (bvp b)
                (equal (length a) (length b))
                (boolp c))
           (equal (bv (v-alu c a b (list f f t t)))
                  (v-or a b))))

(prove-lemma alu-thm_bitv-c-or (rewrite)
  (implies (and (bvp a)
                (bvp b)
                (equal (length a) (length b))
                (boolp c))
           (equal (c (v-alu c a b (list f f t t)))
                  f)))

(prove-lemma alu-thm_bitv-bv-xor (rewrite)
  (implies (and (bvp a)
                (bvp b)
                (equal (length a) (length b))
                (boolp c))
           (equal (bv (v-alu c a b (list t t f t)))
                  (v-xor a b))))

(prove-lemma alu-thm_bitv-c-xor (rewrite)
  (implies (and (bvp a)
                (bvp b)
                (equal (length a) (length b))
                (boolp c))
           (equal (c (v-alu c a b (list t t f t)))
                  f)))

; Conflict:  We will have both a BITV and a NAT interpretation of the
; BV and C produced by the LSR instruction.  Here is the BITV case:

(prove-lemma alu-thm_bitv-bv-lsr (rewrite)
  (implies (and (bvp a)
                (bvp b)
                (equal (length a) (length b))
                (boolp c))
           (equal (bv (v-alu c a b (list f t f t)))
                  (v-lsr a))))

; Note that we have an additional hypothesis below, (listp a).

(prove-lemma alu-thm_bitv-c-lsr (rewrite)
  (implies (and (bvp a)
                (bvp b)
                (equal (length a) (length b))
                (listp a)
                (boolp c))
           (equal (c (v-alu c a b (list f t f t)))
                  (bitn a 1))))

; Conflict:  We will have both a BITV and a TC interpretation of the BV
; produced by the ASR instruction.  

(prove-lemma alu-thm_bitv-bv-asr (rewrite)
  (implies (and (bvp a)
                (bvp b)
                (equal (length a) (length b))
                (boolp c))
           (equal (bv (v-alu c a b (list t f f t)))
                  (v-asr a))))

; Note that we have an additional hypothesis below, (listp a).

(prove-lemma alu-thm_bitv-c-asr (rewrite)
  (implies (and (bvp a)
                (bvp b)
                (equal (length a) (length b))
                (listp a)
                (boolp c))
           (equal (c (v-alu c a b (list t f f t)))
                  (bitn a 1))))


(prove-lemma alu-thm_bitv-bv-ror (rewrite)
  (implies (and (bvp a)
                (bvp b)
                (equal (length a) (length b))
                (boolp c))
           (equal (bv (v-alu c a b (list f f f t)))
                  (v-ror a c))))

; To prove the next one we need another piece of help.

(prove-lemma boolp-truep (rewrite)
  (implies (boolp c) (equal (truep c) c)))

(prove-lemma alu-thm_bitv-c-ror (rewrite)
  (implies (and (bvp a)
                (bvp b)
                (equal (length a) (length b))
                (boolp c))
           (equal (c (v-alu c a b (list f f f t)))
                  (if (zerop (length a))
                      c
                      (bitn a 1)))))


; Here are the natural number interpretations of the bv and c flag of the
; alu.

; Our first step is to get the natural interpretation lemma as a rewrite
; rule and shut down v-alu:

(disable v-alu)

(prove-lemma v-alu-correct-nat-rewriter (rewrite)
  (implies (bv2p a b)
           (equal (v-alu c a b op)
                  (v-alu-nat c a b op)))
  ((disable v-alu-nat)
   (use (v-alu-correct-nat))))

; The original (FM8502) Piton proofs were based on alu interpretation
; lemmas proved for FM8502.  When FM9001 was done, Matt Kaufmann was given
; a free hand to formulate the alu interpretation lemmas for it.  His
; algebraic expressions were different than those used for FM8502, even
; though they were equivalent.  Rather than redesign the Piton proof to
; use Matt's formulation, we take the approach of proving the old-style
; algebraic formulations from Matt's.  That is what we do now.

; This gets exceptionally tedious for the twos-complement stuff.  I essentially
; just use brute force to wade through this stuff.  The general scheme was
; was to attack the top-level theorems with a fixed set of rules enabled,
; generating certain goals (all phrased in integer terms) and then attack
; each of those goals as a separate lemma with the integer stuff enabled.
; Those integer lemmas are killers, taking hundreds or thousands of seconds
; each.  But it was better than thinking...

(prove-lemma alu-thm_nat-bv-lsr (rewrite)
  (implies (and (bvp a)
                (bvp b)
                (equal (length a) (length b))
                (boolp c))
           (equal (bv (v-alu c a b (list f t f t)))
                  (nat-to-v (quotient (v-to-nat a) 2)
                             (length a)))))

(prove-lemma alu-thm_nat-c-lsr (rewrite)
  (implies (and (bvp a)
                (bvp b)
                (equal (length a) (length b))
                (boolp c))
           (equal (c (v-alu c a b (list f t f t)))
                  (not (zerop (remainder (v-to-nat a) 2))))))

(enable plus-0)

(prove-lemma pathological-difference (rewrite)
  (implies (not (lessp a b)) (equal (difference b a) 0)))

(prove-lemma difference-difference-plus (rewrite)
  (equal (difference (difference (plus b e) a) e)
         (difference b a)))

(enable LESSP-V-TO-NAT-EXP)

(prove-lemma remainder-difference-hack (rewrite)
  (implies (lessp b e)
           (equal (remainder (difference b a) e)
                  (difference b a)))
  ((induct (difference b a))))
           
(prove-lemma difference-difference-hack (rewrite)
  (implies (not (lessp a b))
           (equal (difference e (difference a b))
                  (difference (plus b e) a))))

; Conflict:  We will have both a NAT and a TC interpretation of the BV
; produced by the SUB instruction.

(prove-lemma alu-thm_nat-bv-sub (rewrite)
  (implies (and (bvp a)
                (bvp b)
                (equal (length a) (length b))
                (boolp c))
           (equal (bv (v-alu c a b (list t t t f)))
                  (if (not (lessp (v-to-nat b) (v-to-nat a)))
                      (nat-to-v (difference (v-to-nat b)
                                             (v-to-nat a))
                                 (length a))
                      (nat-to-v
                        (difference (exp 2 (length a))
                                    (difference (v-to-nat a)
                                                (v-to-nat b)))
                        (length a)))))
  ((enable NAT-TO-V-REMAINDER)))

(prove-lemma alu-thm_nat-c-sub (rewrite)
  (implies (and (bvp a)
                (bvp b)
                (equal (length a) (length b))
                (boolp c))
           (equal (c (v-alu c a b (list t t t f)))
                  (lessp (v-to-nat b) (v-to-nat a)))))

(defn carry (c)
  (if c 1 0))

; Conflict:  We will have both a NAT and a TC interpretation of the the
; BV produced by the SUBB instruction.

(prove-lemma alu-thm_nat-bv-subb (rewrite)
  (implies (and (bvp a)
                (bvp b)
                (equal (length a) (length b))
                (boolp c))
           (equal (bv (v-alu c a b (list f t t f)))
                  (if (lessp (v-to-nat b)
                             (plus (v-to-nat a) (carry c)))
                      (nat-to-v (difference (exp 2 (length a))
                                  (difference (plus (v-to-nat a) (carry c))
                                              (v-to-nat b)))
                                 (length a))
                      (nat-to-v (difference (v-to-nat b)
                                  (plus (v-to-nat a) (carry c)))
                                 (length a)))))
  ((enable NAT-TO-V-REMAINDER)))

(prove-lemma alu-thm_nat-c-subb (rewrite)
  (implies (and (bvp a)
                (bvp b)
                (equal (length a) (length b))
                (boolp c))
           (equal (c (v-alu c a b (list f t t f)))
                  (lessp (v-to-nat b)
                         (plus (v-to-nat a) (carry c))))))

(disable pathological-difference)
(disable difference-difference-plus)
(disable LESSP-V-TO-NAT-EXP)
(disable remainder-difference-hack)
(disable difference-difference-hack)

(enable length-nat-to-v)
(enable commutativity-of-plus)
(enable associativity-of-plus)
(enable plus-add1)
(enable plus-0)
(enable times-commutes)
(enable associativity-of-times)
(enable times-distributes-over-plus)
(enable times-add1-again)
(enable times-1)
(prove-lemma plus-commutes2 (rewrite)
  (equal (plus x (plus y z)) (plus y (plus x z))))
(prove-lemma times-commutes2 (rewrite)
  (equal (times x (times y z)) (times y (times x z))))
(prove-lemma remainder-lessp (rewrite generalize)
  (equal (lessp (remainder x y) y)
         (not (zerop y))))

(enable remainder-quotient-elim)
(prove-lemma remainder-quotient-rewrite (rewrite)
  (implies (and (numberp x)
                (not (zerop y)))
           (equal (plus (remainder x y) (times y (quotient x y))) x)))

(prove-lemma v-to-nat-nat-to-v (rewrite)
  (implies (lessp n (exp 2 len))
           (equal (v-to-nat (nat-to-v n len)) (fix n))))

(prove-lemma lessp-0-exp (rewrite)
  (implies (not (zerop i)) (lessp 0 (exp i j))))

(prove-lemma difference-plus (rewrite)
  (equal (difference (plus a b) b) (fix a)))

; The following lemma is a way to get linear arithmetic to address the
; question "is a less than b" when opening up (remainder a b).

(prove-lemma remainder-opener (rewrite)
  (implies (lessp a b) (equal (remainder a b) (fix a))))

(enable lessp-v-to-nat-exp)

(prove-lemma LESSP-V-TO-NAT-EXP-gen (REWRITE) 
  (LESSP (V-TO-NAT A) 
         (EXP 2 (LENGTH A))) 
  ((ENABLE V-TO-NAT LENGTH)))

(prove-lemma remainder-hack2 (rewrite)
 (equal (remainder (sub1 (v-to-nat v)) (exp 2 (length v)))
        (sub1 (v-to-nat v))))

(enable difference-x-1)

; Conflict:  We will have both a NAT and a TC interpretation of the the
; BV produced by the DECR instruction.

(prove-lemma alu-thm_nat-bv-decr (rewrite)
  (implies (and (bvp a)
                (bvp b)
                (equal (length a) (length b))
                (boolp c))
           (equal (bv (v-alu c a b (list t f t f)))
                  (if (zerop (v-to-nat a))
                      (nat-to-v (sub1 (exp 2 (length a)))
                                 (length a))
                      (nat-to-v (sub1 (v-to-nat a))
                                 (length a))))))

(prove-lemma alu-thm_nat-c-decr (rewrite)
  (implies (and (bvp a)
                (bvp b)
                (equal (length a) (length b))
                (boolp c))
           (equal (c (v-alu c a b (list t f t f)))
                  (zerop (v-to-nat a)))))

; Conflict:  We will have both a NAT and a TC interpretation of the the
; BV produced by the ADD instruction.

(prove-lemma alu-thm_nat-bv-add (rewrite)
  (implies (and (bvp a)
                (bvp b)
                (equal (length a) (length b))
                (boolp c))
           (equal (bv (v-alu c a b (list t t f f)))
                  (if (lessp (plus (v-to-nat a) (v-to-nat b))
                             (exp 2 (length a)))
                      (nat-to-v (plus (v-to-nat a) (v-to-nat b))
                                 (length a))
                      (nat-to-v (remainder (plus (v-to-nat a) (v-to-nat b))
                                            (exp 2 (length a)))
                                 (length a))))))

(prove-lemma alu-thm_nat-c-add (rewrite)
  (implies (and (bvp a)
                (bvp b)
                (equal (length a) (length b))
                (boolp c))
           (equal (c (v-alu c a b (list t t f f)))
                  (not (lessp (plus (v-to-nat a) (v-to-nat b))
                              (exp 2 (length a)))))))

; Conflict:  We will have both a NAT and a TC interpretation of the the
; BV produced by the ADDC instruction.

(prove-lemma alu-thm_nat-bv-addc (rewrite)
  (implies (and (bvp a)
                (bvp b)
                (equal (length a) (length b))
                (boolp c))
           (equal (bv (v-alu c a b (list f t f f)))
                  (if (lessp (plus (v-to-nat a)
                                   (v-to-nat b)
                                   (carry c))
                             (exp 2 (length a)))
                      (nat-to-v (plus (v-to-nat a)
                                       (v-to-nat b)
                                       (carry c))
                                 (length a))
                      (nat-to-v (remainder (plus (v-to-nat a)
                                                  (v-to-nat b)
                                                  (carry c))
                                            (exp 2 (length a)))
                                 (length a))))))

(prove-lemma alu-thm_nat-c-addc (rewrite)
  (implies (and (bvp a)
                (bvp b)
                (equal (length a) (length b))
                (boolp c))
           (equal (c (v-alu c a b (list f t f f)))
                  (not (lessp (plus (v-to-nat a)
                                    (v-to-nat b)
                                    (carry c))
                              (exp 2 (length a)))))))


; Conflict:  We will have both a NAT and a TC interpretation of the the
; BV produced by the INCR instruction.

(prove-lemma alu-thm_nat-bv-incr (rewrite)
  (implies (and (bvp a)
                (bvp b)
                (equal (length a) (length b))
                (boolp c))
           (equal (bv (v-alu c a b (list t f f f)))
                  (if (lessp (add1 (v-to-nat a))
                             (exp 2 (length a)))
                      (nat-to-v (add1 (v-to-nat a)) (length a))
                      (nat-to-v 0 (length a)))))
  ((enable pathological-difference)))

(prove-lemma alu-thm_nat-c-incr (rewrite)
  (implies (and (bvp a)
                (bvp b)
                (equal (length a) (length b))
                (boolp c))
           (equal (c (v-alu c a b (list t f f f)))
                  (not (lessp (add1 (v-to-nat a))
                              (exp 2 (length a))))))
  ((enable pathological-difference)))


; Conflict:  Each of the TC interpretations conflicts with some other rule.

; Warning: all of these tc guys had (hands-off if) hints!

(disable v-alu-correct-nat-rewriter)

(prove-lemma v-alu-correct-int-rewriter (rewrite)
  (implies (and (bv2p a b)
                (listp a))
           (equal (v-alu c a b op)
                  (v-alu-int c a b op)))
  ((expand (length a))
   (disable v-alu-int)
   (use (v-alu-correct-int))))

(defn mod2 (x)
  (if (negativep x)
      (minus (quotient (add1 (negative-guts x)) 2))
      (quotient x 2)))

(enable quotient-plus-x-x-2)

; A lemma quotient-add1-plus-x-x-2 exists in fm9001.events, but it did
; not originally.  We accommodate this change by introducing the "my-"
; prefix below.

(prove-lemma my-quotient-add1-plus-x-x-2 (rewrite)
  (equal (quotient (add1 (plus x x)) 2) (fix x)))

(prove-lemma idiv-is-mod2 (rewrite)
  (equal (idiv x 2) (if (integerp x) (mod2 x) 0)))

(disable idiv)

; A lemma integerp-v-to-int exists in fm9001.events, but it did not
; originally.  We accommodate this change by introducing the "my-"
; prefix below.

(prove-lemma my-integerp-v-to-int (rewrite)
  (integerp (v-to-int v)))

(prove-lemma alu-thm_tc-bv-asr (rewrite)
  (implies (and (bvp a)
                (listp a)
                (bvp b)
                (listp b)
                (equal (length a) (length b))
                (boolp c))
           (equal (bv (v-alu c a b (list t f f t)))
                  (int-to-v (mod2 (v-to-int a))
                            (length a))))
  ((disable alu-thm_bitv-bv-asr integerp
            carry exp ineg iplus small-integerp v-to-int
            mod2 int-to-v nat-to-v boolp length)))

(defn tc-in-rangep (x n)
  (if (zerop n)
      f
      (if (negativep x)
          (not (lessp (exp 2 (sub1 n))
                      (negative-guts x)))
          (lessp x (exp 2 (sub1 n))))))

(defn tc-add (x y) (iplus x y))

(defn tc-minus (x) (ineg x))

(prove-lemma iplus-0 (rewrite)
  (equal (iplus x 0) (fix-int x)))

(prove-lemma equal-length-0 (rewrite)
  (equal (equal (length x) 0)
         (nlistp x)))

(prove-lemma negativep-ineg (rewrite)
  (implies (and (numberp x) (not (equal x 0))) (negativep (ineg x)))
  ((enable ineg)))

(prove-lemma not-equal-exp-0 (rewrite)
  (implies (not (zerop x)) (not (equal (exp x y) 0)))
  ((enable equal-times-0)))

(prove-lemma ineg-exp-2-x (rewrite)
  (equal (ineg (exp 2 x)) (minus (exp 2 x))))

(prove-lemma diff-diff (rewrite)
  (implies (and (numberp a)
                (numberp b))
           (equal (difference a (difference a b))
                  (if (lessp a b) a b)))
  ((enable pathological-difference)))

(prove-lemma alu-thm_tc-bv-sub-lemma (rewrite)
  (IMPLIES (AND (BVP A) 
                (LISTP A) 
                (BVP B) 
                (LISTP B) 
                (EQUAL (LENGTH A) (LENGTH B)) 
                (NOT (NEGATIVEP (IPLUS (V-TO-INT B) 
                                       (INEG (V-TO-INT A))))) 
                (not (LESSP (IPLUS (V-TO-INT B) 
                                   (INEG (V-TO-INT A))) 
                            (EXP 2 (SUB1 (LENGTH A))))))
           (EQUAL (INT-TO-V (IPLUS (V-TO-INT B) 
                                   (IPLUS (MINUS (EXP 2 (LENGTH A))) 
                                          (INEG (V-TO-INT A)))) 
                            (LENGTH A)) 
                  (INT-TO-V (IPLUS (V-TO-INT B) 
                                   (INEG (V-TO-INT A))) 
                            (LENGTH A))))
  ((DO-NOT-INDUCT T)
   (enable LESSP-V-TO-NAT-EXP-WITH-EXP-OPENED MY-LESSP-V-TO-NAT-EXP ineg-iplus
           associativity-of-iplus ineg-ineg INTEGERP-INEG plus-difference-arg2
           difference-difference-hack)))

; Note: This was proved with the lower case a's replaced by b's, but I
; have now assumed it as shown below (except that the concluding
; equality was reversed).  Under that assumption, I can prove the
; tc-bv-sub lemma I need.  However, I now want to reverse the
; direction of the concluding equality so as not to take the chance
; that it loops.

(prove-lemma alu-thm_tc-bv-sub-lemma2 (rewrite)
  (IMPLIES (AND (BVP A) 
                (LISTP A) 
                (BVP B) 
                (LISTP B) 
                (EQUAL (LENGTH A) (LENGTH B)) 
                (NEGATIVEP (IPLUS (V-TO-INT B) 
                                  (INEG (V-TO-INT A)))) 
                (LESSP (EXP 2 (SUB1 (LENGTH a))) 
                       (NEGATIVE-GUTS (IPLUS (V-TO-INT B) 
                                             (INEG (V-TO-INT A)))))) 
           (EQUAL (INT-TO-V (IPLUS (V-TO-INT B) 
                                   (IPLUS (EXP 2 (LENGTH a)) 
                                          (INEG (V-TO-INT A)))) 
                            (LENGTH a)) 
                  (INT-TO-V (IPLUS (V-TO-INT B) 
                                   (INEG (V-TO-INT A))) 
                            (LENGTH a))))
  ((DO-NOT-INDUCT T)
   (enable LESSP-V-TO-NAT-EXP-WITH-EXP-OPENED MY-LESSP-V-TO-NAT-EXP ineg-iplus
           associativity-of-iplus ineg-ineg INTEGERP-INEG plus-difference-arg2
           difference-difference-hack difference-difference-plus
           DIFFERENCE-PLUS-PLUS-CANCELLATION)))  

(prove-lemma alu-thm_tc-bv-sub (rewrite)
  (implies (and (bvp a)
                (listp a)
                (bvp b)
                (listp b)
                (equal (length a) (length b))
                (boolp c))
           (equal (bv (v-alu c a b (list t t t f)))
                  (int-to-v
                   (cond ((tc-in-rangep (tc-add (v-to-int b)
                                              (tc-minus (v-to-int a)))
                                           (length a))
                           (tc-add (v-to-int b)
                                (tc-minus (v-to-int a))))
                          ((negativep (tc-add (v-to-int b)
                                           (tc-minus (v-to-int a))))
                           (tc-add (v-to-int b)
                                (tc-add (exp 2 (length a))
                                     (tc-minus (v-to-int a)))))
                          (t (tc-add (v-to-int b)
                                  (tc-add (minus (exp 2 (length a)))
                                       (tc-minus (v-to-int a))))))
                    (length a))))
  ((do-not-induct t)
   (enable integerp-iplus equal-length-0)
   (disable V-ZEROP V-SUBTRACTER-CARRY-OUT V-ALU-INT-SUBTRACTER-OVERFLOWP iplus ineg
            integerp v-to-int int-to-v exp)))

(prove-lemma alu-thm_tc-v-sub (rewrite)
  (implies (and (bvp a)
                (listp a)
                (bvp b)
                (listp b)
                (equal (length a) (length b))
                (boolp c))
           (equal (v (v-alu c a b (list t t t f)))
                  (not (tc-in-rangep (tc-add (v-to-int b)
                                          (tc-minus (v-to-int a)))
                                     (length a)))))
  ((do-not-induct t)
   (enable integerp-iplus equal-length-0)
   (disable V-ZEROP V-SUBTRACTER-CARRY-OUT V-ALU-INT-SUBTRACTER-OUTPUT iplus ineg
            integerp v-to-int int-to-v exp)))

(prove-lemma diff-plus-cancellation-hack2 (rewrite)
  (equal (difference (plus a b c d) (plus b c)) (plus a d)))

(prove-lemma diff-plus-sub1-hack1 (rewrite)
  (implies (lessp a e)
           (equal (difference (plus b (sub1 e)) a)
                  (plus b (sub1 (difference e a))))))

(prove-lemma alu-thm_tc-bv-subb-lemma1 (rewrite)
  (IMPLIES (AND (BVP A) 
                (LISTP A) 
                (BVP B) 
                (LISTP B) 
                (EQUAL (LENGTH A) (LENGTH B)) 
                (NOT (NEGATIVEP (IPLUS (V-TO-INT B) 
                                       (INEG (IPLUS (V-TO-INT A) 1))))) 
                (NOT (LESSP (IPLUS (V-TO-INT B) 
                                   (INEG (IPLUS (V-TO-INT A) 1))) 
                            (EXP 2 (SUB1 (LENGTH A)))))) 
           (EQUAL (INT-TO-V (IPLUS (V-TO-INT B) 
                                   (IPLUS (MINUS (EXP 2 (LENGTH A))) 
                                          (INEG (IPLUS (V-TO-INT A) 1)))) 
                            (LENGTH A)) 
                  (INT-TO-V (IPLUS (V-TO-INT B) 
                                   (INEG (IPLUS (V-TO-INT A) 1))) 
                            (LENGTH A))))
  ((DO-NOT-INDUCT T)
   (enable LESSP-V-TO-NAT-EXP-WITH-EXP-OPENED MY-LESSP-V-TO-NAT-EXP ineg-iplus
           associativity-of-iplus ineg-ineg INTEGERP-INEG plus-difference-arg2
           difference-difference-hack difference-sub1-arg2)))

(prove-lemma diff-plus-sub1-hack2 (rewrite)
  (implies (and (not (zerop e))
                (lessp a e))
           (equal (DIFFERENCE (PLUS b (SUB1 (DIFFERENCE e a))) 
                              e)
                  (DIFFERENCE (PLUS b (SUB1 e)) 
                              (PLUS a e))))
  ((do-not-induct t)
   (enable EQUAL-PLUS-0 DIFFERENCE-ADD1-ARG2 DIFFERENCE-PLUS-PLUS-CANCELLATION 
    DIFFERENCE-PLUS-PLUS-CANCELLATION-HACK DIFFERENCE-ELIM)))

(prove-lemma alu-thm_tc-bv-subb-lemma2-lemma1 (rewrite)
  (implies (and (bvp a)
                (not (equal (length a) 0)))
           (EQUAL 
            (NAT-TO-V 
             (DIFFERENCE 
              (PLUS (V-TO-NAT B) 
                    (SUB1 (DIFFERENCE (PLUS (EXP 2 (SUB1 (LENGTH A))) 
                                            (EXP 2 (SUB1 (LENGTH A)))) 
                                      (V-TO-NAT A)))) 
              (PLUS (EXP 2 (SUB1 (LENGTH A))) 
                    (EXP 2 (SUB1 (LENGTH A))))) 
             (LENGTH A)) 
            (NAT-TO-V 
             (DIFFERENCE (PLUS (V-TO-NAT B) 
                               (SUB1 (PLUS (EXP 2 (SUB1 (LENGTH A))) 
                                           (EXP 2 (SUB1 (LENGTH A)))))) 
                         (PLUS (V-TO-NAT A) 
                               (EXP 2 (SUB1 (LENGTH A))) 
                               (EXP 2 (SUB1 (LENGTH A))))) 
             (LENGTH A))))
  ((enable lessp-v-to-nat-exp-with-exp-opened)
   (disable nat-to-v v-to-nat difference plus lessp)))

(disable diff-plus-sub1-hack2)

(prove-lemma alu-thm_tc-bv-subb-lemma2 (rewrite)
  (IMPLIES 
   (AND (BVP A) 
        (LISTP A) 
        (BVP B) 
        (LISTP B) 
        (EQUAL (LENGTH A) (LENGTH B)) 
        (NEGATIVEP (IPLUS (V-TO-INT B) 
                          (INEG (IPLUS (V-TO-INT A) 1)))) 
        (LESSP (EXP 2 (SUB1 (LENGTH A))) 
               (NEGATIVE-GUTS (IPLUS (V-TO-INT B) 
                                     (INEG (IPLUS (V-TO-INT A) 1)))))) 
   (EQUAL (INT-TO-V (IPLUS (V-TO-INT B) 
                           (IPLUS (EXP 2 (LENGTH A)) 
                                  (INEG (IPLUS (V-TO-INT A) 1)))) 
                    (LENGTH A)) 
          (INT-TO-V (IPLUS (V-TO-INT B) 
                           (INEG (IPLUS (V-TO-INT A) 1))) 
                    (LENGTH A))))
  ((DO-NOT-INDUCT T)
   (enable LESSP-V-TO-NAT-EXP-WITH-EXP-OPENED MY-LESSP-V-TO-NAT-EXP ineg-iplus
           associativity-of-iplus ineg-ineg INTEGERP-INEG plus-difference-arg2
           difference-difference-hack difference-sub1-arg2)))

(prove-lemma alu-thm_tc-bv-subb (rewrite)
  (implies (and (bvp a)
                (listp a)
                (bvp b)
                (listp b)
                (equal (length a) (length b))
                (boolp c))
           (equal (bv (v-alu c a b (list f t t f)))
                  (int-to-v
                   (cond ((tc-in-rangep
                            (tc-add (v-to-int b)
                                  (tc-minus (tc-add (v-to-int a) (carry c))))
                             (length a))
                           (tc-add (v-to-int b)
                                (tc-minus (tc-add (v-to-int a) (carry c)))))
                          ((negativep (tc-add (v-to-int b)
                                           (tc-minus (tc-add (v-to-int a)
                                                          (carry c)))))
                           (tc-add (v-to-int b)
                                (tc-add (exp 2 (length a))
                                     (tc-minus (tc-add (v-to-int a) (carry c))))))
                          (t (tc-add (v-to-int b)
                                  (tc-add (minus (exp 2 (length a)))
                                       (tc-minus (tc-add (v-to-int a)
                                                      (carry c)))))))
                    (length a))))
  ((do-not-induct t)
   (enable integerp-iplus equal-length-0)
   (disable V-ZEROP V-SUBTRACTER-CARRY-OUT V-ALU-INT-SUBTRACTER-OVERFLOWP iplus ineg
            integerp v-to-int int-to-v exp)))

(prove-lemma alu-thm_tc-v-subb (rewrite)
  (implies (and (bvp a)
                (listp a)
                (bvp b)
                (listp b)
                (equal (length a) (length b))
                (boolp c))
           (equal (v (v-alu c a b (list f t t f)))
                  (not (tc-in-rangep
                        (tc-add (v-to-int b)
                             (tc-minus (tc-add (v-to-int a) (carry c))))
                        (length a)))))
  ((do-not-induct t)
   (enable integerp-iplus equal-length-0)
   (disable V-ZEROP V-SUBTRACTER-CARRY-OUT V-ALU-INT-SUBTRACTER-OUTPUT iplus ineg
            integerp v-to-int int-to-v exp)))

(prove-lemma v-to-int-int-to-v-0 (rewrite)
  (equal (v-to-int (int-to-v 0 n)) 0))

; A lemma length-int-to-v exists in fm9001.events, but it did not
; originally.  We accommodate this change by introducing the "my-"
; prefix below.

(prove-lemma my-length-int-to-v (rewrite)
  (equal (length (int-to-v x n)) (fix n))
  ((enable length-nat-to-v)))

(prove-lemma alu-thm_tc-bv-decr-lemma1 (rewrite)
        (IMPLIES (AND (BVP A) 
                      (LISTP A) 
                      (BVP B) 
                      (LISTP B) 
                      (EQUAL (LENGTH A) (LENGTH B)) 
                      (NOT (NEGATIVEP (IPLUS (V-TO-INT A) -1))) 
                      (NOT (LESSP (IPLUS (V-TO-INT A) -1) 
                                  (EXP 2 (SUB1 (LENGTH A)))))) 
                 (EQUAL (INT-TO-V (IPLUS (V-TO-INT A) -1) 
                                  (LENGTH A)) 
                        (INT-TO-V (IPLUS (V-TO-INT A) 
                                         (IPLUS -1 (MINUS (EXP 2 (LENGTH A))))) 
                                  (LENGTH A))))
  ((DO-NOT-INDUCT T)
   (enable LESSP-V-TO-NAT-EXP-WITH-EXP-OPENED MY-LESSP-V-TO-NAT-EXP ineg-iplus
           associativity-of-iplus ineg-ineg INTEGERP-INEG plus-difference-arg2
           difference-difference-hack difference-sub1-arg2)))

(prove-lemma alu-thm_tc-bv-decr-lemma2 (rewrite)
        (IMPLIES (AND (BVP A) 
                      (LISTP A) 
                      (BVP B) 
                      (LISTP B) 
                      (EQUAL (LENGTH A) (LENGTH B)) 
                      (NEGATIVEP (IPLUS (V-TO-INT A) -1)) 
                      (LESSP (EXP 2 (SUB1 (LENGTH A))) 
                             (NEGATIVE-GUTS (IPLUS (V-TO-INT A) -1)))) 
                 (EQUAL (INT-TO-V (IPLUS (V-TO-INT A) -1) 
                                  (LENGTH A)) 
                        (INT-TO-V (IPLUS (V-TO-INT A) 
                                         (IPLUS -1 (EXP 2 (LENGTH A)))) 
                                  (LENGTH A))))
  ((DO-NOT-INDUCT T)
   (enable LESSP-V-TO-NAT-EXP-WITH-EXP-OPENED MY-LESSP-V-TO-NAT-EXP ineg-iplus
           associativity-of-iplus ineg-ineg INTEGERP-INEG plus-difference-arg2
           difference-difference-hack difference-sub1-arg2)))
                                                             
(prove-lemma alu-thm_tc-bv-decr (rewrite)
  (implies (and (bvp a)
                (listp a)
                (bvp b)
                (listp b)
                (equal (length a) (length b))
                (boolp c))
           (equal (bv (v-alu c a b (list t f t f)))
                  (int-to-v
                    (cond ((tc-in-rangep (tc-add (v-to-int a) -1)
                                         (length a))
                           (tc-add (v-to-int a) -1))
                          ((negativep (tc-add (v-to-int a) -1))
                           (tc-add (v-to-int a)
                                (tc-add -1 (exp 2 (length a)))))
                          (t (tc-add (v-to-int a)
                                  (tc-add -1 (minus (exp 2 (length a)))))))
                    (length a))))
  ((do-not-induct t)
   (enable integerp-iplus equal-length-0)
   (disable V-ZEROP V-SUBTRACTER-CARRY-OUT V-ALU-INT-SUBTRACTER-OVERFLOWP iplus ineg
            integerp v-to-int int-to-v exp)))



(prove-lemma iplus-0-2 (rewrite) (equal (iplus 0 x) (fix-int x)))

(prove-lemma alu-thm_tc-bv-neg-lemma1 (rewrite)
        (IMPLIES (AND (BVP A) 
                      (LISTP A) 
                      (BVP B) 
                      (LISTP B) 
                      (EQUAL (LENGTH A) (LENGTH B)) 
                      (NOT (NEGATIVEP (INEG (V-TO-INT A)))) 
                      (NOT (LESSP (INEG (V-TO-INT A)) 
                                  (EXP 2 (SUB1 (LENGTH A))))) 
                      (NOT (INTEGERP (INEG (V-TO-INT A))))) 
                 (EQUAL (INT-TO-V 0 (LENGTH A)) 
                        (INT-TO-V (IPLUS (MINUS (EXP 2 (LENGTH A))) 
                                         (INEG (V-TO-INT A))) 
                                  (LENGTH A))))
  ((DO-NOT-INDUCT T)
   (enable LESSP-V-TO-NAT-EXP-WITH-EXP-OPENED MY-LESSP-V-TO-NAT-EXP ineg-iplus
           associativity-of-iplus ineg-ineg INTEGERP-INEG plus-difference-arg2
           difference-difference-hack difference-sub1-arg2)))

(prove-lemma alu-thm_tc-bv-neg-lemma2 (rewrite)
        (IMPLIES (AND (BVP A) 
                      (LISTP A) 
                      (BVP B) 
                      (LISTP B) 
                      (EQUAL (LENGTH A) (LENGTH B)) 
                      (NOT (NEGATIVEP (INEG (V-TO-INT A)))) 
                      (NOT (LESSP (INEG (V-TO-INT A)) 
                                  (EXP 2 (SUB1 (LENGTH A))))) 
                      (INTEGERP (INEG (V-TO-INT A)))) 
                 (EQUAL (INT-TO-V (INEG (V-TO-INT A)) 
                                  (LENGTH A)) 
                        (INT-TO-V (IPLUS (MINUS (EXP 2 (LENGTH A))) 
                                         (INEG (V-TO-INT A))) 
                                  (LENGTH A))))
  ((DO-NOT-INDUCT T)
   (enable LESSP-V-TO-NAT-EXP-WITH-EXP-OPENED MY-LESSP-V-TO-NAT-EXP ineg-iplus
           associativity-of-iplus ineg-ineg INTEGERP-INEG plus-difference-arg2
           difference-difference-hack difference-sub1-arg2)))

(prove-lemma alu-thm_tc-bv-neg-lemma3 (rewrite)
        (IMPLIES (AND (BVP A) 
                      (LISTP A) 
                      (BVP B) 
                      (LISTP B) 
                      (EQUAL (LENGTH A) (LENGTH B)) 
                      (NEGATIVEP (INEG (V-TO-INT A))) 
                      (LESSP (EXP 2 (SUB1 (LENGTH A))) 
                             (NEGATIVE-GUTS (INEG (V-TO-INT A)))) 
                      (NOT (INTEGERP (INEG (V-TO-INT A))))) 
                 (EQUAL (INT-TO-V 0 (LENGTH A)) 
                        (INT-TO-V (IPLUS (EXP 2 (LENGTH A)) 
                                         (INEG (V-TO-INT A))) 
                                  (LENGTH A))))
  ((DO-NOT-INDUCT T)
   (enable LESSP-V-TO-NAT-EXP-WITH-EXP-OPENED MY-LESSP-V-TO-NAT-EXP ineg-iplus
           associativity-of-iplus ineg-ineg INTEGERP-INEG plus-difference-arg2
           difference-difference-hack difference-sub1-arg2)))

(prove-lemma alu-thm_tc-bv-neg-lemma4 (rewrite)
        (IMPLIES (AND (BVP A) 
                      (LISTP A) 
                      (BVP B) 
                      (LISTP B) 
                      (EQUAL (LENGTH A) (LENGTH B)) 
                      (NEGATIVEP (INEG (V-TO-INT A))) 
                      (LESSP (EXP 2 (SUB1 (LENGTH A))) 
                             (NEGATIVE-GUTS (INEG (V-TO-INT A)))) 
                      (INTEGERP (INEG (V-TO-INT A)))) 
                 (EQUAL (INT-TO-V (INEG (V-TO-INT A)) 
                                  (LENGTH A)) 
                        (INT-TO-V (IPLUS (EXP 2 (LENGTH A)) 
                                         (INEG (V-TO-INT A))) 
                                  (LENGTH A))))
  ((DO-NOT-INDUCT T)
   (enable LESSP-V-TO-NAT-EXP-WITH-EXP-OPENED MY-LESSP-V-TO-NAT-EXP ineg-iplus
           associativity-of-iplus ineg-ineg INTEGERP-INEG plus-difference-arg2
           difference-difference-hack difference-sub1-arg2)))

(prove-lemma alu-thm_tc-bv-neg-lemma5 (rewrite)
        (IMPLIES (AND (BVP A) 
                      (LISTP A) 
                      (BVP B) 
                      (LISTP B) 
                      (EQUAL (LENGTH A) (LENGTH B)) 
                      (NOT (NEGATIVEP (INEG (V-TO-INT A)))) 
                      (LESSP (INEG (V-TO-INT A)) 
                             (EXP 2 (SUB1 (LENGTH A)))) 
                      (NOT (INTEGERP (INEG (V-TO-INT A))))) 
                 (EQUAL (INT-TO-V 0 (LENGTH A)) 
                        (INT-TO-V (INEG (V-TO-INT A)) 
                                  (LENGTH A))))
  ((DO-NOT-INDUCT T)
   (enable LESSP-V-TO-NAT-EXP-WITH-EXP-OPENED MY-LESSP-V-TO-NAT-EXP ineg-iplus
           associativity-of-iplus ineg-ineg INTEGERP-INEG plus-difference-arg2
           difference-difference-hack difference-sub1-arg2)))

(prove-lemma alu-thm_tc-bv-neg-lemma6 (rewrite)
        (IMPLIES (AND (BVP A) 
                      (LISTP A) 
                      (BVP B) 
                      (LISTP B) 
                      (EQUAL (LENGTH A) (LENGTH B)) 
                      (NEGATIVEP (INEG (V-TO-INT A))) 
                      (NOT (LESSP (EXP 2 (SUB1 (LENGTH A))) 
                                  (NEGATIVE-GUTS (INEG (V-TO-INT A))))) 
                      (NOT (INTEGERP (INEG (V-TO-INT A))))) 
                 (EQUAL (INT-TO-V 0 (LENGTH A)) 
                        (INT-TO-V (INEG (V-TO-INT A)) 
                                  (LENGTH A))))
  ((DO-NOT-INDUCT T)
   (enable LESSP-V-TO-NAT-EXP-WITH-EXP-OPENED MY-LESSP-V-TO-NAT-EXP ineg-iplus
           associativity-of-iplus ineg-ineg INTEGERP-INEG plus-difference-arg2
           difference-difference-hack difference-sub1-arg2)))

(prove-lemma alu-thm_tc-bv-neg (rewrite) 
  (implies (and (bvp a) 
                (listp a) 
                (bvp b) 
                (listp b) 
                (equal (length a) (length b)) 
                (boolp c)) 
           (equal (bv (v-alu c a b (list f f t f))) 
                  (int-to-v 
                    (cond ((tc-in-rangep (tc-minus (v-to-int a)) 
                                         (length a)) 
                           (tc-minus (v-to-int a))) 
                          ((negativep (tc-minus (v-to-int a))) 
                           (tc-add (exp 2 (length a)) 
                                (tc-minus (v-to-int a)))) 
                          (t (tc-add (minus (exp 2 (length a))) 
                                  (tc-minus (v-to-int a))))) 
                    (length a)))) 
  ((do-not-induct t) 
   (enable integerp-iplus equal-length-0) 
   (disable V-ZEROP V-SUBTRACTER-CARRY-OUT V-ALU-INT-SUBTRACTER-OVERFLOWP iplus ineg 
            integerp v-to-int int-to-v exp)))

(prove-lemma diff-plus-plus-plus-cancellation (rewrite)
  (equal (difference (plus a (plus b e)) e) (plus a b)))

(prove-lemma alu-thm_tc-bv-add-lemma1 (rewrite)
        (IMPLIES (AND (BVP A) 
                      (LISTP A) 
                      (BVP B) 
                      (LISTP B) 
                      (EQUAL (LENGTH A) (LENGTH B)) 
                      (NOT (NEGATIVEP (IPLUS (V-TO-INT A) (V-TO-INT B)))) 
                      (NOT (LESSP (IPLUS (V-TO-INT A) (V-TO-INT B)) 
                                  (EXP 2 (SUB1 (LENGTH A)))))) 
                 (EQUAL (INT-TO-V (IPLUS (V-TO-INT A) (V-TO-INT B)) 
                                  (LENGTH A)) 
                        (INT-TO-V (IPLUS (V-TO-INT A) 
                                         (IPLUS (V-TO-INT B) 
                                                (MINUS (EXP 2 (LENGTH A))))) 
                                  (LENGTH A))))
  ((DO-NOT-INDUCT T)
   (enable LESSP-V-TO-NAT-EXP-WITH-EXP-OPENED MY-LESSP-V-TO-NAT-EXP ineg-iplus
           associativity-of-iplus ineg-ineg INTEGERP-INEG plus-difference-arg2
           difference-difference-hack difference-sub1-arg2)))

(prove-lemma alu-thm_tc-bv-add-lemma2 (rewrite)
        (IMPLIES 
                (AND (BVP A) 
                     (LISTP A) 
                     (BVP B) 
                     (LISTP B) 
                     (EQUAL (LENGTH A) (LENGTH B)) 
                     (NEGATIVEP (IPLUS (V-TO-INT A) (V-TO-INT B))) 
                     (LESSP (EXP 2 (SUB1 (LENGTH A))) 
                            (NEGATIVE-GUTS (IPLUS (V-TO-INT A) (V-TO-INT B))))) 
                (EQUAL (INT-TO-V (IPLUS (V-TO-INT A) (V-TO-INT B)) 
                                 (LENGTH A)) 
                       (INT-TO-V (IPLUS (V-TO-INT A) 
                                        (IPLUS (V-TO-INT B) 
                                               (EXP 2 (LENGTH A)))) 
                                 (LENGTH A))))
  ((DO-NOT-INDUCT T)
   (enable LESSP-V-TO-NAT-EXP-WITH-EXP-OPENED MY-LESSP-V-TO-NAT-EXP ineg-iplus
           associativity-of-iplus ineg-ineg INTEGERP-INEG plus-difference-arg2
           difference-difference-hack difference-sub1-arg2 DIFFERENCE-PLUS-PLUS-CANCELLATION-HACK)))

(prove-lemma alu-thm_tc-bv-add (rewrite)
  (implies (and (bvp a)
                (listp a)
                (bvp b)
                (listp b)
                (equal (length a) (length b))
                (boolp c))
           (equal (bv (v-alu c a b (list t t f f)))
                  (int-to-v
                    (cond ((tc-in-rangep (tc-add (v-to-int a) (v-to-int b))
                                         (length a))
                           (tc-add (v-to-int a) (v-to-int b)))
                          ((negativep (tc-add (v-to-int a) (v-to-int b)))
                           (tc-add (v-to-int a)
                                (tc-add (v-to-int b) (exp 2 (length a)))))
                          (t (tc-add (v-to-int a)
                                  (tc-add (v-to-int b)
                                       (minus (exp 2 (length a)))))))
                    (length a))))
  ((do-not-induct t) 
   (enable integerp-iplus equal-length-0) 
   (disable V-ZEROP V-ADDER-CARRY-OUT V-ALU-INT-ADDER-OVERFLOWP iplus ineg 
            integerp v-to-int int-to-v exp)))

(prove-lemma alu-thm_tc-bv-addc-lemma1 (rewrite)
        (IMPLIES 
          (AND (BVP A) 
               (LISTP A) 
               (BVP B) 
               (LISTP B) 
               (EQUAL (LENGTH A) (LENGTH B)) 
               (NOT (NEGATIVEP (IPLUS (V-TO-INT A) 
                                      (IPLUS (V-TO-INT B) 1)))) 
               (NOT (LESSP (IPLUS (V-TO-INT A) 
                                  (IPLUS (V-TO-INT B) 1)) 
                           (EXP 2 (SUB1 (LENGTH A)))))) 
          (EQUAL (INT-TO-V (IPLUS 1 
                                  (IPLUS (V-TO-INT A) (V-TO-INT B))) 
                           (LENGTH A)) 
                 (INT-TO-V (IPLUS (V-TO-INT A) 
                                  (IPLUS (V-TO-INT B) 
                                         (IPLUS 1 (MINUS (EXP 2 (LENGTH A)))))) 
                           (LENGTH A))))
  ((DO-NOT-INDUCT T)
   (enable LESSP-V-TO-NAT-EXP-WITH-EXP-OPENED MY-LESSP-V-TO-NAT-EXP ineg-iplus
           associativity-of-iplus ineg-ineg INTEGERP-INEG plus-difference-arg2
           difference-difference-hack difference-sub1-arg2 DIFFERENCE-PLUS-PLUS-CANCELLATION-HACK)))

(prove-lemma alu-thm_tc-bv-addc-lemma2 (rewrite)
        (IMPLIES (AND (BVP A) 
                      (LISTP A) 
                      (BVP B) 
                      (LISTP B) 
                      (EQUAL (LENGTH A) (LENGTH B)) 
                      (NEGATIVEP (IPLUS (V-TO-INT A) 
                                        (IPLUS (V-TO-INT B) 1))) 
                      (LESSP (EXP 2 (SUB1 (LENGTH A))) 
                             (NEGATIVE-GUTS (IPLUS (V-TO-INT A) 
                                                   (IPLUS (V-TO-INT B) 1))))) 
                 (EQUAL (INT-TO-V (IPLUS 1 
                                         (IPLUS (V-TO-INT A) (V-TO-INT B))) 
                                  (LENGTH A)) 
                        (INT-TO-V (IPLUS (V-TO-INT A) 
                                         (IPLUS (V-TO-INT B) 
                                                (IPLUS 1 (EXP 2 (LENGTH A))))) 
                                  (LENGTH A))))
  ((DO-NOT-INDUCT T)
   (enable LESSP-V-TO-NAT-EXP-WITH-EXP-OPENED MY-LESSP-V-TO-NAT-EXP ineg-iplus
           associativity-of-iplus ineg-ineg INTEGERP-INEG plus-difference-arg2
           difference-difference-hack difference-sub1-arg2 DIFFERENCE-PLUS-PLUS-CANCELLATION-HACK)))

; The following three lemmas are killers as far as performance goes.
; I prove them, use them to get the lemmas I need, and then
; disable them.

(prove-lemma alu-thm_tc-bv-addc-lemma3-killer1 (rewrite)
  (implies (and (numberp a)
                (not (lessp a (difference (plus e e) b)))
                (not (lessp 1 (difference (plus e e) b)))
                (lessp b (plus e e)))
           (equal (add1 (difference (plus a b) (plus e e)))
                  a)))

(prove-lemma alu-thm_tc-bv-addc-lemma3-killer2 (rewrite)
  (implies (and (not (lessp 1 (difference (plus e e) b)))
                (lessp b (plus e e)))
           (equal (difference (plus e e) b) 1)))

(prove-lemma alu-thm_tc-bv-addc-lemma3-killer3 (rewrite)
  (implies (lessp (v-to-nat a) 1)
           (equal (v-to-nat a) 0)))

(prove-lemma alu-thm_tc-bv-addc-lemma3-lemma1 (rewrite)
  (IMPLIES (AND 
            (LESSP (V-TO-NAT B) 
                   (PLUS (EXP 2 (SUB1 (LENGTH A))) 
                         (EXP 2 (SUB1 (LENGTH A))))) 
            (NOT (LESSP 1 
                        (DIFFERENCE (PLUS (EXP 2 (SUB1 (LENGTH A))) 
                                          (EXP 2 (SUB1 (LENGTH A)))) 
                                    (V-TO-NAT B)))) 
            (NOT (LESSP (V-TO-NAT A) 
                        (DIFFERENCE (PLUS (EXP 2 (SUB1 (LENGTH A))) 
                                          (EXP 2 (SUB1 (LENGTH A)))) 
                                    (V-TO-NAT B))))) 
           (equal (EQUAL (NAT-TO-V (ADD1 (DIFFERENCE (PLUS (V-TO-NAT A) (V-TO-NAT B)) 
                                                     (PLUS (EXP 2 (SUB1 (LENGTH A))) 
                                                           (EXP 2 (SUB1 (LENGTH A)))))) 
                                   (LENGTH A)) 
                         (NAT-TO-V (V-TO-NAT A) (LENGTH A)))
                  t)))

(prove-lemma alu-thm_tc-bv-addc-lemma3-lemma2 (rewrite)
          (IMPLIES 
           (AND 
            (NOT (LESSP 1 
                        (DIFFERENCE (PLUS (EXP 2 (SUB1 (LENGTH A))) 
                                          (EXP 2 (SUB1 (LENGTH A)))) 
                                    (V-TO-NAT B)))) 
            (LESSP (V-TO-NAT B) 
                   (PLUS (EXP 2 (SUB1 (LENGTH A))) 
                         (EXP 2 (SUB1 (LENGTH A))))) 
            (LESSP (V-TO-NAT A) 
                   (DIFFERENCE (PLUS (EXP 2 (SUB1 (LENGTH A))) 
                                     (EXP 2 (SUB1 (LENGTH A)))) 
                               (V-TO-NAT B)))) 
           (equal
            (EQUAL (NAT-TO-V 0 (LENGTH A)) 
                   (NAT-TO-V (V-TO-NAT A) (LENGTH A)))
            t)))

(disable alu-thm_tc-bv-addc-lemma3-killer1)
(disable alu-thm_tc-bv-addc-lemma3-killer2) 
(disable alu-thm_tc-bv-addc-lemma3-killer3)

(prove-lemma alu-thm_tc-bv-addc-lemma3 (rewrite)
        (IMPLIES (AND (BVP A) 
                      (LISTP A) 
                      (BVP B) 
                      (LISTP B) 
                      (EQUAL (LENGTH A) (LENGTH B)) 
                      (NOT (NEGATIVEP (IPLUS (V-TO-INT A) 
                                             (IPLUS (V-TO-INT B) 1)))) 
                      (LESSP (IPLUS (V-TO-INT A) 
                                    (IPLUS (V-TO-INT B) 1)) 
                             (EXP 2 (SUB1 (LENGTH A))))) 
                 (EQUAL (INT-TO-V (IPLUS 1 
                                         (IPLUS (V-TO-INT A) (V-TO-INT B))) 
                                  (LENGTH A)) 
                        (INT-TO-V (IPLUS (V-TO-INT A) 
                                         (IPLUS (V-TO-INT B) 1)) 
                                  (LENGTH A))))
  ((DO-NOT-INDUCT T)
   (enable LESSP-V-TO-NAT-EXP-WITH-EXP-OPENED MY-LESSP-V-TO-NAT-EXP ineg-iplus
           associativity-of-iplus ineg-ineg INTEGERP-INEG plus-difference-arg2
           difference-difference-hack difference-sub1-arg2 DIFFERENCE-PLUS-PLUS-CANCELLATION-HACK)))

(prove-lemma alu-thm_tc-bv-addc-lemma4-lemma1 (rewrite)
 (IMPLIES (AND (LESSP (V-TO-NAT B) 
                      (PLUS (EXP 2 (SUB1 (LENGTH A))) 
                            (EXP 2 (SUB1 (LENGTH A))))) 
               (LESSP (V-TO-NAT A) 
                      (PLUS (EXP 2 (SUB1 (LENGTH A))) 
                            (EXP 2 (SUB1 (LENGTH A)))))
               (NOT 
                (LESSP (PLUS (EXP 2 (SUB1 (LENGTH A))) 
                             (EXP 2 (SUB1 (LENGTH A)))) 
                       (DIFFERENCE (DIFFERENCE (PLUS (EXP 2 (SUB1 (LENGTH A))) 
                                                     (EXP 2 (SUB1 (LENGTH A))) 
                                                     (EXP 2 (SUB1 (LENGTH A))) 
                                                     (EXP 2 (SUB1 (LENGTH A)))) 
                                               (V-TO-NAT A)) 
                                   (V-TO-NAT B))))) 
          (EQUAL 
           (DIFFERENCE 
             (PLUS (EXP 2 (SUB1 (LENGTH A))) 
                   (EXP 2 (SUB1 (LENGTH A)))) 
             (PLUS (DIFFERENCE (PLUS (EXP 2 (SUB1 (LENGTH A))) 
                                     (EXP 2 (SUB1 (LENGTH A)))) 
                               (V-TO-NAT A)) 
                   (SUB1 (DIFFERENCE (PLUS (EXP 2 (SUB1 (LENGTH A))) 
                                           (EXP 2 (SUB1 (LENGTH A)))) 
                                     (V-TO-NAT B))))) 
           (ADD1 (DIFFERENCE (PLUS (V-TO-NAT A) (V-TO-NAT B)) 
                                       (PLUS (EXP 2 (SUB1 (LENGTH A))) 
                                             (EXP 2 (SUB1 (LENGTH A)))))))))

(prove-lemma alu-thm_tc-bv-addc-lemma4 (rewrite)
        (IMPLIES 
             (AND (BVP A) 
                  (LISTP A) 
                  (BVP B) 
                  (LISTP B) 
                  (EQUAL (LENGTH A) (LENGTH B)) 
                  (NEGATIVEP (IPLUS (V-TO-INT A) 
                                    (IPLUS (V-TO-INT B) 1))) 
                  (NOT (LESSP (EXP 2 (SUB1 (LENGTH A))) 
                              (NEGATIVE-GUTS (IPLUS (V-TO-INT A) 
                                                    (IPLUS (V-TO-INT B) 1)))))) 
             (EQUAL (INT-TO-V (IPLUS 1 
                                     (IPLUS (V-TO-INT A) (V-TO-INT B))) 
                              (LENGTH A)) 
                    (INT-TO-V (IPLUS (V-TO-INT A) 
                                     (IPLUS (V-TO-INT B) 1)) 
                              (LENGTH A))))
  ((DO-NOT-INDUCT T)
   (enable LESSP-V-TO-NAT-EXP-WITH-EXP-OPENED MY-LESSP-V-TO-NAT-EXP ineg-iplus
           associativity-of-iplus ineg-ineg INTEGERP-INEG plus-difference-arg2
           difference-difference-hack difference-sub1-arg2 DIFFERENCE-PLUS-PLUS-CANCELLATION-HACK)))

(prove-lemma alu-thm_tc-bv-addc (rewrite)
  (implies (and (bvp a)
                (listp a)
                (bvp b)
                (listp b)
                (equal (length a) (length b))
                (boolp c))
           (equal (bv (v-alu c a b (list f t f f)))
                  (int-to-v
                    (cond ((tc-in-rangep (tc-add (v-to-int a)
                                              (tc-add (v-to-int b) (carry c)))
                                         (length a))
                           (tc-add (v-to-int a)
                                (tc-add (v-to-int b) (carry c))))
                          ((negativep (tc-add (v-to-int a)
                                           (tc-add (v-to-int b) (carry c))))
                           (tc-add (v-to-int a)
                                (tc-add (v-to-int b)
                                     (tc-add (carry c) (exp 2 (length a))))))
                          (t (tc-add (v-to-int a)
                                  (tc-add (v-to-int b)
                                       (tc-add (carry c)
                                            (minus (exp 2 (length a))))))))
                    (length a))))
  ((do-not-induct t) 
   (enable integerp-iplus equal-length-0) 
   (disable V-ZEROP V-ADDER-CARRY-OUT V-ALU-INT-ADDER-OVERFLOWP iplus ineg 
            integerp v-to-int int-to-v exp)))

(prove-lemma alu-thm_tc-v-addc-lemma1 (rewrite)
        (IMPLIES 
              (AND (BVP A) 
                   (LISTP A) 
                   (BVP B) 
                   (LISTP B) 
                   (EQUAL (LENGTH A) (LENGTH B)) 
                   (NOT (NEGATIVEP (IPLUS (V-TO-INT A) 
                                          (IPLUS (V-TO-INT B) 1)))) 
                   (NOT (LESSP (IPLUS (V-TO-INT A) 
                                      (IPLUS (V-TO-INT B) 1)) 
                               (EXP 2 (SUB1 (LENGTH A))))) 
                   (NOT (NEGATIVEP (IPLUS 1 
                                          (IPLUS (V-TO-INT A) (V-TO-INT B)))))) 
              (equal (LESSP (IPLUS 1 
                                   (IPLUS (V-TO-INT A) (V-TO-INT B))) 
                            (EXP 2 (SUB1 (LENGTH A))))
                     f))
  ((DO-NOT-INDUCT T)
   (enable LESSP-V-TO-NAT-EXP-WITH-EXP-OPENED MY-LESSP-V-TO-NAT-EXP ineg-iplus
           associativity-of-iplus ineg-ineg INTEGERP-INEG plus-difference-arg2
           difference-difference-hack difference-sub1-arg2 DIFFERENCE-PLUS-PLUS-CANCELLATION-HACK)))

(prove-lemma alu-thm_tc-v-addc-lemma2 (rewrite)
         (IMPLIES 
            (AND (BVP A) 
                 (LISTP A) 
                 (BVP B) 
                 (LISTP B) 
                 (EQUAL (LENGTH A) (LENGTH B)) 
                 (NOT (NEGATIVEP (IPLUS (V-TO-INT A) 
                                        (IPLUS (V-TO-INT B) 1)))) 
                 (NOT (LESSP (IPLUS (V-TO-INT A) 
                                    (IPLUS (V-TO-INT B) 1)) 
                             (EXP 2 (SUB1 (LENGTH A))))) 
                 (NEGATIVEP (IPLUS 1 
                                   (IPLUS (V-TO-INT A) (V-TO-INT B))))) 
            (equal (LESSP (EXP 2 (SUB1 (LENGTH A))) 
                          (NEGATIVE-GUTS (IPLUS 1 
                                                (IPLUS (V-TO-INT A) (V-TO-INT B)))))
                   t))
  ((DO-NOT-INDUCT T)
   (enable LESSP-V-TO-NAT-EXP-WITH-EXP-OPENED MY-LESSP-V-TO-NAT-EXP ineg-iplus
           associativity-of-iplus ineg-ineg INTEGERP-INEG plus-difference-arg2
           difference-difference-hack difference-sub1-arg2 DIFFERENCE-PLUS-PLUS-CANCELLATION-HACK)))

(prove-lemma alu-thm_tc-v-addc-lemma3 (rewrite)
         (IMPLIES 
              (AND (BVP A) 
                   (LISTP A) 
                   (BVP B) 
                   (LISTP B) 
                   (EQUAL (LENGTH A) (LENGTH B)) 
                   (NEGATIVEP (IPLUS (V-TO-INT A) 
                                     (IPLUS (V-TO-INT B) 1))) 
                   (LESSP (EXP 2 (SUB1 (LENGTH A))) 
                          (NEGATIVE-GUTS (IPLUS (V-TO-INT A) 
                                                (IPLUS (V-TO-INT B) 1)))) 
                   (NOT (NEGATIVEP (IPLUS 1 
                                          (IPLUS (V-TO-INT A) (V-TO-INT B)))))) 
              (equal (LESSP (IPLUS 1 
                                   (IPLUS (V-TO-INT A) (V-TO-INT B))) 
                            (EXP 2 (SUB1 (LENGTH A))))
                     f))
  ((DO-NOT-INDUCT T)
   (enable LESSP-V-TO-NAT-EXP-WITH-EXP-OPENED MY-LESSP-V-TO-NAT-EXP ineg-iplus
           associativity-of-iplus ineg-ineg INTEGERP-INEG plus-difference-arg2
           difference-difference-hack difference-sub1-arg2 DIFFERENCE-PLUS-PLUS-CANCELLATION-HACK)))

(prove-lemma alu-thm_tc-v-addc-lemma4 (rewrite)
         (IMPLIES 
            (AND (BVP A) 
                 (LISTP A) 
                 (BVP B) 
                 (LISTP B) 
                 (EQUAL (LENGTH A) (LENGTH B)) 
                 (NEGATIVEP (IPLUS (V-TO-INT A) 
                                   (IPLUS (V-TO-INT B) 1))) 
                 (LESSP (EXP 2 (SUB1 (LENGTH A))) 
                        (NEGATIVE-GUTS (IPLUS (V-TO-INT A) 
                                              (IPLUS (V-TO-INT B) 1)))) 
                 (NEGATIVEP (IPLUS 1 
                                   (IPLUS (V-TO-INT A) (V-TO-INT B))))) 
            (equal (LESSP (EXP 2 (SUB1 (LENGTH A))) 
                          (NEGATIVE-GUTS (IPLUS 1 
                                                (IPLUS (V-TO-INT A) (V-TO-INT B)))))
                   t))
  ((DO-NOT-INDUCT T)
   (enable LESSP-V-TO-NAT-EXP-WITH-EXP-OPENED MY-LESSP-V-TO-NAT-EXP ineg-iplus
           associativity-of-iplus ineg-ineg INTEGERP-INEG plus-difference-arg2
           difference-difference-hack difference-sub1-arg2 DIFFERENCE-PLUS-PLUS-CANCELLATION-HACK)))
                                                                                                    
(prove-lemma alu-thm_tc-v-addc-lemma5 (rewrite)
         (IMPLIES 
              (AND (BVP A) 
                   (LISTP A) 
                   (BVP B) 
                   (LISTP B) 
                   (EQUAL (LENGTH A) (LENGTH B)) 
                   (NOT (NEGATIVEP (IPLUS (V-TO-INT A) 
                                          (IPLUS (V-TO-INT B) 1)))) 
                   (LESSP (IPLUS (V-TO-INT A) 
                                 (IPLUS (V-TO-INT B) 1)) 
                          (EXP 2 (SUB1 (LENGTH A)))) 
                   (NOT (NEGATIVEP (IPLUS 1 
                                          (IPLUS (V-TO-INT A) (V-TO-INT B)))))) 
              (equal (LESSP (IPLUS 1 
                                   (IPLUS (V-TO-INT A) (V-TO-INT B))) 
                            (EXP 2 (SUB1 (LENGTH A))))
                     t))
  ((DO-NOT-INDUCT T)
   (enable LESSP-V-TO-NAT-EXP-WITH-EXP-OPENED MY-LESSP-V-TO-NAT-EXP ineg-iplus
           associativity-of-iplus ineg-ineg INTEGERP-INEG plus-difference-arg2
           difference-difference-hack difference-sub1-arg2 DIFFERENCE-PLUS-PLUS-CANCELLATION-HACK)))

(prove-lemma alu-thm_tc-v-addc-lemma6 (rewrite)
         (IMPLIES (AND (BVP A) 
                      (LISTP A) 
                      (BVP B) 
                      (LISTP B) 
                      (EQUAL (LENGTH A) (LENGTH B)) 
                      (NOT (NEGATIVEP (IPLUS (V-TO-INT A) 
                                             (IPLUS (V-TO-INT B) 1)))) 
                      (LESSP (IPLUS (V-TO-INT A) 
                                    (IPLUS (V-TO-INT B) 1)) 
                             (EXP 2 (SUB1 (LENGTH A)))) 
                      (NEGATIVEP (IPLUS 1 
                                        (IPLUS (V-TO-INT A) (V-TO-INT B))))) 
                 (equal (LESSP (EXP 2 (SUB1 (LENGTH A))) 
                               (NEGATIVE-GUTS (IPLUS 1 
                                                     (IPLUS (V-TO-INT A) 
                                                            (V-TO-INT B)))))
                        f))
  ((DO-NOT-INDUCT T)
   (enable LESSP-V-TO-NAT-EXP-WITH-EXP-OPENED MY-LESSP-V-TO-NAT-EXP ineg-iplus
           associativity-of-iplus ineg-ineg INTEGERP-INEG plus-difference-arg2
           difference-difference-hack difference-sub1-arg2 DIFFERENCE-PLUS-PLUS-CANCELLATION-HACK)))

(prove-lemma alu-thm_tc-v-addc-lemma7 (rewrite)
         (IMPLIES 
              (AND (BVP A) 
                   (LISTP A) 
                   (BVP B) 
                   (LISTP B) 
                   (EQUAL (LENGTH A) (LENGTH B)) 
                   (NEGATIVEP (IPLUS (V-TO-INT A) 
                                     (IPLUS (V-TO-INT B) 1))) 
                   (NOT (LESSP (EXP 2 (SUB1 (LENGTH A))) 
                               (NEGATIVE-GUTS (IPLUS (V-TO-INT A) 
                                                     (IPLUS (V-TO-INT B) 1))))) 
                   (NOT (NEGATIVEP (IPLUS 1 
                                          (IPLUS (V-TO-INT A) (V-TO-INT B)))))) 
              (equal (LESSP (IPLUS 1 
                                   (IPLUS (V-TO-INT A) (V-TO-INT B))) 
                            (EXP 2 (SUB1 (LENGTH A))))
                     t))
  ((DO-NOT-INDUCT T)
   (enable LESSP-V-TO-NAT-EXP-WITH-EXP-OPENED MY-LESSP-V-TO-NAT-EXP ineg-iplus
           associativity-of-iplus ineg-ineg INTEGERP-INEG plus-difference-arg2
           difference-difference-hack difference-sub1-arg2 DIFFERENCE-PLUS-PLUS-CANCELLATION-HACK)))

(prove-lemma alu-thm_tc-v-addc-lemma8 (rewrite)
         (IMPLIES 
              (AND (BVP A) 
                   (LISTP A) 
                   (BVP B) 
                   (LISTP B) 
                   (EQUAL (LENGTH A) (LENGTH B)) 
                   (NEGATIVEP (IPLUS (V-TO-INT A) 
                                     (IPLUS (V-TO-INT B) 1))) 
                   (NOT (LESSP (EXP 2 (SUB1 (LENGTH A))) 
                               (NEGATIVE-GUTS (IPLUS (V-TO-INT A) 
                                                     (IPLUS (V-TO-INT B) 1))))) 
                   (NEGATIVEP (IPLUS 1 
                                     (IPLUS (V-TO-INT A) (V-TO-INT B))))) 
              (equal (LESSP (EXP 2 (SUB1 (LENGTH A))) 
                            (NEGATIVE-GUTS (IPLUS 1 
                                                  (IPLUS (V-TO-INT A) 
                                                         (V-TO-INT B)))))
                     f))
  ((DO-NOT-INDUCT T)
   (enable LESSP-V-TO-NAT-EXP-WITH-EXP-OPENED MY-LESSP-V-TO-NAT-EXP ineg-iplus
           associativity-of-iplus ineg-ineg INTEGERP-INEG plus-difference-arg2
           difference-difference-hack difference-sub1-arg2 DIFFERENCE-PLUS-PLUS-CANCELLATION-HACK)))

(prove-lemma alu-thm_tc-v-addc (rewrite)
  (implies (and (bvp a)
                (listp a)
                (bvp b)
                (listp b)
                (equal (length a) (length b))
                (boolp c))
           (equal (v (v-alu c a b (list f t f f)))
                  (not
                   (tc-in-rangep (tc-add (v-to-int a)
                                      (tc-add (v-to-int b) (carry c)))
                                 (length a)))))
  ((do-not-induct t) 
   (enable integerp-iplus equal-length-0) 
   (disable V-ZEROP V-ADDER-CARRY-OUT V-ALU-INT-ADDER-OUTPUT iplus ineg 
            integerp v-to-int int-to-v exp)))

(prove-lemma alu-thm_tc-bv-incr-lemma1 (rewrite)
         (IMPLIES (AND (BVP A) 
                      (LISTP A) 
                      (NOT (NEGATIVEP (IPLUS (V-TO-INT A) 1))) 
                      (NOT (LESSP (IPLUS (V-TO-INT A) 1) 
                                  (EXP 2 (SUB1 (LENGTH A)))))) 
                 (EQUAL (INT-TO-V (IPLUS (V-TO-INT A) 
                                         (IPLUS 1 (MINUS (EXP 2 (LENGTH A))))) 
                                  (LENGTH A)) 
                        (INT-TO-V (IPLUS 1 (V-TO-INT A)) 
                                  (LENGTH A))))
  ((DO-NOT-INDUCT T)
   (enable LESSP-V-TO-NAT-EXP-WITH-EXP-OPENED MY-LESSP-V-TO-NAT-EXP ineg-iplus
           associativity-of-iplus ineg-ineg INTEGERP-INEG plus-difference-arg2
           difference-difference-hack difference-sub1-arg2 DIFFERENCE-PLUS-PLUS-CANCELLATION-HACK)))

(prove-lemma alu-thm_tc-bv-incr-lemma2 (rewrite)
         (IMPLIES (AND (BVP A) 
                      (LISTP A) 
                      (NEGATIVEP (IPLUS (V-TO-INT A) 1)) 
                      (LESSP (EXP 2 (SUB1 (LENGTH A))) 
                             (NEGATIVE-GUTS (IPLUS (V-TO-INT A) 1)))) 
                 (EQUAL (INT-TO-V (IPLUS (V-TO-INT A) 
                                         (IPLUS 1 (EXP 2 (LENGTH A)))) 
                                  (LENGTH A)) 
                        (INT-TO-V (IPLUS 1 (V-TO-INT A)) 
                                  (LENGTH A))))
  ((DO-NOT-INDUCT T)
   (enable LESSP-V-TO-NAT-EXP-WITH-EXP-OPENED MY-LESSP-V-TO-NAT-EXP ineg-iplus
           associativity-of-iplus ineg-ineg INTEGERP-INEG plus-difference-arg2
           difference-difference-hack difference-sub1-arg2 DIFFERENCE-PLUS-PLUS-CANCELLATION-HACK)))

(prove-lemma alu-thm_tc-bv-incr (rewrite)
  (implies (and (bvp a)
                (listp a)
                (bvp b)
                (listp b)
                (equal (length a) (length b))
                (boolp c))
           (equal (bv (v-alu c a b (list t f f f)))
                  (int-to-v
                    (cond ((tc-in-rangep (tc-add (v-to-int a) 1)
                                         (length a))
                           (tc-add (v-to-int a) 1))
                          ((negativep (tc-add (v-to-int a) 1))
                           (tc-add (v-to-int a)
                                (tc-add 1 (exp 2 (length a)))))
                          (t (tc-add (v-to-int a)
                                  (tc-add 1 (minus (exp 2 (length a)))))))
                    (length a))))
  ((do-not-induct t) 
   (enable integerp-iplus equal-length-0 commutativity-of-iplus) 
   (disable V-ZEROP V-ADDER-CARRY-OUT V-ALU-INT-ADDER-OVERFLOWP iplus ineg 
            integerp v-to-int int-to-v exp)))

; That completes the alu interpretation lemmas.  Now we disable everything we did
; in this section other than the old-style interpretation lemmas (i.e., we make the
; data base behave as though we had done an add-axiom for each of the interpretation
; lemmas).  The reason for this is that the first time we rebuilt Piton on FM9001 we
; skipped the proofs of these boring facts so we could get on with the interesting
; part and now, having proved them, we have to make sure the lemmas we added don't
; mess up future proofs.

(DISABLE-THEORY
 (EQUAL-LENGTH-0 NEGATIVEP-INEG NOT-EQUAL-EXP-0 INEG-EXP-2-X DIFF-DIFF
  ALU-THM_TC-BV-SUB-LEMMA ALU-THM_TC-BV-SUB-LEMMA2 DIFF-PLUS-CANCELLATION-HACK2
  DIFF-PLUS-SUB1-HACK1 ALU-THM_TC-BV-SUBB-LEMMA1 DIFF-PLUS-SUB1-HACK2
  ALU-THM_TC-BV-SUBB-LEMMA2-LEMMA1 DIFF-PLUS-SUB1-HACK2-OFF
  ALU-THM_TC-BV-SUBB-LEMMA2 V-TO-INT-INT-TO-V-0 my-LENGTH-INT-TO-V
  ALU-THM_TC-BV-DECR-LEMMA1 ALU-THM_TC-BV-DECR-LEMMA2 IPLUS-0-2
  ALU-THM_TC-BV-NEG-LEMMA1 ALU-THM_TC-BV-NEG-LEMMA2 ALU-THM_TC-BV-NEG-LEMMA3
  ALU-THM_TC-BV-NEG-LEMMA4 ALU-THM_TC-BV-NEG-LEMMA5 ALU-THM_TC-BV-NEG-LEMMA6
  DIFF-PLUS-PLUS-PLUS-CANCELLATION ALU-THM_TC-BV-ADD-LEMMA1
  ALU-THM_TC-BV-ADD-LEMMA2 ALU-THM_TC-BV-ADDC-LEMMA1 ALU-THM_TC-BV-ADDC-LEMMA2
  ALU-THM_TC-BV-ADDC-LEMMA3-KILLER1 ALU-THM_TC-BV-ADDC-LEMMA3-KILLER2
  ALU-THM_TC-BV-ADDC-LEMMA3-KILLER3 ALU-THM_TC-BV-ADDC-LEMMA3-LEMMA1
  ALU-THM_TC-BV-ADDC-LEMMA3-LEMMA2 ALU-THM_TC-BV-ADDC-LEMMA3-KILLER1-OFF
  ALU-THM_TC-BV-ADDC-LEMMA3-KILLER2-OFF ALU-THM_TC-BV-ADDC-LEMMA3-KILLER3-OFF
  ALU-THM_TC-BV-ADDC-LEMMA3 ALU-THM_TC-BV-ADDC-LEMMA4-LEMMA1
  ALU-THM_TC-BV-ADDC-LEMMA4 ALU-THM_TC-V-ADDC-LEMMA1 ALU-THM_TC-V-ADDC-LEMMA2
  ALU-THM_TC-V-ADDC-LEMMA3 ALU-THM_TC-V-ADDC-LEMMA4 ALU-THM_TC-V-ADDC-LEMMA5
  ALU-THM_TC-V-ADDC-LEMMA6 ALU-THM_TC-V-ADDC-LEMMA7 ALU-THM_TC-V-ADDC-LEMMA8
  ALU-THM_TC-BV-INCR-LEMMA1 ALU-THM_TC-BV-INCR-LEMMA2 BV V C
  V-ALU-CORRECT-INT-REWRITER UNLABEL I-USR-DATA-TYPEP))

; This completes our rule base for the alu.  We should now be able
; to reduce any bv-alu-cv expression that arises.

; This completes the preliminary pass from m down to fm9001.


; I now prove a few useful equivalences between
; concepts at the m level and concepts at the i level.

(prove-lemma nth-is-get (rewrite)
  (equal (nth n l) (get n l)))

(prove-lemma update-nth-is-put (rewrite)
  (implies (lessp n (length l))
           (equal (update-nth n l v)
                  (put v n l))))

; Goal:  v-to-nat-inverts-nat-to-v

; Subgoal: remainder-quotient-elim

; First we build up the classic proof of remainder-quotient-elim, doing
; a lot of arithmetic along the way.

(enable difference-elim)

(prove-lemma difference-elim-rewrite (rewrite)
 (implies (and (numberp x)
               (not (lessp x y)))
          (equal (plus (difference x y) y) x)))

(prove-lemma v-to-nat-inverts-nat-to-v (rewrite)
  (implies (small-naturalp n word-size)
           (equal (v-to-nat (nat-to-v n word-size))
                  n)))

; QED:  v-to-nat-inverts-nat-to-v


; Next I will speed up the handling of i-objectp-type for
; the case where the type is a quoted constant.

(prove-lemma i-objectp-type-simplifier (rewrite)
  (and (equal (i-objectp-type 'nat x i)
              (and (equal (type x) 'nat)
                   (equal (cddr x) nil)
                   (small-naturalp (untag x)
                                   (i-word-size i))))
       (equal (i-objectp-type 'int x i)
              (and (equal (type x) 'int)
                   (equal (cddr x) nil)
                   (small-integerp (untag x)
                                   (i-word-size i))))
       (equal (i-objectp-type 'bitv x i)
              (and (equal (type x) 'bitv)
                   (equal (cddr x) nil)
                   (bit-vectorp (untag x)
                                (i-word-size i))))
       (equal (i-objectp-type 'bool x i)
              (and (equal (type x) 'bool)
                   (equal (cddr x) nil)
                   (booleanp (untag x))))
       (equal (i-objectp-type 'addr x i)
              (and (equal (type x) 'addr)
                   (equal (cddr x) nil)
                   (adpp (untag x)
                         (i-usr-data-segment i))))
       (equal (i-objectp-type 'pc x i)
              (and (equal (type x) 'pc)
                   (equal (cddr x) nil)
                   (icode-labelp (untag x)
                                 (i-prog-segment i))))
       (equal (i-objectp-type 'subr x i)
              (and (equal (type x) 'subr)
                   (equal (cddr x) nil)
                   (adpp (cons (untag x) 0)
                         (i-prog-segment i))))
       (equal (i-objectp-type 'sys-addr x i)
              (and (equal (type x) 'sys-addr)
                   (equal (cddr x) nil)
                   (adpp (untag x)
                         (i-sys-data-segment i))))
       (equal (i-objectp-type 'ipc x i)
              (and (equal (type x) 'ipc)
                   (equal (cddr x) nil)
                   (adpp (untag x) (i-prog-segment i))))))

(disable i-objectp-type)


; I will disable type, tag and untag for sanity's sake,
; but prove the obvious relationships first.

(prove-lemma type-tag (rewrite)
  (equal (type (tag x y)) x))

(prove-lemma untag-tag (rewrite)
  (equal (untag (tag x y)) y))

(disable type)
(disable tag)
(disable untag)

; And I will do a similar thing for the adp handlers

(prove-lemma adp-name-cons (rewrite)
 (equal (adp-name (cons name offset)) name))
(prove-lemma adp-offset-cons (rewrite)
 (equal (adp-offset (cons name offset)) offset))
(prove-lemma adp-name-add-adp (rewrite)
 (equal (adp-name (add-adp adp n))
        (adp-name adp)))
(prove-lemma adp-offset-add-adp (rewrite)
 (equal (adp-offset (add-adp adp n))
        (plus (adp-offset adp) n)))
(prove-lemma adp-name-sub-adp (rewrite)
 (equal (adp-name (sub-adp adp n))
        (adp-name adp)))
(prove-lemma adp-offset-sub-adp (rewrite)
 (equal (adp-offset (sub-adp adp n))
        (difference (adp-offset adp) n)))
(disable sub-adp)
(disable add-adp)
(disable adp-name)
(disable adp-offset)

; The function BOOLEANP is a killer because it
; causes everything to split.  I will disable it
; and prove what I need about it as necessary.

(disable booleanp)

(disable bool-to-logical)

; I am now going to partition the conjunctions of i-state-okp
; into two pots.  The first pot will put into the function
; defined below, i-state-types-okp, which will remain disabled.
; I will extract stuff from this hyp by back chaining when
; necessary.

(defn i-state-types-okp (i)
  (and 
    (i-statep i)
    (equal (type (i-pc i)) 'ipc)
    (equal (cddr (i-pc i)) nil)
    (listp (untag (i-pc i)))
    (definedp (adp-name (untag (i-pc i)))
              (i-prog-segment i))
    (equal (type (i-cfp i)) 'sys-addr)
    (listp (untag (i-cfp i)))
    (equal (adp-name (untag (i-cfp i)))
           'cstk)
    (equal (cddr (i-cfp i)) nil)
    (definedp 'cstk
              (i-sys-data-segment i))
    (equal (type (i-csp i)) 'sys-addr)
    (listp (untag (i-csp i)))
    (equal (adp-name (untag (i-csp i)))
           'cstk)
    (equal (cddr (i-csp i)) nil)
    (equal (type (i-tsp i)) 'sys-addr)
    (listp (untag (i-tsp i)))
    (equal (adp-name (untag (i-tsp i)))
           'tstk)
    (equal (cddr (i-tsp i)) nil)
    (definedp 'tstk
              (i-sys-data-segment i))
    (equal (type (i-c-flg i)) 'bool)
    (equal (cddr (i-c-flg i)) nil)
    (booleanp (untag (i-c-flg i)))
    (equal (type (i-v-flg i)) 'bool)
    (equal (cddr (i-v-flg i)) nil)
    (booleanp (untag (i-v-flg i)))
    (equal (type (i-n-flg i)) 'bool)
    (equal (cddr (i-n-flg i)) nil)
    (booleanp (untag (i-n-flg i)))
    (equal (type (i-z-flg i)) 'bool)
    (equal (cddr (i-z-flg i)) nil)
    (booleanp (untag (i-z-flg i)))))

; The second pot will be introduced explicitly into any clause
; containing i-state-okp.  These hyps will all be useful to
; linear and I don't want to hide them.

; Here is the lemma that does the restructuring.

(prove-lemma i-state-okp-restructuring (rewrite)
  (equal (i-state-okp i load-addr)
         (and (i-state-types-okp i)
              (numberp (adp-offset (untag (i-pc i))))
              (lessp (adp-offset (untag (i-pc i)))
                     (length (cdr (assoc (adp-name (untag (i-pc i)))
                                         (i-prog-segment i)))))
              (numberp (adp-offset (untag (i-cfp i))))
              (lessp (adp-offset (untag (i-cfp i)))
                     (length (cdr (assoc 'cstk
                                         (i-sys-data-segment i)))))
              (numberp (adp-offset (untag (i-csp i))))
              (lessp (adp-offset (untag (i-csp i)))
                     (length (cdr (assoc 'cstk
                                         (i-sys-data-segment i)))))
              (numberp (adp-offset (untag (i-tsp i))))
              (lessp (adp-offset (untag (i-tsp i)))
                     (length (cdr (assoc 'tstk
                                         (i-sys-data-segment i)))))
              (lessp (plus load-addr
                           (segment-length (i-prog-segment i))
                           (segment-length (i-usr-data-segment i))
                           (segment-length (i-sys-data-segment i)))
                     (exp 2 (i-word-size i))))))

(disable i-state-okp)

; And here is the lemma that lets me back chain into i-state-types-okp.

(prove-lemma i-state-types-okp-properties (rewrite)
  (implies (i-state-types-okp i)
           (and 
             (i-statep i)
             (equal (type (i-pc i)) 'ipc)
             (equal (cddr (i-pc i)) nil)
             (equal (listp (untag (i-pc i))) t)
             (definedp (adp-name (untag (i-pc i)))
                       (i-prog-segment i))
             (equal (type (i-cfp i)) 'sys-addr)
             (equal (listp (untag (i-cfp i))) t)
             (equal (adp-name (untag (i-cfp i)))
                    'cstk)
             (equal (cddr (i-cfp i)) nil)
             (definedp 'cstk
                       (i-sys-data-segment i))
             (equal (type (i-csp i)) 'sys-addr)
             (equal (listp (untag (i-csp i))) t)
             (equal (adp-name (untag (i-csp i)))
                    'cstk)
             (equal (cddr (i-csp i)) nil)
             (equal (type (i-tsp i)) 'sys-addr)
             (equal (listp (untag (i-tsp i))) t)
             (equal (adp-name (untag (i-tsp i)))
                    'tstk)
             (equal (cddr (i-tsp i)) nil)
             (definedp 'tstk
                       (i-sys-data-segment i))
             (equal (type (i-c-flg i)) 'bool)
             (equal (cddr (i-c-flg i)) nil)
             (booleanp (untag (i-c-flg i)))
             (equal (type (i-v-flg i)) 'bool)
             (equal (cddr (i-v-flg i)) nil)
             (booleanp (untag (i-v-flg i)))
             (equal (type (i-n-flg i)) 'bool)
             (equal (cddr (i-n-flg i)) nil)
             (booleanp (untag (i-n-flg i)))
             (equal (type (i-z-flg i)) 'bool)
             (equal (cddr (i-z-flg i)) nil)
             (booleanp (untag (i-z-flg i))))))

(disable i-state-types-okp)

; Some accellerators for psw handling...

(prove-lemma not-equal-x-y-error-msg-run (rewrite)
  (not (equal (x-y-error-msg x y) 'run)))

(disable x-y-error-msg)

(prove-lemma i-psw-i-halt (rewrite)
  (equal (i-psw (i-halt i psw)) psw))

(disable i-halt)


; Disabling some messy functions.

; I will disable a bunch of functions that cause large case
; splits.  These functions will have to be explicitly enabled
; to do proofs about their values.

(prove-lemma link-instr-word-expander (rewrite)
  (equal (link-instr-word (cons opcode nil) word-size)
         (mci (cadr (assoc opcode
                           (link-instruction-alist)))
              word-size)))

(disable link-instr-word)

(prove-lemma link-data-word-expander (rewrite)
  (implies (litatom (type x))
           (equal (link-data-word x link-tables word-size)
                  (case (type x)
                    (nat (nat-to-v (untag x) word-size))
                    (int (int-to-v (untag x) word-size))
                    (bitv (bitv-to-v (untag x) word-size))
                    (bool (BOOL-TO-V (untag x) word-size))
                    (addr (ADDR-TO-V (untag x)
                                      (usr-data-links link-tables)
                                      word-size))
                    (subr (subr-to-v (untag x)
                                      (prog-links link-tables)
                                      word-size))
                    (sys-addr (sys-addr-to-v (untag x)
                                              (sys-data-links link-tables)
                                              word-size))
                    (pc (label-to-v (untag x)
                                     (prog-label-tables link-tables)
                                     word-size))
                    (ipc (ipc-to-v (untag x)
                                    (prog-links link-tables)
                                    word-size))
                    (otherwise (nat-to-v 0 word-size))))))

(prove-lemma size-incr (rewrite)
  (equal (length (incr c a)) (length a)))

(prove-lemma size-compl (rewrite)
  (equal (length (v-not a)) (length a)))

(prove-lemma size-bitv-to-v (rewrite)
  (equal (length (bitv-to-v a word-size)) (fix word-size)))

(prove-lemma size-link-data-word (rewrite)
 (equal (length (link-data-word x link-tables word-size))
        (fix word-size)))

(disable link-data-word)

(disable *1*exp)

(prove-lemma size-link-instr-word (rewrite)
  (equal (length (link-instr-word ins word-size))
         (fix word-size))
  ((enable link-instr-word)
   (disable *1*link-instruction-alist link-instruction-alist
            extract-op extract-move-bits extract-cvnz extract-mode
            extract-reg)))

(prove-lemma size-link-word (rewrite)
  (equal (length (link-word x link-tables word-size))
         (fix word-size)))

(prove-lemma link-word-expander (rewrite)
  (and (implies (icode-instructionp x)
                (equal (link-word x link-tables word-size)
                       (link-instr-word x word-size)))
       (implies (not (icode-instructionp x))
                (equal (link-word x link-tables word-size)
                       (link-data-word x link-tables word-size)))))

(disable link-word)

; I am going to keep the i-link-tables function turned off and
; enable it as needed.  It expands into something I don't like
; reading.  Instead I'll prove the rewrite rules that let the
; four accessors work on it.

(prove-lemma prog-links-i-link-tables (rewrite)
  (equal (prog-links (i-link-tables i load-addr))
         (link-table-for-segment
          (i-prog-segment i)
          (plus load-addr
                (segment-length (i-usr-data-segment i))))))

(prove-lemma prog-label-tables-i-link-tables (rewrite)
  (equal (prog-label-tables (i-link-tables i load-addr))
         (link-table-for-prog-labels
          (i-prog-segment i)
          (plus load-addr
                (segment-length (i-usr-data-segment i))))))

(prove-lemma usr-data-links-i-link-tables (rewrite)
  (equal (usr-data-links (i-link-tables i load-addr))
         (link-table-for-segment (i-usr-data-segment i)
                                 load-addr)))

(prove-lemma sys-data-links-i-link-tables (rewrite)
  (equal (sys-data-links (i-link-tables i load-addr))
         (link-table-for-segment
          (i-sys-data-segment i)
          (plus load-addr
                (segment-length (i-prog-segment i))
                (segment-length (i-usr-data-segment i))))))

(disable i-link-tables)
(disable prog-links)
(disable prog-label-tables)
(disable usr-data-links)
(disable sys-data-links)

; Goal:  The fundamental theorems about Link Tables



(prove-lemma assoc-append (rewrite)
  (equal (assoc x (append alist1 alist2))
         (if (definedp x alist1)
             (assoc x alist1)
             (assoc x alist2))))

(prove-lemma get-append-1 (rewrite)
  (implies (lessp n (length a))
           (equal (get n (append a b))
                  (get n a))))

(prove-lemma get-append-2 (rewrite)
  (implies (equal n (length a))
           (equal (get (plus n k) (append a b))
                  (get k b))))

; Because we have swapped the positions of the data and prog
; segments we have to add the following version of get-append-2.
; Unknownst to me, the original proof exploited the fact that
; "i-prog-segment" comes lexicographically before "i-usr-data-segment"
; so that when the segment-lengths of those two are commuted into
; order the order agreed with that used by link-mem, namely,
; the prog-segment comes first.

(prove-lemma get-append-3 (rewrite)
  (implies (and (equal n1 (length a1))
                (equal n2 (length a2)))
           (equal (get (plus n2 n1 k)
                       (append a1 (append a2 b)))
                  (get k b)))
  ((disable get-append-2)
   (enable commutativity-of-plus commutativity2-of-plus)
   (use (get-append-2 (n n1)(a a1)(k (plus n2 k))(b (append a2 b)))
        (get-append-2 (n n2)(a a2)(k k)(b b)))))

(prove-lemma length-link-area-is-length (rewrite)
  (equal (length (link-area lst table word-size))
         (length lst)))

(enable associativity-of-append)

(prove-lemma get-link-area (rewrite)
  (implies (lessp n (length area))
           (equal (get n (link-area area table word-size))
                  (link-word (unlabel (get n area)) table word-size))))

(defn link-table-entry (name segment)
  (if (nlistp segment)
      0
      (if (equal name (caar segment))
          0
          (plus (length (cdar segment))
                (link-table-entry name (cdr segment))))))


(defn label-table-entry (lab segment)
  (find-label lab (cdr (assoc (car lab) segment))))


(prove-lemma assoc-link-table-for-segment (rewrite)
  (implies (and (definedp name segment)
                (numberp addr0))
           (equal (cdr (assoc name (link-table-for-segment segment addr0)))
                  (plus addr0 (link-table-entry name segment)))))

(prove-lemma lessp-absolute-address-segment-length-generalized nil
  (implies (and (definedp name segment)
                (lessp offset (length (cdr (assoc name segment)))))
           (lessp (plus (link-table-entry name segment) offset)
                  (segment-length segment))))

;  In anticipation of the various uses of this fact, we prove four
;  instances...

(prove-lemma lessp-absolute-address-segment-length-adp-name (rewrite)
  (implies (and (definedp (adp-name adp) segment)
                (lessp (adp-offset adp)
                       (length (cdr (assoc (adp-name adp) segment)))))
           (lessp (plus (link-table-entry (adp-name adp) segment)
                        (adp-offset adp))
                  (segment-length segment)))
  ((use (lessp-absolute-address-segment-length-generalized
          (name (adp-name adp))
          (offset (adp-offset adp))))))

(prove-lemma lessp-absolute-address-segment-length-cfp (rewrite)
  (implies (and (definedp 'cstk (i-sys-data-segment i))
                (lessp (adp-offset (untag (i-cfp i)))
                       (length (cdr (assoc 'cstk
                                           (i-sys-data-segment i))))))
           (lessp (plus (link-table-entry 'cstk
                                          (i-sys-data-segment i))
                        (adp-offset (untag (i-cfp i))))
                  (segment-length (i-sys-data-segment i))))
  ((use (lessp-absolute-address-segment-length-generalized
          (name 'cstk)
          (offset (adp-offset (untag (i-cfp i))))
          (segment (i-sys-data-segment i))))))

(prove-lemma lessp-absolute-address-segment-length-csp (rewrite)
  (implies (and (definedp 'cstk (i-sys-data-segment i))
                (lessp (adp-offset (untag (i-csp i)))
                       (length (cdr (assoc 'cstk
                                           (i-sys-data-segment i))))))
           (lessp (plus (link-table-entry 'cstk
                                          (i-sys-data-segment i))
                        (adp-offset (untag (i-csp i))))
                  (segment-length (i-sys-data-segment i))))
  ((use (lessp-absolute-address-segment-length-generalized
          (name 'cstk)
          (offset (adp-offset (untag (i-csp i))))
          (segment (i-sys-data-segment i))))))

(prove-lemma lessp-absolute-address-segment-length-tsp (rewrite)
  (implies (and (definedp 'tstk (i-sys-data-segment i))
                (lessp (adp-offset (untag (i-tsp i)))
                       (length (cdr (assoc 'tstk
                                           (i-sys-data-segment i))))))
           (lessp (plus (link-table-entry 'tstk
                                          (i-sys-data-segment i))
                        (adp-offset (untag (i-tsp i))))
                  (segment-length (i-sys-data-segment i))))
  ((use (lessp-absolute-address-segment-length-generalized
          (name 'tstk)
          (offset (adp-offset (untag (i-tsp i))))
          (segment (i-sys-data-segment i))))))

(enable length-append)

(prove-lemma length-link-segment-is-segment-length (rewrite)
             (equal (length (link-segment segment table word-size))
                    (segment-length segment)))

(disable commutativity-of-plus)

(prove-lemma get-link-table-entry-link-segment (rewrite)
  (implies (and (definedp (adp-name adp) segment)
                (lessp (adp-offset adp)
                       (length (cdr (assoc (adp-name adp) segment)))))
           (equal (get (plus (link-table-entry (adp-name adp) segment)
                             (adp-offset adp))
                       (link-segment segment table word-size))
                  (link-word
                    (unlabel
                      (get (adp-offset adp)
                           (cdr (assoc (adp-name adp) segment))))
                    table
                    word-size))))

; The above lemma states the fundamental relationship between
; linking and fetching.

; At this point we have enough machinery to reduce any legal
; current-instruction fetch at the m level to a link-word of the
; i level.

; We can speed things up in the subsequent proofs if we package
; this knowledge up.  We do it by proving a fact about
; current-instruction.  We still need the foregoing machinery for
; those occasions when the m machine fetches data from program memory.
; But after this we will disable current-instruction and at least
; short circuit all this for the top level fetch for each instruction.


; We first make it possible to get and put past the boot-code in
; linked memory.  By doing it this way (proving length-boot-code to introduce
; fix and this disabling it when we are done) we prevent all future
; splits on whether load-addr is numeric.

(prove-lemma length-boot-code (rewrite)
  (equal (length (boot-code lst n word-size)) (fix n)))

(prove-lemma get-past-boot-code (rewrite)
  (equal (get (plus load-addr n)
              (append (boot-code boot-lst load-addr word-size) a))
         (get n a)))

; When the address in question has been incremented or decremented,
; as happens when it is a stack pointer, we need:

(prove-lemma get-past-boot-code-add1 (rewrite)
  (equal (get (add1 (plus load-addr n))
              (append (boot-code boot-lst load-addr word-size) a))
         (get (add1 n) a))
  ((disable get-past-boot-code)
   (use (get-past-boot-code (n (add1 n))))))

(prove-lemma get-past-boot-code-sub1 (rewrite)
  (implies (not (zerop n))
           (equal (get (sub1 (plus load-addr n))
                       (append (boot-code boot-lst load-addr word-size) a))
                  (get (sub1 n) a)))
  ((disable get-past-boot-code)
   (use (get-past-boot-code (n (sub1 n))))))

(prove-lemma put-past-boot-code (rewrite)
  (equal (put val
              (plus load-addr n)
              (append (boot-code boot-lst load-addr word-size) a))
         (append (boot-code boot-lst load-addr word-size)
                 (put val n a))))

(prove-lemma put-past-boot-code-add1 (rewrite)
  (equal (put val
              (add1 (plus load-addr n))
              (append (boot-code boot-lst load-addr word-size) a))
         (append (boot-code boot-lst load-addr word-size)
                 (put val (add1 n) a)))
  ((disable put-past-boot-code)
   (use (put-past-boot-code (n (add1 n))))))

(prove-lemma put-past-boot-code-sub1 (rewrite)
  (implies (not (zerop n))
           (equal (put val
                       (sub1 (plus load-addr n))
                       (append (boot-code boot-lst load-addr word-size) a))
                  (append (boot-code boot-lst load-addr word-size)
                          (put val (sub1 n) a))))
  ((disable put-past-boot-code)
   (use (put-past-boot-code (n (sub1 n))))))

(prove-lemma length-boot-code-linear (rewrite)
  (and (not (lessp load-addr (length (boot-code boot-lst load-addr word-size))))
       (not (lessp (length (boot-code boot-lst load-addr word-size)) load-addr))))

(disable length-boot-code)

(prove-lemma current-instruction-i->m (rewrite)
  (implies
    (and (i-state-types-okp i)
         (numberp (adp-offset (untag (i-pc i))))
         (lessp (adp-offset (untag (i-pc i)))
                (length (cdr (assoc (adp-name (untag (i-pc i)))
                                    (i-prog-segment i)))))
         (lessp (plus load-addr
                      (segment-length (i-prog-segment i))
                      (segment-length (i-usr-data-segment i))
                      (segment-length (i-sys-data-segment i)))
                (exp 2 32))
         (equal (i-word-size i) 32))
    (equal
      (current-instruction
       (list r0 r1 r2 r3 r4 r5 r6 r7
             r8 r9 r10 r11 r12 r13 r14
             (nat-to-v
              (plus load-addr
                    (segment-length (i-usr-data-segment i))
                    (link-table-entry (adp-name (untag (i-pc i)))
                                      (i-prog-segment i))
                    (adp-offset (untag (i-pc i))))
              32))
       (append (boot-code boot-lst load-addr 32)
               (append (LINK-SEGMENT (I-USR-DATA-SEGMENT I) 
                                     (I-LINK-TABLES I LOAD-ADDR) 
                                     32)
                       (append
                        (link-segment
                         (i-prog-segment i)
                         (i-link-tables i load-addr)
                         32)
                        data-mem))))
      (link-word (unlabel
                   (fetch (i-pc i) (i-prog-segment i)))
                 (i-link-tables i load-addr)
                 32)))
  ((enable i-state-types-okp)))

(disable current-instruction)
                  
; The following section of this file documents about a half-day's
; work.

; I am headed for a simple theorem, namely that the i-psw of
; i-ins-step is 'run.  This follows immediately by opening up
; the -step fn for each i-level opcode and observing that the
; i-psw in each is 'run.  But there is much case analysis.
; To help out, I will disable -- in fact, hands-off -- every
; function used by any of the -step fns.  In addition, I provide
; the following accelerators:

(prove-lemma equal-i-psw-if-1 (rewrite)
  (equal (equal (i-psw (if t1 b1 b2)) 'run)
         (if t1
             (equal (i-psw b1) 'run)
             (equal (i-psw b2) 'run))))

(prove-lemma equal-i-psw-if-2 (rewrite)
  (equal (equal (i-psw (if t1 b1 (if t2 b2 b3))) 'run)
         (if t1
             (equal (i-psw b1) 'run)
             (if t2
                 (equal (i-psw b2) 'run)
                 (equal (i-psw b3) 'run)))))

(prove-lemma equal-i-psw-i-ins-step-run (rewrite)
  (equal (i-psw (i-ins-step ins i load-addr)) 'run)
  ((hands-off
    lsh-bitv times add-addr small-naturalp fix-small-natural and-bitv
    and-bool sub1 remainder quotient rsh-bitv inegate not-bitv or-bitv
    or-bool sub-addr offset exp difference plus lessp small-integerp
    not bool-to-nat iplus idifference fix-small-integer area-name
    definition ipc negativep pop-stk push-stk xor-bitv i-nextword untag
    xor-bool i-z-flg add2-i-pc i-word-size tag deposit
    i-usr-data-segment i-prog-segment i-sys-data-segment fetch xor-xxx
    all-zero-bitvp bool i-n-flg i-v-flg i-c-flg i-y i-x i-tsp i-csp
    i-cfp add1-i-pc i-state pack cons add1 zero)))

; Note: The hint above was mechanically generated; it is the list of
; all function symbols occurring in the body of any i-xxx-step fn, minus
; i-psw.  We clearly do not wish to keep hands off of (i-psw (i-state ...)).

; During the morning I have proved this theorem many times.  Here are
; some observations.  I don't remember what happens if you try it without
; any preparation, but either it explodes into many cases or it gets
; stack overflow.  I first included just a (hands-off i-state) under
; the mistaken belief that it would prevent all the (i-state ...)'s from
; being rewritten.  But it does not prevent the args to the i-state being
; rewritten so I disabled all the fns listed above.  However, that still
; permitted rewrite rules to be applied to them and so I did a hands-off
; on them instead.

; More interesting is the use of the two lemmas, equal-i-psw-if-1 and -2.
; The first I call the "single stripper" and the second the "double stripper."

; With just the single stripper around you get a stack overflow.  That is
; because rewrite recurses several times for every application of the
; lemma and there are so many opcodes.  My first attempt to solve this
; was to prove a backchaining version of the single stripper.  It said
; "if the psw of b and c are both 'run then the psw of (if a b c) is too."
; That causes fewer recursions in the rewriter and permitted the proof
; to go through, but cost 8538 seconds!  

; Then I hit upon the idea of the double stripper, which cuts in half the
; number of applications -- and this recursions -- necessary.  If the
; double stripper is available but the single stripper is not, the
; proof goes through but generates 30 cases and takes 354 seconds.

; Analysis of this showed that the problem is that some of our -step
; fns generate terms of the form (if & (i-state ...) (i-state ...)) and
; the double stripper could not be applied to these.  They get elevated
; to explicit cases.

; If both strippers are present, the proof goes through without any
; visible cases and takes 46 seconds.

; End of aside.

; In the one-way correspondence theorems I have the hypothesis
; that (i-step i load-addr) does not produce an error and then I make a
; statement about (i->m (i-step i load-addr) boot-lst load-addr).  The two occurrences of
; i-step bother me and the following theorem lets me replace the
; first with a conjunction of predicates.

(prove-lemma i-psw-i-step-run (rewrite)
  (equal (equal (i-psw (i-step i load-addr)) 'run)
         (and (equal (i-psw i) 'run)
              (i-state-okp i load-addr)
              (i-ins-okp (i-current-instruction i) i)))
  ((disable i-ins-okp i-ins-step i-current-instruction)))

(prove-lemma i-link-tables-i-state (rewrite)
  (implies (and (equal (link-table-for-segment
                         i-usr-data-segment
                         load-addr)
                       (link-table-for-segment
                         (i-usr-data-segment i)
                         load-addr))
                (equal (segment-length i-usr-data-segment)
                       (segment-length (i-usr-data-segment i)))
                (equal (link-table-for-segment
                         i-sys-data-segment
                         (plus load-addr
                               (segment-length (i-prog-segment i))
                               (segment-length (i-usr-data-segment i))))
                       (link-table-for-segment
                         (i-sys-data-segment i)
                         (plus load-addr
                               (segment-length (i-prog-segment i))
                               (segment-length (i-usr-data-segment i))))))
           (equal (i-link-tables (i-state pc cfp csp tsp
                                          x y c-flg v-flg n-flg z-flg
                                          (i-prog-segment i)
                                          i-usr-data-segment
                                          i-sys-data-segment
                                          word-size
                                          psw)
                                 load-addr)
                  (i-link-tables i load-addr)))
  ((enable i-link-tables)))


; Now I will embark on the proofs of each of one-way correspondence
; step theorems, starting with what I think is the simplest: the
; no-op case.

(enable plus-add1)

(prove-lemma get-add1-cons (rewrite)
  (equal (get (add1 n) (cons x y))
         (get n y)))

(prove-lemma get-0-cons (rewrite)
  (equal (get 0 (cons x y)) x))

(enable length-cons)

(prove-lemma length-reg-file (rewrite)
  (equal (length
           (list r0 r1 r2 r3 r4 r5 r6 r7 r8 r9 r10 r11 r12 r13 r14 r15))
         16))

(prove-lemma put-add1-cons (rewrite)
  (equal (put val (add1 n) (cons x y))
         (cons x (put val n y))))

(prove-lemma put-zero-cons (rewrite)
  (equal (put val 0 (cons x y))
         (cons val y)))

(prove-lemma boolp-bool-to-logical (rewrite)
  (boolp (bool-to-logical b)))

(prove-lemma i-state-types-okp-property2 (rewrite)
  (implies (i-state-types-okp i)
           (and (not (icode-instructionp (i-pc i)))
                (not (icode-instructionp (i-cfp i)))
                (not (icode-instructionp (i-csp i)))
                (not (icode-instructionp (i-tsp i)))
                (not (icode-instructionp (i-c-flg i)))
                (not (icode-instructionp (i-v-flg i)))
                (not (icode-instructionp (i-n-flg i)))
                (not (icode-instructionp (i-z-flg i)))))
  ((enable i-state-types-okp untag)))

(prove-lemma not-icode-instructionp-tag (rewrite)
  (not (icode-instructionp (tag type obj)))
  ((enable tag)))

(disable icode-instructionp)


(prove-lemma length-put (rewrite)
  (implies (lessp n (length lst))
           (equal (length (put v n lst))
                  (length lst))))

(prove-lemma nat-to-v-equivalence (rewrite)
  (implies (and (numberp n)
                (numberp m)
                (lessp n (exp 2 word-size))
                (lessp m (exp 2 word-size)))
           (equal (equal (nat-to-v n word-size)
                         (nat-to-v m word-size))
                  (equal n m))))



; --- Here I take time out in my development to define a few
; functions used to make slides for my Piton talk.

(defn list-of-bvs (lst)
 (if (nlistp lst)
     nil
     (cons (nat-to-v (car lst) 32)
           (list-of-bvs (cdr lst)))))

(defn n->m (n)
  (m-state (list-of-bvs (car n))
           (cadr n)
           (caddr n)
           (cadddr n)
           (caddddr n)
           (list-of-bvs (cadddddr n))))

(defn m->n (m)
  (list (list-of-nats (m-regs m))
        (m-c-flg m)
        (m-v-flg m)
        (m-n-flg m)
        (m-z-flg m)
        (list-of-nats (m-mem m))))

(defn n-step (n)
  (m->n (m-step (n->m n))))

; --- end of aside

; Recall



;(prove-lemma get-link-table-entry-link-segment (rewrite)
;  (implies (and (definedp (adp-name adp) segment)
;               (lessp (adp-offset adp)
;                      (length (cdr (assoc (adp-name adp) segment)))))
;          (equal (get (plus (link-table-entry (adp-name adp) segment)
;                            (adp-offset adp))
;                      (link-segment segment table word-size))
;                 (link-word
;                   (unlabel
;                     (get (adp-offset adp)
;                          (cdr (assoc (adp-name adp) segment))))
;                   table
;                   word-size))))
;

; from above.  Analogous lemmas for the data segment and the
; stack segment are needed.  In addition, we need to be able to handle
; the arithmetically equivalent cases that arise from opening plus
; or incrementing and decrementing addresses.  We'll do that first
; and then turn to the other segments and the add1/sub1 cases for them.

(prove-lemma plus-zerop (rewrite)
  (implies (not (numberp y))
           (equal (plus x y) (fix x))))

(prove-lemma get-link-table-entry-link-segment-add1 (rewrite)
  (implies (and (definedp (adp-name adp) segment)
                (lessp (add1 (adp-offset adp))
                       (length (cdr (assoc (adp-name adp) segment)))))
           (equal (get (add1 (plus (link-table-entry (adp-name adp) segment)
                                   (adp-offset adp)))
                       (link-segment segment table word-size))
                  (link-word
                    (unlabel
                      (get (add1 (adp-offset adp))
                           (cdr (assoc (adp-name adp) segment))))
                    table
                    word-size)))
  ((use (get-link-table-entry-link-segment (adp (add1-adp adp))))
   (disable get-link-table-entry-link-segment)))

(prove-lemma plus-sub1 (rewrite)
  (implies (not (zerop y))
           (equal (plus x (sub1 y))
                  (sub1 (plus x y)))))

;  The above lemma causes infinite looping if plus opens and commutes.
;  So I'll disable it asap.

(prove-lemma get-link-table-entry-link-segment-sub1 (rewrite)
  (implies (and (definedp (adp-name adp) segment)
                (not (zerop (sub1 (adp-offset adp))))
                (lessp (adp-offset adp)
                       (length (cdr (assoc (adp-name adp) segment)))))
           (equal (get (sub1 (plus (link-table-entry (adp-name adp) segment)
                                   (adp-offset adp)))
                       (link-segment segment table word-size))
                  (link-word
                    (unlabel
                      (get (sub1 (adp-offset adp))
                           (cdr (assoc (adp-name adp) segment))))
                    table
                    word-size)))
  ((use (get-link-table-entry-link-segment (adp (sub1-adp adp))))
   (disable get-link-table-entry-link-segment)))

(disable plus-sub1)

; Before we work on the two data segments we do some
; similar trivial arithmetic for the add1/sub1 cases of
; the previously proved:

;
;(prove-lemma lessp-absolute-address-segment-length-adp-name (rewrite)
;  (implies (and (definedp (adp-name adp) segment)
;               (lessp (adp-offset adp)
;                      (length (cdr (assoc (adp-name adp) segment)))))
;          (lessp (plus (link-table-entry (adp-name adp) segment)
;                       (adp-offset adp))
;                 (segment-length segment)))
;  ((use (lessp-absolute-address-segment-length-generalized
;         (name (adp-name adp))
;         (offset (adp-offset adp))))))
;


(prove-lemma lessp-absolute-address-segment-length-adp-name-add1 (rewrite)
  (implies (and (definedp (adp-name adp) segment)
                (lessp (adp-offset adp)
                       (sub1 (length (cdr (assoc (adp-name adp) segment))))))
           (lessp (add1
                    (plus (link-table-entry (adp-name adp) segment)
                          (adp-offset adp)))
                  (segment-length segment)))
  ((use (lessp-absolute-address-segment-length-generalized
          (name (adp-name adp))
          (offset (add1 (adp-offset adp)))))))


;  We will undoubtedly need related facts about 'cstk and 'tsk, similar
; to lessp-absolute-address-segment-length-cfp, etc., above.  But I
; don't know the exact form we'll need so I'll wait...  Here however
; are the related lemmas in their pure form



;(prove-lemma  (rewrite)
;  (implies (and (definedp 'cstk (i-sys-data-segment i))
;               (lessp (adp-offset (untag (i-cfp i)))
;                      (length (cdr (assoc 'cstk
;                                          (i-sys-data-segment i))))))
;          (lessp (plus (link-table-entry 'cstk
;                                         (i-sys-data-segment i))
;                       (adp-offset (untag (i-cfp i))))
;                 (segment-length (i-sys-data-segment i))))
;  ((use (lessp-absolute-address-segment-length-generalized
;         (name 'cstk)
;         (offset (adp-offset (untag (i-cfp i))))
;         (segment (i-sys-data-segment i))))))
;
;(prove-lemma lessp-absolute-address-segment-length-csp (rewrite)
;  (implies (and (definedp 'cstk (i-sys-data-segment i))
;               (lessp (adp-offset (untag (i-csp i)))
;                      (length (cdr (assoc 'cstk
;                                          (i-sys-data-segment i))))))
;          (lessp (plus (link-table-entry 'cstk
;                                         (i-sys-data-segment i))
;                       (adp-offset (untag (i-csp i))))
;                 (segment-length (i-sys-data-segment i))))
;  ((use (lessp-absolute-address-segment-length-generalized
;         (name 'cstk)
;         (offset (adp-offset (untag (i-csp i))))
;         (segment (i-sys-data-segment i))))))
;
;(prove-lemma lessp-absolute-address-segment-length-tsp (rewrite)
;  (implies (and (definedp 'tstk (i-sys-data-segment i))
;               (lessp (adp-offset (untag (i-tsp i)))
;                      (length (cdr (assoc 'tstk
;                                          (i-sys-data-segment i))))))
;          (lessp (plus (link-table-entry 'tstk
;                                         (i-sys-data-segment i))
;                       (adp-offset (untag (i-tsp i))))
;                 (segment-length (i-sys-data-segment i))))
;  ((use (lessp-absolute-address-segment-length-generalized
;         (name 'tstk)
;         (offset (adp-offset (untag (i-tsp i))))
;         (segment (i-sys-data-segment i))))))





; The previously proved:

;
;(prove-lemma get-append-2 (rewrite)
;  (implies (equal n (length a))
;          (equal (get (plus n k) (append a b))
;                 (get k b))))
;
; also needs to be expanded to the add1/sub1 cases:

(prove-lemma get-append-2-add1 (rewrite)
  (implies (equal n (length a))
           (equal (get (add1 (plus n k)) (append a b))
                  (get (add1 k) b)))
  ((use (get-append-2 (k (add1 k))))
   (disable get-append-2)))

(prove-lemma get-append-2-sub1 (rewrite)
  (implies (and (equal n (length a))
                (not (zerop k)))
           (equal (get (sub1 (plus n k)) (append a b))
                  (get (sub1 k) b)))
  ((use (get-append-2 (k (sub1 k))))
   (disable get-append-2)))

(prove-lemma get-append-3-add1 (rewrite)
  (implies (and (equal n1 (length a1))
                (equal n2 (length a2)))
           (equal (get (add1 (plus n2 n1 k))
                       (append a1 (append a2 b)))
                  (get (add1 k) b)))
  ((use (get-append-3 (k (add1 k))))
   (disable get-append-3)))

(prove-lemma get-append-3-sub1 (rewrite)
  (implies (and (equal n1 (length a1))
                (equal n2 (length a2))
                (not (zerop k)))
           (equal (get (sub1 (plus n2 n1 k))
                       (append a1 (append a2 b)))
                  (get (sub1 k) b)))
  ((use (get-append-3 (k (sub1 k))))
   (disable get-append-3)))

; Now it turns out we never increment or decrement addresses into the
; usr-data segment.  So we don't need lemmas for that.  But we do both
; operations on sys-data addresses when pushing and popping.  There
; is no difference between the usr-data and the sys-data accessing
; but it will turn out that we know that (adp-name (untag (i-csp i)))
; is 'cstk so we have to phrase the lemma explicitly for 'cstk and another
; one for tstk.

; Now for the sys-data segment, we just use the result above,
; but acknowledge that (adp-name adp) will be either 'cstk or 'tstk
; in all of our uses...

(prove-lemma get-link-table-entry-link-segment-cstk (rewrite)
  (implies (and (definedp 'cstk segment)
                (lessp (adp-offset adp)
                       (length (cdr (assoc 'cstk segment)))))
           (equal (get (plus (link-table-entry 'cstk segment)
                             (adp-offset adp))
                       (link-segment segment table word-size))
                  (link-word
                    (unlabel
                      (get (adp-offset adp)
                           (cdr (assoc 'cstk segment))))
                    table
                    word-size)))
  ((use (get-link-table-entry-link-segment
          (adp (cons 'cstk (adp-offset adp)))))
   (disable get-link-table-entry-link-segment)))

(prove-lemma get-link-table-entry-link-segment-tstk (rewrite)
  (implies (and (definedp 'tstk segment)
                (lessp (adp-offset adp)
                       (length (cdr (assoc 'tstk segment)))))
           (equal (get (plus (link-table-entry 'tstk segment)
                             (adp-offset adp))
                       (link-segment segment table word-size))
                  (link-word
                    (unlabel
                      (get (adp-offset adp)
                           (cdr (assoc 'tstk segment))))
                    table
                    word-size)))
  ((use (get-link-table-entry-link-segment
          (adp (cons 'tstk (adp-offset adp)))))
   (disable get-link-table-entry-link-segment)))

; and now, for both cstk and tstk, we get the pushed and popped
; versions.

(prove-lemma get-link-table-entry-link-segment-cstk-add1 (rewrite)
  (implies (and (definedp 'cstk segment)
                (lessp (adp-offset adp)
                       (sub1 (length (cdr (assoc 'cstk segment))))))
           (equal (get (add1
                         (plus (link-table-entry 'cstk segment)
                               (adp-offset adp)))
                       (link-segment segment table word-size))
                  (link-word
                    (unlabel 
                      (get (add1 (adp-offset adp))
                           (cdr (assoc 'cstk segment))))
                    table
                    word-size)))
  ((use (get-link-table-entry-link-segment
          (adp (cons 'cstk (add1 (adp-offset adp))))))
   (disable get-link-table-entry-link-segment)))

(prove-lemma get-link-table-entry-link-segment-cstk-sub1 (rewrite)
  (implies (and (definedp 'cstk segment)
                (not (zerop (adp-offset adp)))
                (lessp (adp-offset adp)
                       (length (cdr (assoc 'cstk segment)))))
           (equal (get (sub1
                         (plus (link-table-entry 'cstk segment)
                               (adp-offset adp)))
                       (link-segment segment table word-size))
                  (link-word
                    (unlabel
                      (get (sub1 (adp-offset adp))
                           (cdr (assoc 'cstk segment))))
                    table
                    word-size)))
  ((enable plus-sub1)
   (use (get-link-table-entry-link-segment
          (adp (cons 'cstk (sub1 (adp-offset adp))))))
   (disable get-link-table-entry-link-segment)))

(prove-lemma get-link-table-entry-link-segment-tstk-add1 (rewrite)
  (implies (and (definedp 'tstk segment)
                (lessp (adp-offset adp)
                       (sub1 (length (cdr (assoc 'tstk segment))))))
           (equal (get (add1
                         (plus (link-table-entry 'tstk segment)
                               (adp-offset adp)))
                       (link-segment segment table word-size))
                  (link-word
                    (unlabel
                      (get (add1 (adp-offset adp))
                           (cdr (assoc 'tstk segment))))
                    table
                    word-size)))
  ((use (get-link-table-entry-link-segment
          (adp (cons 'tstk (add1 (adp-offset adp))))))
   (disable get-link-table-entry-link-segment)))

(prove-lemma get-link-table-entry-link-segment-tstk-sub1 (rewrite)
  (implies (and (definedp 'tstk segment)
                (not (zerop (adp-offset adp)))
                (lessp (adp-offset adp)
                       (length (cdr (assoc 'tstk segment)))))
           (equal (get (sub1
                         (plus (link-table-entry 'tstk segment)
                               (adp-offset adp)))
                       (link-segment segment table word-size))
                  (link-word
                    (unlabel
                      (get (sub1 (adp-offset adp))
                           (cdr (assoc 'tstk segment))))
                    table
                    word-size)))
  ((enable plus-sub1)
   (use (get-link-table-entry-link-segment
          (adp (cons 'tstk (sub1 (adp-offset adp))))))
   (disable get-link-table-entry-link-segment)))

; We now need for put all of the stuff we have developed for get...

(prove-lemma put-append-1 (rewrite)
  (implies (lessp n (length a))
           (equal (put val n (append a b))
                  (append (put val n a) b))))

(prove-lemma put-append-2 (rewrite)
  (implies (equal n (length a))
           (equal (put val (plus n k) (append a b))
                  (append a (put val k b)))))

(prove-lemma put-append-3 (rewrite)
  (implies (and (equal n1 (length a1))
                (equal n2 (length a2)))
           (equal (put val
                       (plus n2 n1 k)
                       (append a1 (append a2 b)))
                  (append a1 (append a2 (put val k b)))))
  ((disable put-append-2)
   (enable commutativity-of-plus commutativity2-of-plus)
   (use (put-append-2 (n n1)(a a1)(k (plus n2 k))(b (append a2 b)))
        (put-append-2 (n n2)(a a2)(k k)(b b)))))

(prove-lemma put-append-2-add1 (rewrite)
  (implies (equal n (length a))
           (equal (put val (add1 (plus n k)) (append a b))
                  (append a (put val (add1 k) b))))
  ((use (put-append-2 (k (add1 k))))
   (disable put-append-2)))

(prove-lemma put-append-2-sub1 (rewrite)
  (implies (and (equal n (length a))
                (not (zerop k)))
           (equal (put val (sub1 (plus n k)) (append a b))
                  (append a (put val (sub1 k) b))))
  ((use (put-append-2 (k (sub1 k))))
   (disable put-append-2)
   (enable plus-sub1)))

(prove-lemma put-append-3-add1 (rewrite)
  (implies (and (equal n1 (length a1))
                (equal n2 (length a2)))
           (equal (put val
                       (add1 (plus n2 n1 k))
                       (append a1 (append a2 b)))
                  (append a1 (append a2 (put val (add1 k) b)))))
  ((disable put-append-3)
   (use (put-append-3 (k (add1 k))))))

(prove-lemma put-append-3-sub1 (rewrite)
  (implies (and (equal n1 (length a1))
                (equal n2 (length a2))
                (not (zerop k)))
           (equal (put val
                       (sub1 (plus n2 n1 k))
                       (append a1 (append a2 b)))
                  (append a1 (append a2 (put val (sub1 k) b)))))
  ((disable put-append-3)
   (use (put-append-3 (k (sub1 k))))))

(prove-lemma put-link-area (rewrite)
  (implies (lessp n (length lst))
           (equal (link-area (put val n lst)
                             tables
                             word-size)
                  (put (link-word (unlabel val) tables word-size)
                       n
                       (link-area lst tables word-size)))))

; Now we do for put and link-segment what we did for get and link-segment:

(prove-lemma put-link-segment (rewrite)
  (implies (and (definedp (adp-name adp) segment)
                (lessp (adp-offset adp)
                       (length (cdr (assoc (adp-name adp) segment)))))
           (equal (link-segment
                    (put-assoc
                     (put val
                          (adp-offset adp)
                          (cdr (assoc (adp-name adp) segment)))
                     (adp-name adp)
                     segment)
                    tables
                    word-size)
                  (put (link-word (unlabel val) tables word-size)
                       (plus (link-table-entry (adp-name adp) segment)
                             (adp-offset adp))
                       (link-segment segment tables word-size)))))

; And now we prove the cstk and tstk versions of the above, with
; the add1/sub1 variants.  These six lemmas, all just variations on
; the basic one above, should explain all of our deposits into the
; cstk and tstk areas.

(prove-lemma put-link-segment-cstk (rewrite)
  (implies (and (definedp 'cstk segment)
                (numberp stk-ptr)
                (lessp stk-ptr
                       (length (cdr (assoc 'cstk segment)))))
           (equal (link-segment
                    (put-assoc (put val stk-ptr
                                    (cdr (assoc 'cstk segment)))
                               'cstk
                               segment)
                    tables
                    word-size)
                  (put (link-word (unlabel val) tables word-size)
                       (plus (link-table-entry 'cstk segment)
                             stk-ptr)
                       (link-segment segment tables word-size))))
  ((use (put-link-segment (adp (cons 'cstk stk-ptr))))
   (disable put-link-segment)))

(prove-lemma put-link-segment-tstk (rewrite)
  (implies (and (definedp 'tstk segment)
                (numberp stk-ptr)
                (lessp stk-ptr
                       (length (cdr (assoc 'tstk segment)))))
           (equal (link-segment
                    (put-assoc (put val stk-ptr (cdr (assoc 'tstk segment)))
                               'tstk
                               segment)
                    tables
                    word-size)
                  (put (link-word (unlabel val) tables word-size)
                       (plus (link-table-entry 'tstk segment)
                             stk-ptr)
                       (link-segment segment tables word-size))))
  ((use (put-link-segment (adp (cons 'tstk stk-ptr))))
   (disable put-link-segment)))

(prove-lemma put-link-segment-cstk-add1 (rewrite)
  (implies (and (definedp 'cstk segment)
                (lessp (add1 stk-ptr)
                       (length (cdr (assoc 'cstk segment)))))
           (equal (link-segment
                    (put-assoc (put val (add1 stk-ptr)
                                    (cdr (assoc 'cstk segment)))
                               'cstk
                               segment)
                    tables
                    word-size)
                  (put (link-word (unlabel val) tables word-size)
                       (add1
                         (plus (link-table-entry 'cstk segment)
                               stk-ptr))
                       (link-segment segment tables word-size))))
  ((use (put-link-segment (adp (cons 'cstk (add1 stk-ptr)))))
   (disable put-link-segment)))

(prove-lemma put-link-segment-cstk-sub1 (rewrite)
  (implies (and (definedp 'cstk segment)
                (not (zerop stk-ptr))
                (lessp stk-ptr
                       (length (cdr (assoc 'cstk segment)))))
           (equal (link-segment
                    (put-assoc (put val (sub1 stk-ptr)
                                    (cdr (assoc 'cstk segment)))
                               'cstk
                               segment)
                    tables
                    word-size)
                  (put (link-word (unlabel val) tables word-size)
                       (sub1
                         (plus (link-table-entry 'cstk segment)
                               stk-ptr))
                       (link-segment segment tables word-size))))
  ((use (put-link-segment (adp (cons 'cstk (sub1 stk-ptr)))))
   (enable plus-sub1)
   (disable put-link-segment)))

(prove-lemma put-link-segment-tstk-add1 (rewrite)
  (implies (and (definedp 'tstk segment)
                (lessp (add1 stk-ptr)
                       (length (cdr (assoc 'tstk segment)))))
           (equal (link-segment
                    (put-assoc (put val (add1 stk-ptr)
                                    (cdr (assoc 'tstk segment)))
                               'tstk
                               segment)
                    tables
                    word-size)
                  (put (link-word (unlabel val) tables word-size)
                       (add1
                         (plus (link-table-entry 'tstk segment)
                               stk-ptr))
                       (link-segment segment tables word-size))))
  ((use (put-link-segment (adp (cons 'tstk (add1 stk-ptr)))))
   (disable put-link-segment)))

(prove-lemma put-link-segment-tstk-sub1 (rewrite)
  (implies (and (definedp 'tstk segment)
                (not (zerop stk-ptr))
                (lessp stk-ptr
                       (length (cdr (assoc 'tstk segment)))))
           (equal (link-segment
                    (put-assoc (put val (sub1 stk-ptr)
                                    (cdr (assoc 'tstk segment)))
                               'tstk
                               segment)
                    tables
                    word-size)
                  (put (link-word (unlabel val) tables word-size)
                       (sub1
                         (plus (link-table-entry 'tstk segment)
                               stk-ptr))
                       (link-segment segment tables word-size))))
  ((use (put-link-segment (adp (cons 'tstk (sub1 stk-ptr)))))
   (enable plus-sub1)
   (disable put-link-segment)))

(prove-lemma definedp-put-assoc (rewrite)
  (equal (definedp name (put-assoc val name2 segment))
         (definedp name segment)))

(prove-lemma link-table-entry-put-assoc (rewrite)
  (implies (equal (length val)
                  (length (cdr (assoc name2 segment))))
           (equal (link-table-entry name (put-assoc val name2 segment))
                  (link-table-entry name segment))))

(prove-lemma link-table-for-segment-put-assoc (rewrite)
  (implies
    (equal (length val)
           (length (cdr (assoc name2 segment))))
    (equal (link-table-for-segment
             (put-assoc val name2 segment)
             addr)
           (link-table-for-segment segment addr))))

(prove-lemma equal-append (rewrite)
  (equal (equal (append a b)
                (append a c))
         (equal b c)))

; We also need...


(disable i-objectp)

(prove-lemma unlabel-i-objectp (rewrite)
  (implies (i-objectp x i) (equal (unlabel x) x))
  ((enable i-objectp unlabel type)))

(prove-lemma unlabel-tagged-object (rewrite)
  (implies (not (equal (type x) 'dl)) (equal (unlabel x) x))
  ((enable unlabel type)))

(prove-lemma link-area-put-unlabel (rewrite)
  (implies (i-objectp (unlabel val) i)
           (equal (link-area (put (unlabel val) n lst) tables word-size)
                  (link-area (put val n lst) tables word-size))))

(prove-lemma link-segment-put-unlabel (rewrite)
  (implies (i-objectp (unlabel val) i)
           (equal (link-segment
                    (put-assoc
                      (put (unlabel val)
                           offset
                           (cdr (assoc name segment)))
                      name
                      segment)
                    tables
                    word-size)
                  (link-segment
                    (put-assoc
                      (put val
                           offset
                           (cdr (assoc name segment)))
                      name
                      segment)
                    tables
                    word-size))))

(prove-lemma difference-1 (rewrite) (equal (difference x 1) (sub1 x)))

(disable int-to-v)

(prove-lemma tc-add-is-iplus (rewrite)
  (equal (tc-add x y) (iplus x y)))

(disable add)

(prove-lemma tc-in-rangep-is-small-integerp (rewrite)
  (implies (and (integerp x)
                (not (zerop word-size)))
           (equal (tc-in-rangep x word-size)
                  (small-integerp x word-size))))

(disable tc-in-rangep)

(enable integerp-iplus)

(prove-lemma small-integerp-implies-integerp (rewrite)
  (implies (small-integerp x word-size)
           (integerp x)))

(prove-lemma bitn-of-positive-is-f (rewrite)
  (implies (lessp i (exp 2 (sub1 word-size)))
           (equal (bitn (nat-to-v i word-size) word-size)
                  f)))

(prove-lemma lessp-exp-sub1-exp (rewrite)
  (implies (not (zerop word-size))
           (lessp (exp 2 (sub1 word-size))
                  (exp 2 word-size))))

(prove-lemma incr-f (rewrite)
  (implies (bvp b) (equal (incr f b) b)))

(prove-lemma compl-compl (rewrite)
  (implies (bvp b) (equal (v-not (v-not b)) b)))

(prove-lemma v-to-int-inverts-int-to-v-lemma1 (rewrite)
  (implies
         (and (numberp x)
              (not (equal x 0))
              (not (lessp (exp 2 (sub1 word-size)) x))
              (not (equal word-size 0))
              (numberp word-size))
         (equal
              (v-to-nat (incr t
                               (v-not (incr t
                                            (v-not (nat-to-v x word-size))))))
              x)))

(prove-lemma bitn-nat-to-v-0 (rewrite)
  (equal (bitn (nat-to-v 0 k) i)
         (if (zerop i)
             f
             (if (lessp k i) 0 f)))
  ((induct (lessp k i))))

; In fm8502 days we proved
; (prove-lemma not-zerop-size-implies-not-equal-bv-btm (rewrite)
;   (implies (not (zerop (length x)))
;            (not (equal x (btm)))))
; but I'm going with equal-length-0 now:

(enable equal-length-0)

(prove-lemma bitn-compl (rewrite)
  (implies (and (not (zerop n))
                (not (lessp (length b) n)))
           (equal (bitn (v-not b) n)
                  (not (bitn b n)))))

(prove-lemma times-non-numberp (rewrite)
  (implies (not (numberp x)) (equal (times y x) 0)))

(enable difference-plus-cancellation)

(prove-lemma remainder-times (rewrite)
  (equal (remainder (times x y) x) 0)
  ((induct (times y x))
   (expand (REMAINDER (PLUS X (TIMES X Z)) X))))

(prove-lemma remainder-exp-2-2 (rewrite)
  (equal (remainder (exp 2 x) 2)
         (if (zerop x) 1 0)))

(prove-lemma my-quotient-times (rewrite)
  (implies (not (zerop x))
           (equal (quotient (times x y) x)
                  (fix y)))
  ((induct (times y x))
   (expand (quotient (plus x (times x z)) x))))

(prove-lemma quotient-exp-2-2 (rewrite)
  (implies (not (zerop x))
           (equal (quotient (exp 2 x) 2)
                  (exp 2 (sub1 x)))))

(prove-lemma bitn-exp-2-sub1-word-size (rewrite)
  (implies (not (zerop word-size))
           (equal (bitn (nat-to-v (exp 2 (sub1 word-size))
                                   word-size)
                        word-size)
                  t))
  ((disable times)))

(prove-lemma bitn-of-negatives-is-t-lemma (rewrite)
  (implies (and (not (zerop word-size))
                (numberp x)
                (not (lessp (exp 2 (sub1 word-size))
                            x)))
           (equal (bitn (nat-to-v x word-size) word-size)
                  (equal x (exp 2 (sub1 word-size))))))

(prove-lemma bitn-of-negatives-is-t-lemma-hyp (rewrite)
  (implies (and (not (zerop word-size))
                (not (lessp (exp 2 word-size) i)))
           (not (lessp (exp 2 (sub1 word-size)) (quotient i 2)))))

(prove-lemma incr-f-is-noop (rewrite)
  (equal (bitn (incr f v) n)
         (if (lessp (length v) n)
             0
             (if (bitn v n) t f))))

(disable plus-commutes2)

(prove-lemma bitn-cons (rewrite)
  (equal (bitn (cons b v) i)
         (if (zerop i) f (if (equal i 1) b (bitn v (sub1 i))))))

(prove-lemma bitn-of-negatives-is-t (rewrite)
  (implies (and (not (zerop i))
                (not (zerop word-size))
                (not (lessp (exp 2 (sub1 word-size)) i)))
           (equal (bitn (incr t (v-not (nat-to-v i word-size)))
                        word-size)
                  t)))

(disable incr-f-is-noop)
(disable bitn-cons)
(disable bitn-of-negatives-is-t-lemma)
(disable bitn-of-negatives-is-t-lemma-hyp)

(prove-lemma v-to-int-inverts-int-to-v (rewrite)
  (implies (and (small-integerp i word-size)
                (not (zerop word-size)))
           (equal (v-to-int (int-to-v i word-size)) i))
  ((enable int-to-v)))

(prove-lemma v-to-int-inverts-link-word (rewrite)
  (implies (and (equal (type x) 'int)
                (equal (cddr x) nil)
                (small-integerp (untag x) word-size)
                (not (zerop word-size)))
           (equal (v-to-int (link-word x tables word-size))
                  (untag x)))
  ((disable v-to-int)
   (enable link-word icode-instructionp)))

(prove-lemma not-equal-link-word-btm (rewrite)
  (listp (link-word x tables 32))
  ((disable size-link-word)
   (use (size-link-word (link-tables tables) (word-size 32)))))

(enable commutativity-of-iplus)

; Initially, my owc step theorems were stated in terms of i-ins-okp
; and i-step.  But now I use the -okp and -step function specific to
; the given current-instruction.  Frequently the attempt to prove a
; owc step theorem exposes bugs in the -okp or -step function for
; the instruction.  If the previously proved owc step theorems are
; stated in terms of the i-ins-okp and i-step those previously proved
; theorems must be proved again when the -okp and -step functions for
; the current instruction are redefined.

; Here I have inserted a new theorem, m-step1-opener, that play the
; role that m-step1-expander did in fm8502.

(enable remainder-plus-x-x-2)

(prove-lemma remainder-add1-plus-x-x-2 (rewrite)
  (equal (remainder (add1 (plus x x)) 2) 1))

(prove-lemma nat-to-v-inverts-v-to-nat (rewrite)
  (implies (bvp v)
           (equal (nat-to-v (v-to-nat v) (length v)) v)))

(prove-lemma backchainer-trick (rewrite)
 (implies (and (bvp v)
               (not (lessp (length v) word-size))
               (equal (v-to-nat v) n))
          (equal (equal (firstn word-size v) (nat-to-v n word-size))
                 t)))

(prove-lemma v-adder-t-0-is-nat-to-v-add1 (rewrite)
  (implies (and (numberp pc)
                (not (zerop word-size))
                (lessp (add1 pc) (exp 2 word-size)))
           (equal (firstn word-size
                          (v-adder t
                                   (nat-to-v pc word-size)
                                   (nat-to-v 0 word-size)))
                  (nat-to-v (add1 pc) word-size)))
  ((enable bvp-nat-to-v v-adder-works BVP-V-ADDER length-v-adder)))

(prove-lemma v-adder-f-1-is-nat-to-v-sub1 (rewrite)
  (implies (and (numberp pc)
                (not (equal pc 0))
                (not (zerop word-size))
                (lessp pc (exp 2 word-size)))
           (equal (firstn word-size
                          (v-adder f
                                   (v-not (nat-to-v 0 word-size))
                                   (nat-to-v pc word-size)))
                  (nat-to-v (sub1 pc) word-size)))
  ((use (v-alu-correct-nat-subtracter-output
         (c t)
         (a (nat-to-v 0 word-size))
         (b (nat-to-v pc word-size))))
   (enable v-to-nat-v-not bvp-v-not bvp-nat-to-v v-adder-works BVP-V-ADDER length-v-adder)))

(disable backchainer-trick)
(disable nat-to-v-inverts-v-to-nat)
(disable remainder-add1-plus-x-x-2)
(disable remainder-plus-x-x-2)

(prove-lemma v-inc-nat-to-v (rewrite)
  (implies (and (numberp i)
                (not (zerop word-size))
                (lessp (add1 i) (exp 2 word-size)))
           (equal (v-inc (nat-to-v i word-size))
                  (nat-to-v (add1 i) word-size))))

(disable v-inc)

(enable bvp-nat-to-v)

(prove-lemma v-dec-nat-to-v (rewrite)
  (implies (and (lessp i (exp 2 word-size))
                (not (zerop word-size)))
           (equal (v-dec (nat-to-v i word-size))
                  (if (zerop i)
                      (nat-to-v (sub1 (exp 2 word-size)) word-size)
                      (nat-to-v (sub1 i) word-size))))
  ((disable alu-thm_nat-bv-subb)
   (enable v-alu bv)
   (use (alu-thm_nat-bv-subb (c t)
                             (a (nat-to-v 0 word-size))
                             (b (nat-to-v i word-size))))))

(disable v-dec)

(prove-lemma m-step1-opener (rewrite)
  (implies (and (numberp pc)
                (not (zerop word-size))
                (lessp (add1 pc) (exp 2 word-size)))
           (equal (m-step1 (cons ins0 ins1-31)
                           (m-state (list r0 r1 r2 r3 r4 r5 r6 r7
                                          r8 r9 r10 r11 r12 r13 r14
                                          (nat-to-v pc word-size))
                                    c v n z mem))
                  (m-operand-a (list r0 r1 r2 r3 r4 r5 r6 r7
                                     r8 r9 r10 r11 r12 r13 r14
                                     (nat-to-v (add1 pc) word-size))
                      c v n z mem (cons ins0 ins1-31))))
  ((disable m-operand-a)))

(disable m-step1)

(prove-lemma bvp-bitv-to-v (rewrite)
  (bvp (bitv-to-v bv word-size))
  ((enable bvp-append)))

; A lemma bvp-int-to-v exists in fm9001.events, but it did not
; originally.  We accommodate this change by introducing the "my-"
; prefix below.

(prove-lemma my-bvp-int-to-v (rewrite)
  (bvp (int-to-v i word-size))
  ((enable int-to-v)))

(prove-lemma bvp-link-word (rewrite)
  (bvp (link-word x link-tables word-size))
  ((disable *1*link-instruction-alist link-instruction-alist
            extract-op extract-move-bits extract-cvnz extract-mode
            extract-reg)
   (enable link-word link-data-word link-instr-word)))

(prove-lemma i-m-one-way-correspondence-step-move_x_x (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-move_x_x-okp i)
                (equal (i-current-instruction i) '(move_x_x)))
           (equal (i->m (i-move_x_x-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable nat-to-v link-table-entry)))

; This next segment has been added during the fm9001 port, to speed up
; the processing of the new fns introduced there.

; I had this around in the fm9001 effort before backing up and
; disabling v-inc and v-dec...

;(prove-lemma v-adder-t-0-is-nat-to-v-add1-32 (rewrite)
;  (implies (and (numberp pc)
;               (lessp (add1 pc) (exp 2 32)))
;          (equal (firstn 32
;                         (v-adder t
;                                  (nat-to-v pc 32)
;                                  (LIST F F F F F F F F F F F F F F F F
;                                        F F F F F F F F F F F F F F F F)))
;                 (nat-to-v (add1 pc) 32)))
;  ((disable v-adder-t-0-is-nat-to-v-add1)
;   (use (v-adder-t-0-is-nat-to-v-add1 (word-size 32)))))

; The following theorem delays the opening of m-operand-a until the
; reg file has been put into normal form.  Note that this means we
; list all 16 regs and the pc is (NAT-TO-V & 32). Use of the free var
; regs in the hyp is arranged to save the repeated rewriting of it in
; the rhs of the concl.  The conclusion is just what (ppsd
; 'm-operand-a) prints, except for the list-expr in the regs slot on
; the lhs.

(prove-lemma m-operand-a-opener (rewrite)
  (implies
   (equal regs (list r0 r1 r2 r3 r4 r5 r6 r7
                     r8 r9 r10 r11 r12 r13 r14 (nat-to-v pc 32)))
   (EQUAL (M-OPERAND-A (list r0 r1 r2 r3 r4 r5 r6 r7
                             r8 r9 r10 r11 r12 r13 r14 (nat-to-v pc 32))
                       C V N Z MEM INS)
          (COND
           ((A-IMMEDIATE-P INS)
            (M-OPERAND-B REGS C V N Z MEM INS
                         (SIGN-EXTEND (A-IMMEDIATE INS) 32)))
           ((PRE-DEC-P (MODE-A INS))
            (IF (REG-DIRECT-P (MODE-A INS))
                (M-OPERAND-B (UPDATE-V-NTH (RN-A INS)
                                           REGS
                                           (V-DEC (V-NTH1 (RN-A INS) REGS)))
                             C V N Z MEM INS
                             (V-NTH1 (RN-A INS) REGS))
                (M-OPERAND-B (UPDATE-V-NTH (RN-A INS)
                                           REGS
                                           (V-DEC (V-NTH1 (RN-A INS) REGS)))
                             C V N Z MEM INS
                             (V-NTH1 (V-DEC (V-NTH1 (RN-A INS) REGS))
                                     MEM))))
           ((POST-INC-P (MODE-A INS))
            (IF (REG-DIRECT-P (MODE-A INS))
                (M-OPERAND-B (UPDATE-V-NTH (RN-A INS)
                                           REGS
                                           (V-INC (V-NTH1 (RN-A INS) REGS)))
                             C V N Z MEM INS
                             (V-NTH1 (RN-A INS) REGS))
                (M-OPERAND-B (UPDATE-V-NTH (RN-A INS)
                                           REGS
                                           (V-INC (V-NTH1 (RN-A INS) REGS)))
                             C V N Z MEM INS
                             (V-NTH1 (V-NTH1 (RN-A INS) REGS)
                                     MEM))))
           ((REG-DIRECT-P (MODE-A INS))
            (M-OPERAND-B REGS C V N Z MEM INS
                         (V-NTH1 (RN-A INS) REGS)))
           (T (M-OPERAND-B REGS C V N Z MEM INS
                           (V-NTH1 (V-NTH1 (RN-A INS) REGS)
                                   MEM))))))
  ((disable A-IMMEDIATE-P M-OPERAND-B SIGN-EXTEND A-IMMEDIATE PRE-DEC-P
            MODE-A REG-DIRECT-P UPDATE-V-NTH RN-A V-DEC V-NTH1 POST-INC-P
            V-INC)))

(disable m-operand-a)

; Now we repeat the exercise for m-operand-b.

(prove-lemma m-operand-b-opener (rewrite)
  (implies
   (equal regs (list r0 r1 r2 r3 r4 r5 r6 r7
                     r8 r9 r10 r11 r12 r13 r14 (nat-to-v pc 32)))
   (EQUAL
    (M-OPERAND-B (list r0 r1 r2 r3 r4 r5 r6 r7
                       r8 r9 r10 r11 r12 r13 r14 (nat-to-v pc 32))
                 C V N Z MEM INS OPERAND-A)
    (COND ((PRE-DEC-P (MODE-B INS))
           (IF (REG-DIRECT-P (MODE-B INS))
               (M-ALU-OPERATION (UPDATE-V-NTH (RN-B INS)
                                              REGS
                                              (V-DEC (V-NTH1 (RN-B INS) REGS)))
                                C V N Z MEM INS OPERAND-A
                                (V-NTH1 (RN-B INS) REGS)
                                (V-DEC (V-NTH1 (RN-B INS) REGS)))
               (M-ALU-OPERATION (UPDATE-V-NTH (RN-B INS)
                                              REGS
                                              (V-DEC (V-NTH1 (RN-B INS) REGS)))
                                C V N Z MEM INS OPERAND-A
                                (V-NTH1 (V-DEC (V-NTH1 (RN-B INS) REGS))
                                        MEM)
                                (V-DEC (V-NTH1 (RN-B INS) REGS)))))
          ((POST-INC-P (MODE-B INS))
           (IF (REG-DIRECT-P (MODE-B INS))
               (M-ALU-OPERATION (UPDATE-V-NTH (RN-B INS)
                                              REGS
                                              (V-INC (V-NTH1 (RN-B INS) REGS)))
                                C V N Z MEM INS OPERAND-A
                                (V-NTH1 (RN-B INS) REGS)
                                (V-NTH1 (RN-B INS) REGS))
               (M-ALU-OPERATION (UPDATE-V-NTH (RN-B INS)
                                              REGS
                                              (V-INC (V-NTH1 (RN-B INS) REGS)))
                                C V N Z MEM INS OPERAND-A
                                (V-NTH1 (V-NTH1 (RN-B INS) REGS) MEM)
                                (V-NTH1 (RN-B INS) REGS))))
          ((REG-DIRECT-P (MODE-B INS))
           (M-ALU-OPERATION REGS C V N Z MEM INS OPERAND-A
                            (V-NTH1 (RN-B INS) REGS)
                            (V-NTH1 (RN-B INS) REGS)))
          (T (M-ALU-OPERATION REGS C V N Z MEM INS OPERAND-A
                              (V-NTH1 (V-NTH1 (RN-B INS) REGS) MEM)
                              (V-NTH1 (RN-B INS) REGS))))))
  ((disable PRE-DEC-P MODE-B REG-DIRECT-P M-ALU-OPERATION UPDATE-V-NTH
            RN-B V-DEC V-NTH1 POST-INC-P V-INC)))

(disable m-operand-b)

; In watching expansions we have found that the following fact comes up
; and causes a split, which we wish to avoid.  Note that we have
; generalized (I-SYS-DATA-SEGMENT I) to I-SYS-DATA-SEGMENT so we can
; induct here.

(prove-lemma non-zero-total-i-system-size (rewrite)
   (implies (LESSP (ADP-OFFSET (UNTAG (I-TSP I)))
                   (LENGTH (CDR (ASSOC 'TSTK I-SYS-DATA-SEGMENT))))  
            (not (EQUAL (PLUS load-addr
                              (SEGMENT-LENGTH (I-USR-DATA-SEGMENT I))
                              (SEGMENT-LENGTH (I-PROG-SEGMENT I))
                              (SEGMENT-LENGTH I-SYS-DATA-SEGMENT))
                        0))))

; And again for m-alu-operation...except this time we also eliminate the
; B-IF's in m-alu-operation (in favor of plain IFs, which we hypothesize
; have boolp args).

(disable boolp)


; I am not sure if these two should be shut down or not.  But I will
; shut them down and we'll see...

(disable zb)
(disable n)

; To eliminate b-if without explosion, we have to be careful.

(prove-lemma b-if-is-if (rewrite)
  (implies (and (boolp a) (boolp b))
           (equal (b-if c a b) (if c a b)))
  ((enable boolp)))

(disable b-if)

(prove-lemma m-alu-operation-opener (rewrite)
  (implies
   (and
    (equal regs (list r0 r1 r2 r3 r4 r5 r6 r7
                      r8 r9 r10 r11 r12 r13 r14 pc))
    (boolp c)
    (boolp v)
    (boolp n)
    (boolp z)
    (bvp operand-a)
    (not (equal (length operand-a) 0)))
   (EQUAL
    (M-ALU-OPERATION (list r0 r1 r2 r3 r4 r5 r6 r7
                           r8 r9 r10 r11 r12 r13 r14 pc)
                     C V N Z MEM INS OPERAND-A OPERAND-B B-ADDRESS)
    (IF (M-STORE-RESULTP (STORE-CC INS)
                         C V N Z)
        (IF (REG-DIRECT-P (MODE-B INS))
            (M-STATE (UPDATE-V-NTH (RN-B INS)
                                   REGS
                                   (BV (V-ALU C OPERAND-A OPERAND-B
                                              (OP-CODE INS))))
                     (IF (C-SET (SET-FLAGS INS))
                         (C (V-ALU C OPERAND-A OPERAND-B
                                   (OP-CODE INS)))
                         C)
                     (IF (V-SET (SET-FLAGS INS))
                         (V (V-ALU C OPERAND-A OPERAND-B
                                   (OP-CODE INS)))
                         V)
                     (IF (N-SET (SET-FLAGS INS))
                         (N (V-ALU C OPERAND-A OPERAND-B
                                   (OP-CODE INS)))
                         N)
                     (IF (Z-SET (SET-FLAGS INS))
                         (ZB (V-ALU C OPERAND-A OPERAND-B
                                    (OP-CODE INS)))
                         Z)
                     MEM)
            (M-STATE REGS
                     (IF (C-SET (SET-FLAGS INS))
                         (C (V-ALU C OPERAND-A OPERAND-B
                                   (OP-CODE INS)))
                         C)
                     (IF (V-SET (SET-FLAGS INS))
                         (V (V-ALU C OPERAND-A OPERAND-B
                                   (OP-CODE INS)))
                         V)
                     (IF (N-SET (SET-FLAGS INS))
                         (N (V-ALU C OPERAND-A OPERAND-B
                                   (OP-CODE INS)))
                         N)
                     (IF (Z-SET (SET-FLAGS INS))
                         (ZB (V-ALU C OPERAND-A OPERAND-B
                                    (OP-CODE INS)))
                         Z)
                     (UPDATE-V-NTH B-ADDRESS MEM
                                   (BV (V-ALU C OPERAND-A OPERAND-B
                                              (OP-CODE INS))))))
        (M-STATE REGS
                 (IF (C-SET (SET-FLAGS INS))
                     (C (V-ALU C OPERAND-A OPERAND-B
                               (OP-CODE INS)))
                     C)
                 (IF (V-SET (SET-FLAGS INS))
                     (V (V-ALU C OPERAND-A OPERAND-B
                               (OP-CODE INS)))
                     V)
                 (IF (N-SET (SET-FLAGS INS))
                     (N (V-ALU C OPERAND-A OPERAND-B
                               (OP-CODE INS)))
                     N)
                 (IF (Z-SET (SET-FLAGS INS))
                     (ZB (V-ALU C OPERAND-A OPERAND-B
                                (OP-CODE INS)))
                     Z)
                 MEM))))
  ((hands-off if)
   (enable boolp-c-v-alu boolp-v-v-alu boolp-n boolp-zb-v-alu bvp-bv-v-alu)
   (disable M-STORE-RESULTP STORE-CC REG-DIRECT-P MODE-B UPDATE-V-NTH
            RN-B BV V-ALU OP-CODE C-SET SET-FLAGS V-SET N-SET Z-SET)))

(disable m-alu-operation)

(prove-lemma i-m-one-way-correspondence-step-cpush_* (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-cpush_*-okp i)
                (equal (i-current-instruction i) '(cpush_*)))
           (equal (i->m (i-cpush_*-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable get nat-to-v link-table-entry)))


(prove-lemma i-m-one-way-correspondence-step-add_<tsp>{i}_x{i} (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-add_<tsp>{i}_x{i}-okp i)
                (equal (i-current-instruction i) '(add_<tsp>{i}_x{i})))
           (equal (i->m (i-add_<tsp>{i}_x{i}-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable alu-thm_nat-bv-add alu-thm_nat-c-add
            int-to-v v-to-int
            small-integerp
            integerp
            iplus
            get nat-to-v link-table-entry)))

(prove-lemma i-m-one-way-correspondence-step-cpush_cfp (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-cpush_cfp-okp i)
                (equal (i-current-instruction i) '(cpush_cfp)))
           (equal (i->m (i-cpush_cfp-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-m-one-way-correspondence-step-move_cfp_csp (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-move_cfp_csp-okp i)
                (equal (i-current-instruction i) '(move_cfp_csp)))
           (equal (i->m (i-move_cfp_csp-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-m-one-way-correspondence-step-cpush_<tsp>+ (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-cpush_<tsp>+-okp i)
                (equal (i-current-instruction i) '(cpush_<tsp>+)))
           (equal (i->m (i-cpush_<tsp>+-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-m-one-way-correspondence-step-move_csp_cfp (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-move_csp_cfp-okp i)
                (equal (i-current-instruction i) '(move_csp_cfp)))
           (equal (i->m (i-move_csp_cfp-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-m-one-way-correspondence-step-move_x_tsp (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-move_x_tsp-okp i)
                (equal (i-current-instruction i) '(move_x_tsp)))
           (equal (i->m (i-move_x_tsp-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-m-one-way-correspondence-step-cpop_cfp (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-cpop_cfp-okp i)
                (equal (i-current-instruction i) '(cpop_cfp)))
           (equal (i->m (i-cpop_cfp-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-m-one-way-correspondence-step-move_x_* (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-move_x_*-okp i)
                (equal (i-current-instruction i) '(move_x_*)))
           (equal (i->m (i-move_x_*-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-m-one-way-correspondence-step-move_y_* (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-move_y_*-okp i)
                (equal (i-current-instruction i) '(move_y_*)))
           (equal (i->m (i-move_y_*-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma icode-instructionp-data-word (rewrite)
  (implies (equal (cddr x) nil)
           (equal (icode-instructionp x) f))
  ((enable icode-instructionp)))

(prove-lemma lessp-absolute-address-segment-length-rewrite (rewrite)
  (implies (and (definedp name segment)
                (lessp offset (length (cdr (assoc name segment)))))
           (lessp (plus (link-table-entry name segment) offset)
                  (segment-length segment)))
  ((use (lessp-absolute-address-segment-length-generalized))))

(prove-lemma i-m-one-way-correspondence-step-add_x{n}_csp (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-add_x{n}_csp-okp i)
                (equal (i-current-instruction i) '(add_x{n}_csp)))
           (equal (i->m (i-add_x{n}_csp-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable get nat-to-v link-table-entry)))

; To make the theorem below work, I had to change the -okp fn to
; check that the fetch of sys-addr i-x produced an i-objectp.

(prove-lemma i-m-one-way-correspondence-step-move_x_<x{s}>
             (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-move_x_<x{s}>-okp i)
                (equal (i-current-instruction i)
                       '(move_x_<x{s}>)))
           (equal (i->m (i-move_x_<x{s}>-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-m-one-way-correspondence-step-move_y_<y{s}>
             (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-move_y_<y{s}>-okp i)
                (equal (i-current-instruction i)
                       '(move_y_<y{s}>)))
           (equal (i->m (i-move_y_<y{s}>-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-m-one-way-correspondence-step-move_y_tsp (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-move_y_tsp-okp i)
                (equal (i-current-instruction i) '(move_y_tsp)))
           (equal (i->m (i-move_y_tsp-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-m-one-way-correspondence-step-tpush_csp (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-tpush_csp-okp i)
                (equal (i-current-instruction i) '(tpush_csp)))
           (equal (i->m (i-tpush_csp-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-m-one-way-correspondence-step-tpush_tsp (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-tpush_tsp-okp i)
                (equal (i-current-instruction i) '(tpush_tsp)))
           (equal (i->m (i-tpush_tsp-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-m-one-way-correspondence-step-tpush_x (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-tpush_x-okp i)
                (equal (i-current-instruction i) '(tpush_x)))
           (equal (i->m (i-tpush_x-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-m-one-way-correspondence-step-tpush_<x{s}>
             (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-tpush_<x{s}>-okp i)
                (equal (i-current-instruction i)
                       '(tpush_<x{s}>)))
           (equal (i->m (i-tpush_<x{s}>-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-m-one-way-correspondence-step-tpush_<x{a}>
             (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-tpush_<x{a}>-okp i)
                (equal (i-current-instruction i) '(tpush_<x{a}>)))
           (equal (i->m (i-tpush_<x{a}>-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable get nat-to-v link-table-entry)))


; To make the theorem below work I had to change the -okp function
; to make sure that nextword was an i-objectp

(prove-lemma i-m-one-way-correspondence-step-tpush_* (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-tpush_*-okp i)
                (equal (i-current-instruction i) '(tpush_*)))
           (equal (i->m (i-tpush_*-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable get nat-to-v link-table-entry)))

; To make the theorem below work I had to change the -okp function
; to make sure that the top of tsp was an i-objectp.

(prove-lemma i-m-one-way-correspondence-step-tpop_x (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-tpop_x-okp i)
                (equal (i-current-instruction i) '(tpop_x)))
           (equal (i->m (i-tpop_x-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable get nat-to-v link-table-entry)))

; To make the theorem below work I had to change the -okp function
; to make sure that the top of tsp was an i-objectp.

(prove-lemma i-m-one-way-correspondence-step-tpop_y (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-tpop_y-okp i)
                (equal (i-current-instruction i) '(tpop_y)))
           (equal (i->m (i-tpop_y-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-m-one-way-correspondence-step-tpop_<x{s}>
             (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-tpop_<x{s}>-okp i)
                (equal (i-current-instruction i)
                       '(tpop_<x{s}>)))
           (equal (i->m (i-tpop_<x{s}>-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma segment-length-put-assoc (rewrite)
  (implies (equal (length (cdr (assoc name segment)))
                       (length val))
           (equal (segment-length (put-assoc val name segment))
                  (segment-length segment))))


(prove-lemma i-m-one-way-correspondence-step-tpop_<x{a}>
             (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-tpop_<x{a}>-okp i)
                (equal (i-current-instruction i)
                       '(tpop_<x{a}>)))
           (equal (i->m (i-tpop_<x{a}>-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma car-assoc (rewrite)
  (implies (definedp name alist)
           (equal (car (assoc name alist)) name)))

(prove-lemma assoc-link-table-for-prog-labels (rewrite)
  (implies (and (numberp addr0)
                (definedp name segment))
           (equal
            (cdr
             (assoc name
                    (link-table-for-prog-labels segment addr0)))
            (link-table-for-labels
             (definiens name segment)
             (plus addr0
                   (link-table-entry name segment))))))

(prove-lemma assoc-link-table-for-labels (rewrite)
  (implies (and (numberp addr0)
                (find-labelp label lst))
           (equal (cdr (assoc label
                              (link-table-for-labels
                               lst
                               addr0)))
                  (plus addr0 (find-label label lst)))))

(prove-lemma i-m-one-way-correspondence-step-jump_* (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-jump_*-okp i)
                (equal (i-current-instruction i) '(jump_*)))
           (equal (i->m (i-jump_*-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-m-one-way-correspondence-step-cpop_pc (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-cpop_pc-okp i)
                (equal (i-current-instruction i) '(cpop_pc)))
           (equal (i->m (i-cpop_pc-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-m-one-way-correspondence-step-move_<x{s}>_<tsp>
             (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-move_<x{s}>_<tsp>-okp i)
                (equal (i-current-instruction i)
                       '(move_<x{s}>_<tsp>)))
           (equal (i->m (i-move_<x{s}>_<tsp>-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-m-one-way-correspondence-step-move_<x{a}>_<tsp>
             (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-move_<x{a}>_<tsp>-okp i)
                (equal (i-current-instruction i)
                       '(move_<x{a}>_<tsp>)))
           (equal (i->m (i-move_<x{a}>_<tsp>-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-m-one-way-correspondence-step-jump_x{subr} (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-jump_x{subr}-okp i)
                (equal (i-current-instruction i) '(jump_x{subr})))
           (equal (i->m (i-jump_x{subr}-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma bool-to-logical-non-f (rewrite)
  (implies (not (equal x 'F))
           (equal (bool-to-logical x) t))
  ((enable bool-to-logical)))

(prove-lemma i-m-one-way-correspondence-step-jump-n_x (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-jump-n_x-okp i)
                (equal (i-current-instruction i) '(jump-n_x)))
           (equal (i->m (i-jump-n_x-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-m-one-way-correspondence-step-jump-nn_x (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-jump-nn_x-okp i)
                (equal (i-current-instruction i) '(jump-nn_x)))
           (equal (i->m (i-jump-nn_x-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-m-one-way-correspondence-step-jump-z_x (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-jump-z_x-okp i)
                (equal (i-current-instruction i) '(jump-z_x)))
           (equal (i->m (i-jump-z_x-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-m-one-way-correspondence-step-jump-nz_x (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-jump-nz_x-okp i)
                (equal (i-current-instruction i) '(jump-nz_x)))
           (equal (i->m (i-jump-nz_x-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-m-one-way-correspondence-step-tpop_pc (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-tpop_pc-okp i)
                (equal (i-current-instruction i) '(tpop_pc)))
           (equal (i->m (i-tpop_pc-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable get nat-to-v link-table-entry)))

; To make the theorem below work I had to change the -okp fn to
; insure that the top of tsp was an i-objectp.

(prove-lemma i-m-one-way-correspondence-step-tpop_<c>_x (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-tpop_<c>_x-okp i)
                (equal (i-current-instruction i) '(tpop_<c>_x)))
           (equal (i->m (i-tpop_<c>_x-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable get nat-to-v link-table-entry)))

; To make the thm below work I had to redefine the -step function
; because it did not include an untag in the computation of the flag.

; A lemma v-nzerop-nat-to-v exists in fm9001.events, but it did not
; originally.  We accommodate this change by introducing the "my-"
; prefix below.

(prove-lemma my-v-nzerop-nat-to-v (rewrite)
 (implies (lessp n (exp 2 word-size))
          (equal (v-nzerop (nat-to-v n word-size))
                 (not (zerop n)))))

(prove-lemma alu-thm_bitv-zb-move-15 (rewrite)
  (implies (and (bvp a)
                (bvp b)
                (equal (length a) (length b))
                (boolp c))
           (equal (zb (v-alu c a b (list t t t t)))
                  (not (v-nzerop a))))
  ((enable zb v-alu)))

(prove-lemma i-m-one-way-correspondence-step-tpop{n}_<z>_y
             (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-tpop{n}_<z>_y-okp i)
                (equal (i-current-instruction i)
                       '(tpop{n}_<z>_y)))
           (equal (i->m (i-tpop{n}_<z>_y-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma size-int-to-v (rewrite)
  (equal (length (int-to-v i word-size)) (fix word-size))
  ((enable int-to-v)))

; These seem irrelevant and I'm going to skip them for the moment...
; They may have v-nzerop counterparts...

;(prove-lemma v-to-nat-incr-t (rewrite)
;  (equal (v-to-nat (incr t b))
;        (if (all-onesp b)
;            0
;            (add1 (v-to-nat b)))))

;(prove-lemma all-onesp-compl (rewrite)
;  (equal (all-onesp (v-not b))
;        (equal (v-to-nat b) 0)))

(prove-lemma zerop-v-to-nat-int-to-v (rewrite)
  (implies (and (not (zerop word-size))
                (small-integerp i word-size))
           (equal (equal (v-to-nat (int-to-v i word-size)) 0)
                  (equal i 0)))
  ((enable int-to-v)))

; A lemma v-nzerop-int-to-v exists in fm9001.events, but it did not
; originally.  We accommodate this change by introducing the "my-"
; prefix below.

(prove-lemma my-v-nzerop-int-to-v (rewrite)
  (implies (and (not (zerop word-size))
                (small-integerp i word-size))
           (equal (v-nzerop (int-to-v i word-size))
                  (not (equal i 0))))
  ((enable small-integerp int-to-v)))

(prove-lemma v-negp-nat-to-v (rewrite)
  (implies (and (not (zerop w))
                (lessp n (exp 2 w)))
           (equal (v-negp (nat-to-v n w))
                  (not (lessp n (exp 2 (sub1 w)))))))

(prove-lemma v-negp-int-to-v (rewrite)
  (implies (and (not (zerop word-size))
                (small-integerp i word-size))
           (equal (v-negp (int-to-v i word-size))
                  (negativep i)))
  ((enable int-to-v)))

(disable v-negp-nat-to-v)

; I had to change the -step fn below because it failed to set y!

(prove-lemma i-m-one-way-correspondence-step-tpop{i}_<zn>_y
             (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-tpop{i}_<zn>_y-okp i)
                (equal (i-current-instruction i)
                       '(tpop{i}_<zn>_y)))
           (equal (i->m (i-tpop{i}_<zn>_y-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((enable n)
   (disable int-to-v v-to-int
            small-integerp
            integerp
            get nat-to-v link-table-entry)))

(prove-lemma i-m-one-way-correspondence-step-tpop{b}_<z>_y
             (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-tpop{b}_<z>_y-okp i)
                (equal (i-current-instruction i)
                       '(tpop{b}_<z>_y)))
           (equal (i->m (i-tpop{b}_<z>_y-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma all-zero-bitvp-not-v-nzerop-bitv-to-v (rewrite)
  (equal (all-zero-bitvp b)
         (not (v-nzerop (bitv-to-v b (length b))))))

(prove-lemma length-bit-vectorp (rewrite)
  (implies (bit-vectorp b word-size)
           (equal (length b) (fix word-size))))

(prove-lemma i-m-one-way-correspondence-step-tpop{v}_<z>_y
             (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-tpop{v}_<z>_y-okp i)
                (equal (i-current-instruction i)
                       '(tpop{v}_<z>_y)))
           (equal (i->m (i-tpop{v}_<z>_y-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable get nat-to-v link-table-entry)))

; For the next owc lemma it would be useful to have the
; commutativity of plus, but providing it messes up our
; rewrite rules.  We have implicitly assumed we had total
; knowledge of the shape of plus-nests.  The following rule,
; which is elegant in its own right, elevates the two
; plus expressions to the point where linear arithmetic
; can deal with them.

(prove-lemma put-equal (rewrite)
  (equal (equal (put val1 n lst)
                (put val2 n lst))
         (equal val1 val2)))

(prove-lemma i-m-one-way-correspondence-step-add_<tsp>{a}_x{n} (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-add_<tsp>{a}_x{n}-okp i)
                (equal (i-current-instruction i) '(add_<tsp>{a}_x{n})))
           (equal (i->m (i-add_<tsp>{a}_x{n}-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-m-one-way-correspondence-step-add_tsp_*{n} (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-add_tsp_*{n}-okp i)
                (equal (i-current-instruction i) '(add_tsp_*{n})))
           (equal (i->m (i-add_tsp_*{n}-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-m-one-way-correspondence-step-add_tsp_x{n} (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-add_tsp_x{n}-okp i)
                (equal (i-current-instruction i) '(add_tsp_x{n})))
           (equal (i->m (i-add_tsp_x{n}-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-m-one-way-correspondence-step-sub_<tsp>{a}_x{n} (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-sub_<tsp>{a}_x{n}-okp i)
                (equal (i-current-instruction i) '(sub_<tsp>{a}_x{n})))
           (equal (i->m (i-sub_<tsp>{a}_x{n}-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-m-one-way-correspondence-step-sub_x{s}_y{n} (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-sub_x{s}_y{n}-okp i)
                (equal (i-current-instruction i) '(sub_x{s}_y{n})))
           (equal (i->m (i-sub_x{s}_y{n}-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma all-zero-bitvp-xor-bitv nil
  (implies (and (bit-vectorp a word-size)
                (bit-vectorp b word-size))
           (equal (all-zero-bitvp (xor-bitv a b))
                  (equal a b))))

(prove-lemma equal-append-generalized (rewrite)
  (implies (and (properp a)
                (properp b)
                (equal (length a) (length b)))
           (equal (equal (append a x)
                         (append b y))
                  (and (equal a b)
                       (equal x y))))
  ((induct (pairlist a b))))

(prove-lemma properp-v-to-bitv (rewrite)
  (properp (V-TO-BITV x)))

(prove-lemma length-v-to-bitv (rewrite)
  (equal (length (V-TO-BITV a))
         (length a)))

(prove-lemma equal-v-to-bitv nil
   (implies (and (bvp x)
                 (bvp y)
                 (equal (length x) (length y)))
            (equal (equal (V-TO-BITV x)
                          (V-TO-BITV y))
                   (equal x y)))
   ((induct (v-and x y))
    (enable boolp)))

(prove-lemma bit-vectorp-append-singleton (rewrite)
  (implies (and (bitp bit)
                (properp a))
           (equal (bit-vectorp (append a (list bit)) n)
                  (if (zerop n)
                      f
                      (bit-vectorp a (sub1 n)))))
  ((induct (bit-vectorp a n))
   (disable bitp)))
                  
(defn bit-vectorp-v-to-bitv-hint (a word-size)
  (if (or (zerop word-size)
          (not (bvp a))
          (nlistp a))
      t
      (bit-vectorp-v-to-bitv-hint (cdr a) (sub1 word-size))))

(prove-lemma bit-vectorp-v-to-bitv-lemma (rewrite)
  (bit-vectorp (v-to-bitv a) (length a)))

(prove-lemma bit-vectorp-v-to-bitv (rewrite)
  (equal (bit-vectorp (V-TO-BITV a) word-size)
         (equal (length a) (fix word-size)))
  ((disable length-bit-vectorp)
   (use (length-bit-vectorp (b (v-to-bitv a))))))

(prove-lemma bit-vectorp-v-to-bitv-link-data-word (rewrite)
  (bit-vectorp (V-TO-BITV (link-data-word x
                                           tables
                                           word-size))
               word-size)
  ((enable link-data-word int-to-v)))

(prove-lemma equal-int-to-v (rewrite)
  (implies (and (not (zerop word-size))
                (small-integerp i word-size)
                (small-integerp j word-size))
           (equal (equal (int-to-v i word-size)
                         (int-to-v j word-size))
                  (equal i j)))
  ((disable v-to-int-inverts-int-to-v small-integerp)
   (use (v-to-int-inverts-int-to-v)
        (v-to-int-inverts-int-to-v (i j)))))

(prove-lemma v-to-bitv-inverts-bitv-to-v (rewrite)
  (implies (bit-vectorp x word-size)
           (equal (V-TO-BITV (bitv-to-v x word-size)) x)))

(prove-lemma equal-bitv-to-v (rewrite)
  (implies (and (bit-vectorp x word-size)
                (bit-vectorp y word-size))
           (equal (equal (bitv-to-v x word-size)
                         (bitv-to-v y word-size))
                  (equal x y)))
  ((disable v-to-bitv-inverts-bitv-to-v)
   (use (V-TO-BITV-inverts-bitv-to-v)
        (V-TO-BITV-inverts-bitv-to-v (x y)))))

(prove-lemma v-to-bool-inverts-bool-to-v (rewrite)
  (implies (and (not (zerop word-size))
                (booleanp x))
           (equal (V-TO-BOOL (BOOL-TO-V x word-size))
                  x))
  ((enable booleanp)
   (expand (nat-to-v 0 word-size)
           (nat-to-v 1 word-size))))

(prove-lemma equal-bool-to-v (rewrite)
  (implies (and (not (zerop word-size))
                (booleanp x)
                (booleanp y))
           (equal (equal (BOOL-TO-V x word-size)
                         (BOOL-TO-V y word-size))
                  (equal x y)))
  ((disable v-to-bool-inverts-bool-to-v)
   (use (V-TO-BOOL-inverts-bool-to-v)
        (V-TO-BOOL-inverts-bool-to-v (x y)))))

; We now turn to the harder cases of linking, those involving
; the link tables.

; Three of the linkers, namely addr-to-v, sys-addr-to-v, and
; ipc-to-v, use the primitive function absolute-address to
; compute their values.  We therefore first establish that
; absolute-address can be inverted on the link table actually used.

(prove-lemma cons-adp-name-adp-offset (rewrite)
  (implies (listp adp)
           (equal (cons (adp-name adp) (adp-offset adp)) adp))
  ((enable adp-name adp-offset)))

(prove-lemma listp-link-table-for-segment (rewrite)
  (equal (listp (link-table-for-segment segment addr0))
         (listp segment)))

(prove-lemma cdar-link-table-for-segment (rewrite)
  (implies (listp segment)
           (equal (cdar (link-table-for-segment segment addr0))
                  addr0)))

(prove-lemma find-containing-area-name-link-table-for-segment (rewrite)
  (implies (adpp adp segment)
           (equal (find-containing-area-name
                   (plus (cdr (assoc (adp-name adp)
                                     (link-table-for-segment
                                                segment addr0)))
                         (adp-offset adp))
                   (link-table-for-segment segment addr0))
                  (adp-name adp))))

(prove-lemma invert-absolute-address-inverts-absolute-address (rewrite)
  (implies (adpp adp segment)
           (equal (invert-absolute-address
                   (absolute-address adp
                                     (link-table-for-segment segment addr0))
                   (link-table-for-segment segment addr0))
                  adp)))

; Now I prove the invertibility results and the equality results for
; each of the three linkers that use absolute-address:  ipc-to-v,
; addr-to-v, and sys-addr-to-v.

; Each linker is used with its own link table.  In fact, if we could
; completely characterize the link table properties we could avoid
; having different theorems for these three linkers and just have a
; general one.  Rather than do that I just prove the appropriate
; result for the link table used by each linker.

; In fact we prove three lemmas for each linker.  The first establishes
; that the absolute address computed for a given link table is small
; enough.  The second is the invertibility result for the link table.
; The third is the equality result.

; Here is the series for prog-segment addresses.

; The following lemma would not be necessary if absolute-address could be
; enabled in the lemma below this.  But the invertibility of absolute-address
; above requires that the fn be disabled.

; The (PLUS LOAD-ADDR ...) term below is just (i-loadablep i load-addr).
; But it is open because it contains the free-var load-addr and will be
; the term we look for to bind that var.



(prove-lemma lessp-absolute-address-ipc (rewrite)
  (implies (and (adpp adp (i-prog-segment i))
                (LESSP (PLUS LOAD-ADDR 
                             (SEGMENT-LENGTH (I-USR-DATA-SEGMENT I)) 
                             (SEGMENT-LENGTH (I-PROG-SEGMENT I)) 
                             (SEGMENT-LENGTH (I-SYS-DATA-SEGMENT I))) 
                       (EXP 2 (I-WORD-SIZE I))))
           (lessp (absolute-address
                               adp
                               (link-table-for-segment
                                    (i-prog-segment i)
                                    (plus load-addr
                                          (segment-length (i-usr-data-segment i)))))
                  (exp 2 (i-word-size i)))))

; To prove the invertibility result for ipcs and keep it exactly
; symmetric with addrs and sys-addrs, it is necessary to define
; the inverter.  The inverter is not used in the main theorem.

(defn v-to-ipc (bv prog-links)
  (invert-absolute-address (v-to-nat bv)
                           prog-links))

(prove-lemma v-to-ipc-inverts-ipc-to-v (rewrite)
  (implies (and (adpp adp (i-prog-segment i))
                (i-loadablep i load-addr))
           (equal (v-to-ipc
                   (ipc-to-v adp
                             (link-table-for-segment
                              (i-prog-segment i)
                              (plus load-addr (segment-length (i-usr-data-segment i))))
                             (i-word-size i))
                   (link-table-for-segment
                    (i-prog-segment i)
                     (plus load-addr (segment-length (i-usr-data-segment i)))))
                  adp))
  ((disable absolute-address invert-absolute-address)))

(prove-lemma equal-ipc-to-v (rewrite)
  (implies (and (adpp adp1 (i-prog-segment i))
                (adpp adp2 (i-prog-segment i))
                (i-loadablep i load-addr))
           (equal (equal (IPC-TO-V adp1
                                   (link-table-for-segment
                                    (i-prog-segment i)
                                    (plus load-addr (segment-length (i-usr-data-segment i))))
                                   (i-word-size i))
                         (IPC-TO-V adp2
                                   (link-table-for-segment
                                    (i-prog-segment i)
                                    (plus load-addr (segment-length (i-usr-data-segment i))))
                                   (i-word-size i)))
                  (equal adp1 adp2)))
  ((disable v-to-ipc-inverts-ipc-to-v
            v-to-ipc ipc-to-v)
   (use (V-TO-IPC-inverts-ipc-to-v (adp adp1))
        (V-TO-IPC-inverts-ipc-to-v (adp adp2)))))

; So now we repeat the exercise for ADDRs.  That is, we use the usr-data
; segment and its link table...

(prove-lemma lessp-absolute-address-usr-data (rewrite)
  (implies (and (adpp adp (i-usr-data-segment i))
                (LESSP (PLUS LOAD-ADDR 
                             (SEGMENT-LENGTH (I-USR-DATA-SEGMENT I)) 
                             (SEGMENT-LENGTH (I-PROG-SEGMENT I)) 
                             (SEGMENT-LENGTH (I-SYS-DATA-SEGMENT I))) 
                       (EXP 2 (I-WORD-SIZE I)))
                (numberp load-addr))
           (lessp (absolute-address
                               adp
                               (link-table-for-segment
                                    (i-usr-data-segment i)
                                    load-addr))
                  (exp 2 (i-word-size i)))))

(prove-lemma v-to-addr-inverts-addr-to-v (rewrite)
  (implies (and (numberp load-addr)
                (adpp adp (i-usr-data-segment i))
                (i-loadablep i load-addr))
           (equal (V-TO-ADDR
                   (ADDR-TO-V adp
                               (link-table-for-segment
                                    (i-usr-data-segment i)
                                    load-addr)
                               (i-word-size i))
                   (link-table-for-segment
                        (i-usr-data-segment i)
                        load-addr))
                  adp))
  ((disable absolute-address invert-absolute-address)))

(prove-lemma equal-addr-to-v (rewrite)
  (implies (and (numberp load-addr)
                (adpp adp1 (i-usr-data-segment i))
                (adpp adp2 (i-usr-data-segment i))
                (i-loadablep i load-addr))
           (equal (equal (ADDR-TO-V adp1
                                     (link-table-for-segment
                                        (i-usr-data-segment i)
                                        load-addr)
                                     (i-word-size i))
                         (ADDR-TO-V adp2
                                     (link-table-for-segment
                                        (i-usr-data-segment i)
                                        load-addr)
                                     (i-word-size i)))
                  (equal adp1 adp2)))
  ((disable v-to-addr-inverts-addr-to-v
            v-to-addr addr-to-v)
   (use (V-TO-ADDR-inverts-addr-to-v (adp adp1))
        (V-TO-ADDR-inverts-addr-to-v (adp adp2)))))

; And finally we do the SYS-ADDR type...

(prove-lemma lessp-absolute-address-sys-data (rewrite)
  (implies (and (adpp adp (i-sys-data-segment i))
                (LESSP (PLUS LOAD-ADDR 
                             (SEGMENT-LENGTH (I-USR-DATA-SEGMENT I)) 
                             (SEGMENT-LENGTH (I-PROG-SEGMENT I)) 
                             (SEGMENT-LENGTH (I-SYS-DATA-SEGMENT I))) 
                       (EXP 2 (I-WORD-SIZE I))))
           (lessp (absolute-address
                               adp
                               (link-table-for-segment
                                    (i-sys-data-segment i)
                                    (plus
                                     load-addr
                                     (segment-length
                                      (i-usr-data-segment i))
                                     (segment-length
                                      (i-prog-segment i)))))
                  (exp 2 (i-word-size i)))))

(prove-lemma v-to-sys-addr-inverts-sys-addr-to-v (rewrite)
  (implies (and (adpp adp (i-sys-data-segment i))
                (i-loadablep i load-addr))
           (equal (V-TO-SYS-ADDR
                   (sys-addr-to-v adp
                                   (link-table-for-segment
                                    (i-sys-data-segment i)
                                    (plus
                                     load-addr
                                     (segment-length
                                      (i-usr-data-segment i))
                                     (segment-length
                                      (i-prog-segment i))))
                                   (i-word-size i))
                   (link-table-for-segment
                    (i-sys-data-segment i)
                    (plus
                     load-addr
                     (segment-length
                      (i-usr-data-segment i))
                     (segment-length
                      (i-prog-segment i)))))
                  adp))
  ((disable absolute-address invert-absolute-address)))

(prove-lemma equal-sys-addr-to-v (rewrite)
  (implies (and (adpp adp1 (i-sys-data-segment i))
                (adpp adp2 (i-sys-data-segment i))
                (i-loadablep i load-addr))
           (equal (equal (sys-addr-to-v adp1
                                     (link-table-for-segment
                                        (i-sys-data-segment i)
                                        (plus
                                         load-addr
                                         (segment-length
                                          (i-prog-segment i))
                                         (segment-length
                                          (i-usr-data-segment i))))
                                     (i-word-size i))
                         (sys-addr-to-v adp2
                                     (link-table-for-segment
                                        (i-sys-data-segment i)
                                        (plus
                                         load-addr
                                         (segment-length
                                          (i-prog-segment i))
                                         (segment-length
                                          (i-usr-data-segment i))))
                                     (i-word-size i)))
                  (equal adp1 adp2)))
  ((disable v-to-sys-addr-inverts-sys-addr-to-v
            v-to-sys-addr sys-addr-to-v)
   (enable commutativity-of-plus)
   (use (V-TO-SYS-ADDR-inverts-sys-addr-to-v (adp adp1))
        (V-TO-SYS-ADDR-inverts-sys-addr-to-v (adp adp2)))))

; Now I turn to the SUBR case.  It uses base-address instead of
; absolute-address.  The results we need could probably be
; obtained by creative instantiation of what we have.  But I
; prefer simply to prove them cold in perfect analogy with
; what we have done already.

(prove-lemma lessp-0-length (rewrite)
  (implies (listp a) (lessp 0 (length a))))

(prove-lemma invert-base-address-inverts-base-address-on-subrs (rewrite)
  (implies (adpp (cons name 0) segment)
           (equal (invert-base-address
                   (base-address name
                                 (link-table-for-segment segment addr0))
                   (link-table-for-segment segment addr0))
                  name)))

(prove-lemma lessp-base-address-link-table-for-segment (rewrite)
  (implies (and (adpp (cons name 0) (i-prog-segment i))
                (LESSP (PLUS LOAD-ADDR 
                             (SEGMENT-LENGTH (I-USR-DATA-SEGMENT I)) 
                             (SEGMENT-LENGTH (I-PROG-SEGMENT I)) 
                             (SEGMENT-LENGTH (I-SYS-DATA-SEGMENT I))) 
                       (EXP 2 (I-WORD-SIZE I)))         )
           (lessp (base-address name
                                (link-table-for-segment
                                    (i-prog-segment i)
                                    (plus load-addr
                                          (segment-length (i-usr-data-segment i)))))
                  (exp 2 (i-word-size i))))
  ((use (lessp-absolute-address-segment-length-generalized
         (segment (i-prog-segment i))
         (offset 0)))))

(prove-lemma numberp-base-address-link-table-for-segment (rewrite)
  (implies (numberp addr0)
           (numberp (base-address name
                                  (link-table-for-segment
                                   segment
                                   addr0)))))

(prove-lemma v-to-subr-inverts-subr-to-v (rewrite)
  (implies (and (adpp (cons subr 0) (i-prog-segment i))
                (i-loadablep i load-addr))
           (equal (V-TO-SUBR
                   (subr-to-v subr
                               (link-table-for-segment
                                (i-prog-segment i)
                                (plus load-addr (segment-length (i-usr-data-segment i))))
                               (i-word-size i))
                   (link-table-for-segment
                        (i-prog-segment i)
                        (plus load-addr (segment-length (i-usr-data-segment i)))))
                  subr))
  ((disable base-address invert-base-address)))

(prove-lemma equal-subr-to-v (rewrite)
  (implies (and (adpp (cons subr1 0) (i-prog-segment i))
                (adpp (cons subr2 0) (i-prog-segment i))
                (i-loadablep i load-addr))
           (equal (equal (subr-to-v subr1
                                     (link-table-for-segment
                                        (i-prog-segment i)
                                        (plus load-addr (segment-length (i-usr-data-segment i))))
                                     (i-word-size i))
                         (subr-to-v subr2
                                     (link-table-for-segment
                                        (i-prog-segment i)
                                        (plus load-addr (segment-length (i-usr-data-segment i))))
                                     (i-word-size i)))
                  (equal subr1 subr2)))
  ((disable v-to-subr-inverts-subr-to-v
            v-to-subr subr-to-v)
   (use (V-TO-SUBR-inverts-subr-to-v (subr subr1))
        (V-TO-SUBR-inverts-subr-to-v (subr subr2)))))

(prove-lemma lessp-find-label-length (rewrite)
  (implies (find-labelp lab lst)
           (lessp (find-label lab lst) (length lst))))

(prove-lemma lessp-base-address-link-table-for-labels (rewrite)
  (implies (and (icode-labelp lab (i-prog-segment i))
                (i-loadablep i load-addr))
           (lessp (base-address lab
                                (link-table-for-labels
                                   (cdr (assoc (adp-name lab)
                                               (i-prog-segment i)))
                                   (plus load-addr
                                         (segment-length (i-usr-data-segment i))
                                         (link-table-entry
                                          (adp-name lab)
                                          (i-prog-segment i)))))
                  (exp 2 (i-word-size i))))
 ((use (lessp-absolute-address-segment-length-generalized
         (name (adp-name lab))
         (segment (i-prog-segment i))
         (offset (find-label lab
                             (cdr (assoc (adp-name lab)
                                         (i-prog-segment i)))))))))

(prove-lemma numberp-base-address-link-table-for-labels (rewrite)
  (implies (numberp addr0)
           (numberp (base-address name
                                  (link-table-for-labels lst addr0)))))

(prove-lemma assoc-cdrp-link-table-for-labels-t (rewrite)
  (implies (and (numberp addr0)
                (find-labelp lab lst))
           (assoc-cdrp (plus addr0 (find-label lab lst))
                       (link-table-for-labels lst addr0))))

(prove-lemma assoc-cdrp-link-table-for-labels-f (rewrite)
  (implies (not (lessp n (plus addr0 (length lst))))
           (not (assoc-cdrp n (link-table-for-labels lst addr0)))))

;The following lemma is a generalization of what we need.  We will
; instantiate it with addr0 = 0

(prove-lemma find-containing-label-table-base-address-generalized nil 
  (implies (and (numberp addr0)
                (definedp (adp-name lab) segment)
                (find-labelp lab
                             (cdr (assoc (adp-name lab) segment))))
           (equal
            (find-containing-label-table
             (base-address lab
                           (link-table-for-labels
                            (cdr (assoc (adp-name lab) segment))
                            (plus addr0
                                  (link-table-entry (adp-name lab)
                                                    segment))))
             (link-table-for-prog-labels segment addr0))
            (link-table-for-labels
             (cdr (assoc (adp-name lab) segment))
             (plus addr0
                   (link-table-entry (adp-name lab)
                                     segment))))))

(prove-lemma find-containing-label-table-base-address (rewrite)
  (implies (and (definedp (adp-name lab) segment)
                (find-labelp lab
                             (cdr (assoc (adp-name lab) segment))))
           (equal
            (find-containing-label-table
             (base-address lab
                           (link-table-for-labels
                            (cdr (assoc (adp-name lab) segment))
                            (plus load-addr
                                  (segment-length (i-usr-data-segment i))
                                  (link-table-entry (adp-name lab)
                                                    segment))))
             (link-table-for-prog-labels segment
                                         (plus load-addr (segment-length (i-usr-data-segment i)))))
            (link-table-for-labels
             (cdr (assoc (adp-name lab) segment))
             (plus load-addr
                   (segment-length (i-usr-data-segment i))
                   (link-table-entry (adp-name lab)
                                     segment)))))
  ((use (find-containing-label-table-base-address-generalized
         (addr0 (plus load-addr (segment-length (i-usr-data-segment i))))))))

(prove-lemma lessp-cdar-link-table-for-labels (rewrite)
  (implies (listp (link-table-for-labels lst addr0))
           (not (lessp (cdar (link-table-for-labels lst addr0))
                       addr0))))

(prove-lemma lessp-find-label-cdar-link-table-for-labels (rewrite)
  (implies (find-labelp lab lst)
           (not (lessp (plus addr0 (find-label lab lst))
                       (cdar (link-table-for-labels lst addr0))))))

(prove-lemma find-labelp-implies-listp-link-table-for-labels (rewrite)
  (implies (find-labelp lab lst)
           (listp (link-table-for-labels lst addr0))))

(prove-lemma invert-base-address-inverts-base-address-on-labels (rewrite)
  (implies (and (numberp addr0)
                (find-labelp lab lst))
           (equal (invert-base-address
                   (base-address lab
                                 (link-table-for-labels lst addr0))
                   (link-table-for-labels lst addr0))
                  lab)))

(prove-lemma v-to-label-inverts-label-to-v (rewrite)
  (implies (and (icode-labelp lab (i-prog-segment i))
                (i-loadablep i load-addr))
           (equal (V-TO-LABEL
                   (label-to-v lab
                                (link-table-for-prog-labels
                                 (i-prog-segment i)
                                 (plus load-addr (segment-length (i-usr-data-segment i))))
                                (i-word-size i))
                   (link-table-for-prog-labels
                    (i-prog-segment i)
                    (plus load-addr (segment-length (i-usr-data-segment i)))))
                  lab))
  ((disable base-address invert-base-address)))

(prove-lemma equal-label-to-v (rewrite)
  (implies (and (icode-labelp lab1 (i-prog-segment i))
                (icode-labelp lab2 (i-prog-segment i))
                (i-loadablep i load-addr))
           (equal (equal (label-to-v lab1
                                      (link-table-for-prog-labels
                                       (i-prog-segment i)
                                       (plus load-addr (segment-length (i-usr-data-segment i))))
                                      (i-word-size i))
                         (label-to-v lab2
                                      (link-table-for-prog-labels
                                       (i-prog-segment i)
                                       (plus load-addr (segment-length (i-usr-data-segment i))))
                                      (i-word-size i)))
                  (equal lab1 lab2)))
  ((disable v-to-label-inverts-label-to-v
            v-to-label label-to-v)
   (use (V-TO-LABEL-inverts-label-to-v (lab lab1))
        (V-TO-LABEL-inverts-label-to-v (lab lab2)))))

; The following little lemma would not be necessary if type and untag
; were opened to car and cadr and we were willing to suffer elims.

(prove-lemma equal-types-and-untags (rewrite)
  (implies (and (equal (type x) (type y))
                (equal (cddr x) nil)
                (equal (cddr y) nil)
                (not (equal x y)))
           (not (equal (untag x) (untag y))))
  ((enable type untag)))

(prove-lemma equal-link-data-word (rewrite)
  (implies (and (numberp load-addr)
                (not (zerop (i-word-size i)))
                (i-loadablep i load-addr)
                (i-objectp x i)
                (i-objectp-type (type x) y i))
           (equal (equal (link-data-word x
                                         (i-link-tables i load-addr)
                                         (i-word-size i))
                         (link-data-word y
                                         (i-link-tables i load-addr)
                                         (i-word-size i)))
                  (equal x y)))
  ((disable small-integerp bit-vectorp                 ;the top level fns of
            booleanp adpp icode-labelp                 ;i-objectp, except for
                                                       ;small-naturalp

            int-to-v bitv-to-v bool-to-v ipc-to-v   ;the top level fns of
            addr-to-v sys-addr-to-v subr-to-v       ;link-data-word
            label-to-v

            i-loadablep)
   (enable i-objectp link-data-word)))
                
; Note:  small-naturalp is not disabled above simply because I
; didn't provide what might be called equal-nat-to-v but rely
; instead on nat-to-v-equivalence, which has small-naturalp
; expanded in its hyps.

(prove-lemma bvp-link-data-word (rewrite)
  (bvp (link-data-word x table word-size))
  ((enable link-data-word)))

(prove-lemma xor-xxx-is-equal (rewrite)
  (implies (and (numberp load-addr)
                (not (zerop (i-word-size i)))
                (i-loadablep i load-addr)
                (i-objectp x i)
                (i-objectp-type (type x) y i))
           (equal (all-zero-bitvp (xor-xxx x y i load-addr))
                  (equal x y)))
 ((use (all-zero-bitvp-xor-bitv
        (a (V-TO-BITV (link-data-word x
                                       (i-link-tables i load-addr)
                                       (i-word-size i))))
        (b (V-TO-BITV (link-data-word y
                                       (i-link-tables i load-addr)
                                       (i-word-size i))))
        (word-size (i-word-size i)))
       (equal-v-to-bitv
        (x (link-data-word x
                           (i-link-tables i load-addr)
                           (i-word-size i)))
        (y (link-data-word y
                           (i-link-tables i load-addr)
                           (i-word-size i)))))))

(prove-lemma v-to-nat-v-xor-xx (rewrite)
  (equal (v-to-nat (v-xor x x)) 0))

(prove-lemma v-xor-is-equal (rewrite)
  (implies (and (bvp a)
                (bvp b)
                (equal (length a) (length b)))
           (equal (equal (v-to-nat (v-xor a b)) 0)
                  (equal a b)))
  ((enable boolp)))

(prove-lemma equal-link-word-lemma1 nil
  (implies (i-objectp x i) (not (icode-instructionp x)))
  ((enable i-objectp icode-instructionp)))

(prove-lemma equal-link-word-lemma2 nil
  (implies (i-objectp-type type x i) (not (icode-instructionp x)))
  ((enable i-objectp i-objectp-type icode-instructionp)))

(prove-lemma equal-link-word (rewrite)
  (implies (and (numberp load-addr)
                (equal word-size (i-word-size i))
                (not (zerop (i-word-size i)))
                (i-loadablep i load-addr)
                (i-objectp x i)
                (i-objectp-type (type x) y i))
           (equal (equal (link-word x (i-link-tables i load-addr) word-size)
                         (link-word y (i-link-tables i load-addr) word-size))
                  (equal x y)))
  ((use (equal-link-word-lemma1)
        (equal-link-word-lemma2 (x y) (type (type x))))
   (enable link-word)))

(prove-lemma v-xor-append (rewrite)
  (implies (and (bvp x)
                (bvp y)
                (equal (length a) (length b)))
           (equal (v-xor (append a x)
                         (append b y))
                  (append (v-xor a b) (v-xor x y)))))

(prove-lemma bitv-to-v-xor-bitv nil
  (implies (equal (length a) (length b))
           (equal (bitv-to-v (xor-bitv a b)
                              (length a))
                  (v-xor (bitv-to-v a (length a))
                         (bitv-to-v b (length a))))))

(prove-lemma bitv-to-v-inverts-v-to-bitv (rewrite)
  (implies (and (bvp a)
                (equal word-size (length a)))
           (equal (bitv-to-v (V-TO-BITV a) word-size)
                  a))
  ((disable v-to-bitv-inverts-bitv-to-v)
   (use (V-TO-BITV-inverts-bitv-to-v (x (V-TO-BITV a))
                                       (word-size (length a)))
        (equal-v-to-bitv (x (bitv-to-v (V-TO-BITV a) (length a)))
                          (y a)))))


(prove-lemma bitv-to-v-xor-xxx-is-v-xor-link-word (rewrite)
  (implies (and (numberp load-addr)
                (equal word-size (i-word-size i))
                (numberp (i-word-size i))
                (i-objectp x i)
                (i-objectp-type (type x) y i))
           (equal
            (equal (bitv-to-v (xor-xxx x y i load-addr) word-size)
                   (v-xor (link-word x (i-link-tables i load-addr) word-size)
                          (link-word y (i-link-tables i load-addr) word-size)))
            t))
  ((use (equal-link-word-lemma1)
        (equal-link-word-lemma2 (x y)(type (type x)))
        (bitv-to-v-xor-bitv
         (a (V-TO-BITV (link-data-word x
                                        (i-link-tables i load-addr)
                                        (i-word-size i))))
         (b (V-TO-BITV (link-data-word y
                                        (i-link-tables i load-addr)
                                        (i-word-size i))))))
   (enable link-word)))

; The complications are neverending!  Ok.  The next problem is
; that the two machines use xor in opposite orders.  That is,
; the xor done by one is the commuted version of the one done
; by the other.  So

(prove-lemma commutativity-of-xor-bitv (rewrite)
  (implies (equal (length x) (length y))
           (equal (xor-bitv x y) (xor-bitv y x))))

(prove-lemma commutativity-of-xor-xxx (rewrite)
  (equal (xor-xxx x y i load-addr)
         (xor-xxx y x i load-addr)))

(prove-lemma alu-thm_bitv-zb-xor (rewrite)
  (implies (and (bvp a)
                (bvp b)
                (equal (length a) (length b))
                (boolp c))
           (equal (zb (v-alu c a b (list t t f t)))
                  (not (v-nzerop (v-xor a b)))))
  ((enable zb v-alu)))

; There is a certain amount of xor versus equal work above.  Unfortunately,
; I think it was all made irrelevant when FM9001 was introduced with its
; kind of bit vectors.

(prove-lemma v-nzerop-v-xor (rewrite)
  (implies (and (bvp a)
                (bvp b)
                (equal (length a) (length b)))
           (equal (v-nzerop (v-xor a b))
                  (not (equal a b))))
  ((enable boolp)))

(prove-lemma i-m-one-way-correspondence-step-xor_<z>_<tsp>_x
             (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-xor_<z>_<tsp>_x-okp i)
                (equal (i-current-instruction i)
                       '(xor_<z>_<tsp>_x)))
           (equal (i->m (i-xor_<z>_<tsp>_x-step i load-addr) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((enable i-objectp-type)
   (disable xor-xxx
            get nat-to-v link-table-entry)))

; The next owc uses xor to zero the top of stack.  I need

(prove-lemma v-xor-x-x-is-0 (rewrite)
  (equal (v-xor x x)
         (nat-to-v 0 (length x))))

; This rule will clash with others, like (v-to-nat (v-xor x x)) = 0,
; but I don't think I'll need the other rules anymore.  Famous last
; words.  This will return to haunt me.

(prove-lemma i-m-one-way-correspondence-step-xor_<tsp>_<tsp> (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-xor_<tsp>_<tsp>-okp i)
                (equal (i-current-instruction i) '(xor_<tsp>_<tsp>)))
           (equal (i->m (i-xor_<tsp>_<tsp>-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable get nat-to-v link-table-entry)))

; To make the next theorem work I had to change the -okp fn to
; insure that the nextword was an i-objectp

(prove-lemma i-m-one-way-correspondence-step-move-z_<tsp>_* (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-move-z_<tsp>_*-okp i)
                (equal (i-current-instruction i) '(move-z_<tsp>_*)))
           (equal (i->m (i-move-z_<tsp>_*-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-m-one-way-correspondence-step-move-n_x_* (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-move-n_x_*-okp i)
                (equal (i-current-instruction i) '(move-n_x_*)))
           (equal (i->m (i-move-n_x_*-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-m-one-way-correspondence-step-move_<tsp>_* (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-move_<tsp>_*-okp i)
                (equal (i-current-instruction i) '(move_<tsp>_*)))
           (equal (i->m (i-move_<tsp>_*-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma listp-nat-to-v (rewrite)
  (equal (listp (nat-to-v n word-size))
         (not (zerop word-size))))

(prove-lemma listp-int-to-v (rewrite)
  (equal (listp (int-to-v i word-size))
         (not (zerop word-size)))
  ((enable int-to-v)))

(prove-lemma i-m-one-way-correspondence-step-incr_<tsp>_<tsp>{i} (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-incr_<tsp>_<tsp>{i}-okp i)
                (equal (i-current-instruction i) '(incr_<tsp>_<tsp>{i})))
           (equal (i->m (i-incr_<tsp>_<tsp>{i}-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable alu-thm_nat-bv-incr alu-thm_nat-c-incr
            int-to-v v-to-int
            small-integerp
            integerp
            iplus
            get nat-to-v link-table-entry)))

(prove-lemma i-m-one-way-correspondence-step-sub_<tsp>{i}_x{i} (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-sub_<tsp>{i}_x{i}-okp i)
                (equal (i-current-instruction i) '(sub_<tsp>{i}_x{i})))
           (equal (i->m (i-sub_<tsp>{i}_x{i}-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable alu-thm_nat-bv-sub alu-thm_nat-c-sub
            int-to-v v-to-int
            small-integerp
            integerp
            iplus
            get nat-to-v link-table-entry)))

(prove-lemma i-m-one-way-correspondence-step-decr_<tsp>_<tsp>{i} (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-decr_<tsp>_<tsp>{i}-okp i)
                (equal (i-current-instruction i) '(decr_<tsp>_<tsp>{i})))
           (equal (i->m (i-decr_<tsp>_<tsp>{i}-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable alu-thm_nat-bv-decr alu-thm_nat-c-decr
            int-to-v v-to-int
            small-integerp
            integerp
            iplus
            get nat-to-v link-table-entry)))

(prove-lemma i-m-one-way-correspondence-step-neg_<tsp>_<tsp>{i} (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-neg_<tsp>_<tsp>{i}-okp i)
                (equal (i-current-instruction i) '(neg_<tsp>_<tsp>{i})))
           (equal (i->m (i-neg_<tsp>_<tsp>{i}-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable int-to-v v-to-int
            small-integerp
            integerp
            iplus
            get nat-to-v link-table-entry)))

(prove-lemma i-m-one-way-correspondence-step-asr_<c>_<tsp>_<tsp>{b} (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-asr_<c>_<tsp>_<tsp>{b}-okp i)
                (equal (i-current-instruction i) '(asr_<c>_<tsp>_<tsp>{b})))
           (equal (i->m (i-asr_<c>_<tsp>_<tsp>{b}-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma plus-1 (rewrite) (equal (plus 1 x) (add1 x)))

(prove-lemma not-zerop-exp-2-32 (rewrite) (lessp 0 (exp 2 32))
 ((enable *1*exp)))

(prove-lemma i-m-one-way-correspondence-step-addc_<c>_x{n}_y{n} (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-addc_<c>_x{n}_y{n}-okp i)
                (equal (i-current-instruction i) '(addc_<c>_x{n}_y{n})))
           (equal (i->m (i-addc_<c>_x{n}_y{n}-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable alu-thm_tc-bv-addc get nat-to-v link-table-entry)))

(prove-lemma i-m-one-way-correspondence-step-add_<tsp>{n}_x{n} (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-add_<tsp>{n}_x{n}-okp i)
                (equal (i-current-instruction i) '(add_<tsp>{n}_x{n})))
           (equal (i->m (i-add_<tsp>{n}_x{n}-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable alu-thm_tc-bv-add get nat-to-v link-table-entry)))

(prove-lemma i-m-one-way-correspondence-step-incr_<tsp>_<tsp>{n} (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-incr_<tsp>_<tsp>{n}-okp i)
                (equal (i-current-instruction i) '(incr_<tsp>_<tsp>{n})))
           (equal (i->m (i-incr_<tsp>_<tsp>{n}-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable alu-thm_tc-bv-incr get nat-to-v link-table-entry)))

(prove-lemma i-m-one-way-correspondence-step-incr_y_y{n} (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-incr_y_y{n}-okp i)
                (equal (i-current-instruction i) '(incr_y_y{n})))
           (equal (i->m (i-incr_y_y{n}-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable alu-thm_tc-bv-incr get nat-to-v link-table-entry)))

; The following lemma, put-link-segment-no-op, states that it is a
; no-op to put into the link-segment of a segment a value that is
; the link-word of what is already at the corresponding position
; in the segment.  This lemma is what enables us to convert from
; one data type to another, e.g., from INT to NAT, by doing an
; explicit push in the i-level machine but a no-op in the m-level.
; To justify such an act all we need to know is that the link-word
; of what is being pushed is the link-word of what was already
; there.

(prove-lemma put-link-area-no-op (rewrite)
  (implies (and (numberp offset)
                (lessp offset (length v)))
           (equal (put (link-word (unlabel (get offset v))
                                  link-tables word-size)
                       offset
                       (link-area v link-tables word-size))
                  (link-area v link-tables word-size))))

(prove-lemma put-link-segment-no-op (rewrite)
  (implies (and (definedp name segment)
                (numberp offset)
                (lessp offset (length (cdr (assoc name segment))))
                (equal val
                       (link-word (unlabel
                                   (get offset (cdr (assoc name segment))))
                                  link-tables
                                  word-size)))
           (equal (equal (put val
                              (plus (link-table-entry name segment)
                                    offset)
                              (link-segment segment link-tables word-size))
                         (link-segment segment link-tables word-size))
                  t)))

; For the INT-TO-NAT case the justification is then:

(prove-lemma int-to-v-is-nat-to-v-on-nats (rewrite)
  (implies (numberp n)
           (equal (int-to-v n word-size)
                  (nat-to-v n word-size)))
  ((enable int-to-v)))

(prove-lemma i-m-one-way-correspondence-step-int-to-nat (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-int-to-nat-okp i)
                (equal (i-current-instruction i) '(int-to-nat)))
           (equal (i->m (i-int-to-nat-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable get nat-to-v link-table-entry)))

(disable int-to-v-is-nat-to-v-on-nats)

(prove-lemma i-m-one-way-correspondence-step-decr_<tsp>_<tsp>{n} (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-decr_<tsp>_<tsp>{n}-okp i)
                (equal (i-current-instruction i) '(decr_<tsp>_<tsp>{n})))
           (equal (i->m (i-decr_<tsp>_<tsp>{n}-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable alu-thm_tc-bv-decr get nat-to-v link-table-entry)))

(enable times-2)

(prove-lemma i-m-one-way-correspondence-step-add_<c>_x_x{n}
             (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-add_<c>_x_x{n}-okp i)
                (equal (i-current-instruction i)
                       '(add_<c>_x_x{n})))
           (equal (i->m (i-add_<c>_x_x{n}-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable alu-thm_tc-bv-add get nat-to-v link-table-entry)))

(prove-lemma i-m-one-way-correspondence-step-add_<tsp>_<tsp>{n}
             (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-add_<tsp>_<tsp>{n}-okp i)
                (equal (i-current-instruction i)
                       '(add_<tsp>_<tsp>{n})))
           (equal (i->m (i-add_<tsp>_<tsp>{n}-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable alu-thm_tc-bv-add get nat-to-v link-table-entry)))

(prove-lemma remainder-by-2 (rewrite)
  (implies (not (equal (remainder x 2) 0))
           (equal (remainder x 2) 1)))

(prove-lemma i-m-one-way-correspondence-step-lsr_<c>_x_x{n}
             (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-lsr_<c>_x_x{n}-okp i)
                (equal (i-current-instruction i)
                       '(lsr_<c>_x_x{n})))
           (equal (i->m (i-lsr_<c>_x_x{n}-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-m-one-way-correspondence-step-subb_<c>_x{n}_y{n} (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-subb_<c>_x{n}_y{n}-okp i)
                (equal (i-current-instruction i) '(subb_<c>_x{n}_y{n})))
           (equal (i->m (i-subb_<c>_x{n}_y{n}-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable alu-thm_tc-bv-subb get nat-to-v link-table-entry)))

; I redefined the -step fn below because it had the wrong parity on the
; c-flg!

(prove-lemma i-m-one-way-correspondence-step-sub_<c>_<tsp>{n}_x{n} (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-sub_<c>_<tsp>{n}_x{n}-okp i)
                (equal (i-current-instruction i) '(sub_<c>_<tsp>{n}_x{n})))
           (equal (i->m (i-sub_<c>_<tsp>{n}_x{n}-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable alu-thm_tc-bv-sub get nat-to-v link-table-entry)))

(prove-lemma i-m-one-way-correspondence-step-sub_<tsp>{n}_x{n} (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-sub_<tsp>{n}_x{n}-okp i)
                (equal (i-current-instruction i) '(sub_<tsp>{n}_x{n})))
           (equal (i->m (i-sub_<tsp>{n}_x{n}-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable alu-thm_tc-bv-sub get nat-to-v link-table-entry)))

; The use hint below is necessary here because we have the hypothesis
; that both the top of tsp and x are addresses into the same usr-data
; area.  The rewriter replaces references to the adp-name of the top
; of tsp with references to the adp-name of x because it is simpler.
; But that prevents the firing of our rewrite rules for establishing
; that addresses link to small-naturalps.

(prove-lemma i-m-one-way-correspondence-step-sub_<c>_<tsp>{a}_x{a} (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-sub_<c>_<tsp>{a}_x{a}-okp i)
                (equal (i-current-instruction i) '(sub_<c>_<tsp>{a}_x{a})))
           (equal (i->m (i-sub_<c>_<tsp>{a}_x{a}-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable alu-thm_tc-bv-sub get nat-to-v link-table-entry)
   (use (lessp-absolute-address-segment-length-generalized
         (name (adp-name
                (untag (get (adp-offset (untag (i-tsp i)))
                            (cdr (assoc 'tstk
                                        (i-sys-data-segment i)))))))
         (offset (adp-offset
                  (untag (get (adp-offset (untag (i-tsp i)))
                              (cdr (assoc 'tstk
                                          (i-sys-data-segment i)))))))
         (segment (i-usr-data-segment i))))))

(prove-lemma i-m-one-way-correspondence-step-sub_<tsp>{s}_x{s} (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-sub_<tsp>{s}_x{s}-okp i)
                (equal (i-current-instruction i) '(sub_<tsp>{s}_x{s})))
           (equal (i->m (i-sub_<tsp>{s}_x{s}-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable alu-thm_tc-bv-sub get nat-to-v link-table-entry)
   (use (lessp-absolute-address-segment-length-generalized
         (name (adp-name
                (untag (get (adp-offset (untag (i-tsp i)))
                            (cdr (assoc 'tstk
                                        (i-sys-data-segment i)))))))
         (offset (adp-offset
                  (untag (get (adp-offset (untag (i-tsp i)))
                              (cdr (assoc 'tstk
                                          (i-sys-data-segment i)))))))
         (segment (i-sys-data-segment i))))))


(prove-lemma v-nzerop-nat-to-v-bridge (rewrite)
  (implies (and (equal firstn (nat-to-v n word-size))
                (lessp n (exp 2 word-size)))
           (equal (v-nzerop firstn) (not (zerop n)))))

(prove-lemma equal-difference-zero (rewrite)
  (equal (equal (difference x y) 0)
         (not (lessp y x))))

(prove-lemma equal-v-to-nat-v-to-nat (rewrite)
  (implies (and (bvp a)
                (bvp b)
                (equal (length a) (length b)))
           (equal (equal (v-to-nat a) (v-to-nat b))
                  (equal a b)))
  ((enable boolp)
   (induct (v-and a b))))

(enable my-lessp-v-to-nat-exp)

(prove-lemma alu-thm_bitv-zb-sub (rewrite)
  (implies (and (bvp a)
                (bvp b)
                (equal (length a) (length b))
                (boolp c))
           (equal (zb (v-alu c a b (list t t t f)))
                  (equal a b)))
  ((disable alu-thm_nat-bv-sub alu-thm_tc-bv-sub)
   (use (alu-thm_nat-bv-sub))
   (enable bv zb v-alu)))

(prove-lemma i-m-one-way-correspondence-step-sub_<z>_x{s}_y{s}
             (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-sub_<z>_x{s}_y{s}-okp i)
                (equal (i-current-instruction i)
                       '(sub_<z>_x{s}_y{s})))
           (equal (i->m (i-sub_<z>_x{s}_y{s}-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable alu-thm_tc-bv-sub get nat-to-v link-table-entry)
   (use (lessp-absolute-address-segment-length-generalized
         (name (adp-name
                (untag (i-y i))))
         (offset (adp-offset
                  (untag (i-y i))))
         (segment (i-sys-data-segment i))))))

; To make the next thm work I changed the -okp fn to insure
; that nextword is an i-objectp.  I also changed the link instruction
; alist.

(prove-lemma i-m-one-way-correspondence-step-move-c_<tsp>_* (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-move-c_<tsp>_*-okp i)
                (equal (i-current-instruction i) '(move-c_<tsp>_*)))
           (equal (i->m (i-move-c_<tsp>_*-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-m-one-way-correspondence-step-move-v_<tsp>_* (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-move-v_<tsp>_*-okp i)
                (equal (i-current-instruction i) '(move-v_<tsp>_*)))
           (equal (i->m (i-move-v_<tsp>_*-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma v-or-append (rewrite)
  (implies (and (equal (length a) (length b))
                (bvp x)
                (bvp y))
           (equal (v-or (append a x)
                        (append b y))
                  (append (v-or a b)
                            (v-or x y)))))

(prove-lemma v-or-bitv-to-v (rewrite)
  (implies (and (bit-vectorp x word-size)
                (bit-vectorp y word-size))
           (equal (v-or (bitv-to-v x word-size)
                        (bitv-to-v y word-size))
                  (bitv-to-v (or-bitv x y) word-size))))

(prove-lemma commutativity-of-or-bitv (rewrite)
  (implies (equal (length x) (length y))
           (equal (or-bitv x y) (or-bitv y x))))

(prove-lemma i-m-one-way-correspondence-step-or_<tsp>{v}_x{v} (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-or_<tsp>{v}_x{v}-okp i)
                (equal (i-current-instruction i) '(or_<tsp>{v}_x{v})))
           (equal (i->m (i-or_<tsp>{v}_x{v}-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma v-and-append (rewrite)
  (implies (and (equal (length a) (length b))
                (bvp x)
                (bvp y))
           (equal (v-and (append a x)
                         (append b y))
                  (append (v-and a b)
                            (v-and x y)))))

(prove-lemma v-and-bitv-to-v (rewrite)
  (implies (and (bit-vectorp x word-size)
                (bit-vectorp y word-size))
           (equal (v-and (bitv-to-v x word-size)
                         (bitv-to-v y word-size))
                  (bitv-to-v (and-bitv x y) word-size))))

(prove-lemma commutativity-of-and-bitv (rewrite)
  (implies (equal (length x) (length y))
           (equal (and-bitv x y) (and-bitv y x))))

(prove-lemma i-m-one-way-correspondence-step-and_<tsp>{v}_x{v} (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-and_<tsp>{v}_x{v}-okp i)
                (equal (i-current-instruction i) '(and_<tsp>{v}_x{v})))
           (equal (i->m (i-and_<tsp>{v}_x{v}-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma v-not-append (rewrite)
  (implies (bvp x)
           (equal (v-not (append a x))
                  (append (v-not a)
                            (v-not x)))))

(prove-lemma v-not-bitv-to-v (rewrite)
  (implies (bit-vectorp x word-size)
           (equal (v-not (bitv-to-v x word-size))
                  (bitv-to-v (not-bitv x) word-size))))

(prove-lemma i-m-one-way-correspondence-step-not_<tsp>_<tsp>{v} (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-not_<tsp>_<tsp>{v}-okp i)
                (equal (i-current-instruction i) '(not_<tsp>_<tsp>{v})))
           (equal (i->m (i-not_<tsp>_<tsp>{v}-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma v-xor-bitv-to-v (rewrite)
  (implies (and (bit-vectorp x word-size)
                (bit-vectorp y word-size))
           (equal (v-xor (bitv-to-v x word-size)
                         (bitv-to-v y word-size))
                  (bitv-to-v (xor-bitv x y) word-size))))

(prove-lemma i-m-one-way-correspondence-step-xor_<tsp>{v}_x{v} (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-xor_<tsp>{v}_x{v}-okp i)
                (equal (i-current-instruction i) '(xor_<tsp>{v}_x{v})))
           (equal (i->m (i-xor_<tsp>{v}_x{v}-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma cdr-bitv-to-v (rewrite)
  (implies (and (listp x)
                (bit-vectorp x word-size))
           (equal (cdr (bitv-to-v x word-size))
                  (bitv-to-v (all-but-last x) (sub1 word-size)))))

(prove-lemma listp-append (rewrite)
  (equal (listp (append a b))
         (or (listp a) (listp b))))

(prove-lemma cdr-append (rewrite)
  (equal (cdr (append a b))
         (if (listp a) (append (cdr a) b) (cdr b))))

(prove-lemma v-buf-append (rewrite)
  (equal (v-buf (append a b)) (append (v-buf a) (v-buf b))))

(prove-lemma v-lsr-bitv-to-v (rewrite)
  (implies (bit-vectorp x word-size)
           (equal (v-lsr (bitv-to-v x word-size))
                  (bitv-to-v (rsh-bitv x) word-size)))
  ((enable v-buf-works)))

; The following two disables are motivated merely by the fact that the
; named lemmas were proved for the fm9001 effort and hence might get
; in the way.

(disable v-buf-append)
(disable cdr-append)

(prove-lemma i-m-one-way-correspondence-step-lsr_<tsp>_<tsp>{v} (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-lsr_<tsp>_<tsp>{v}-okp i)
                (equal (i-current-instruction i) '(lsr_<tsp>_<tsp>{v})))
           (equal (i->m (i-lsr_<tsp>_<tsp>{v}-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable alu-thm_nat-bv-lsr alu-thm_nat-c-lsr
            v-lsr
            get nat-to-v link-table-entry)))

(prove-lemma lsh-lemma-1 (rewrite)
  (implies (and (bit-vectorp x word-size)
                (not (zerop word-size)))
           (equal (bitv-to-v (append (cdr x) '(0)) word-size)
                  (cons f (bitv-to-v (cdr x) (sub1 word-size))))))

; Four of the next six lemmas use (plus x x y y) where (plus i i) could be
; used and then instantiated with (plus x y) and rearranged.  But
; they are, as stated, exactly what is needed and they go through
; without help.

(prove-lemma remainder-add1-xxyy-2 (rewrite)
  (equal (remainder (add1 (plus x x y y)) 2) 1))

(prove-lemma quotient-add1-xxyy-2 (rewrite)
  (equal (quotient (add1 (plus x x y y)) 2)
         (plus x y)))

(prove-lemma remainder-xx-2 (rewrite)
  (equal (remainder (plus x x) 2) 0))

(prove-lemma quotient-xx-2  (rewrite)
  (equal (quotient (plus x x) 2)
         (fix x)))

(prove-lemma remainder-xxyy-2 (rewrite)
  (equal (remainder (plus x x y y) 2) 0))

(prove-lemma quotient-xxyy-2  (rewrite)
  (equal (quotient (plus x x y y) 2)
         (plus x y)))

(prove-lemma lsh-lemma-2 (rewrite)
  (equal (nat-to-v (plus z (exp 2 word-size)) word-size)
         (nat-to-v z word-size)))

(prove-lemma lsh-lemma-3 (rewrite)
  (equal (nat-to-v (plus z (exp 2 word-size) u) word-size)
         (nat-to-v (plus z u) word-size))
  ((use (lsh-lemma-2 (z (plus z u)))
        (commutativity-of-plus (x (exp 2 word-size)) (y u)))))

(prove-lemma lsh-lemma-4 (rewrite)
  (equal (nat-to-v (plus z (times (exp 2 word-size) v)) word-size)
         (nat-to-v z word-size))
  ((induct (times v xxx))))

(disable times-commutes)

(prove-lemma lsh-lemma-5 (rewrite)
  (implies (numberp x)
           (equal (nat-to-v (remainder x (exp 2 word-size)) word-size)
                  (nat-to-v x word-size))))

(prove-lemma lsh-lemma-6 (rewrite)
  (implies (not (zerop word-size))
           (equal (nat-to-v (plus x x) word-size)
                  (cons f (nat-to-v x (sub1 word-size))))))

(prove-lemma remainder-add1-xx-2 (rewrite)
  (equal (remainder (add1 (plus x x)) 2) 1))

(prove-lemma quotient-add1-xx-2 (rewrite)
  (equal (quotient (add1 (plus x x)) 2) (fix x)))

(prove-lemma lsh-lemma-7 (rewrite)
  (implies (and (bvp x)
                (equal k (length x)))
           (equal (nat-to-v (v-to-nat (append x y)) k)
                  x))
  ((enable boolp)))

(enable bvp-append)

(prove-lemma i-m-one-way-correspondence-step-add_<tsp>_<tsp>{v} (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-add_<tsp>_<tsp>{v}-okp i)
                (equal (i-current-instruction i) '(add_<tsp>_<tsp>{v})))
           (equal (i->m (i-add_<tsp>_<tsp>{v}-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable alu-thm_tc-bv-add remainder-opener get nat-to-v link-table-entry)))

(prove-lemma i-m-one-way-correspondence-step-or_<tsp>{b}_x{b} (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-or_<tsp>{b}_x{b}-okp i)
                (equal (i-current-instruction i) '(or_<tsp>{b}_x{b})))
           (equal (i->m (i-or_<tsp>{b}_x{b}-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-m-one-way-correspondence-step-and_<tsp>{b}_x{b} (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-and_<tsp>{b}_x{b}-okp i)
                (equal (i-current-instruction i) '(and_<tsp>{b}_x{b})))
           (equal (i->m (i-and_<tsp>{b}_x{b}-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-m-one-way-correspondence-step-xor_<tsp>{b}_*{b} (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-xor_<tsp>{b}_*{b}-okp i)
                (equal (i-current-instruction i) '(xor_<tsp>{b}_*{b})))
           (equal (i->m (i-xor_<tsp>{b}_*{b}-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-m-one-way-correspondence-step-xor_<tsp>{b}_x{b} (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-xor_<tsp>{b}_x{b}-okp i)
                (equal (i-current-instruction i) '(xor_<tsp>{b}_x{b})))
           (equal (i->m (i-xor_<tsp>{b}_x{b}-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable get nat-to-v link-table-entry)))

; The following lemma is just enough arithmetic to get the add_pc_x{n}
; lemma.  As noted before, I've adopted the strategy of not automatically
; rewriting arithmetic expressions.  I could perhaps get the proof with
; associativity and commutativity available, but I don't want to even
; bother trying.

(prove-lemma commutativity-of-plus-hack (rewrite)
  (equal (plus load-addr
               (segment-length (i-usr-data-segment i))
               (link-table-entry (adp-name (untag (i-pc i)))
                                 (i-prog-segment i))
               (adp-offset (untag (i-pc i)))
               (untag (i-x i)))
         (plus (untag (i-x i))
               load-addr
               (segment-length (i-usr-data-segment i))
               (link-table-entry (adp-name (untag (i-pc i)))
                                 (i-prog-segment i))
               (adp-offset (untag (i-pc i))))))

(disable equal-length-0)
(disable remainder-opener)

(prove-lemma i-m-one-way-correspondence-step-add_pc_x{n} (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-add_pc_x{n}-okp i)
                (equal (i-current-instruction i) '(add_pc_x{n})))
           (equal (i->m (i-add_pc_x{n}-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable alu-thm_tc-bv-add get nat-to-v link-table-entry)))

(prove-lemma i-m-one-way-correspondence-step-add_x_x{n} (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-add_x_x{n}-okp i)
                (equal (i-current-instruction i) '(add_x_x{n})))
           (equal (i->m (i-add_x_x{n}-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable alu-thm_tc-bv-add get nat-to-v link-table-entry)))

(enable associativity-of-iplus)

(enable commutativity2-of-iplus)

(prove-lemma i-m-one-way-correspondence-step-addc_<v>_x{i}_y{i} (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-addc_<v>_x{i}_y{i}-okp i)
                (equal (i-current-instruction i) '(addc_<v>_x{i}_y{i})))
           (equal (i->m (i-addc_<v>_x{i}_y{i}-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable alu-thm_nat-bv-addc alu-thm_nat-c-addc
            int-to-v v-to-int
            small-integerp
            integerp
            iplus
            get nat-to-v link-table-entry)))

(prove-lemma tc-minus-is-inegate (rewrite)
  (equal (tc-minus x) (inegate x)))

(disable tc-minus)

(prove-lemma integerp-inegate (rewrite)
  (integerp (inegate x)))

(prove-lemma ineg-is-inegate (rewrite)
  (equal (ineg x) (inegate x)))

(disable ineg)

(prove-lemma i-m-one-way-correspondence-step-subb_<v>_x{i}_y{i} (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-subb_<v>_x{i}_y{i}-okp i)
                (equal (i-current-instruction i) '(subb_<v>_x{i}_y{i})))
           (equal (i->m (i-subb_<v>_x{i}_y{i}-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
    ((disable alu-thm_nat-bv-subb alu-thm_nat-c-subb
            int-to-v v-to-int
            small-integerp
            integerp
            iplus
            inegate
            get nat-to-v link-table-entry)))

; To relieve one of the hypotheses above we need the following lemma.
; Intuitively it says that (inegate x) is a small-integerp if x is.
; That's not true, because x might be the most negative integer, which
; has no small opposite.  But in the case in question we know that
; (inegate x) + y is negative, so things work out to tell us that  x isn't
; the most negative.

(prove-lemma small-integerp-inegate (rewrite)
  (implies (and (not (zerop word-size))
                (small-integerp x word-size)
                (negativep (iplus (inegate x) y))
                (small-integerp y word-size))
           (small-integerp (inegate x) word-size)))

(prove-lemma small-integerp-fix-small-integer-case-1 (rewrite)
  (implies (and (small-integerp x word-size)
                (small-integerp y word-size)
                (not (zerop word-size))
                (not (small-integerp (iplus (inegate x) y) word-size))
                (negativep (iplus (inegate x) y)))
           (small-integerp (iplus (exp 2 word-size) (iplus (inegate x) y))
                           word-size)))

(prove-lemma small-integerp-fix-small-integer-case-2 (rewrite)
  (implies (and (small-integerp x word-size)
                (small-integerp y word-size)
                (not (zerop word-size))
                (not (small-integerp (iplus (inegate x) y) word-size))
                (not (negativep (iplus (inegate x) y))))
           (small-integerp (iplus (minus (exp 2 word-size))
                                  (iplus (inegate x) y))
                           word-size)))

(prove-lemma i-m-one-way-correspondence-step-sub_<nv>_<tsp>{i}_x{i} (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-sub_<nv>_<tsp>{i}_x{i}-okp i)
                (equal (i-current-instruction i) '(sub_<nv>_<tsp>{i}_x{i})))
           (equal (i->m (i-sub_<nv>_<tsp>{i}_x{i}-step i) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
    ((enable n)
     (disable alu-thm_nat-bv-subb alu-thm_nat-c-subb
            int-to-v v-to-int
            small-integerp
            integerp
            iplus
            inegate
            get nat-to-v link-table-entry)))

(prove-lemma i-current-instruction-packer-lemma nil
  (implies (and (equal (car ins) (pack opcode))
                (equal (cdr ins) nil))
           (equal ins
                  (list (pack opcode)))))

(prove-lemma i-current-instruction-packer (rewrite)
  (implies (and (equal (car (i-current-instruction i)) (pack opcode))
                (equal (cdr (i-current-instruction i)) nil))
           (equal (i-current-instruction i)
                  (list (pack opcode))))
  ((use (i-current-instruction-packer-lemma
         (ins (i-current-instruction i))))))

(prove-lemma i-m-one-way-correspondence-ins-okp-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-ins-okp (i-current-instruction i) i))
           (equal (i->m (i-ins-step (i-current-instruction i) i load-addr) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
  ((disable
    i-state-okp i-state-okp-restructuring
    i-current-instruction
    i->m
    m-step
    i-add_<c>_x_x{n}-okp
    i-add_<c>_x_x{n}-step
    i-add_<tsp>_<tsp>{v}-okp
    i-add_<tsp>_<tsp>{v}-step
    i-add_<tsp>_<tsp>{n}-okp
    i-add_<tsp>_<tsp>{n}-step
    i-add_<tsp>{a}_x{n}-okp
    i-add_<tsp>{a}_x{n}-step
    i-add_tsp_*{n}-okp
    i-add_tsp_*{n}-step
    i-add_tsp_x{n}-okp
    i-add_tsp_x{n}-step
    i-add_<tsp>{i}_x{i}-okp
    i-add_<tsp>{i}_x{i}-step
    i-add_<tsp>{n}_x{n}-okp
    i-add_<tsp>{n}_x{n}-step
    i-add_pc_x{n}-okp
    i-add_pc_x{n}-step
    i-add_x_x{n}-okp
    i-add_x_x{n}-step
    i-add_x{n}_csp-okp
    i-add_x{n}_csp-step
    i-addc_<c>_x{n}_y{n}-okp
    i-addc_<c>_x{n}_y{n}-step
    i-addc_<v>_x{i}_y{i}-okp
    i-addc_<v>_x{i}_y{i}-step
    i-and_<tsp>{v}_x{v}-okp
    i-and_<tsp>{v}_x{v}-step
    i-and_<tsp>{b}_x{b}-okp
    i-and_<tsp>{b}_x{b}-step
    i-asr_<c>_<tsp>_<tsp>{b}-okp
    i-asr_<c>_<tsp>_<tsp>{b}-step
    i-cpop_cfp-okp
    i-cpop_cfp-step
    i-cpop_pc-okp
    i-cpop_pc-step
    i-cpush_*-okp
    i-cpush_*-step
    i-cpush_<tsp>+-okp
    i-cpush_<tsp>+-step
    i-cpush_cfp-okp
    i-cpush_cfp-step
    i-decr_<tsp>_<tsp>{i}-okp
    i-decr_<tsp>_<tsp>{i}-step
    i-decr_<tsp>_<tsp>{n}-okp
    i-decr_<tsp>_<tsp>{n}-step
    i-incr_<tsp>_<tsp>{i}-okp
    i-incr_<tsp>_<tsp>{i}-step
    i-incr_<tsp>_<tsp>{n}-okp
    i-incr_<tsp>_<tsp>{n}-step
    i-incr_y_y{n}-okp
    i-incr_y_y{n}-step
    i-int-to-nat-okp
    i-int-to-nat-step
    i-jump-n_x-okp
    i-jump-n_x-step
    i-jump-nn_x-okp
    i-jump-nn_x-step
    i-jump-nz_x-okp
    i-jump-nz_x-step
    i-jump-z_x-okp
    i-jump-z_x-step
    i-jump_*-okp
    i-jump_*-step
    i-jump_x{subr}-okp
    i-jump_x{subr}-step
    i-lsr_<c>_x_x{n}-okp
    i-lsr_<c>_x_x{n}-step
    i-lsr_<tsp>_<tsp>{v}-okp
    i-lsr_<tsp>_<tsp>{v}-step
    i-move-c_<tsp>_*-okp
    i-move-c_<tsp>_*-step
    i-move-v_<tsp>_*-okp
    i-move-v_<tsp>_*-step
    i-move-z_<tsp>_*-okp
    i-move-z_<tsp>_*-step
    i-move-n_x_*-okp
    i-move-n_x_*-step
    i-move_<tsp>_*-okp
    i-move_<tsp>_*-step
    i-move_<x{a}>_<tsp>-okp
    i-move_<x{a}>_<tsp>-step
    i-move_<x{s}>_<tsp>-okp
    i-move_<x{s}>_<tsp>-step
    i-move_cfp_csp-okp
    i-move_cfp_csp-step
    i-move_csp_cfp-okp
    i-move_csp_cfp-step
    i-move_x_*-okp
    i-move_x_*-step
    i-move_x_<x{s}>-okp
    i-move_x_<x{s}>-step
    i-move_x_tsp-okp
    i-move_x_tsp-step
    i-move_x_x-okp
    i-move_x_x-step
    i-move_y_*-okp
    i-move_y_*-step
    i-move_y_<y{s}>-okp
    i-move_y_<y{s}>-step
    i-move_y_tsp-okp
    i-move_y_tsp-step
    i-neg_<tsp>_<tsp>{i}-okp
    i-neg_<tsp>_<tsp>{i}-step
    i-not_<tsp>_<tsp>{v}-okp
    i-not_<tsp>_<tsp>{v}-step
    i-or_<tsp>{v}_x{v}-okp
    i-or_<tsp>{v}_x{v}-step
    i-or_<tsp>{b}_x{b}-okp
    i-or_<tsp>{b}_x{b}-step
    i-sub_<c>_<tsp>{a}_x{a}-okp
    i-sub_<c>_<tsp>{a}_x{a}-step
    i-sub_<c>_<tsp>{n}_x{n}-okp
    i-sub_<c>_<tsp>{n}_x{n}-step
    i-sub_<nv>_<tsp>{i}_x{i}-okp
    i-sub_<nv>_<tsp>{i}_x{i}-step
    i-sub_<tsp>{a}_x{n}-okp
    i-sub_<tsp>{a}_x{n}-step
    i-sub_x{s}_y{n}-okp
    i-sub_x{s}_y{n}-step
    i-sub_<tsp>{i}_x{i}-okp
    i-sub_<tsp>{i}_x{i}-step
    i-sub_<tsp>{n}_x{n}-okp
    i-sub_<tsp>{n}_x{n}-step
    i-sub_<tsp>{s}_x{s}-okp
    i-sub_<tsp>{s}_x{s}-step
    i-sub_<z>_x{s}_y{s}-okp
    i-sub_<z>_x{s}_y{s}-step
    i-subb_<c>_x{n}_y{n}-okp
    i-subb_<c>_x{n}_y{n}-step
    i-subb_<v>_x{i}_y{i}-okp
    i-subb_<v>_x{i}_y{i}-step
    i-tpop_<c>_x-okp
    i-tpop_<c>_x-step
    i-tpop_<x{a}>-okp
    i-tpop_<x{a}>-step
    i-tpop_<x{s}>-okp
    i-tpop_<x{s}>-step
    i-tpop_pc-okp
    i-tpop_pc-step
    i-tpop_x-okp
    i-tpop_x-step
    i-tpop_y-okp
    i-tpop_y-step
    i-tpop{v}_<z>_y-okp
    i-tpop{v}_<z>_y-step
    i-tpop{b}_<z>_y-okp
    i-tpop{b}_<z>_y-step
    i-tpop{i}_<zn>_y-okp
    i-tpop{i}_<zn>_y-step
    i-tpop{n}_<z>_y-okp
    i-tpop{n}_<z>_y-step
    i-tpush_*-okp
    i-tpush_*-step
    i-tpush_<x{a}>-okp
    i-tpush_<x{a}>-step
    i-tpush_<x{s}>-okp
    i-tpush_<x{s}>-step
    i-tpush_csp-okp
    i-tpush_csp-step
    i-tpush_tsp-okp
    i-tpush_tsp-step
    i-tpush_x-okp
    i-tpush_x-step
    i-xor_<tsp>_<tsp>-okp
    i-xor_<tsp>_<tsp>-step
    i-xor_<tsp>{v}_x{v}-okp
    i-xor_<tsp>{v}_x{v}-step
    i-xor_<tsp>{b}_*{b}-okp
    i-xor_<tsp>{b}_*{b}-step
    i-xor_<tsp>{b}_x{b}-okp
    i-xor_<tsp>{b}_x{b}-step
    i-xor_<z>_<tsp>_x-okp
    i-xor_<z>_<tsp>_x-step
    )))

(prove-lemma i-m-one-way-correspondence-step (rewrite)
  (implies (and (numberp load-addr)
                (equal (i-psw (i-step i load-addr)) 'run)
                (equal (i-word-size i) 32))
           (equal (i->m (i-step i load-addr) boot-lst load-addr)
                  (m-step (i->m i boot-lst load-addr))))
 ((disable i-state-okp i-state-okp-restructuring
           i-current-instruction
           i-ins-okp
           i-ins-step)))

(prove-lemma i-word-size-i-halt (rewrite)
  (equal (i-word-size (i-halt i psw)) (i-word-size i))
  ((enable i-halt)))

; The following two lemmas and then i-word-size-i-ins-step follow exactly
; the same strategy described above for i-psw-i-ins-step.

(prove-lemma equal-i-word-size-if-1 (rewrite)
  (equal (equal (i-word-size (if t1 b1 b2)) w)
         (if t1
             (equal (i-word-size b1) w)
             (equal (i-word-size b2) w))))

(prove-lemma equal-i-word-size-if-2 (rewrite)
  (equal (equal (i-word-size (if t1 b1 (if t2 b2 b3))) w)
         (if t1
             (equal (i-word-size b1) w)
             (if t2
                 (equal (i-word-size b2) w)
                 (equal (i-word-size b3) w)))))

(prove-lemma i-word-size-i-ins-step (rewrite)
  (equal (i-word-size (i-ins-step ins i load-addr)) (i-word-size i))
  ((hands-off
    lsh-bitv times add-addr small-naturalp fix-small-natural and-bitv
    and-bool sub1 remainder quotient rsh-bitv inegate not-bitv or-bitv
    or-bool sub-addr offset exp difference plus lessp small-integerp
    not bool-to-nat iplus idifference fix-small-integer area-name
    definition ipc negativep pop-stk push-stk xor-bitv i-nextword untag
    xor-bool i-z-flg add2-i-pc tag deposit i-psw
    i-usr-data-segment i-prog-segment i-sys-data-segment fetch xor-xxx
    all-zero-bitvp bool i-n-flg i-v-flg i-c-flg i-y i-x i-tsp i-csp
    i-cfp add1-i-pc i-state pack cons add1 zero)))

; The hint above is mechanically generated as in i-psw case mentioned
; above, except that it does not include i-word-size.

(prove-lemma i-word-size-i-step (rewrite)
  (equal (i-word-size (i-step i load-addr)) (i-word-size i))
  ((disable i-state-okp i-state-okp-restructuring
            i-current-instruction
            i-ins-okp
            i-ins-step)))

(prove-lemma i-psw-i-run (rewrite)
  (implies (equal (i-psw (i i n load-addr)) 'run)
           (equal (i-psw i) 'run))
  ((disable i-step)))

(prove-lemma i-m-one-way-correspondence (rewrite)
  (implies (and (numberp load-addr)
                (equal (i-psw (i i n load-addr)) 'run)
                (equal (i-word-size i) 32))
           (equal (i->m (i i n load-addr) boot-lst load-addr)
                  (m (i->m i boot-lst load-addr) n)))
  ((induct (i i n load-addr))
   (disable i-step m-step i->m i-state-okp i-state-okp-restructuring
            i-ins-okp i-ins-step)))

;  We now prove that i-state-okp is preserved by i-step.  We do
;  it in a very predictable way:  we prove it for each stepper.
;  First a few lemmas...

(prove-lemma assoc-put-assoc (rewrite)
  (implies (definedp name2 alist)
           (equal (assoc name1
                         (put-assoc val name2 alist))
                  (if (equal name1 name2)
                      (cons name1 val)
                      (assoc name1 alist))))
  nil)

(prove-lemma cddr-tag (rewrite)
  (equal (cddr (tag type obj))
         nil)
  ((enable tag)))

;  Now comes the litany of instructions.

;  After the first two, the hints for all of these preservation lemmas
;  are derived mechanically from the hint for the corresponding
;  one-way-correspondence lemma above by simply adding to the old hint
;  the disabling of the restructuring lemma and the enabling of
;  i-state-okp.

(prove-lemma i-state-okp-i-move_x_x-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-move_x_x-okp i))
           (i-state-okp (i-move_x_x-step i) load-addr))
  ((disable i-state-okp-restructuring)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-cpush_*-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-cpush_*-okp i))
           (i-state-okp (i-cpush_*-step i) load-addr))
  ((disable i-state-okp-restructuring)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-add_<tsp>{i}_x{i}-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-add_<tsp>{i}_x{i}-okp i))
           (i-state-okp (i-add_<tsp>{i}_x{i}-step i) load-addr))
  ((disable i-state-okp-restructuring alu-thm_nat-bv-add
            alu-thm_nat-c-add int-to-v v-to-int small-integerp
            integerp iplus get nat-to-v link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-move_cfp_csp-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-move_cfp_csp-okp i))
           (i-state-okp (i-move_cfp_csp-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-cpush_<tsp>+-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-cpush_<tsp>+-okp i))
           (i-state-okp (i-cpush_<tsp>+-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-move_csp_cfp-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-move_csp_cfp-okp i))
           (i-state-okp (i-move_csp_cfp-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-move_x_tsp-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-move_x_tsp-okp i))
           (i-state-okp (i-move_x_tsp-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-cpop_cfp-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-cpop_cfp-okp i))
           (i-state-okp (i-cpop_cfp-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-move_x_*-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-move_x_*-okp i))
           (i-state-okp (i-move_x_*-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-move_y_*-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-move_y_*-okp i))
           (i-state-okp (i-move_y_*-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-add_x{n}_csp-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-add_x{n}_csp-okp i))
           (i-state-okp (i-add_x{n}_csp-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-move_x_<x{s}>-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-move_x_<x{s}>-okp i))
           (i-state-okp (i-move_x_<x{s}>-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-move_y_<y{s}>-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-move_y_<y{s}>-okp i))
           (i-state-okp (i-move_y_<y{s}>-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-move_y_tsp-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-move_y_tsp-okp i))
           (i-state-okp (i-move_y_tsp-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-tpush_csp-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-tpush_csp-okp i))
           (i-state-okp (i-tpush_csp-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-tpush_tsp-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-tpush_tsp-okp i))
           (i-state-okp (i-tpush_tsp-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-tpush_x-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-tpush_x-okp i))
           (i-state-okp (i-tpush_x-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-tpush_<x{s}>-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-tpush_<x{s}>-okp i))
           (i-state-okp (i-tpush_<x{s}>-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-tpush_<x{a}>-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-tpush_<x{a}>-okp i))
           (i-state-okp (i-tpush_<x{a}>-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-tpush_*-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-tpush_*-okp i))
           (i-state-okp (i-tpush_*-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-tpop_x-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-tpop_x-okp i))
           (i-state-okp (i-tpop_x-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-tpop_y-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-tpop_y-okp i))
           (i-state-okp (i-tpop_y-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-tpop_<x{s}>-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-tpop_<x{s}>-okp i))
           (i-state-okp (i-tpop_<x{s}>-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-tpop_<x{a}>-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-tpop_<x{a}>-okp i))
           (i-state-okp (i-tpop_<x{a}>-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-jump_*-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-jump_*-okp i))
           (i-state-okp (i-jump_*-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-cpop_pc-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-cpop_pc-okp i))
           (i-state-okp (i-cpop_pc-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-move_<x{s}>_<tsp>-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-move_<x{s}>_<tsp>-okp i))
           (i-state-okp (i-move_<x{s}>_<tsp>-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-move_<x{a}>_<tsp>-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-move_<x{a}>_<tsp>-okp i))
           (i-state-okp (i-move_<x{a}>_<tsp>-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-jump_x{subr}-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-jump_x{subr}-okp i))
           (i-state-okp (i-jump_x{subr}-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-jump-n_x-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-jump-n_x-okp i))
           (i-state-okp (i-jump-n_x-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-jump-nn_x-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-jump-nn_x-okp i))
           (i-state-okp (i-jump-nn_x-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-jump-z_x-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-jump-z_x-okp i))
           (i-state-okp (i-jump-z_x-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-jump-nz_x-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-jump-nz_x-okp i))
           (i-state-okp (i-jump-nz_x-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-tpop_pc-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-tpop_pc-okp i))
           (i-state-okp (i-tpop_pc-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-tpop_<c>_x-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-tpop_<c>_x-okp i))
           (i-state-okp (i-tpop_<c>_x-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-tpop{n}_<z>_y-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-tpop{n}_<z>_y-okp i))
           (i-state-okp (i-tpop{n}_<z>_y-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-tpop{i}_<zn>_y-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-tpop{i}_<zn>_y-okp i))
           (i-state-okp (i-tpop{i}_<zn>_y-step i) load-addr))
  ((disable i-state-okp-restructuring int-to-v v-to-int
            small-integerp integerp get nat-to-v link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-tpop{b}_<z>_y-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-tpop{b}_<z>_y-okp i))
           (i-state-okp (i-tpop{b}_<z>_y-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-tpop{v}_<z>_y-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-tpop{v}_<z>_y-okp i))
           (i-state-okp (i-tpop{v}_<z>_y-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-add_<tsp>{a}_x{n}-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-add_<tsp>{a}_x{n}-okp i))
           (i-state-okp (i-add_<tsp>{a}_x{n}-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-add_tsp_*{n}-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-add_tsp_*{n}-okp i))
           (i-state-okp (i-add_tsp_*{n}-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-add_tsp_x{n}-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-add_tsp_x{n}-okp i))
           (i-state-okp (i-add_tsp_x{n}-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-sub_<tsp>{a}_x{n}-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-sub_<tsp>{a}_x{n}-okp i))
           (i-state-okp (i-sub_<tsp>{a}_x{n}-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-sub_x{s}_y{n}-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-sub_x{s}_y{n}-okp i))
           (i-state-okp (i-sub_x{s}_y{n}-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-xor_<tsp>_<tsp>-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-xor_<tsp>_<tsp>-okp i))
           (i-state-okp (i-xor_<tsp>_<tsp>-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-move-z_<tsp>_*-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-move-z_<tsp>_*-okp i))
           (i-state-okp (i-move-z_<tsp>_*-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-move-n_x_*-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-move-n_x_*-okp i))
           (i-state-okp (i-move-n_x_*-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-move_<tsp>_*-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-move_<tsp>_*-okp i))
           (i-state-okp (i-move_<tsp>_*-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-incr_<tsp>_<tsp>{i}-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-incr_<tsp>_<tsp>{i}-okp i))
           (i-state-okp (i-incr_<tsp>_<tsp>{i}-step i) load-addr))
  ((disable i-state-okp-restructuring alu-thm_nat-bv-incr
            alu-thm_nat-c-incr int-to-v v-to-int small-integerp
            integerp iplus get nat-to-v link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-xor_<z>_<tsp>_x-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-xor_<z>_<tsp>_x-okp i))
           (i-state-okp (i-xor_<z>_<tsp>_x-step i load-addr) load-addr))
  ((disable i-state-okp-restructuring xor-xxx get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-sub_<tsp>{i}_x{i}-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-sub_<tsp>{i}_x{i}-okp i))
           (i-state-okp (i-sub_<tsp>{i}_x{i}-step i) load-addr))
  ((disable i-state-okp-restructuring alu-thm_nat-bv-sub
            alu-thm_nat-c-sub int-to-v v-to-int small-integerp
            integerp iplus get nat-to-v link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-decr_<tsp>_<tsp>{i}-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-decr_<tsp>_<tsp>{i}-okp i))
           (i-state-okp (i-decr_<tsp>_<tsp>{i}-step i) load-addr))
  ((disable i-state-okp-restructuring alu-thm_nat-bv-decr
            alu-thm_nat-c-decr int-to-v v-to-int small-integerp
            integerp iplus get nat-to-v link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-neg_<tsp>_<tsp>{i}-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-neg_<tsp>_<tsp>{i}-okp i))
           (i-state-okp (i-neg_<tsp>_<tsp>{i}-step i) load-addr))
  ((disable i-state-okp-restructuring int-to-v v-to-int
            small-integerp integerp iplus get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-asr_<c>_<tsp>_<tsp>{b}-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-asr_<c>_<tsp>_<tsp>{b}-okp i))
           (i-state-okp (i-asr_<c>_<tsp>_<tsp>{b}-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-addc_<c>_x{n}_y{n}-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-addc_<c>_x{n}_y{n}-okp i))
           (i-state-okp (i-addc_<c>_x{n}_y{n}-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-add_<tsp>{n}_x{n}-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-add_<tsp>{n}_x{n}-okp i))
           (i-state-okp (i-add_<tsp>{n}_x{n}-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-incr_<tsp>_<tsp>{n}-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-incr_<tsp>_<tsp>{n}-okp i))
           (i-state-okp (i-incr_<tsp>_<tsp>{n}-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-incr_y_y{n}-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-incr_y_y{n}-okp i))
           (i-state-okp (i-incr_y_y{n}-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-int-to-nat-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-int-to-nat-okp i))
           (i-state-okp (i-int-to-nat-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-decr_<tsp>_<tsp>{n}-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-decr_<tsp>_<tsp>{n}-okp i))
           (i-state-okp (i-decr_<tsp>_<tsp>{n}-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-add_<c>_x_x{n}-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-add_<c>_x_x{n}-okp i))
           (i-state-okp (i-add_<c>_x_x{n}-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-add_<tsp>_<tsp>{n}-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-add_<tsp>_<tsp>{n}-okp i))
           (i-state-okp (i-add_<tsp>_<tsp>{n}-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-lsr_<c>_x_x{n}-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-lsr_<c>_x_x{n}-okp i))
           (i-state-okp (i-lsr_<c>_x_x{n}-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-subb_<c>_x{n}_y{n}-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-subb_<c>_x{n}_y{n}-okp i))
           (i-state-okp (i-subb_<c>_x{n}_y{n}-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-sub_<c>_<tsp>{n}_x{n}-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-sub_<c>_<tsp>{n}_x{n}-okp i))
           (i-state-okp (i-sub_<c>_<tsp>{n}_x{n}-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

; I got to here, but ran out of CONS space and can't save my lib.


(prove-lemma i-state-okp-i-sub_<nv>_<tsp>{i}_x{i}-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-sub_<nv>_<tsp>{i}_x{i}-okp i))
           (i-state-okp (i-sub_<nv>_<tsp>{i}_x{i}-step i) load-addr))
  ((disable alu-thm_nat-bv-subb alu-thm_nat-c-subb
            int-to-v v-to-int
            small-integerp
            integerp
            iplus
            inegate
            i-state-okp-restructuring
            get nat-to-v link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-sub_<tsp>{n}_x{n}-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-sub_<tsp>{n}_x{n}-okp i))
           (i-state-okp (i-sub_<tsp>{n}_x{n}-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-sub_<c>_<tsp>{a}_x{a}-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-sub_<c>_<tsp>{a}_x{a}-okp i))
           (i-state-okp (i-sub_<c>_<tsp>{a}_x{a}-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v link-table-entry)
   (use
    (lessp-absolute-address-segment-length-generalized
     (name (adp-name (untag (get (adp-offset (untag (i-tsp i)))
                                 (cdr (assoc 'tstk
                                             (i-sys-data-segment i)))))))
     (offset (adp-offset (untag (get (adp-offset (untag (i-tsp i)))
                                     (cdr (assoc 'tstk
                                                 (i-sys-data-segment i)))))))
     (segment (i-usr-data-segment i))))
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-sub_<tsp>{s}_x{s}-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-sub_<tsp>{s}_x{s}-okp i))
           (i-state-okp (i-sub_<tsp>{s}_x{s}-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v link-table-entry)
   (use
    (lessp-absolute-address-segment-length-generalized
     (name (adp-name (untag (get (adp-offset (untag (i-tsp i)))
                                 (cdr (assoc 'tstk
                                             (i-sys-data-segment i)))))))
     (offset (adp-offset (untag (get (adp-offset (untag (i-tsp i)))
                                     (cdr (assoc 'tstk
                                                 (i-sys-data-segment i)))))))
     (segment (i-sys-data-segment i))))
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-move-c_<tsp>_*-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-move-c_<tsp>_*-okp i))
           (i-state-okp (i-move-c_<tsp>_*-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-move-v_<tsp>_*-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-move-v_<tsp>_*-okp i))
           (i-state-okp (i-move-v_<tsp>_*-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-or_<tsp>{v}_x{v}-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-or_<tsp>{v}_x{v}-okp i))
           (i-state-okp (i-or_<tsp>{v}_x{v}-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-and_<tsp>{v}_x{v}-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-and_<tsp>{v}_x{v}-okp i))
           (i-state-okp (i-and_<tsp>{v}_x{v}-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-not_<tsp>_<tsp>{v}-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-not_<tsp>_<tsp>{v}-okp i))
           (i-state-okp (i-not_<tsp>_<tsp>{v}-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-xor_<tsp>{v}_x{v}-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-xor_<tsp>{v}_x{v}-okp i))
           (i-state-okp (i-xor_<tsp>{v}_x{v}-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-lsr_<tsp>_<tsp>{v}-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-lsr_<tsp>_<tsp>{v}-okp i))
           (i-state-okp (i-lsr_<tsp>_<tsp>{v}-step i) load-addr))
  ((disable i-state-okp-restructuring alu-thm_nat-bv-lsr
            alu-thm_nat-c-lsr v-lsr get nat-to-v link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-add_<tsp>_<tsp>{v}-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-add_<tsp>_<tsp>{v}-okp i))
           (i-state-okp (i-add_<tsp>_<tsp>{v}-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-or_<tsp>{b}_x{b}-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-or_<tsp>{b}_x{b}-okp i))
           (i-state-okp (i-or_<tsp>{b}_x{b}-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-and_<tsp>{b}_x{b}-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-and_<tsp>{b}_x{b}-okp i))
           (i-state-okp (i-and_<tsp>{b}_x{b}-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-xor_<tsp>{b}_*{b}-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-xor_<tsp>{b}_*{b}-okp i))
           (i-state-okp (i-xor_<tsp>{b}_*{b}-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-xor_<tsp>{b}_x{b}-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-xor_<tsp>{b}_x{b}-okp i))
           (i-state-okp (i-xor_<tsp>{b}_x{b}-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-add_pc_x{n}-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-add_pc_x{n}-okp i))
           (i-state-okp (i-add_pc_x{n}-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-add_x_x{n}-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-add_x_x{n}-okp i))
           (i-state-okp (i-add_x_x{n}-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-addc_<v>_x{i}_y{i}-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-addc_<v>_x{i}_y{i}-okp i))
           (i-state-okp (i-addc_<v>_x{i}_y{i}-step i) load-addr))
  ((disable i-state-okp-restructuring alu-thm_nat-bv-addc
            alu-thm_nat-c-addc int-to-v v-to-int small-integerp
            integerp iplus get nat-to-v link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-subb_<v>_x{i}_y{i}-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-subb_<v>_x{i}_y{i}-okp i))
           (i-state-okp (i-subb_<v>_x{i}_y{i}-step i) load-addr))
  ((disable i-state-okp-restructuring alu-thm_nat-bv-subb
            alu-thm_nat-c-subb int-to-v v-to-int small-integerp
            integerp iplus inegate get nat-to-v link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-cpush_cfp-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-cpush_cfp-okp i))
           (i-state-okp (i-cpush_cfp-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v
            link-table-entry)
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-sub_<z>_x{s}_y{s}-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-sub_<z>_x{s}_y{s}-okp i))
           (i-state-okp (i-sub_<z>_x{s}_y{s}-step i) load-addr))
  ((disable i-state-okp-restructuring get nat-to-v link-table-entry)
   (use
    (lessp-absolute-address-segment-length-generalized
     (name (adp-name (untag (i-y i))))
     (offset (adp-offset (untag (i-y i))))
     (segment (i-sys-data-segment i))))
   (enable i-state-okp)))

(prove-lemma i-state-okp-i-ins-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (i-ins-okp ins i))
           (i-state-okp (i-ins-step ins i load-addr) load-addr))
  ((disable i-state-okp i-state-okp-restructuring
            i-add_<c>_x_x{n}-okp i-add_<c>_x_x{n}-step
            i-add_<tsp>_<tsp>{v}-okp i-add_<tsp>_<tsp>{v}-step
            i-add_<tsp>_<tsp>{n}-okp i-add_<tsp>_<tsp>{n}-step
            i-add_<tsp>{a}_x{n}-okp i-add_<tsp>{a}_x{n}-step
            i-add_tsp_*{n}-okp i-add_tsp_*{n}-step
            i-add_tsp_x{n}-okp i-add_tsp_x{n}-step
            i-add_<tsp>{i}_x{i}-okp i-add_<tsp>{i}_x{i}-step
            i-add_<tsp>{n}_x{n}-okp i-add_<tsp>{n}_x{n}-step
            i-add_pc_x{n}-okp i-add_pc_x{n}-step
            i-add_x_x{n}-okp i-add_x_x{n}-step
            i-add_x{n}_csp-okp i-add_x{n}_csp-step
            i-addc_<c>_x{n}_y{n}-okp i-addc_<c>_x{n}_y{n}-step
            i-addc_<v>_x{i}_y{i}-okp i-addc_<v>_x{i}_y{i}-step
            i-and_<tsp>{v}_x{v}-okp i-and_<tsp>{v}_x{v}-step
            i-and_<tsp>{b}_x{b}-okp i-and_<tsp>{b}_x{b}-step
            i-asr_<c>_<tsp>_<tsp>{b}-okp
            i-asr_<c>_<tsp>_<tsp>{b}-step i-cpop_cfp-okp
            i-cpop_cfp-step i-cpop_pc-okp i-cpop_pc-step
            i-cpush_*-okp i-cpush_*-step i-cpush_<tsp>+-okp
            i-cpush_<tsp>+-step i-cpush_cfp-okp i-cpush_cfp-step
            i-decr_<tsp>_<tsp>{i}-okp i-decr_<tsp>_<tsp>{i}-step
            i-decr_<tsp>_<tsp>{n}-okp i-decr_<tsp>_<tsp>{n}-step
            i-incr_<tsp>_<tsp>{i}-okp i-incr_<tsp>_<tsp>{i}-step
            i-incr_<tsp>_<tsp>{n}-okp i-incr_<tsp>_<tsp>{n}-step
            i-incr_y_y{n}-okp
            i-incr_y_y{n}-step
            i-int-to-nat-okp
            i-int-to-nat-step
            i-jump-n_x-okp i-jump-n_x-step i-jump-nn_x-okp
            i-jump-nn_x-step i-jump-nz_x-okp i-jump-nz_x-step
            i-jump-z_x-okp i-jump-z_x-step i-jump_*-okp
            i-jump_*-step i-jump_x{subr}-okp i-jump_x{subr}-step
            i-lsr_<c>_x_x{n}-okp i-lsr_<c>_x_x{n}-step
            i-lsr_<tsp>_<tsp>{v}-okp i-lsr_<tsp>_<tsp>{v}-step
            i-move-c_<tsp>_*-okp i-move-c_<tsp>_*-step
            i-move-v_<tsp>_*-okp i-move-v_<tsp>_*-step
            i-move-z_<tsp>_*-okp i-move-z_<tsp>_*-step
            i-move-n_x_*-okp i-move-n_x_*-step
            i-move_<tsp>_*-okp i-move_<tsp>_*-step
            i-move_<x{a}>_<tsp>-okp i-move_<x{a}>_<tsp>-step
            i-move_<x{s}>_<tsp>-okp i-move_<x{s}>_<tsp>-step
            i-move_cfp_csp-okp i-move_cfp_csp-step
            i-move_csp_cfp-okp i-move_csp_cfp-step
            i-move_x_*-okp i-move_x_*-step i-move_x_<x{s}>-okp
            i-move_x_<x{s}>-step i-move_x_tsp-okp
            i-move_x_tsp-step i-move_x_x-okp i-move_x_x-step
            i-move_y_*-okp i-move_y_*-step i-move_y_<y{s}>-okp
            i-move_y_<y{s}>-step i-move_y_tsp-okp i-move_y_tsp-step
            i-neg_<tsp>_<tsp>{i}-okp
            i-neg_<tsp>_<tsp>{i}-step i-not_<tsp>_<tsp>{v}-okp
            i-not_<tsp>_<tsp>{v}-step i-or_<tsp>{v}_x{v}-okp
            i-or_<tsp>{v}_x{v}-step i-or_<tsp>{b}_x{b}-okp
            i-or_<tsp>{b}_x{b}-step i-sub_<c>_<tsp>{a}_x{a}-okp
            i-sub_<c>_<tsp>{a}_x{a}-step
            i-sub_<c>_<tsp>{n}_x{n}-okp
            i-sub_<c>_<tsp>{n}_x{n}-step
            i-sub_<nv>_<tsp>{i}_x{i}-okp
            i-sub_<nv>_<tsp>{i}_x{i}-step
            i-sub_<tsp>{a}_x{n}-okp i-sub_<tsp>{a}_x{n}-step
            i-sub_x{s}_y{n}-okp i-sub_x{s}_y{n}-step
            i-sub_<tsp>{i}_x{i}-okp
            i-sub_<tsp>{i}_x{i}-step i-sub_<tsp>{n}_x{n}-okp
            i-sub_<tsp>{n}_x{n}-step i-sub_<tsp>{s}_x{s}-okp
            i-sub_<tsp>{s}_x{s}-step i-sub_<z>_x{s}_y{s}-okp
            i-sub_<z>_x{s}_y{s}-step i-subb_<c>_x{n}_y{n}-okp
            i-subb_<c>_x{n}_y{n}-step i-subb_<v>_x{i}_y{i}-okp
            i-subb_<v>_x{i}_y{i}-step i-tpop_<c>_x-okp
            i-tpop_<c>_x-step i-tpop_<x{a}>-okp
            i-tpop_<x{a}>-step i-tpop_<x{s}>-okp
            i-tpop_<x{s}>-step i-tpop_pc-okp i-tpop_pc-step
            i-tpop_x-okp i-tpop_x-step i-tpop_y-okp
            i-tpop_y-step i-tpop{v}_<z>_y-okp
            i-tpop{v}_<z>_y-step i-tpop{b}_<z>_y-okp
            i-tpop{b}_<z>_y-step i-tpop{i}_<zn>_y-okp
            i-tpop{i}_<zn>_y-step i-tpop{n}_<z>_y-okp
            i-tpop{n}_<z>_y-step i-tpush_*-okp i-tpush_*-step
            i-tpush_<x{a}>-okp i-tpush_<x{a}>-step
            i-tpush_<x{s}>-okp i-tpush_<x{s}>-step
            i-tpush_csp-okp i-tpush_csp-step i-tpush_tsp-okp
            i-tpush_tsp-step i-tpush_x-okp i-tpush_x-step
            i-xor_<tsp>_<tsp>-okp i-xor_<tsp>_<tsp>-step
            i-xor_<tsp>{v}_x{v}-okp i-xor_<tsp>{v}_x{v}-step
            i-xor_<tsp>{b}_*{b}-okp i-xor_<tsp>{b}_*{b}-step
            i-xor_<tsp>{b}_x{b}-okp i-xor_<tsp>{b}_x{b}-step
            i-xor_<z>_<tsp>_x-okp i-xor_<z>_<tsp>_x-step)))

(prove-lemma i-state-okp-i-halt (rewrite)
  (equal (i-state-okp (i-halt i psw) load-addr)
         (i-state-okp i load-addr))
  ((disable i-state-okp-restructuring)
   (enable i-state-okp i-halt)))

(prove-lemma i-state-okp-i-step (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr))
           (i-state-okp (i-step i load-addr) load-addr))
  ((disable i-ins-okp i-ins-step i-state-okp
            i-state-okp-restructuring)))

; The link tables in display-data-segment play two roles.  One is
; to let us get at that section of memory containing a certain
; area.  The other is to map the objects in that section up.
; I wish to distinguish these two roles because I need to do some
; inductions in which one of the tables is fixed and the other
; varies.  In addition, I need to separate the process of fetching
; the objects from the process of mapping them up.  So I will define
; the functions that do these separate jobs and prove their equivalence
; to display-data-segment.

(defn get-array (n m-addr m-mem)
   (if (zerop n)
       nil
       (cons (get m-addr m-mem)
             (get-array (sub1 n) (add1 m-addr) m-mem))))

(defn unlink-data-word-array (type-lst obj-lst link-tables)
  (if (nlistp type-lst)
      nil
      (cons (unlink-data-word (car type-lst)
                              (car obj-lst)
                              link-tables)
            (unlink-data-word-array (cdr type-lst)
                                    (cdr obj-lst)
                                    link-tables))))

(defn get-areas (type-spec usr-data-links m-mem)
  (if (nlistp type-spec)
      nil
      (cons (cons (caar type-spec)
                  (get-array (length (cdar type-spec))
                             (base-address (caar type-spec)
                                           usr-data-links)
                             m-mem))
            (get-areas (cdr type-spec) usr-data-links m-mem))))

(defn unlink-areas (type-spec segment link-tables)
  (if (nlistp type-spec)
      nil
      (cons (cons (caar type-spec)
                  (unlink-data-word-array (cdar type-spec)
                                          (cdar segment)
                                          link-tables))
            (unlink-areas (cdr type-spec) (cdr segment) link-tables))))

(DEFN DISPLAY-ARRAY (TYPE-LST N M-MEM LINK-TABLES)
  (IF (NLISTP TYPE-LST)
      NIL
      (CONS (UNLINK-DATA-WORD (CAR TYPE-LST)
                              (GET N M-MEM)
                              LINK-TABLES)
            (DISPLAY-ARRAY (CDR TYPE-LST)
                                  (ADD1 N)
                                  M-MEM LINK-TABLES))))

(DEFN DISPLAY-DATA-AREA (AREA-TYPE-SPEC M-MEM LINK-TABLES)
  (CONS (CAR AREA-TYPE-SPEC)
        (DISPLAY-ARRAY (CDR AREA-TYPE-SPEC)
                       (BASE-ADDRESS (CAR AREA-TYPE-SPEC)
                                     (USR-DATA-LINKS LINK-TABLES))
                       M-MEM LINK-TABLES)))

(DEFN DISPLAY-DATA-SEGMENT (TYPE-SPEC M-MEM LINK-TABLES)
  (IF (NLISTP TYPE-SPEC)
      NIL
      (CONS (DISPLAY-DATA-AREA (CAR TYPE-SPEC) M-MEM LINK-TABLES)
            (DISPLAY-DATA-SEGMENT (CDR TYPE-SPEC) M-MEM LINK-TABLES))))

(DEFN DISPLAY-M-DATA-SEGMENT (M TYPE-SPEC LINK-TABLES)
      (DISPLAY-DATA-SEGMENT TYPE-SPEC
                            (M-MEM M)
                            LINK-TABLES))

(prove-lemma display-array-decomposition (rewrite)
  (equal (display-array type-lst m-addr m-mem link-tables)
         (unlink-data-word-array type-lst
                                 (get-array (length type-lst) m-addr m-mem)
                                 link-tables)))

(prove-lemma display-data-segment-decomposition (rewrite)
  (equal (display-data-segment type-spec m-mem (i-link-tables i load-addr))
         (unlink-areas type-spec
                       (get-areas type-spec
                                  (link-table-for-segment
                                   (i-usr-data-segment i)
                                   load-addr)
                                  m-mem)
                       (i-link-tables i load-addr))))

; The key steps to proving that display-data-segment inverts is to
; show that (a) get-areas retrieves the linked areas and (b)
; unlink-areas inverts link-areas.  We begin with the get-segment
; part.

; Link-areas, mentioned above, is like link-segment, only it
; preserves the areas instead of flattening them.

(defn link-areas (segment link-tables word-size)
      (if (nlistp segment)
          nil
          (cons (cons (caar segment)
                      (link-area (cdar segment)
                                 link-tables word-size))
                (link-areas (cdr segment)
                              link-tables word-size))))


; To show that get-areas on a linked memory gives link-areas, it is
; necessary to know that get-array gets a link-area.

(defn cdr-n (n lst)
  (if (zerop n) lst (cdr-n (sub1 n) (cdr lst))))

(enable equal-length-0)

(prove-lemma lessp-link-table-entry (rewrite)
  (implies (and (definedp name segment)
                (listp (cdr (assoc name segment))))
           (lessp (link-table-entry name segment)
                  (segment-length segment)))
  ((use (lessp-absolute-address-segment-length-generalized (offset 0)))))

(prove-lemma get-link-table-entry-link-segment-generalized (rewrite)
  (implies (and (definedp name segment)
                (lessp i
                       (length (cdr (assoc name segment)))))
           (equal (get (plus i
                             (link-table-entry name segment))
                       (link-segment segment table word-size))
                  (link-word
                    (unlabel
                      (get i
                           (cdr (assoc name segment))))
                    table
                    word-size)))
  ((use (commutativity-of-plus (x i) (y (link-table-entry name segment)))
        (get-link-table-entry-link-segment (adp (cons name i))))
   (disable get-link-table-entry-link-segment)))


(prove-lemma plus-equal-0 (rewrite)
  (equal (equal (plus x y) 0)
         (and (zerop x) (zerop y))))

(prove-lemma car-cdr-n-is-get (rewrite)
  (equal (car (cdr-n n lst)) (get n lst)))

(prove-lemma cdr-cdr-n (rewrite)
  (equal (cdr (cdr-n n lst)) (cdr-n n (cdr lst))))

; This lemma was excrutiatingly hard for me to get.
; The reason, I think, is that I've just come back to
; the im level proofs after 3 months of working elsewhere
; and I no longer have the required mastery of the rules.

; This theorem was hard to invent too.  The main reason is
; that I had to get a sufficiently general version to permit
; inductive proof.  The trick was the introduction of i.

(defn first-n (n x)
  (if (zerop n)
      nil
      (cons (car x) (first-n (sub1 n) (cdr x)))))

(prove-lemma get-array-link-mem nil
   (implies
         (and (definedp name usr-data-segment)
              (not (lessp (length (cdr (assoc name usr-data-segment)))
                          (plus i n)))
              (numberp i)
              (numberp n))
         (equal (get-array n
                           (plus load-addr
                                 (plus i
                                       (link-table-entry name
                                                   usr-data-segment)))
                           (append (boot-code boot-lst load-addr word-size)
                                   (append (link-segment usr-data-segment
                                                         tables word-size)
                                           rest)))
                (link-area
                 (first-n n
                          (cdr-n i
                                 (cdr (assoc name usr-data-segment))))
                 tables word-size)))
   ((induct (get-array n i mem))
    (use (lessp-absolute-address-segment-length-generalized
          (segment usr-data-segment)
          (offset i)))))

; Now I instantiate the above theorem to get the rule I need.

; The following lemma has a link-area around a familiar identity
; just so I can avoid bringing up a properp hypothesis.

(prove-lemma first-n-length-embedded (rewrite)
  (equal (link-area (first-n (length lst) lst) tables word-size)
         (link-area lst tables word-size)))

(prove-lemma get-array-link-mem-instance (rewrite)
   (implies
         (and (definedp name usr-data-segment)
              (equal n (length (cdr (assoc name usr-data-segment)))))
         (equal (get-array n
                           (plus load-addr
                                 (link-table-entry name
                                                   usr-data-segment))
                           (append (boot-code boot-lst load-addr word-size)
                                   (append (link-segment usr-data-segment
                                                         tables word-size)
                                           rest)))
                (link-area
                 (cdr (assoc name usr-data-segment))
                 tables word-size)))
   ((use (get-array-link-mem
          (n (length (cdr (assoc name usr-data-segment))))
          (i 0)))))

; To formulate a suitably general version of the get-areas
; theorem I need the concept that one segment is an extension
; of another.  By that I mean that everything that occurs in
; the one is identically defined in the other.
; Notice that this concept is not reflexive
; unless we know the segment contains no duplicate area names.
; This whole concept is fairly subtle in its interaction with
; the proof of the get-areas lemma.  The first three lemmas
; below are the crucial properties of subsegmentp for that
; proof.  Reflexivity is needed only for the final use of
; the get-areas theorem.

(defn subsegmentp
      (segment1 segment2)
      (if (nlistp segment1)
          t
          (and (definedp (caar segment1) segment2)
               (equal (assoc (caar segment1) segment2)
                      (car segment1))
               (subsegmentp (cdr segment1)
                            segment2))))

(prove-lemma subsegmentp-cdr (rewrite)
  (implies (and (listp x)
                (subsegmentp x y))
           (subsegmentp (cdr x) y)))

(prove-lemma subsegmentp-implies-definedp (rewrite)
  (implies (and (listp segment)
                (subsegmentp segment usr-data-segment))
           (definedp (caar segment) usr-data-segment)))

(prove-lemma subsegmentp-implies-equal-assoc (rewrite)
  (implies (and (listp segment)
                (subsegmentp segment usr-data-segment))
           (equal (assoc (caar segment) usr-data-segment)
                  (car segment))))

(prove-lemma subsegmentp-reflexive-lemma (rewrite)
  (implies (and (subsegmentp x (cdr y))
                (not (definedp (caar y) x)))
           (subsegmentp x y)))

(prove-lemma subsegmentp-reflexive (rewrite)
  (implies (proper-i-usr-data-segmentp segment i)
           (subsegmentp segment segment)))

(prove-lemma length-type-lst (rewrite)
  (equal (length (type-lst area)) (length area)))


; The following theorem is key step (a) above, when the theorem is
; instantiated with segment replaced by usr-data-segment.

(prove-lemma get-areas-link-mem (rewrite)
  (implies (and (numberp load-addr)
                (subsegmentp segment usr-data-segment))
           (equal (get-areas (type-specification segment)
                             (link-table-for-segment
                              usr-data-segment
                              load-addr)
                             (append (boot-code boot-lst load-addr word-size)
                                     (append (link-segment usr-data-segment
                                                           tables
                                                           word-size)
                                             rest)))
                  (link-areas segment tables word-size)))
  ((enable length-boot-code)
   (induct (type-specification segment))))

(prove-lemma not-icode-instructionp (rewrite)
  (implies (i-objectp x i)
           (not (icode-instructionp x)))
  ((enable i-objectp)))


; We now have to prove that if i-state-okp holds then i-word-size is
; non-0.  This is necessary because otherwise booleans don't invert!

(prove-lemma cstk-implies-not-zerop-segment-length nil
  (implies (lessp n (length (cdr (assoc 'cstk segment))))
           (not (zerop (segment-length segment)))))

(prove-lemma i-loadablep-and-cstk-implies-not-zerop-i-word-size nil
  (implies (and (i-loadablep i load-addr)
                (lessp (adp-offset (untag (i-cfp i)))
                       (length (cdr (assoc 'cstk
                                           (i-sys-data-segment i))))))
           (and (numberp (i-word-size i))
                (lessp 0 (i-word-size i))))
  ((enable i-loadablep)
   (use (cstk-implies-not-zerop-segment-length
         (segment (i-sys-data-segment i))
         (n (adp-offset (untag (i-cfp i))))))))

(prove-lemma car-cdr-elim-accelerator (rewrite)
  (implies (and (listp x)
                (equal (cddr x) nil)
                (equal type (car x)))
           (equal (list type (cadr x)) x)))


; Here is the key invertibility lemma.

; The list of disabled functions, after icode-instructionp, in the
; hint below was mechanically generated.  It contains all the
; functions used to link and unlink individual data types.  The list
; could be shortened.

(prove-lemma unlink-data-word-link-data-word (rewrite)
  (implies (and (numberp load-addr)
                (i-usr-data-objectp x i)
                (i-state-okp i load-addr))
           (equal (unlink-data-word (type x)
                                    (link-data-word x
                                                    (i-link-tables i load-addr)
                                                    (i-word-size i))
                                    (i-link-tables i load-addr))
                  x))
  ((use (i-loadablep-and-cstk-implies-not-zerop-i-word-size))
   (enable i-objectp tag type untag)
   (disable icode-instructionp
            nat-to-v int-to-v bitv-to-v bool-to-v addr-to-v subr-to-v
            sys-addr-to-v label-to-v v-to-nat v-to-int v-to-bitv
            v-to-bool v-to-addr v-to-subr v-to-sys-addr v-to-label)))

(prove-lemma unlink-data-word-array-link-area (rewrite)
   (implies (and (numberp load-addr)
                 (all-i-usr-data-objectps array i)
                 (i-state-okp i load-addr))
            (equal (unlink-data-word-array (type-lst array)
                                           (link-area array
                                                      (i-link-tables i
                                                                     load-addr)
                                                      (i-word-size i))
                                           (i-link-tables i load-addr))
                   array))
   ((disable unlink-data-word)))

(prove-lemma unlink-areas-link-areas (rewrite)
  (implies (and (numberp load-addr)
                (proper-i-usr-data-segmentp segment
                                            i)
                (i-state-okp i load-addr))
           (equal (unlink-areas (type-specification segment)
                                (link-areas segment
                                            (i-link-tables i load-addr)
                                            (i-word-size i))
                                (i-link-tables i load-addr))
                  segment)))

(prove-lemma display-m-data-segment-inverts-i->m (rewrite)
 (implies
  (and (numberp load-addr)
       (proper-i-usr-data-segmentp (i-usr-data-segment i) i)
       (i-state-okp i load-addr))
  (equal
      (display-m-data-segment (i->m i boot-lst load-addr)
                              (type-specification (i-usr-data-segment i))
                              (i-link-tables i load-addr))
      (i-usr-data-segment i))))
 
(prove-lemma i-link-tables-step-move_x_x (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-move_x_x-okp i)
                (equal (i-current-instruction i) '(move_x_x)))
           (equal (i-link-tables (i-move_x_x-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable nat-to-v link-table-entry)))

(prove-lemma i-link-tables-step-cpush_* (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-cpush_*-okp i)
                (equal (i-current-instruction i) '(cpush_*)))
           (equal (i-link-tables (i-cpush_*-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-link-tables-step-add_<tsp>{i}_x{i} (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-add_<tsp>{i}_x{i}-okp i)
                (equal (i-current-instruction i) '(add_<tsp>{i}_x{i})))
           (equal (i-link-tables (i-add_<tsp>{i}_x{i}-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable alu-thm_nat-bv-add alu-thm_nat-c-add
            int-to-v v-to-int
            small-integerp
            integerp
            iplus
            get nat-to-v link-table-entry)))

(prove-lemma i-link-tables-step-cpush_cfp (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-cpush_cfp-okp i)
                (equal (i-current-instruction i) '(cpush_cfp)))
           (equal (i-link-tables (i-cpush_cfp-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-link-tables-step-move_cfp_csp (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-move_cfp_csp-okp i)
                (equal (i-current-instruction i) '(move_cfp_csp)))
           (equal (i-link-tables (i-move_cfp_csp-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-link-tables-step-cpush_<tsp>+ (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-cpush_<tsp>+-okp i)
                (equal (i-current-instruction i) '(cpush_<tsp>+)))
           (equal (i-link-tables (i-cpush_<tsp>+-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-link-tables-step-move_csp_cfp (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-move_csp_cfp-okp i)
                (equal (i-current-instruction i) '(move_csp_cfp)))
           (equal (i-link-tables (i-move_csp_cfp-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-link-tables-step-move_x_tsp (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-move_x_tsp-okp i)
                (equal (i-current-instruction i) '(move_x_tsp)))
           (equal (i-link-tables (i-move_x_tsp-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-link-tables-step-cpop_cfp (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-cpop_cfp-okp i)
                (equal (i-current-instruction i) '(cpop_cfp)))
           (equal (i-link-tables (i-cpop_cfp-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-link-tables-step-move_x_* (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-move_x_*-okp i)
                (equal (i-current-instruction i) '(move_x_*)))
           (equal (i-link-tables (i-move_x_*-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-link-tables-step-move_y_* (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-move_y_*-okp i)
                (equal (i-current-instruction i) '(move_y_*)))
           (equal (i-link-tables (i-move_y_*-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-link-tables-step-add_x{n}_csp (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-add_x{n}_csp-okp i)
                (equal (i-current-instruction i) '(add_x{n}_csp)))
           (equal (i-link-tables (i-add_x{n}_csp-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-link-tables-step-move_x_<x{s}>
             (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-move_x_<x{s}>-okp i)
                (equal (i-current-instruction i)
                       '(move_x_<x{s}>)))
           (equal (i-link-tables (i-move_x_<x{s}>-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-link-tables-step-move_y_<y{s}>
             (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-move_y_<y{s}>-okp i)
                (equal (i-current-instruction i)
                       '(move_y_<y{s}>)))
           (equal (i-link-tables (i-move_y_<y{s}>-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-link-tables-step-move_y_tsp (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-move_y_tsp-okp i)
                (equal (i-current-instruction i) '(move_y_tsp)))
           (equal (i-link-tables (i-move_y_tsp-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-link-tables-step-tpush_csp (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-tpush_csp-okp i)
                (equal (i-current-instruction i) '(tpush_csp)))
           (equal (i-link-tables (i-tpush_csp-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-link-tables-step-tpush_tsp (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-tpush_tsp-okp i)
                (equal (i-current-instruction i) '(tpush_tsp)))
           (equal (i-link-tables (i-tpush_tsp-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-link-tables-step-tpush_x (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-tpush_x-okp i)
                (equal (i-current-instruction i) '(tpush_x)))
           (equal (i-link-tables (i-tpush_x-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-link-tables-step-tpush_<x{s}>
             (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-tpush_<x{s}>-okp i)
                (equal (i-current-instruction i)
                       '(tpush_<x{s}>)))
           (equal (i-link-tables (i-tpush_<x{s}>-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-link-tables-step-tpush_<x{a}>
             (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-tpush_<x{a}>-okp i)
                (equal (i-current-instruction i) '(tpush_<x{a}>)))
           (equal (i-link-tables (i-tpush_<x{a}>-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-link-tables-step-tpush_* (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-tpush_*-okp i)
                (equal (i-current-instruction i) '(tpush_*)))
           (equal (i-link-tables (i-tpush_*-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-link-tables-step-tpop_x (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-tpop_x-okp i)
                (equal (i-current-instruction i) '(tpop_x)))
           (equal (i-link-tables (i-tpop_x-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-link-tables-step-tpop_y (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-tpop_y-okp i)
                (equal (i-current-instruction i) '(tpop_y)))
           (equal (i-link-tables (i-tpop_y-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-link-tables-step-tpop_<x{s}>
             (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-tpop_<x{s}>-okp i)
                (equal (i-current-instruction i)
                       '(tpop_<x{s}>)))
           (equal (i-link-tables (i-tpop_<x{s}>-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-link-tables-step-tpop_<x{a}>
             (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-tpop_<x{a}>-okp i)
                (equal (i-current-instruction i)
                       '(tpop_<x{a}>)))
           (equal (i-link-tables (i-tpop_<x{a}>-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-link-tables-step-jump_* (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-jump_*-okp i)
                (equal (i-current-instruction i) '(jump_*)))
           (equal (i-link-tables (i-jump_*-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-link-tables-step-cpop_pc (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-cpop_pc-okp i)
                (equal (i-current-instruction i) '(cpop_pc)))
           (equal (i-link-tables (i-cpop_pc-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-link-tables-step-move_<x{s}>_<tsp>
             (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-move_<x{s}>_<tsp>-okp i)
                (equal (i-current-instruction i)
                       '(move_<x{s}>_<tsp>)))
           (equal (i-link-tables (i-move_<x{s}>_<tsp>-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-link-tables-step-move_<x{a}>_<tsp>
             (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-move_<x{a}>_<tsp>-okp i)
                (equal (i-current-instruction i)
                       '(move_<x{a}>_<tsp>)))
           (equal (i-link-tables (i-move_<x{a}>_<tsp>-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-link-tables-step-jump_x{subr} (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-jump_x{subr}-okp i)
                (equal (i-current-instruction i) '(jump_x{subr})))
           (equal (i-link-tables (i-jump_x{subr}-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-link-tables-step-jump-n_x (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-jump-n_x-okp i)
                (equal (i-current-instruction i) '(jump-n_x)))
           (equal (i-link-tables (i-jump-n_x-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-link-tables-step-jump-nn_x (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-jump-nn_x-okp i)
                (equal (i-current-instruction i) '(jump-nn_x)))
           (equal (i-link-tables (i-jump-nn_x-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-link-tables-step-jump-z_x (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-jump-z_x-okp i)
                (equal (i-current-instruction i) '(jump-z_x)))
           (equal (i-link-tables (i-jump-z_x-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-link-tables-step-jump-nz_x (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-jump-nz_x-okp i)
                (equal (i-current-instruction i) '(jump-nz_x)))
           (equal (i-link-tables (i-jump-nz_x-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-link-tables-step-tpop_pc (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-tpop_pc-okp i)
                (equal (i-current-instruction i) '(tpop_pc)))
           (equal (i-link-tables (i-tpop_pc-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-link-tables-step-tpop_<c>_x (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-tpop_<c>_x-okp i)
                (equal (i-current-instruction i) '(tpop_<c>_x)))
           (equal (i-link-tables (i-tpop_<c>_x-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-link-tables-step-tpop{n}_<z>_y
             (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-tpop{n}_<z>_y-okp i)
                (equal (i-current-instruction i)
                       '(tpop{n}_<z>_y)))
           (equal (i-link-tables (i-tpop{n}_<z>_y-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-link-tables-step-tpop{i}_<zn>_y
             (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-tpop{i}_<zn>_y-okp i)
                (equal (i-current-instruction i)
                       '(tpop{i}_<zn>_y)))
           (equal (i-link-tables (i-tpop{i}_<zn>_y-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable int-to-v v-to-int
            small-integerp
            integerp
            get nat-to-v link-table-entry)))

(prove-lemma i-link-tables-step-tpop{b}_<z>_y
             (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-tpop{b}_<z>_y-okp i)
                (equal (i-current-instruction i)
                       '(tpop{b}_<z>_y)))
           (equal (i-link-tables (i-tpop{b}_<z>_y-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-link-tables-step-tpop{v}_<z>_y
             (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-tpop{v}_<z>_y-okp i)
                (equal (i-current-instruction i)
                       '(tpop{v}_<z>_y)))
           (equal (i-link-tables (i-tpop{v}_<z>_y-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-link-tables-step-add_<tsp>{a}_x{n} (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-add_<tsp>{a}_x{n}-okp i)
                (equal (i-current-instruction i) '(add_<tsp>{a}_x{n})))
           (equal (i-link-tables (i-add_<tsp>{a}_x{n}-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-link-tables-step-add_tsp_*{n} (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-add_tsp_*{n}-okp i)
                (equal (i-current-instruction i) '(add_tsp_*{n})))
           (equal (i-link-tables (i-add_tsp_*{n}-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-link-tables-step-add_tsp_x{n} (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-add_tsp_x{n}-okp i)
                (equal (i-current-instruction i) '(add_tsp_x{n})))
           (equal (i-link-tables (i-add_tsp_x{n}-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-link-tables-step-sub_<tsp>{a}_x{n} (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-sub_<tsp>{a}_x{n}-okp i)
                (equal (i-current-instruction i) '(sub_<tsp>{a}_x{n})))
           (equal (i-link-tables (i-sub_<tsp>{a}_x{n}-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-link-tables-step-sub_x{s}_y{n} (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-sub_x{s}_y{n}-okp i)
                (equal (i-current-instruction i) '(sub_x{s}_y{n})))
           (equal (i-link-tables (i-sub_x{s}_y{n}-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-link-tables-step-xor_<z>_<tsp>_x
             (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-xor_<z>_<tsp>_x-okp i)
                (equal (i-current-instruction i)
                       '(xor_<z>_<tsp>_x)))
           (equal (i-link-tables (i-xor_<z>_<tsp>_x-step i load-addr) load-addr)
                  (i-link-tables i load-addr)))
  ((enable i-objectp-type)
   (disable xor-xxx
            get nat-to-v link-table-entry)))

(prove-lemma i-link-tables-step-xor_<tsp>_<tsp> (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-xor_<tsp>_<tsp>-okp i)
                (equal (i-current-instruction i) '(xor_<tsp>_<tsp>)))
           (equal (i-link-tables (i-xor_<tsp>_<tsp>-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-link-tables-step-move-z_<tsp>_* (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-move-z_<tsp>_*-okp i)
                (equal (i-current-instruction i) '(move-z_<tsp>_*)))
           (equal (i-link-tables (i-move-z_<tsp>_*-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-link-tables-step-move-n_x_* (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-move-n_x_*-okp i)
                (equal (i-current-instruction i) '(move-n_x_*)))
           (equal (i-link-tables (i-move-n_x_*-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-link-tables-step-move_<tsp>_* (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-move_<tsp>_*-okp i)
                (equal (i-current-instruction i) '(move_<tsp>_*)))
           (equal (i-link-tables (i-move_<tsp>_*-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-link-tables-step-incr_<tsp>_<tsp>{i} (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-incr_<tsp>_<tsp>{i}-okp i)
                (equal (i-current-instruction i) '(incr_<tsp>_<tsp>{i})))
           (equal (i-link-tables (i-incr_<tsp>_<tsp>{i}-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable alu-thm_nat-bv-incr alu-thm_nat-c-incr
            int-to-v v-to-int
            small-integerp
            integerp
            iplus
            get nat-to-v link-table-entry)))

(prove-lemma i-link-tables-step-sub_<tsp>{i}_x{i} (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-sub_<tsp>{i}_x{i}-okp i)
                (equal (i-current-instruction i) '(sub_<tsp>{i}_x{i})))
           (equal (i-link-tables (i-sub_<tsp>{i}_x{i}-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable alu-thm_nat-bv-sub alu-thm_nat-c-sub
            int-to-v v-to-int
            small-integerp
            integerp
            iplus
            get nat-to-v link-table-entry)))

(prove-lemma i-link-tables-step-decr_<tsp>_<tsp>{i} (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-decr_<tsp>_<tsp>{i}-okp i)
                (equal (i-current-instruction i) '(decr_<tsp>_<tsp>{i})))
           (equal (i-link-tables (i-decr_<tsp>_<tsp>{i}-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable alu-thm_nat-bv-decr alu-thm_nat-c-decr
            int-to-v v-to-int
            small-integerp
            integerp
            iplus
            get nat-to-v link-table-entry)))

(prove-lemma i-link-tables-step-neg_<tsp>_<tsp>{i} (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-neg_<tsp>_<tsp>{i}-okp i)
                (equal (i-current-instruction i) '(neg_<tsp>_<tsp>{i})))
           (equal (i-link-tables (i-neg_<tsp>_<tsp>{i}-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable int-to-v v-to-int
            small-integerp
            integerp
            iplus
            get nat-to-v link-table-entry)))

(prove-lemma i-link-tables-step-asr_<c>_<tsp>_<tsp>{b} (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-asr_<c>_<tsp>_<tsp>{b}-okp i)
                (equal (i-current-instruction i) '(asr_<c>_<tsp>_<tsp>{b})))
           (equal (i-link-tables (i-asr_<c>_<tsp>_<tsp>{b}-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-link-tables-step-addc_<c>_x{n}_y{n} (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-addc_<c>_x{n}_y{n}-okp i)
                (equal (i-current-instruction i) '(addc_<c>_x{n}_y{n})))
           (equal (i-link-tables (i-addc_<c>_x{n}_y{n}-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-link-tables-step-add_<tsp>{n}_x{n} (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-add_<tsp>{n}_x{n}-okp i)
                (equal (i-current-instruction i) '(add_<tsp>{n}_x{n})))
           (equal (i-link-tables (i-add_<tsp>{n}_x{n}-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-link-tables-step-incr_<tsp>_<tsp>{n} (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-incr_<tsp>_<tsp>{n}-okp i)
                (equal (i-current-instruction i) '(incr_<tsp>_<tsp>{n})))
           (equal (i-link-tables (i-incr_<tsp>_<tsp>{n}-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-link-tables-step-incr_y_y{n} (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-incr_y_y{n}-okp i)
                (equal (i-current-instruction i) '(incr_y_y{n})))
           (equal (i-link-tables (i-incr_y_y{n}-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-link-tables-step-int-to-nat (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-int-to-nat-okp i)
                (equal (i-current-instruction i) '(int-to-nat)))
           (equal (i-link-tables (i-int-to-nat-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-link-tables-step-decr_<tsp>_<tsp>{n} (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-decr_<tsp>_<tsp>{n}-okp i)
                (equal (i-current-instruction i) '(decr_<tsp>_<tsp>{n})))
           (equal (i-link-tables (i-decr_<tsp>_<tsp>{n}-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-link-tables-step-add_<c>_x_x{n}
             (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-add_<c>_x_x{n}-okp i)
                (equal (i-current-instruction i)
                       '(add_<c>_x_x{n})))
           (equal (i-link-tables (i-add_<c>_x_x{n}-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-link-tables-step-add_<tsp>_<tsp>{n}
             (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-add_<tsp>_<tsp>{n}-okp i)
                (equal (i-current-instruction i)
                       '(add_<tsp>_<tsp>{n})))
           (equal (i-link-tables (i-add_<tsp>_<tsp>{n}-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-link-tables-step-lsr_<c>_x_x{n}
             (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-lsr_<c>_x_x{n}-okp i)
                (equal (i-current-instruction i)
                       '(lsr_<c>_x_x{n})))
           (equal (i-link-tables (i-lsr_<c>_x_x{n}-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-link-tables-step-subb_<c>_x{n}_y{n} (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-subb_<c>_x{n}_y{n}-okp i)
                (equal (i-current-instruction i) '(subb_<c>_x{n}_y{n})))
           (equal (i-link-tables (i-subb_<c>_x{n}_y{n}-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-link-tables-step-sub_<c>_<tsp>{n}_x{n} (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-sub_<c>_<tsp>{n}_x{n}-okp i)
                (equal (i-current-instruction i) '(sub_<c>_<tsp>{n}_x{n})))
           (equal (i-link-tables (i-sub_<c>_<tsp>{n}_x{n}-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-link-tables-step-sub_<nv>_<tsp>{i}_x{i} (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-sub_<nv>_<tsp>{i}_x{i}-okp i)
                (equal (i-current-instruction i) '(sub_<nv>_<tsp>{i}_x{i})))
           (equal (i-link-tables (i-sub_<nv>_<tsp>{i}_x{i}-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable alu-thm_nat-bv-sub alu-thm_nat-c-sub
            int-to-v v-to-int
            small-integerp
            integerp
            iplus
            inegate
            get nat-to-v link-table-entry)))

(prove-lemma i-link-tables-step-sub_<tsp>{n}_x{n} (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-sub_<tsp>{n}_x{n}-okp i)
                (equal (i-current-instruction i) '(sub_<tsp>{n}_x{n})))
           (equal (i-link-tables (i-sub_<tsp>{n}_x{n}-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable get nat-to-v link-table-entry)))

(prove-lemma i-link-tables-step-sub_<c>_<tsp>{a}_x{a} (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-sub_<c>_<tsp>{a}_x{a}-okp i)
                (equal (i-current-instruction i) '(sub_<c>_<tsp>{a}_x{a})))
           (equal (i-link-tables (i-sub_<c>_<tsp>{a}_x{a}-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable get nat-to-v link-table-entry)
   (use (lessp-absolute-address-segment-length-generalized
         (name (adp-name
                (untag (get (adp-offset (untag (i-tsp i)))
                            (cdr (assoc 'tstk
                                        (i-sys-data-segment i)))))))
         (offset (adp-offset
                  (untag (get (adp-offset (untag (i-tsp i)))
                              (cdr (assoc 'tstk
                                          (i-sys-data-segment i)))))))
         (segment (i-usr-data-segment i))))))

(prove-lemma i-link-tables-step-sub_<tsp>{s}_x{s} (rewrite)
  (implies (and (numberp load-addr)
                (i-state-okp i load-addr)
                (equal (i-psw i) 'run)
                (equal (i-word-size i) 32)
                (i-sub_<tsp>{s}_x{s}-okp i)
                (equal (i-current-instruction i) '(sub_<tsp>{s}_x{s})))
           (equal (i-link-tables (i-sub_<tsp>{s}_x{s}-step i) load-addr)
                  (i-link-tables i load-addr)))
  ((disable get nat-to-v link-table-entry)
   (use (lessp-absolute-address-segment-length-generalized
         (name (adp