defthm

(defun form-of-rewrite-quoted-constant-rule
  (equiv lhs rhs)
  (cond ((and (not (eq equiv 'equal)) (quotep lhs) (quotep rhs)) 1)
    ((and (not (eq equiv 'equal))
       (nvariablep lhs)
       (not (fquotep lhs))
       (symbolp (ffn-symb lhs))
       (cdr lhs)
       (null (cddr lhs))
       (variablep (fargn lhs 1))
       (eq (fargn lhs 1) rhs)) 2)
    ((or (variablep lhs)
       (fquotep lhs)
       (member-eq (ffn-symb lhs) *one-way-unify1-implicit-fns*)) 3)
    (t nil)))

(defun interpret-term-as-rewrite-rule2
  (qc-flg name hyps equiv lhs rhs wrld)
  (cond ((equal lhs rhs) (msg "A ~x0 rule generated from ~x1 is illegal because it rewrites the ~
      term ~x2 to itself!  This can happen even when you submit a rule whose ~
      left and right sides appear to be different, in the case that those two ~
      sides represent the same term (for example, after macroexpansion).  For ~
      general information about rewrite rules in ACL2, see :DOC rewrite.  You ~
      may wish to consider submitting a DEFTHM event ending with ~
      :RULE-CLASSES NIL."
        (if qc-flg
          :rewrite-quoted-constant :rewrite)
        name
        lhs))
    ((and qc-flg
       (not (form-of-rewrite-quoted-constant-rule equiv lhs rhs))) (msg "A :REWRITE-QUOTED-CONSTANT rule generated from ~x0 is illegal because ~
      the conclusion is not compatible with any of the allowed forms.  To be ~
      Form [1], the conclusion must be an equivalence (other than EQUAL) ~
      between two quoted constants.  To be Form [2], the conclusion must be ~
      an equivalence (other than EQUAL) between, on the left, a call of a ~
      monadic function symbol on a variable symbol and, on the right, that ~
      same variable symbol.  To be of Form [3], the conclusion must be an ~
      equivalence relation and the left-hand side must be a variable, a ~
      quoted constant, or a call of one of the function symbols in ~
      *ONE-WAY-UNifY1-IMPLICIT-FNS* so that the left-hand side can match a ~
      quoted constant.  But the conclusion of ~x0 is ~x1."
        name
        (list equiv lhs rhs)))
    ((and (not qc-flg)
       (or (variablep lhs)
         (fquotep lhs)
         (flambda-applicationp lhs))) (msg "A :REWRITE rule generated from ~x0 is illegal because it rewrites the ~
      ~@1 ~x2.  For general information about rewrite rules in ACL2, see :DOC ~
      rewrite."
        name
        (cond ((variablep lhs) "variable symbol")
          ((fquotep lhs) "quoted constant")
          ((flambda-applicationp lhs) "LET-expression")
          (t (er hard
              'interpret-term-as-rewrite-rule2
              "Implementation error: forgot a case.  LHS:~|~x0."
              lhs)))
        lhs))
    (t (let ((bad-synp-hyp-msg (bad-synp-hyp-msg hyps (all-vars lhs) nil wrld)))
        (cond (bad-synp-hyp-msg (msg "A ~x0 rule generated from ~x1 is illegal because ~@2"
              (if qc-flg
                :rewrite-quoted-constant :rewrite)
              name
              bad-synp-hyp-msg))
          (t nil))))))

(defun interpret-term-as-rewrite-rule1
  (term equiv-okp ens wrld)
  (cond ((variablep term) (mv 'iff term term *t* nil))
    ((fquotep term) (mv 'iff term term *t* nil))
    ((member-eq (ffn-symb term) *equality-aliases*) (mv 'equal
        (fargn term 1)
        (remove-lambdas (fargn term 1))
        (fargn term 2)
        nil))
    ((flambdap (ffn-symb term)) (interpret-term-as-rewrite-rule1 (subcor-var (lambda-formals (ffn-symb term))
          (fargs term)
          (lambda-body (ffn-symb term)))
        equiv-okp
        ens
        wrld))
    ((if equiv-okp
       (equivalence-relationp (ffn-symb term) wrld)
       (member-eq (ffn-symb term) '(equal iff))) (let ((lhs (remove-lambdas (fargn term 1))))
        (mv-let (equiv ttree)
          (cond ((eq (ffn-symb term) 'iff) (mv-let (ts ttree)
                (type-set lhs nil nil nil ens wrld nil nil nil)
                (cond ((ts-subsetp ts *ts-boolean*) (mv-let (ts ttree)
                      (type-set (fargn term 2) nil nil nil ens wrld ttree nil nil)
                      (cond ((ts-subsetp ts *ts-boolean*) (mv 'equal ttree))
                        (t (mv 'iff nil)))))
                  (t (mv 'iff nil)))))
            (t (mv (ffn-symb term) nil)))
          (mv equiv (fargn term 1) lhs (fargn term 2) ttree))))
    ((eq (ffn-symb term) 'not) (mv 'equal
        (fargn term 1)
        (remove-lambdas (fargn term 1))
        *nil*
        nil))
    (t (mv-let (ts ttree)
        (type-set term nil nil nil ens wrld nil nil nil)
        (cond ((ts-subsetp ts *ts-boolean*) (mv 'equal term (remove-lambdas term) *t* ttree))
          (t (mv 'iff term (remove-lambdas term) *t* nil)))))))

(defun interpret-term-as-rewrite-rule
  (qc-flg name hyps term ctx ens wrld)
  (mv-let (eqv lhs0 lhs rhs ttree)
    (interpret-term-as-rewrite-rule1 term t ens wrld)
    (let ((msg (interpret-term-as-rewrite-rule2 qc-flg
           name
           hyps
           eqv
           lhs
           rhs
           wrld)))
      (cond (msg (mv-let (eqv2 lhs20 lhs2 rhs2 ttree2)
            (interpret-term-as-rewrite-rule1 term nil ens wrld)
            (cond ((interpret-term-as-rewrite-rule2 qc-flg
                 name
                 hyps
                 eqv2
                 lhs2
                 rhs2
                 wrld) (mv msg eqv lhs0 lhs rhs ttree))
              (t (prog2$ (and ctx
                    (observation-cw ctx
                      "The proposed rewrite rule ~x0 may ~
                                     suggest a conclusion of the form (Equiv ~
                                     Lhs Rhs) where:~|  Equiv: ~x1~|  Lhs:   ~
                                     ~x2~|  Rhs:   ~x3~|But such a rewrite ~
                                     rule would be illegal, so the conclusion ~
                                     is treated as follows instead.~|  Equiv: ~
                                     ~x4~|  Lhs:   ~x5~|  Rhs:   ~x6~|"
                      name
                      eqv
                      (untranslate lhs nil wrld)
                      (untranslate rhs nil wrld)
                      eqv2
                      (untranslate lhs2 nil wrld)
                      (untranslate rhs2 nil wrld)))
                  (mv nil eqv2 lhs20 lhs2 rhs2 ttree2))))))
        (t (mv nil eqv lhs0 lhs rhs ttree))))))

(defun non-recursive-fnnames-alist
  (term ens wrld)
  (reverse (non-recursive-fnnames-alist-rec term ens wrld nil nil)))

(defun non-recursive-fnnames-alist-lst
  (lst ens wrld)
  (reverse (non-recursive-fnnames-alist-rec-lst lst ens wrld nil nil)))

(defun hide-lambdas1
  (formals)
  (cond ((null formals) nil)
    (t (cons (list (car formals) '&) (hide-lambdas1 (cdr formals))))))

(defun hide-lambdas
  (lst)
  (cond ((null lst) nil)
    (t (cons (if (flambdap (car lst))
          (list 'let
            (hide-lambdas1 (lambda-formals (car lst)))
            (lambda-body (car lst)))
          (car lst))
        (hide-lambdas (cdr lst))))))

(defun variantp
  (term1 term2)
  (mv-let (ans unify-subst)
    (one-way-unify term1 term2)
    (cond (ans (let ((range (strip-cdrs unify-subst)))
          (mv (and (symbol-listp range) (no-duplicatesp-equal range))
            unify-subst)))
      (t (mv nil nil)))))

(defun surrounding-fns
  (vars term)
  (cond ((or (variablep term) (fquotep term)) nil)
    (t (let ((ans (surrounding-fns-lst vars (fargs term) (ffn-symb term) nil)))
        (if (eq ans 'has-lambda)
          nil
          ans)))))

(defun loop-stopper1
  (alist vars lhs)
  (cond ((null alist) nil)
    ((member-eq (car (car alist))
       (cdr (member-eq (cdr (car alist)) vars))) (cons (list* (caar alist)
          (cdar alist)
          (surrounding-fns (list (caar alist) (cdar alist)) lhs))
        (loop-stopper1 (cdr alist) vars lhs)))
    (t (loop-stopper1 (cdr alist) vars lhs))))

(defun loop-stopper
  (lhs rhs)
  (mv-let (ans unify-subst)
    (variantp lhs rhs)
    (cond (ans (loop-stopper1 unify-subst (all-vars lhs) lhs))
      (t nil))))

(defun remove-irrelevant-loop-stopper-pairs
  (pairs vars)
  (if pairs
    (if (and (member-eq (caar pairs) vars)
        (member-eq (cadar pairs) vars))
      (cons (car pairs)
        (remove-irrelevant-loop-stopper-pairs (cdr pairs) vars))
      (remove-irrelevant-loop-stopper-pairs (cdr pairs) vars))
    nil))

(defun put-match-free-value
  (match-free-value rune wrld)
  (cond ((eq match-free-value :all) (global-set 'free-var-runes-all
        (cons rune (global-val 'free-var-runes-all wrld))
        wrld))
    ((eq match-free-value :once) (global-set 'free-var-runes-once
        (cons rune (global-val 'free-var-runes-once wrld))
        wrld))
    ((null match-free-value) wrld)
    (t (er hard
        'put-match-free-value
        "Internal ACL2 error (called put-match-free-value with ~
         match-free-value equal to ~x0).  Please contact the ACL2 implementors."
        match-free-value))))

(defun free-vars-in-hyps
  (hyps bound-vars wrld)
  (cond ((null hyps) nil)
    (t (mv-let (forcep flg)
        (binding-hyp-p (car hyps)
          (pairlis$ bound-vars bound-vars)
          wrld)
        (cond ((and flg (not forcep)) (free-vars-in-hyps (cdr hyps)
              (cons (fargn (car hyps) 1) bound-vars)
              wrld))
          (t (let ((hyp-vars (all-vars (car hyps))))
              (union-eq (set-difference-eq hyp-vars bound-vars)
                (free-vars-in-hyps (cdr hyps)
                  (union-eq hyp-vars bound-vars)
                  wrld)))))))))

(defun free-vars-in-hyps-simple
  (hyps bound-vars)
  (cond ((null hyps) nil)
    (t (let ((hyp-vars (all-vars (car hyps))))
        (union-eq (set-difference-eq hyp-vars bound-vars)
          (free-vars-in-hyps-simple (cdr hyps)
            (union-eq hyp-vars bound-vars)))))))

(defun free-vars-in-fc-hyps
  (triggers hyps concls)
  (if (endp triggers)
    nil
    (let ((vars (all-vars (car triggers))))
      (or (free-vars-in-hyps-simple hyps vars)
        (or (free-vars-in-hyps-simple concls vars)
          (free-vars-in-fc-hyps (cdr triggers) hyps concls))))))

(defun free-vars-in-hyps-considering-bind-free
  (hyps bound-vars wrld)
  (cond ((null hyps) nil)
    (t (mv-let (forcep flg)
        (binding-hyp-p (car hyps)
          (pairlis$ bound-vars bound-vars)
          wrld)
        (cond ((and flg (not forcep)) (free-vars-in-hyps-considering-bind-free (cdr hyps)
              (cons (fargn (car hyps) 1) bound-vars)
              wrld))
          ((and (ffn-symb-p (car hyps) 'synp)
             (not (equal (fargn (car hyps) 1) *nil*))) (cond ((equal (fargn (car hyps) 1) *t*) nil)
              ((and (quotep (fargn (car hyps) 1))
                 (not (collect-non-legal-variableps (cadr (fargn (car hyps) 1))))) (free-vars-in-hyps-considering-bind-free (cdr hyps)
                  (union-eq (cadr (fargn (car hyps) 1)) bound-vars)
                  wrld))
              (t (er hard
                  'free-vars-in-hyps-considering-bind-free
                  "We thought the first argument of synp in this context ~
                       was either 'NIL, 'T, or else a quoted true list of ~
                       variables, but ~x0 is not!"
                  (fargn (car hyps) 1)))))
          (t (let ((hyp-vars (all-vars (car hyps))))
              (union-eq (set-difference-eq hyp-vars bound-vars)
                (free-vars-in-hyps-considering-bind-free (cdr hyps)
                  (union-eq hyp-vars bound-vars)
                  wrld)))))))))

(defun all-vars-in-hyps
  (hyps)
  (cond ((null hyps) nil)
    (t (let ((vars (all-vars-in-hyps (cdr hyps))))
        (cond ((eq vars t) t)
          ((variablep (car hyps)) (add-to-set-eq (car hyps) vars))
          ((fquotep (car hyps)) vars)
          ((eq (ffn-symb (car hyps)) 'synp) (cond ((equal (fargn (car hyps) 1) *nil*) vars)
              ((equal (fargn (car hyps) 1) *t*) t)
              ((and (quotep (fargn (car hyps) 1))
                 (not (collect-non-legal-variableps (cadr (fargn (car hyps) 1))))) (union-eq (cadr (fargn (car hyps) 1)) vars))
              (t (er hard
                  'free-vars-in-hyps-considering-bind-free
                  "We thought the first argument of synp in this context ~
                      was either 'NIL, 'T, or else a quoted true list of ~
                      variables, but ~x0 is not!"
                  (fargn (car hyps) 1)))))
          (t (union-eq (all-vars (car hyps)) vars)))))))

(defun match-free-value
  (match-free hyps pat wrld)
  (or match-free
    (and (free-vars-in-hyps hyps (all-vars pat) wrld)
      (or (match-free-default wrld) :all))))

(defun match-free-fc-value
  (match-free hyps concls triggers wrld)
  (or match-free
    (and (free-vars-in-fc-hyps triggers hyps concls)
      (or (match-free-default wrld) :all))))

(defun rule-backchain-limit-lst
  (backchain-limit-lst hyps wrld flg)
  (cond (backchain-limit-lst (cadr backchain-limit-lst))
    (t (let ((limit (default-backchain-limit wrld flg)))
        (and limit
          (cond ((eq flg :meta) limit)
            (t (make-list (length hyps) :initial-element limit))))))))

(defun create-rewrite-rule
  (qc-flg rune
    nume
    hyps
    equiv
    lhs0
    lhs
    rhs
    loop-stopper-lst
    backchain-limit-lst
    match-free-value
    wrld)
  (let ((hyps (preprocess-hyps hyps wrld)) (loop-stopper (if loop-stopper-lst
          (remove-irrelevant-loop-stopper-pairs (cadr loop-stopper-lst)
            (all-vars lhs))
          (or (loop-stopper lhs rhs)
            (and (not (equal lhs0 lhs)) (loop-stopper lhs0 rhs))))))
    (make rewrite-rule
      :rune rune
      :nume nume
      :hyps hyps
      :equiv equiv
      :lhs lhs
      :var-info (free-varsp lhs nil)
      :rhs rhs
      :subclass (cond (qc-flg 'rewrite-quoted-constant)
        ((and (null hyps)
           (null loop-stopper)
           (abbreviationp nil (all-vars-bag lhs nil) rhs)) 'abbreviation)
        (t 'backchain))
      :heuristic-info (if qc-flg
        (cons (form-of-rewrite-quoted-constant-rule equiv lhs rhs)
          loop-stopper)
        loop-stopper)
      :backchain-limit-lst (rule-backchain-limit-lst backchain-limit-lst
        hyps
        wrld
        :rewrite)
      :match-free match-free-value)))

(defun hyps-that-instantiate-free-vars
  (free-vars hyps)
  (cond ((null free-vars) nil)
    ((intersectp-eq free-vars (all-vars (car hyps))) (cons (car hyps)
        (hyps-that-instantiate-free-vars (set-difference-eq free-vars (all-vars (car hyps)))
          (cdr hyps))))
    (t (hyps-that-instantiate-free-vars free-vars (cdr hyps)))))

(defun maybe-one-way-unify-with-some
  (pat term-lst alist)
  (cond ((endp term-lst) nil)
    ((maybe-one-way-unify pat (car term-lst) alist) t)
    (t (maybe-one-way-unify-with-some pat (cdr term-lst) alist))))

(defun maybe-subsumes
  (cl1 cl2 alist)
  (cond ((null cl1) t)
    ((maybe-one-way-unify-with-some (car cl1) cl2 alist) (maybe-subsumes (cdr cl1) cl2 alist))
    (t nil)))

(defun subsumes-rewrite-rule
  (rule1 rule2 wrld)
  (and (not (eql (car (access rewrite-rule rule1 :heuristic-info)) 2))
    (not (eql (car (access rewrite-rule rule2 :heuristic-info)) 2))
    (refinementp (access rewrite-rule rule1 :equiv)
      (access rewrite-rule rule2 :equiv)
      wrld)
    (mv-let (ans unify-subst)
      (one-way-unify (access rewrite-rule rule1 :lhs)
        (access rewrite-rule rule2 :lhs))
      (and ans
        (maybe-subsumes (access rewrite-rule rule1 :hyps)
          (access rewrite-rule rule2 :hyps)
          unify-subst)
        (eq (subsumes *init-subsumes-count*
            (access rewrite-rule rule1 :hyps)
            (access rewrite-rule rule2 :hyps)
            unify-subst)
          t)))))

(defun find-subsumed-rule-names
  (lst rule ens wrld)
  (cond ((null lst) nil)
    ((and (enabled-numep (access rewrite-rule (car lst) :nume) ens)
       (not (eq (access rewrite-rule (car lst) :subclass) 'meta))
       (not (eq (access rewrite-rule (car lst) :subclass) 'definition))
       (subsumes-rewrite-rule rule (car lst) wrld)) (cons (base-symbol (access rewrite-rule (car lst) :rune))
        (find-subsumed-rule-names (cdr lst) rule ens wrld)))
    (t (find-subsumed-rule-names (cdr lst) rule ens wrld))))

(defun find-subsuming-rule-names
  (lst rule ens wrld)
  (cond ((null lst) nil)
    ((and (enabled-numep (access rewrite-rule (car lst) :nume) ens)
       (not (eq (access rewrite-rule (car lst) :subclass) 'meta))
       (not (eq (access rewrite-rule (car lst) :subclass) 'definition))
       (subsumes-rewrite-rule (car lst) rule wrld)) (cons (base-symbol (access rewrite-rule (car lst) :rune))
        (find-subsuming-rule-names (cdr lst) rule ens wrld)))
    (t (find-subsuming-rule-names (cdr lst) rule ens wrld))))

(defun forced-hyps
  (lst)
  (cond ((null lst) nil)
    ((and (nvariablep (car lst))
       (or (eq (ffn-symb (car lst)) 'force)
         (eq (ffn-symb (car lst)) 'case-split))) (cons (car lst) (forced-hyps (cdr lst))))
    (t (forced-hyps (cdr lst)))))

(defun strip-top-level-nots-and-forces
  (hyps)
  (cond ((null hyps) nil)
    (t (mv-let (not-flg atm)
        (strip-not (if (and (nvariablep (car hyps))
              (or (eq (ffn-symb (car hyps)) 'force)
                (eq (ffn-symb (car hyps)) 'case-split)))
            (fargn (car hyps) 1)
            (car hyps)))
        (declare (ignore not-flg))
        (cons atm (strip-top-level-nots-and-forces (cdr hyps)))))))

(defun free-variable-error?
  (token name ctx wrld state)
  (if (and (null (match-free-default wrld))
      (f-get-global 'match-free-error state))
    (er soft
      ctx
      "The warning above has caused this error in order to make it clear ~
           that there are free variables in ~s0 of a ~x1 rule generated from ~
           ~x2.  This error can be suppressed for the rest of this ACL2 ~
           session by submitting the following form:~|~%~x3~|~%However, you ~
           are advised not to do so until you have read the documentation on ~
           ``free variables'' (see :DOC free-variables) in order to understand ~
           the issues.  In particular, you can supply a :match-free value for ~
           the :rewrite rule class (see :DOC rule-classes) or a default for ~
           the book under development (see :DOC set-match-free-default)."
      (if (eq token :forward-chaining)
        "some trigger term"
        "the hypotheses")
      token
      name
      '(set-match-free-error nil))
    (value nil)))

(defun extend-geneqv-alist
  (var geneqv alist wrld)
  (put-assoc-eq var
    (union-geneqv geneqv (cdr (assoc-eq var alist)) wrld)
    alist))

(defun uncovered-equivs
  (geneqv covered-geneqv wrld)
  (cond ((endp geneqv) nil)
    (t (let ((equiv (access congruence-rule (car geneqv) :equiv)) (rst (uncovered-equivs (cdr geneqv) covered-geneqv wrld)))
        (cond ((geneqv-refinementp equiv covered-geneqv wrld) rst)
          (t (cons equiv rst)))))))

(defun double-rewrite-opportunities
  (hyp-index hyps
    var-geneqv-alist
    final-term
    final-location
    final-geneqv
    ens
    wrld)
  (cond ((endp hyps) (mv-let (var-equivs-alist var-counts var-geneqv-alist)
        (uncovered-equivs-alist final-term
          final-geneqv
          nil
          var-geneqv-alist
          var-geneqv-alist
          nil
          nil
          nil
          ens
          wrld)
        (declare (ignore var-geneqv-alist))
        (if var-equivs-alist
          (list (list* final-location var-equivs-alist var-counts))
          nil)))
    (t (mv-let (forcep bind-flg)
        (binding-hyp-p (car hyps) var-geneqv-alist wrld)
        (let ((hyp (if forcep
               (fargn (car hyps) 1)
               (car hyps))))
          (cond (bind-flg (let* ((equiv (ffn-symb hyp)) (var (fargn hyp 1))
                  (term0 (fargn hyp 2))
                  (term (if (ffn-symb-p term0 'double-rewrite)
                      (fargn term0 1)
                      term0))
                  (new-geneqv (cadr (geneqv-lst equiv *geneqv-iff* nil wrld))))
                (double-rewrite-opportunities (1+ hyp-index)
                  (cdr hyps)
                  (covered-geneqv-alist term
                    new-geneqv
                    nil
                    (assert$ (variablep var)
                      (extend-geneqv-alist var new-geneqv var-geneqv-alist wrld))
                    ens
                    wrld)
                  final-term
                  final-location
                  final-geneqv
                  ens
                  wrld)))
            (t (mv-let (var-equivs-alist var-counts var-geneqv-alist)
                (uncovered-equivs-alist (car hyps)
                  *geneqv-iff*
                  nil
                  var-geneqv-alist
                  var-geneqv-alist
                  t
                  nil
                  nil
                  ens
                  wrld)
                (let ((cdr-result (double-rewrite-opportunities (1+ hyp-index)
                       (cdr hyps)
                       var-geneqv-alist
                       final-term
                       final-location
                       final-geneqv
                       ens
                       wrld)))
                  (if var-equivs-alist
                    (cons (list* (msg "the ~n0 hypothesis" (list hyp-index))
                        var-equivs-alist
                        var-counts)
                      cdr-result)
                    cdr-result))))))))))

(defun show-double-rewrite-opportunities1
  (location var-equivs-alist
    var-count-alist
    token
    name
    max-term-msg
    ctx
    state)
  (cond ((endp var-equivs-alist) state)
    (t (pprogn (let* ((var (caar var-equivs-alist)) (count (let ((pair (assoc-eq var var-count-alist)))
                (assert$ pair (cdr pair)))))
          (warning$ ctx
            ("Double-rewrite")
            `("In a ~x0 rule generated from ~x1~@2, ~
                                  equivalence relation~#3~[ ~&3 is~/s ~&3 ~
                                  are~] maintained at ~n4 problematic ~
                                  occurrence~#5~[~/s~] of variable ~x6 in ~
                                  ~@7, but not at any binding occurrence of ~
                                  ~x6.  Consider replacing ~#5~[that ~
                                  occurrence~/those ~n4 occurrences~] of ~x6 ~
                                  in ~@7 with ~x8.  See :doc double-rewrite ~
                                  for more information on this issue." (:doc double-rewrite)
              (:equivalence-relations ,(CDAR VAR-EQUIVS-ALIST))
              (:location ,LOCATION)
              ,@(AND (NOT (EQUAL MAX-TERM-MSG "")) `((:MAX-TERM-MSG ,MAX-TERM-MSG)))
              (:new-rule ,NAME)
              (:number-of-problematic-occurrences ,COUNT)
              (:rule-class ,TOKEN)
              (:variable ,VAR))
            token
            name
            max-term-msg
            (cdar var-equivs-alist)
            count
            (if (eql count 1)
              0
              1)
            var
            location
            (list 'double-rewrite var)))
        (show-double-rewrite-opportunities1 location
          (cdr var-equivs-alist)
          var-count-alist
          token
          name
          max-term-msg
          ctx
          state)))))

(defun show-double-rewrite-opportunities
  (hyp-var-equivs-counts-alist-pairs token
    name
    max-term-msg
    ctx
    state)
  (cond ((endp hyp-var-equivs-counts-alist-pairs) state)
    (t (pprogn (show-double-rewrite-opportunities1 (caar hyp-var-equivs-counts-alist-pairs)
          (cadar hyp-var-equivs-counts-alist-pairs)
          (cddar hyp-var-equivs-counts-alist-pairs)
          token
          name
          max-term-msg
          ctx
          state)
        (show-double-rewrite-opportunities (cdr hyp-var-equivs-counts-alist-pairs)
          token
          name
          max-term-msg
          ctx
          state)))))

(defun irrelevant-loop-stopper-pairs
  (pairs vars)
  (if pairs
    (if (and (member-eq (caar pairs) vars)
        (member-eq (cadar pairs) vars))
      (irrelevant-loop-stopper-pairs (cdr pairs) vars)
      (cons (car pairs)
        (irrelevant-loop-stopper-pairs (cdr pairs) vars)))
    nil))

(defun non-rec-def-rules-msg-1
  (alist)
  (cond ((endp alist) nil)
    ((null (cdar alist)) (non-rec-def-rules-msg-1 (cdr alist)))
    (t (cons (msg "~x0 is defined with ~x1" (caar alist) (cdar alist))
        (non-rec-def-rules-msg-1 (cdr alist))))))

(defun non-rec-def-rules-msg
  (alist)
  (let ((lst (non-rec-def-rules-msg-1 alist)))
    (cond ((null lst) "")
      (t (msg "  (Note that ~*0"
          (list "impossible" "~@*.)" "~@* and " "~@*, " lst))))))

(defun chk-rewrite-rule-warnings
  (name match-free loop-stopper rule ctx ens wrld state)
  (let* ((token (cond ((eq (access rewrite-rule rule :subclass) 'definition) :definition)
         ((eq (access rewrite-rule rule :subclass)
            'rewrite-quoted-constant) :rewrite-quoted-constant)
         (t :rewrite))) (hyps (access rewrite-rule rule :hyps))
      (lhs (access rewrite-rule rule :lhs))
      (warn-non-rec (not (warning-disabled-p "Non-rec")))
      (non-rec-fns-lhs-alist (and warn-non-rec
          (not (eq token :rewrite-quoted-constant))
          (non-recursive-fnnames-alist lhs ens wrld)))
      (lhs-vars (all-vars lhs))
      (rhs-vars (all-vars (access rewrite-rule rule :rhs)))
      (free-vars (free-vars-in-hyps-considering-bind-free hyps lhs-vars wrld))
      (inst-hyps (hyps-that-instantiate-free-vars free-vars hyps))
      (non-rec-fns-inst-hyps-alist (and warn-non-rec
          (non-recursive-fnnames-alist-lst (strip-top-level-nots-and-forces inst-hyps)
            ens
            wrld)))
      (subsume-check-enabled (not (warning-disabled-p "Subsume")))
      (subsumed-rule-names (and subsume-check-enabled
          (find-subsumed-rule-names (if (eq token :rewrite-quoted-constant)
              (global-val 'rewrite-quoted-constant-rules wrld)
              (getpropc (ffn-symb lhs) 'lemmas nil wrld))
            rule
            ens
            wrld)))
      (subsuming-rule-names (and subsume-check-enabled
          (not (eq token :rewrite-quoted-constant))
          (find-subsuming-rule-names (if (eq token :rewrite-quoted-constant)
              (global-val 'rewrite-quoted-constant-rules wrld)
              (getpropc (ffn-symb lhs) 'lemmas nil wrld))
            rule
            ens
            wrld)))
      (equiv (access rewrite-rule rule :equiv))
      (geneqv (cadr (geneqv-lst equiv nil nil wrld)))
      (double-rewrite-opportunities (and (not (warning-disabled-p "Double-rewrite"))
          (not (eq token :rewrite-quoted-constant))
          (double-rewrite-opportunities 1
            hyps
            (covered-geneqv-alist lhs geneqv nil nil ens wrld)
            (access rewrite-rule rule :rhs)
            "the right-hand side"
            geneqv
            ens
            wrld))))
    (pprogn (cond (double-rewrite-opportunities (show-double-rewrite-opportunities double-rewrite-opportunities
            token
            name
            ""
            ctx
            state))
        (t state))
      (cond (non-rec-fns-lhs-alist (warning$ ctx
            "Non-rec"
            `("A ~x0 rule generated from ~x1 will be triggered only by ~
                    terms containing the function symbol~#2~[ ~&2, which has ~
                    a non-recursive definition.~@3  Unless this definition ~
                    is~/s ~&2, which have non-recursive definitions.~@3  ~
                    Unless these definitions are~] disabled, this rule is ~
                    unlikely ever to be used." (:non-recursive-fns-lhs ,(HIDE-LAMBDAS (STRIP-CARS NON-REC-FNS-LHS-ALIST)))
              (:name ,NAME)
              (:rule-class ,TOKEN))
            token
            name
            (hide-lambdas (strip-cars non-rec-fns-lhs-alist))
            (non-rec-def-rules-msg non-rec-fns-lhs-alist)))
        (t state))
      (er-progn (cond ((and free-vars (null match-free)) (pprogn (warning$ ctx
                "Free"
                `("A ~x0 rule generated from ~x1 contains the free ~
                    variable~#2~[ ~&2.  This variable~/s ~&2.  These ~
                    variables~] will be chosen by searching for ~#3~[an ~
                    instance~/instances~] of ~*4 in the context of the term ~
                    being rewritten.  This is generally a severe restriction ~
                    on the applicability of a ~x0 rule.  See :DOC ~
                    free-variables." (:doc free-variables)
                  (:free-variables ,FREE-VARS)
                  (:instantiated-hyps ,(UNTRANSLATE-LST INST-HYPS T WRLD))
                  (:name ,NAME)
                  (:rule-class ,TOKEN))
                token
                name
                free-vars
                inst-hyps
                (tilde-*-untranslate-lst-phrase inst-hyps nil t wrld))
              (free-variable-error? token name ctx wrld state)))
          (t (value nil)))
        (pprogn (cond ((and free-vars (forced-hyps inst-hyps)) (warning$ ctx
                "Free"
                "For the forced ~#0~[hypothesis~/hypotheses~], ~*1, used ~
                    to instantiate free variables we will search for ~#0~[an ~
                    instance of the argument~/instances of the arguments~] ~
                    rather than ~#0~[an instance~/instances~] of the FORCE or ~
                    CASE-SPLIT ~#0~[term itself~/terms themselves~].  If a ~
                    search fails for such a hypothesis, we will cause a case ~
                    split on the partially instantiated hypothesis.  Note ~
                    that this case split will introduce a ``free variable'' ~
                    into the conjecture.  While sound, this will establish a ~
                    goal almost certain to fail since the restriction ~
                    described by this apparently necessary hypothesis ~
                    constrains a variable not involved in the problem.  To ~
                    highlight this oddity, we will rename the free variables ~
                    in such forced hypotheses by prefixing them with ~
                    ``UNBOUND-FREE-''.  This is not guaranteed to generate a ~
                    new variable but at least it generates an unusual one.  ~
                    If you see such a variable in a subsequent proof (and did ~
                    not introduce them yourself) you should consider the ~
                    possibility that the free variables of this rewrite rule ~
                    were forced into the conjecture."
                (if (null (cdr (forced-hyps inst-hyps)))
                  0
                  1)
                (tilde-*-untranslate-lst-phrase (forced-hyps inst-hyps)
                  nil
                  t
                  wrld)))
            (t state))
          (cond ((set-difference-eq rhs-vars lhs-vars) (cond ((set-difference-eq rhs-vars (all-vars1-lst hyps lhs-vars)) (warning$ ctx
                    "Free"
                    "A ~x0 rule generated from ~x1 contains the free ~
                      variable~#2~[~/s~] ~&2 on the right-hand side of the ~
                      rule, which ~#2~[is~/are~] not bound on the left-hand ~
                      side~#3~[~/ or in the hypothesis~/ or in any ~
                      hypothesis~].  This can cause new variables to be ~
                      introduced into the proof, which may surprise you."
                    token
                    name
                    (set-difference-eq rhs-vars (all-vars1-lst hyps lhs-vars))
                    (zero-one-or-more hyps)))
                (t state)))
            (t state))
          (cond (non-rec-fns-inst-hyps-alist (warning$ ctx
                "Non-rec"
                `("As noted, we will instantiate the free ~
                      variable~#0~[~/s~], ~&0, of a ~x1 rule generated from ~
                      ~x2, by searching for the ~#3~[hypothesis~/set of ~
                      hypotheses~] shown above.  However, ~#3~[this ~
                      hypothesis mentions~/these hypotheses mention~] the ~
                      function symbol~#4~[ ~&4, which has a non-recursive ~
                      definition.~@5  Unless this definition is disabled, ~
                      that function symbol is~/s ~&4, which have ~
                      non-recursive definitions.~@5  Unless these definitions ~
                      are disabled, those function symbols are~] unlikely to ~
                      occur in the conjecture being proved and hence the ~
                      search for the required ~#3~[hypothesis~/hypotheses~] ~
                      will likely fail." (:free-variables ,FREE-VARS)
                  (:instantiated-hyps ,INST-HYPS)
                  (:non-rec-fns-inst-hyps ,(HIDE-LAMBDAS (STRIP-CARS NON-REC-FNS-INST-HYPS-ALIST)))
                  (:name ,NAME)
                  (:rule-class ,TOKEN))
                free-vars
                token
                name
                inst-hyps
                (hide-lambdas (strip-cars non-rec-fns-inst-hyps-alist))
                (non-rec-def-rules-msg non-rec-fns-inst-hyps-alist)))
            (t state))
          (cond (subsumed-rule-names (warning$ ctx
                ("Subsume")
                `("A newly proposed ~x0 rule generated from ~x1 probably ~
                     subsumes the previously added ~x3 rule~#2~[~/s~] ~
                     ~&2, in the sense that the new rule will now probably be ~
                     applied whenever the old rule~#2~[~/s~] would have been." (:new-rule ,NAME)
                  (:rule-class-new ,TOKEN)
                  (:rule-class-old ,(IF (EQ TOKEN :REWRITE-QUOTED-CONSTANT)
     :REWRITE-QUOTED-CONSTANT
     :REWRITE))
                  (:subsumed-rules ,SUBSUMED-RULE-NAMES))
                token
                name
                subsumed-rule-names
                (if (eq token :rewrite-quoted-constant)
                  :rewrite-quoted-constant :rewrite)))
            (t state))
          (cond (subsuming-rule-names (warning$ ctx
                ("Subsume")
                `("The previously added rule~#1~[~/s~] ~&1 ~
                     subsume~#1~[s~/~] a newly proposed ~x0 rule generated ~
                     from ~x2, in the sense that the old rule~#1~[ rewrites a ~
                     more general target~/s rewrite more general targets~].  ~
                     Because the new rule will be tried first, it may ~
                     nonetheless find application." (:new-rule ,NAME)
                  (:rule-class ,TOKEN)
                  (:subsuming-rules ,SUBSUMING-RULE-NAMES))
                token
                subsuming-rule-names
                name))
            (t state))
          (cond ((warning-disabled-p "Loop-Stopper") state)
            (t (let ((bad-pairs (irrelevant-loop-stopper-pairs loop-stopper lhs-vars)))
                (cond (bad-pairs (warning$ ctx
                      ("Loop-Stopper")
                      "When the ~x0 rule generated from ~x1 is created, ~
                          the ~#2~[entry~/entries~] ~&2 from the specified ~
                          :LOOP-STOPPER will be ignored because the two ~
                          specified variables do not both occur on the ~
                          left-hand side of the rule.  See :DOC loop-stopper."
                      token
                      name
                      bad-pairs))
                  (t state)))))
          (value nil))))))

(defun chk-acceptable-rewrite-rule2
  (qc-flg name
    match-free
    loop-stopper
    hyps
    concl
    ctx
    ens
    wrld
    state)
  (mv-let (msg eqv lhs0 lhs rhs ttree)
    (interpret-term-as-rewrite-rule qc-flg
      name
      hyps
      concl
      ctx
      ens
      wrld)
    (declare (ignore lhs0))
    (cond (msg (er soft ctx "~@0" msg))
      (t (let ((rewrite-rule (create-rewrite-rule qc-flg
               *fake-rune-for-anonymous-enabled-rule*
               nil
               hyps
               eqv
               lhs
               lhs
               rhs
               nil
               nil
               nil
               wrld)))
          (er-progn (chk-rewrite-rule-warnings name
              match-free
              loop-stopper
              rewrite-rule
              ctx
              ens
              wrld
              state)
            (value ttree)))))))

(defun chk-acceptable-rewrite-rule1
  (qc-flg name match-free loop-stopper lst ctx ens wrld state)
  (cond ((null lst) (value nil))
    (t (er-let* ((ttree1 (chk-acceptable-rewrite-rule2 qc-flg
             name
             match-free
             loop-stopper
             (caar lst)
             (cdar lst)
             ctx
             ens
             wrld
             state)) (ttree (chk-acceptable-rewrite-rule1 qc-flg
              name
              match-free
              loop-stopper
              (cdr lst)
              ctx
              ens
              wrld
              state)))
        (value (cons-tag-trees ttree1 ttree))))))

(defun chk-acceptable-rewrite-rule
  (qc-flg name
    match-free
    loop-stopper
    term
    ctx
    ens
    wrld
    state)
  (chk-acceptable-rewrite-rule1 qc-flg
    name
    match-free
    loop-stopper
    (possibly-clean-up-dirty-lambda-objects-in-pairs (unprettyify (remove-guard-holders term wrld))
      wrld
      (remove-guard-holders-lamp))
    ctx
    ens
    wrld
    state))

(defun add-rewrite-rule2
  (qc-flg rune
    nume
    hyps
    concl
    loop-stopper-lst
    backchain-limit-lst
    match-free
    ens
    wrld)
  (mv-let (msg eqv lhs0 lhs rhs ttree)
    (interpret-term-as-rewrite-rule qc-flg
      (base-symbol rune)
      hyps
      concl
      nil
      ens
      wrld)
    (declare (ignore ttree))
    (cond (msg (er hard
          'add-rewrite-rule2
          "We believe that this error is occurring because the conclusion of a ~
          proposed :REWRITE or :REWRITE-QUOTED-CONSTANT rule generated from ~
          ~x0 is of the form (equiv LHS RHS), where equiv was a known ~
          equivalence relation when this rule was originally processed, but ~
          that is no longer the case.  In any case, the rule is now ~
          ill-formed. Perhaps you can fix this problem by making equiv an ~
          equivalence relation non-locally."
          (base-symbol rune)))
      (t (let* ((match-free-value (match-free-value match-free hyps lhs wrld)) (rewrite-rule (create-rewrite-rule qc-flg
                rune
                nume
                hyps
                eqv
                lhs0
                lhs
                rhs
                loop-stopper-lst
                backchain-limit-lst
                match-free-value
                wrld))
            (wrld1 (if qc-flg
                (global-set 'rewrite-quoted-constant-rules
                  (cons rewrite-rule
                    (global-val 'rewrite-quoted-constant-rules wrld))
                  wrld)
                (putprop (ffn-symb lhs)
                  'lemmas
                  (cons rewrite-rule
                    (getpropc (ffn-symb lhs) 'lemmas nil wrld))
                  wrld))))
          (put-match-free-value match-free-value rune wrld1))))))

(defun add-rewrite-rule1
  (qc-flg rune
    nume
    lst
    loop-stopper-lst
    backchain-limit-lst
    match-free
    ens
    wrld)
  (cond ((null lst) wrld)
    (t (add-rewrite-rule1 qc-flg
        rune
        nume
        (cdr lst)
        loop-stopper-lst
        backchain-limit-lst
        match-free
        ens
        (add-rewrite-rule2 qc-flg
          rune
          nume
          (caar lst)
          (cdar lst)
          loop-stopper-lst
          backchain-limit-lst
          match-free
          ens
          wrld)))))

(defun add-rewrite-rule
  (qc-flg rune
    nume
    loop-stopper-lst
    term
    backchain-limit-lst
    match-free
    ens
    wrld)
  (add-rewrite-rule1 qc-flg
    rune
    nume
    (possibly-clean-up-dirty-lambda-objects-in-pairs (unprettyify (remove-guard-holders term wrld))
      wrld
      (remove-guard-holders-lamp))
    loop-stopper-lst
    backchain-limit-lst
    match-free
    ens
    wrld))

(defun expand-inequality-fncall1
  (term)
  (let ((fn (ffn-symb term)))
    (case fn
      (< term)
      (= (mcons-term* 'equal (fargn term 1) (fargn term 2)))
      (/= (mcons-term* 'not
          (mcons-term* 'equal (fargn term 1) (fargn term 2))))
      (otherwise term))))

(defun expand-inequality-fncall
  (term)
  (mv-let (negativep atm)
    (strip-not term)
    (let ((atm (cond ((variablep atm) atm)
           ((fquotep atm) atm)
           (t (expand-inequality-fncall1 atm)))))
      (cond (negativep (dumb-negate-lit atm)) (t atm)))))

(defun all-vars-in-poly-lst
  (lst)
  (cond ((null lst) nil)
    (t (union-equal (strip-cars (access poly (car lst) :alist))
        (all-vars-in-poly-lst (cdr lst))))))

(defun subbagp-eq
  (bag1 bag2)
  (cond ((null bag1) t)
    ((null bag2) nil)
    ((member-eq (car bag1) bag2) (subbagp-eq (cdr bag1) (remove1-eq (car bag1) bag2)))
    (t nil)))

(defun always-biggerp-data
  (term)
  (mv-let (fn-cnt p-fn-cnt)
    (fn-count term)
    (cons term
      (cons fn-cnt (cons p-fn-cnt (all-vars-bag term nil))))))

(defun always-biggerp-data-lst
  (lst)
  (cond ((null lst) nil)
    (t (cons (always-biggerp-data (car lst))
        (always-biggerp-data-lst (cdr lst))))))

(defun always-biggerp
  (abd1 abd2)
  (and (or (> (cadr abd1) (cadr abd2))
      (and (eql (cadr abd1) (cadr abd2))
        (> (caddr abd1) (caddr abd2))))
    (subbagp-eq (cdddr abd2) (cdddr abd1))))

(defun no-element-always-biggerp
  (abd-lst abd)
  (cond ((null abd-lst) t)
    ((always-biggerp (car abd-lst) abd) nil)
    (t (no-element-always-biggerp (cdr abd-lst) abd))))

(defun maximal-terms1
  (abd-lst abd-lst0 needed-vars)
  (cond ((null abd-lst) nil)
    ((and (nvariablep (car (car abd-lst)))
       (not (fquotep (car (car abd-lst))))
       (not (flambda-applicationp (car (car abd-lst))))
       (not (eq (ffn-symb (car (car abd-lst))) 'if))
       (subsetp-eq needed-vars (cdddr (car abd-lst)))
       (no-element-always-biggerp abd-lst0 (car abd-lst))) (cons (car (car abd-lst))
        (maximal-terms1 (cdr abd-lst) abd-lst0 needed-vars)))
    (t (maximal-terms1 (cdr abd-lst) abd-lst0 needed-vars))))

(defun maximal-terms
  (lst hyp-vars concl-vars)
  (let ((abd-lst (always-biggerp-data-lst lst)))
    (maximal-terms1 abd-lst
      abd-lst
      (if (eq hyp-vars t)
        nil
        (set-difference-eq concl-vars hyp-vars)))))

(defun collect-when-ffnnamesp
  (fns lst)
  (cond ((null lst) nil)
    ((ffnnamesp fns (car lst)) (cons (car lst) (collect-when-ffnnamesp fns (cdr lst))))
    (t (collect-when-ffnnamesp fns (cdr lst)))))

(defun make-free-max-terms-msg1
  (max-terms vars hyps)
  (cond ((null max-terms) nil)
    ((subsetp-eq vars (all-vars (car max-terms))) (make-free-max-terms-msg1 (cdr max-terms) vars hyps))
    (t (cons (cons "When ~xN is triggered by ~xT the variable~#V~[~/s~] ~&V ~
              will be chosen by searching for ~#H~[an ~
              instance~/instances~] of ~&H among the hypotheses of the ~
              conjecture being rewritten.  "
          (list (cons #\T (car max-terms))
            (cons #\V
              (set-difference-eq vars (all-vars (car max-terms))))
            (cons #\H
              (hyps-that-instantiate-free-vars (set-difference-eq vars (all-vars (car max-terms)))
                hyps))))
        (make-free-max-terms-msg1 (cdr max-terms) vars hyps)))))

(defun make-free-max-terms-msg
  (name max-terms vars hyps)
  (list* ""
    "~@*"
    "~@*"
    "~@*"
    (make-free-max-terms-msg1 max-terms vars hyps)
    (list (cons #\N name))))

(defun external-linearize
  (term ens wrld state)
  (linearize term
    t
    nil
    ens
    (ok-to-force-ens ens)
    wrld
    nil
    state))

(defun bad-synp-hyp-msg-for-linear
  (max-terms hyps wrld)
  (if (null max-terms)
    (mv nil nil)
    (let ((bad-synp-hyp-msg (bad-synp-hyp-msg hyps (all-vars (car max-terms)) nil wrld)))
      (if bad-synp-hyp-msg
        (mv bad-synp-hyp-msg (car max-terms))
        (bad-synp-hyp-msg-for-linear (cdr max-terms) hyps wrld)))))

(defun show-double-rewrite-opportunities-linear
  (hyps max-terms final-term name ctx ens wrld state)
  (cond ((endp max-terms) state)
    (t (pprogn (show-double-rewrite-opportunities (double-rewrite-opportunities 1
            hyps
            (covered-geneqv-alist (car max-terms) nil nil nil ens wrld)
            final-term
            "the conclusion"
            *geneqv-iff*
            ens
            wrld)
          :linear name
          (msg " for trigger term ~x0"
            (untranslate (car max-terms) nil wrld))
          ctx
          state)
        (show-double-rewrite-opportunities-linear hyps
          (cdr max-terms)
          final-term
          name
          ctx
          ens
          wrld
          state)))))

(defun no-linear-msg
  (name concl extra ens wrld state)
  (msg "No :LINEAR rule can be generated from ~x0.  See :DOC linear.~@1~@2"
    name
    (mv-let (flg x ttree)
      (eval-ground-subexpressions concl ens wrld state nil)
      (declare (ignore flg ttree))
      (if (quotep x)
        (msg "  Note that after ground evaluation, the ~
                           conclusion, ~x0, was treated as the constant, ~x1."
          (untranslate concl t wrld)
          (untranslate x t wrld))
        ""))
    extra))

(defun all-non-numeric
  (lst ens wrld)
  (cond ((endp lst) t)
    (t (mv-let (ts ttree)
        (type-set (car lst) nil nil nil ens wrld nil nil nil)
        (declare (ignore ttree))
        (cond ((ts-intersectp ts *ts-acl2-number*) nil)
          (t (all-non-numeric (cdr lst) ens wrld)))))))

(defun chk-acceptable-linear-rule2
  (name match-free
    trigger-terms
    hyps
    concl
    ctx
    ens
    wrld
    state)
  (let* ((xconcl (expand-inequality-fncall concl)) (lst (and (null trigger-terms)
          (external-linearize xconcl ens wrld state))))
    (cond ((and (null trigger-terms) (null lst)) (er soft
          ctx
          "~@0"
          (no-linear-msg name concl "" ens wrld state)))
      ((not (null (cdr lst))) (er soft
          ctx
          "No :LINEAR rule can be generated from ~x0 because the ~
                linearization of its conclusion, which in normal form is ~p1, ~
                produces a disjunction of polynomial inequalities.  See :DOC ~
                linear."
          name
          (untranslate xconcl t wrld)))
      (t (let* ((all-vars-hyps (and (null trigger-terms) (all-vars-in-hyps hyps))) (potential-free-vars (free-vars-in-hyps-considering-bind-free hyps nil wrld))
            (all-vars-in-poly-lst (and (null trigger-terms) (all-vars-in-poly-lst (car lst))))
            (max-terms (or trigger-terms
                (maximal-terms all-vars-in-poly-lst
                  all-vars-hyps
                  (all-vars concl))))
            (warn-non-rec (not (warning-disabled-p "Non-rec")))
            (non-rec-fns-alist (and warn-non-rec
                (non-recursive-fnnames-alist-lst max-terms ens wrld)))
            (non-rec-fns (strip-cars non-rec-fns-alist))
            (bad-max-terms (collect-when-ffnnamesp non-rec-fns max-terms))
            (free-max-terms-msg (make-free-max-terms-msg name
                max-terms
                potential-free-vars
                hyps)))
          (cond ((null max-terms) (cond ((and (null trigger-terms) (null all-vars-in-poly-lst)) (er soft
                    ctx
                    "No :LINEAR rule can be generated from ~x0 because there ~
                      are no ``maximal terms'' in the inequality produced ~
                      from its conclusion.  In fact, the inequality has ~
                      simplified to one that has no variables."
                    name))
                (t (er soft
                    ctx
                    "No :LINEAR rule can be generated from ~x0 because there ~
                      are no ``maximal terms'' in the inequality produced ~
                      from its conclusion.  The inequality produced from its ~
                      conclusion involves a linear polynomial in the ~
                      unknown~#1~[~/s~] ~&1.  No unknown above has the three ~
                      properties of a maximal term (see :DOC linear).  What ~
                      can you do?  The most direct solution is to make this a ~
                      :REWRITE rule rather than a :LINEAR rule.  Of course, ~
                      you then have to make sure your intended application ~
                      can suffer it being a :REWRITE rule!  A more ~
                      challenging (and sometimes more rewarding) alternative ~
                      is to package up some of your functions into a new ~
                      non-recursive function (either in the unknowns or the ~
                      hypotheses) so as to create a maximal term.  Of course, ~
                      if you do that, you have to arrange to use that ~
                      non-recursive function in the intended applications of ~
                      this rule."
                    name
                    all-vars-in-poly-lst))))
            ((and (null trigger-terms)
               (all-non-numeric all-vars-in-poly-lst ens wrld)) (er soft
                ctx
                "The conclusion of a :LINEAR rule produces a polynomial ~
                    c1*x1 + ... + cn*xn where each ci is a constant and each ~
                    xi is a term.  See :DOC linear.  However, in this case ~
                    the conclusion, ~x1, generates such a polynomial ~
                    ~#2~[with a single term, ~x3, and that term is~/for which ~
                    all of the terms xi are~] provably non-numeric; so the ~
                    proposed rule ~x0 would not be reasonable.~#2~[~/  Here ~
                    is that list of terms:~|~%~x3.~]"
                name
                (untranslate concl t wrld)
                (if (cdr all-vars-in-poly-lst)
                  1
                  0)
                (if (cdr all-vars-in-poly-lst)
                  (untranslate-lst all-vars-in-poly-lst t wrld)
                  (untranslate (car all-vars-in-poly-lst) t wrld))))
            (t (mv-let (bad-synp-hyp-msg bad-max-term)
                (bad-synp-hyp-msg-for-linear max-terms hyps wrld)
                (cond (bad-synp-hyp-msg (er soft
                      ctx
                      "While checking the hypotheses of ~x0 and using the ~
                        trigger term ~x1, the following error message was ~
                        generated:~%~%~@2"
                      name
                      bad-max-term
                      bad-synp-hyp-msg))
                  (t (pprogn (if (warning-disabled-p "Double-rewrite")
                        state
                        (show-double-rewrite-opportunities-linear hyps
                          max-terms
                          concl
                          name
                          ctx
                          ens
                          wrld
                          state))
                      (cond ((equal max-terms bad-max-terms) (warning$ ctx
                            "Non-rec"
                            `("A :LINEAR rule generated from ~x0 will be ~
                                   triggered only by terms containing the ~
                                   function symbol~#1~[ ~&1, which has a ~
                                   non-recursive definition.~@2  Unless this ~
                                   definition is~/s ~&1, which have ~
                                   non-recursive definitions.~@2  Unless ~
                                   these definitions are~] disabled, such ~
                                   triggering terms are unlikely to arise and ~
                                   so ~x0 is unlikely to ever be used." (:name ,NAME)
                              (:non-recursive-fns ,(HIDE-LAMBDAS NON-REC-FNS))
                              (:rule-class :linear))
                            name
                            (hide-lambdas non-rec-fns)
                            (non-rec-def-rules-msg non-rec-fns-alist)))
                        (bad-max-terms (warning$ ctx
                            "Non-rec"
                            "A :LINEAR rule generated from ~x0 will be ~
                                 triggered by the terms ~&1. ~N2 of these ~
                                 terms, namely ~&3, contain~#3~[s~/~] the ~
                                 function symbol~#4~[ ~&4, which has a ~
                                 non-recursive definition.~@5  Unless this ~
                                 definition is~/s ~&4, which have ~
                                 non-recursive definitions.~@5  Unless these ~
                                 definitions are~] disabled, ~x0 is unlikely ~
                                 to be triggered via ~#3~[this term~/these ~
                                 terms~]."
                            name
                            max-terms
                            (length bad-max-terms)
                            bad-max-terms
                            (hide-lambdas non-rec-fns)
                            (non-rec-def-rules-msg non-rec-fns-alist)))
                        (t state))
                      (cond ((and (nth 4 free-max-terms-msg) (null match-free)) (pprogn (warning$ ctx
                              "Free"
                              "A :LINEAR rule generated from ~x0 will be ~
                                  triggered by the term~#1~[~/s~] ~&1.  ~
                                  ~*2This is generally a severe restriction ~
                                  on the applicability of the :LINEAR rule~@3."
                              name
                              max-terms
                              free-max-terms-msg
                              (let ((len-max-terms (length max-terms)) (len-bad-max-terms (length (nth 4 free-max-terms-msg))))
                                (cond ((eql len-bad-max-terms len-max-terms) "")
                                  ((eql len-bad-max-terms 1) " for this trigger")
                                  (t (msg " for these ~n0 triggers" len-bad-max-terms)))))
                            (free-variable-error? :linear name ctx wrld state)))
                        (t (value nil))))))))))))))

(defun chk-acceptable-linear-rule1
  (name match-free trigger-terms lst ctx ens wrld state)
  (cond ((null lst) (value nil))
    (t (er-progn (chk-acceptable-linear-rule2 name
          match-free
          trigger-terms
          (caar lst)
          (cdar lst)
          ctx
          ens
          wrld
          state)
        (chk-acceptable-linear-rule1 name
          match-free
          trigger-terms
          (cdr lst)
          ctx
          ens
          wrld
          state)))))

(defun chk-acceptable-linear-rule
  (name match-free trigger-terms term ctx ens wrld state)
  (chk-acceptable-linear-rule1 name
    match-free
    trigger-terms
    (possibly-clean-up-dirty-lambda-objects-in-pairs (unprettyify (remove-guard-holders term wrld))
      wrld
      (remove-guard-holders-lamp))
    ctx
    ens
    wrld
    state))

(defun add-linear-rule3
  (rune nume
    hyps
    concl
    max-terms
    backchain-limit-lst
    match-free
    put-match-free-done
    wrld)
  (cond ((null max-terms) wrld)
    (t (let* ((match-free-value (match-free-value match-free hyps (car max-terms) wrld)) (linear-rule (make linear-lemma
              :rune rune
              :nume nume
              :hyps hyps
              :concl concl
              :max-term (car max-terms)
              :backchain-limit-lst (rule-backchain-limit-lst backchain-limit-lst
                hyps
                wrld
                :rewrite)
              :match-free match-free-value))
          (wrld1 (putprop (ffn-symb (access linear-lemma linear-rule :max-term))
              'linear-lemmas
              (cons linear-rule
                (getpropc (ffn-symb (access linear-lemma linear-rule :max-term))
                  'linear-lemmas
                  nil
                  wrld))
              wrld)))
        (add-linear-rule3 rune
          nume
          hyps
          concl
          (cdr max-terms)
          backchain-limit-lst
          match-free
          (or put-match-free-done match-free-value)
          (if put-match-free-done
            wrld1
            (put-match-free-value match-free-value rune wrld1)))))))

(defun add-linear-rule2
  (rune nume
    trigger-terms
    hyps
    concl
    backchain-limit-lst
    match-free
    ens
    wrld
    state)
  (let* ((concl (remove-guard-holders concl wrld)) (xconcl (expand-inequality-fncall concl))
      (lst (and (null trigger-terms)
          (external-linearize xconcl ens wrld state)))
      (hyps (preprocess-hyps hyps wrld))
      (all-vars-hyps (and (null trigger-terms) (all-vars-in-hyps hyps)))
      (max-terms (or trigger-terms
          (maximal-terms (all-vars-in-poly-lst (car lst))
            all-vars-hyps
            (all-vars concl)))))
    (cond ((and (null trigger-terms) (null lst)) (er hard
          'add-linear-rule2
          "~@0"
          (no-linear-msg (base-symbol rune)
            concl
            (msg "  This can happen during ~x0 or the ~
                                    second pass of a call of ~x1, when the ~
                                    current-theory is different than when the ~
                                    rule was originally checked.  You can ~
                                    avoid this error by supplying ~
                                    :trigger-terms in your :linear rule-class."
              'include-book
              'encapsulate)
            ens
            wrld
            state)))
      (t (add-linear-rule3 rune
          nume
          hyps
          xconcl
          max-terms
          backchain-limit-lst
          match-free
          nil
          wrld)))))

(defun add-linear-rule1
  (rune nume
    trigger-terms
    lst
    backchain-limit-lst
    match-free
    ens
    wrld
    state)
  (cond ((null lst) wrld)
    (t (add-linear-rule1 rune
        nume
        trigger-terms
        (cdr lst)
        backchain-limit-lst
        match-free
        ens
        (add-linear-rule2 rune
          nume
          trigger-terms
          (caar lst)
          (cdar lst)
          backchain-limit-lst
          match-free
          ens
          wrld
          state)
        state))))

(defun add-linear-rule
  (rune nume
    trigger-terms
    term
    backchain-limit-lst
    match-free
    ens
    wrld
    state)
  (add-linear-rule1 rune
    nume
    trigger-terms
    (possibly-clean-up-dirty-lambda-objects-in-pairs (unprettyify (remove-guard-holders term wrld))
      wrld
      (remove-guard-holders-lamp))
    backchain-limit-lst
    match-free
    ens
    wrld
    state))

(defun destructure-well-founded-relation-rule
  (term)
  (case-match term
    (('if ('implies (mp x) ('o-p (fn x)))
       ('implies ('if (mp x) ('if (mp y) (rel x y) ''nil) ''nil)
         ('o< (fn x) (fn y)))
       ''nil) (cond ((and (symbolp mp)
           (variablep x)
           (symbolp fn)
           (variablep y)
           (not (eq x y))
           (symbolp rel)) (mv mp rel))
        (t (mv nil nil))))
    (('if ('o-p (fn x))
       ('implies (rel x y) ('o< (fn x) (fn y)))
       ''nil) (cond ((and (variablep x)
           (symbolp fn)
           (variablep y)
           (not (eq x y))
           (symbolp rel)) (mv t rel))
        (t (mv nil nil))))
    (& (mv nil nil))))

(defun chk-acceptable-well-founded-relation-rule
  (name term ctx wrld state)
  (mv-let (mp rel)
    (destructure-well-founded-relation-rule term)
    (cond ((null mp) (er soft
          ctx
          "No :WELL-FOUNDED-RELATION rule can be generated for ~x0 ~
          because it does not have either of the two general forms ~
          described in :DOC well-founded-relation."
          name))
      ((and (assoc-eq rel
           (global-val 'well-founded-relation-alist wrld))
         (not (eq (cadr (assoc-eq rel
                 (global-val 'well-founded-relation-alist wrld)))
             mp))) (er soft
          ctx
          "~x0 was shown in ~x1 to be well-founded~@2  We do not permit more ~
          than one domain to be associated with a well-founded relation.  To ~
          proceed in this direction, you should define some new function ~
          symbol to be ~x0 and state your well-foundedness in terms of the ~
          new function."
          rel
          (cadr (cddr (assoc-eq rel
                (global-val 'well-founded-relation-alist wrld))))
          (if (eq (cadr (assoc-eq rel
                  (global-val 'well-founded-relation-alist wrld)))
              t)
            "."
            (msg " on objects satisfying ~x0."
              (cadr (assoc-eq rel
                  (global-val 'well-founded-relation-alist wrld)))))))
      (t (value nil)))))

(defun add-well-founded-relation-rule
  (rune nume term wrld)
  (declare (ignore nume))
  (mv-let (mp rel)
    (destructure-well-founded-relation-rule term)
    (global-set 'well-founded-relation-alist
      (cons (cons rel (cons mp rune))
        (global-val 'well-founded-relation-alist wrld))
      wrld)))

(defun chk-acceptable-built-in-clause-rule2
  (name hyps concl ctx wrld state)
  (let* ((term (if (null hyps)
         concl
         (mcons-term* 'if (conjoin hyps) concl *t*))) (clauses (clausify term nil t (sr-limit wrld))))
    (cond ((null clauses) (er soft
          ctx
          "~x0 is an illegal :built-in-clause rule because ~p1 clausifies ~
                to nil, indicating that it is a propositional tautology.  See ~
                :DOC built-in-clause."
          name
          (untranslate (cond ((null hyps) concl)
              (t (mcons-term* 'implies (conjoin hyps) concl)))
            t
            wrld)))
      (t (value nil)))))

(defun chk-acceptable-built-in-clause-rule1
  (name lst ctx wrld state)
  (cond ((null lst) (value nil))
    (t (er-progn (chk-acceptable-built-in-clause-rule2 name
          (caar lst)
          (cdar lst)
          ctx
          wrld
          state)
        (chk-acceptable-built-in-clause-rule1 name
          (cdr lst)
          ctx
          wrld
          state)))))

(defun chk-acceptable-built-in-clause-rule
  (name term ctx wrld state)
  (chk-acceptable-built-in-clause-rule1 name
    (unprettyify term)
    ctx
    wrld
    state))

(defun built-in-clause-discriminator-fn
  (cl wrld)
  (mv-let (fn max)
    (fn-and-maximal-level-no-lst cl wrld nil -1)
    (declare (ignore max))
    fn))

(defun all-fnnames-subsumer
  (cl wrld)
  (let ((syms (set-difference-eq (all-fnnames-lst cl)
         *one-way-unify1-implicit-fns*)) (discrim-fn (built-in-clause-discriminator-fn cl wrld)))
    (cond ((null discrim-fn) syms)
      (t (cons discrim-fn (remove1-eq discrim-fn syms))))))

(defun make-built-in-clause-rules1
  (rune nume clauses wrld)
  (cond ((null clauses) nil)
    (t (let ((cl (cons (car (last (car clauses))) (butlast (car clauses) 1))))
        (cons (make built-in-clause
            :rune rune
            :nume nume
            :clause cl
            :all-fnnames (all-fnnames-subsumer cl wrld))
          (make-built-in-clause-rules1 rune nume (cdr clauses) wrld))))))

(defun chk-initial-built-in-clauses
  (lst wrld good-lst some-badp)
  (cond ((null lst) (cond (some-badp (reverse good-lst)) (t nil)))
    (t (let* ((clause (access built-in-clause (car lst) :clause)) (fnnames1 (access built-in-clause (car lst) :all-fnnames))
          (fnnames2 (all-fnnames-subsumer clause wrld)))
        (chk-initial-built-in-clauses (cdr lst)
          wrld
          (cons `(make built-in-clause
              :nume nil
              :rune *fake-rune-for-anonymous-enabled-rule*
              :clause ',CLAUSE
              :all-fnnames ',FNNAMES2)
            good-lst)
          (or some-badp (not (equal fnnames1 fnnames2))))))))

(defun make-built-in-clause-rules
  (rune nume lst wrld)
  (cond ((null lst) nil)
    (t (let* ((hyps (caar lst)) (concl (cdar lst))
          (clauses (clausify (if (null hyps)
                concl
                (mcons-term* 'if (conjoin hyps) concl *t*))
              nil
              t
              (sr-limit wrld))))
        (append (make-built-in-clause-rules1 rune nume clauses wrld)
          (make-built-in-clause-rules rune nume (cdr lst) wrld))))))

(defun classify-and-store-built-in-clause-rules
  (lst pots wrld)
  (cond ((null lst) pots)
    (t (let* ((bic (car lst)) (fns (or (access built-in-clause bic :all-fnnames)
              (all-fnnames-subsumer (access built-in-clause bic :clause)
                wrld)))
          (fn (car fns))
          (pot (cdr (assoc-eq fn pots))))
        (classify-and-store-built-in-clause-rules (cdr lst)
          (put-assoc-eq fn
            (cons (change built-in-clause bic :all-fnnames (cdr fns))
              pot)
            pots)
          wrld)))))

(defun add-built-in-clause-rule
  (rune nume term wrld)
  (let ((rules (make-built-in-clause-rules rune
         nume
         (unprettyify term)
         wrld)))
    (global-set 'half-length-built-in-clauses
      (floor (+ (length rules)
          (length (global-val 'built-in-clauses wrld)))
        2)
      (global-set 'built-in-clauses
        (classify-and-store-built-in-clause-rules rules
          (global-val 'built-in-clauses wrld)
          wrld)
        wrld))))

(defun destructure-compound-recognizer
  (term)
  (case-match term
    (('implies ('not (fn x)) concl) (cond ((and (variablep x) (symbolp fn)) (mv 'false fn x concl))
        (t (mv nil nil nil nil))))
    (('implies (fn x) concl) (cond ((and (variablep x) (symbolp fn)) (mv 'true fn x concl))
        (t (mv nil nil nil nil))))
    (('if ('implies (fn x) concl1)
       ('implies ('not (fn x)) concl2)
       ''nil) (cond ((and (variablep x) (symbolp fn)) (mv 'weak-both fn x (cons concl1 concl2)))
        (t (mv nil nil nil nil))))
    (('if (fn x) concl1 concl2) (cond ((and (variablep x) (symbolp fn)) (mv 'weak-both fn x (cons concl1 concl2)))
        (t (mv nil nil nil nil))))
    (('if ('implies ('not (fn x)) concl2)
       ('implies (fn x) concl1)
       ''nil) (cond ((and (variablep x) (symbolp fn)) (mv 'weak-both fn x (cons concl1 concl2)))
        (t (mv nil nil nil nil))))
    (('if ('implies ('not (fn x)) concl2)
       ('implies (fn x) concl1)
       ''nil) (cond ((and (variablep x) (symbolp fn)) (mv 'weak-both fn x (cons concl1 concl2)))
        (t (mv nil nil nil nil))))
    (('iff (fn x) concl) (cond ((and (variablep x) (symbolp fn)) (mv 'strong-both fn x concl))
        (t (mv nil nil nil nil))))
    (('equal (fn x) concl) (cond ((and (variablep x) (symbolp fn)) (mv 'strong-both fn x concl))
        (t (mv nil nil nil nil))))
    (& (mv nil nil nil nil))))

(defun make-recognizer-tuple
  (rune nume parity fn var term ens wrld)
  (case parity
    (true (mv-let (ts ttree)
        (type-set-implied-by-term var nil term ens wrld nil)
        (mv (make recognizer-tuple
            :rune rune
            :nume nume
            :fn fn
            :true-ts ts
            :false-ts *ts-unknown*
            :strongp nil)
          ttree)))
    (false (mv-let (ts ttree)
        (type-set-implied-by-term var nil term ens wrld nil)
        (mv (make recognizer-tuple
            :rune rune
            :nume nume
            :fn fn
            :true-ts *ts-unknown*
            :false-ts ts
            :strongp nil)
          ttree)))
    (weak-both (mv-let (tts ttree)
        (type-set-implied-by-term var nil (car term) ens wrld nil)
        (mv-let (fts ttree)
          (type-set-implied-by-term var nil (cdr term) ens wrld ttree)
          (mv (make recognizer-tuple
              :rune rune
              :nume nume
              :fn fn
              :true-ts tts
              :false-ts fts
              :strongp (ts= tts (ts-complement fts)))
            ttree))))
    (otherwise (mv-let (tts ttree)
        (type-set-implied-by-term var nil term ens wrld nil)
        (mv-let (fts ttree)
          (type-set-implied-by-term var t term ens wrld ttree)
          (mv (make recognizer-tuple
              :rune rune
              :nume nume
              :fn fn
              :true-ts tts
              :false-ts fts
              :strongp (ts= tts (ts-complement fts)))
            ttree))))))

(defun comment-on-new-recog-tuple1
  (new-recog-tuple recognizer-alist ctx state)
  (cond ((null recognizer-alist) (value nil))
    ((and (ts-subsetp (access recognizer-tuple new-recog-tuple :true-ts)
         (access recognizer-tuple (car recognizer-alist) :true-ts))
       (ts-subsetp (access recognizer-tuple new-recog-tuple :false-ts)
         (access recognizer-tuple (car recognizer-alist) :false-ts))
       (or (access recognizer-tuple new-recog-tuple :strongp)
         (null (access recognizer-tuple (car recognizer-alist) :strongp)))
       (or (not (ts= (access recognizer-tuple new-recog-tuple :false-ts)
             (access recognizer-tuple (car recognizer-alist) :false-ts)))
         (not (ts= (access recognizer-tuple new-recog-tuple :true-ts)
             (access recognizer-tuple (car recognizer-alist) :true-ts)))
         (not (eq (access recognizer-tuple new-recog-tuple :strongp)
             (access recognizer-tuple (car recognizer-alist) :strongp))))) (comment-on-new-recog-tuple1 new-recog-tuple
        (cdr recognizer-alist)
        ctx
        state))
    (t (pprogn (warning$ ctx
          ("Compound-rec")
          "The newly proposed compound recognizer rule ~x0 is not as ~
                  restrictive as the old rule ~x1.  See :DOC ~
                  compound-recognizer."
          (base-symbol (access recognizer-tuple new-recog-tuple :rune))
          (base-symbol (access recognizer-tuple (car recognizer-alist) :rune)))
        (comment-on-new-recog-tuple1 new-recog-tuple
          (cdr recognizer-alist)
          ctx
          state)))))

(defun comment-on-new-recog-tuple
  (new-recog-tuple ctx ens wrld state)
  (let* ((fn (access recognizer-tuple new-recog-tuple :fn)) (pred (fcons-term* fn 'x)))
    (mv-let (tts-term ttree)
      (convert-type-set-to-term 'x
        (access recognizer-tuple new-recog-tuple :true-ts)
        ens
        wrld
        nil)
      (mv-let (fts-term ttree)
        (convert-type-set-to-term 'x
          (access recognizer-tuple new-recog-tuple :false-ts)
          ens
          wrld
          ttree)
        (let ((tts-term (untranslate tts-term t wrld)) (fts-term (untranslate fts-term t wrld)))
          (er-progn (if (and (ts= (access recognizer-tuple new-recog-tuple :true-ts)
                  *ts-unknown*)
                (ts= (access recognizer-tuple new-recog-tuple :false-ts)
                  *ts-unknown*))
              (er soft
                ctx
                "When ~x0 is assumed true, ~x1 will allow us to deduce ~
                  nothing about the type of X.  Also, when ~x0 is assumed ~
                  false, ~x1 will allow us to deduce nothing about the type of ~
                  X.  Thus this is not a legal compound recognizer rule.  See ~
                  doc :compound-recognizer if these observations surprise you."
                pred
                (base-symbol (access recognizer-tuple new-recog-tuple :rune)))
              (value nil))
            (pprogn (observation ctx
                "When ~x0 is assumed true, ~x1 will allow us to deduce ~#2~[nothing ~
            about the type of X.~/~p3.~]  When ~x0 is assumed false, ~x1 will ~
            allow us to deduce ~#4~[nothing about the type of X.~/~p5.~]  Note ~
            that ~x0 is~#6~[ not~/~] a strong compound recognizer, according ~
            to this rule.  See doc :compound-recognizer if these observations ~
            surprise you.  These particular expressions of the type ~
            information are based on ~*7."
                pred
                (base-symbol (access recognizer-tuple new-recog-tuple :rune))
                (if (eq tts-term t)
                  0
                  1)
                tts-term
                (if (eq fts-term t)
                  0
                  1)
                fts-term
                (if (access recognizer-tuple new-recog-tuple :strongp)
                  1
                  0)
                (tilde-*-simp-phrase ttree))
              (if (warning-disabled-p "Compound-rec")
                (value nil)
                (comment-on-new-recog-tuple1 new-recog-tuple
                  (getpropc fn 'recognizer-alist nil wrld)
                  ctx
                  state)))))))))

(defun chk-acceptable-compound-recognizer-rule
  (name term ctx ens wrld state)
  (mv-let (parity fn var term1)
    (destructure-compound-recognizer term)
    (cond ((null parity) (er soft
          ctx
          "No :COMPOUND-RECOGNIZER rule can be generated from ~x0 ~
          because it does not have the form described in :DOC ~
          compound-recognizer."
          name))
      (t (mv-let (ts ttree1)
          (type-set (mcons-term* fn var)
            nil
            nil
            nil
            ens
            wrld
            nil
            nil
            nil)
          (cond ((not (ts-subsetp ts *ts-boolean*)) (er soft
                ctx
                "A function can be treated as a :COMPOUND-RECOGNIZER only ~
                    if it is Boolean valued. ~x0 is not known to be Boolean.  ~
                    See :DOC compound-recognizer."
                fn))
            (t (mv-let (recog-tuple ttree2)
                (make-recognizer-tuple `(:compound-recognizer ,NAME . x)
                  nil
                  parity
                  fn
                  var
                  term1
                  ens
                  wrld)
                (er-progn (comment-on-new-recog-tuple recog-tuple ctx ens wrld state)
                  (value (cons-tag-trees ttree1 ttree2)))))))))))

(defun add-compound-recognizer-rule
  (rune nume term ens wrld)
  (mv-let (parity fn var term1)
    (destructure-compound-recognizer term)
    (mv-let (recog-tuple ttree)
      (make-recognizer-tuple rune
        nume
        parity
        fn
        var
        term1
        ens
        wrld)
      (declare (ignore ttree))
      (putprop fn
        'recognizer-alist
        (cons recog-tuple (getpropc fn 'recognizer-alist nil wrld))
        wrld))))

(defun chk-triggers
  (name match-free
    hyps
    terms
    hyps-vars
    concls-vars
    ctx
    ens
    wrld
    state)
  (cond ((null terms) (value nil))
    ((or (variablep (car terms))
       (fquotep (car terms))
       (flambda-applicationp (car terms))
       (eq (ffn-symb (car terms)) 'not)) (er soft
        ctx
        "It is illegal to use a variable, a quoted constant, the ~
              application of a lambda-expression, a LET-expression, ~
              or a NOT-expression as the trigger of a forward ~
              chaining rule.  Your proposed trigger, ~x0, violates ~
              these restrictions.  See :DOC forward-chaining."
        (car terms)))
    ((not (subsetp-eq concls-vars (all-vars1 (car terms) hyps-vars))) (er soft
        ctx
        "We cannot use ~x0 as a forward chaining rule triggered ~
              by ~x1 because the variable~#2~[ ~&2 is~/s ~&2 are~] ~
              used in the conclusion but not in the ~#3~[~/hypothesis ~
              or the ~/hypotheses or the ~]trigger.  See :DOC ~
              forward-chaining."
        name
        (car terms)
        (set-difference-eq concls-vars
          (all-vars1 (car terms) hyps-vars))
        (zero-one-or-more hyps)))
    (t (let* ((warn-non-rec (not (warning-disabled-p "Non-rec"))) (free-vars (free-vars-in-hyps hyps (all-vars (car terms)) wrld))
          (inst-hyps (hyps-that-instantiate-free-vars free-vars hyps))
          (forced-hyps (forced-hyps inst-hyps))
          (non-rec-fns-alist (and warn-non-rec
              (non-recursive-fnnames-alist (car terms) ens wrld)))
          (non-rec-fns (strip-cars non-rec-fns-alist))
          (non-rec-fns-inst-hyps-alist (and warn-non-rec
              (non-recursive-fnnames-alist-lst (strip-top-level-nots-and-forces inst-hyps)
                ens
                wrld)))
          (non-rec-fns-inst-hyps (strip-cars non-rec-fns-inst-hyps-alist)))
        (er-progn (cond ((and free-vars (null match-free)) (pprogn (warning$ ctx
                  "Free"
                  `("When the :FORWARD-CHAINING rule generated from ~
                            ~x0 is triggered by ~x1 it contains the free ~
                            variable~#2~[ ~&2.  This variable~/s ~&2.  These ~
                            variables~] will be chosen by searching for ~
                            ~#3~[an instance~/instances~] of ~&3 among the ~
                            hypotheses of the conjecture being rewritten.  ~
                            This is generally a severe restriction on the ~
                            applicability of the forward chaining rule." (:free-variables ,FREE-VARS)
                    (:instantiated-hyps ,INST-HYPS)
                    (:name ,NAME)
                    (:rule-class :forward-chaining)
                    (:trigger ,(CAR TERMS)))
                  name
                  (car terms)
                  free-vars
                  inst-hyps)
                (free-variable-error? :forward-chaining name ctx wrld state)))
            (t (value nil)))
          (pprogn (cond ((and free-vars forced-hyps) (warning$ ctx
                  "Free"
                  "Forward chaining rule ~x0 has forced (or ~
                          case-split) ~#1~[hypothesis~/hypotheses~], ~*2 ~
                          which will be used to instantiate one or more free ~
                          variables.  We will search for suitable ~
                          instantiations (of the term inside the FORCE or ~
                          CASE-SPLIT) among the known assumptions in the ~
                          context at the time we encounter ~#1~[the~/each~] ~
                          hypothesis.  If no instances are found, we will ~
                          force or case split on the partially instantiated ~
                          ~#1~[hypothesis~/hypotheses~] instead of waiting ~
                          for future rounds of forward chaining which might ~
                          derive appropriate instances.  Note that this will ~
                          introduce a ``free variable'' into the conjecture.  ~
                          While sound, this will establish a goal almost ~
                          certain to fail since the restriction described by ~
                          this apparently necessary hypothesis constrains a ~
                          variable not involved in the problem.  To highlight ~
                          this oddity, we will rename the free variables in ~
                          such forced hypotheses by prefixing them with ~
                          ``UNBOUND-FREE-''.  This is not guaranteed to ~
                          generate a new variable but at least it generates ~
                          an unusual one.  If you see such a variable in a ~
                          subsequent proof (and did not introduce them ~
                          yourself) you should consider the possibility that ~
                          the free variables of this forward chaining rule ~
                          were forced into the conjecture."
                  name
                  (if (null (cdr forced-hyps))
                    0
                    1)
                  (tilde-*-untranslate-lst-phrase forced-hyps #\, t wrld)))
              (t state))
            (cond (non-rec-fns (warning$ ctx
                  ("Non-rec")
                  `("The term ~x0 contains the function symbol~#1~[ ~
                            ~&1, which has a non-recursive definition.~@2  ~
                            Unless this definition is~/s ~&1, which have ~
                            non-recursive definitions.~@2  Unless these ~
                            definitions are~] disabled, ~x0 is unlikely ever ~
                            to occur as a trigger for ~x3." (:name ,NAME)
                    (:non-recursive-fns ,(HIDE-LAMBDAS NON-REC-FNS))
                    (:trigger-term ,(CAR TERMS)))
                  (car terms)
                  (hide-lambdas non-rec-fns)
                  (non-rec-def-rules-msg non-rec-fns-alist)
                  name))
              (t state))
            (cond (non-rec-fns-inst-hyps (warning$ ctx
                  ("Non-rec")
                  `("As noted, when triggered by ~x0, we will ~
                            instantiate the free variable~#1~[~/s~], ~&1, of ~
                            the rule ~x2, by searching for the ~
                            ~#3~[hypothesis~/set of hypotheses~] shown above. ~
                            ~ However, ~#3~[this hypothesis mentions~/these ~
                            hypotheses mention~] the function symbol~#4~[ ~
                            ~&4, which has a non-recursive definition.~@5  ~
                            Unless this definition is disabled, that function ~
                            symbol is~/s ~&4, which have non-recursive ~
                            definitions.~@5  Unless these definitions are ~
                            disabled, those function symbols are~] unlikely ~
                            to occur in the conjecture being proved and hence ~
                            the search for the required ~
                            ~#3~[hypothesis~/hypotheses~] will likely fail." (:free-variables ,FREE-VARS)
                    (:instantiated-hyps ,INST-HYPS)
                    (:name ,NAME)
                    (:non-recursive-fns-inst-hyps ,(HIDE-LAMBDAS NON-REC-FNS-INST-HYPS))
                    (:trigger-term ,(CAR TERMS)))
                  (car terms)
                  free-vars
                  name
                  inst-hyps
                  (hide-lambdas non-rec-fns-inst-hyps)
                  (non-rec-def-rules-msg non-rec-fns-inst-hyps-alist)))
              (t state))
            (chk-triggers match-free
              name
              hyps
              (cdr terms)
              hyps-vars
              concls-vars
              ctx
              ens
              wrld
              state)))))))

(defun destructure-forward-chaining-term
  (term wrld)
  (let ((term (remove-lambdas (remove-guard-holders term wrld))))
    (cond ((or (variablep term)
         (fquotep term)
         (not (eq (ffn-symb term) 'implies))) (mv nil (flatten-ands-in-lit term)))
      (t (mv (flatten-ands-in-lit (fargn term 1))
          (flatten-ands-in-lit (fargn term 2)))))))

(defun warn-on-synp-hyps1
  (hyps name rule-class ctx wrld state)
  (cond ((endp hyps) state)
    ((ffn-symb-p (car hyps) 'synp) (let ((uhyp (untranslate (car hyps) t wrld)))
        (warning$ ctx
          ("Syntaxp/Bind-free Hypotheses")
          "For the rule-class ~x0, ~#1~[syntaxp ~
                      hypotheses~/bind-free hypotheses~/hypotheses calling ~
                      synp~] receive no special treatment; they are always ~
                      simply true.  Thus, for proposed rule ~x2 it is ~
                      recommended to remove the hypothesis ~x3."
          rule-class
          (cond ((and (consp uhyp) (eq (car uhyp) 'syntaxp)) 0)
            ((and (consp uhyp) (eq (car uhyp) 'bind-free)) 1)
            (t 2))
          name
          uhyp)))
    (t (warn-on-synp-hyps1 (cdr hyps)
        name
        rule-class
        ctx
        wrld
        state))))

(defun warn-on-synp-hyps
  (hyps name rule-class ctx wrld state)
  (cond ((or (null hyps)
       (warning-off-p "Syntaxp/Bind-free Hypotheses" state)) state)
    (t (warn-on-synp-hyps1 hyps name rule-class ctx wrld state))))

(defun chk-acceptable-forward-chaining-rule
  (name match-free trigger-terms term ctx ens wrld state)
  (mv-let (hyps concls)
    (destructure-forward-chaining-term term wrld)
    (let ((hyps-vars (all-vars1-lst hyps nil)) (concls-vars (all-vars1-lst concls nil)))
      (pprogn (warn-on-synp-hyps hyps
          name
          :forward-chaining ctx
          wrld
          state)
        (chk-triggers name
          match-free
          hyps
          trigger-terms
          hyps-vars
          concls-vars
          ctx
          ens
          wrld
          state)))))

(defun putprop-forward-chaining-rules-lst
  (rune nume triggers hyps concls match-free wrld)
  (cond ((null triggers) (put-match-free-value match-free rune wrld))
    (t (putprop-forward-chaining-rules-lst rune
        nume
        (cdr triggers)
        hyps
        concls
        match-free
        (putprop (ffn-symb (car triggers))
          'forward-chaining-rules
          (cons (make forward-chaining-rule
              :rune rune
              :nume nume
              :trigger (car triggers)
              :hyps hyps
              :concls concls
              :match-free match-free)
            (getpropc (ffn-symb (car triggers))
              'forward-chaining-rules
              nil
              wrld))
          wrld)))))

(defun add-forward-chaining-rule
  (rune nume trigger-terms term match-free wrld)
  (mv-let (hyps concls)
    (destructure-forward-chaining-term term wrld)
    (putprop-forward-chaining-rules-lst rune
      nume
      trigger-terms
      hyps
      concls
      (match-free-fc-value match-free
        hyps
        concls
        trigger-terms
        wrld)
      wrld)))

(defun evaluator-clause/arglist
  (evfn formals x)
  (cond ((null formals) nil)
    (t (cons (mcons-term* evfn (mcons-term* 'car x) 'a)
        (evaluator-clause/arglist evfn
          (cdr formals)
          (mcons-term* 'cdr x))))))

(defun evaluator-clause
  (evfn fn-args)
  (list '(not (consp x))
    (fcons-term* 'not
      (fcons-term* 'equal '(car x) (kwote (car fn-args))))
    (fcons-term* 'equal
      (fcons-term* evfn 'x 'a)
      (fcons-term (car fn-args)
        (evaluator-clause/arglist evfn (cdr fn-args) '(cdr x))))))

(defun evaluator-clauses1
  (evfn fn-args-lst)
  (cond ((null fn-args-lst) nil)
    (t (cons (evaluator-clause evfn (car fn-args-lst))
        (evaluator-clauses1 evfn (cdr fn-args-lst))))))

(defun evaluator-clauses
  (evfn evfn-lst fn-args-lst)
  (append (sublis (list (cons 'evfn evfn) (cons 'evfn-lst evfn-lst))
      '(((not (consp x)) (not (synp 'nil
             '(syntaxp (not (equal a ''nil)))
             '(if (not (equal a ''nil))
               't
               'nil)))
         (equal (car x) 'quote)
         (equal (evfn x a)
           (evfn (cons (car x) (kwote-lst (evfn-lst (cdr x) a))) 'nil))) ((not (symbolp x)) (equal (evfn x a)
            (if x
              (cdr (assoc-equal x a))
              'nil)))
        ((not (consp x)) (not (equal (car x) 'quote))
          (equal (evfn x a) (car (cdr x))))
        ((not (consp x)) (not (consp (car x)))
          (equal (evfn x a)
            (evfn (car (cdr (cdr (car x))))
              (pairlis$ (car (cdr (car x))) (evfn-lst (cdr x) a)))))
        ((consp x-lst) (equal (evfn-lst x-lst a) 'nil))
        ((not (consp x-lst)) (equal (evfn-lst x-lst a)
            (cons (evfn (car x-lst) a) (evfn-lst (cdr x-lst) a))))
        ((consp x) (symbolp x) (equal (evfn x a) 'nil))
        ((not (consp x)) (consp (car x))
          (symbolp (car x))
          (equal (evfn x a) 'nil))))
    (evaluator-clauses1 evfn fn-args-lst)))

(defun cdrp
  (x term)
  (cond ((equal x term) t)
    ((variablep term) nil)
    ((fquotep term) nil)
    ((eq (ffn-symb term) 'cdr) (cdrp x (fargn term 1)))
    (t nil)))

(defun expand-eq-and-atom-term-lst
  (lst)
  (cond ((null lst) nil)
    (t (let ((rst (expand-eq-and-atom-term-lst (cdr lst))) (lit (car lst)))
        (case-match lit
          (('not ('eq x ('quote s))) (cond ((symbolp s) (cons (mcons-term* 'not (mcons-term* 'equal x (list 'quote s)))
                  rst))
              ((and (quotep x) (symbolp (cadr x))) (cons (mcons-term* 'not (mcons-term* 'equal (list 'quote s) x))
                  rst))
              (t (cons lit rst))))
          (('not ('eq ('quote s) x)) (cond ((symbolp s) (cons (mcons-term* 'not (mcons-term* 'equal x (list 'quote s)))
                  rst))
              (t (cons lit rst))))
          (('not ('equal ('quote s) x)) (cond ((and (symbolp s) (not (and (quotep x) (symbolp (cadr x))))) (cons (mcons-term* 'not (mcons-term* 'equal x (list 'quote s)))
                  rst))
              (t (cons lit rst))))
          (('atom x) (cons (mcons-term* 'not (mcons-term* 'consp x)) rst))
          (& (cons lit rst)))))))

(defun normalize-alleged-evaluator-clause
  (clause)
  (expand-eq-and-atom-term-lst clause))

(defun normalize-alleged-evaluator-clause-set
  (lst)
  (cond ((null lst) nil)
    (t (cons (normalize-alleged-evaluator-clause (car lst))
        (normalize-alleged-evaluator-clause-set (cdr lst))))))

(defun shallow-clausify1
  (lst)
  (cond ((null lst) nil)
    (t (conjoin-clause-to-clause-set (add-literal (cdar lst) (dumb-negate-lit-lst (caar lst)) t)
        (shallow-clausify1 (cdr lst))))))

(defun shallow-clausify
  (term)
  (shallow-clausify1 (unprettyify term)))

(defun find-evfn-lst-in-clause
  (evfn cl)
  (cond ((null cl) nil)
    (t (let ((lit (car cl)))
        (case-match lit
          (('equal (!evfn x a)
             (!evfn ('car ('cdr ('cdr ('car x))))
               ('pairlis$ ('car ('cdr ('car x))) (evfn-lst ('cdr x) a)))) (cond ((and (variablep x) (variablep a)) evfn-lst)
              (t (find-evfn-lst-in-clause evfn (cdr cl)))))
          (& (find-evfn-lst-in-clause evfn (cdr cl))))))))

(defun guess-evfn-lst-for-evfn
  (evfn cl-set)
  (cond ((null cl-set) nil)
    ((and (int= (length (car cl-set)) 3)
       (find-evfn-lst-in-clause evfn (car cl-set))))
    (t (guess-evfn-lst-for-evfn evfn (cdr cl-set)))))

(defun find-fn-in-clause
  (cl wrld)
  (cond ((null cl) nil)
    (t (let ((lit (car cl)))
        (case-match lit
          (('not ('equal ('car x) ('quote fn))) (cond ((and (variablep x)
                 (symbolp fn)
                 (not (eq fn 'quote))
                 (function-symbolp fn wrld)) fn)
              (t (find-fn-in-clause (cdr cl) wrld))))
          (& (find-fn-in-clause (cdr cl) wrld)))))))

(defun guess-fn-args-lst-for-evfn
  (cl-set wrld)
  (cond ((null cl-set) nil)
    (t (let ((fn (and (int= (length (car cl-set)) 3)
             (find-fn-in-clause (car cl-set) wrld))))
        (cond (fn (cons (mcons-term fn (formals fn wrld))
              (guess-fn-args-lst-for-evfn (cdr cl-set) wrld)))
          (t (guess-fn-args-lst-for-evfn (cdr cl-set) wrld)))))))

(defun normalized-evaluator-cl-set
  (ev wrld)
  (normalize-alleged-evaluator-clause-set (shallow-clausify (mv-let (sym x origins)
        (constraint-info ev wrld)
        (declare (ignore origins))
        (assert$ (not (unknown-constraints-p x))
          (cond (sym (conjoin x)) (t x)))))))

(defun chk-evaluator
  (evfn wrld ctx state)
  (let ((cl-set0 (normalized-evaluator-cl-set evfn wrld)) (str "The symbol ~x0, playing the role of an evaluator in your alleged ~
          theorem, does not pass the test for an evaluator.  See :DOC meta ~
          and :DOC defevaluator.  The constraint on ~x0 is in fact ~p1.  ~@2"))
    (cond ((< (length cl-set0) 4) (er soft
          ctx
          str
          evfn
          (prettyify-clause-set cl-set0 nil wrld)
          "This constraint has fewer than four conjuncts."))
      (t (let ((evfn-lst (guess-evfn-lst-for-evfn evfn cl-set0)))
          (cond ((null evfn-lst) (er soft
                ctx
                str
                evfn
                (prettyify-clause-set cl-set0 nil wrld)
                "We cannot find the formula describing how to ~
                 evaluate lambda applications."))
            (t (let* ((fn-args-lst (guess-fn-args-lst-for-evfn cl-set0 wrld)) (cl-set1 (conjoin-clause-sets cl-set0
                      (normalized-evaluator-cl-set evfn-lst wrld)))
                  (cl-set2 (remove-guard-holders-lst-lst (evaluator-clauses evfn evfn-lst fn-args-lst)
                      wrld)))
                (cond ((not (and (clause-set-subsumes nil cl-set1 cl-set2)
                       (clause-set-subsumes nil cl-set2 cl-set1))) (er soft
                      ctx
                      "If ~x0 is an evaluator then it recognizes ~#1~[no ~
                       function symbols~/only the function symbol ~&2~/the ~
                       function symbols ~&2~] and its mutually recursive ~
                       counterpart for lists of terms must be ~x3.  The ~
                       constraints on ~x0 and ~x3 must therefore be ~
                       ~P45.~|~%We would recognize ~x0 and ~x3 as evaluators ~
                       if the constraints on them subsumed and were subsumed ~
                       by the constraints above.  But, in fact, the ~
                       constraints on ~x0 and ~x3 are ~P65 and the ~
                       bidirectional subsumption check fails.  See :DOC ~
                       defevaluator."
                      evfn
                      (zero-one-or-more fn-args-lst)
                      (strip-cars fn-args-lst)
                      evfn-lst
                      (prettyify-clause-set cl-set2 nil wrld)
                      (term-evisc-tuple nil state)
                      (prettyify-clause-set cl-set1 nil wrld)))
                  (t (value nil)))))))))))

(defun namedp-prefix
  (evfn namedp)
  (if namedp
    (concatenate 'string (symbol-name evfn) "-OF-")
    (concatenate 'string (symbol-name evfn) "-CONSTRAINT-")))

(defun defevaluator-form/defthm-name
  (evfn evfn-lst namedp prefix i clause)
  (cond (namedp (let ((fn (car (fargn (caddr clause) 2))))
        (case i
          (0 (genvar evfn
              (concatenate 'string prefix "FNCALL-ARGS")
              nil
              nil))
          (1 (genvar evfn
              (concatenate 'string prefix "VARIABLE")
              nil
              nil))
          (2 (genvar evfn (concatenate 'string prefix "QUOTE") nil nil))
          (3 (genvar evfn (concatenate 'string prefix "LAMBDA") nil nil))
          (4 (genvar evfn
              (concatenate 'string (symbol-name evfn-lst) "-OF-ATOM")
              nil
              nil))
          (5 (genvar evfn
              (concatenate 'string (symbol-name evfn-lst) "-OF-CONS")
              nil
              nil))
          (6 (genvar evfn
              (concatenate 'string prefix "NONSYMBOL-ATOM")
              nil
              nil))
          (7 (genvar evfn
              (concatenate 'string prefix "BAD-FNCALL")
              nil
              nil))
          (otherwise (genvar evfn
              (concatenate 'string prefix (symbol-name fn) "-CALL")
              nil
              nil)))))
    (t (genvar evfn prefix i nil))))

(defun defevaluator-form/defthm-hints
  (evfn evfn-lst i)
  (cond ((> i 7) `(("Goal" :expand ((,EVFN x a) (:free (x) (hide x))
           (:free (fn args) (apply-for-defevaluator fn args))))))
    (t (case i
        (0 `(("Goal" :expand ((:free (x) (hide x)) (,EVFN x a)
               (:free (args) (,EVFN (cons (car x) args) nil)))
             :in-theory '(eval-list-kwote-lst true-list-fix-ev-lst car-cons cdr-cons))))
        ((1 2 3 6 7) `(("Goal" :expand ((,EVFN x a)))))
        (otherwise `(("Goal" :expand ((,EVFN-LST x-lst a)))))))))

(defun defevaluator-form/defthm
  (evfn evfn-lst namedp prefix i clause)
  (let* ((defthm (if (or (eql i 0) (eql i 6) (eql i 7))
         'defthmd
         'defthm)) (name (defevaluator-form/defthm-name evfn
          evfn-lst
          namedp
          prefix
          i
          clause))
      (formula (prettyify-clause clause nil nil))
      (hints (defevaluator-form/defthm-hints evfn evfn-lst i)))
    `((,DEFTHM ,NAME ,FORMULA :hints ,HINTS) (local (in-theory (disable ,NAME))))))

(defun defevaluator-form/defthms
  (evfn evfn-lst namedp prefix i clauses)
  (declare (xargs :mode :program))
  (if (endp clauses)
    nil
    (append (defevaluator-form/defthm evfn
        evfn-lst
        namedp
        prefix
        i
        (car clauses))
      (defevaluator-form/defthms evfn
        evfn-lst
        namedp
        prefix
        (+ 1 i)
        (cdr clauses)))))

(defun car-cadr-caddr-etc
  (formals x)
  (if (endp formals)
    nil
    (cons `(car ,X)
      (car-cadr-caddr-etc (cdr formals) `(cdr ,X)))))

(defun defevaluator-form/fns-clauses
  (fn-args-lst)
  (declare (xargs :mode :program))
  (cond ((null fn-args-lst) '((t nil)))
    (t (cons (list (list 'equal 'fn (kwote (caar fn-args-lst)))
          (cons (caar fn-args-lst)
            (car-cadr-caddr-etc (cdar fn-args-lst) 'args)))
        (defevaluator-form/fns-clauses (cdr fn-args-lst))))))

(defun defevaluator-form
  (evfn evfn-lst namedp fn-args-lst)
  (declare (xargs :mode :program))
  (let* ((fns-clauses (defevaluator-form/fns-clauses fn-args-lst)) (defthms (defevaluator-form/defthms evfn
          evfn-lst
          namedp
          (namedp-prefix evfn namedp)
          0
          (evaluator-clauses evfn evfn-lst fn-args-lst))))
    `(encapsulate (((,EVFN * *) => *) ((,EVFN-LST * *) => *))
      (set-inhibit-warnings "theory")
      (local (in-theory *defevaluator-form-base-theory*)) . ,(SUBLIS
  (LIST (CONS 'EVFN EVFN) (CONS 'EVFN-LST EVFN-LST)
        (CONS 'FNS-CLAUSES FNS-CLAUSES) (CONS 'DEFTHMS DEFTHMS))
  '((LOCAL
     (DEFUN-NX APPLY-FOR-DEFEVALUATOR (FN ARGS)
               (DECLARE (XARGS :VERIFY-GUARDS NIL :NORMALIZE NIL))
               (COND . FNS-CLAUSES)))
    (LOCAL
     (MUTUAL-RECURSION
      (DEFUN-NX EVFN (X A)
                (DECLARE
                 (XARGS :VERIFY-GUARDS NIL :MEASURE (ACL2-COUNT X)
                  :WELL-FOUNDED-RELATION O< :NORMALIZE NIL :HINTS
                  (("goal" :IN-THEORY
                    (ENABLE (:TYPE-PRESCRIPTION ACL2-COUNT))))
                  :MODE :LOGIC))
                (COND ((SYMBOLP X) (AND X (CDR (ASSOC-EQ X A)))) ((ATOM X) NIL)
                      ((EQ (CAR X) 'QUOTE) (CAR (CDR X)))
                      (T
                       (LET ((ARGS (EVFN-LST (CDR X) A)))
                         (COND
                          ((CONSP (CAR X))
                           (EVFN (CAR (CDR (CDR (CAR X))))
                            (PAIRLIS$ (CAR (CDR (CAR X))) ARGS)))
                          ((NOT (SYMBOLP (CAR X))) NIL)
                          (T (APPLY-FOR-DEFEVALUATOR (CAR X) ARGS)))))))
      (DEFUN-NX EVFN-LST (X-LST A)
                (DECLARE
                 (XARGS :MEASURE (ACL2-COUNT X-LST) :WELL-FOUNDED-RELATION O<))
                (COND ((ENDP X-LST) NIL)
                      (T
                       (CONS (EVFN (CAR X-LST) A)
                             (EVFN-LST (CDR X-LST) A)))))))
    (LOCAL (IN-THEORY (DISABLE EVFN EVFN-LST APPLY-FOR-DEFEVALUATOR)))
    (LOCAL
     (DEFTHM EVAL-LIST-KWOTE-LST
             (EQUAL (EVFN-LST (KWOTE-LST ARGS) A) (TRUE-LIST-FIX ARGS)) :HINTS
             (("goal" :EXPAND
               ((:FREE (X Y) (EVFN-LST (CONS X Y) A)) (EVFN-LST NIL A)
                (:FREE (X) (EVFN (LIST 'QUOTE X) A)))
               :INDUCT (TRUE-LIST-FIX ARGS)))))
    (LOCAL
     (DEFTHM TRUE-LIST-FIX-EV-LST
             (EQUAL (TRUE-LIST-FIX (EVFN-LST X A)) (EVFN-LST X A)) :HINTS
             (("goal" :INDUCT (LEN X) :IN-THEORY (E/D ((:INDUCTION LEN)))
               :EXPAND ((EVFN-LST X A) (EVFN-LST NIL A))))))
    (LOCAL
     (DEFTHM EV-COMMUTES-CAR (EQUAL (CAR (EVFN-LST X A)) (EVFN (CAR X) A))
             :HINTS
             (("goal" :EXPAND ((EVFN-LST X A) (EVFN NIL A)) :IN-THEORY
               (ENABLE DEFAULT-CAR)))))
    (LOCAL
     (DEFTHM EV-LST-COMMUTES-CDR
             (EQUAL (CDR (EVFN-LST X A)) (EVFN-LST (CDR X) A)) :HINTS
             (("Goal" :EXPAND ((EVFN-LST X A) (EVFN-LST NIL A)) :IN-THEORY
               (ENABLE DEFAULT-CDR)))))
    . DEFTHMS)))))

(defun pairs-to-macro-alias-msgs
  (alist)
  (declare (xargs :guard (symbol-alistp alist)))
  (cond ((endp alist) nil)
    (t (cons (msg "~x0 is a macro alias for function ~x1"
          (caar alist)
          (cdar alist))
        (pairs-to-macro-alias-msgs (cdr alist))))))

(defun defevaluator-check-msg
  (alist macro-aliases wrld bad macro-alist)
  (declare (xargs :guard (and (symbol-alistp alist)
        (symbol-alistp macro-aliases)
        (plist-worldp wrld)
        (symbol-listp bad)
        (symbol-alistp macro-alist))))
  (cond ((endp alist) (cond ((or bad macro-alist) (msg "~@0~@1"
            (cond ((null bad) "")
              ((null (cdr bad)) (msg "The symbol ~x0 is not a function symbol in ~
                                  the current ACL2 world."
                  (car bad)))
              (t (msg "The symbols ~&0 are not function symbols in ~
                                  the current ACL2 world."
                  bad)))
            (cond ((null macro-alist) "")
              (t (msg "  Note that ~*0."
                  (list ""
                    "~@*"
                    "~@*, and "
                    "~@*"
                    (pairs-to-macro-alias-msgs macro-alist)))))))
        (t nil)))
    ((function-symbolp (caar alist) wrld) (defevaluator-check-msg (cdr alist)
        macro-aliases
        wrld
        bad
        macro-alist))
    (t (defevaluator-check-msg (cdr alist)
        macro-aliases
        wrld
        (cons (caar alist) bad)
        (let ((entry (assoc-eq (caar alist) macro-aliases)))
          (cond (entry (cons entry macro-alist)) (t macro-alist)))))))

(defun defevaluator-check
  (x evfn evfn-lst fn-args-lst ctx state)
  (declare (xargs :guard (and (state-p state)
        (symbol-alistp fn-args-lst)
        (symbol-alistp (fgetprop 'macro-aliases-table 'table-alist nil (w state))))))
  (cond ((not (and (symbolp evfn)
         (symbolp evfn-lst)
         (symbol-list-listp fn-args-lst))) (er soft
        ctx
        "The form of a defevaluator event is (defevaluator evfn evfn-lst ~
              fn-args-lst), where evfn and evfn-lst are symbols and ~
              fn-args-lst is a true list of lists of symbols.  Optionally, ~
              one may supply the final keyword argument :namedp with value t ~
              or nil (default).  However, ~x0 does not have this form."
        x))
    (t (let* ((wrld (w state)) (msg (defevaluator-check-msg fn-args-lst
              (macro-aliases wrld)
              wrld
              nil
              nil)))
        (cond (msg (er soft ctx "~@0" msg)) (t (value nil)))))))

(defun defevaluator-check-form
  (x evfn evfn-lst fn-args-lst)
  (declare (xargs :guard t))
  `(with-output :off error
    :stack :push (make-event (er-progn (with-output :stack :pop (defevaluator-check ',X
            ',EVFN
            ',EVFN-LST
            ',FN-ARGS-LST
            '(defevaluator . ,EVFN)
            state))
        (value '(value-triple nil))))))

(defun remove-meta-extract-contextual-hyps
  (hyps ev mfc-symbol a)
  (cond ((atom hyps) (mv nil nil))
    (t (let ((hyp (car hyps)))
        (mv-let (hs flg)
          (remove-meta-extract-contextual-hyps (cdr hyps)
            ev
            mfc-symbol
            a)
          (case-match hyp
            ((!ev ('meta-extract-contextual-fact & !mfc-symbol 'state)
               !a) (mv hs t))
            (& (mv (cons hyp hs) flg))))))))

(defun remove-meta-extract-global-hyps
  (hyps ev)
  (declare (xargs :mode :program))
  (cond ((atom hyps) (mv nil nil))
    (t (let ((hyp (car hyps)))
        (mv-let (hs flg)
          (remove-meta-extract-global-hyps (cdr hyps) ev)
          (case-match hyp
            ((!ev ('meta-extract-global-fact+ & & 'state) &) (mv hs t))
            (& (mv (cons hyp hs) flg))))))))

(defun meta-rule-hypothesis-functions
  (hyp ev x a mfc-symbol)
  (let ((hyps (remove1-equal (fcons-term* 'pseudo-termp x)
         (remove1-equal (fcons-term* 'alistp a)
           (flatten-ands-in-lit hyp)))))
    (mv-let (hyps flg1)
      (if mfc-symbol
        (remove-meta-extract-contextual-hyps hyps ev mfc-symbol a)
        (mv hyps nil))
      (mv-let (hyps flg2)
        (remove-meta-extract-global-hyps hyps ev)
        (let ((hyp3 (car hyps)) (extended-args (if mfc-symbol
                (cons mfc-symbol '(state))
                nil)))
          (mv (cond ((null hyps) t)
              (t (and (null (cdr hyps))
                  (case-match hyp3
                    ((!ev (fn !x . !extended-args) !a) (if (symbolp fn)
                        fn
                        nil))
                    (& nil)))))
            (append (and flg1 '(meta-extract-contextual-fact))
              (and flg2 '(meta-extract-global-fact+)))))))))

(defun meta-fn-args
  (term extendedp ens state)
  (cond (extendedp (let ((wrld (w state)))
        (list term
          (make metafunction-context
            :rdepth (rewrite-stack-limit wrld)
            :type-alist nil
            :obj '?
            :geneqv nil
            :wrld wrld
            :fnstack nil
            :ancestors nil
            :simplify-clause-pot-lst nil
            :rcnst (make-rcnst ens
              wrld
              state
              :force-info t
              :top-clause (list term)
              :current-clause (list term))
            :gstack nil
            :ttree nil
            :unify-subst nil)
          (coerce-state-to-object state))))
    (t (list term))))

(defun chk-meta-function
  (metafn name trigger-fns extendedp term-list ctx ens state)
  (cond ((null term-list) (value nil))
    ((or (variablep (car term-list))
       (fquotep (car term-list))
       (flambda-applicationp (car term-list))
       (not (member-eq (ffn-symb (car term-list)) trigger-fns))) (chk-meta-function metafn
        name
        trigger-fns
        extendedp
        (cdr term-list)
        ctx
        ens
        state))
    (t (let ((args (meta-fn-args (car term-list) extendedp ens state)))
        (pprogn (cond ((warning-disabled-p "Meta") state)
            (t (mv-let (erp val latches)
                (ev-fncall-meta metafn args state)
                (declare (ignore latches))
                (cond (erp (warning$ ctx
                      ("Meta")
                      "An error occurred upon running the metafunction ~
                              ~x0 on the term ~x1.  This does not bode well ~
                              for the utility of this metafunction for the ~
                              meta rule ~x2.  See :DOC term-table."
                      metafn
                      (car term-list)
                      name))
                  ((termp val (w state)) state)
                  (t (warning$ ctx
                      ("Meta")
                      "The value obtained upon running the ~
                              metafunction ~x0 on the term ~x1 is ~x2, which ~
                              is NOT a termp in the current ACL2 world.  This ~
                              does not bode well for the utility of this ~
                              metafunction for the meta rule ~x3.  See :DOC ~
                              term-table."
                      metafn
                      (car term-list)
                      val
                      name))))))
          (chk-meta-function metafn
            name
            trigger-fns
            extendedp
            (cdr term-list)
            ctx
            ens
            state))))))

(defun ev-lst-from-ev
  (ev wrld)
  (guess-evfn-lst-for-evfn ev
    (normalized-evaluator-cl-set ev wrld)))

(defun attached-fns
  (fns wrld)
  (cond ((endp fns) nil)
    (t (let ((prop (attachment-alist (car fns) wrld)))
        (cond ((or (null prop)
             (and (consp prop) (eq (car prop) :attachment-disallowed))) (attached-fns (cdr fns) wrld))
          (t (cons (car fns) (attached-fns (cdr fns) wrld))))))))

(defun siblings
  (f wrld)
  (or (getpropc f 'siblings nil wrld)
    (getpropc f 'recursivep nil wrld)
    (list f)))

(defun canonical-sibling
  (f wrld)
  (let ((sibs (getpropc f 'siblings nil wrld)))
    (cond (sibs (car sibs))
      (t (let ((sibs (getpropc f 'recursivep nil wrld)))
          (cond (sibs (car sibs)) (t f)))))))

(defun collect-canonical-siblings
  (fns wrld ans ign)
  (cond ((endp fns) ans)
    (t (collect-canonical-siblings (cdr fns)
        wrld
        (let ((fn (canonical-sibling (car fns) wrld)))
          (cond ((or (eq fn ign) (member-eq fn ans)) ans)
            (t (cons fn ans))))
        ign))))

(defun constraint-lst-etc-union1
  (data1 origins1 data2 origins2)
  (declare (xargs :guard (and (true-listp data1)
        (true-listp origins1)
        (true-listp data2))))
  (cond ((endp data1) (mv data2 origins2))
    ((member-equal (car data1) data2) (constraint-lst-etc-union1 (cdr data1)
        (cdr origins1)
        data2
        origins2))
    (t (mv-let (new-data2 new-origins2)
        (constraint-lst-etc-union1 (cdr data1)
          (cdr origins1)
          data2
          origins2)
        (mv (cons (car data1) new-data2)
          (cons (car origins1) new-origins2))))))

(defun constraint-lst-etc-union
  (pair1 pair2)
  (declare (xargs :guard (and (consp pair1)
        (consp pair2)
        (true-listp (car pair1))
        (true-listp (cdr pair1))
        (true-listp (car pair2)))))
  (mv-let (data origins)
    (constraint-lst-etc-union1 (car pair1)
      (cdr pair1)
      (car pair2)
      (cdr pair2))
    (cons data origins)))

(defun constraints-list
  (fns wrld constraint-lst-etc-pair seen)
  (cond ((endp fns) constraint-lst-etc-pair)
    (t (mv-let (name x origins)
        (constraint-info (car fns) wrld)
        (cond ((unknown-constraints-p x) (cons x nil))
          (name (cond ((member-eq name seen) (constraints-list (cdr fns)
                  wrld
                  constraint-lst-etc-pair
                  seen))
              (t (constraints-list (cdr fns)
                  wrld
                  (constraint-lst-etc-union (cons x origins)
                    constraint-lst-etc-pair)
                  (cons name seen)))))
          (t (constraints-list (cdr fns)
              wrld
              (if (member-equal x (car constraint-lst-etc-pair))
                constraint-lst-etc-pair
                (cons (cons x (car constraint-lst-etc-pair))
                  (cons origins (cdr constraint-lst-etc-pair))))
              seen)))))))

(defun constraint-info+
  (fn wrld)
  (let ((fns (getpropc fn 'recursivep nil wrld)))
    (cond ((and (consp fns) (consp (cdr fns))) (let ((constraint-lst-etc-pair (constraints-list fns wrld (cons nil nil) nil)))
          (mv t
            (car constraint-lst-etc-pair)
            (cdr constraint-lst-etc-pair))))
      (t (constraint-info fn wrld)))))

(defun immediate-canonical-ancestors
  (fn wrld rlp)
  (let ((guard-anc (canonical-ffn-symbs (guard fn nil wrld) wrld nil fn rlp)))
    (mv-let (name x origins)
      (constraint-info+ fn wrld)
      (declare (ignore origins))
      (cond ((unknown-constraints-p x) (collect-canonical-siblings (unknown-constraints-supporters x)
            wrld
            guard-anc
            fn))
        (name (canonical-ffn-symbs-lst x wrld guard-anc fn rlp))
        (t (canonical-ffn-symbs x wrld guard-anc fn rlp))))))

(defun canonical-ancestors-rec
  (fns wrld rlp)
  (cond ((null fns) nil)
    (t (let* ((imm (immediate-canonical-ancestors (car fns) wrld rlp)) (ans2 (canonical-ancestors-rec imm wrld rlp)))
        (add-to-set-eq (car fns)
          (union-eq ans2 (canonical-ancestors-rec (cdr fns) wrld rlp)))))))

(defun canonical-ancestors
  (fn wrld rlp)
  (let* ((imm (immediate-canonical-ancestors fn wrld rlp)))
    (canonical-ancestors-rec imm wrld rlp)))

(defun canonical-ancestors-lst
  (fns wrld)
  (canonical-ancestors-rec (collect-canonical-siblings fns wrld nil nil)
    wrld
    t))

(defun transparent-fn-p
  (name wrld)
  (declare (xargs :guard (and (symbolp name)
        (plist-worldp wrld)
        (eq (canonical-sibling name wrld) name))))
  (weak-transparent-rec-p (getpropc name 'constrainedp nil wrld)))

(defun immediate-canonical-ancestors-tr
  (fn trp wrld)
  (cond ((and trp
       (let ((pair (attachment-pair fn wrld)))
         (and pair (list (canonical-sibling (cdr pair) wrld))))))
    (t (let ((guard-anc (canonical-ffn-symbs (guard fn nil wrld) wrld nil fn t)))
        (mv-let (name x origins)
          (constraint-info+ fn wrld)
          (declare (ignore origins))
          (cond ((unknown-constraints-p x) (collect-canonical-siblings (unknown-constraints-supporters x)
                wrld
                guard-anc
                fn))
            (name (canonical-ffn-symbs-lst x wrld guard-anc fn t))
            (t (canonical-ffn-symbs x wrld guard-anc fn t))))))))

(defun canonical-ancestors-tr-rec
  (fns wrld)
  (cond ((null fns) (mv nil nil))
    (t (let* ((fn (car fns)) (trp (transparent-fn-p fn wrld))
          (imm (immediate-canonical-ancestors-tr fn trp wrld)))
        (mv-let (tr-lst1 ans1)
          (canonical-ancestors-tr-rec imm wrld)
          (mv-let (tr-lst2 ans2)
            (canonical-ancestors-tr-rec (cdr fns) wrld)
            (mv (if trp
                (add-to-set-eq fn (union-eq tr-lst1 tr-lst2))
                (union-eq tr-lst1 tr-lst2))
              (add-to-set-eq fn (union-eq ans1 ans2)))))))))

(defun canonical-ancestors-tr-lst
  (fns wrld)
  (canonical-ancestors-tr-rec (collect-canonical-siblings fns wrld nil nil)
    wrld))

(defun chk-meta-fn-attachments
  (name rule-class
    meta-fn-lst
    ev-anc
    extra-anc
    ev-fns
    newp
    ctx
    wrld
    state)
  (mv-let (tr-fns meta-anc)
    (canonical-ancestors-tr-lst meta-fn-lst wrld)
    (let* ((common-anc-1 (intersection-eq ev-anc meta-anc)) (bad-attached-fns-1 (attached-fns common-anc-1 wrld))
        (common-anc-2 (intersection-eq extra-anc meta-anc))
        (bad-attached-fns-2 (attached-fns common-anc-2 wrld)))
      (cond ((or bad-attached-fns-1 bad-attached-fns-2) (let* ((msg "because the attached function~#0~[~/s~] ~&0 ~
                     ~#1~[is~/are~/would be~] ancestral in both the ~@2 and ~
                     ~@3 functions") (type-string (if (eq rule-class :meta)
                  "meta"
                  "clause-processor"))
              (btm (canonical-sibling (car (or bad-attached-fns-1 bad-attached-fns-2))
                  wrld))
              (m-path (some-canonical-ancestors-tr-path (collect-canonical-siblings meta-fn-lst wrld nil nil)
                  btm
                  wrld))
              (e-path (some-canonical-ancestors-path ev-fns btm wrld)))
            (er soft
              ctx
              "The ~#0~[proposed~/existing~] ~x1 rule, ~x2, ~#0~[is ~
               illegal~/would become illegal after the proposed defattach ~
               event changes one or more attachments made to transparent ~
               functions,~] ~@3~@4.  See :DOC evaluator-restrictions and see ~
               :DOC transparent-functions.~@5~@6"
              (if newp
                0
                1)
              rule-class
              name
              (msg msg
                (or bad-attached-fns-1 bad-attached-fns-2)
                (cond ((not newp) 2)
                  ((cdr (or bad-attached-fns-1 bad-attached-fns-2)) 1)
                  (t 0))
                (if bad-attached-fns-1
                  "evaluator"
                  "meta-extract")
                type-string)
              (cond ((and bad-attached-fns-1 bad-attached-fns-2) (msg ", and ~@0"
                    (msg msg
                      bad-attached-fns-2
                      (cond ((not newp) 2) ((cdr bad-attached-fns-2) 1) (t 0))
                      "meta-extract"
                      type-string)))
                (t ""))
              (msg "~|~%The following ~#0~[is~/would be~] an ancestor path ~
                    from ~x1 to the ~s2 function ~x3, i.e., each function ~
                    symbol ~#0~[is~/would be~] a supporter of the ~
                    next:~|~%~X45"
                (if newp
                  0
                  1)
                btm
                type-string
                (car m-path)
                (reverse m-path)
                nil)
              (msg "~|~%The following ~#0~[is~/would be~] an ancestor path ~
                    from ~x1 to the evaluator function ~x2, i.e., each ~
                    function symbol ~#0~[is~/would be~] a supporter of the ~
                    next:~|~%~X34"
                (if newp
                  0
                  1)
                btm
                (car e-path)
                (reverse e-path)
                nil))))
        (t (value (and (or tr-fns common-anc-2 common-anc-1)
              (cons tr-fns (union-eq common-anc-2 common-anc-1)))))))))

(defun chk-evaluator-use-in-rule
  (name meta-fn hyp-fn extra-fns rule-class ev ctx wrld state)
  (er-progn (let ((temp (context-for-encapsulate-pass-2 (decode-logical-name ev wrld)
           (f-get-global 'in-local-flg state))))
      (case temp
        (illegal (er soft
            ctx
            "The proposed ~x0 rule, ~x1, is illegal because its evaluator ~
             function symbol, ~x2, is defined in a superior non-trivial ~
             encapsulate event (``non-trivial'' in the sense that it has a ~
             non-empty signature).  See :DOC evaluator-restrictions.  In some ~
             cases, a solution is to make the current ~x0 rule LOCAL, though ~
             the alleged evaluator will probably not be available for future ~
             :META or :CLAUSE-PROCESSOR rules."
            rule-class
            name
            ev))
        (maybe (pprogn (warning$ ctx
              nil
              "The proposed ~x0 rule will ultimately need to be LOCAL in ~
                    its immediately surrounding encapsulate event, because ~
                    its evaluator is introduced in a superior non-trivial ~
                    encapsulate event.  Even if this rule is LOCAL, the ~
                    alleged evaluator will probably not be available for ~
                    future :META or :CLAUSE-PROCESSOR rules. See :DOC ~
                    evaluator-restrictions."
              rule-class
              name
              ev)
            (value nil)))
        (otherwise (value nil))))
    (mv-let (fn constraint origins)
      (constraint-info ev wrld)
      (declare (ignore fn origins))
      (cond ((unknown-constraints-p constraint) (er soft
            ctx
            "The proposed ~x0 rule, ~x1, is illegal because its evaluator ~
            function symbol, ~x2, has unknown-constraints.  See :DOC ~
            partial-encapsulate."
            rule-class
            name
            ev))
        (t (let* ((ev-lst (ev-lst-from-ev ev wrld)) (ev-prop (getpropc ev 'defaxiom-supporter nil wrld))
              (ev-lst-prop (getpropc ev-lst 'defaxiom-supporter nil wrld))
              (meta-fn-lst (if hyp-fn
                  (list meta-fn hyp-fn)
                  (list meta-fn)))
              (extra-anc (canonical-ancestors-lst extra-fns wrld))
              (ev-anc (canonical-ancestors-lst (list ev) wrld)))
            (cond ((and extra-fns
                 (or (getpropc ev 'predefined nil wrld)
                   (getpropc ev-lst 'predefined nil wrld))) (er soft
                  ctx
                  "The proposed evaluator function, ~x0, was defined in the ~
                boot-strap world.  This is illegal when meta-extract ~
                hypotheses are present, because for logical reasons our ~
                implementation assumes that the evaluator is not ancestral in ~
                ~v1."
                  (if (getpropc ev 'predefined nil wrld)
                    ev
                    ev-lst)
                  '(meta-extract-contextual-fact meta-extract-global-fact+)))
              ((or ev-prop ev-lst-prop) (er soft
                  ctx
                  "The proposed ~x0 rule, ~x1, is illegal because its evaluator ~
                function symbol, ~x2, supports the formula of the defaxiom ~
                event named ~x3.  See :DOC evaluator-restrictions."
                  rule-class
                  name
                  (if ev-prop
                    ev
                    ev-lst)
                  (or ev-prop ev-lst-prop)))
              (t (er-let* ((ev-fns (value (collect-canonical-siblings (cons ev extra-fns)
                         wrld
                         nil
                         nil))) (tr-fns/common-anc (chk-meta-fn-attachments name
                        rule-class
                        meta-fn-lst
                        ev-anc
                        extra-anc
                        ev-fns
                        t
                        ctx
                        wrld
                        state)))
                  (value (cond (tr-fns/common-anc (add-to-tag-tree 'evaluator-check-for-rule
                          (list (car tr-fns/common-anc)
                            (cdr tr-fns/common-anc)
                            rule-class
                            meta-fn-lst
                            ev-anc
                            extra-anc
                            ev-fns)
                          nil))
                      (t nil))))))))))))

(defun chk-rule-fn-guard
  (function-string rule-type fn ctx wrld state)
  (let ((guard (guard fn t wrld)) (pseudo-termp-predicate (case rule-type
          (:meta 'pseudo-termp)
          (:clause-processor 'pseudo-term-listp)
          (t (er hard
              'chk-rule-fn-guard
              "Implementation error: unknown case in chk-rule-fn-guard. ~
                   Please contact the ACL2 implementors.")))))
    (cond ((or (equal guard *t*)
         (tautologyp (fcons-term* 'implies
             (fcons-term* pseudo-termp-predicate (car (formals fn wrld)))
             guard)
           wrld)) (value nil))
      (t (er soft
          ctx
          "The ~s0 of a ~x1 rule must have a guard that obviously ~
                  holds whenever its first argument is known to be a ~x2 and ~
                  any stobj arguments are assumed to satisfy their stobj ~
                  predicates.  However, the guard for ~x3 is ~p4.  See :DOC ~
                  ~@5."
          function-string
          rule-type
          pseudo-termp-predicate
          fn
          (untranslate guard t wrld)
          (case rule-type
            (:meta "meta")
            (:clause-processor "clause-processor")
            (t (er hard
                'chk-rule-fn-guard
                "Implementation error: unknown case in ~
                           chk-rule-fn-guard.  Please contact the ACL2 ~
                           implementors."))))))))

(defun add-new-never-untouchable-fns
  (fns well-formedness-guarantee never-untouchable-fns)
  (cond ((endp fns) never-untouchable-fns)
    (t (add-new-never-untouchable-fns (cdr fns)
        well-formedness-guarantee
        (put-assoc-eq (car fns)
          (add-to-set-equal well-formedness-guarantee
            (cdr (assoc-eq (car fns) never-untouchable-fns)))
          never-untouchable-fns)))))

(defun collect-never-untouchable-fns-entries
  (fns never-untouchable-fns)
  (cond ((endp fns) nil)
    (t (let ((entry (assoc-eq (car fns) never-untouchable-fns)))
        (cond (entry (cons entry
              (collect-never-untouchable-fns-entries (cdr fns)
                never-untouchable-fns)))
          (t (collect-never-untouchable-fns-entries (cdr fns)
              never-untouchable-fns)))))))

(defun interpret-term-as-meta-rule
  (term)
  (case-match term
    (('implies hyp (eqv (ev x a) (ev (fn x) a))) (mv hyp eqv ev x a fn nil))
    ((eqv (ev x a) (ev (fn x) a)) (mv *t* eqv ev x a fn nil))
    (('implies hyp
       (eqv (ev x a) (ev (fn x mfc-symbol 'state) a))) (mv hyp eqv ev x a fn mfc-symbol))
    ((eqv (ev x a) (ev (fn x mfc-symbol 'state) a)) (mv *t* eqv ev x a fn mfc-symbol))
    (& (mv *t* nil nil nil nil nil nil))))

(defun chk-non-local-in-non-trivial-encapsulate
  (msg1 msg2p ctx wrld state)
  (cond ((eq (context-for-encapsulate-pass-2 wrld
         (f-get-global 'in-local-flg state))
       'illegal) (er soft
        ctx
        "~@0 are illegal inside encapsulate events with non-empty ~
              signatures unless the rules are local.  In this case such a ~
              signature introduces the function symbol ~x1.~#2~[~/  You can ~
              probably avoid this error easily by stating the theorem with a ~
              different name, N, using :rule-classes nil, and then -- back at ~
              the top level after the encapsulate event -- including your ~
              original theorem with the hint, :by N.~]"
        msg1
        (caar (cadar (non-trivial-encapsulate-ee-entries (global-val 'embedded-event-lst wrld))))
        (if msg2p
          1
          0)))
    (t (value nil))))

(defun chk-acceptable-meta-rule
  (name trigger-fns term ctx ens wrld state)
  (er-progn (chk-non-local-in-non-trivial-encapsulate "Rules of class :META"
      t
      ctx
      wrld
      state)
    (cond ((member-eq 'if trigger-fns) (er soft
          ctx
          "The function symbol IF is not an acceptable member of :trigger-fns, ~
          because the ACL2 simplifier is not set up to apply :meta rules to ~
          calls of IF."))
      (t (let ((str "No :META rule can be generated from ~x0 because ~p1 does not ~
                 have the form of a metatheorem.  See :DOC meta."))
          (mv-let (hyp eqv ev x a fn mfc-symbol)
            (interpret-term-as-meta-rule term)
            (cond ((null eqv) (er soft ctx str name (untranslate term t wrld)))
              ((eq fn 'return-last) (er soft
                  ctx
                  "It is illegal to use ~x0 as a metafunction, as specified ~
                     by ~x1.  See :DOC meta."
                  'return-last
                  name))
              ((not (and (not (flambdap eqv))
                   (equivalence-relationp eqv wrld)
                   (variablep x)
                   (variablep a)
                   (not (eq x a))
                   (not (eq fn 'quote))
                   (not (flambdap fn))
                   (or (null mfc-symbol)
                     (and (variablep mfc-symbol)
                       (no-duplicatesp (list x a mfc-symbol 'state)))))) (er soft ctx str name (untranslate term t wrld)))
              ((not (member-equal (stobjs-in fn wrld) '((nil) (nil nil state)))) (er soft
                  ctx
                  "Metafunctions cannot take single-threaded object names ~
                     other than STATE as formal parameters. The function ~x0 ~
                     may therefore not be used as a metafunction."
                  fn))
              (t (er-progn (chk-rule-fn-guard "metafunction" :meta fn ctx wrld state)
                  (mv-let (hyp-fn extra-fns)
                    (meta-rule-hypothesis-functions hyp ev x a mfc-symbol)
                    (let ((term-list (cdar (table-alist 'term-table (w state)))))
                      (er-progn (cond ((null hyp-fn) (er soft ctx str name (untranslate term t wrld)))
                          ((and (not (eq hyp-fn t))
                             (not (member-equal (stobjs-in hyp-fn wrld)
                                 '((nil) (nil nil state))))) (er soft
                              ctx
                              "Hypothesis metafunctions cannot take single ~
                               threaded object names as formal parameters.  ~
                               The function ~x0 may therefore not be used as ~
                               a hypothesis metafunction."
                              hyp-fn))
                          ((not (eq hyp-fn t)) (chk-rule-fn-guard "hypothesis function"
                              :meta fn
                              ctx
                              wrld
                              state))
                          (t (value nil)))
                        (chk-evaluator ev wrld ctx state)
                        (chk-meta-function fn
                          name
                          trigger-fns
                          mfc-symbol
                          term-list
                          ctx
                          ens
                          state)
                        (if (eq hyp-fn t)
                          (value nil)
                          (chk-meta-function hyp-fn
                            name
                            trigger-fns
                            mfc-symbol
                            term-list
                            ctx
                            ens
                            state))
                        (chk-evaluator-use-in-rule name
                          fn
                          (if (eq hyp-fn t)
                            nil
                            hyp-fn)
                          extra-fns
                          :meta ev
                          ctx
                          wrld
                          state)))))))))))))

(defun add-meta-rule1
  (lst rule wrld)
  (cond ((null lst) wrld)
    (t (add-meta-rule1 (cdr lst)
        rule
        (putprop (car lst)
          'lemmas
          (cons rule (getpropc (car lst) 'lemmas nil wrld))
          wrld)))))

(defun maybe-putprop-lst
  (symb-lst key val wrld)
  (cond ((endp symb-lst) wrld)
    (t (let ((symb (car symb-lst)))
        (maybe-putprop-lst (cdr symb-lst)
          key
          val
          (cond ((getpropc symb key nil wrld) wrld)
            (t (putprop symb key val wrld))))))))

(defun update-transparent-rec
  (tr-meta-anc name wrld)
  (cond ((endp tr-meta-anc) wrld)
    (t (let* ((fn (car tr-meta-anc)) (old-prop (getpropc fn 'constrainedp nil wrld)))
        (assert$ (weak-transparent-rec-p old-prop)
          (update-transparent-rec (cdr tr-meta-anc)
            name
            (putprop fn
              'constrainedp
              (change transparent-rec
                old-prop
                :names (cons name (access transparent-rec old-prop :names)))
              wrld)))))))

(defun union-eq-cars
  (alist)
  (cond ((null alist) nil)
    (t (union-eq (caar alist) (union-eq-cars (cdr alist))))))

(defun mark-attachment-disallowed
  (common-anc name rule-class wrld installed-w)
  (cond ((endp common-anc) wrld)
    (t (let* ((fn (car common-anc)) (old-prop (getpropc fn 'attachment nil installed-w))
          (pair (cons name rule-class))
          (new-prop (cond (old-prop (assert$ (and (consp old-prop)
                    (eq (car old-prop) :attachment-disallowed))
                  (list* :attachment-disallowed pair (cdr old-prop))))
              (t (list :attachment-disallowed pair))))
          (other-siblings (if old-prop
              nil
              (let ((siblings (siblings fn wrld)))
                (assert$ (eq (car siblings) fn) (cdr siblings)))))
          (wrld1 (if other-siblings
              (putprop-x-lst1 other-siblings
                'attachment
                (cons :attachment-disallowed fn)
                wrld)
              wrld)))
        (mark-attachment-disallowed (cdr common-anc)
          name
          rule-class
          (putprop fn 'attachment new-prop wrld1)
          installed-w)))))

(defun update-meta-props
  (name ttree wrld state)
  (let ((lst (tagged-objects 'evaluator-check-for-rule ttree)))
    (cond ((null lst) wrld)
      (t (let* ((rule-class (if (null (cdr lst))
               (caddr (car lst))
               t)) (tr-meta-anc (union-eq-cars lst))
            (lst-cdrs (strip-cdrs lst))
            (common-anc (union-eq-cars lst-cdrs))
            (entries (strip-cdrs lst-cdrs))
            (wrld1 (update-transparent-rec tr-meta-anc name wrld))
            (wrld2 (if tr-meta-anc
                (putprop name
                  'evaluator-check-inputs
                  (list* tr-meta-anc common-anc entries)
                  wrld1)
                wrld1)))
          (mark-attachment-disallowed common-anc
            name
            rule-class
            wrld2
            (w state)))))))

(defun add-meta-rule
  (rune nume
    trigger-fns
    well-formedness-guarantee
    term
    backchain-limit
    wrld)
  (mv-let (hyp eqv ev x a fn mfc-symbol)
    (interpret-term-as-meta-rule term)
    (mv-let (hyp-fn extra-fns)
      (meta-rule-hypothesis-functions hyp ev x a mfc-symbol)
      (declare (ignore extra-fns))
      (cond ((or (null hyp-fn) (null eqv)) (er hard
            'add-meta-rule
            "Add-meta-rule broke on args ~x0!  It seems to be out of sync with ~
           chk-acceptable-meta-rule."
            (list rune nume trigger-fns term)))
        (t (let* ((arity-alist (cdr well-formedness-guarantee)) (wrld1 (add-meta-rule1 trigger-fns
                  (make rewrite-rule
                    :rune rune
                    :nume nume
                    :hyps (if (eq hyp-fn t)
                      nil
                      hyp-fn)
                    :equiv eqv
                    :lhs fn
                    :var-info nil
                    :rhs (if mfc-symbol
                      'extended
                      nil)
                    :subclass 'meta
                    :heuristic-info well-formedness-guarantee
                    :backchain-limit-lst (rule-backchain-limit-lst backchain-limit nil wrld :meta))
                  wrld))
              (wrld2 (global-set 'never-untouchable-fns
                  (add-new-never-untouchable-fns (strip-cars arity-alist)
                    well-formedness-guarantee
                    (global-val 'never-untouchable-fns wrld1))
                  wrld1)))
            wrld2))))))

(defun strip-ffn-symbs
  (lst)
  (cond ((null lst) nil)
    (t (cons (ffn-symb (car lst)) (strip-ffn-symbs (cdr lst))))))

(defun chk-acceptable-elim-rule1
  (name vars dests ctx wrld state)
  (cond ((null dests) (value nil))
    ((not (subsetp-eq vars (fargs (car dests)))) (er soft
        ctx
        "~x0 is an unacceptable destructor elimination rule because ~
         the destructor term ~x1 does not mention ~&2.  See :DOC elim."
        name
        (car dests)
        (set-difference-eq vars (fargs (car dests)))))
    (t (pprogn (let ((rule (most-recent-enabled-elim-rule (ffn-symb (car dests))
               wrld
               (ens state))))
          (cond (rule (warning$ ctx
                "Elim-rule"
                "There is already an enabled destructor elimination ~
                         rule for ~x0, namely ~x1.  Unless the new rule ~x2 ~
                         is disabled, it will replace ~x1 as the destructor ~
                         elimination rule to be used for ~x0."
                (ffn-symb (car dests))
                (base-symbol (access elim-rule rule :rune))
                name))
            (t state)))
        (chk-acceptable-elim-rule1 name
          vars
          (cdr dests)
          ctx
          wrld
          state)))))

(defun chk-acceptable-elim-rule
  (name term ctx wrld state)
  (let ((lst (unprettyify term)))
    (case-match lst
      (((& equiv lhs rhs)) (cond ((not (equivalence-relationp equiv wrld)) (er soft
              ctx
              "~x0 is an unacceptable destructor elimination rule ~
             because ~x1 is not a known equivalence relation.  See ~
             :DOC elim."
              name
              equiv))
          ((nvariablep rhs) (er soft
              ctx
              "~x0 is an unacceptable destructor elimination rule ~
             because the right-hand side of its conclusion, ~x1, is ~
             not a variable symbol.  See :DOC elim."
              name
              rhs))
          (t (let ((dests (destructors lhs nil)))
              (cond ((null dests) (er soft
                    ctx
                    "~x0 is an unacceptable destructor elimination rule ~
                 because the left-hand side of its conclusion, ~x1, ~
                 does not contain any terms of the form (fn v1 ... ~
                 vn), where fn is a function symbol and the vi are ~
                 all distinct variables.  See :DOC elim."
                    name
                    lhs))
                ((not (no-duplicatesp-equal (strip-ffn-symbs dests))) (er soft
                    ctx
                    "~x0 is an unacceptable destructor elimination rule ~
                 because the destructor terms, ~&1, include more than ~
                 one occurrence of the same function symbol.  See :DOC ~
                 elim."
                    name
                    dests))
                ((occur rhs (sublis-expr (pairlis-x2 dests *t*) lhs)) (er soft
                    ctx
                    "~x0 is an unacceptable destructor elimination rule ~
                 because the right-hand side of the conclusion, ~x1, ~
                 occurs in the left-hand side, ~x2, in places other ~
                 than the destructor term~#3~[~/s~] ~&3.  See :DOC ~
                 elim."
                    name
                    rhs
                    lhs
                    dests))
                (t (chk-acceptable-elim-rule1 name
                    (all-vars term)
                    dests
                    ctx
                    wrld
                    state)))))))
      (& (er soft
          ctx
          "~x0 is an unacceptable destructor elimination rule because ~
           its conclusion is not of the form (equiv lhs rhs).  See ~
           :DOC elim."
          name)))))

(defun add-elim-rule1
  (rune nume hyps equiv lhs rhs lst dests wrld)
  (cond ((null lst) wrld)
    (t (let* ((dest (car lst)) (rule (make elim-rule
              :rune rune
              :nume nume
              :hyps hyps
              :equiv equiv
              :lhs lhs
              :rhs rhs
              :crucial-position (- (length (fargs dest))
                (length (member-eq rhs (fargs dest))))
              :destructor-term dest
              :destructor-terms dests)))
        (add-elim-rule1 rune
          nume
          hyps
          equiv
          lhs
          rhs
          (cdr lst)
          dests
          (putprop (ffn-symb dest)
            'eliminate-destructors-rules
            (cons rule
              (getpropc (ffn-symb dest)
                'eliminate-destructors-rules
                nil
                wrld))
            wrld))))))

(defun add-elim-rule
  (rune nume term wrld)
  (let* ((lst (unprettyify term)) (hyps (caar lst))
      (equiv (ffn-symb (cdar lst)))
      (lhs (fargn (cdar lst) 1))
      (rhs (fargn (cdar lst) 2))
      (dests (reverse (destructors lhs nil))))
    (add-elim-rule1 rune
      nume
      hyps
      equiv
      lhs
      rhs
      dests
      dests
      wrld)))

(defun chk-acceptable-generalize-rule
  (name term ctx wrld state)
  (declare (ignore name term ctx wrld))
  (value nil))

(defun add-generalize-rule
  (rune nume term wrld)
  (global-set 'generalize-rules
    (cons (make generalize-rule :rune rune :nume nume :formula term)
      (global-val 'generalize-rules wrld))
    wrld))

(defun find-type-prescription-pat
  (term ens wrld)
  (cond ((variablep term) nil)
    ((fquotep term) nil)
    ((flambda-applicationp term) nil)
    ((eq (ffn-symb term) 'if) (or (find-type-prescription-pat (fargn term 1) ens wrld)
        (find-type-prescription-pat (fargn term 2) ens wrld)
        (find-type-prescription-pat (fargn term 3) ens wrld)))
    ((eq (ffn-symb term) 'not) (find-type-prescription-pat (fargn term 1) ens wrld))
    ((eq (ffn-symb term) '<) (if (quotep (fargn term 1))
        (fargn term 2)
        (fargn term 1)))
    ((eq (ffn-symb term) 'equal) (cond ((or (variablep (fargn term 1)) (fquotep (fargn term 1))) (fargn term 2))
        ((or (variablep (fargn term 2)) (fquotep (fargn term 2))) (fargn term 1))
        (t nil)))
    ((let ((recog-tuple (most-recent-enabled-recog-tuple (ffn-symb term) wrld ens)))
       (and recog-tuple
         (access recognizer-tuple recog-tuple :strongp))) (fargn term 1))
    (t term)))

(defun add-type-prescription-rule
  (rune nume
    typed-term
    term
    backchain-limit-lst
    ens
    wrld
    quietp)
  (mv-let (erp hyps concl ts vars ttree)
    (destructure-type-prescription (base-symbol rune)
      typed-term
      term
      ens
      wrld)
    (declare (ignore concl ttree))
    (cond (erp (cond (quietp (prog2$ (cw "~%NOTE:  ACL2 is unable to create a proposed ~
                         type-prescription rule from the term ~x0 for ~
                         :typed-term ~x1, so this proposed rule is not being ~
                         added.~|"
                term
                typed-term)
              wrld))
          (t (er hard
              'add-type-prescription-rule
              "Unable to process this :TYPE-PRESCRIPTION rule.  A possible ~
                 explanation is that we are in the second pass of an ~
                 include-book or encapsulate, and although this rule was ~
                 legal in the first pass, it is not legal in the second pass. ~
                 For example, the rule may depend on a preceding ~
                 :COMPOUND-RECOGNIZER rule local to this encapsulate or ~
                 include-book.  The usual error message for ~
                 :TYPE-PRESCRIPTION rules now follows.~|~%~@0"
              erp))))
      (t (putprop (ffn-symb typed-term)
          'type-prescriptions
          (cons (make type-prescription
              :rune rune
              :nume nume
              :term typed-term
              :hyps hyps
              :backchain-limit-lst (rule-backchain-limit-lst backchain-limit-lst hyps wrld :ts)
              :basic-ts ts
              :vars vars
              :corollary term)
            (getpropc (ffn-symb typed-term)
              'type-prescriptions
              nil
              wrld))
          wrld)))))

(defun strong-compound-recognizer-p1
  (recognizer-alist ens)
  (cond ((endp recognizer-alist) nil)
    ((let ((recog-tuple (car recognizer-alist)))
       (and (access recognizer-tuple recog-tuple :strongp)
         (enabled-numep (access recognizer-tuple recog-tuple :nume)
           ens))) t)
    (t (strong-compound-recognizer-p1 (cdr recognizer-alist) ens))))

(defun strong-compound-recognizer-p
  (fn ens wrld)
  (let ((alist (getpropc fn 'recognizer-alist nil wrld)))
    (and alist (strong-compound-recognizer-p1 alist ens))))

(defun warned-non-rec-fns-alist-for-tp
  (term ens wrld)
  (cond ((or (variablep term) (fquotep term)) nil)
    ((flambdap (ffn-symb term)) (put-assoc-equal (ffn-symb term)
        nil
        (non-recursive-fnnames-alist-lst (fargs term) ens wrld)))
    ((eq (ffn-symb term) 'if) (union-equal (warned-non-rec-fns-alist-for-tp (fargn term 1) ens wrld)
        (union-equal (warned-non-rec-fns-alist-for-tp (fargn term 2) ens wrld)
          (warned-non-rec-fns-alist-for-tp (fargn term 3) ens wrld))))
    ((eq (ffn-symb term) 'not) (warned-non-rec-fns-alist-for-tp (fargn term 1) ens wrld))
    ((strong-compound-recognizer-p (ffn-symb term) ens wrld) (non-recursive-fnnames-alist-lst (fargs term) ens wrld))
    (t (non-recursive-fnnames-alist term ens wrld))))

(defun warned-non-rec-fns-alist-tp-hyps1
  (hyps ens wrld acc)
  (cond ((endp hyps) acc)
    (t (warned-non-rec-fns-alist-tp-hyps1 (cdr hyps)
        ens
        wrld
        (let ((hyp (if (and (nvariablep (car hyps))
                 (member-eq (ffn-symb (car hyps)) '(force case-split)))
               (fargn (car hyps) 1)
               (car hyps))))
          (cond (acc (union-equal (warned-non-rec-fns-alist-for-tp hyp ens wrld)
                acc))
            (t (warned-non-rec-fns-alist-for-tp hyp ens wrld))))))))

(defun warned-non-rec-fns-alist-tp-hyps
  (hyps ens wrld)
  (warned-non-rec-fns-alist-tp-hyps1 hyps ens wrld nil))

(defun chk-acceptable-type-prescription-rule
  (name typed-term
    term
    backchain-limit-lst
    ctx
    ens
    wrld
    state)
  (declare (ignore backchain-limit-lst))
  (mv-let (erp hyps concl ts vars ttree)
    (destructure-type-prescription name
      typed-term
      term
      ens
      wrld)
    (declare (ignore ts concl vars))
    (cond (erp (er soft ctx "~@0" erp))
      (t (pprogn (warn-on-synp-hyps hyps
            name
            :type-prescription ctx
            wrld
            state)
          (let* ((warned-non-rec-fns-alist (and (not (warning-disabled-p "Non-rec"))
                 (warned-non-rec-fns-alist-tp-hyps hyps ens wrld))) (warned-non-rec-fns (strip-cars warned-non-rec-fns-alist))
              (warned-free-vars (and (not (warning-disabled-p "Free"))
                  (free-vars-in-hyps hyps (all-vars typed-term) wrld)))
              (inst-hyps (and warned-free-vars
                  (hyps-that-instantiate-free-vars warned-free-vars hyps))))
            (pprogn (cond (warned-non-rec-fns-alist (warning$ ctx
                    ("Non-rec")
                    `("The hypothesis of the :type-prescription rule ~
                         generated from ~x0 contains the function symbol~#1~[ ~
                         ~&1, which has a non-recursive definition~/s ~&1, ~
                         which have non-recursive definitions~].~@2  Since ~
                         the hypotheses of :type-prescription rules are ~
                         relieved by type reasoning alone (and not rewriting) ~
                         ~#1~[this function is~/these functions are~] liable ~
                         to make the rule inapplicable.  See :DOC ~
                         type-prescription." (:doc type-prescription)
                      (:name ,NAME)
                      (:non-recursive-fns ,(HIDE-LAMBDAS WARNED-NON-REC-FNS))
                      (:rule-class :type-prescription))
                    name
                    (hide-lambdas warned-non-rec-fns)
                    (non-rec-def-rules-msg warned-non-rec-fns-alist)))
                (t state))
              (cond (warned-free-vars (warning$ ctx
                    ("Free")
                    `("The :type-prescription rule generated from ~x0 ~
                         contains the free variable~#1~[ ~&1.  This ~
                         variable~/s ~&1.  These variables~] will be chosen ~
                         by searching for instances of ~&2 among the ~
                         hypotheses of conjectures being rewritten.  This is ~
                         generally a severe restriction on the applicability ~
                         of the :type-prescription rule." (:free-variables ,WARNED-FREE-VARS)
                      (:instantiated-hyps ,INST-HYPS)
                      (:name ,NAME)
                      (:rule-class :type-prescription))
                    name
                    warned-free-vars
                    inst-hyps))
                (t state))
              (cond ((and warned-free-vars (forced-hyps inst-hyps)) (warning$ ctx
                    ("Free")
                    "For the forced ~#0~[hypothesis~/hypotheses~], ~&1, ~
                       used to instantiate free variables we will search for ~
                       ~#0~[an instance of the argument~/instances of the ~
                       arguments~] rather than ~#0~[an instance~/instances~] ~
                       of the FORCE or CASE-SPLIT ~#0~[term itself~/terms ~
                       themselves~].  If a search fails for such a ~
                       hypothesis, we will cause a case split on the ~
                       partially instantiated hypothesis.  Note that this ~
                       case split will introduce a ``free variable'' into the ~
                       conjecture.  While sound, this will establish a goal ~
                       almost certain to fail since the restriction described ~
                       by this apparently necessary hypothesis constrains a ~
                       variable not involved in the problem.  To highlight ~
                       this oddity, we will rename the free variables in such ~
                       forced hypotheses by prefixing them with ~
                       ``UNBOUND-FREE-''.  This is not guaranteed to generate ~
                       a new variable but at least it generates an unusual ~
                       one.  If you see such a variable in a subsequent proof ~
                       (and did not introduce them yourself) you should ~
                       consider the possibility that the free variables of ~
                       this type-prescription rule were forced into the ~
                       conjecture."
                    (if (null (cdr (forced-hyps inst-hyps)))
                      0
                      1)
                    (forced-hyps inst-hyps)))
                (t state))
              (value ttree))))))))

(defun fix-pkg
  (pkg)
  (declare (xargs :guard (and (or (null pkg) (stringp pkg)) (not (equal pkg "")))))
  (if (and pkg (not (equal pkg *main-lisp-package-name*)))
    pkg
    "ACL2"))

(defun pack-to-string
  (l)
  (declare (xargs :guard (atom-listp l)))
  (coerce (packn1 l) 'string))

(defun gen-sym-sym
  (l sym)
  (declare (xargs :guard (and (atom-listp l) (symbolp sym))))
  (fix-intern-in-pkg-of-sym (pack-to-string l) sym))

(defun boolean-fn
  (fn sym)
  (let ((x (fix-intern-in-pkg-of-sym "X" sym)) (y (fix-intern-in-pkg-of-sym "Y" sym)))
    `(booleanp (,FN ,X ,Y))))

(defun reflexivity
  (fn sym)
  (let ((x (fix-intern-in-pkg-of-sym "X" sym)))
    `(,FN ,X ,X)))

(defun symmetry
  (fn sym)
  (let ((x (fix-intern-in-pkg-of-sym "X" sym)) (y (fix-intern-in-pkg-of-sym "Y" sym)))
    `(implies (,FN ,X ,Y) (,FN ,Y ,X))))

(defun transitivity
  (fn sym)
  (let ((x (fix-intern-in-pkg-of-sym "X" sym)) (y (fix-intern-in-pkg-of-sym "Y" sym))
      (z (fix-intern-in-pkg-of-sym "Z" sym)))
    `(implies (and (,FN ,X ,Y) (,FN ,Y ,Z)) (,FN ,X ,Z))))

(defun equivalence-relation-condition
  (fn sym)
  `(and ,(BOOLEAN-FN FN SYM)
    ,(REFLEXIVITY FN SYM)
    ,(SYMMETRY FN SYM)
    ,(TRANSITIVITY FN SYM)))

(defun find-candidate-equivalence-relation
  (clauses)
  (cond ((null clauses) nil)
    (t (let ((clause (car clauses)))
        (case-match clause
          (((fn x x)) (declare (ignore x)) fn)
          (& (find-candidate-equivalence-relation (cdr clauses))))))))

(defun collect-problematic-pre-equivalence-rule-names
  (lst)
  (cond ((null lst) nil)
    ((and (eq (access rewrite-rule (car lst) :equiv) 'equal)
       (equal (access rewrite-rule (car lst) :rhs) *t*)
       (not (variablep (fargn (access rewrite-rule (car lst) :lhs) 1)))
       (not (quotep (fargn (access rewrite-rule (car lst) :lhs) 1)))) (cons (access rewrite-rule (car lst) :rune)
        (collect-problematic-pre-equivalence-rule-names (cdr lst))))
    (t (collect-problematic-pre-equivalence-rule-names (cdr lst)))))

(defun chk-acceptable-equivalence-rule
  (name term ctx wrld state)
  (let* ((act-clauses (shallow-clausify term)) (fn (find-candidate-equivalence-relation act-clauses)))
    (cond ((null fn) (er soft
          ctx
          "~x0 is an unacceptable :EQUIVALENCE lemma.  Such a lemma ~
           must state that a given 2-place function symbol is ~
           Boolean, reflexive, symmetric, and transitive.  We cannot ~
           find the statement of reflexivity, which is the one we key ~
           on to identify the name of the alleged equivalence ~
           relation.  Perhaps you have forgotten to include it.  More ~
           likely, perhaps your relation takes more than two ~
           arguments.  We do not support n-ary equivalence relations, ~
           for n>2.  Sorry."
          name))
      (t (er-let* ((eqv-cond (translate (equivalence-relation-condition fn name)
               t
               t
               t
               ctx
               wrld
               state)))
          (let ((eqv-clauses (shallow-clausify eqv-cond)))
            (cond ((or (eq fn 'equal)
                 (and (not (flambdap fn))
                   (getpropc fn 'coarsenings nil wrld))) (er soft
                  ctx
                  "~x0 is already known to be an equivalence relation."
                  fn))
              (t (let ((subsumes (clause-set-subsumes *init-subsumes-count*
                       act-clauses
                       eqv-clauses)))
                  (cond ((eq subsumes t) (cond ((warning-disabled-p "Equiv") (value nil))
                        (t (let ((lst (scrunch-eq (collect-problematic-pre-equivalence-rule-names (getpropc fn 'lemmas nil wrld)))))
                            (cond (lst (pprogn (warning$ ctx
                                    ("Equiv")
                                    "Any lemma about ~p0, proved before ~x1 is ~
                                   marked as an equivalence relation, is ~
                                   stored so as to rewrite ~p0 to T.  After ~
                                   ~x1 is known to be an equivalence ~
                                   relation, such a rule would rewrite the ~
                                   left-hand side to the right-hand side, ~
                                   preserving ~x1.  You have previously ~
                                   proved ~n2 possibly problematic ~
                                   rule~#3~[~/s~] about ~x1, namely ~&3.  ~
                                   After ~x1 is marked as an equivalence ~
                                   relation you should reconsider ~
                                   ~#3~[this~/each~] problematic rule.  If ~
                                   the rule is merely in support of ~
                                   establishing that ~x1 is an equivalence ~
                                   relation, it may be appropriate to disable ~
                                   it permanently hereafter.  If the rule is ~
                                   now intended to rewrite left to right, you ~
                                   must prove the lemma again after ~x1 is ~
                                   known to be an equivalence relation."
                                    (fcons-term fn '(x y))
                                    fn
                                    (length lst)
                                    (strip-cadrs lst))
                                  (value nil)))
                              (t (value nil)))))))
                    (t (er soft
                        ctx
                        (if subsumes
                          "This low-level implementation error is a complete ~
                            surprise, as the subsumption check returned '? ~
                            for the :EQUIVALENCE lemma ~x0 for function ~
                            symbol ~x1.  This failure occurred when it was ~
                            checked that the equivalence-relation formula ~
                            subsumes the following canonical form: ~X23.  ~
                            Please contact the ACL2 implementors."
                          "~x0 is an unacceptable :EQUIVALENCE lemma for the ~
                          function symbol ~x1.  To be acceptable the formula ~
                          being proved must state that ~x1 is Boolean, ~
                          reflexive, symmetric, and transitive.  This is ~
                          checked by verifying that the formula subsumes the ~
                          following canonical form:  ~x2.  It does not.")
                        name
                        fn
                        (prettyify-clause-set eqv-clauses nil wrld)
                        nil))))))))))))

(defun add-equivalence-rule
  (rune nume term ens wrld)
  (let* ((act-clauses (shallow-clausify term)) (fn (find-candidate-equivalence-relation act-clauses)))
    (putprop fn
      'coarsenings
      (list fn)
      (putprop 'equal
        'coarsenings
        (append (getpropc 'equal 'coarsenings nil wrld) (list fn))
        (putprop fn
          'congruences
          (cons (list 'equal
              (list (make congruence-rule :rune rune :nume nume :equiv fn))
              (list (make congruence-rule :rune rune :nume nume :equiv fn)))
            (getpropc fn 'congruences nil wrld))
          (cond ((mv-let (ts ttree)
               (type-set (fcons-term* fn 'x 'y)
                 nil
                 nil
                 nil
                 ens
                 wrld
                 nil
                 nil
                 nil)
               (declare (ignore ttree))
               (ts-subsetp ts *ts-boolean*)) wrld)
            (t (add-type-prescription-rule rune
                nume
                (fcons-term* fn 'x 'y)
                (fcons-term* 'booleanp (fcons-term* fn 'x 'y))
                nil
                ens
                wrld
                t))))))))

(defun chk-acceptable-refinement-rule
  (name term ctx wrld state)
  (let ((str "~x0 does not have the form of a :REFINEMENT rule.  See :DOC refinement."))
    (case-match term
      (('implies (equiv1 x y) (equiv2 x y)) (cond ((and (equivalence-relationp equiv1 wrld)
             (equivalence-relationp equiv2 wrld)
             (variablep x)
             (variablep y)
             (not (eq x y))) (cond ((refinementp equiv1 equiv2 wrld) (er soft
                  ctx
                  "~x0 is already known to be a refinement of ~
                          ~x1.  See :DOC refinement."
                  equiv1
                  equiv2))
              (t (value nil))))
          (t (er soft ctx str name))))
      (& (er soft ctx str name)))))

(defun collect-coarsenings
  (wrld)
  (let ((all-equivs (getpropc 'equal 'coarsenings nil wrld)))
    (pairlis$ all-equivs
      (getprop-x-lst all-equivs 'coarsenings wrld))))

(defun putprop-coarsenings
  (alist wrld)
  (cond ((null alist) wrld)
    ((equal (getpropc (caar alist) 'coarsenings nil wrld)
       (cdar alist)) (putprop-coarsenings (cdr alist) wrld))
    (t (putprop (caar alist)
        'coarsenings
        (cdar alist)
        (putprop-coarsenings (cdr alist) wrld)))))

(defun union-values
  (lst alist)
  (cond ((null lst) nil)
    (t (union-eq (cdr (assoc-eq (car lst) alist))
        (union-values (cdr lst) alist)))))

(defun extend-value-set
  (lst alist)
  (append lst
    (set-difference-eq (union-values lst alist) lst)))

(defun extend-each-value-set
  (alist1 alist2)
  (cond ((null alist1) nil)
    (t (cons (cons (caar alist1) (extend-value-set (cdar alist1) alist2))
        (extend-each-value-set (cdr alist1) alist2)))))

(defun close-value-sets
  (alist)
  (let ((new-alist (extend-each-value-set alist alist)))
    (cond ((equal new-alist alist) alist)
      (t (close-value-sets new-alist)))))

(defun add-refinement-rule
  (name nume term wrld)
  (declare (ignore name nume))
  (let ((equiv1 (ffn-symb (fargn term 1))) (equiv2 (ffn-symb (fargn term 2))))
    (putprop-coarsenings (close-value-sets (put-assoc-eq equiv1
          (append (getpropc equiv1 'coarsenings nil wrld)
            (list equiv2))
          (collect-coarsenings wrld)))
      wrld)))

(defun corresponding-args-eq-except
  (args1 args2 xk yk)
  (cond ((null args1) t)
    ((eq (car args1) xk) (and (eq (car args2) yk)
        (corresponding-args-eq-except (cdr args1) (cdr args2) xk yk)))
    (t (and (eq (car args1) (car args2))
        (corresponding-args-eq-except (cdr args1) (cdr args2) xk yk)))))

(defun duplicate-vars
  (term)
  (mv-let (seen dups)
    (duplicate-vars-1 term nil nil)
    (declare (ignore seen))
    dups))

(defun replace-duplicate-vars-with-anonymous-var
  (term)
  (replace-duplicate-vars-with-anonymous-var-1 term
    (duplicate-vars term)))

(defun split-at-position
  (posn lst acc)
  (cond ((eql posn 1) (mv acc lst))
    (t (split-at-position (1- posn) (cdr lst) (cons (car lst) acc)))))

(defun make-pequiv-pattern
  (term addr)
  (cond ((endp addr) (assert$ (variablep term) term))
    (t (assert$ (and (nvariablep term)
          (not (fquotep term))
          (not (flambda-applicationp term)))
        (mv-let (pre-rev next/post)
          (split-at-position (car addr) (fargs term) nil)
          (make pequiv-pattern
            :fn (ffn-symb term)
            :posn (car addr)
            :pre-rev pre-rev
            :post (cdr next/post)
            :next (make-pequiv-pattern (car next/post) (cdr addr))))))))

(defun make-pequiv
  (term addr nume equiv rune)
  (make pequiv
    :pattern (make-pequiv-pattern (replace-duplicate-vars-with-anonymous-var term)
      addr)
    :unify-subst nil
    :congruence-rule (make congruence-rule :rune rune :nume nume :equiv equiv)))

(defun interpret-term-as-congruence-rule
  (name term wrld)
  (let ((pairs (unprettyify (remove-guard-holders term wrld))) (hyp-msg "~x0 is an unacceptable :CONGRUENCE rule.  The ~
                    single hypothesis of a :CONGRUENCE rule must be a ~
                    term of the form (equiv x y), where equiv has ~
                    been proved to be an equivalence relation and x ~
                    and y are distinct variable symbols.  The ~
                    hypothesis of ~x0, ~x1, is not of this form.")
      (concl-msg "~x0 is an unacceptable :CONGRUENCE rule because its ~
                    conclusion does not have the expected form.  See :DOC ~
                    congruence.")
      (failure-msg "~x0 is an unacceptable :CONGRUENCE rule because ~@1.  ~
                      See :DOC congruence."))
    (cond ((and (int= (length pairs) 1) (int= (length (caar pairs)) 1)) (let ((hyp (caaar pairs)) (concl (quote-normal-form (cdar pairs))))
          (case-match hyp
            ((equiv1 xk yk) (cond ((and (variablep xk)
                   (variablep yk)
                   (equivalence-relationp equiv1 wrld)) (case-match concl
                    ((equiv2 (fn . args1) (fn . args2)) (cond ((or (not (equivalence-relationp equiv2 wrld))
                           (not (symbolp fn))
                           (eq fn 'quote)
                           (eq fn 'if)) (mv nil (msg concl-msg name)))
                        ((and (all-variablep args1)
                           (no-duplicatesp-eq args1)
                           (member-eq xk args1)
                           (not (member-eq yk args1))
                           (corresponding-args-eq-except args1 args2 xk yk)) (mv :classic (list* fn
                              equiv1
                              (1+ (- (length args1) (length (member-eq xk args1))))
                              equiv2
                              nil)))
                        ((or (ffnnamep-lst 'if args1)
                           (ffnnamep-lst 'implies args1)
                           (ffnnamep-lst 'equal args1)
                           (lambda-subtermp-lst args1)) (let ((bad-fns (append (and (ffnnamep-lst 'if args1) '(if))
                                 (and (ffnnamep-lst 'implies args1) '(implies))
                                 (and (ffnnamep-lst 'equal args1) '(equal)))) (bad-lambda-p (lambda-subtermp-lst args1)))
                            (mv nil
                              (msg failure-msg
                                name
                                (cond ((and bad-fns bad-lambda-p) (msg "the function symbol~#0~[ ~&0~/s ~&0~] ~
                                        and a lambda application occur in the ~
                                        conclusion of the rule"
                                      bad-fns))
                                  (bad-fns (msg "the function symbol~#0~[ ~&0 ~
                                        occurs~/s ~&0 occur~] in the ~
                                        conclusion of the rule"
                                      bad-fns))
                                  (t (msg "a lambda application occurs in the ~
                                        conclusion of the rule.")))))))
                        ((dumb-occur-var-lst *anonymous-var* term) (mv nil
                            (msg failure-msg
                              name
                              (msg "the variable ~x0, which is used in a special ~
                               way by the implementation, occurs in the rule"
                                *anonymous-var*))))
                        (t (let ((addr1 (var-address xk (fargn concl 1) nil)) (addr2 (var-address yk (fargn concl 2) nil)))
                            (cond ((or (null addr1) (null addr2)) (mv nil
                                  (msg failure-msg
                                    name
                                    (cond ((null addr1) (msg "the variable ~x0 does not occur in ~x1"
                                          xk
                                          (fargn concl 1)))
                                      (t (msg "the variable ~x0 does not occur in ~x1"
                                          yk
                                          (fargn concl 2)))))))
                              ((or (eq addr1 t) (eq addr2 t)) (mv nil
                                  (msg failure-msg
                                    name
                                    (cond ((null addr1) (msg "the variable ~x0 occurs more than once ~
                                     in ~x1"
                                          xk
                                          (fargn concl 1)))
                                      (t (msg "the variable ~x0 occurs more than once ~
                                     in ~x1"
                                          yk
                                          (fargn concl 2)))))))
                              ((not (equal addr1 addr2)) (mv nil
                                  (msg failure-msg
                                    name
                                    (msg "the variables ~x0 and ~x1 occur at ~
                                   different positions in the first and ~
                                   second arguments, respectively, of ~x3 in ~
                                   the conclusion of the proposed rule"
                                      xk
                                      yk
                                      equiv2))))
                              ((not (equal args2 (subst-var-lst yk xk args1))) (mv nil
                                  (msg failure-msg
                                    name
                                    (msg "the second argument of its conclusion is ~
                                   not equal to the result of substituting ~
                                   ~x0 for ~x1 in its first argument"
                                      yk
                                      xk))))
                              (t (mv (if (member-eq xk args1)
                                    :shallow :deep)
                                  (list* fn equiv1 addr1 equiv2 (fargn concl 1)))))))))
                    (& (mv nil (msg concl-msg name)))))
                (t (mv nil (msg hyp-msg name hyp)))))
            (& (mv nil (msg hyp-msg name hyp))))))
      (t (mv nil
          (msg failure-msg
            name
            "the supplied formula does not generate a single ~
                      conjunct of the form (implies (equiv1 xk yk) (equiv2 ~
                      (fn ...) (fn ...))), where equiv1 and equiv2 are ~
                      equivalence relations"))))))

(defun some-congruence-rule-same
  (equiv rules)
  (cond ((null rules) nil)
    ((eq equiv (access congruence-rule (car rules) :equiv)) (car rules))
    (t (some-congruence-rule-same equiv (cdr rules)))))

(defun some-congruence-rule-has-refinement
  (equiv rules wrld)
  (cond ((null rules) nil)
    ((refinementp equiv
       (access congruence-rule (car rules) :equiv)
       wrld) (car rules))
    (t (some-congruence-rule-has-refinement equiv (cdr rules) wrld))))

(defun chk-acceptable-congruence-rule
  (name term ctx wrld state)
  (mv-let (flg x)
    (interpret-term-as-congruence-rule name term wrld)
    (cond ((not flg) (er soft ctx "~@0" x))
      (t (let ((fn (car x)) (equiv1 (cadr x))
            (addr (caddr x))
            (equiv2 (cadddr x)))
          (pprogn (cond ((eq equiv1 'equal) (warning$ ctx
                  "Equiv"
                  "The :CONGRUENCE rule ~x0 will have no effect on ~
                          proofs because ACL2 already knows that ~x1 refines ~
                          every equivalence relation."
                  name
                  'equal))
              ((and (eq equiv2 'iff)
                 (mv-let (ts ttree)
                   (type-set (cons-term fn (formals fn wrld))
                     nil
                     nil
                     nil
                     (ens state)
                     wrld
                     nil
                     nil
                     nil)
                   (declare (ignore ttree))
                   (ts-subsetp ts *ts-boolean*))) (warning$ ctx
                  "Equiv"
                  "The :CONGRUENCE rule ~x0 can be strengthened by ~
                          replacing the outer equivalence relation, ~x1, by ~
                          ~x2.  See :DOC congruence, in particular (near the ~
                          end) the Remark on Replacing IFF by EQUAL."
                  name
                  'iff
                  'equal))
              (t state))
            (cond ((eq flg :classic) (let* ((k addr) (temp (nth k
                        (assoc-eq equiv2 (getpropc fn 'congruences nil wrld)))))
                  (cond ((some-congruence-rule-same equiv1 temp) (warning$ ctx
                        "Equiv"
                        "The previously added :CONGRUENCE lemma, ~x0, ~
                         establishes that ~x1 preserves ~x2 in the ~n3 slot ~
                         of ~x4.  Thus, ~x5 is unnecessary."
                        (base-symbol (access congruence-rule
                            (some-congruence-rule-same equiv1 temp)
                            :rune))
                        equiv1
                        equiv2
                        (cons k 'th)
                        fn
                        name))
                    ((some-congruence-rule-has-refinement equiv1 temp wrld) (warning$ ctx
                        "Equiv"
                        "The previously added :CONGRUENCE lemma, ~x0, ~
                         establishes that ~x1 preserves ~x2 in the ~n3 slot ~
                         of ~x4.  But we know that ~x5 is a refinement of ~
                         ~x1.  Thus, ~x6 is unnecessary."
                        (base-symbol (access congruence-rule
                            (some-congruence-rule-has-refinement equiv1 temp wrld)
                            :rune))
                        (access congruence-rule
                          (some-congruence-rule-has-refinement equiv1 temp wrld)
                          :equiv)
                        equiv2
                        (cons k 'th)
                        fn
                        equiv1
                        name))
                    (t state))))
              (t (observation ctx
                  "The rule ~x0 is a ~s1 patterned congruence rule.  ~
                          See :DOC patterned-congruence."
                  name
                  (if (eq flg :shallow)
                    "shallow"
                    (assert$ (eq flg :deep) "deep")))))
            (value nil)))))))

(defun add-congruence-rule-to-congruence
  (rule k congruence)
  (update-nth k (cons rule (nth k congruence)) congruence))

(defun cons-assoc-eq-rec
  (key val alist)
  (declare (xargs :guard (and (symbol-alistp alist)
        (true-list-listp alist)
        (assoc-eq key alist))))
  (cond ((endp alist) (er hard
        'cons-assoc-eq-rec
        "Implementation error: Reached the end of the alist for key ~x0!"
        key))
    ((eq key (caar alist)) (acons key (cons val (cdar alist)) (cdr alist)))
    (t (cons (car alist) (cons-assoc-eq-rec key val (cdr alist))))))

(defun cons-assoc-eq
  (key val alist)
  (declare (xargs :guard (and (symbol-alistp alist) (true-list-listp alist))))
  (cond ((endp alist) (list (list key val)))
    ((assoc-eq key alist) (cons-assoc-eq-rec key val alist))
    (t (acons key (list val) alist))))

(defun add-congruence-rule
  (rune nume term wrld)
  (mv-let (flg x)
    (interpret-term-as-congruence-rule (base-symbol rune)
      term
      wrld)
    (let ((fn (car x)) (equiv1 (cadr x))
        (addr (caddr x))
        (equiv2 (cadddr x))
        (lhs (cddddr x)))
      (cond ((eq flg :classic) (let* ((k addr) (temp (assoc-eq equiv2 (getpropc fn 'congruences nil wrld)))
              (equiv2-congruence (or temp
                  (cons equiv2 (make-list-ac (arity fn wrld) nil nil))))
              (rst (if temp
                  (remove1-equal temp (getpropc fn 'congruences nil wrld))
                  (getpropc fn 'congruences nil wrld))))
            (putprop fn
              'congruences
              (cons (add-congruence-rule-to-congruence (make congruence-rule :rune rune :nume nume :equiv equiv1)
                  k
                  equiv2-congruence)
                rst)
              wrld)))
        ((null flg) (er hard!
            'add-congruence-rule
            "Implementation error: ~x0 returned failure when attempting to ~
            apply ~x1.  Please contact the ACL2 implementors."
            'interpret-term-as-congruence-rule
            'add-congruence-rule))
        (t (assert$ (and (member-eq flg '(:deep :shallow))
              (not (or (variablep lhs) (fquotep lhs) (lambda-applicationp lhs)))
              (consp addr))
            (let* ((pequiv (make-pequiv lhs addr nume equiv1 rune)) (sym (if (eq flg :shallow)
                    fn
                    (let ((arg (nth (car addr) lhs)))
                      (assert$ (not (or (variablep arg) (fquotep arg) (lambda-applicationp arg)))
                        (ffn-symb arg)))))
                (prop (getpropc sym 'pequivs nil wrld))
                (new-prop (let ((prop (or prop *empty-pequivs-property*)))
                    (cond ((eq flg :shallow) (change pequivs-property
                          prop
                          :shallow (cons-assoc-eq equiv2
                            pequiv
                            (pequivs-property-field prop :shallow))))
                      (t (let ((new (cons-assoc-eq equiv2
                               pequiv
                               (pequivs-property-field prop :deep))))
                          (cond ((and (eq fn sym)
                               (not (pequivs-property-field prop :deep-pequiv-p))) (change pequivs-property prop :deep new :deep-pequiv-p t))
                            (t (change pequivs-property prop :deep new))))))))
                (parent-prop (and (eq flg :deep)
                    (not (eq fn sym))
                    (getpropc fn 'pequivs nil wrld))))
              (putprop sym
                'pequivs
                new-prop
                (cond ((or (eq fn sym) (eq flg :shallow)) wrld)
                  ((null parent-prop) (putprop fn
                      'pequivs
                      (make pequivs-property
                        :shallow nil
                        :deep nil
                        :deep-pequiv-p t)
                      wrld))
                  ((pequivs-property-field parent-prop :deep-pequiv-p) wrld)
                  (t (putprop fn
                      'pequivs
                      (change pequivs-property parent-prop :deep-pequiv-p t)
                      wrld)))))))))))

(defun chk-destructure-definition
  (name term ctx wrld state)
  (mv-let (hyps equiv fn args body ttree)
    (destructure-definition term nil nil wrld nil)
    (declare (ignore hyps equiv args body ttree))
    (cond ((null fn) (er soft
          ctx
          "~x0 cannot be stored as a :DEFINITION rule ~
                      because the :COROLLARY formula, ~p1, is not of ~
                      the proper form.  See :DOC definition."
          name
          (untranslate term t wrld)))
      (t (value nil)))))

(defun chk-acceptable-definition-install-body
  (fn hyps
    equiv
    args
    body
    install-body
    install-body-supplied-p
    ctx
    state)
  (let ((install-body (if install-body-supplied-p
         install-body
         :normalize)) (er-preamble (msg "For a :DEFINITION rule with non-nil :INSTALL-BODY value~@0,"
          (if install-body-supplied-p
            ""
            " (default :NORMALIZE)")))
      (install-body-msg (if install-body-supplied-p
          ""
          (msg "  Please add :INSTALL-BODY ~x0 to your :DEFINITION rule ~
                 class."
            nil))))
    (cond ((null install-body) (value nil))
      ((not (arglistp args)) (er soft
          ctx
          "~@0 the arguments on the left-hand side of the rule must be a list ~
           of distinct variables, unlike ~x1.~@2  See :DOC definition."
          er-preamble
          args
          install-body-msg))
      ((not (equivalence-relationp equiv (w state))) (er soft
          ctx
          "~@0 the function symbol at the top of the conclusion must be an ~
           equivalence relation, unlike ~x1.~@2  See :DOC definition."
          er-preamble
          equiv
          install-body-msg))
      ((free-varsp-member-lst hyps args) (er soft
          ctx
          "~@0 the hypotheses must not contain free variables that are not ~
           among the variables on its left-hand side.  The ~#1~[variable ~&1 ~
           violates~/variables ~&1 violate~] this requirement.~@2  See :DOC ~
           definition."
          er-preamble
          (reverse (set-difference-eq (all-vars1-lst hyps nil) args))
          install-body-msg))
      ((free-varsp-member body args) (er soft
          ctx
          "~@0 the right-hand side of a :DEFINITION rule must not contain free ~
           variables that are not among the variables on its left-hand side.  ~
           The ~#1~[variable ~&1 violates~/variables ~&1 violate~] this ~
           requirement.~@2  See :DOC definition."
          er-preamble
          (reverse (set-difference-eq (all-vars body) args))
          install-body-msg))
      (t (pprogn (cond ((member-eq fn *definition-minimal-theory*) (warning$ ctx
                "Definition"
                "The proposed :DEFINITION rule might not ~
                                  always be the one applied when expanding ~
                                  calls of ~x0 during proofs.  Instead, these ~
                                  calls and, more generally, calls of any ~
                                  function symbol that is in the list ~x1, ~
                                  will often be expanded using the original ~
                                  definition of the function symbol.  Add ~
                                  :INSTALL-BODY ~x2 to the proposed ~
                                  :DEFINITION rule class to avoid this ~
                                  warning."
                fn
                '*definition-minimal-theory*
                nil))
            (t state))
          (value nil))))))

(defun chk-acceptable-definition-rule
  (name clique
    controller-alist
    install-body-tail
    term
    ctx
    ens
    wrld
    state)
  (mv-let (hyps equiv fn args body ttree)
    (destructure-definition term nil ens wrld nil)
    (cond ((eq fn 'hide) (er soft
          ctx
          "It is illegal to make a definition rule for ~x0, because of the ~
          special role of this function in the ACL2 rewriter."
          'hide))
      (t (let ((rule (make rewrite-rule
               :rune *fake-rune-for-anonymous-enabled-rule*
               :nume nil
               :hyps (preprocess-hyps hyps wrld)
               :equiv equiv
               :lhs (mcons-term fn args)
               :var-info (var-counts args body)
               :rhs body
               :subclass 'definition
               :heuristic-info (cons clique controller-alist)
               :backchain-limit-lst nil)))
          (er-progn (chk-rewrite-rule-warnings name
              nil
              nil
              rule
              ctx
              ens
              wrld
              state)
            (chk-acceptable-definition-install-body fn
              hyps
              equiv
              args
              body
              (cadr install-body-tail)
              install-body-tail
              ctx
              state)
            (value ttree)))))))

(defun chk-acceptable-induction-rule
  (name term ctx wrld state)
  (declare (ignore name term ctx wrld))
  (value nil))

(defun add-induction-rule
  (rune nume pat-term cond-term scheme-term term wrld)
  (declare (ignore term))
  (let ((fn (ffn-symb pat-term)))
    (putprop fn
      'induction-rules
      (cons (make induction-rule
          :rune rune
          :nume nume
          :pattern pat-term
          :condition (flatten-ands-in-lit cond-term)
          :scheme scheme-term)
        (getpropc fn 'induction-rules nil wrld))
      wrld)))

(defun chk-acceptable-type-set-inverter-rule
  (name ts term ctx ens wrld state)
  (let* ((vars (all-vars term)))
    (cond ((not (and (ffn-symb-p term 'equal)
           (equal vars '(x))
           (equal (all-vars (fargn term 1)) (all-vars (fargn term 2))))) (er soft
          ctx
          "The :COROLLARY of a :TYPE-SET-INVERTER rule must be of the form ~
           (equal old-expr new-expr), where new-expr and old-expr are each ~
           terms containing the single free variable X.  ~p0 is not of this ~
           form, so ~x1 is an illegal :TYPE-SET-INVERTER rule.  See :DOC ~
           type-set-inverter."
          (untranslate term t wrld)
          name))
      (t (mv-let (ts2 ttree)
          (cond ((null ts) (type-set-implied-by-term 'x
                nil
                (fargn term 2)
                ens
                wrld
                nil))
            (t (mv ts nil)))
          (cond ((not (and (integerp ts2)
                 (<= *min-type-set* ts2)
                 (<= ts2 *max-type-set*))) (cond ((null ts) (mv t
                    (er hard
                      ctx
                      "Type-set-implied-by-term returned ~x0 instead of a ~
                         type-set!"
                      ts2)
                    state))
                (t (er soft
                    ctx
                    "The :TYPE-SET of a :TYPE-SET-INVERTER rule must be a ~
                       type-set, i.e., an integer n such that ~x0 <= n <= ~x1. ~
                       But ~x2 is not so ~x3 is an illegal :TYPE-SET-INVERTER ~
                       rule.  See :DOC type-set-inverter."
                    *min-type-set*
                    *max-type-set*
                    ts2
                    name))))
            (t (mv-let (required-old-expr ttree)
                (convert-type-set-to-term 'x ts2 ens wrld ttree)
                (cond ((not (tautologyp (fcons-term* 'iff (fargn term 2) required-old-expr)
                       wrld)) (er soft
                      ctx
                      "The right-hand side of the :COROLLARY of a :TYPE-SET-INVERTER ~
                 rule with :TYPE-SET ~x0 must be propositionally equivalent to ~
                 ~p1 but you have specified ~p2.  Thus, ~x3 is an illegal ~
                 :TYPE-SET-INVERTER rule.  See :doc type-set-inverter."
                      ts2
                      (untranslate required-old-expr t wrld)
                      (untranslate (fargn term 2) t wrld)
                      name))
                  (t (value ttree)))))))))))

(defun add-type-set-inverter-rule
  (rune nume ts term ens wrld)
  (mv-let (ts ttree)
    (cond ((null ts) (type-set-implied-by-term 'x
          nil
          (fargn term 2)
          ens
          wrld
          nil))
      (t (mv ts nil)))
    (declare (ignore ttree))
    (global-set 'type-set-inverter-rules
      (cons (make type-set-inverter-rule
          :nume nume
          :rune rune
          :ts ts
          :terms (flatten-ands-in-lit (fargn term 1)))
        (global-val 'type-set-inverter-rules wrld))
      wrld)))

(defun tilde-@-illegal-clause-processor-sig-msg
  (cl-proc stobjs-in stobjs-out)
  (cond ((null (cdr stobjs-out)) (cond ((car stobjs-out) (msg "~x0 returns a single argument but it is a stobj"
            cl-proc))
        ((or (equal stobjs-in '(nil)) (equal stobjs-in '(nil nil))) nil)
        (t (msg "~x0 returns a single argument, but doesn't take exactly one ~
                   or two arguments, both not stobjs"
            cl-proc))))
    ((and (null (car stobjs-in))
       (cdr stobjs-in)
       (null (cadr stobjs-in))
       (not (member-eq nil (cddr stobjs-in)))
       (null (car stobjs-out))
       (cdr stobjs-out)
       (null (cadr stobjs-out))
       (member-equal (member-eq nil (cddr stobjs-out))
         '(nil (nil)))) nil)
    (t (msg "both the arguments and results of ~x0 in this case are expected to ~
          contain stobjs in exactly all positions other than the first two ~
          and possibly the last"
        cl-proc))))

(defun destructure-clause-processor-rule
  (term)
  (case-match term
    (('implies hyp (ev ('disjoin clause) alist)) (mv-let (hyps meta-extract-flg)
        (remove-meta-extract-global-hyps (remove1-equal (fcons-term* 'pseudo-term-listp clause)
            (remove1-equal (fcons-term* 'alistp alist)
              (flatten-ands-in-lit hyp)))
          ev)
        (case-match hyps
          (((ev ('conjoin-clauses cl-result) &)) (case-match cl-result
              (('clauses-result (cl-proc !clause . rest-args)) (mv t
                  cl-proc
                  clause
                  alist
                  rest-args
                  ev
                  (cadr cl-result)
                  meta-extract-flg))
              ((cl-proc !clause . rest-args) (mv nil
                  cl-proc
                  clause
                  alist
                  rest-args
                  ev
                  cl-result
                  meta-extract-flg))
              (& (mv :error nil nil nil nil nil nil nil))))
          (& (mv :error nil nil nil nil nil nil nil)))))
    (& (mv :error nil nil nil nil nil nil nil))))

(defun chk-acceptable-clause-processor-rule
  (name term ctx wrld state)
  (er-progn (chk-non-local-in-non-trivial-encapsulate "Rules of class :CLAUSE-PROCESSOR"
      t
      ctx
      wrld
      state)
    (let ((str "No :CLAUSE-PROCESSOR rule can be generated from ~x0 ~
               because~|~%~p1~|~%does not have the necessary form:  ~@2.  See ~
               :DOC clause-processor."))
      (mv-let (clauses-result-call-p cl-proc
          clause
          alist
          rest-args
          ev
          cl-proc-call
          meta-extract-flg)
        (destructure-clause-processor-rule term)
        (cond ((eq clauses-result-call-p :error) (er soft
              ctx
              str
              name
              (untranslate term t wrld)
              "it fails to satisfy basic syntactic criteria"))
          ((not (and (symbolp cl-proc) (function-symbolp cl-proc wrld))) (er soft
              ctx
              str
              name
              (untranslate term t wrld)
              (msg "the symbol ~x0 is not a function symbol in the current world"
                cl-proc)))
          (t (mv-let (erp t-cl-proc-call bindings state)
              (translate1 cl-proc-call
                :stobjs-out '((:stobjs-out . :stobjs-out))
                t
                ctx
                wrld
                state)
              (declare (ignore bindings))
              (cond (erp (er soft
                    ctx
                    str
                    name
                    (untranslate term t wrld)
                    (msg "the clause-processor call is not in a form ~
                           suitable for evaluation (as may be indicated by an ~
                           error message above)")))
                (t (assert$ (equal cl-proc-call t-cl-proc-call)
                    (let* ((stobjs-in (stobjs-in cl-proc wrld)) (stobjs-out (stobjs-out cl-proc wrld)))
                      (er-progn (cond ((if clauses-result-call-p
                             (equal stobjs-out '(nil))
                             (not (equal stobjs-out '(nil)))) (er soft
                              ctx
                              str
                              name
                              (untranslate term t wrld)
                              (msg "~x0 returns ~#1~[only~/more than~] one ~
                                  value and hence there should be ~
                                  ~#1~[no~/a~] call of ~x2"
                                cl-proc
                                (if clauses-result-call-p
                                  0
                                  1)
                                'clauses-result)))
                          (t (let ((msg (tilde-@-illegal-clause-processor-sig-msg cl-proc
                                   stobjs-in
                                   stobjs-out)))
                              (cond (msg (er soft ctx str name (untranslate term t wrld) msg))
                                (t (value nil))))))
                        (let* ((user-hints-p (cdr stobjs-in)) (user-hints (cond (user-hints-p (car rest-args)) (t nil)))
                            (stobjs-called (cond (user-hints-p (cdr rest-args)) (t rest-args)))
                            (non-alist-vars (if user-hints
                                (list* clause user-hints stobjs-called)
                                (list* clause stobjs-called)))
                            (vars (cons alist non-alist-vars))
                            (bad-vars (collect-non-legal-variableps vars)))
                          (cond (bad-vars (er soft
                                ctx
                                str
                                name
                                (untranslate term t wrld)
                                (msg "the clause-processor function must be ~
                                    applied to a list of distinct variable ~
                                    and stobj names, but ~&0 ~#0~[is~/are~] ~
                                    not"
                                  (untranslate-lst bad-vars nil wrld))))
                            ((not (no-duplicatesp vars)) (cond ((no-duplicatesp non-alist-vars) (er soft
                                    ctx
                                    str
                                    name
                                    (untranslate term t wrld)
                                    (msg "the proposed :clause-processor ~
                                           rule uses ~x0 as its alist ~
                                           variable, but this variable also ~
                                           occurs in the argument list of the ~
                                           clause-processor function, ~x1"
                                      alist
                                      cl-proc)))
                                (t (er soft
                                    ctx
                                    str
                                    name
                                    (untranslate term t wrld)
                                    (msg "the clause-processor function must ~
                                           be applied to a list of distinct ~
                                           variable and stobj names, but the ~
                                           list ~x0 contains duplicates"
                                      non-alist-vars)))))
                            (t (value nil))))
                        (er-let* ((ttree (chk-evaluator-use-in-rule name
                               cl-proc
                               nil
                               (and meta-extract-flg '(meta-extract-global-fact+))
                               :clause-processor ev
                               ctx
                               wrld
                               state)))
                          (er-progn (chk-rule-fn-guard "clause-processor"
                              :clause-processor cl-proc
                              ctx
                              wrld
                              state)
                            (chk-evaluator ev wrld ctx state)
                            (value ttree)))))))))))))))

(defun add-clause-processor-rule
  (name well-formedness-guarantee term wrld)
  (mv-let (clauses-result-call-p cl-proc
      clause
      alist
      rest-args
      ev
      cl-proc-call
      meta-extract-flg)
    (destructure-clause-processor-rule term)
    (declare (ignore clause
        alist
        rest-args
        ev
        cl-proc-call
        meta-extract-flg))
    (assert$ (and (not (eq clauses-result-call-p :error))
        (symbolp cl-proc)
        (function-symbolp cl-proc wrld))
      (putprop cl-proc
        'clause-processor
        (or well-formedness-guarantee t)
        (global-set 'clause-processor-rules
          (acons name term (global-val 'clause-processor-rules wrld))
          wrld)))))

(defun trusted-cl-proc-table-guard
  (key val wrld)
  (let ((er-msg "The proposed designation of a trusted clause-processor is ~
                 illegal because ~@0.  See :DOC ~
                 define-trusted-clause-processor."))
    (cond ((not (or (ttag wrld) (global-val 'boot-strap-flg wrld))) (mv nil
          (msg er-msg
            "there is not an active ttag (also see :DOC ttag)")))
      ((not (symbolp key)) (mv nil
          (msg er-msg
            (msg "the clause-processor must be a symbol, unlike ~x0"
              key))))
      ((not (function-symbolp key wrld)) (mv nil
          (msg er-msg
            (msg "the clause-processor must be a function symbol, unlike ~
                     ~x0"
              key))))
      ((not (all-function-symbolps val wrld)) (cond ((not (symbol-listp val)) (mv nil
              (msg er-msg
                "the indicated supporters list is not a true list of ~
                       symbols")))
          (t (mv nil
              (msg er-msg
                (msg "the indicated supporter~#0~[ ~&0 is not a ~
                              function symbol~/s ~&0 are not function ~
                              symbols~] in the current ACL2 world"
                  (non-function-symbols val wrld)))))))
      (t (let ((failure-msg (tilde-@-illegal-clause-processor-sig-msg key
               (stobjs-in key wrld)
               (stobjs-out key wrld))))
          (cond (failure-msg (mv nil (msg er-msg failure-msg)))
            (t (mv t nil))))))))

(defun primitive-instructionp
  (instr state)
  (let* ((cmd (car (make-official-pc-instr instr))) (typ (pc-command-type cmd)))
    (and (member-eq typ '(primitive atomic-macro))
      (acl2-system-namep-state (intern-in-package-of-symbol (symbol-name cmd)
          'induct)
        state))))

(defun non-primitive-instructions
  (instructions state)
  (cond ((endp instructions) nil)
    ((primitive-instructionp (car instructions) state) (non-primitive-instructions (cdr instructions) state))
    (t (cons (car instructions)
        (non-primitive-instructions (cdr instructions) state)))))

(defun chk-primitive-instruction-listp
  (instructions ctx state)
  (if (true-listp instructions)
    (value nil)
    (er soft
      ctx
      "An :instructions argument must be a ~
         true-list and ~x0 is not."
      instructions)))

(defun translate-instructions
  (instructions ctx state)
  (if (eq instructions t)
    (value t)
    (er-progn (chk-primitive-instruction-listp instructions ctx state)
      (value instructions))))

(defun controller-alistp
  (clique alist wrld)
  (cond ((atom alist) (cond ((null alist) (null clique)) (t nil)))
    ((and (consp (car alist))
       (symbolp (caar alist))
       (member-eq (caar alist) clique)
       (boolean-listp (cdar alist))
       (= (length (cdar alist)) (arity (caar alist) wrld))) (controller-alistp (remove1-eq (caar alist) clique)
        (cdr alist)
        wrld))
    (t nil)))

(defun alist-to-keyword-alist
  (alist ans)
  (declare (xargs :guard (alistp alist)))
  (cond ((endp alist) ans)
    (t (alist-to-keyword-alist (cdr alist)
        (cons (caar alist) (cons (cdar alist) ans))))))

(defun eliminate-macro-aliases
  (lst macro-aliases wrld)
  (cond ((atom lst) (cond ((null lst) (mv nil nil))
        (t (mv :error "does not end in nil"))))
    (t (mv-let (flg rst)
        (eliminate-macro-aliases (cdr lst) macro-aliases wrld)
        (cond ((eq flg :error) (mv :error rst))
          (t (let* ((next (car lst)) (fn (deref-macro-name next macro-aliases)))
              (cond ((not (and (symbolp fn) (function-symbolp fn wrld))) (mv :error (msg "contains ~x0" next)))
                ((or (eq flg :changed) (not (eq next fn))) (mv :changed (cons fn rst)))
                (t (mv nil lst))))))))))

(defun fix-loop-stopper-alist
  (x macro-aliases wrld)
  (cond ((null x) (mv nil nil))
    ((atom x) (mv :error nil))
    ((not (and (true-listp (car x))
         (<= 2 (length (car x)))
         (legal-variablep (caar x))
         (legal-variablep (cadar x))
         (not (eq (caar x) (cadar x))))) (mv :error nil))
    (t (mv-let (flg1 fns)
        (eliminate-macro-aliases (cddar x) macro-aliases wrld)
        (cond ((eq flg1 :error) (mv :error nil))
          (t (mv-let (flg2 rest)
              (fix-loop-stopper-alist (cdr x) macro-aliases wrld)
              (cond (flg1 (mv t (cons (list* (caar x) (cadar x) fns) rest)))
                (flg2 (mv t (cons (car x) rest)))
                (t (mv nil x))))))))))

(defun guess-controller-alist-for-definition-rule
  (names formals body ctx wrld state)
  (let ((t-machine (termination-machine nil
         nil
         names
         formals
         body
         nil
         nil
         (default-ruler-extenders wrld))))
    (er-let* ((m (guess-measure (car names)
           nil
           formals
           0
           t-machine
           ctx
           wrld
           state)))
      (value (list (cons (car names)
            (make-controller-pocket formals (all-vars m))))))))

(defun chk-legal-linear-trigger-terms1
  (term lst name ctx state)
  (cond ((null lst) (value nil))
    ((let ((hyp-vars (all-vars-in-hyps (caar lst))))
       (or (eq hyp-vars t)
         (subsetp-eq (set-difference-eq (all-vars (cdar lst)) hyp-vars)
           (all-vars term)))) (chk-legal-linear-trigger-terms1 term
        (cdr lst)
        name
        ctx
        state))
    (t (er soft
        ctx
        "Each term in the :TRIGGER-TERMS of a :LINEAR rule should be a ~
                legal trigger for the rule generated for each branch through ~
                the corollary.  But the proposed trigger ~p0 for the ~
                :LINEAR rule ~x1 is illegal for the branch ~p2 because it ~
                contains insufficient variables.  See :DOC linear."
        (untranslate term nil (w state))
        name
        (untranslate (if (caar lst)
            (fcons-term* 'implies (conjoin (caar lst)) (cdar lst))
            (cdar lst))
          t
          (w state))))))

(defun chk-legal-linear-trigger-terms
  (terms lst name ctx state)
  (cond ((null terms) (value nil))
    ((and (nvariablep (car terms))
       (not (fquotep (car terms)))
       (not (flambda-applicationp (car terms)))
       (not (eq (ffn-symb (car terms)) 'if))) (er-progn (chk-legal-linear-trigger-terms1 (car terms)
          lst
          name
          ctx
          state)
        (chk-legal-linear-trigger-terms (cdr terms)
          lst
          name
          ctx
          state)))
    (t (er soft
        ctx
        "The term ~p0 supplied as a :TRIGGER-TERM for the :LINEAR rule ~x1 ~
           is illegal because it is either a variable, a quoted constant, a ~
           lambda application (or LET-expression), or an IF-expression."
        (untranslate (car terms) nil (w state))
        name))))

(defun backchain-limit-listp
  (lst)
  (cond ((atom lst) (equal lst nil))
    ((or (null (car lst)) (natp (car lst))) (backchain-limit-listp (cdr lst)))
    (t nil)))

(defun recover-metafunction-or-clause-processor-signatures
  (token term)
  (cond ((eq token :meta) (mv-let (hyp eqv ev x a fn mfc-symbol)
        (interpret-term-as-meta-rule term)
        (mv-let (hyp-fn extra-fns)
          (meta-rule-hypothesis-functions hyp ev x a mfc-symbol)
          (declare (ignore extra-fns))
          (cond ((or (null eqv)
               (not (symbolp fn))
               (null hyp-fn)
               (not (symbolp hyp-fn))
               (not (symbolp mfc-symbol))) (mv :error nil nil nil))
            (t (mv nil
                fn
                (if (eq hyp-fn t)
                  nil
                  hyp-fn)
                (if mfc-symbol
                  (list mfc-symbol 'state)
                  nil)))))))
    (t (mv-let (flg fn cl alist rest-args ev call xflg)
        (destructure-clause-processor-rule term)
        (declare (ignore call xflg))
        (cond ((or (eq flg :error)
             (not (symbolp fn))
             (not (symbolp cl))
             (not (symbolp alist))
             (not (symbol-listp rest-args))
             (not (symbolp ev))
             (not (no-duplicatesp (list* cl alist rest-args)))) (mv :error nil nil nil))
          (t (mv flg fn nil rest-args)))))))

(defun equal-except-on-non-stobjs
  (arglist1 arglist2 w)
  (cond ((atom arglist1) (and (equal nil arglist1) (equal nil arglist2)))
    ((atom arglist2) nil)
    ((equal (car arglist1) (car arglist2)) (equal-except-on-non-stobjs (cdr arglist1) (cdr arglist2) w))
    ((or (stobjp (car arglist1) t w) (stobjp (car arglist2) t w)) nil)
    (t (equal-except-on-non-stobjs (cdr arglist1) (cdr arglist2) w))))

(defun arity-alistp
  (alist)
  (cond ((atom alist) (eq alist nil))
    ((and (consp (car alist))
       (symbolp (car (car alist)))
       (natp (cdr (car alist)))
       (arity-alistp (cdr alist))
       (not (assoc-eq (car (car alist)) (cdr alist)))) t)
    (t nil)))

(defun compatible-arity-alistsp
  (alist1 alist2)
  (cond ((equal alist1 alist2) t)
    (t (arity-alistp (union-equal alist1 alist2)))))

(defun collect-disagreeing-arity-assumptions
  (alist1 alist2)
  (cond ((endp alist1) nil)
    ((and (assoc (car (car alist1)) alist2)
       (not (equal (cdr (car alist1))
           (cdr (assoc (car (car alist1)) alist2))))) (cons (car (car alist1))
        (collect-disagreeing-arity-assumptions (cdr alist1) alist2)))
    (t (collect-disagreeing-arity-assumptions (cdr alist1) alist2))))

(defun interpret-term-as-well-formedness-guarantee-thm
  (token fn thm)
  (let ((pre (if (eq token :meta)
         'logic-termp
         'logic-term-listp)) (post (if (eq token :meta)
          'logic-termp
          'logic-term-list-listp)))
    (case-match thm
      (('implies ('if (!pre tvar wvar)
           ('arities-okp ('quote alist) wvar)
           ''nil)
         (!post (!fn tvar . rest-args) wvar)) (mv tvar wvar alist nil rest-args))
      (('implies ('if ('arities-okp ('quote alist) wvar)
           (!pre tvar wvar)
           ''nil)
         (!post (!fn tvar . rest-args) wvar)) (mv tvar wvar alist nil rest-args))
      (('implies (!pre tvar wvar)
         (!post (!fn tvar . rest-args) wvar)) (mv tvar wvar nil nil rest-args))
      (('implies ('arities-okp ('quote alist) wvar)
         (!post (!fn tvar . rest-args) wvar)) (mv tvar wvar alist nil rest-args))
      ((!post (!fn tvar . rest-args) wvar) (mv tvar wvar nil nil rest-args))
      (('implies ('if (!pre tvar wvar)
           ('arities-okp ('quote alist) wvar)
           ''nil)
         (!post ('clauses-result (!fn tvar . rest-args)) wvar)) (mv tvar wvar alist t rest-args))
      (('implies ('if ('arities-okp ('quote alist) wvar)
           (!pre tvar wvar)
           ''nil)
         (!post ('clauses-result (!fn tvar . rest-args)) wvar)) (mv tvar wvar alist t rest-args))
      (('implies (!pre tvar wvar)
         (!post ('clauses-result (!fn tvar . rest-args)) wvar)) (mv tvar wvar nil t rest-args))
      (('implies ('arities-okp ('quote alist) wvar)
         (!post ('clauses-result (!fn tvar . rest-args)) wvar)) (mv tvar wvar alist t rest-args))
      ((!post ('clauses-result (!fn tvar . rest-args)) wvar) (mv tvar wvar nil t rest-args))
      (& (mv nil nil nil :error nil)))))

(defun translate-well-formedness-guarantee
  (token x name corollary ctx wrld state)
  (cond ((not (or (and (symbolp x) (formula x nil wrld))
         (and (eq token :meta)
           (consp x)
           (symbolp (car x))
           (null (cdr x))
           (formula (car x) nil wrld))
         (and (eq token :meta)
           (consp x)
           (symbolp (car x))
           (consp (cdr x))
           (symbolp (cadr x))
           (null (cddr x))
           (formula (car x) nil wrld)
           (formula (cadr x) nil wrld)))) (if (eq token :meta)
        (er soft
          ctx
          "The :WELL-FORMEDNESS-GUARANTEE of :META rule ~x0 is ill-formed.  ~
             In general, a :WELL-FORMEDNESS-GUARANTEE must be of one of the ~
             following forms:~%[1]  thm-name1~%[2]  (thm-name1)~%[3]  ~
             (thm-name1 thm-name2)~%where thm-name1 names a previously proved ~
             theorem guaranteeing that the relevant metafunction returns a ~
             LOGIC-TERMP when given a LOGIC-TERMP.  See :DOC logic-termp.  ~
             Form [3] is only permitted (and is required!) when the ~
             metatheorem has a hypothesis metafunction, in which case ~
             thm-name2 names a previously proved theorem guaranteeing that ~
             the hypothesis metafunction also returns a LOGIC-TERMP when ~
             given one.  ~x1 is of none of the expected forms.  See :DOC ~
             well-formedness-guarantee for details."
          name
          x)
        (er soft
          ctx
          "The :WELL-FORMEDNESS-GUARANTEE of :CLAUSE-PROCESSOR rule ~x0 ~
             must be the name of a theorem guaranteeing that the clause ~
             processor returns a LOGIC-TERM-LIST-LISTP when given a ~
             LOGIC-TERM-LISTP.  ~x1 is not such a name.  See :DOC ~
             logic-term-listp, :DOC logic-term-list-listp, and :DOC ~
             well-formedness-guarantee for details."
          name
          x)))
    (t (let* ((thm-name1 (cond ((symbolp x) x) (t (car x)))) (thm-name2 (cond ((symbolp x) nil) (t (cadr x))))
          (thm1 (formula thm-name1 nil wrld))
          (thm2 (if (null thm-name2)
              nil
              (formula thm-name2 nil wrld))))
        (mv-let (triple-flg fn hyp-fn rest-args)
          (recover-metafunction-or-clause-processor-signatures token
            corollary)
          (let ((expected-fn-form `(implies (and (,(IF (EQ TOKEN :META)
     'LOGIC-TERMP
     'LOGIC-TERM-LISTP) x
                     w)
                   (arity-alistp '<alist> w))
                 (,(IF (EQ TOKEN :META)
     'LOGIC-TERMP
     'LOGIC-TERM-LIST-LISTP) ,(IF TRIPLE-FLG
     `(CLAUSES-RESULT (,FN X ,@REST-ARGS))
     `(,FN X ,@REST-ARGS))
                   w))) (expected-hyp-fn-form (if hyp-fn
                  `(implies (and (logic-termp x w) (arity-alistp '<alist> w))
                    (logic-termp (,HYP-FN x ,@REST-ARGS) w))
                  nil))
              (evisc (evisc-tuple nil
                  nil
                  '((<alist> . "((fn1 . n1) ... (fnk . nk))"))
                  nil)))
            (cond ((eq triple-flg :error) (value nil))
              (t (mv-let (tvar1 wvar1 alist1 triple-flg1 rest-args1)
                  (interpret-term-as-well-formedness-guarantee-thm token
                    fn
                    thm1)
                  (cond ((eq triple-flg1 :error) (er soft
                        ctx
                        "The :WELL-FORMEDNESS-GUARANTEE of ~x0 rule ~x1 is ~
                      ill-formed.  We cannot interpret the theorem named ~x2 ~
                      as a well-formedness guarantee for the function ~x3.  ~
                      We expected the name of a theorem like ~X45.  See :DOC ~
                      well-formedness-guarantee for details of the acceptable ~
                      forms."
                        token
                        name
                        thm-name1
                        fn
                        expected-fn-form
                        evisc))
                    ((and (equal-except-on-non-stobjs rest-args rest-args1 wrld)
                       (eq triple-flg triple-flg1)
                       (variablep tvar1)
                       (variablep wvar1)
                       (symbol-listp rest-args1)
                       (no-duplicatesp-equal (list* tvar1 wvar1 rest-args1))
                       (arity-alistp alist1)) (cond ((null hyp-fn) (cond (thm-name2 (er soft
                                ctx
                                "The ~x0 rule ~x1 mentions the metafunction ~x2 but ~
                          does not mention a hypothesis metafunction.  ~
                          Therefore, it makes no sense to name a previously ~
                          proved theorem that provides a well-formedness ~
                          guarantee for a hypothesis metafunction.  But you ~
                          have specified such a name, ~x4, with your ~
                          :WELL-FORMEDNESS-GUARANTEE ~x3.  This may indicate ~
                          a misunderstanding.  Replace your guarantee with ~
                          :WELL-FORMEDNESS-GUARANTEE ~x5."
                                token
                                name
                                fn
                                x
                                thm-name2
                                (list thm-name1)))
                            (t (value (cons (list name fn thm-name1) alist1)))))
                        ((null thm-name2) (er soft
                            ctx
                            "The :META rule ~x0 mentions the metafunction ~x1 and ~
                        the hypothesis metafunction ~x2.  You have correctly ~
                        named ~x3 as a previously proved theorem guaranteeing ~
                        that ~x1 always returns a LOGIC-TERMP, but you have ~
                        not specified such a name for ~x2.  We require that ~
                        you do so.  That is, prove a theorem like ~X45 with ~
                        some name and change your :WELL-FORMEDNESS-GUARANTEE ~
                        value to (~x3 name)."
                            name
                            fn
                            hyp-fn
                            thm-name1
                            expected-hyp-fn-form
                            evisc))
                        (t (mv-let (tvar2 wvar2 alist2 triple-flg2 rest-args2)
                            (interpret-term-as-well-formedness-guarantee-thm token
                              hyp-fn
                              thm2)
                            (cond ((and (equal-except-on-non-stobjs rest-args rest-args2 wrld)
                                 (eq triple-flg triple-flg2)
                                 (variablep tvar2)
                                 (variablep wvar2)
                                 (no-duplicatesp-equal (list* tvar2 wvar2 rest-args2))
                                 (arity-alistp alist2)) (cond ((compatible-arity-alistsp alist1 alist2) (value (cons (list name fn thm-name1 hyp-fn thm-name2)
                                        (union-equal alist1 alist2))))
                                  (t (er soft
                                      ctx
                                      "The :WELL-FORMEDNESS-GUARANTEE of the :META ~
                                 rule ~x0 for the metafunction ~x1 with ~
                                 hypothesis metafunction ~x2 is inadmissible ~
                                 because the two LOGIC-TERMP theorems (~x3 ~
                                 and ~x4) assume different arities for one or ~
                                 more function symbols, to wit ~&5.  You will ~
                                 have to prove LOGIC-TERMP guarantee theorems ~
                                 that make compatible arity assumptions!"
                                      name
                                      fn
                                      hyp-fn
                                      thm-name1
                                      thm-name2
                                      (collect-disagreeing-arity-assumptions alist1 alist2)))))
                              (t (er soft
                                  ctx
                                  "The :WELL-FORMEDNESS-GUARANTEE of the :META ~
                               rule ~x0 for the metafunction ~x1 with ~
                               hypothesis metafunction ~x2 specified that ~x3 ~
                               is the name of the previously proved theorem ~
                               that guarantees that ~x2 always returns a ~
                               LOGIC-TERMP.  But theorem ~x3 is not of the ~
                               expected form.  We expected it to be something ~
                               like:~X45.  See :DOC well-formedness-guarantee."
                                  name
                                  fn
                                  hyp-fn
                                  thm-name2
                                  expected-hyp-fn-form
                                  evisc)))))))
                    (t (er soft
                        ctx
                        "The :WELL-FORMEDNESS-GUARANTEE of the ~x0 rule ~x1 ~
                        for ~x2 specified that ~x3 is the name of the ~
                        previously proved theorem that established that ~x2 ~
                        always returns a LOGIC-TERMP.  But theorem ~x3 is not ~
                        of the expected form.  We expected it to be something ~
                        like ~X45. See :DOC well-formedness-guarantee."
                        token
                        name
                        fn
                        thm-name1
                        expected-fn-form
                        evisc))))))))))))

(defun induction-rule-synp-sanityp
  (lst)
  (cond ((endp lst) t)
    ((and (nvariablep (car lst))
       (not (fquotep (car lst)))
       (eq (ffn-symb (car lst)) 'synp)) (induction-rule-synp-sanityp (cdr lst)))
    ((ffnnamep 'synp (car lst)) nil)
    (t (induction-rule-synp-sanityp (cdr lst)))))

(defun translate-rule-class-alist
  (token alist seen corollary name x ctx ens wrld state)
  (cond ((null alist) (cond ((eq token :meta) (cond ((not (assoc-eq :trigger-fns seen)) (er soft
                ctx
                "The :META rule class must specify :TRIGGER-FNS.  ~
                  The rule class ~x0 is thus illegal.  See :DOC meta."
                x))
            (t (value (alist-to-keyword-alist seen nil)))))
        ((eq token :forward-chaining) (cond ((not (assoc-eq :trigger-terms seen)) (mv-let (hyps concls)
                (destructure-forward-chaining-term corollary wrld)
                (declare (ignore concls))
                (cond ((null hyps) (er soft
                      ctx
                      "When no :TRIGGER-TERMS component is ~
                                 specified for a :FORWARD-CHAINING ~
                                 rule class, the first hypothesis of ~
                                 the conjecture is used as the only ~
                                 trigger.  But ~p0 has no hypotheses ~
                                 and thus ~x1 is an illegal rule ~
                                 class.  See :DOC forward-chaining."
                      (untranslate corollary t wrld)
                      x))
                  (t (let* ((first-hyp (if (and (nvariablep (car hyps))
                             (or (eq (ffn-symb (car hyps)) 'force)
                               (eq (ffn-symb (car hyps)) 'case-split)))
                           (fargn (car hyps) 1)
                           (car hyps))) (trigger-term (if (ffn-symb-p first-hyp 'not)
                            (fargn first-hyp 1)
                            first-hyp)))
                      (pprogn (observation ctx
                          "The :TRIGGER-TERMS for the ~
                                               :FORWARD-CHAINING rule ~x0 will ~
                                               consist of the list containing ~p1."
                          name
                          (untranslate trigger-term nil wrld))
                        (value (alist-to-keyword-alist seen
                            (list :trigger-terms (list trigger-term))))))))))
            (t (value (alist-to-keyword-alist seen nil)))))
        ((eq token :type-prescription) (cond ((not (assoc-eq :typed-term seen)) (mv-let (hyps concl)
                (unprettyify-tp (remove-guard-holders corollary wrld))
                (declare (ignore hyps))
                (let ((pat (cond ((ffn-symb-p concl 'implies) (find-type-prescription-pat (fargn concl 2) ens wrld))
                       (t (find-type-prescription-pat concl ens wrld)))))
                  (cond ((null pat) (er soft
                        ctx
                        "When no :TYPED-TERM component is specified for a ~
                            :TYPE-PRESCRIPTION rule class, a suitable term is ~
                            selected heuristically from the conjecture.  But ~
                            our heuristics identify no candidate term in ~p0. ~
                             Thus, ~x1 is an illegal rule class.  See :DOC ~
                            type-prescription."
                        (untranslate corollary t wrld)
                        x))
                    (t (pprogn (if (ld-skip-proofsp state)
                          state
                          (observation ctx
                            "Our heuristics choose ~p0 as the ~
                                         :TYPED-TERM."
                            (untranslate pat nil wrld)))
                        (value (alist-to-keyword-alist seen (list :typed-term pat)))))))))
            (t (value (alist-to-keyword-alist seen nil)))))
        ((eq token :definition) (er-progn (chk-destructure-definition name corollary ctx wrld state)
            (mv-let (hyps equiv fn args body ttree)
              (destructure-definition corollary nil nil wrld nil)
              (declare (ignore hyps equiv ttree))
              (er-let* ((clique (value (cond ((assoc-eq :clique seen) (cdr (assoc-eq :clique seen)))
                       ((ffnnamep fn body) (list fn))
                       (t nil)))) (controller-alist (cond ((assoc-eq :controller-alist seen) (value (cdr (assoc-eq :controller-alist seen))))
                      ((null clique) (value nil))
                      ((null (cdr clique)) (guess-controller-alist-for-definition-rule clique
                          args
                          body
                          ctx
                          wrld
                          state))
                      (t (er soft
                          ctx
                          "We are unable to guess a :CONTROLLER-ALIST for a ~
                            :DEFINITION rule if the :CLIQUE contains more ~
                            than one function symbol.  Therefore, you must ~
                            supply a :CONTROLLER-ALIST entry for ~x0."
                          name)))))
                (cond ((controller-alistp clique controller-alist wrld) (value (alist-to-keyword-alist seen
                        (append (if (assoc-eq :clique seen)
                            nil
                            (list :clique clique))
                          (if (assoc-eq :controller-alist seen)
                            nil
                            (list :controller-alist controller-alist))))))
                  (t (er soft
                      ctx
                      "The :CONTROLLER-ALIST of a :DEFINITION must be an alist ~
                   that maps each function symbol in the :CLIQUE to a list of ~
                   t's and nil's whose length is equal to the arity of the ~
                   function symbol. ~x0 is an inappropriate controller alist ~
                   for the ~@1.  See :DOC definition."
                      controller-alist
                      (cond ((null clique) "empty clique")
                        (t (msg ":CLIQUE consisting of ~&0" clique))))))))))
        ((eq token :induction) (cond ((not (assoc-eq :pattern seen)) (er soft
                ctx
                "The :INDUCTION rule class requires the specification of a ~
                  :PATTERN term and ~x0 contains no such entry."
                x))
            ((not (assoc-eq :scheme seen)) (er soft
                ctx
                "The :INDUCTION rule class requires the specification of a ~
                  :SCHEME term and ~x0 contains no such entry."
                x))
            (t (let* ((pat-term (cdr (assoc-eq :pattern seen))) (cond-term (or (cdr (assoc-eq :condition seen)) *t*))
                  (scheme-term (cdr (assoc-eq :scheme seen)))
                  (pat-vars (all-vars pat-term))
                  (cond-vars (all-vars cond-term))
                  (scheme-vars (all-vars scheme-term)))
                (cond ((not (subsetp-eq cond-vars pat-vars)) (er soft
                      ctx
                      "The variables occurring freely in the :CONDITION term ~
                        of an :INDUCTION rule class must be a subset of those ~
                        occurring freely in the :PATTERN term.  But the ~
                        condition term ~x0 mentions ~&1, which ~#1~[does~/do~] ~
                        not occur in the pattern term ~x2.  Thus the ~
                        :INDUCTION rule class specified for ~x3 is illegal."
                      cond-term
                      (reverse (set-difference-eq cond-vars pat-vars))
                      pat-term
                      name))
                  ((not (subsetp-eq scheme-vars pat-vars)) (er soft
                      ctx
                      "The variables occurring freely in the :SCHEME term ~
                        of an :INDUCTION rule class must be a subset of those ~
                        occurring freely in the :PATTERN term.  But the ~
                        scheme term ~x0 mentions ~&1, which ~#1~[does~/do~] ~
                        not occur in the pattern term ~x2.  Thus the ~
                        :INDUCTION rule class specified for ~x3 is illegal."
                      scheme-term
                      (reverse (set-difference-eq scheme-vars pat-vars))
                      pat-term
                      name))
                  ((member-eq 'state cond-vars) (er soft
                      ctx
                      "The variable STATE may not appear in the :CONDITION ~
                        term of an :INDUCTION rule because we have not ~
                        implemented proper handling of STATE in SYNTAXP ~
                        hypotheses of such rules.  But the condition ~x0 ~
                        specified for ~x1 mentions STATE."
                      cond-term
                      name))
                  ((member-eq 'mfc cond-vars) (er soft
                      ctx
                      "The variable MFC may not appear in the :CONDITION ~
                        term of an :INDUCTION rule because we have not ~
                        implemented proper handling of MFC in SYNTAXP ~
                        hypotheses of such rules.  But the condition ~x0 ~
                        specified for ~x1 mentions MFC."
                      cond-term
                      name))
                  ((not (induction-rule-synp-sanityp (flatten-ands-in-lit cond-term))) (er soft
                      ctx
                      "The term ~x0 in the :CONDITION field of the ~
                        :INDUCTION rule ~x1 violates the restriction that all ~
                        occurrences of the SYNTAXP (aka SYNP) construct must ~
                        be as top-level conjuncts of the term and not buried ~
                        within other terms."
                      cond-term
                      name))
                  ((assoc-eq :condition seen) (value (alist-to-keyword-alist seen nil)))
                  (t (value (alist-to-keyword-alist seen (list :condition *t*)))))))))
        (t (value (alist-to-keyword-alist seen nil)))))
    ((assoc-eq (car alist) seen) (er soft
        ctx
        "Rule classes may not contain duplicate keys, but ~x0 occurs ~
         twice in ~x1.  See :DOC rule-classes."
        (car alist)
        x))
    (t (let ((assumep (or (eq (ld-skip-proofsp state) 'include-book)
             (eq (ld-skip-proofsp state) 'include-book-with-locals)
             (eq (ld-skip-proofsp state) 'initialize-acl2))))
        (er-let* ((val (case (car alist)
               (:corollary (value corollary))
               (:hints (cond ((assoc-eq :instructions seen) (er soft
                       ctx
                       "It is illegal to supply both :INSTRUCTIONS ~
                         and :HINTS in a rule class.  Hence, ~x0 is ~
                         illegal.  See :DOC rule-classes."
                       x))
                   (t (er-let* ((hints (if assumep
                            (value nil)
                            (translate-hints+ (cons "Corollary of " name)
                              (cadr alist)
                              (default-hints wrld)
                              ctx
                              wrld
                              state))))
                       (value hints)))))
               (:instructions (cond ((assoc-eq :hints seen) (er soft
                       ctx
                       "It is illegal to supply both :HINTS and ~
                          :INSTRUCTIONS in a rule class.  Hence, ~x0 is ~
                          illegal.  See :DOC rule-classes."
                       x))
                   (t (er-let* ((instrs (if assumep
                            (value nil)
                            (translate-instructions (cadr alist) ctx state))))
                       (value instrs)))))
               (:otf-flg (value (cadr alist)))
               (:trigger-fns (cond ((eq token :forward-chaining) (er soft
                       ctx
                       "The :FORWARD-CHAINING rule class may specify ~
                          :TRIGGER-TERMS but may not specify :TRIGGER-FNS.  ~
                          Thus, ~x0 is illegal.  See :DOC forward-chaining ~
                          and :DOC meta."
                       x))
                   ((not (eq token :meta)) (er soft
                       ctx
                       ":TRIGGER-FNS can only be specified for :META rules. ~
                           Thus, ~x0 is illegal.  See :DOC ~@1."
                       x
                       (symbol-name token)))
                   ((atom (cadr alist)) (er soft
                       ctx
                       "The :TRIGGER-FNS component of a :META rule class ~
                          must be a non-empty true-list of function symbols.  ~
                          But ~x0 is empty.  See :DOC meta."
                       (cadr alist)))
                   ((eq (car (cadr alist)) 'quote) (er soft
                       ctx
                       "The :TRIGGER-FNS component of a :META rule class ~
                          must be a non-empty true-list of function symbols.  ~
                          You specified ~x0 for this component, but the list ~
                          is not to be quoted.~@1  See :DOC meta."
                       (cadr alist)
                       (cond ((and (consp (cdr (cadr alist)))
                            (symbol-listp (cadr (cadr alist)))
                            (null (cddr (cadr alist)))) (msg "  Perhaps you intended ~x0 instead."
                             (cadr (cadr alist))))
                         (t ""))))
                   (t (mv-let (flg lst)
                       (eliminate-macro-aliases (cadr alist)
                         (macro-aliases wrld)
                         wrld)
                       (cond ((eq flg :error) (er soft
                             ctx
                             "The :TRIGGER-FNS component of a ~
                                           :META rule class must be a ~
                                           non-empty true-list of function ~
                                           symbols, but ~x0 ~@1.  See :DOC ~
                                           meta."
                             (cadr alist)
                             lst))
                         (t (value lst)))))))
               (:trigger-terms (cond ((eq token :meta) (er soft
                       ctx
                       "The :META rule class may specify :TRIGGER-FNS but ~
                          may not specify :TRIGGER-TERMS.  Thus, ~x0 is ~
                          illegal.  See :DOC meta and :DOC forward-chaining."
                       x))
                   ((not (true-listp (cadr alist))) (er soft
                       ctx
                       "The :TRIGGER-TERMS must be a list true list.  Thus ~
                          the rule class ~x0 proposed for ~x1 is illegal."
                       x
                       name))
                   ((eq token :linear) (er-let* ((terms (translate-term-lst (cadr alist) t t t ctx wrld state)))
                       (cond ((null terms) (er soft
                             ctx
                             "For the :LINEAR rule ~x0 you specified an empty ~
                              list of :TRIGGER-TERMS.  This is illegal.  If ~
                              you wish to cause ACL2 to compute the trigger ~
                              terms, omit the :TRIGGER-TERMS field entirely.  ~
                              See :DOC linear."
                             name))
                         (t (let ((terms (remove-guard-holders-lst terms wrld)))
                             (er-progn (chk-legal-linear-trigger-terms terms
                                 (possibly-clean-up-dirty-lambda-objects-in-pairs (unprettyify (remove-guard-holders corollary wrld))
                                   wrld
                                   (remove-guard-holders-lamp))
                                 name
                                 ctx
                                 state)
                               (value terms)))))))
                   ((eq token :forward-chaining) (er-let* ((terms (translate-term-lst (cadr alist) t t t ctx wrld state)))
                       (cond ((null terms) (er soft
                             ctx
                             ":FORWARD-CHAINING rules must have at least ~
                                   one trigger.  Your rule class, ~x0, ~
                                   specifies none.  See :DOC forward-chaining."
                             x))
                         (t (value (remove-guard-holders-lst terms wrld))))))
                   (t (er soft
                       ctx
                       ":TRIGGER-TERMS can only be specified for ~
                          :FORWARD-CHAINING and :LINEAR rules.  Thus, ~x0 is ~
                          illegal.  See :DOC ~@1."
                       x
                       (symbol-name token)))))
               (:well-formedness-guarantee (cond ((and (not (eq token :meta))
                      (not (eq token :clause-processor))) (er soft
                       ctx
                       "Only :META and :CLAUSE-PROCESSOR rule classes are ~
                          permitted to have a :WELL-FORMEDNESS-GUARANTEE ~
                          component.  Thus, ~x0 is illegal.  See :DOC ~
                          well-formedness-guarantee."
                       x))
                   (t (er-let* ((well-formedness-guarantee (translate-well-formedness-guarantee token
                            (cadr alist)
                            name
                            corollary
                            ctx
                            wrld
                            state)))
                       (let* ((thm-name1 (nth 2 (car well-formedness-guarantee))) (hyp-fn (nth 3 (car well-formedness-guarantee)))
                           (thm-name2 (nth 4 (car well-formedness-guarantee)))
                           (alist (cdr well-formedness-guarantee))
                           (bad-arity-info (collect-bad-fn-arity-info alist wrld nil nil))
                           (bad-arity-alist (car bad-arity-info))
                           (non-logic-fns (cdr bad-arity-info))
                           (forbidden-fns (intersection-eq (strip-cars alist)
                               (forbidden-fns wrld state))))
                         (cond (bad-arity-alist (er soft
                               ctx
                               "~x0 rule ~x1 is inadmissible because its ~
                                  :WELL-FORMEDNESS-GUARANTEE ~
                                  theorem~#2~[~/s~], named ~&2, ~
                                  ~#2~[is~/are~] incompatible with the ~
                                  current world.  In particular, the ~
                                  ~#2~[theorem makes~/theorems make~] invalid ~
                                  assumptions about the arities of one or ~
                                  more function symbols possibly introduced ~
                                  by the ~s3.  The following alist ~
                                  shows assumed arities that are different ~
                                  from the actual arities of those symbols in ~
                                  the current world: ~X45."
                               token
                               name
                               (if hyp-fn
                                 (list thm-name1 thm-name2)
                                 (list thm-name1))
                               (if (eq token :meta)
                                 "metafunction"
                                 "clause-processor")
                               bad-arity-alist
                               nil))
                           (non-logic-fns (er soft
                               ctx
                               "~x0 rule ~x1 is inadmissible because its ~
                                  :WELL-FORMEDNESS-GUARANTEE ~
                                  theorem~#2~[~/s~], named ~&2, ~
                                  ~#2~[is~/are~] incompatible with the ~
                                  current world.  In particular, the ~
                                  ~#2~[theorem assumes~/theorems assume~] ~
                                  that relevant functions are in :logic mode, ~
                                  but :program mode function symbol~#3~[ ~&3 ~
                                  is~/s ~&3 are~] perhaps introduced by the ~
                                  ~s4, ~&3."
                               token
                               name
                               (if hyp-fn
                                 (list thm-name1 thm-name2)
                                 (list thm-name1))
                               non-logic-fns
                               (if (eq token :meta)
                                 "metafunction"
                                 "clause-processor")))
                           (forbidden-fns (er soft
                               ctx
                               "~x0 rule ~x1 is inadmissible because its ~
                                  well-formedness theorem~#2~[~/s~], named ~
                                  ~&2, ~#2~[is~/are~] incompatible with the ~
                                  current world.  In particular, judging by ~
                                  the ARITIES-OKP ~
                                  ~#2~[hypothesis~/hypotheses~] of the ~
                                  theorem~#2~[~/s~], the specified ~s3 may ~
                                  introduce one or more functions that are ~
                                  currently forbidden, to wit ~&4.  See :DOC ~
                                  set-skip-meta-termp-checks and :DOC ~
                                  well-formedness-guarantee."
                               token
                               name
                               (if hyp-fn
                                 (list thm-name1 thm-name2)
                                 (list thm-name1))
                               (if (eq token :meta)
                                 "metafunction"
                                 "clause-processor")
                               forbidden-fns))
                           (t (value well-formedness-guarantee))))))))
               (:typed-term (cond ((not (eq token :type-prescription)) (er soft
                       ctx
                       "Only :TYPE-PRESCRIPTION rule classes are permitted ~
                          to have a :TYPED-TERM component.  Thus, ~x0 is ~
                          illegal.  See :DOC ~@1."
                       x
                       (symbol-name token)))
                   (t (er-let* ((term (translate (cadr alist) t t t ctx wrld state)))
                       (value term)))))
               (:backchain-limit-lst (let ((hyps-concl-pairs (case token
                        (:meta (case-match corollary
                            (('implies hyp concl) (list (cons (list hyp) concl)))
                            (& (list (cons nil corollary)))))
                        (:type-prescription (mv-let (hyps concl)
                            (unprettyify-tp (remove-guard-holders corollary wrld))
                            (list (cons hyps concl))))
                        (otherwise (possibly-clean-up-dirty-lambda-objects-in-pairs (unprettyify (remove-guard-holders corollary wrld))
                            wrld
                            (remove-guard-holders-lamp))))))
                   (cond ((not (member-eq token
                          '(:rewrite :meta :linear :type-prescription))) (er soft
                         ctx
                         "The rule-class ~@0 is not permitted to have a ~
                            :BACKCHAIN-LIMIT-LST component.  Hence, ~x1 is ~
                            illegal.  See :DOC ~@0."
                         (symbol-name token)
                         x))
                     ((not (equal (length (remove-duplicates-equal (strip-cars hyps-concl-pairs)))
                          1)) (er soft
                         ctx
                         "We do not allow you to specify the ~
                            :BACKCHAIN-LIMIT-LST when more than one rule is ~
                            produced from the corollary and at least two such ~
                            rules have different hypothesis lists.  You ~
                            should split the corollary of ~x0 into parts and ~
                            specify a limit for each."
                         x))
                     (t (let ((hyps (car (car hyps-concl-pairs))))
                         (cond ((null hyps) (er soft
                               ctx
                               "There are no hypotheses, so ~
                                :BACKCHAIN-LIMIT-LST makes no sense.  See ~
                                :DOC RULE-CLASSES."))
                           ((null (cadr alist)) (value nil))
                           ((and (integerp (cadr alist)) (<= 0 (cadr alist))) (cond ((eq token :meta) (value (cadr alist)))
                               (t (value (make-list (length hyps) :initial-element (cadr alist))))))
                           ((eq token :meta) (er soft
                               ctx
                               "The legal values of :BACKCHAIN-LIMIT-LST for ~
                                rules of class :META are nil or a ~
                                non-negative integer.  See :DOC RULE-CLASSES."))
                           ((and (backchain-limit-listp (cadr alist))
                              (eql (length (cadr alist)) (length hyps))) (value (cadr alist)))
                           (t (er soft
                               ctx
                               "The legal values of :BACKCHAIN-LIMIT-LST are ~
                                nil, a non-negative integer, or a list of ~
                                these of the same length as the flattened ~
                                hypotheses.  In this case the list of ~
                                flattened hypotheses, of length ~x0, is:~%  ~
                                ~x1.~%See :DOC RULE-CLASSES."
                               (length hyps)
                               hyps))))))))
               (:match-free (cond ((not (member-eq token '(:rewrite :linear :forward-chaining))) (er soft
                       ctx
                       "Only :REWRITE, :FORWARD-CHAINING, and :LINEAR rule ~
                          classes are permitted to have a :MATCH-FREE ~
                          component.  Thus, ~x0 is illegal.  See :DOC ~
                          free-variables."
                       x))
                   ((not (member-eq (cadr alist) '(:all :once))) (er soft
                       ctx
                       "The legal values of :MATCH-FREE are :ALL and :ONCE. ~
                          Thus, ~x0 is illegal.  See :DOC free-variables."
                       x))
                   (t (value (cadr alist)))))
               (:clique (cond ((not (eq token :definition)) (er soft
                       ctx
                       "Only :DEFINITION rule classes are permitted to have ~
                          a :CLIQUE component.  Thus, ~x0 is illegal.  See ~
                          :DOC ~@1."
                       x
                       (symbol-name token)))
                   (t (er-progn (chk-destructure-definition name corollary ctx wrld state)
                       (mv-let (hyps equiv fn args body ttree)
                         (destructure-definition corollary nil nil wrld nil)
                         (declare (ignore hyps equiv args ttree))
                         (let ((clique (cond ((null (cadr alist)) nil)
                                ((atom (cadr alist)) (list (cadr alist)))
                                (t (cadr alist)))))
                           (cond ((not (and (all-function-symbolps clique wrld)
                                  (no-duplicatesp-equal clique))) (mv-let (flg lst)
                                 (eliminate-macro-aliases (cadr alist)
                                   (macro-aliases wrld)
                                   wrld)
                                 (er soft
                                   ctx
                                   "The :CLIQUE of a :DEFINITION must be ~
                                        a truelist of function symbols ~
                                        (containing no duplications) or else ~
                                        a single function symbol.  ~x0 is ~
                                        neither.~@1  See :DOC definition."
                                   (cadr alist)
                                   (cond ((eq flg :error) "")
                                     (t (msg "  Note that it is ~
                                                      illegal to use ~v0 ~
                                                      here, because we ~
                                                      require function ~
                                                      symbols, not merely ~
                                                      macros that are aliases ~
                                                      for function symbols ~
                                                      (see :DOC ~
                                                      macro-aliases-table)."
                                         (set-difference-equal (cadr alist) lst)))))))
                             ((and (ffnnamep fn body) (not (member-eq fn clique))) (er soft
                                 ctx
                                 "The :CLIQUE of a :DEFINITION must ~
                                       contain the defined function, ~x0, if ~
                                       the body calls the function.  See :DOC ~
                                       definition."
                                 fn))
                             ((and clique (not (member-eq fn clique))) (er soft
                                 ctx
                                 "The :CLIQUE of a :DEFINITION, when ~
                                       non-nil, must contain the function ~
                                       defined.  ~x0 does not contain ~x1.  ~
                                       See :DOC definition."
                                 (cadr alist)
                                 fn))
                             (t (value clique)))))))))
               (:controller-alist (cond ((not (eq token :definition)) (er soft
                       ctx
                       "Only :DEFINITION rule classes are permitted to have ~
                          a :CONTROLLER-ALIST component.  Thus, ~x0 is ~
                          illegal.  See :DOC ~@1."
                       x
                       (symbol-name token)))
                   (t (value (cadr alist)))))
               (:install-body (cond ((not (eq token :definition)) (er soft
                       ctx
                       "Only :DEFINITION rule classes are permitted to have ~
                          an :INSTALL-BODY component.  Thus, ~x0 is illegal.  ~
                          See :DOC ~@1."
                       x
                       (symbol-name token)))
                   ((not (member-eq (cadr alist) '(t nil :normalize))) (er soft
                       ctx
                       "The :INSTALL-BODY component of a  :DEFINITION rule ~
                          class must have one of the values ~v0.  Thus, ~x1 ~
                          is illegal.  See :DOC ~@2."
                       '(t nil :normalize)
                       (cadr alist)
                       (symbol-name token)))
                   (t (value (cadr alist)))))
               (:loop-stopper (cond ((not (or (eq token :rewrite) (eq token :rewrite-quoted-constant))) (er soft
                       ctx
                       "Only :REWRITE and :REWRITE-QUOTED-CONSTANT rule ~
                          classes are permitted to have a :LOOP-STOPPER ~
                          component.  Thus, ~x0 is illegal.  See :DOC ~
                          rule-classes."
                       x))
                   (t (mv-let (flg loop-stopper-alist)
                       (fix-loop-stopper-alist (cadr alist)
                         (macro-aliases wrld)
                         wrld)
                       (cond ((eq flg :error) (er soft
                             ctx
                             "The :LOOP-STOPPER for a rule class must be a ~
                               list whose elements have the form (variable1 ~
                               variable2 . fns), where variable1 and ~
                               variable2 are distinct variables and fns is a ~
                               list of function symbols (or macro-aliases for ~
                               function symbols), but ~x0 does not have this ~
                               form.  Thus, ~x1 is illegal.  See :DOC ~
                               rule-classes."
                             (cadr alist)
                             x))
                         ((not (subsetp-eq (union-eq (strip-cars loop-stopper-alist)
                                (strip-cadrs loop-stopper-alist))
                              (all-vars corollary))) (let ((bad-vars (set-difference-eq (union-eq (strip-cars loop-stopper-alist)
                                    (strip-cadrs loop-stopper-alist))
                                  (all-vars corollary))))
                             (er soft
                               ctx
                               "The variables from elements (variable1 ~
                                 variable2 . fns) of a :LOOP-STOPPER ~
                                 specified for a rule class must all appear ~
                                 in the :COROLLARY theorem for that rule ~
                                 class.  However, the ~#0~[variables ~&1 ~
                                 do~/variable ~&1 does~] not appear in ~p2.  ~
                                 Thus, ~x3 is illegal.  See :DOC rule-classes."
                               (if (cdr bad-vars)
                                 0
                                 1)
                               bad-vars
                               (untranslate corollary t wrld)
                               x)))
                         (t (value loop-stopper-alist)))))))
               (:pattern (cond ((not (eq token :induction)) (er soft
                       ctx
                       "Only :INDUCTION rule classes are permitted to have ~
                          a :PATTERN component.  Thus, ~x0 is illegal.  See ~
                          :DOC ~@1."
                       x
                       (symbol-name token)))
                   (t (er-let* ((term (translate (cadr alist) t t t ctx wrld state)))
                       (cond ((or (variablep term)
                            (fquotep term)
                            (flambdap (ffn-symb term))) (er soft
                             ctx
                             "The :PATTERN term of an :INDUCTION rule class ~
                                may not be a variable symbol, constant, or ~
                                the application of a lambda expression.  Thus ~
                                ~x0 is illegal.  See :DOC induction."
                             x))
                         (t (value term)))))))
               (:condition (cond ((not (eq token :induction)) (er soft
                       ctx
                       "Only :INDUCTION rule classes are permitted to have ~
                          a :CONDITION component.  Thus, ~x0 is illegal.  See ~
                          :DOC ~@1."
                       x
                       (symbol-name token)))
                   (t (er-let* ((term (translate (cadr alist) t t t ctx wrld state)))
                       (value term)))))
               (:scheme (cond ((not (eq token :induction)) (er soft
                       ctx
                       "Only :INDUCTION rule classes are permitted to have ~
                          a :SCHEME component.  Thus, ~x0 is illegal.  See ~
                          :DOC ~@1."
                       x
                       (symbol-name token)))
                   (t (er-let* ((term (translate (cadr alist) t t t ctx wrld state)))
                       (cond ((or (variablep term)
                            (fquotep term)
                            (flambdap (ffn-symb term))) (er soft
                             ctx
                             "The :SCHEME term of an :INDUCTION rule class ~
                                may not be a variable symbol, constant, or ~
                                the application of a lambda expression.  Thus ~
                                ~x0 is illegal.  See :DOC induction."
                             x))
                         ((not (or (getpropc (ffn-symb term) 'induction-machine nil wrld)
                              (getpropc (ffn-symb term) 'induction-rules nil wrld))) (er soft
                             ctx
                             "The function symbol of the :SCHEME term of an ~
                                :INDUCTION rule class must, at least ~
                                sometimes, suggest an induction and ~x0 does ~
                                not.  See :DOC induction."
                             (ffn-symb term)))
                         (t (value term)))))))
               (:type-set (cond ((not (eq token :type-set-inverter)) (er soft
                       ctx
                       "Only :TYPE-SET-INVERTER rule classes are permitted ~
                          to have a :TYPE-SET component.  Thus ~x0 is ~
                          illegal.  See :DOC type-set-inverter."
                       x))
                   ((not (and (integerp (cadr alist))
                        (<= *min-type-set* (cadr alist))
                        (<= (cadr alist) *max-type-set*))) (er soft
                       ctx
                       "The :TYPE-SET of a :TYPE-SET-INVERTER rule must be ~
                          a type-set, i.e., an integer between ~x0 and ~x1, ~
                          inclusive.  ~x2 is not a type-set.  See :DOC ~
                          type-set and :DOC type-set-inverter."
                       *min-type-set*
                       *max-type-set*
                       (cadr alist)))
                   (t (value (cadr alist)))))
               (otherwise (er soft
                   ctx
                   "The key ~x0 is unrecognized as a rule class ~
                        component.  See :DOC rule-classes."
                   (car alist))))))
          (translate-rule-class-alist token
            (cddr alist)
            (cons (cons (car alist) val) seen)
            corollary
            name
            x
            ctx
            ens
            wrld
            state))))))

(defun translate-rule-class1
  (class tflg name x ctx ens wrld state)
  (let ((rule-tokens '(:rewrite :rewrite-quoted-constant :linear :well-founded-relation :built-in-clause :compound-recognizer :elim :generalize :meta :forward-chaining :equivalence :refinement :congruence :type-prescription :definition :induction :type-set-inverter :clause-processor :tau-system)))
    (cond ((not (member-eq (car class) rule-tokens)) (er soft
          ctx
          "~x0 is not one of the known rule tokens, ~&1.  See :DOC ~
         rule-classes."
          (car class)
          rule-tokens))
      (t (er-let* ((corollary (cond (tflg (value (cadr (assoc-keyword :corollary (cdr class)))))
               (t (translate (cadr (assoc-keyword :corollary (cdr class)))
                   t
                   t
                   t
                   ctx
                   wrld
                   state)))) (alist (translate-rule-class-alist (car class)
                (cdr class)
                nil
                corollary
                name
                x
                ctx
                ens
                wrld
                state)))
          (value (cons (car class) alist)))))))

(defun reason-for-non-keyword-value-listp
  (x)
  (cond ((atom x) (cond ((null x) (er hard
            'reason-for-non-keyword-value-listp
            "Uh oh, it was a keyword-value-listp after all!"))
        (t (msg "there is a non-nil final cdr of ~x0" x))))
    ((not (keywordp (car x))) (msg "we found a non-keyword, ~x0, where a keyword was expected"
        (car x)))
    ((atom (cdr x)) (msg "the value corresponding to the final key of ~x0 was missing"
        (car x)))
    (t (reason-for-non-keyword-value-listp (cddr x)))))