; C Library
;
; Copyright (C) 2021 Kestrel Institute (http://www.kestrel.edu)
; Copyright (C) 2021 Kestrel Technology LLC (http://kestreltechnology.com)
;
; License: A 3-clause BSD license. See the LICENSE file distributed with ACL2.
;
; Author: Alessandro Coglio (coglio@kestrel.edu)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(in-package "C")

(include-book "dynamic-semantics")

(include-book "kestrel/utilities/defopeners" :dir :system)
(include-book "tools/rulesets" :dir :system)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defxdoc+ atc-proof-support
  :parents (atc-implementation)
  :short "Functions and rules to support the proofs generated by ATC."
  :long
  (xdoc::topstring
   (xdoc::p
    "Currently, the generated proofs of function correctness
     are carried out via symbolic execution of the C code.
     The C code is a constant value,
     because we are generating proofs over specific C functions;
     this makes symbolic execution possible.")
   (xdoc::p
    "In order to make these generated proofs more robust,
     we carry them out in a theory that consists exactly of
     (what we believe to be) all and only the needed rules.
     This file defines that theory, which consists of
     some rules introduced elsewhere and some rules introduced in this file.
     This set of rules has been defined by
     not only thinking of what is needed for symbolic execution,
     but also experimenting with several symbolic execution proofs,
     starting with the empty theory and adding rules
     as needed to advance the symbolic execution,
     and also by looking at the C dynamic semantics.
     There is no guarantee (meta proof) that
     these rules will suffice for every use of ATC;
     there is also no guarantee that
     the proof will not be defeated by some ACL2 heuristic in some cases.
     Nonetheless, the proof strategy seems sound and robust,
     and if a generated proof fails
     it should be possible to (prove and) use additional rules.")
   (xdoc::p
    "Besides rules, we also introduce some functions
     that provide a canonical representation of computation states
     that is used during symbolic execution.
     Thus, some of the rules in the symbolic execution theory
     are tailored to the functions that form this canonical representation."))
  :order-subtopics t
  :default-parent t)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defsection atc-symbolic-computation-states
  :short "Canonical representation of
          the computation states for the symbolic execution."
  :long
  (xdoc::topstring
   (xdoc::p
    "Starting from a generic (symbolic) computation state,
     a symbolic execution starting with @(tsee exec-fun)
     will push a frame (for the function),
     possibly read variables,
     possibly create new variables,
     possibly write existing variables,
     possibly enter new scopes,
     possibly exit existing scopes,
     and eventually pop the frame.
     Just one frame is pushed and then popped
     because the symbolic execution is compositional w.r.t. functions,
     i.e. the symbolic execution rewrites function calls in function bodies
     using the theorems about the called functions.")
   (xdoc::p
    "The dynamic semantics functions that perform the above actions,
     namely @(tsee push-frame), @tsee enter-scope), @(tsee create-var), etc.,
     go into the frame stack component of the computation state,
     via the @(tsee compustate->frames) accessor.
     That leads to a complex symbolic term for the computation state.")
   (xdoc::p
    "Instead, we pull the ``additions'' to the computation state,
     i.e. the added frames, scopes, and variables,
     out of the computation state via the three functions defined below.
     Their definition is of course to
     push the frames, scopes, and variables into the computation state,
     but we leave these functions disabled during symbolic execution,
     so that the symbolic computation states has these additions explicit.
     Thus, the symbolic computation state is
     a sequence of applications of the three functions below
     to an initial symbolic computation state @('<compst>'):")
   (xdoc::codeblock
    "(add-var ... (add-var ... (add-scope (add-frame ... <compst>)...)")
   (xdoc::p
    "We then prove theorems that describe
     the effect of @(tsee push-frame) and other functions
     on computation states of this form,
     where the effect is another state in that form.
     These theorems are enabled during symbolic execution,
     and manipulate the computation state.")
   (xdoc::p
    "Note that @(tsee add-scope) and @(tsee add-var)
     return the computation state unchanged if the frame stack is empty.
     This is intentional, as it seems to make some theorems simpler,
     but this decision may be revisited.")
   (xdoc::p
    "In the presence of C loops,
     which are represented by ACL2 recursive functions,
     we generate theorems that describe the execution of the loops
     starting from generic (symbolic) computation states.
     The execution of a loop does not push a new frame,
     because the loop executes in the frame of the enclosing C function.
     In this case, the initial generic computation state
     includes part of the frame of the enclosing C function;
     the execution of the loop may add new scopes and variables,
     so in this case the symbolic computtion state looks like")
   (xdoc::codeblock
    "(add-var ... (add-var ... (add-scope <compst>)...)")
   (xdoc::p
    "In fact, the innermost function there
     must be @(tsee add-scope) (it cannot be @(tsee add-var)),
     because the loops we generate have compound statements as bodies,
     which create new scopes.")
   (xdoc::p
    "The initial symbolic computation state @('<compst>')
     contains the initial part of the frame
     of the function that contains the loop;
     the loop extends the frame with @(tsee add-scope) and @(tsee add-var)
     as shown above.
     But the structure of the initial part of the frame
     is not known in the symbolic execution for the loop itself:
     it is just the initial @('<compst>').
     However, the loop may access variables in that initial part of the frame:
     the theorem generated for the loop includes hypotheses
     saying that @(tsee read-var) applied to @('<compst>')
     for certain variables (i.e. identifiers)
     yields values of certain C types:
     this way, any of these @(tsee read-var) calls
     arising during symbolic execution match those hypotheses.
     A loop may write to those variables:
     in this case, the @(tsee write-var) will go through
     all the @(tsee add-var) and @(tsee add-scope) layers shown above,
     and reach @('<compst>'), where it is not further reducible.
     This may happen for several different variables,
     so the general form of our symbolic computation states is")
   (xdoc::codeblock
    "(add-var ... (add-scope (write-var ... (write-var ... <compst>)...)")
   (xdoc::p
    "Below we introduce rules to order these @(tsee write-var)s
     according to the variables,
     maintaining a canonical form.")
   (xdoc::p
    "Note that this form of the computation states
     serves to represent side effects performed by the loop
     on the initial computation state.
     The same approach will be used to generate proofs for
     more general side effects, e.g. on global variables or the heap."))
  :order-subtopics t)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define add-frame ((fun identp) (compst compustatep))
  :returns (new-compst compustatep)
  :parents (atc-symbolic-computation-states)
  :short (xdoc::topstring
          "Add a frame to a "
          (xdoc::seetopic "atc-symbolic-computation-states"
                          "canonical representation of computation states")
          ".")
  (push-frame (make-frame :function fun :scopes (list nil))
              compst)
  :hooks (:fix))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define add-scope ((compst compustatep))
  :returns (new-compst compustatep)
  :parents (atc-symbolic-computation-states)
  :short (xdoc::topstring
          "Add a scope to a "
          (xdoc::seetopic "atc-symbolic-computation-states"
                          "canonical representation of computation states")
          ".")
  (b* (((when (= (compustate-frames-number compst) 0)) (compustate-fix compst))
       (frame (top-frame compst))
       (scopes (frame->scopes frame))
       (new-scopes (cons nil scopes))
       (new-frame (change-frame frame :scopes new-scopes))
       (new-compst (push-frame new-frame (pop-frame compst))))
    new-compst)
  :hooks (:fix))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define add-var ((var identp) (val valuep) (compst compustatep))
  :returns (new-compst compustatep)
  :parents (atc-symbolic-computation-states)
  :short (xdoc::topstring
          "Add a variable to a "
          (xdoc::seetopic "atc-symbolic-computation-states"
                          "canonical representation of computation states")
          ".")
  (b* (((when (= (compustate-frames-number compst) 0)) (compustate-fix compst))
       (frame (top-frame compst))
       (scopes (frame->scopes frame))
       (scope (car scopes))
       (new-scope (omap::update (ident-fix var) (value-fix val) scope))
       (new-scopes (cons new-scope (cdr scopes)))
       (new-frame (change-frame frame :scopes new-scopes))
       (new-compst (push-frame new-frame (pop-frame compst))))
    new-compst)
  :hooks (:fix))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defsection atc-symbolic-computation-state-rules
  :short "Rewrite rules for symbolic computation states."
  :long
  (xdoc::topstring
   (xdoc::p
    "As explained in @(see atc-symbolic-computation-states),
     we use a canonical representation of computation states
     that explicates the frames, scopes, and variables
     added to a starting computation state,
     as well as the side-effecting updates to the starting computation state.
     Here we prove theorems expressing how
     functions like @(tsee push-frame) transform those computation states,
     maintaining their canonical form.")
   (xdoc::p
    "In @(tsee exec-fun), a scope is initialized
     and a frame is pushed with that scope.
     Here we provide two theorems to turn that into a canonical representation.
     Assuming that @(tsee init-scope) is rewritten
     to a nest of @(tsee omap::update) calls
     (as it is, because we use openers for @(tsee init-scope)),
     the two theorems below move the variables into @(tsee add-var) calls,
     and finally turn @(tsee push-frame) into @(tsee add-frame).")
   (xdoc::p
    "The theorems below about @(tsee pop-frame)
     remove all the @(tsee add-var) and @(tsee add-scope) calls
     until they reach @(tsee add-frame),
     with which @(tsee pop-frame) neutralizes.
     No rules are needed for
     computation states that start with @(tsee write-var)
     because these only occur when executing loops,
     which do not pop frames.")
   (xdoc::p
    "We provide a single theorem about @(tsee enter-scope),
     which just turns that into @(tsee add-scope) in all cases.
     If the computation state starts with @(tsee add-frame),
     the hypothesis  that the stack frame is not empty is not needed;
     but we still prefer to have just one theorem for all cases here.")
   (xdoc::p
    "The theorems below about @(tsee exit-scope)
     cancel it with @(tsee add-scope)
     and move it past @(tsee add-var).
     No rule for @(tsee add-frame) is needed
     because that case should never happen in the symbolic execution.
     No rule is needed for computation states that start with @(tsee write-var)
     because @(tsee write-var) is always pushed past @(tsee add-scope).")
   (xdoc::p
    "The theorems below about @(tsee create-var)
     turn that into @(tsee add-var)
     when @(tsee add-frame) or @(tsee add-scope) is reached,
     because a variable is only created in the current scope.
     The third theorem skips over @(tsee add-var)
     when the two variables have different names
     (they should never have the same name during the symbolic execution),
     but note that @(tsee create-var) may return an error,
     and so we have a hypothesis about it not returning an error.
     But this may be inefficient, because it means that
     we are pushing @(tsee create-var)
     into the layers of the computation state repeatedly.
     We will look into making this more efficient.
     The reason for skipping over @(tsee add-var)s with different names
     is to exclude the case of a variable redefinition:
     attempting to prove a theorem
     that simply replaces @(tsee create-var) with @(tsee add-var),
     similarly to the theorem that
     turns @(tsee enter-scope) into @(tsee add-scope),
     fails because of the possibility of a redefined variable.
     There is no rule for @(tsee create-var) applied to @(tsee write-var),
     because @(tsee write-var)s are always pushed past @(tsee add-scope).")
   (xdoc::p
    "The theorems below about @(tsee read-var) are a bit different
     because @(tsee read-var) does not return a state, but a value instead.
     The first theorem skips over @(tsee add-scope).
     The second theorem
     either returns the value of the encountered variable or skips over it,
     based on whether the names coincide or not.
     There is no theorem for @(tsee add-frame) because this situation
     should never happen during the symbolic execution.
     The third theorem serves for variables read in loops
     that are declared outside the scope of the loop,
     i.e. that are represented as @(tsee write-var)s:
     if the two variables are the same, the value is returned;
     otherwise, we skip over the @(tsee write-var)
     in search for the variable.")
   (xdoc::p
    "The theorems below about @(tsee write-var)
     have some analogies to the ones for @(tsee create-var),
     because @(tsee write-var) may also return an error.
     The first theorem skips over @(tsee add-scope),
     but has the same kind of possibly inefficient hypothesis
     discussed above for @(tsee create-var).
     There is no rule for @(tsee add-frame) because that should not happen.
     The second and third theorems are for @(tsee add-var),
     when the variable names are the same or are different:
     when they are the same, the value in the @(tsee add-var) is replaced;
     when the names differ, we skip over the @(tsee add-var),
     but again we have the potentially inefficient hypothesis discussed.
     The fourth theorem overwrites a @(tsee write-var)
     with a @(tsee write-var) for the same variable.
     The fifth theorem is used to arrange a nest of @(tsee write-var)s
     in alphabetical order of the variable names:
     it swaps two @(tsee write-var)s when the outer one
     has an larger variable than the inner one.
     Note that we need to disable loop stoppers for this rule,
     otherwise ACL2 may not apply it based on the written value terms,
     which are irrelevant to this normalization
     based on alphabetical order.
     Note the @(tsee syntaxp) hypotheses
     that require the identifiers (i.e. variable names)
     to have the form described in @(see atc-identifier-rules).
     Finally, the sixth theorem serves to simplify the case in which
     a variable is written with its current value;
     this case may occur when proving the base case of a loop.")
   (xdoc::p
    "The theorems below about @(tsee compustate-frames-number)
     serve to discharge the hypotheses about it being not 0
     in some of the other theorems below.
     We simply consume @(tsee add-scope) and @(tsee add-var),
     and stop at @(tsee add-frame) because that one adds a frame.
     For @(tsee write-var), i.e. for side-effected variables,
     we need the hypothesis that @(tsee write-var) is not an error.")
   (xdoc::p
    "The theorems below about @(tsee deref)
     applied to the heap component of the computation state
     skip over all the added frames, scopes, and variables.
     We also skip over the side-effected @(tsee write-var) variables.")
   (xdoc::p
    "The theorem about @(tsee errorp) applied to @(tsee write-var)
     serves to discharge the hypotheses about that in some of the other rules.
     During symbolic execution, there will be hypotheses saying that
     reading the variable in question does not return an error:
     so we have that hypothesis in the rule.
     The rule reduces the fact that @(tsee write-var) is an error
     to the non-equality of the types of the values,
     which will always be equal during symbolic execution by construction."))

  ;; rules about PUSH-FRAME:

  (defruled push-frame-of-one-empty-scope
    (equal (push-frame (frame fun (list nil)) compst)
           (add-frame fun compst))
    :enable add-frame)

  (defruled push-frame-of-one-nonempty-scope
    (implies (and (identp var)
                  (valuep val)
                  (scopep scope))
             (equal (push-frame (frame fun (list (omap::update var val scope)))
                                compst)
                    (add-var var
                             val
                             (push-frame (frame fun (list scope)) compst))))
    :enable (push-frame
             top-frame
             pop-frame
             add-var
             compustate-frames-number))

  ;; rules about POP-FRAME:

  (defruled pop-frame-of-add-frame
    (equal (pop-frame (add-frame fun compst))
           (compustate-fix compst))
    :enable (pop-frame add-frame))

  (defruled pop-frame-of-add-scope
    (equal (pop-frame (add-scope compst))
           (pop-frame compst))
    :enable (pop-frame
             add-scope
             push-frame))

  (defruled pop-frame-of-add-var
    (equal (pop-frame (add-var var val compst))
           (pop-frame compst))
    :enable (pop-frame
             add-var
             push-frame))

  ;; rules about ENTER-SCOPE:

  (defruled enter-scope-of-compustate
    (implies (not (equal (compustate-frames-number compst) 0))
             (equal (enter-scope compst)
                    (add-scope compst)))
    :enable (enter-scope add-scope))

  ;; rules about EXIT-SCOPE:

  (defruled exit-scope-of-add-scope
    (implies (not (equal (compustate-frames-number compst) 0))
             (equal (exit-scope (add-scope compst))
                    (compustate-fix compst)))
    :enable (add-scope
             exit-scope
             push-frame
             top-frame
             pop-frame
             compustate-frames-number))

  (defruled exit-scope-of-add-var
    (equal (exit-scope (add-var var val compst))
           (exit-scope compst))
    :enable (exit-scope add-var))

  ;; rules about CREATE-VAR:

  (defruled create-var-of-add-frame
    (equal (create-var var val (add-frame fun compst))
           (add-var var val (add-frame fun compst)))
    :enable (create-var add-var add-frame))

  (defruled create-var-of-add-scope
    (implies (not (equal (compustate-frames-number compst) 0))
             (equal (create-var var val (add-scope compst))
                    (add-var var val (add-scope compst))))
    :enable (create-var add-var add-scope))

  (defruled create-var-of-add-var
    (implies (and (not (equal (compustate-frames-number compst) 0))
                  (not (equal (ident-fix var)
                              (ident-fix var2)))
                  ;; the following hyp may be inefficient:
                  (not (errorp (create-var var val compst))))
             (equal (create-var var val (add-var var2 val2 compst))
                    (add-var var2 val2 (create-var var val compst))))
    :enable (create-var add-var))

  ;; rules about READ-VAR:

  (defruled read-var-of-add-scope
    (equal (read-var var (add-scope compst))
           (read-var var compst))
    :enable (read-var
             read-var-aux
             add-scope))

  (defruled read-var-of-add-var
    (implies (not (equal (compustate-frames-number compst) 0))
             (equal (read-var var (add-var var2 val compst))
                    (if (equal (ident-fix var)
                               (ident-fix var2))
                        (value-fix val)
                      (read-var var compst))))
    :enable (read-var
             read-var-aux
             add-var
             compustate-frames-number
             push-frame
             top-frame)
    :disable omap::in-when-in-tail)

  (defruled read-var-of-write-var
    (implies (not (errorp (write-var var2 val compst)))
             (equal (read-var var (write-var var2 val compst))
                    (if (equal (ident-fix var)
                               (ident-fix var2))
                        (value-fix val)
                      (read-var var compst))))
    :enable (read-var
             write-var
             push-frame
             top-frame
             compustate-frames-number
             read-var-aux-of-write-var-aux)
    :prep-lemmas
    ((defruled read-var-aux-of-write-var-aux
       (implies (not (errorp (write-var-aux var2 val scopes)))
                (equal (read-var-aux var (write-var-aux var2 val scopes))
                       (if (equal (ident-fix var)
                                  (ident-fix var2))
                           (value-fix val)
                         (read-var-aux var scopes))))
       :enable (read-var-aux
                write-var-aux)
       :disable omap::in-when-in-tail)))

  ;; rules about WRITE-VAR:

  (defruled write-var-of-add-scope
    (implies (and (not (equal (compustate-frames-number compst) 0))
                  ;; the following hyp may be inefficient:
                  (not (errorp (write-var var val compst))))
             (equal (write-var var val (add-scope compst))
                    (add-scope (write-var var val compst))))
    :enable (write-var
             write-var-aux
             add-scope
             push-frame
             pop-frame
             top-frame
             compustate-frames-number
             errorp))

  (defruled write-var-of-add-var-same
    (implies (and (not (equal (compustate-frames-number compst) 0))
                  (equal (ident-fix var)
                         (ident-fix var2))
                  (equal (type-of-value val)
                         (type-of-value val2)))
             (equal (write-var var val (add-var var2 val2 compst))
                    (add-var var val compst)))
    :enable (write-var
             write-var-aux
             add-var
             push-frame
             top-frame
             pop-frame
             compustate-frames-number
             errorp))

  (defruled write-var-of-add-var-diff
    (implies (and (not (equal (ident-fix var)
                              (ident-fix var2)))
                  ;; the following hyp may be inefficient:
                  (not (errorp (write-var var val compst))))
             (equal (write-var var val (add-var var2 val2 compst))
                    (add-var var2 val2 (write-var var val compst))))
    :enable (write-var
             write-var-aux
             add-var
             push-frame
             top-frame
             pop-frame
             compustate-frames-number
             errorp
             error))

  (defruled write-var-of-write-var-same
    (implies (not (errorp (write-var var val2 compst)))
             (equal (write-var var val (write-var var val2 compst))
                    (write-var var val compst)))
    :enable (write-var
             write-var-aux-of-write-var-aux-same
             push-frame
             pop-frame
             top-frame
             compustate-frames-number)
    :prep-lemmas
    ((defruled write-var-aux-of-write-var-aux-same
       (implies (not (errorp (write-var-aux var val2 scopes)))
                (equal (write-var-aux var val (write-var-aux var val2 scopes))
                       (write-var-aux var val scopes)))
       :enable write-var-aux)))

  (defruled write-var-of-write-var-less
    (implies (and (syntaxp (and (consp var2)
                                (eq (car var2) 'ident)
                                (quotep (cadr var2))))
                  (syntaxp (and (consp var)
                                (eq (car var) 'ident)
                                (quotep (cadr var))))
                  (<< (ident-fix var2)
                      (ident-fix var))
                  (not (equal (compustate-frames-number compst) 0))
                  (not (errorp (write-var var val compst)))
                  (not (errorp (write-var var2 val2 compst))))
             (equal (write-var var val (write-var var2 val2 compst))
                    (write-var var2 val2 (write-var var val compst))))
    :enable (write-var
             push-frame
             pop-frame
             top-frame
             compustate-frames-number)
    :use (:instance write-var-aux-of-write-var-aux-less
          (scopes (frame->scopes (top-frame compst))))
    :rule-classes ((:rewrite :loop-stopper nil))
    :prep-lemmas
    ((defruled write-var-aux-of-write-var-aux-less
       (implies (and (not (errorp (write-var-aux var val scopes)))
                     (not (errorp (write-var-aux var2 val2 scopes)))
                     (<< (ident-fix var2)
                         (ident-fix var)))
                (equal (write-var-aux var
                                      val
                                      (write-var-aux var2
                                                     val2
                                                     scopes))
                       (write-var-aux var2
                                      val2
                                      (write-var-aux var
                                                     val
                                                     scopes))))
       :use (:instance lemma (a (ident-fix var2)) (b (ident-fix var)))
       :prep-lemmas
       ((defrule write-var-aux-of-write-var-aux-diff
          (implies (and (not (errorp (write-var-aux var val scopes)))
                        (not (errorp (write-var-aux var2 val2 scopes)))
                        (not (equal (ident-fix var2)
                                    (ident-fix var))))
                   (equal (write-var-aux var
                                         val
                                         (write-var-aux var2
                                                        val2
                                                        scopes))
                          (write-var-aux var2
                                         val2
                                         (write-var-aux var
                                                        val
                                                        scopes))))
          :enable (write-var-aux
                   scope-listp-when-scope-list-resultp-and-not-errorp))
        (defruled lemma
          (implies (<< a b)
                   (not (equal a b))))))))

  (defruled write-var-of-read-var-same
    (implies (not (errorp (read-var var compst)))
             (equal (write-var var (read-var var compst) compst)
                    (compustate-fix compst)))
    :enable (read-var
             write-var
             write-var-aux-of-read-var-aux-same
             top-frame
             push-frame
             pop-frame
             compustate-frames-number)
    :prep-lemmas
    ((defrule lemma
       (implies (scope-listp x)
                (not (errorp x)))
       :enable errorp)
     (defruled write-var-aux-of-read-var-aux-same
       (implies (not (errorp (read-var-aux var scopes)))
                (equal (write-var-aux var (read-var-aux var scopes) scopes)
                       (scope-list-fix scopes)))
       :enable (read-var-aux
                write-var-aux
                omap::update-of-cdr-of-in-when-in)
       :prep-lemmas
       ((defruled omap::update-of-cdr-of-in-when-in
          (implies (consp (omap::in k m))
                   (equal (omap::update k (cdr (omap::in k m)) m)
                          m))
          :induct (omap::in k m)
          :enable omap::in)))))

  ;; rules about COMPUSTATE-FRAMES-NUMBER:

  (defruled compustate-frames-number-of-add-frame-not-zero
    (not (equal (compustate-frames-number (add-frame fun compst)) 0))
    :enable add-frame)

  (defruled compustate-frames-number-of-add-scope
    (equal (compustate-frames-number (add-scope compst))
           (compustate-frames-number compst))
    :enable add-scope)

  (defruled compustate-frames-number-of-add-var
    (equal (compustate-frames-number (add-var var val compst))
           (compustate-frames-number compst))
    :enable add-var)

  (defruled compustate-frames-number-of-write-var-when-not-errorp
    (implies (not (errorp (write-var var val compst)))
             (equal (compustate-frames-number (write-var var val compst))
                    (compustate-frames-number compst)))
    :enable (compustate-frames-number
             write-var
             push-frame
             pop-frame))

  ;; rules about DEREF of COMPUSTATE->HEAP:

  (defruled deref-of-heap-of-add-frame
    (equal (deref ptr (compustate->heap (add-frame fun compst)))
           (deref ptr (compustate->heap compst)))
    :enable (add-frame push-frame))

  (defruled deref-of-heap-of-add-scope
    (equal (deref ptr (compustate->heap (add-scope compst)))
           (deref ptr (compustate->heap compst)))
    :enable (add-scope
             push-frame
             pop-frame))

  (defruled deref-of-heap-of-add-var
    (equal (deref ptr (compustate->heap (add-var var val compst)))
           (deref ptr (compustate->heap compst)))
    :enable (add-var
             push-frame
             pop-frame))

  (defruled deref-of-heap-of-write-var
    (implies (not (errorp (write-var var val compst)))
             (equal (deref ptr (compustate->heap (write-var var val compst)))
                    (deref ptr (compustate->heap compst))))
    :enable (write-var
             push-frame
             pop-frame))

  ;; rules about WRITE-VAR being an error:

  (defruled errorp-of-write-var-when-not-errorp-of-read-var
    (implies (not (errorp (read-var var compst)))
             (equal (errorp (write-var var val compst))
                    (not (equal (type-of-value val)
                                (type-of-value (read-var var compst))))))
    :enable (read-var
             write-var
             errorp-of-write-var-aux-when-not-errorp-of-read-var-aux)
    :prep-lemmas
    ((defruled errorp-of-write-var-aux-when-not-errorp-of-read-var-aux
       (implies (not (errorp (read-var-aux var scopes)))
                (equal (errorp (write-var-aux var val scopes))
                       (not (equal (type-of-value val)
                                   (type-of-value (read-var-aux var scopes))))))
       :enable (read-var-aux
                write-var-aux
                scope-listp-when-scope-list-resultp-and-not-errorp)
       :prep-lemmas
       ((defrule lemma
          (implies (scope-listp x)
                   (not (errorp x)))
          :enable errorp))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defval *atc-symbolic-computation-state-rules*
  :short "List of rewrite rules for symbolic computation states."
  '(push-frame-of-one-empty-scope
    push-frame-of-one-nonempty-scope
    pop-frame-of-add-frame
    pop-frame-of-add-scope
    pop-frame-of-add-var
    enter-scope-of-compustate
    exit-scope-of-add-scope
    exit-scope-of-add-var
    create-var-of-add-frame
    create-var-of-add-scope
    create-var-of-add-var
    read-var-of-add-scope
    read-var-of-add-var
    read-var-of-write-var
    write-var-of-add-scope
    write-var-of-add-var-same
    write-var-of-add-var-diff
    write-var-of-write-var-same
    write-var-of-write-var-less
    write-var-of-read-var-same
    compustate-frames-number-of-add-frame-not-zero
    compustate-frames-number-of-add-scope
    compustate-frames-number-of-add-var
    compustate-frames-number-of-write-var-when-not-errorp
    deref-of-heap-of-add-frame
    deref-of-heap-of-add-scope
    deref-of-heap-of-add-var
    deref-of-heap-of-write-var
    errorp-of-write-var-when-not-errorp-of-read-var))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defsection atc-opener-rules
  :short "Opener rules for the proofs generated by ATC."
  :long
  (xdoc::topstring
   (xdoc::p
    "To symbolically execute  the generated C code,
     we need to unfold the recursive execution functions,
     as well as other recursive functions.")
   (xdoc::p
    "In general, just enabling recursive functions in ACL2
     does not guarantee that their calls will be expanded when desired:
     ACL2 has heuristics to inhibit the unfolding sometimes,
     to avoid infinite loops.
     When the values over which a recursive function recurses are constant,
     as it happens in our symbolic execution,
     then we know that the expansion is always safe,
     but experiments suggest that ACL2's heuristics
     sometimes block those expansions.
     For this reason, it is better to have opener rules,
     i.e. rules that expand function calls,
     according to the function definitions,
     under suitable conditions.")
   (xdoc::p
    "We use the @('defopeners') utility
     from @('[books]/kestrel/utilities/defopeners').
     Compared to the @(tsee defopener) utility,
     @('defopeners') generates multiple opener rules
     (note the plural vs. singular name),
     corresponding to the conditional structure of the function.
     In general, there will be some base cases and some step cases;
     the former have @('base') in the generated rule names,
     while the latter have @('unroll') in the generated rule names.
     The names of the generated rules are automatically obtained
     via the @('defopeners-names') companion tool of @('defopeners').
     While @(tsee defopener) simplifies the expansion, @('defopeners') does not;
     since we use the rules in a symbolic execution,
     we expect that the simplification will take place there.")
   (xdoc::p
    "We generate opener rules for
     all the (singly and mutually) recursive @('exec-...') functions
     except @(tsee exec-fun) (more on this below),
     as well as for @(tsee init-scope).
     The opener rules have hypotheses saying that
     certain arguments are (quoted) constants,
     which is what we expect in the symbolic execution.")
   (xdoc::p
    "We avoid opener rules for @(tsee exec-fun) because
     we use the correctness theorems of callees
     in the correctness proofs of callers.
     Those correctness theorems are expressed in terms of @(tsee exec-fun),
     so we do not want to expand @(tsee exec-fun).
     See the proof generation code for more details.")
   (xdoc::p
    "We collect all the openers rules in a ruleset,
     to make it easier to collect them incrementally as they are introduced."))

  (def-ruleset atc-openers nil)

  (progn
    (defopeners exec-expr-pure
      :hyps ((syntaxp (quotep e)))
      :disable t)
    (add-to-ruleset atc-openers (defopeners-names exec-expr-pure)))

  (progn
    (defopeners exec-expr-pure-list
      :hyps ((syntaxp (quotep es)))
      :disable t)
    (add-to-ruleset atc-openers (defopeners-names exec-expr-pure-list)))

  (progn
    (defopeners exec-expr-call-or-pure
      :hyps ((syntaxp (quotep e)))
      :disable t)
    (add-to-ruleset atc-openers (defopeners-names exec-expr-call-or-pure)))

  (progn
    (defopeners exec-expr-asg
      :hyps ((syntaxp (quotep e)))
      :disable t)
    (add-to-ruleset atc-openers (defopeners-names exec-expr-asg)))

  (progn
    (defopeners exec-stmt
      :hyps ((syntaxp (quotep s)))
      :disable t)
    (add-to-ruleset atc-openers (defopeners-names exec-stmt)))

  (progn
    (defopeners exec-stmt-while
      :hyps ((syntaxp (quote test))
             (syntaxp (quote body)))
      :disable t)
    (add-to-ruleset atc-openers (defopeners-names exec-stmt-while)))

  (progn
    (defopeners exec-block-item
      :hyps ((syntaxp item))
      :disable t)
    (add-to-ruleset atc-openers (defopeners-names exec-block-item)))

  (progn
    (defopeners exec-block-item-list
      :hyps ((syntaxp (quotep items)))
      :disable t)
    (add-to-ruleset atc-openers (defopeners-names exec-block-item-list)))

  (progn
    (defopeners init-scope
      :hyps ((syntaxp formals))
      :disable t)
    (add-to-ruleset atc-openers (defopeners-names init-scope))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(make-event
 `(defval *atc-opener-rules*
    :short "List of opener rules for the proofs generated by ATC."
    :long
    (xdoc::topstring
     (xdoc::p
      "To speed up the proofs,
       we exclude some opener rules that should never apply,
       because they handle error situations that are not supposed to occur.
       Listing their names explicitly is a bit brittle,
       but for now it is the best we can do.
       Experiments sugges that it does speed up some proofs quite a bit."))
    (set-difference-eq
     ',(get-ruleset 'atc-openers (w state))
     '(exec-expr-pure-base-6
       exec-expr-pure-base-7
       exec-expr-pure-base-8
       exec-expr-pure-list-base-2
       exec-stmt-base-1
       exec-stmt-base-6
       exec-stmt-base-8
       exec-stmt-while-base-1
       exec-stmt-while-base-2
       exec-stmt-while-base-4
       exec-block-item-list-base-1
       exec-block-item-list-base-3
       init-scope-base-2))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defval *atc-abstract-syntax-rules*
  :short "List of rules related to the C ASTs."
  :long
  (xdoc::topstring
   (xdoc::p
    "During symbolic execution, the C ASTs being executed are constant.
     In the course of the symbolic execution,
     terms appear with functions applied to quoted AST constants.
     Those can be simplified via the executable counterparts of such functions.
     We collect all such rules here.")
   (xdoc::p
    "These rules were originally all in
     @(tsee *atc-other-executable-counterpart-rules*).
     We have started moving them from there to here;
     more may be moved in the future.")
   (xdoc::p
    "Many of the functions mentioned below are fixtype
     discriminators (i.e. the `kind' functions)
     and deconstructors (i.e. the field accessors):
     clearly, the symbolic execution needs to check and decompose the ASTs.
     There are also a few predicates on ASTs,
     e.g. to check whether a binary operator is strict."))
  '((:e binop-kind)
    (:e binop-purep)
    (:e binop-strictp)
    (:e block-item-declon->get)
    (:e block-item-kind)
    (:e block-item-stmt->get)
    (:e const-int->get)
    (:e const-kind)
    (:e declon->init)
    (:e declon->declor)
    (:e declon->type)
    (:e declor->ident)
    (:e declor->pointerp)
    (:e expr-arrsub->arr)
    (:e expr-arrsub->sub)
    (:e expr-binary->arg1)
    (:e expr-binary->arg2)
    (:e expr-binary->op)
    (:e expr-call->args)
    (:e expr-call->fun)
    (:e expr-cast->type)
    (:e expr-cast->arg)
    (:e expr-cond->else)
    (:e expr-cond->test)
    (:e expr-cond->then)
    (:e expr-const->get)
    (:e expr-ident->get)
    (:e expr-kind)
    (:e expr-unary->arg)
    (:e expr-unary->op)
    (:e iconst->base)
    (:e iconst->type)
    (:e iconst->unsignedp)
    (:e iconst->value)
    (:e iconst-tysuffix-kind)
    (:e param-declon->declor)
    (:e param-declon->type)
    (:e stmt-compound->items)
    (:e stmt-expr->get)
    (:e stmt-if->test)
    (:e stmt-if->then)
    (:e stmt-ifelse->else)
    (:e stmt-ifelse->test)
    (:e stmt-ifelse->then)
    (:e stmt-kind)
    (:e stmt-return->value)
    (:e stmt-while->test)
    (:e stmt-while->body)
    (:e type-kind)
    (:e unop-fix)
    (:e unop-kind)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defval *atc-other-executable-counterpart-rules*
  :short "List of other executable counterpart rules
          for the proofs generated by ATC."
  :long
  (xdoc::topstring
   (xdoc::p
    "These are in addition to the ones in @(tsee *atc-abstract-syntax-rules*).
     More rules may be moved from here to there at some point,
     or moved from here to more specific categories."))
  '((:e binop-fix)
    (:e booleanp)
    (:e expr-fix)
    (:e exprp)
    (:e fun-env-lookup)
    (:e fun-info->body)
    (:e fun-info->params)
    (:e fun-info->result)
    (:e iconst-fix)
    (:e init-fun-env)
    (:e len)
    (:e natp)
    (:e omap::in)
    (:e param-declon-list-fix)
    (:e scope-list-fix)
    (:e scope-listp)
    (:e scopep)
    (:e stmt-fix)
    (:e schar-integerp)
    (:e uchar-integerp)
    (:e sshort-integerp)
    (:e ushort-integerp)
    (:e sint-integerp)
    (:e uint-integerp)
    (:e slong-integerp)
    (:e ulong-integerp)
    (:e sllong-integerp)
    (:e ullong-integerp)
    (:e tyname)
    (:e type-name-to-type)
    (:e type-pointer)
    (:e type-schar)
    (:e type-uchar)
    (:e type-sshort)
    (:e type-ushort)
    (:e type-sint)
    (:e type-uint)
    (:e type-slong)
    (:e type-ulong)
    (:e type-sllong)
    (:e type-ullong)
    (:e valuep)
    (:e value-list-fix)
    (:e value-listp)
    (:e zp)
    (:e <<)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defval *atc-shift-definition-rules*
  :short "List of definition rules for shift operations
          for the proofs generated by ATC."
  :long
  (xdoc::topstring
   (xdoc::p
    "These are the ACL2 functions that model shift operations on C integers.
     They are expanded in proofs because they are defined in terms of
     the ACL2 functions that model shift operations
     on C integers (first argument) and ACL2 integers (second argument).
     We include in this list not only the function themselves,
     but also the ones expressing their guards."))
  (b* ((types (list (type-schar)
                    (type-uchar)
                    (type-sshort)
                    (type-ushort)
                    (type-sint)
                    (type-uint)
                    (type-slong)
                    (type-ulong)
                    (type-sllong)
                    (type-ullong))))
    (atc-shl/shr-names-loop-left-types types types))

  :prepwork

  ((define atc-shl/shr-names-loop-right-types ((ltype typep) (rtypes type-listp))
     :guard (and (type-integerp ltype)
                 (type-integer-listp rtypes))
     :returns (names symbol-listp)
     (cond ((endp rtypes) nil)
           (t (b* ((lfixtype (atc-integer-type-fixtype ltype))
                   (rfixtype (atc-integer-type-fixtype (car rtypes)))
                   (shl (pack 'shl- lfixtype '- rfixtype))
                   (shr (pack 'shr- lfixtype '- rfixtype))
                   (shl-okp (pack shl '-okp))
                   (shr-okp (pack shr '-okp)))
                (list*
                 shl shr shl-okp shr-okp
                 (atc-shl/shr-names-loop-right-types ltype (cdr rtypes)))))))

   (define atc-shl/shr-names-loop-left-types ((ltypes type-listp)
                                              (rtypes type-listp))
     :guard (and (type-integer-listp ltypes)
                 (type-integer-listp rtypes))
     :returns (names symbol-listp)
     (cond ((endp ltypes) nil)
           (t (append
               (atc-shl/shr-names-loop-right-types (car ltypes) rtypes)
               (atc-shl/shr-names-loop-left-types (cdr ltypes) rtypes)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defval *atc-integer-ops-1-conv-definition-rules*
  :short "List of definition rules for operations
          that involve one C integer type
          and that involve conversions."
  :long
  (xdoc::topstring
   (xdoc::p
    "This is for operations on types of rank lower than @('int'):
     these involve conversions in the sense that
     the operand is promoted prior to being operated upon.
     We exclude logical negation from the operations here,
     because that operation does not promote the operand.
     We include the shift operations with ACL2 integers as second arguments.")
   (xdoc::p
    "These functions are all expanded in proofs because
     they are defined in terms of conversions and
     of operations on types of rank at least @('int'):
     this is what the dynamic semantics of C uses."))
  (b* ((types (list (type-schar)
                    (type-uchar)
                    (type-sshort)
                    (type-ushort))))
    (atc-integer-ops-1-conv-names-loop-ops '(plus minus bitnot shl shr) types))

  :prepwork

  ((define atc-integer-ops-1-conv-names-loop-types ((op symbolp)
                                                    (types type-listp))
     :guard (and (member-eq op '(plus minus bitnot shl shr))
                 (type-integer-listp types))
     :returns (name symbol-listp)
     (cond ((endp types) nil)
           (t (b* ((type (car types))
                   (fixtype (atc-integer-type-fixtype type))
                   (names (if (and (eq op 'minus)
                                   (type-signed-integerp type))
                              (list (pack op '- fixtype)
                                    (pack op '- fixtype '-okp))
                            (list (pack op '- fixtype))))
                   (more-names
                    (atc-integer-ops-1-conv-names-loop-types op (cdr types))))
                (append names more-names)))))

   (define atc-integer-ops-1-conv-names-loop-ops ((ops symbol-listp)
                                                  (types type-listp))
     :guard (and (subsetp-eq ops '(plus minus bitnot shl shr))
                 (type-integer-listp types))
     :returns (names symbol-listp)
     (cond ((endp ops) nil)
           (t (append
               (atc-integer-ops-1-conv-names-loop-types (car ops) types)
               (atc-integer-ops-1-conv-names-loop-ops (cdr ops) types)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defval *atc-integer-ops-2-conv-definition-rules*
  :short "List of definition rules for operations
          that involve two C integer types
          and that involve conversions."
  :long
  (xdoc::topstring
   (xdoc::p
    "This is for operations on types that differ
     or that have rank lower than @('int'):
     these involve conversions in the sense that
     the operands are subjected to the usual arithmetic conversions
     prior to being operated upon.")
   (xdoc::p
    "These functions are all expanded in proofs because
     they are defined in terms of conversions and
     of operations on equal types of rank at least @('int'):
     this is what the dynamic semantics of C uses."))
  (b* ((ops (list 'add 'sub 'mul 'div 'rem
                  'lt 'gt 'le 'ge 'eq 'ne
                  'bitand 'bitxor 'bitior))
       (types (list (type-schar)
                    (type-uchar)
                    (type-sshort)
                    (type-ushort)
                    (type-sint)
                    (type-uint)
                    (type-slong)
                    (type-ulong)
                    (type-sllong)
                    (type-ullong))))
    (atc-integer-ops-2-conv-names-loop-ops ops types types))

  :prepwork

  ((define atc-integer-ops-2-conv-names-loop-right-types ((op symbolp)
                                                          (ltype typep)
                                                          (rtypes type-listp))
     :guard (and (member-eq op (list 'add 'sub 'mul 'div 'rem
                                     'lt 'gt 'le 'ge 'eq 'ne
                                     'bitand 'bitxor 'bitior))
                 (type-integerp ltype)
                 (type-integer-listp rtypes))
     :returns (names symbol-listp)
     (cond
      ((endp rtypes) nil)
      (t (b* ((rtype (car rtypes))
              (type (if (member-eq op '(lt gt le ge eq ne))
                        (type-sint)
                      (uaconvert-types ltype rtype)))
              ((when (and (equal type ltype)
                          (equal type rtype)))
               (atc-integer-ops-2-conv-names-loop-right-types op
                                                              ltype
                                                              (cdr rtypes)))
              (lfixtype (atc-integer-type-fixtype ltype))
              (rfixtype (atc-integer-type-fixtype rtype))
              (names (if (or (member-eq op '(div rem))
                             (and (type-signed-integerp type)
                                  (member-eq op '(add sub mul))))
                         (list (pack op '- lfixtype '- rfixtype)
                               (pack op '- lfixtype '- rfixtype '-okp))
                       (list (pack op '- lfixtype '- rfixtype))))
              (more-names
               (atc-integer-ops-2-conv-names-loop-right-types
                op
                ltype
                (cdr rtypes))))
           (append names more-names))))
     :guard-hints (("Goal" :in-theory (enable type-arithmeticp type-realp))))

   (define atc-integer-ops-2-conv-names-loop-left-types ((op symbolp)
                                                         (ltypes type-listp)
                                                         (rtypes type-listp))
     :guard (and (member-eq op (list 'add 'sub 'mul 'div 'rem
                                     'lt 'gt 'le 'ge 'eq 'ne
                                     'bitand 'bitxor 'bitior))
                 (type-integer-listp ltypes)
                 (type-integer-listp rtypes))
     :returns (names symbol-listp)
     (cond ((endp ltypes) nil)
           (t (append
               (atc-integer-ops-2-conv-names-loop-right-types op
                                                              (car ltypes)
                                                              rtypes)
               (atc-integer-ops-2-conv-names-loop-left-types op
                                                             (cdr ltypes)
                                                             rtypes)))))

   (define atc-integer-ops-2-conv-names-loop-ops ((ops symbol-listp)
                                                  (ltypes type-listp)
                                                  (rtypes type-listp))
     :guard (and (subsetp-eq ops (list 'add 'sub 'mul 'div 'rem
                                       'lt 'gt 'le 'ge 'eq 'ne
                                       'bitand 'bitxor 'bitior))
                 (type-integer-listp ltypes)
                 (type-integer-listp rtypes))
     :returns (names symbol-listp)
     (cond ((endp ops) nil)
           (t (append
               (atc-integer-ops-2-conv-names-loop-left-types (car ops)
                                                             ltypes
                                                             rtypes)
               (atc-integer-ops-2-conv-names-loop-ops (cdr ops)
                                                      ltypes
                                                      rtypes)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defval *atc-array-definition-rules*
  :short "List of definition rules for array operations
          for the proofs generated by ATC."
  :long
  (xdoc::topstring
   (xdoc::p
    "These are the ACL2 functions that model
     array operations involving indices of C integer types.
     They are expanded in in proofs because they are defined in terms of
     the ACL2 functions that model
     array ooperations involving indices that are ACL2 integers.
     We include in this list not only the function themselves,
     but also the ones expressing their guards."))
  (b* ((types (list (type-schar)
                    (type-uchar)
                    (type-sshort)
                    (type-ushort)
                    (type-sint)
                    (type-uint)
                    (type-slong)
                    (type-ulong)
                    (type-sllong)
                    (type-ullong))))
    (atc-array-ops-names-loop-element-types types types))

  :prepwork

  ((define atc-array-ops-names-loop-index-types ((etype typep)
                                                 (itypes type-listp))
     :guard (and (type-integerp etype)
                 (type-integer-listp itypes))
     :returns (names symbol-listp)
     (cond ((endp itypes) nil)
           (t (b* ((efixtype (atc-integer-type-fixtype etype))
                   (ifixtype (atc-integer-type-fixtype (car itypes)))
                   (indexokp (pack efixtype '-array- ifixtype '-index-okp))
                   (read (pack efixtype '-array-read- ifixtype))
                   (write (pack efixtype '-array-write- ifixtype)))
                (list*
                 indexokp read write
                 (atc-array-ops-names-loop-index-types etype (cdr itypes)))))))

   (define atc-array-ops-names-loop-element-types ((etypes type-listp)
                                                   (itypes type-listp))
     :guard (and (type-integer-listp etypes)
                 (type-integer-listp itypes))
     :returns (names symbol-listp)
     (cond ((endp etypes) nil)
           (t
            (append
             (atc-array-ops-names-loop-index-types (car etypes) itypes)
             (atc-array-ops-names-loop-element-types (cdr etypes) itypes)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defval *atc-other-definition-rules*
  :short "List of other definition rules for the proofs generated by ATC."
  :long
  (xdoc::topstring
   (xdoc::p
    "These are designated as `other' with respect to the definition rules
     for shifts and other operations that are collected separately.")
   (xdoc::p
    "During symbolic execution, terms appear
     with certain non-recursive functions applied to
     terms that are not constant, but contain constant parts.
     These can be simplified by opening the function definition,
     which ACL2's heuristics (we believe) should never block,
     given that they are not recursive.
     Some are @('exec-...') functions,
     others are functions to manipulate the frame stack,
     etc.")
   (xdoc::p
    "We expand @(tsee condexpr) because it is just a wrapper
     that signifies a conditional expression instead of statement.")
   (xdoc::p
    "It may seem surprising that
     we expand functions like @(tsee sint-dec-const),
     since those correspond to C constructs;
     we certainly do not expand functions like @(tsee add-sint-sint).
     The reason is that functions like @(tsee sint-dec-const)
     are used to represent C constants in ACL2 functions,
     but in the dynamic semantics,
     @(tsee exec-iconst) (which we expand, obviously)
     produces terms of the form @('(sint <quoted-integer>)').
     By expanding @(tsee sint-dec-const) in the ACL2 functions,
     we produce terms of the form @('(sint <quoted-integer>)'),
     which therefore match the ones from @(tsee exec-iconst).")
   (xdoc::p
    "We do not expand any fixtype constructors.
     This is because such expansions would expose
     the internal representational details of the fixtype's values.
     Instead, we want to operate on those as more abstract entities,
     and use deconstructors to obtain their components.
     In fact, as explained elsewhere,
     we enable rules that simplify
     applications of deconstructors to constructors.")
   (xdoc::p
    "We expand @(tsee sint-from-boolean),
     because it is really just an abbreviation.
     In fact, we want to expose its @(tsee if) structure
     in the symbolic execution."))
  '(condexpr
    declar
    assign
    exec-iconst
    exec-const
    exec-ident
    exec-plus
    exec-minus
    exec-bitnot
    exec-lognot
    exec-unary
    exec-mul
    exec-div
    exec-rem
    exec-add
    exec-sub
    exec-shl
    exec-shr
    exec-lt
    exec-gt
    exec-le
    exec-ge
    exec-eq
    exec-ne
    exec-bitand
    exec-bitxor
    exec-bitior
    exec-binary-strict-pure
    exec-test
    exec-integer
    exec-binary-logand
    exec-binary-logor
    exec-binary-pure
    exec-cast
    exec-arrsub
    promote-value
    sint-from-boolean
    sint-dec-const
    sint-oct-const
    sint-hex-const
    uint-dec-const
    uint-oct-const
    uint-hex-const
    slong-dec-const
    slong-oct-const
    slong-hex-const
    ulong-dec-const
    ulong-oct-const
    ulong-hex-const
    sllong-dec-const
    sllong-oct-const
    sllong-hex-const
    ullong-dec-const
    ullong-oct-const
    ullong-hex-const
    type-of-value
    uaconvert-values
    value-unsigned-integerp
    value-signed-integerp
    value-integerp
    value-realp
    value-arithmeticp
    value-scalarp))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defsection atc-distributivity-over-if-rewrite-rules
  :short "Rewrite rules about certain functions distributing over @(tsee if)."

  (defruled car-of-if
    (equal (car (if a b c))
           (if a (car b) (car c))))

  (defruled mv-nth-of-if
    (equal (mv-nth n (if a b c))
           (if a (mv-nth n b) (mv-nth n c))))

  (defruled len-of-if
    (equal (len (if a b c))
           (if a (len b) (len c))))

  (defruled errorp-of-if
    (equal (errorp (if a b c))
           (if a (errorp b) (errorp c))))

  (defruled valuep-of-if
    (equal (valuep (if a b c))
           (if a (valuep b) (valuep c))))

  (defruled scharp-of-if
    (equal (scharp (if a b c))
           (if a (scharp b) (scharp c))))

  (defruled ucharp-of-if
    (equal (ucharp (if a b c))
           (if a (ucharp b) (ucharp c))))

  (defruled sshortp-of-if
    (equal (sshortp (if a b c))
           (if a (sshortp b) (sshortp c))))

  (defruled ushortp-of-if
    (equal (ushortp (if a b c))
           (if a (ushortp b) (ushortp c))))

  (defruled sintp-of-if
    (equal (sintp (if a b c))
           (if a (sintp b) (sintp c))))

  (defruled uintp-of-if
    (equal (uintp (if a b c))
           (if a (uintp b) (uintp c))))

  (defruled slongp-of-if
    (equal (slongp (if a b c))
           (if a (slongp b) (slongp c))))

  (defruled ulongp-of-if
    (equal (ulongp (if a b c))
           (if a (ulongp b) (ulongp c))))

  (defruled sllongp-of-if
    (equal (sllongp (if a b c))
           (if a (sllongp b) (sllongp c))))

  (defruled ullongp-of-if
    (equal (ullongp (if a b c))
           (if a (ullongp b) (ullongp c))))

  (defruled pointerp-of-if
    (equal (pointerp (if a b c))
           (if a (pointerp b) (pointerp c))))

  (defruled compustate->frames-of-if
    (equal (compustate->frames (if a b c))
           (if a (compustate->frames b) (compustate->frames c))))

  (defruled scope-fix-of-if
    (equal (scope-fix (if a b c))
           (if a (scope-fix b) (scope-fix c))))

  (defruled value-result-fix-of-if
    (equal (value-result-fix (if a b c))
           (if a (value-result-fix b) (value-result-fix c)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defval *atc-distributivity-over-if-rewrite-rules*
  :short "List of rewrite rules about
          certain functions distributing over @(tsee if)."
  '(car-of-if
    mv-nth-of-if
    len-of-if
    errorp-of-if
    valuep-of-if
    scharp-of-if
    ucharp-of-if
    sshortp-of-if
    ushortp-of-if
    sintp-of-if
    uintp-of-if
    slongp-of-if
    ulongp-of-if
    sllongp-of-if
    ullongp-of-if
    pointerp-of-if
    compustate->frames-of-if
    scope-fix-of-if
    value-result-fix-of-if))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defsection atc-identifier-rules
  :short "Rules related to C identifiers."
  :long
  (xdoc::topstring
   (xdoc::p
    "During symbolic execution, C identifiers in the computation state
     always have the form @('(ident <string>)'),
     where @('<string>') is a quoted string constant.
     To keep them in this form, we leave @(tsee ident) disabled.
     Since the symbolic execution
     sometimes applies @(tsee ident-fix) to identifiers,
     we enable @('ident-fix-when-identp') and @('identp-of-ident'),
     so that @(tsee ident-fix) can be rewritten away.
     Sometimes the symbolic execution produces equalities over identifiers:
     we introduce a rule that reduces those to equalities over strings.
     Since the latter equalities involve the string fixer,
     we enable its executable counterpart.
     Similarly, sometimes the symbolic execution produces
     calls of @(tsee <<) over identifiers:
     we introduce a rule that reduces those to @(tsee <<) over strings.")
   (xdoc::p
    "In the course of symbolic execution,
     terms appears of the form @('(exec-fun <ident> ...)'),
     where @('<ident>') is a quoted identifier constant,
     obtained by the C ASTs being executed.
     This @('<ident>') does not have the form @('(ident <string>'));
     we introduce and enable a rule
     to turn @('<ident>') into @('(ident <string>')
     when it appears in @(tsee exec-fun).
     We introduce similar rules for terms of the form
     @('(create-var <ident> ...)'),
     @('(read-var <ident> ...)'), and
     @('(write-var <ident> ...)')."))

  (defruled equal-of-ident-and-ident
    (equal (equal (ident x)
                  (ident y))
           (equal (str-fix x)
                  (str-fix y))))

  (defruled <<-of-ident-and-ident
    (equal (<< (ident x)
               (ident y))
           (<< (str-fix x)
               (str-fix y)))
    :enable (<< lexorder ident))

  (defruled exec-fun-of-const-identifier
    (implies (and (syntaxp (quotep fun))
                  (c::identp fun))
             (equal (exec-fun fun
                              args compst fenv limit)
                    (exec-fun (ident (ident->name fun))
                              args compst fenv limit))))

  (defruled create-var-of-const-identifier
    (implies (and (syntaxp (quotep var))
                  (c::identp var))
             (equal (create-var var val compst)
                    (create-var (ident (ident->name var)) val compst))))

  (defruled read-var-of-const-identifier
    (implies (and (syntaxp (quotep var))
                  (c::identp var))
             (equal (read-var var compst)
                    (read-var (ident (ident->name var)) compst))))

  (defruled write-var-of-const-identifier
    (implies (and (syntaxp (quotep var))
                  (c::identp var))
             (equal (write-var var val compst)
                    (write-var (ident (ident->name var)) val compst)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defval *atc-identifier-rules*
  :short "List of rules related to C identifiers."
  :long
  (xdoc::topstring
   (xdoc::p
    "See @(see atc-identifier-rules)."))
  '(ident-fix-when-identp
    identp-of-ident
    equal-of-ident-and-ident
    <<-of-ident-and-ident
    (:e str-fix)
    exec-fun-of-const-identifier
    create-var-of-const-identifier
    read-var-of-const-identifier
    write-var-of-const-identifier))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defsection atc-function-environment-rules
  :short "Rules related to C function environments."
  :long
  (xdoc::topstring
   (xdoc::p
    "In the course of the symbolic execution,
     C functions must be looked up by name in the function environment.
     Since, as explaiend in @(tsee atc-identifier-rules),
     we keep identifiers in the form @('(ident <string>)'),
     we cannot simply use the executable counterpart of @(tsee fun-env-lookup).
     Instead, we enable @(tsee fun-env-lookup), which uses @(tsee omap::in);
     so we introduce and enable opener rules for @(tsee omap::in),
     restricting them to the case in which the map is
     a quoted function environment constant.
     In order to resolve the comparison between @('(ident <string>'))
     and the quoted identifiers in the function environment,
     we prove and enable the rule @('equal-of-ident-and-const') below.
     We also need to enable a few executable counterparts of functions,
     in order to resolve the look up in the function environment.
     See @(tsee *atc-function-environment-rules*).")
   (xdoc::p
    "This treatment of function environment lookups is somewhat temporary.
     We plan to treat them in a more general way at some point."))

  (defopeners omap::in
    :hyps ((syntaxp (and (quotep omap::map)
                         (fun-envp (cadr omap::map)))))
    :disable t)

  (defruled equal-of-ident-and-const
    (implies (and (syntaxp (and (quotep x)
                                (quotep c)))
                  (identp c))
             (equal (equal (ident x) c)
                    (equal (str-fix x)
                           (ident->name c))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defval *atc-function-environment-rules*
  :short "List of rules related to function environments."
  '(omap::in-base-1
    omap::in-base-2
    omap::in-unroll
    fun-env-lookup
    equal-of-ident-and-const
    (:e c::fun-env-fix)
    (:e omap::empty)
    (:e omap::head)
    (:e omap::tail)
    (:e c::identp)
    (:e c::ident->name)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defsection atc-other-rewrite-rules
  :short "Other rewrite rules for the proofs generated by ATC."
  :long
  (xdoc::topstring
   (xdoc::p
    "These are designated as `other' with respect to the rewrite rules
     for openers etc., which are collected separately.")
   (xdoc::p
    "During symbolic execution, certain term patterns appear,
     which are amenable to simplification via the following rewrite rules.
     These are non-opener rewrite rules; opener rules are considered separately
     (see @(tsee atc-opener-rules)).")
   (xdoc::p
    "The following rules are general
     and should be probably moved to a more general place.
     For now we put them here, disabled.")
   (xdoc::p
    "Some of the following rewrite rules, in combinations with external ones,
     may exhibit backchaining circularities.
     However, it looks like ACL2's ancestor checks
     should avoid actual circularities,
     in effect limiting the application of
     different partial ``arcs'' of the circles in different situations.
     Anyways, this is being flagged here as something to watch for.")
   (xdoc::p
    "The rule @('c::len-of-cons') below
     is a duplicate of @('acl2::len-of-cons')
     from at least two list libraries,
     but this way we avoid having this file depend on those list libraries;
     the theorem is very simple and small,
     so it is not a lot of duplication.")
   (xdoc::p
    "We also have two rules to simplify applications of
     @(tsee boolean-from-sint) to @('(sint 0)') and @('(sint 1)').
     These applications appear during symbolic execution,
     because in C certain ``boolean'' expressions produce those @('int') values,
     and @(tsee boolean-from-sint) is used to turn those into ACL2 booleans,
     which are uses in @(tsee if)s,
     and thus we clearly want to simplify those application
     to @('t') and @('nil'), which further simplifies the @(tsee if)s.")
   (xdoc::p
    "We also have two rules to simplify applications of
     @(tsee lognot-sint) to @('(sint 0)') and @('(sint 1)').
     Terms of this form may arise in the process of simplifying
     C non-strict expressions involving @('&&') and @('||').")
   (xdoc::p
    "We also found it necessary to include rules
     to distribute two specific functions over @(tsee if)s.
     It seems that, in the course of these symbolic execution proofs,
     we will always want to distribute functions over @(tsee if)s.
     This distribution happens at the goal level,
     but not in the rewriter by default.")
   (xdoc::p
    "The two @('not-zp-of-limit-...') rules
     serve to relieve the recurring hypothesis
     that the limit is never 0 during the symbolic execution.
     Initially the limit is a variable, and the first rule applies;
     the hypothesis of this rule is easily discharged by
     the inequality assumption over the initial limit
     in the symbolic execution theorem,
     via ACL2's linear arithmetic.
     The @(tsee syntaxp) hypothesis restricts the application of the rule
     to the case in which the limit is a variable (which is true initially).
     As the symbolic execution proceeds,
     1 gets repeatedly subtracted from the initial limit variable,
     and it appears that ACL2 automatically combines multiple 1s
     into constants larger than 1,
     giving the pattern @('(binary-+ \'<negative-integer> <limit-variable>)').
     This is the pattern in the second rule @('not-zp-of-limit-...'),
     whose hypothesis about the limit variable
     is easily discharged via linear arithmetic."))

  (defruled not-zp-of-limit-variable
    (implies (and (syntaxp (symbolp limit))
                  (integerp limit)
                  (> limit 0))
             (not (zp limit))))

  (defruled not-zp-of-limit-minus-const
    (implies (and (syntaxp (quotep -c))
                  (integerp -c)
                  (< -c 0)
                  (integerp limit)
                  (> limit (- -c)))
             (not (zp (binary-+ -c limit)))))

  (defruled value-result-fix-when-valuep
    (implies (valuep x)
             (equal (value-result-fix x)
                    x)))

  (defruled not-errorp-when-valuep
    (implies (valuep x)
             (not (errorp x)))
    :enable (errorp
             valuep
             ucharp
             scharp
             ushortp
             sshortp
             uintp
             sintp
             ulongp
             slongp
             ullongp
             sllongp
             pointerp))

  (defruled not-errorp-when-value-listp
    (implies (value-listp x)
             (not (errorp x)))
    :enable errorp)

  (defruled not-errorp-when-scopep
    (implies (scopep x)
             (not (errorp x)))
    :enable (errorp scopep))

  (defruled not-errorp-when-scope-listp
    (implies (scope-listp x)
             (not (errorp x)))
    :enable errorp)

  (defruled not-errorp-when-schar-arrayp
    (implies (schar-arrayp x)
             (not (errorp x)))
    :enable (errorp schar-arrayp))

  (defruled not-errorp-when-uchar-arrayp
    (implies (uchar-arrayp x)
             (not (errorp x)))
    :enable (errorp uchar-arrayp))

  (defruled not-errorp-when-sshort-arrayp
    (implies (sshort-arrayp x)
             (not (errorp x)))
    :enable (errorp sshort-arrayp))

  (defruled not-errorp-when-ushort-arrayp
    (implies (ushort-arrayp x)
             (not (errorp x)))
    :enable (errorp ushort-arrayp))

  (defruled not-errorp-when-sint-arrayp
    (implies (sint-arrayp x)
             (not (errorp x)))
    :enable (errorp sint-arrayp))

  (defruled not-errorp-when-uint-arrayp
    (implies (uint-arrayp x)
             (not (errorp x)))
    :enable (errorp uint-arrayp))

  (defruled not-errorp-when-slong-arrayp
    (implies (slong-arrayp x)
             (not (errorp x)))
    :enable (errorp slong-arrayp))

  (defruled not-errorp-when-ulong-arrayp
    (implies (ulong-arrayp x)
             (not (errorp x)))
    :enable (errorp ulong-arrayp))

  (defruled not-errorp-when-sllong-arrayp
    (implies (sllong-arrayp x)
             (not (errorp x)))
    :enable (errorp sllong-arrayp))

  (defruled not-errorp-when-ullong-arrayp
    (implies (ullong-arrayp x)
             (not (errorp x)))
    :enable (errorp ullong-arrayp))

  (defruled not-errorp-when-booleanp
    (implies (booleanp x)
             (not (errorp x)))
    :enable errorp)

  (defruled boolean-from-sint-of-0
    (equal (boolean-from-sint (sint 0)) nil))

  (defruled boolean-from-sint-of-1
    (equal (boolean-from-sint (sint 1)) t))

  (defruled lognot-sint-of-0
    (equal (lognot-sint (sint 0))
           (sint 1)))

  (defruled lognot-sint-of-1
    (equal (lognot-sint (sint 1))
           (sint 0))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defval *atc-other-rewrite-rules*
  :short "List of rewrite rules proved in @(see atc-other-rewrite-rules)."
  '(not-zp-of-limit-variable
    not-zp-of-limit-minus-const
    value-result-fix-when-valuep
    not-errorp-when-valuep
    not-errorp-when-value-listp
    not-errorp-when-scopep
    not-errorp-when-scope-listp
    not-errorp-when-schar-arrayp
    not-errorp-when-uchar-arrayp
    not-errorp-when-sshort-arrayp
    not-errorp-when-ushort-arrayp
    not-errorp-when-sint-arrayp
    not-errorp-when-uint-arrayp
    not-errorp-when-slong-arrayp
    not-errorp-when-ulong-arrayp
    not-errorp-when-sllong-arrayp
    not-errorp-when-ullong-arrayp
    not-errorp-when-booleanp
    boolean-from-sint-of-0
    boolean-from-sint-of-1
    lognot-sint-of-0
    lognot-sint-of-1))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defval *atc-integer-ops-1-return-rewrite-rules*
  :short "List of rewrite rules for the return types of
          models of C integer operations that involve one C integer type."
  (b* ((ops '(plus minus bitnot lognot shl shr))
       (types (list (type-schar)
                    (type-uchar)
                    (type-sshort)
                    (type-ushort)
                    (type-sint)
                    (type-uint)
                    (type-slong)
                    (type-ulong)
                    (type-sllong)
                    (type-ullong))))
    (atc-integer-ops-1-return-names-loop-ops ops types))

  :prepwork

  ((define atc-integer-ops-1-return-names-loop-types ((op symbolp)
                                                      (types type-listp))
     :guard (and (member-eq op '(plus minus bitnot lognot shl shr))
                 (type-integer-listp types))
     :returns (names symbol-listp)
     (cond
      ((endp types) nil)
      (t (b* ((type (car types))
              (argfixtype (atc-integer-type-fixtype type))
              (restype (if (eq op 'lognot) (type-sint) (promote-type type)))
              (resfixtype (atc-integer-type-fixtype restype))
              (respred (pack resfixtype 'p)))
           (cons (pack respred '-of- op '- argfixtype)
                 (atc-integer-ops-1-return-names-loop-types op (cdr types)))))))

   (define atc-integer-ops-1-return-names-loop-ops ((ops symbol-listp)
                                                    (types type-listp))
     :guard (and (subsetp-eq ops '(plus minus bitnot lognot shl shr))
                 (type-integer-listp types))
     :returns (names symbol-listp)
     (cond ((endp ops) nil)
           (t (append
               (atc-integer-ops-1-return-names-loop-types (car ops) types)
               (atc-integer-ops-1-return-names-loop-ops (cdr ops) types)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defval *atc-integer-ops-2-return-rewrite-rules*
  :short "List of rewrite rules for the return types of
          models of C integer operations that involve two C integer types."
  (b* ((ops (list 'add 'sub 'mul 'div 'rem
                  'lt 'gt 'le 'ge 'eq 'ne
                  'bitand 'bitxor 'bitior))
       (types (list (type-schar)
                    (type-uchar)
                    (type-sshort)
                    (type-ushort)
                    (type-sint)
                    (type-uint)
                    (type-slong)
                    (type-ulong)
                    (type-sllong)
                    (type-ullong))))
    (atc-integer-ops-2-return-names-loop-ops ops types types))

  :prepwork

  ((define atc-integer-ops-2-return-names-loop-right-types ((op symbolp)
                                                            (ltype typep)
                                                            (rtypes type-listp))
     :guard (and (member-eq op (list 'add 'sub 'mul 'div 'rem
                                     'lt 'gt 'le 'ge 'eq 'ne
                                     'bitand 'bitxor 'bitior))
                 (type-integerp ltype)
                 (type-integer-listp rtypes))
     :returns (names symbol-listp)
     (cond
      ((endp rtypes) nil)
      (t (b* ((rtype (car rtypes))
              (type (if (member-eq op '(lt gt le ge eq ne))
                        (type-sint)
                      (uaconvert-types ltype rtype)))
              (lfixtype (atc-integer-type-fixtype ltype))
              (rfixtype (atc-integer-type-fixtype rtype))
              (fixtype (atc-integer-type-fixtype type))
              (pred (pack fixtype 'p)))
           (cons
            (pack pred '-of- op '- lfixtype '- rfixtype)
            (atc-integer-ops-2-return-names-loop-right-types op
                                                             ltype
                                                             (cdr rtypes))))))
     :guard-hints (("Goal" :in-theory (enable type-arithmeticp type-realp))))

   (define atc-integer-ops-2-return-names-loop-left-types ((op symbolp)
                                                           (ltypes type-listp)
                                                           (rtypes type-listp))
     :guard (and (member-eq op (list 'add 'sub 'mul 'div 'rem
                                     'lt 'gt 'le 'ge 'eq 'ne
                                     'bitand 'bitxor 'bitior))
                 (type-integer-listp ltypes)
                 (type-integer-listp rtypes))
     :returns (names symbol-listp)
     (cond ((endp ltypes) nil)
           (t (append
               (atc-integer-ops-2-return-names-loop-right-types op
                                                                (car ltypes)
                                                                rtypes)
               (atc-integer-ops-2-return-names-loop-left-types op
                                                               (cdr ltypes)
                                                               rtypes)))))

   (define atc-integer-ops-2-return-names-loop-ops ((ops symbol-listp)
                                                    (ltypes type-listp)
                                                    (rtypes type-listp))
     :guard (and (subsetp-eq ops (list 'add 'sub 'mul 'div 'rem
                                       'lt 'gt 'le 'ge 'eq 'ne
                                       'bitand 'bitxor 'bitior))
                 (type-integer-listp ltypes)
                 (type-integer-listp rtypes))
     :returns (names symbol-listp)
     (cond ((endp ops) nil)
           (t (append
               (atc-integer-ops-2-return-names-loop-left-types (car ops)
                                                               ltypes
                                                               rtypes)
               (atc-integer-ops-2-return-names-loop-ops (cdr ops)
                                                        ltypes
                                                        rtypes)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defval *atc-integer-convs-return-rewrite-rules*
  :short "List of rewrite rules for the return types of
          models of C integer conversions."
  (b* ((types (list (type-schar)
                    (type-uchar)
                    (type-sshort)
                    (type-ushort)
                    (type-sint)
                    (type-uint)
                    (type-slong)
                    (type-ulong)
                    (type-sllong)
                    (type-ullong))))
    (atc-integer-convs-return-names-loop-src-types types types))

  :prepwork

  ((define atc-integer-convs-return-names-loop-dst-types ((stype typep)
                                                          (dtypes type-listp))
     :guard (and (type-integerp stype)
                 (type-integer-listp dtypes))
     :returns (names symbol-listp)
     (cond
      ((endp dtypes) nil)
      ((equal stype (car dtypes))
       (atc-integer-convs-return-names-loop-dst-types stype
                                                      (cdr dtypes)))
      (t (b* ((sfixtype (atc-integer-type-fixtype stype))
              (dfixtype (atc-integer-type-fixtype (car dtypes)))
              (pred (pack dfixtype 'p)))
           (cons
            (pack pred '-of- dfixtype '-from- sfixtype)
            (atc-integer-convs-return-names-loop-dst-types stype
                                                           (cdr dtypes)))))))

   (define atc-integer-convs-return-names-loop-src-types ((stypes type-listp)
                                                          (dtypes type-listp))
     :guard (and (type-integer-listp stypes)
                 (type-integer-listp dtypes))
     :returns (names symbol-listp)
     (cond ((endp stypes) nil)
           (t (append
               (atc-integer-convs-return-names-loop-dst-types (car stypes)
                                                              dtypes)
               (atc-integer-convs-return-names-loop-src-types (cdr stypes)
                                                              dtypes)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defval *atc-more-rewrite-rules*
  :short "List of more rewrite rules for the proofs generated by ATC."
  :long
  (xdoc::topstring
   (xdoc::p
    "These are rewrite rules in addition to
     the ones in @(see atc-other-rewrite-rules).
     We definitely need better nomenclature than `more' and `other'."))
  '(booleanp-of-boolean-from-uchar
    booleanp-of-boolean-from-schar
    booleanp-of-boolean-from-ushort
    booleanp-of-boolean-from-sshort
    booleanp-of-boolean-from-uint
    booleanp-of-boolean-from-sint
    booleanp-of-boolean-from-ulong
    booleanp-of-boolean-from-slong
    booleanp-of-boolean-from-ullong
    booleanp-of-boolean-from-sllong
    car-cons
    cdr-cons
    compustate-fix-when-compustatep
    compustatep-of-add-frame
    compustatep-of-add-scope
    compustatep-of-add-var
    compustatep-when-compustate-resultp-and-not-errorp
    compustate-resultp-of-write-var
    heap-fix-when-heapp
    heapp-of-compustate->heap
    mv-nth-of-cons
    not-errorp-when-compustatep
    omap::in-of-update
    scopep-of-update
    schar-fix-when-scharp
    uchar-fix-when-ucharp
    sshort-fix-when-sshortp
    ushort-fix-when-ushortp
    sint-fix-when-sintp
    uint-fix-when-uintp
    slong-fix-when-slongp
    ulong-fix-when-ulongp
    sllong-fix-when-sllongp
    ullong-fix-when-ullongp
    scharp-of-schar
    ucharp-of-uchar
    sshortp-of-sshort
    ushortp-of-ushort
    sintp-of-sint
    uintp-of-uint
    slongp-of-slong
    ulongp-of-ulong
    sllongp-of-sllong
    ullongp-of-ullong
    scharp-of-schar-array-read
    ucharp-of-uchar-array-read
    sshortp-of-sshort-array-read
    ushortp-of-ushort-array-read
    sintp-of-sint-array-read
    uintp-of-uint-array-read
    slongp-of-slong-array-read
    ulongp-of-ulong-array-read
    sllongp-of-sllong-array-read
    ullongp-of-ullong-array-read
    valuep-when-pointerp
    valuep-when-scharp
    valuep-when-ucharp
    valuep-when-sshortp
    valuep-when-ushortp
    valuep-when-sintp
    valuep-when-uintp
    valuep-when-slongp
    valuep-when-ulongp
    valuep-when-sllongp
    valuep-when-ullongp
    value-fix-when-valuep
    value-listp-of-cons
    value-list-fix-of-cons
    value-optionp-when-valuep))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defval *atc-integer-ops-1-type-prescription-rules*
  :short "List of type prescription rules for the
          models of C integer operations that involve one C integer type."
  (b* ((ops '(plus minus bitnot lognot shl shr))
       (types (list (type-schar)
                    (type-uchar)
                    (type-sshort)
                    (type-ushort)
                    (type-sint)
                    (type-uint)
                    (type-slong)
                    (type-ulong)
                    (type-sllong)
                    (type-ullong))))
    (atc-integer-ops-1-type-presc-rules-loop-ops ops types))

  :prepwork

  ((define atc-integer-ops-1-type-presc-rules-loop-types ((op symbolp)
                                                          (types type-listp))
     :guard (and (member-eq op '(plus minus bitnot lognot shl shr))
                 (type-integer-listp types))
     :returns (rules true-list-listp)
     (cond
      ((endp types) nil)
      (t (b* ((type (car types))
              (fixtype (atc-integer-type-fixtype type)))
           (cons
            (list :t (pack op '- fixtype))
            (atc-integer-ops-1-type-presc-rules-loop-types op (cdr types)))))))

   (define atc-integer-ops-1-type-presc-rules-loop-ops ((ops symbol-listp)
                                                        (types type-listp))
     :guard (and (subsetp-eq ops '(plus minus bitnot lognot shl shr))
                 (type-integer-listp types))
     :returns (rule true-list-listp)
     (cond
      ((endp ops) nil)
      (t (append
          (atc-integer-ops-1-type-presc-rules-loop-types (car ops) types)
          (atc-integer-ops-1-type-presc-rules-loop-ops (cdr ops) types)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defval *atc-integer-ops-2-type-prescription-rules*
  :short "List of type prescription rules for the
          models of C integer operations that involve two C integer types."
  (b* ((ops (list 'add 'sub 'mul 'div 'rem
                  'lt 'gt 'le 'ge 'eq 'ne
                  'bitand 'bitxor 'bitior))
       (types (list (type-schar)
                    (type-uchar)
                    (type-sshort)
                    (type-ushort)
                    (type-sint)
                    (type-uint)
                    (type-slong)
                    (type-ulong)
                    (type-sllong)
                    (type-ullong))))
    (atc-integer-ops-2-type-presc-rules-loop-ops ops types types))

  :prepwork

  ((define atc-integer-ops-2-type-presc-rules-loop-right-types
     ((op symbolp)
      (ltype typep)
      (rtypes type-listp))
     :guard (and (member-eq op (list 'add 'sub 'mul 'div 'rem
                                     'lt 'gt 'le 'ge 'eq 'ne
                                     'bitand 'bitxor 'bitior))
                 (type-integerp ltype)
                 (type-integer-listp rtypes))
     :returns (rules true-list-listp)
     (cond
      ((endp rtypes) nil)
      (t (b* ((rtype (car rtypes))
              (lfixtype (atc-integer-type-fixtype ltype))
              (rfixtype (atc-integer-type-fixtype rtype)))
           (cons
            (list :t (pack op '- lfixtype '- rfixtype))
            (atc-integer-ops-2-type-presc-rules-loop-right-types
             op
             ltype
             (cdr rtypes))))))
     :guard-hints (("Goal" :in-theory (enable type-arithmeticp type-realp))))

   (define atc-integer-ops-2-type-presc-rules-loop-left-types
     ((op symbolp)
      (ltypes type-listp)
      (rtypes type-listp))
     :guard (and (member-eq op (list 'add 'sub 'mul 'div 'rem
                                     'lt 'gt 'le 'ge 'eq 'ne
                                     'bitand 'bitxor 'bitior))
                 (type-integer-listp ltypes)
                 (type-integer-listp rtypes))
     :returns (rules true-list-listp)
     (cond ((endp ltypes) nil)
           (t (append
               (atc-integer-ops-2-type-presc-rules-loop-right-types op
                                                                    (car ltypes)
                                                                    rtypes)
               (atc-integer-ops-2-type-presc-rules-loop-left-types op
                                                                   (cdr ltypes)
                                                                   rtypes)))))

   (define atc-integer-ops-2-type-presc-rules-loop-ops ((ops symbol-listp)
                                                        (ltypes type-listp)
                                                        (rtypes type-listp))
     :guard (and (subsetp-eq ops (list 'add 'sub 'mul 'div 'rem
                                       'lt 'gt 'le 'ge 'eq 'ne
                                       'bitand 'bitxor 'bitior))
                 (type-integer-listp ltypes)
                 (type-integer-listp rtypes))
     :returns (rules true-list-listp)
     (cond ((endp ops) nil)
           (t (append
               (atc-integer-ops-2-type-presc-rules-loop-left-types (car ops)
                                                                   ltypes
                                                                   rtypes)
               (atc-integer-ops-2-type-presc-rules-loop-ops (cdr ops)
                                                            ltypes
                                                            rtypes)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defval *atc-integer-convs-type-prescription-rules*
  :short "List of type prescription rules for the
          models of C integer conversions."
  (b* ((types (list (type-schar)
                    (type-uchar)
                    (type-sshort)
                    (type-ushort)
                    (type-sint)
                    (type-uint)
                    (type-slong)
                    (type-ulong)
                    (type-sllong)
                    (type-ullong))))
    (atc-integer-convs-type-presc-rules-loop-src-types types types))

  :prepwork

  ((define atc-integer-convs-type-presc-rules-loop-dst-types
     ((stype typep)
      (dtypes type-listp))
     :guard (and (type-integerp stype)
                 (type-integer-listp dtypes))
     :returns (rules true-list-listp)
     (cond
      ((endp dtypes) nil)
      ((equal stype (car dtypes))
       (atc-integer-convs-type-presc-rules-loop-dst-types stype
                                                          (cdr dtypes)))
      (t (b* ((sfixtype (atc-integer-type-fixtype stype))
              (dfixtype (atc-integer-type-fixtype (car dtypes))))
           (cons
            (list :t (pack dfixtype '-from- sfixtype))
            (atc-integer-convs-type-presc-rules-loop-dst-types
             stype
             (cdr dtypes)))))))

   (define atc-integer-convs-type-presc-rules-loop-src-types
     ((stypes type-listp)
      (dtypes type-listp))
     :guard (and (type-integer-listp stypes)
                 (type-integer-listp dtypes))
     :returns (rules true-list-listp)
     (cond ((endp stypes) nil)
           (t (append
               (atc-integer-convs-type-presc-rules-loop-dst-types (car stypes)
                                                                  dtypes)
               (atc-integer-convs-type-presc-rules-loop-src-types (cdr stypes)
                                                                  dtypes)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defval *atc-type-prescription-rules*
  :short "List of type prescription rules for the proofs generated by ATC."
  :long
  (xdoc::topstring
   (xdoc::p
    "In the dynamic semantics, the execution of statements and other entities
     returns @(tsee mv) values, which logically satisfy @(tsee consp);
     the negated application of @(tsee consp) to those execution functions
     comes up in certain subgoals,
     so a simple way to discharge those subgoals
     is to use the type prescription rules for those execution functions.")
   (xdoc::p
    "We also need rules about the constructors of C integer values
     and the C functions that represent C operations and conversions,
     including array read operations."))
  (append
   '((:t exec-expr-call-or-pure)
     (:t exec-fun)
     (:t exec-stmt)
     (:t exec-block-item)
     (:t exec-block-item-list)
     (:t schar)
     (:t uchar)
     (:t sshort)
     (:t ushort)
     (:t sint)
     (:t uint)
     (:t slong)
     (:t ulong)
     (:t sllong)
     (:t ullong)
     (:t schar-array-read)
     (:t uchar-array-read)
     (:t sshort-array-read)
     (:t ushort-array-read)
     (:t sint-array-read)
     (:t uint-array-read)
     (:t slong-array-read)
     (:t ulong-array-read)
     (:t sllong-array-read)
     (:t ullong-array-read))
   *atc-integer-ops-1-type-prescription-rules*
   *atc-integer-ops-2-type-prescription-rules*
   *atc-integer-convs-type-prescription-rules*))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defval *atc-compound-recognizer-rules*
  :short "List of compound recognizer rules for the proofs generated by ATC."
  :long
  (xdoc::topstring
   (xdoc::p
    "The type prescription rules in @(tsee *atc-type-prescription-rules*)
     cover all the shallowly embedded C expressions except for variables.
     In the scenarios explained in @(tsee *atc-type-prescription-rules*),
     we may need to establish that a variable is not @('nil'),
     which must follow from the guard hypotheses.
     For this, we use the compound recognizer rule below.
     The fact that the type is @(tsee consp) is actually not important;
     what is important is that it does not include @('nil'),
     i.e. it is logically true."))
  '(consp-when-scharp
    consp-when-ucharp
    consp-when-sshortp
    consp-when-ushortp
    consp-when-sintp
    consp-when-uintp
    consp-when-slongp
    consp-when-ulongp
    consp-when-sllongp
    consp-when-ullongp))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defsection atc-conversion-composition-rules
  :short "Rules about the composition of conversions."
  :long
  (xdoc::topstring
   (xdoc::p
    "The "
    (xdoc::seetopic "atc-integer-operations" "integer operations")
    " operate on all the combinations of integer types for their arguments.
     When the types differ or have rank below @('int'),
     conversions are applied to the arguments
     so that they have the same type of rank @('int') or higher,
     and then the version of the operation
     with homogeneous argument types of rank @('int') or higher
     is applied to the converted operands.
     When the types have smaller rank than @('int'),
     a conversion is applied to both,
     which corresponds to the integer promotions.
     when one of the types has rank @('unsigned int') or higher,
     a single conversion is applied to the ``smaller'' type,
     which corresponds to both an integer promotion
     and the usual arithmetic conversions.
     However, in the C dynamic semantics,
     integer promotions and usual arithmetic conversions
     are separate processed that may produce two conversions in sequence.")
   (xdoc::p
    "For example, @(tsee add-slong-schar) is defined to
     apply @(tsee slong-from-schar) to the second argument
     and then use @(tsee add-slong-slong) to obtain the result.
     If @(tsee add-slong-schar) is used
     in an ACL2 function that represents a C function,
     the @(tsee slong-from-uchar) shows up in the symbolic execution.
     However, in the C counterpart of the operation,
     two conversions show up:
     @(tsee sint-from-schar) from @(tsee promote-value),
     and @(tsee slong-from-sint) from @(tsee uaconvert-values),
     one after the other.")
   (xdoc::p
    "Thus, here we prove theorems saying that
     the conversions that may arise
     from the integer promotions,
     followed by the conversions that may arise
     from the usual arithmetic conversions,
     can be reduced to single conversions
     from the starting type to the ending type.
     In the example above,
     @(tsee sint-from-schar) folowed by @(tsee slong-from-sint)
     is the same as the single @(tsee slong-from-schar).")
   (xdoc::p
    "With these rules,
     the symbolic execution can recognize the equality of
     the execution of the ACL2 function
     and the execution of the C function.")
   (xdoc::p
    "All these rules have @('int') as the intermediate type,
     because that is the target of the integer promotions.
     This depends on the fact that
     we have certain hardwired assumptions
     about relations among sizes of various integer types.
     We should generalize this to accommodate for
     the possibility of integer promotions to yield @('unsigned int') values."))

  ;; unsigned int as final type:

  (defruled uint-from-sint-of-sint-from-schar
    (equal (uint-from-sint (sint-from-schar x))
           (uint-from-schar x))
    :enable (uint-from-sint
             sint-from-schar
             uint-from-schar
             sint-integerp-alt-def))

  (defruled uint-from-sint-of-sint-from-uchar
    (equal (uint-from-sint (sint-from-uchar x))
           (uint-from-uchar x))
    :enable (uint-from-sint
             sint-from-uchar
             uint-from-uchar
             sint-integerp-alt-def))

  (defruled uint-from-sint-of-sint-from-sshort
    (equal (uint-from-sint (sint-from-sshort x))
           (uint-from-sshort x))
    :enable (uint-from-sint
             sint-from-sshort
             uint-from-sshort
             sint-integerp-alt-def))

  (defruled uint-from-sint-of-sint-from-ushort
    (equal (uint-from-sint (sint-from-ushort x))
           (uint-from-ushort x))
    :enable (uint-from-sint
             sint-from-ushort
             uint-from-ushort
             sint-integerp-alt-def))

  ;; signed long as final type:

  (defruled slong-from-sint-of-sint-from-schar
    (equal (slong-from-sint (sint-from-schar x))
           (slong-from-schar x))
    :enable (slong-from-sint
             sint-from-schar
             slong-from-schar
             sint-integerp-alt-def))

  (defruled slong-from-sint-of-sint-from-uchar
    (equal (slong-from-sint (sint-from-uchar x))
           (slong-from-uchar x))
    :enable (slong-from-sint
             sint-from-uchar
             slong-from-uchar
             sint-integerp-alt-def))

  (defruled slong-from-sint-of-sint-from-sshort
    (equal (slong-from-sint (sint-from-sshort x))
           (slong-from-sshort x))
    :enable (slong-from-sint
             sint-from-sshort
             slong-from-sshort
             sint-integerp-alt-def))

  (defruled slong-from-sint-of-sint-from-ushort
    (equal (slong-from-sint (sint-from-ushort x))
           (slong-from-ushort x))
    :enable (slong-from-sint
             sint-from-ushort
             slong-from-ushort
             sint-integerp-alt-def))

  ;; unsigned long as final type:

  (defruled ulong-from-sint-of-sint-from-schar
    (equal (ulong-from-sint (sint-from-schar x))
           (ulong-from-schar x))
    :enable (ulong-from-sint
             sint-from-schar
             ulong-from-schar
             sint-integerp-alt-def))

  (defruled ulong-from-sint-of-sint-from-uchar
    (equal (ulong-from-sint (sint-from-uchar x))
           (ulong-from-uchar x))
    :enable (ulong-from-sint
             sint-from-uchar
             ulong-from-uchar
             sint-integerp-alt-def))

  (defruled ulong-from-sint-of-sint-from-sshort
    (equal (ulong-from-sint (sint-from-sshort x))
           (ulong-from-sshort x))
    :enable (ulong-from-sint
             sint-from-sshort
             ulong-from-sshort
             sint-integerp-alt-def))

  (defruled ulong-from-sint-of-sint-from-ushort
    (equal (ulong-from-sint (sint-from-ushort x))
           (ulong-from-ushort x))
    :enable (ulong-from-sint
             sint-from-ushort
             ulong-from-ushort
             sint-integerp-alt-def))

  ;; signed long long as final type:

  (defruled sllong-from-sint-of-sint-from-schar
    (equal (sllong-from-sint (sint-from-schar x))
           (sllong-from-schar x))
    :enable (sllong-from-sint
             sint-from-schar
             sllong-from-schar
             sint-integerp-alt-def))

  (defruled sllong-from-sint-of-sint-from-uchar
    (equal (sllong-from-sint (sint-from-uchar x))
           (sllong-from-uchar x))
    :enable (sllong-from-sint
             sint-from-uchar
             sllong-from-uchar
             sint-integerp-alt-def))

  (defruled sllong-from-sint-of-sint-from-sshort
    (equal (sllong-from-sint (sint-from-sshort x))
           (sllong-from-sshort x))
    :enable (sllong-from-sint
             sint-from-sshort
             sllong-from-sshort
             sint-integerp-alt-def))

  (defruled sllong-from-sint-of-sint-from-ushort
    (equal (sllong-from-sint (sint-from-ushort x))
           (sllong-from-ushort x))
    :enable (sllong-from-sint
             sint-from-ushort
             sllong-from-ushort
             sint-integerp-alt-def))

  ;; unsigned long long as final type:

  (defruled ullong-from-sint-of-sint-from-schar
    (equal (ullong-from-sint (sint-from-schar x))
           (ullong-from-schar x))
    :enable (ullong-from-sint
             sint-from-schar
             ullong-from-schar
             sint-integerp-alt-def))

  (defruled ullong-from-sint-of-sint-from-uchar
    (equal (ullong-from-sint (sint-from-uchar x))
           (ullong-from-uchar x))
    :enable (ullong-from-sint
             sint-from-uchar
             ullong-from-uchar
             sint-integerp-alt-def))

  (defruled ullong-from-sint-of-sint-from-sshort
    (equal (ullong-from-sint (sint-from-sshort x))
           (ullong-from-sshort x))
    :enable (ullong-from-sint
             sint-from-sshort
             ullong-from-sshort
             sint-integerp-alt-def))

  (defruled ullong-from-sint-of-sint-from-ushort
    (equal (ullong-from-sint (sint-from-ushort x))
           (ullong-from-ushort x))
    :enable (ullong-from-sint
             sint-from-ushort
             ullong-from-ushort
             sint-integerp-alt-def)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defval *atc-conversion-composition-rules*
  :short "List of rules about the composition of conversions."
  '(uint-from-sint-of-sint-from-schar
    uint-from-sint-of-sint-from-uchar
    uint-from-sint-of-sint-from-sshort
    uint-from-sint-of-sint-from-ushort
    slong-from-sint-of-sint-from-schar
    slong-from-sint-of-sint-from-uchar
    slong-from-sint-of-sint-from-sshort
    slong-from-sint-of-sint-from-ushort
    ulong-from-sint-of-sint-from-schar
    ulong-from-sint-of-sint-from-uchar
    ulong-from-sint-of-sint-from-sshort
    ulong-from-sint-of-sint-from-ushort
    sllong-from-sint-of-sint-from-schar
    sllong-from-sint-of-sint-from-uchar
    sllong-from-sint-of-sint-from-sshort
    sllong-from-sint-of-sint-from-ushort
    ullong-from-sint-of-sint-from-schar
    ullong-from-sint-of-sint-from-uchar
    ullong-from-sint-of-sint-from-sshort
    ullong-from-sint-of-sint-from-ushort))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defval *atc-all-rules*
  :short "List of all the (generic) rules for the proofs generated by ATC."
  :long
  (xdoc::topstring
   (xdoc::p
    "These are the ones used in all the generated proofs.
     In addition, each proof includes a few additional rules
     that depend on the specific C-representing ACL2 functions involved.
     See @(see atc-implementation)."))
  (append *atc-symbolic-computation-state-rules*
          *atc-opener-rules*
          *atc-abstract-syntax-rules*
          *atc-other-executable-counterpart-rules*
          *atc-shift-definition-rules*
          *atc-integer-ops-1-conv-definition-rules*
          *atc-integer-ops-2-conv-definition-rules*
          *atc-array-definition-rules*
          *atc-other-definition-rules*
          *atc-distributivity-over-if-rewrite-rules*
          *atc-identifier-rules*
          *atc-function-environment-rules*
          *atc-other-rewrite-rules*
          *atc-integer-ops-1-return-rewrite-rules*
          *atc-integer-ops-2-return-rewrite-rules*
          *atc-integer-convs-return-rewrite-rules*
          *atc-more-rewrite-rules*
          *atc-type-prescription-rules*
          *atc-compound-recognizer-rules*
          *atc-conversion-composition-rules*
          *value-disjoint-rules*))
