File: other-events.lisp

package info (click to toggle)
acl2 8.6%2Bdfsg-2
links: PTS
area: main
in suites: trixie
size: 1,111,420 kB
sloc: lisp: 17,818,294; java: 125,359; python: 28,122; javascript: 23,458; cpp: 18,851; ansic: 11,569; perl: 7,678; xml: 5,591; sh: 3,976; makefile: 3,833; ruby: 2,633; yacc: 1,126; ml: 763; awk: 295; csh: 233; lex: 197; php: 178; tcl: 49; asm: 23; haskell: 17
file content (36923 lines) | stat: -rw-r--r-- 1,714,172 bytes
parent folder | download | duplicates (2)
; ACL2 Version 8.6 -- A Computational Logic for Applicative Common Lisp
; Copyright (C) 2025, Regents of the University of Texas

; This version of ACL2 is a descendent of ACL2 Version 1.9, Copyright
; (C) 1997 Computational Logic, Inc.  See the documentation topic NOTE-2-0.

; This program is free software; you can redistribute it and/or modify
; it under the terms of the LICENSE file distributed with ACL2.

; This program is distributed in the hope that it will be useful,
; but WITHOUT ANY WARRANTY; without even the implied warranty of
; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
; LICENSE for more details.

; Written by:  Matt Kaufmann               and J Strother Moore
; email:       Kaufmann@cs.utexas.edu      and Moore@cs.utexas.edu
; Department of Computer Science
; University of Texas at Austin
; Austin, TX 78712 U.S.A.

(in-package "ACL2")

(defun chk-legal-defconst-name (name state)
  (cond ((legal-constantp name) (value nil))
        ((legal-variable-or-constant-namep name)
         (er soft (cons 'defconst name)
             "The symbol ~x0 may not be declared as a constant because ~
              it does not begin and end with the character *."
             name))
        (t (er soft (cons 'defconst name)
               "Constant symbols must ~*0.  Thus, ~x1 may not be ~
                declared as a constant.  See :DOC name and :DOC ~
                defconst."
               (tilde-@-illegal-variable-or-constant-name-phrase name)
               name))))

(defun defconst-fn1 (name val w state)
  (let ((w (putprop name 'const (kwote val) w)))
    (value w)))

#-acl2-loop-only
(progn

; See the Essay on Hash Table Support for Compilation.

(defvar *hcomp-fn-ht* nil)
(defvar *hcomp-const-ht* nil)
(defvar *hcomp-macro-ht* nil)
(defvar *hcomp-cert-obj* nil)
(defvar *hcomp-fn-alist* nil)
(defvar *hcomp-const-alist* nil)
(defvar *hcomp-macro-alist* nil)
(defconstant *hcomp-fake-value* 'acl2_invisible::hcomp-fake-value)
(defvar *hcomp-book-ht*
; Note that the keys of this hash table are full-book-names.
  nil)
(defvar *hcomp-const-restore-ht* nil)
(defvar *hcomp-fn-macro-restore-ht*

; We use a single hash table to restore both function and macro definitions.
; In v4-0 and v4-1 we had separate hash tables for these, but after a bug
; report from Jared Davis that amounted to a CCL issue (error upon redefining a
; macro as a function), we discovered an ACL2 issue, which we now describe
; using an example.

; In our example, the file fn.lisp has the definition
;   (defun f (x)
;     (declare (xargs :guard t))
;     (cons x x))
; while the file mac.lisp has this:
;   (defmacro f (x)
;     x)

; After certifying both books in v4-1, the following sequence of events then
; causes the error shown below in v4-1, as does the sequence obtained by
; switching the order of the include-book forms.  The problem in both cases is
; a failure to restore properly the original definition of f after the failed
; include-book.

; (include-book "fn")
; (include-book "mac") ; fails, as expected (redefinition error)
; (defun g (x)
;   (declare (xargs :guard t))
;   (f x))
; (g 3) ; "Error:  The function F is undefined."

; By using a single hash table (in functions hcomp-init and hcomp-restore-defs)
; we avoid this problem.

  nil)
(defvar *declaim-list* nil)

(defvar *hcomp-full-book-string*)
(defvar *hcomp-full-book-name*)
(defvar *hcomp-directory-name*)
(defvar *hcomp-ctx*)
(defvar *hcomp-cert-obj*)
(defvar *hcomp-cert-filename*)

)

(defrec hcomp-book-ht-entry

; Note that the status field has value COMPLETE, TO-BE-COMPILED, or INCOMPLETE;
; the value of this field is never nil.  The other fields can be nil if the
; status field is such that we don't need them.

  ((status . fn-ht)
   (const-ht . macro-ht)
   cert-obj . cert-filename)
  t)

#-acl2-loop-only
(defun defconst-val-raw (full-book-name name)
  (let* ((entry (and *hcomp-book-ht*
                     (gethash full-book-name *hcomp-book-ht*)))
         (const-ht (and entry
                        (access hcomp-book-ht-entry entry :const-ht))))
    (cond (const-ht (multiple-value-bind (val present-p)
                        (gethash name const-ht)
                      (cond (present-p val)
                            (t *hcomp-fake-value*))))
          (t *hcomp-fake-value*))))

(defun defconst-val (name form ctx wrld state)
  #+acl2-loop-only
  (declare (ignore name))
  #-acl2-loop-only
  (cond
   ((f-get-global 'boot-strap-flg state)
    (cond
     ((member name '(*first-order-like-terms-and-out-arities*
                     *badge-prim-falist*
                     *system-verify-guards-alist-1*
                     *system-verify-guards-alist-2*
                     *apply$-boot-fns-badge-alist*)
              :test 'eq)

; The boot-strap is performed after loading the compiled ACL2 source files.
; Thus, we generally expect that name is already bound, and we return that
; value as explained below.  But in apply.lisp we avoid compiling
; *badge-prim-falist* because it depends on
; *first-order-like-terms-and-out-arities*, which is defined with a make-event
; that cannot be compiled.  Since *apply$-boot-fns-badge-alist* is only defined
; in pass 2, we deal with it similarly here.  We use defparameter so that the
; compiler knows that the variable is special.

      (eval `(defparameter ,name ,form)))
     (t (or (boundp name)
            (er hard 'defconst
                "Implementation error!  Expected ~x0 to be boundp.  Please ~
                 contact the ACL2 implementors."
                name))))

; We want the symbol-value of name to be EQ to what is returned, especially to
; avoid duplication of large values.  Note that starting with Version_7.0, the
; code here is not necessary when the event being processed is (defconst name
; (quote val)); see ld-fix-command.  However, here we arrange that the
; symbol-value is EQ to what is returned by defconst-val even without the
; assumption that the defconst expression is of the form (quote val).

    (return-from defconst-val
                 (value (symbol-value name))))
   (t (let ((full-book-name (car (global-val 'include-book-path wrld))))
        (when full-book-name
          (let ((val (defconst-val-raw full-book-name name)))
            (when (not (eq val *hcomp-fake-value*))
              (return-from defconst-val
                           (value val))))))))
  (er-let*
   ((pair (state-global-let*
           ((safe-mode

; Warning: If you are tempted to bind safe-mode to nil outside the boot-strap,
; then revisit the binding of *safe-mode-verified-p* to t in the
; #-acl2-loop-only definition of defconst.  See the defparameter for
; *safe-mode-verified-p*.

; Why do we need to bind safe-mode to t?  An important reason is that we will
; be loading compiled files corresponding to certified books, where defconst
; forms will be evaluated in raw Lisp.  By using safe-mode, we can guarantee
; that these evaluations were free of guard violations when certifying the
; book, and hence will be free of guard violations when loading such compiled
; files.

; But even before we started loading compiled files before processing
; include-book events (i.e., up through Version_3.6.1), safe-mode played an
; important role.  The following legacy comment explains:

; Otherwise [without safe-mode bound to t], if we certify book char-bug-sub
; with a GCL image then we can certify char-bug with an Allegro image, thus
; proving nil.  The problem is that f1 is not properly guarded, yet we go
; directly into the raw Lisp version of f1 when evaluating the defconst.  That
; is just the sort of problem that safe-mode prevents.  See also :doc
; note-2-9-3 for another example, and see the comment about safe-mode related
; to redundancy of a :program mode defun with a previous :logic mode defun, in
; redundant-or-reclassifying-defunp.  And before deciding to remove safe-mode
; here, consider an example like this:

; (defun foo () (declare (xargs :mode :program)) (mbe :logic t :exec nil))
; (defconst *a* (foo))
; ... followed by a theorem about *a*.  If *a* is proved nil, that could
; conflict with a theorem that *a* is t proved after (verify-termination foo).

; Anyhow, here is the char-bug-sub example mentioned above.

; ;;; char-bug-sub.lisp

; (in-package "ACL2")
;
; (defun f1 ()
;   (declare (xargs :mode :program))
;   (char-upcase (code-char 224)))
;
; (defconst *b* (f1))
;
; (defthm gcl-not-allegro
;   (equal (code-char 224) *b*)
;   :rule-classes nil)

; ;;; char-bug.lisp

; (in-package "ACL2")
;
; (include-book "char-bug-sub")
;
; (defthm ouch
;   nil
;   :hints (("Goal" :use gcl-not-allegro))
;   :rule-classes nil)

; The following comment is no longer relevant, because the #-acl2-loop-only
; code above for the boot-strap case allows us to assume here that
; (f-get-global 'boot-strap-flg state) is nil.

;   However, it is not practical to bind safe-mode to t during the boot-strap
;   with user::*fast-acl2-gcl-build*, because we have not yet compiled the *1*
;   functions (see add-trip).  For the sake of uniformity, we go ahead and
;   allow raw Lisp calls, avoiding safe mode during the boot-strap, even for
;   other lisps.

             t ; (not (f-get-global 'boot-strap-flg state))
             ))
           (simple-translate-and-eval form nil
                                      nil
                                      "The second argument of defconst"
                                      ctx wrld state nil))))
   (value (cdr pair))))

(defun large-consp (x)
  (eql (the #.*fixnat-type* (cons-count-bounded x))
       (the #.*fixnat-type* (fn-count-evg-max-val))))

(defun defconst-fn (name form state event-form)

; Important Note:  Don't change the formals of this function without
; reading the *initial-event-defmacros* discussion in axioms.lisp.

; Warning: If this event ever generates proof obligations, remove it from the
; list of exceptions in install-event just below its "Comment on irrelevance of
; skip-proofs".

  (with-ctx-summarized
   (cons 'defconst name)
   (let ((wrld1 (w state))
         (event-form (or event-form (list 'defconst name form))))
     (er-progn
      (chk-all-but-new-name name ctx 'const wrld1 state)
      (chk-legal-defconst-name name state)
      (let ((const-prop (getpropc name 'const nil wrld1)))
        (cond
         ((and const-prop
               (not (ld-redefinition-action state))

; Skip the event-level check (which is merely an optimization; see below) if it
; seems expensive but the second check (below) could be cheap.  Imagine for
; example (defconst *a* (hons-copy '<large_cons_tree>)) executed redundantly.
; A related check may be found in the raw Lisp definition of acl2::defconst.
; For a concrete example, see :doc note-7-2.

               (not (large-consp event-form))
               (equal event-form (get-event name wrld1)))

; We stop the redundant event even before evaluating the form.  We believe
; that this is merely an optimization, even if the form calls compress1 or
; compress2 (which will not update the 'acl2-array property when supplied the
; same input as the last time the compress function was called).  We avoid this
; optimization if redefinition is on, in case we have redefined a constant or
; macro used in the body of this defconst form.

          (stop-redundant-event ctx state
                                :name name))
         (t
          (er-let*
           ((val (defconst-val name form ctx wrld1 state)))
           (cond
            ((and (consp const-prop)
                  (equal (cadr const-prop) val))

; When we store the 'const property, we kwote it so that it is a term.
; Thus, if there is no 'const property, we will getprop the nil and
; the consp will fail.

             (stop-redundant-event ctx state
                                   :name name))
            (t
             (enforce-redundancy
              event-form ctx wrld1
              (er-let*
               ((wrld2 (chk-just-new-name name nil 'const nil ctx wrld1 state))
                (wrld3 (defconst-fn1 name val wrld2 state)))
               (install-event name
                              event-form
                              'defconst
                              name
                              nil
                              (list 'defconst name form val)
                              nil nil wrld3 state)))))))))))))

(defun defmacro-fn1 (name args guard body w state)
  (let ((w (putprop
            name 'macro-args args
            (putprop
             name 'macro-body body

; Below we store the guard. We currently store it in unnormalized form.
; If we ever store it in normalized form -- or in any form other than
; the translated user input -- then reconsider redundant-defmacrop
; below.

             (putprop-unless name 'guard guard *t* w)))))
    (value w)))

(defun redundant-defmacrop (name args guard body w)

; We determine whether there is already a defmacro of name with the
; given args, guard, and body.  We know that body is a term.  Hence,
; it is not nil.  Hence, if name is not a macro and there is no
; 'macro-body, the first equal below will fail.

  (and (getpropc name 'absolute-event-number nil w)

; You might think the above test is redundant, given that we look for
; properties like 'macro-body below and find them.  But you would be wrong.
; Certain defmacros, in particular, those in *initial-event-defmacros* have
; 'macro-body and other properties but haven't really been defined yet!

       (equal (getpropc name 'macro-body nil w) body)
       (equal (macro-args name w) args)
       (equal (guard name nil w) guard)))

(defun defmacro-fn (mdef state event-form)

; Important Note:  Don't change the formals of this function without
; reading the *initial-event-defmacros* discussion in axioms.lisp.

; Warning: If this event ever generates proof obligations, remove it from the
; list of exceptions in install-event just below its "Comment on irrelevance of
; skip-proofs".

  (with-ctx-summarized
   (cons 'defmacro (car mdef))
   (let ((wrld (w state))
         (event-form (or event-form (cons 'defmacro mdef))))
     (er-let* ((val (chk-acceptable-defmacro mdef nil ctx wrld state)))
       (let ((name (car val))
             (args (cadr val))
             (edcls (caddr val))
             (body (cadddr val))
             (guard (cddddr val)))
         (er-let*
             ((tguard (translate guard '(nil) nil nil ctx wrld state)))
           (mv-let
             (ctx1 tbody)
             (translate-cmp body '(nil) nil nil ctx wrld
                            (default-state-vars t))
             (cond
              (ctx1 (cond ((null tbody)

; This case would seem to be impossible, since if translate (or translate-cmp)
; causes an error, there is presumably an associated error message.

                           (er soft ctx
                               "An error occurred in attempting to translate ~
                                the body of the macro.  It is very unusual ~
                                however to see this message; feel free to ~
                                contact the ACL2 implementors if you are ~
                                willing to help them debug how this message ~
                                occurred."))
                          ((member-eq 'state args)
                           (er soft ctx
                               "~@0~|~%You might find it useful to understand ~
                                that although you used STATE as a formal ~
                                parameter, it does not refer to the ACL2 ~
                                state.  It is just a parameter bound to some ~
                                piece of syntax during macroexpansion.  See ~
                                :DOC defmacro."
                               tbody))
                          (t (er soft ctx "~@0" tbody))))
              (t
               (er-progn
                (chk-macro-ancestors name tguard tbody ctx wrld state)
                (cond
                 ((redundant-defmacrop name args tguard tbody wrld)
                  (cond ((and (not (f-get-global 'in-local-flg state))
                              (not (f-get-global 'boot-strap-flg state))
                              (not (f-get-global 'redundant-with-raw-code-okp
                                                 state))
                              (member-eq name
                                         (f-get-global 'macros-with-raw-code
                                                       state)))

; See the comment in chk-acceptable-defuns-redundancy related to this error in
; the defuns case.

                         (er soft ctx
                             "~@0"
                             (redundant-predefined-error-msg name wrld)))
                        (t (stop-redundant-event ctx state
                                                 :name name))))
                 (t
                  (enforce-redundancy
                   event-form ctx wrld
                   (er-let*
                       ((wrld2 (chk-just-new-name name nil 'macro nil ctx
                                                  wrld state))
                        (ignored (value (ignore-vars edcls)))
                        (ignorables (value (ignorable-vars edcls))))
                     (er-progn
                      (chk-xargs-keywords1 edcls '(:guard) ctx state)
                      (chk-free-and-ignored-vars name (macro-vars args)
                                                 tguard
                                                 *nil* ; split-types-term
                                                 *no-measure*
                                                 ignored ignorables
                                                 tbody ctx state)
                      (er-let*
                          ((wrld3 (defmacro-fn1 name args
                                    tguard tbody wrld2 state)))
                        (install-event name
                                       event-form
                                       'defmacro
                                       name
                                       nil
                                       (cons 'defmacro mdef)
                                       nil nil wrld3 state)))))))))))))))))

; The following functions support boot-strapping.  Consider what
; happens when we begin to boot-strap.  The first form is read.
; Suppose it is (defconst nil 'nil).  It is translated wrt the
; initial world.  Unless 'defconst has a macro definition in that
; initial world, we won't get off the ground.  The same remark holds
; for the other primitive event functions encountered in axioms.lisp.
; Therefore, before we first call translate we have got to construct a
; world with certain properties already set.

; We compute those properties with the functions below, from the
; following constant.  This constant must be the quoted form of the
; event defmacros found in axioms.lisp!  It was obtained by
; going to the axioms.lisp buffer, grabbing all of the text in the
; "The *initial-event-defmacros* Discussion", moving it over here,
; embedding it in "(defconst *initial-event-defmacros* '(&))" and
; then deleting the #+acl2-loop-only commands, comments, and documentation
; strings.

(defconst *initial-event-defmacros*
  '((defmacro in-package (str)
      (list 'in-package-fn
            (list 'quote str)
            'state))
    (defmacro defpkg (&whole event-form name form &optional doc book-path)
      (list 'defpkg-fn
            (list 'quote name)
            (list 'quote form)
            'state
            (list 'quote doc)
            (list 'quote book-path)
            (list 'quote hidden-p)
            (list 'quote event-form)))
    (defmacro defchoose (&whole event-form &rest def)
      (list 'defchoose-fn
            (list 'quote def)
            'state
            (list 'quote event-form)))
    (defmacro defun (&whole event-form &rest def)
      (list 'defun-fn
            (list 'quote def)
            'state
            (list 'quote event-form)
            #+:non-standard-analysis ; std-p
            nil))
    (defmacro defuns (&whole event-form &rest def-lst)
      (list 'defuns-fn
            (list 'quote def-lst)
            'state
            (list 'quote event-form)
            #+:non-standard-analysis ; std-p
            nil))
    (defmacro verify-termination-boot-strap (&whole event-form &rest lst)
      (list 'verify-termination-boot-strap-fn
            (list 'quote lst)
            'state
            (list 'quote event-form)))
    (defmacro verify-guards (&whole event-form name
                                    &key
                                    (hints 'nil hints-p)
                                    (guard-debug 'nil guard-debug-p)
                                    (guard-simplify 't guard-simplify-p)
                                    otf-flg)
      (list 'verify-guards-fn
            (list 'quote name)
            'state
            (list 'quote hints) (list 'quote hints-p)
            (list 'quote otf-flg)
            (list 'quote guard-debug) (list 'quote guard-debug-p)
            (list 'quote guard-simplify) (list 'quote guard-simplify-p)
            (list 'quote event-form)))
    (defmacro defmacro (&whole event-form &rest mdef)
      (list 'defmacro-fn
            (list 'quote mdef)
            'state
            (list 'quote event-form)))
    (defmacro defconst (&whole event-form name form &optional doc)
      (list 'defconst-fn
            (list 'quote name)
            (list 'quote form)
            'state
            (list 'quote event-form)))
    (defmacro defstobj (&whole event-form name &rest args)
      (list 'defstobj-fn
            (list 'quote name)
            (list 'quote args)
            'state
            (list 'quote event-form)))
    (defmacro defthm (&whole event-form
                             name term
                             &key (rule-classes '(:REWRITE))
                             instructions
                             hints
                             otf-flg)
      (list 'defthm-fn
            (list 'quote name)
            (list 'quote term)
            'state
            (list 'quote rule-classes)
            (list 'quote instructions)
            (list 'quote hints)
            (list 'quote otf-flg)
            (list 'quote event-form)
            #+:non-standard-analysis ; std-p
            nil))
    (defmacro defaxiom (&whole event-form
                               name term
                               &key (rule-classes '(:REWRITE)))
      (list 'defaxiom-fn
            (list 'quote name)
            (list 'quote term)
            'state
            (list 'quote rule-classes)
            (list 'quote event-form)))
    (defmacro deflabel (&whole event-form name)
      (list 'deflabel-fn
            (list 'quote name)
            'state
            (list 'quote event-form)))
    (defmacro deftheory (&whole event-form name expr)
      (list 'deftheory-fn
            (list 'quote name)
            (list 'quote expr)
            'state
            (list 'quote redundant-okp)
            (list 'quote ctx)
            (list 'quote event-form)))
    (defmacro in-theory (&whole event-form expr)
      (list 'in-theory-fn
            (list 'quote expr)
            'state
            (list 'quote event-form)))
    (defmacro in-arithmetic-theory (&whole event-form expr)
      (list 'in-arithmetic-theory-fn
            (list 'quote expr)
            'state
            (list 'quote event-form)))
    (defmacro regenerate-tau-database (&whole event-form)
      (list 'regenerate-tau-database-fn
            'state
            (list 'quote event-form)))
    (defmacro push-untouchable (&whole event-form name fn-p)
      (list 'push-untouchable-fn
            (list 'quote name)
            (list 'quote fn-p)
            'state
            (list 'quote event-form)))
    (defmacro set-body (&whole event-form fn name-or-rune)
      (list 'set-body-fn
            (list 'quote fn)
            (list 'quote name-or-rune)
            'state
            (list 'quote event-form)))
    (defmacro table (&whole event-form name &rest args)
      (list 'table-fn
            (list 'quote name)
            (list 'quote args)
            'state
            (list 'quote event-form)))
    (defmacro progn (&rest r)
      (list 'progn-fn
            (list 'quote r)
            'state))
    (defmacro encapsulate (&whole event-form signatures &rest cmd-lst)
      (list 'encapsulate-fn
            (list 'quote signatures)
            (list 'quote cmd-lst)
            'state
            (list 'quote event-form)))
    (defmacro include-book (&whole event-form user-book-name
                                   &key
                                   (load-compiled-file ':default)
                                   (uncertified-okp 't)
                                   (defaxioms-okp 't)
                                   (skip-proofs-okp 't)
                                   (ttags 'nil)
                                   dir)
      (list 'include-book-fn
            (list 'quote user-book-name)
            'state
            (list 'quote load-compiled-file)
            (list 'quote nil)
            (list 'quote uncertified-okp)
            (list 'quote defaxioms-okp)
            (list 'quote skip-proofs-okp)
            (list 'quote ttags)
            (list 'quote dir)
            (list 'quote event-form)))
    (defmacro local (x)
      (list 'if
            '(or (member-eq (ld-skip-proofsp state)
                            '(include-book initialize-acl2))
                 (f-get-global 'ld-always-skip-top-level-locals state))
            '(mv nil nil state)
            (list 'state-global-let*
                  '((in-local-flg t))
                  (list 'when-logic "LOCAL" x))))
    (defmacro defattach (&whole event-form &rest args)
      (list 'defattach-fn
            (list 'quote args)
            'state
            (list 'quote event-form)))
    ))

; Because of the Important Boot-Strapping Invariant noted in axioms.lisp,
; we can compute from this list the following things for each event:

; the macro name
; the macro args
; the macro body
; the -fn name corresponding to the macro
; the formals of the -fn

; The macro name and args are easy.  The macro body must be obtained
; from the list above by translating the given bodies, but we can't use
; translate yet because the world is empty and so, for example, 'list
; is not defined as a macro in it.  So we use the following boot-strap
; version of translate that is capable (just) of mapping the bodies above
; into their translations under a properly initialized world.

(defun boot-translate (x)
  (cond ((atom x)
         (cond ((eq x nil) *nil*)
               ((eq x t) *t*)
               ((keywordp x) (kwote x))
               ((symbolp x) x)
               (t (kwote x))))
        ((eq (car x) 'quote) x)
        ((eq (car x) 'if)
         (list 'if
               (boot-translate (cadr x))
               (boot-translate (caddr x))
               (boot-translate (cadddr x))))
        ((eq (car x) 'equal)
         (list 'equal
               (boot-translate (cadr x))
               (boot-translate (caddr x))))
        ((eq (car x) 'ld-skip-proofsp)
         (list 'ld-skip-proofsp
               (boot-translate (cadr x))))
        ((or (eq (car x) 'list)
             (eq (car x) 'mv))
         (cond ((null (cdr x)) *nil*)
               (t (list 'cons
                        (boot-translate (cadr x))
                        (boot-translate (cons 'list (cddr x)))))))
        ((eq (car x) 'when-logic)
         (list 'if
               '(eq (default-defun-mode-from-state state) ':program)
               (list 'skip-when-logic (list 'quote (cadr x)) 'state)
               (boot-translate (caddr x))))
        (t (er hard 'boot-translate
               "Boot-translate was called on ~x0, which is ~
                unrecognized.  If you want to use such a form in one ~
                of the *initial-event-defmacros* then you must modify ~
                boot-translate so that it can translate the form."
               x))))

; The -fn name corresponding to the macro is easy.  Finally to get the
; formals of the -fn we have to walk through the actuals of the call of
; the -fn in the macro body and unquote all the names but 'STATE.  That
; is done by:

(defun primordial-event-macro-and-fn1 (actuals)
  (cond ((null actuals) nil)
        ((equal (car actuals) '(quote state))
         (cons 'state (primordial-event-macro-and-fn1 (cdr actuals))))
        #+:non-standard-analysis
        ((or (equal (car actuals) nil)
             (equal (car actuals) t))

; Since nil and t are not valid names for formals, we need to transform (car
; actuals) to something else.  Up until the non-standard extension this never
; happened.  We henceforth assume that values of nil and t correspond to the
; formal std-p.

         (cons 'std-p (primordial-event-macro-and-fn1 (cdr actuals))))
        ((and (consp (car actuals))
              (eq (car (car actuals)) 'list)
              (equal (cadr (car actuals)) '(quote quote)))
         (cons (caddr (car actuals))
               (primordial-event-macro-and-fn1 (cdr actuals))))
        (t (er hard 'primordial-event-macro-and-fn1
               "We encountered an unrecognized form of actual, ~x0, ~
                in trying to extract the formals from the actuals in ~
                some member of *initial-event-defmacros*.  If you ~
                want to use such a form in one of the initial event ~
                defmacros, you must modify ~
                primordial-event-macro-and-fn1 so that it can recover ~
                the corresponding formal name from the actual form."
               (car actuals)))))

(defun primordial-event-macro-and-fn (form wrld)

; Given a member of *initial-event-defmacros* above, form, we check that
; it is of the desired shape, extract the fields we need as described,
; and putprop them into wrld.

  (case-match form
              (('defmacro 'local macro-args macro-body)
               (putprop
                'local 'macro-args macro-args
                (putprop
                 'local 'macro-body (boot-translate macro-body)
                 (putprop
                  'ld-skip-proofsp 'symbol-class :common-lisp-compliant
                  (putprop
                   'ld-skip-proofsp 'formals '(state)
                   (putprop
                    'ld-skip-proofsp 'stobjs-in '(state)
                    (putprop
                     'ld-skip-proofsp 'stobjs-out '(nil)

; See the fakery comment below for an explanation of this infinite
; recursion!  This specious body is only in effect during the
; processing of the first part of axioms.lisp during boot-strap.  It
; is overwritten by the accepted defun of ld-skip-proofsp.  Similarly
; for default-defun-mode-from-state and skip-when-logic.

                     (putprop
                      'ld-skip-proofsp 'def-bodies
                      (list (make def-body
                                  :formals '(state)
                                  :hyp nil
                                  :concl '(ld-skip-proofsp state)
                                  :equiv 'equal
                                  :rune *fake-rune-for-anonymous-enabled-rule*
                                  :nume 0 ; fake
                                  :recursivep nil
                                  :controller-alist nil))
                      (putprop
                       'default-defun-mode-from-state 'symbol-class
                       :common-lisp-compliant
                       (putprop
                        'default-defun-mode-from-state 'formals '(state)
                        (putprop
                         'default-defun-mode-from-state 'stobjs-in '(state)
                         (putprop
                          'default-defun-mode-from-state 'stobjs-out '(nil)
                          (putprop
                           'default-defun-mode-from-state 'def-bodies
                           (list (make def-body
                                       :formals '(str state)
                                       :hyp nil
                                       :concl '(default-defun-mode-from-state
                                                 state)
                                       :equiv 'equal
                                       :rune
                                       *fake-rune-for-anonymous-enabled-rule*
                                       :nume 0 ; fake
                                       :recursivep nil
                                       :controller-alist nil))
                           (putprop
                            'skip-when-logic 'symbol-class
                            :common-lisp-compliant
                            (putprop
                             'skip-when-logic 'formals '(str state)
                             (putprop
                              'skip-when-logic 'stobjs-in '(nil state)
                              (putprop
                               'skip-when-logic 'stobjs-out *error-triple-sig*
                               (putprop
                                'skip-when-logic 'def-bodies
                                (list (make def-body
                                            :formals '(str state)
                                            :hyp nil
                                            :concl '(skip-when-logic str state)
                                            :equiv 'equal
                                            :rune
                                            *fake-rune-for-anonymous-enabled-rule*
                                            :nume 0 ; fake
                                            :recursivep nil
                                            :controller-alist nil))
                                wrld))))))))))))))))))
              (('defmacro name macro-args
                 ('list ('quote name-fn) . actuals))
               (let* ((formals (primordial-event-macro-and-fn1 actuals))
                      (stobjs-in (compute-stobj-flags formals t nil wrld))

; known-stobjs = t but, in this case it could just as well be
; known-stobjs = '(state) because we are constructing the primordial world
; and state is the only stobj.

                      (macro-body (boot-translate (list* 'list
                                                         (kwote name-fn)
                                                         actuals))))

; We could do a (putprop-unless name 'guard *t* *t* &) and a
; (putprop-unless name-fn 'guard *t* *t* &) here, but it would be silly.

                 (putprop
                  name 'macro-args macro-args
                  (putprop
                   name 'macro-body macro-body
                   (putprop
                    name-fn 'symbol-class :program
                    (putprop
                     name-fn 'formals formals
                     (putprop
                      name-fn 'stobjs-in stobjs-in
                      (putprop
                       name-fn 'stobjs-out *error-triple-sig*
                       wrld))))))))
              (& (er hard 'primordial-event-macro-and-fn
                     "The supplied form ~x0 was not of the required shape.  ~
                      Every element of *initial-event-defmacros* must be of ~
                      the form expected by this function.  Either change the ~
                      event defmacro or modify this function."
                     form))))

(defun primordial-event-macros-and-fns (lst wrld)

; This function is given *initial-event-defmacros* and just sweeps down it,
; putting the properties for each event macro and its corresponding -fn.

  (cond
   ((null lst) wrld)
   (t (primordial-event-macros-and-fns
       (cdr lst)
       (primordial-event-macro-and-fn (car lst) wrld)))))

; We need to declare the 'type-prescriptions for those fns that are
; referenced before they are defined in the boot-strapping process.
; Actually, apply is such a function, but it has an unrestricted type
; so we leave its 'type-prescriptions nil.

(defconst *initial-type-prescriptions*
  (list (list 'o-p
              (make type-prescription
                    :rune *fake-rune-for-anonymous-enabled-rule*
                    :nume nil
                    :term '(o-p x)
                    :hyps nil
                    :backchain-limit-lst nil
                    :basic-ts *ts-boolean*
                    :vars nil
                    :corollary '(booleanp (o-p x))))
        (list 'o<
              (make type-prescription
                    :rune *fake-rune-for-anonymous-enabled-rule*
                    :nume nil
                    :term '(o< x y)
                    :hyps nil
                    :backchain-limit-lst nil
                    :basic-ts *ts-boolean*
                    :vars nil
                    :corollary '(booleanp (o< x y))))))

(defun collect-world-globals (wrld ans)
  (cond ((null wrld) ans)
        ((eq (cadar wrld) 'global-value)
         (collect-world-globals (cdr wrld)
                                (add-to-set-eq (caar wrld) ans)))
        (t (collect-world-globals (cdr wrld) ans))))

(defun primordial-world-globals (operating-system project-dir-alist)

; This function is the standard place to initialize a world global.
; Among the effects of this function is to set the global variable
; 'world-globals to the list of all variables initialized.  Thus,
; it is very helpful to follow the discipline of initializing all
; globals here, whether their initial values are important or not.

; Historical Note: Once upon a time, before we kept a stack of
; properties on the property lists representing installed worlds, it
; was necessary, when retracting from a world, to scan the newly
; exposed world to find the new current value of any property removed.
; This included the values of world globals and it often sent us all
; the way back to the beginning of the primordial world.  We then
; patched things up by using this collection of names at the end of
; system initialization to "float" to the then-top of the world the
; values of all world globals.  That was the true motivation of
; collecting the initialization of all globals into one function: so
; we could get 'world-globals so we knew who to float.

  (let ((wrld
         (global-set-lst
          (list*
           (list 'event-landmark (make-event-tuple -1 0 nil nil 0 nil nil nil))
           (list 'command-landmark (make-command-tuple -1 :logic nil nil nil))
           (list 'known-package-alist *initial-known-package-alist*)
           (list 'well-founded-relation-alist
                 (list (cons 'o<
                             (cons 'o-p
                                   *fake-rune-for-anonymous-enabled-rule*))
; The following is justified by the theorem WELL-FOUNDED-L<, which is quoted in
; check-system-events and thus checked by "make devel-check".
                       (cons 'l<
                             (cons 'lexp
                                   *fake-rune-for-anonymous-enabled-rule*))))
           (list 'built-in-clauses
                 (classify-and-store-built-in-clause-rules
                  *initial-built-in-clauses*
                  nil
; The value of wrld supplied below, nil, just means that all function symbols
; of initial-built-in-clauses will seem to have level-no 0.
                  nil))
           (list 'half-length-built-in-clauses
                 (floor (length *initial-built-in-clauses*) 2))
           (list 'type-set-inverter-rules *initial-type-set-inverter-rules*)
           (list 'global-arithmetic-enabled-structure
                 (initial-global-enabled-structure
                  "ARITHMETIC-ENABLED-ARRAY-"))
           (let ((globals
                  `((event-index nil)
                    (command-index nil)
                    (event-number-baseline 0)
                    (embedded-event-lst nil)
                    (cltl-command nil)
                    (top-level-cltl-command-stack nil)
                    (include-book-alist nil)
                    (include-book-alist-all nil)
                    (pcert-books nil)
                    (include-book-path nil)
                    (certification-tuple nil)
                    (proved-functional-instances-alist nil)
                    (nonconstructive-axiom-names nil)
                    (standard-theories (nil nil nil nil))
                    (current-theory nil)
                    (current-theory-length 0)
                    (current-theory-augmented nil)
                    (current-theory-index -1)
                    (generalize-rules nil)

; Make sure the following tau globals are initialized this same way
; by initialize-tau-globals:

                    (tau-runes nil)
                    (tau-next-index 0)
                    (tau-conjunctive-rules nil)
                    (tau-mv-nth-synonyms nil)
                    (tau-lost-runes nil)

                    (clause-processor-rules nil)
                    (boot-strap-flg t)
                    (boot-strap-pass-2 nil)
                    (skip-proofs-seen nil)
                    (redef-seen nil)
                    (cert-replay nil)
                    (free-var-runes-all nil)
                    (free-var-runes-once nil)
                    (translate-cert-data nil)
                    (chk-new-name-lst
                     (if iff implies not
                         in-package
                         defpkg defun defuns mutual-recursion defmacro defconst
                         defstobj defthm defaxiom progn encapsulate include-book
                         deflabel deftheory
                         in-theory in-arithmetic-theory regenerate-tau-database
                         push-untouchable remove-untouchable set-body table
                         reset-prehistory verify-guards verify-termination-boot-strap
                         local defchoose ld-skip-proofsp
                         in-package-fn defpkg-fn defun-fn defuns-fn
                         mutual-recursion-fn defmacro-fn defconst-fn
                         defstobj-fn
                         defthm-fn defaxiom-fn progn-fn encapsulate-fn
                         include-book-fn deflabel-fn
                         deftheory-fn in-theory-fn in-arithmetic-theory-fn
                         regenerate-tau-database-fn
                         push-untouchable-fn remove-untouchable-fn
                         reset-prehistory-fn set-body-fn
                         table-fn verify-guards-fn verify-termination-boot-strap-fn
                         defchoose-fn apply o-p o<
                         defattach defattach-fn
                         default-defun-mode-from-state skip-when-logic

; The following names are here simply so we can deflabel them for
; documentation purposes:

                         state
                         declare apropos finding-documentation
                         enter-boot-strap-mode exit-boot-strap-mode
                         lp acl2-defaults-table let let*
                         complex complex-rationalp

; The following became necessary after Version_8.2, when we starting storing a
; new 'recognizer-alist property on symbols (in the primordial-world) in place
; of using a world global for the recognizer-alist.

                         ,@(strip-cars *initial-recognizer-alist*)
                         ))
                    (ttags-seen nil)
                    (never-untouchable-fns nil)
                    (untouchable-fns nil)
                    (untouchable-vars nil)
                    (defined-hereditarily-constrained-fns nil)
                    (attach-nil-lst nil)
                    (attachment-records nil)
                    (attachments-at-ground-zero nil)
                    (proof-supporters-alist nil)
                    (lambda$-alist nil)
                    (loop$-alist nil)
                    (common-lisp-compliant-lambdas nil)
                    (rewrite-quoted-constant-rules nil)
                    (project-dir-alist ,project-dir-alist)
                    (projects/apply/base-includedp nil)
                    (ext-gens nil)
                    (ext-gen-barriers nil)
                    )))
             (list* `(operating-system ,operating-system)
                    `(command-number-baseline-info
                      ,(make command-number-baseline-info
                             :current 0
                             :permanent-p t
                             :original 0))
                    globals)))
          nil)))
    (global-set 'world-globals
                (collect-world-globals wrld '(world-globals))
                wrld)))

(defun arglists-to-nils (arglists)
  (declare (xargs :guard (true-list-listp arglists)))
  (cond ((endp arglists) nil)
        (t (cons (make-list (length (car arglists)))
                 (arglists-to-nils (cdr arglists))))))

(defconst *unattachable-primitives*

; This constant contains the names of function symbols for which we must
; disallow attachments, for example to prevent execution.  So we search the
; code for encapsulated functions that we do not want executed.

  '(big-n decrement-big-n zp-big-n

; We disallow user-supplied attachments for the following system functions that
; support apply$.

          badge-userfn apply$-userfn

; At one time we also included canonical-pathname and various mfc-xx functions.
; But these are all handled now by dependent clause-processors, which gives
; them unknown-constraints and hence defeats attachability.

          ))

;; Historical Comment from Ruben Gamboa:
;; I added the treatment of *non-standard-primitives*

(defun putprop-recognizer-alist (alist wrld)
  (cond ((endp alist) wrld)
        (t (putprop-recognizer-alist
            (cdr alist)
            (let* ((recog-tuple (car alist))
                   (fn (access recognizer-tuple recog-tuple :fn)))
              (putprop fn 'recognizer-alist
                       (cons recog-tuple
                             (getpropc fn 'recognizer-alist nil wrld))
                       wrld))))))

(defun primordial-world (operating-system project-dir-alist)

; Warning: Names converted during the boot-strap from :program mode to :logic
; mode will, we believe, have many properties erased by renew-name.  Consider
; whether a property should be set in end-prehistoric-world rather than here.
; But be careful; through Version_8.3 we had that issue in mind when we called
; a function to initialize invariant-risk for certain function symbols (see
; *boot-strap-invariant-risk-alist*)a at the end of the boot-strap, in
; end-prehistoric-world, instead of here.  But then the 'invariant-risk
; property was never set for aset1-lst, even though it calls aset1, which has
; invariant-risk.

  (let ((names (strip-cars *primitive-formals-and-guards*))
        (arglists (strip-cadrs *primitive-formals-and-guards*))
        (guards (strip-caddrs *primitive-formals-and-guards*))
        (ns-names #+:non-standard-analysis *non-standard-primitives*
                  #-:non-standard-analysis nil))

    (add-command-landmark
     :logic
     (list 'enter-boot-strap-mode operating-system)
     nil ; cbd is only needed for user-generated commands
     nil
     (add-event-landmark
      (list 'enter-boot-strap-mode operating-system)
      'enter-boot-strap-mode
      (append (strip-cars *primitive-formals-and-guards*)
              (strip-non-hidden-package-names *initial-known-package-alist*))
      (initialize-tau-preds
       *primitive-monadic-booleans*
       (putprop
        'equal
        'coarsenings
        '(equal)
        (putprop-x-lst1
         names 'absolute-event-number 0
         (putprop-x-lst1
          names 'predefined t
          (putprop-defun-runic-mapping-pairs
           names nil
           (putprop-x-lst1
            ns-names ; nil in the #-:non-standard-analysis case
            'classicalp nil
            (putprop-x-lst1
             ns-names
             'constrainedp t
             (putprop-x-lst1
              names
              'symbol-class :common-lisp-compliant
              (putprop-x-lst2-unless
               names 'guard guards *t*
               (putprop-x-lst2
                names 'formals arglists
                (putprop-x-lst2
                 (strip-cars *initial-type-prescriptions*)
                 'type-prescriptions
                 (strip-cdrs *initial-type-prescriptions*)
                 (putprop-x-lst1
                  names 'coarsenings nil
                  (putprop-x-lst1
                   names 'congruences nil
                   (putprop-x-lst1
                    names 'pequivs nil
                    (putprop-x-lst2
                     names 'stobjs-in (arglists-to-nils arglists)
                     (putprop-x-lst1
                      names 'stobjs-out '(nil)
                      (primordial-event-macros-and-fns
                       *initial-event-defmacros*

; This putprop must be here, into the world seen by
; primordial-event-macros-and-fns!

                       (putprop
                        'state 'stobj '(*the-live-state*)
                        (putprop-recognizer-alist
                         *initial-recognizer-alist*
                         (primordial-world-globals
                          operating-system
                          project-dir-alist))))))))))))))))))))
      t
      nil
      nil))))

(defun same-name-twice (l)
  (cond ((null l) nil)
        ((null (cdr l)) nil)
        ((equal (symbol-name (car l))
                (symbol-name (cadr l)))
         (list (car l) (cadr l)))
        (t (same-name-twice (cdr l)))))

(defun conflicting-imports (l)

; We assume that l is sorted so that if any two elements have the same
; symbol-name, then two such are adjacent.

  (same-name-twice l))

(defun chk-new-stringp-name (ev-type name ctx w state)

; This function has a slightly misleading name, because if ev-type is
; include-book, then name is a full-book-name and hence might be a sysfile.

  (cond
   ((not (if (eq ev-type 'defpkg)
             (stringp name)
           (book-name-p name)))
    (er soft ctx
        "The first argument to ~s0 must be a ~s1.  You provided the object ~
         ~x2.  See :DOC ~s0."
        (cond
         ((eq ev-type 'defpkg) "defpkg")
         (t "include-book"))
        (cond
         ((eq ev-type 'defpkg) "string")
         (t "book-name"))
        name))
   (t (let ((entry
             (and (stringp name)
                  (find-package-entry name
                                      (global-val 'known-package-alist w)))))
        (cond
         ((and entry
               (not (and (eq ev-type 'defpkg)
                         (package-entry-hidden-p entry))))

; Name is already defined as a package, and either that package is not hidden
; or ev-type is 'include-book.  Since we don't allow reincarnation of packages
; we certainly want to cause an error here in the case that ev-type is 'defpkg.
; We could perhaps let this go in the include-book case, but we'll be strict
; rather than think hard about that; anyhow, we expect it to be rare that
; package names, which must be upper-case, are book-names, which generally have
; lower-case characters.

          (er soft ctx
              "The name ~x0 is in use as a package name.  We do not permit ~
               package names~s1 to participate in redefinition.  If you must ~
               redefine this name, use :ubt to undo the existing definition."
              name
              (if (package-entry-hidden-p entry)
                  " (even those that are hidden; see :DOC hidden-death-package"
                "")))
         ((assoc-equal name (global-val 'include-book-alist w))

; Name is thus a full-book-name.

          (cond
           ((eq ev-type 'include-book)
            (value name))
           (t

; As above, we expect name conflicts between defpkg and include-book to be very
; rare.  So we don't bother to replace name below by a string in the case that
; it is a sysfile.

            (er soft ctx
                "The name ~x0 is in use as a book-name.  You are trying to ~
                 redefine it as a package.  We do not permit package names to ~
                 participate in redefinition.  If you must redefine this ~
                 name, use :ubt to undo the existing definition."
                name))))
         (t (value nil)))))))

(defun chk-package-reincarnation-import-restrictions (name proposed-imports)

; Logically, this function always returns t, but it may cause a hard
; error because we cannot create a package with the given name and imports.
; See :DOC package-reincarnation-import-restrictions.

  #+acl2-loop-only
  (declare (ignore name proposed-imports))
  #-acl2-loop-only
  (chk-package-reincarnation-import-restrictions2 name proposed-imports)
  t)

(defun convert-book-string-to-cert (x cert-op)

; X is a book pathname (a string).  We generate the corresponding certification
; file name.

; The cddddr below chops off the "lisp" from the end of the filename but leaves
; the dot.

  (concatenate 'string
               (remove-lisp-suffix x nil)
               (case cert-op
                 ((t)
                  "cert")
                 ((:create-pcert :create+convert-pcert)
                  "pcert0")
                 (:convert-pcert
                  "pcert1")
                 (otherwise ; including :write-acl2x
                  (er hard 'convert-book-string-to-cert
                      "Bad value of cert-op for convert-book-string-to-cert:  ~
                       ~x0"
                      cert-op)))))

(defun tilde-@-defpkg-error-phrase (name package-entry new-not-old old-not-new
                                         book-path defpkg-book-path w)
  (let* ((project-dir-alist (project-dir-alist w))
         (ctx 'tilde-@-defpkg-error-phrase)
         (book-path-strings
          (book-name-lst-to-filename-lst book-path project-dir-alist ctx))
         (defpkg-book-path-strings
           (book-name-lst-to-filename-lst defpkg-book-path project-dir-alist
                                          ctx)))
    (list
     "The proposed defpkg conflicts with an existing defpkg for ~
      name ~x0~@1.  ~#a~[For example, symbol ~s2::~s3 is in the list of ~
      imported symbols for the ~s4 definition but not for the other.~/The two ~
      have the same lists of imported symbols, but not in the same order.~]  ~
      The existing defpkg is ~#5~[at the top level.~/in the certificate file ~
      for the book ~x7, which is included at the top level.~/in the ~
      certificate file for the book ~x7, which is included via the following ~
      path, from top-most book down to the above file.~|  ~F8~]~@9~@b"
     (cons #\0 name)
     (cons #\1 (if (package-entry-hidden-p package-entry)
                   " that no longer exists in the current ACL2 logical world ~
                  (see :DOC hidden-death-package)"
                 ""))
     (cons #\a (if (or new-not-old old-not-new) 0 1))
     (cons #\2 (symbol-package-name (if new-not-old
                                        (car new-not-old)
                                      (car old-not-new))))
     (cons #\3 (symbol-name (if new-not-old
                                (car new-not-old)
                              (car old-not-new))))
     (cons #\4 (if new-not-old "proposed" "existing"))
     (cons #\5 (zero-one-or-more book-path-strings))
     (cons #\7 (car book-path-strings))
     (cons #\8 (reverse book-path-strings))
     (cons #\9 (if defpkg-book-path-strings
                   "~|This existing defpkg event appears to have been created ~
                  because of a defpkg that was hidden by a local include-book; ~
                  see :DOC hidden-death-package."
                 ""))
     (cons #\b (let ((include-book-path-strings
                      (book-name-lst-to-filename-lst
                       (global-val 'include-book-path w)
                       project-dir-alist
                       ctx)))
                 (if (or include-book-path-strings
                         defpkg-book-path-strings)
                     (msg "~|The proposed defpkg event may be found by ~
                           following the sequence of include-books below, ~
                           from top-most book down to the book whose ~
                           portcullis contains the proposed defpkg event.~|  ~
                           ~F0"
                          (reverse (append defpkg-book-path-strings
                                           include-book-path-strings)))
                   ""))))))

(defconst *1*-pkg-prefix*

; Unfortunately, *1*-package-prefix* is defined in raw Lisp only, early in the
; boot-strap.  We mirror that constant here for use below.

  (let ((result "ACL2_*1*_"))
    #-acl2-loop-only
    (or (equal result *1*-package-prefix*)
        (er hard '*1*-pkg-prefix*
            "Implementation error:  Failed to keep *1*-package-prefix* and ~
             *1*-pkg-prefix* in sync."))
    result))

(defun chk-acceptable-defpkg (name form defpkg-book-path hidden-p ctx w state)

; Warning: Keep this in sync with the redefinition of this function in
; community book books/misc/redef-pkg.lisp.

; We return an error triple.  The non-error value is either 'redundant or a
; triple (tform value . package-entry), where tform and value are a translated
; form and its value, and either package-entry is nil in the case that no
; package with name name has been seen, or else is an existing entry for name
; in known-package-alist with field hidden-p=t (see the Essay on Hidden
; Packages).

  (let ((package-entry
         (and (not (f-get-global 'boot-strap-flg state))
              (find-package-entry
               name
               (global-val 'known-package-alist w)))))
    (cond
     ((not (true-listp defpkg-book-path))
      (er soft ctx
          "The book-path argument to defpkg, if supplied, must be a ~
           true-listp.  It is not recommended to supply this argument, since ~
           the system makes use of it for producing useful error messages.  ~
           The defpkg of ~x0 is thus illegal."
          name))
     ((get-invalid-book-name defpkg-book-path (os w) w)
      (er soft ctx
         "A defpkg form for ~x0 specifies an invalid book-path entry, ~x1.~@2"
         name
         (get-invalid-book-name defpkg-book-path (os w) w)
         (let ((x (get-invalid-book-name defpkg-book-path (os w) w)))
           (if (and (sysfile-p x)
                    (not (project-dir-lookup (sysfile-key x)
                                             (project-dir-alist w)
                                             nil)))
               (msg "  Note that the keyword ~x0 is not currently bound in ~
                     the project-dir-alist.  Probably it was bound in the ~
                     project-dir-alist in a previous session, when this ~
                     defpkg form was written to a book's certificate.  See ~
                     :DOC project-dir-alist."
                    (sysfile-key x))
; The following case is presumably rare or impossible.
             ""))))
     ((and package-entry
           (or hidden-p
               (not (package-entry-hidden-p package-entry)))
           (equal (caddr (package-entry-defpkg-event-form package-entry))
                  form))
      (value 'redundant))
     (t
      (er-progn
       (cond
        ((or package-entry
             (eq (ld-skip-proofsp state) 'include-book))
         (value nil))
        ((not (stringp name))
         (er soft ctx
             "Package names must be string constants and ~x0 is not.  See ~
              :DOC defpkg."
             name))
        ((equal name "")

; In Allegro CL, "" is prohibited because it is already a nickname for the
; KEYWORD package.  But in (non-ANSI, at least) GCL we could prove nil up
; through v2-7 by certifying the following book with the indicated portcullis:

; (in-package "ACL2")
;
; Portcullis:
; (defpkg "" nil)
;
; (defthm bug
;   nil
;   :hints (("Goal" :use ((:instance intern-in-package-of-symbol-symbol-name
;                                    (x '::abc) (y 17)))))
;   :rule-classes nil)

         (er soft ctx
             "The empty string is not a legal package name for defpkg."
             name))
        ((not (equal (string-upcase name) name))
         (er soft ctx
             "~x0 is not a legal package name for defpkg, which disallows ~
              lower case characters in the name."
             name))
        ((equal name "LISP")
         (er soft ctx
             "~x0 is disallowed as a a package name for defpkg, because this ~
              package name is used under the hood in some Common Lisp ~
              implementations."
             name))
        ((let ((len (length *1*-pkg-prefix*)))
           (and (<= len (length name))
                (string-equal (subseq name 0 len) *1*-pkg-prefix*)))

; The use of string-equal could be considered overkill; probably equal provides
; enough of a check.  But we prefer not to consider the possibility that some
; Lisp has case-insensitive package names.  Probably we should similarly use
; member-string-equal instead of member-equal below.

         (er soft ctx
             "It is illegal for a package name to start (even ignoring case) ~
              with the string \"~@0\".  ACL2 makes internal use of package ~
              names starting with that string."
             *1*-pkg-prefix*))
        (t (value nil)))

; At one time we checked that if the package exists, i.e. (member-equal name
; all-names), and we are not in the boot-strap, then name must previously have
; been introduced by defpkg.  But name may have been introduced by
; maybe-introduce-empty-pkg, or even by a defpkg form evaluated in raw Lisp
; when loading a compiled file before processing events on behalf of an
; include-book.  So we leave it to defpkg-raw1 to check that a proposed package
; is either new, is among *defpkg-virgins*, or is consistent with an existing
; entry in *ever-known-package-alist*.

       (state-global-let*
        ((safe-mode

; Warning: If you are tempted to bind safe-mode to nil outside the boot-strap,
; then revisit the binding of *safe-mode-verified-p* to t in the
; #-acl2-loop-only definition of defpkg-raw.  See the defparameter for
; *safe-mode-verified-p*.

; In order to build a profiling image for GCL, we have observed a need to avoid
; going into safe-mode when building the system.

          (not (f-get-global 'boot-strap-flg state))))
        (er-let*
         ((pair (simple-translate-and-eval form nil nil
                                           "The second argument to defpkg"
                                           ctx w state nil)))
         (let ((tform (car pair))
               (imports (cdr pair)))
           (cond
            ((not (symbol-listp imports))
             (er soft ctx
                 "The second argument of defpkg must eval to a list of ~
                  symbols.  See :DOC defpkg."))
            (t (let* ((imports (sort-symbol-listp imports))
                      (conflict (conflicting-imports imports))
                      (base-symbol (packn (cons name '("-PACKAGE")))))

; Base-symbol is the base symbol of the rune for the rule added by
; defpkg describing the properties of symbol-package-name on interns
; with the new package.

                 (cond
                  ((member-symbol-name *pkg-witness-name* imports)
                   (er soft ctx
                       "It is illegal to import symbol ~x0 because its name ~
                        has been reserved for a symbol in the package being ~
                        defined."
                       (car (member-symbol-name *pkg-witness-name*
                                                imports))))
                  (conflict
                   (er soft ctx
                       "The value of the second (imports) argument of defpkg ~
                        may not contain two symbols with the same symbol ~
                        name, e.g. ~&0.  See :DOC defpkg."
                       conflict))
                  (t (cond
                      ((and package-entry
                            (not (equal imports
                                        (package-entry-imports
                                         package-entry))))
                       (er soft ctx
                           "~@0"
                           (tilde-@-defpkg-error-phrase
                            name package-entry
                            (set-difference-eq
                             imports
                             (package-entry-imports package-entry))
                            (set-difference-eq
                             (package-entry-imports package-entry)
                             imports)
                            (package-entry-book-path package-entry)
                            defpkg-book-path
                            w)))
                      ((and package-entry
                            (or hidden-p
                                (not (package-entry-hidden-p package-entry))))
                       (prog2$
                        (chk-package-reincarnation-import-restrictions
                         name imports)
                        (value 'redundant)))
                      (t (er-progn
                          (chk-new-stringp-name 'defpkg name ctx w state)
                          (chk-all-but-new-name base-symbol ctx nil w state)

; Note:  Chk-just-new-name below returns a world which we ignore because
; we know redefinition of 'package base-symbols is disallowed, so the
; world returned is w when an error isn't caused.

; Warning: In maybe-push-undo-stack and maybe-pop-undo-stack we rely
; on the fact that the symbol name-PACKAGE is new!

                          (chk-just-new-name base-symbol nil
                                             'theorem nil ctx w state)
                          (prog2$
                           (chk-package-reincarnation-import-restrictions
                            name imports)
                           (value (list* tform
                                         imports
                                         package-entry ; hidden-p is true
                                         )))))))))))))))))))

(defun defpkg-fn (name form state doc book-path hidden-p event-form)

; Important Note:  Don't change the formals of this function without
; reading the *initial-event-defmacros* discussion in axioms.lisp.

; Warning: If this event ever generates proof obligations, remove it from the
; list of exceptions in install-event just below its "Comment on irrelevance of
; skip-proofs".

; Like defconst, defpkg evals its second argument.

; We forbid interning into a package before its imports are set once and for
; all.  In the case of the main Lisp package, we assume that we have no control
; over it and simply refuse requests to intern into it.

  (with-ctx-summarized
   (cons 'defpkg name)
   (let ((w (w state))
         (event-form (or event-form
                         (list* 'defpkg name form
                                (if (or doc book-path) (list doc) nil)
                                (if book-path (list book-path) nil)))))
     (er-let* ((tform-imports-entry
                (chk-acceptable-defpkg name form book-path hidden-p ctx w
                                       state)))
              (cond
               ((eq tform-imports-entry 'redundant)
                (stop-redundant-event ctx state))
               (t
                (let* ((imports (cadr tform-imports-entry))
                       (w1 (global-set
                            'known-package-alist
                            (cons (make-package-entry
                                   :name name
                                   :imports imports
                                   :hidden-p hidden-p
                                   :book-path
                                   (append book-path
                                           (global-val
                                            'include-book-path
                                            w))
                                   :defpkg-event-form event-form
                                   :tterm (car tform-imports-entry))
                                  (if (cddr tform-imports-entry)
                                      (remove-package-entry
                                       name
                                       (known-package-alist state))
                                    (global-val 'known-package-alist w)))
                            w))

; Defpkg adds an axiom, labeled ax below.  We make a :REWRITE rule out of ax.
; Warning: If the axiom added by defpkg changes, be sure to consider the
; initial packages that are not defined with defpkg, e.g., "ACL2".  In
; particular, for each primitive package in *initial-known-package-alist* there
; is a defaxiom in axioms.lisp exactly analogous to the add-rule below.  So if
; you change this code, change that code.

                       (w2
                        (cond
                         (hidden-p w1)
                         (t (let ((ax `(equal (pkg-imports (quote ,name))
                                              (quote ,imports))))
                              (add-rules
                               (packn (cons name '("-PACKAGE")))
                               `((:REWRITE :COROLLARY ,ax))
                               ax ax (ens state) w1 state))))))
                  (install-event name
                                 event-form
                                 'defpkg
                                 name
                                 nil
                                 (list 'defpkg name form)
                                 :protect ctx w2 state))))))))

; We now start the development of deftheory and theory expressions.

; First, please read the Essay on Enabling, Enabled Structures, and
; Theories for a refresher course on such things as runes, common
; theories, and runic theories.  Roughly speaking, theory expressions
; are terms that produce common theories as their results.  Recall
; that a common theory is a truelist of rule name designators.  A rule
; name designator is an object standing for a set of runes; examples
; include APP, which might stand for {(:DEFINITION app)}, (APP), which
; might stand for {(:EXECUTABLE-COUNTERPART app)}, and LEMMA1, which
; might stand for the set of runes {(REWRITE lemma1 . 1) (REWRITE
; lemma1 . 2) (ELIM lemma1)}.  Of course, a rune is a rule name designator
; and stands for the obvious: the singleton set containing that rune.

; To every common theory there corresponds a runic theory, obtained
; from the common theory by unioning together the designated sets of
; runes and then ordering the result by nume.  Runic theories are
; easier to manipulate (e.g., union together) because they are
; ordered.

; To define deftheory we need not define any any "theory manipulation
; functions" (e.g., union-theories, or universal-theory) because
; deftheory just does a full-blown eval of whatever expression the
; user provides.  We could therefore define deftheory now.  But there
; are a lot of useful theory manipulation functions and they are
; generally used only in deftheory and in-theory, so we define them
; now.

; Calls of these functions will be typed by the user in theory
; expressions.  Those expressions will be executed to obtain new
; theories.  Furthermore, the user may well define his own theory
; producing functions which will be mixed in with ours in his
; expressions.  How do we know a "theory expression" will produce a
; theory?  We don't.  We just evaluate it and check the result.  But
; this raises a more serious question: how do we know our theory
; manipulation functions are given theories as their arguments?
; Indeed, they may not be given theories because of misspellings, bugs
; in the user's functions, etc.  Because of the presence of
; user-defined functions in theory expressions we can't syntactically
; check that an expression is ok.  And at the moment we don't see that
; it is worth the trouble of making the user prove "theory theorems"
; such as (THEORYP A W) -> (THEORYP (MY-FN A) W) that would let us so
; analyze his expressions.

; So we have decided to put run-time checks into our theory functions.
; We have two methods available to us: we could put guards on them or
; we could put checks into them.  The latter course does not permit us
; to abort on undesired arguments -- because we don't want theory
; functions to take STATE and be multi-valued.  Thus, once past the
; guards all we can do is coerce unwanted args into acceptable ones.

; There are several sources of tension.  It was such tensions that
; led to the idea of "common" v. "runic" theories and, one level deeper,
; "rule name designators" v. runes.

; (1) When our theory functions are getting input directly from the
;     user we wish they did a thorough job of checking it and were
;     forgiving about such things as order, e.g., sorted otherwise ok
;     lists, so that the user didn't need to worry about order.

; (2) When our theory functions are getting input produced by one of
;     our functions, we wish they didn't check anything so they could
;     just fly.

; (3) These functions have to be admissible under the definitional principle
;     and not cause errors when called on the utter garbage that the user
;     might type.

; (4) Checking the well-formedness of a theory value requires access to
;     wrld.

; We have therefore chosen the following strategy.

; First, all theory manipulation functions take wrld as an argument.
; Some need it, e.g., the function that returns all the available rule
; names.  Others wouldn't need it if we made certain choices on the
; handling of run-time checks.  We've chosen to be uniform: all have
; it.  This uniformity saves the user from having to remember which
; functions do and which don't.

; Second, all theory functions have guards that check that their
; "theory" arguments "common theories."  This means that if a theory
; function is called on utter garbage the user will get an error
; message.  But it means we'll pay the price of scanning each theory
; value on each function entry in his expression to check
; rule-name-designatorp.

; To compute on theories we will convert common theories to runic ones
; (actually, all the way to augmented runic theories) and we will
; always return runic theories because they can be verified faster.
; This causes a second scan every time but in general will not go into
; sorting because our intermediate results will always be ordered.
; This gives us "user-friendliness" for top-level calls of the theory
; functions without (too much?)  overhead.

; Now we define union, intersect, and set-difference for lists of rule
; names.

(defun theory-fn-callp (x)

; We return t or nil.  If t, and the evaluation of x does not cause an error,
; then the result is a runic-theoryp.  Here x is an untranslated term; see also
; theory-fn-translated-callp for translated terms x.  It would be sound to
; return non-nil here if theory-fn-translated-callp returns non-nil, but that
; doesn't seem useful for user-level terms (though we may want to reconsider).

  (and (consp x)
       (member-eq (car x)
                  '(current-theory
                    disable
                    e/d
                    enable
                    executable-counterpart-theory
                    function-theory
                    intersection-theories
                    set-difference-theories
                    theory
                    union-theories
                    universal-theory))
       t))

(defun intersection-augmented-theories-fn1 (lst1 lst2 ans)

; Let lst1 and lst2 be augmented theories: descendingly ordered lists
; of pairs mapping numes to runes.  We return the intersection of the
; two theories -- as a runic theory, not as an augmented runic theory.
; That is, we strip off the numes as we go.  This is unesthetic: it
; would be more symmetric to produce an augmented theory since we take
; in augmented theories.  But this is more efficient because we don't
; have to copy the result later to strip off the numes.

  (cond
   ((null lst1) (revappend ans nil))
   ((null lst2) (revappend ans nil))
   ((= (car (car lst1)) (car (car lst2)))
    (intersection-augmented-theories-fn1 (cdr lst1) (cdr lst2)
                                         (cons (cdr (car lst1)) ans)))
   ((> (car (car lst1)) (car (car lst2)))
    (intersection-augmented-theories-fn1 (cdr lst1) lst2 ans))
   (t (intersection-augmented-theories-fn1 lst1 (cdr lst2) ans))))

(defun check-theory-msg1 (lst macro-aliases wrld bad macros theorems)

; For background see check-theory-msg.  Parameters bad, macros, and theorems
; are accumulators.  Bad contains members of lst that do not satisfy n
; rule-name-designatorp.  Macros and theorems are the subsets of bad consisting
; of symbols that name a macro or a theorem, respectively.

  (cond ((endp lst)
         (mv (reverse bad) (reverse macros) (reverse theorems)))
        (t
         (let ((sym (rule-name-designatorp (car lst) macro-aliases wrld)))
           (cond
            (sym (check-theory-msg1 (cdr lst) macro-aliases wrld bad macros
                                    theorems))

; Otherwise we add (car lst) to bad.  But we might also add (car lst) to one or
; more of the other accumulators.

            ((not (symbolp (car lst)))
             (check-theory-msg1 (cdr lst) macro-aliases wrld
                                (cons (car lst) bad)
                                macros theorems))
            (t (let ((name (car lst)))
                 (mv-let (macros theorems)
                   (cond ((and (not (eq (getpropc name 'macro-args t wrld)
                                        t))

; Do not use the function macro-args above, as it can cause a hard error!  But
; checking for a macro isn't enough -- we don't want to report that this is a
; macro for which add-macro-alias if actually, the macro already aliases a
; function but that function can't be disabled (e.g., because it's
; constrained).

                               (eq (deref-macro-name name macro-aliases)
                                   name))
                          (mv (cons name macros)
                              theorems))
                         ((or (body name nil wrld)
                              (getpropc name 'theorem nil wrld)
                              (getpropc name 'defchoose-axiom nil
                                        wrld))
                          (mv macros
                              (cons name theorems)))
                         (t (mv macros theorems)))
                   (check-theory-msg1 (cdr lst) macro-aliases wrld
                                      (cons name bad)
                                      macros theorems)))))))))

(defun check-theory-msg (lst wrld)

; This variant of theoryp1 returns (mv flg msg), where flg is true iff lst does
; not represent a list of runes and msg is to be printed (as an error if flg is
; true, else as a warning).

  (cond
   ((true-listp lst)
    (mv-let (bad macros theorems)
      (check-theory-msg1 lst (macro-aliases wrld) wrld nil nil nil)
      (cond (bad (msg
                  "A theory function has been called on a list that contains ~
                   ~&0, which ~#0~[does~/do~] not designate a rule or a ~
                   non-empty list of rules.  ~@1See :DOC theories."
                  bad
                  (cond ((or macros theorems)
                         (msg "Note that ~@0~@1~@2.  "
                              (cond
                               (macros
                                (msg "~&0 ~#0~[is a macro~/are macros~]; see ~
                                      :DOC add-macro-alias to associate a ~
                                      macro with a function"
                                     macros))
                               (t ""))
                              (cond ((and macros theorems)
                                     ".  Also note that ")
                                    (t ""))
                              (cond (theorems
                                     (msg "~&0 ~#0~[names a theorem~/name ~
                                           theorems~] but not any rules"
                                          theorems))
                                    (t ""))))
                        (t ""))))
            (t nil))))
   (t (msg
       "A theory function has been called on the following argument that does ~
        not represent a theory because it is not a true-list:~|~Y01.~|"
       lst
       (evisc-tuple 5 7 nil nil)))))

(defun check-theory-action (lst wrld ctx)

; A theory expression must evaluate to a common theory, i.e., a truelist of
; rule name designators.  A rule name designator, recall, is something we can
; interpret as a set of runes and includes runes themselves and the base
; symbols of runes, such as APP and ASSOC-OF-APP.  We already have a predicate
; for this concept: theoryp.  This checker checks for theoryp but with better
; error reporting.  It returns t if there is an error, else nil.

  (let ((msg (check-theory-msg lst wrld)))
    (cond (msg (prog2$ (er hard ctx "~@0" msg)
                       t))
          (t nil))))

(defmacro check-theory (lst wrld ctx form)
  `(if (check-theory-action ,lst ,wrld ,ctx)
       nil
     ,form))

(defmacro maybe-check-theory (skip-check lst wrld ctx form)
  `(if ,skip-check
       ,form
     (check-theory ,lst ,wrld ,ctx ,form)))

(defun intersection-theories-fn (lst1 lst2
                                      lst1-known-to-be-runic
                                      lst2-known-to-be-runic
                                      wrld)
  (maybe-check-theory
   lst1-known-to-be-runic
   lst1 wrld 'intersection-theories-fn
   (maybe-check-theory
    lst2-known-to-be-runic
    lst2 wrld 'intersection-theories-fn
    (intersection-augmented-theories-fn1 (augment-theory lst1 wrld)
                                         (augment-theory lst2 wrld)
                                         nil))))

(defmacro intersection-theories (lst1 lst2)

; Warning: The resulting value must be a runic-theoryp.  See theory-fn-callp.

  (list 'intersection-theories-fn
        lst1
        lst2
        (theory-fn-callp lst1)
        (theory-fn-callp lst2)
        'world))

(defun union-augmented-theories-fn1 (lst1 lst2 ans)

; Warning: Keep this in sync with union-augmented-theories-fn1+.

; Let lst1 and lst2 be augmented theories: descendingly ordered lists
; of pairs mapping numes to runes.  We return their union as an
; unaugmented runic theory.  See intersection-augmented-theories-fn1.

  (cond ((null lst1) (revappend ans (strip-cdrs lst2)))
        ((null lst2) (revappend ans (strip-cdrs lst1)))
        ((int= (car (car lst1)) (car (car lst2)))
         (union-augmented-theories-fn1 (cdr lst1) (cdr lst2)
                                       (cons (cdr (car lst1)) ans)))
        ((> (car (car lst1)) (car (car lst2)))
         (union-augmented-theories-fn1 (cdr lst1) lst2
                                       (cons (cdr (car lst1)) ans)))
        (t (union-augmented-theories-fn1 lst1 (cdr lst2)
                                         (cons (cdr (car lst2)) ans)))))

(defun union-theories-fn1 (lst1 lst2 nume wrld ans)

; Lst2 is an augmented runic theory: descendingly ordered list of pairs mapping
; numes to runes.  Lst1 is an unaugmented runic theory, which may be thought of
; as the strip-cdrs of an augmented runic theory.  Nume is either nil or else
; is the nume of the first element of lst1.  We accumulate into ans and
; ultimately return the result of adding all runes in lst2 to lst1, as an
; unaugmented runic theory.

  (cond ((null lst1) (revappend ans (strip-cdrs lst2)))
        ((null lst2) (revappend ans lst1))
        (t (let ((nume (or nume (runep (car lst1) wrld))))
             (assert$
              nume
              (cond
               ((int= nume (car (car lst2)))
                (union-theories-fn1
                 (cdr lst1) (cdr lst2) nil wrld (cons (car lst1) ans)))
               ((> nume (car (car lst2)))
                (union-theories-fn1
                 (cdr lst1) lst2 nil wrld (cons (car lst1) ans)))
               (t (union-theories-fn1
                   lst1 (cdr lst2) nume wrld (cons (cdar lst2) ans)))))))))

(defun union-theories-fn (lst1 lst2 lst1-known-to-be-runic wrld)

; We make some effort to share structure with lst1 if it is a runic theory,
; else with lst2 if it is a runic theory.  Argument lst1-known-to-be-runic is
; an optimization: if it is true, then lst1 is known to be a runic theory, so
; we can skip its runic-theoryp check.  If furthermore lst1-known-to-be-runic
; is 'both then lst2 is also known to be a runic theory and we can skip its
; check, too.

  (cond
   ((or lst1-known-to-be-runic
        (runic-theoryp lst1 wrld))
    (maybe-check-theory (eq lst1-known-to-be-runic 'both)
                        lst2 wrld 'union-theories-fn
                        (union-theories-fn1 lst1
                                            (augment-theory lst2 wrld)
                                            nil
                                            wrld
                                            nil)))
   ((runic-theoryp lst2 wrld)
    (check-theory lst1 wrld 'union-theories-fn
                  (union-theories-fn1 lst2
                                      (augment-theory lst1 wrld)
                                      nil
                                      wrld
                                      nil)))
   (t
    (check-theory
     lst1 wrld 'union-theories-fn
     (check-theory
      lst2 wrld 'union-theories-fn
      (union-augmented-theories-fn1

; We know that lst1 is not a runic-theoryp, so we open-code for a call of
; augment-theory, which should be kept in sync with the code below.

       (duplicitous-sort-car
        nil
        (convert-theory-to-unordered-mapping-pairs lst1 wrld))
       (augment-theory lst2 wrld)
       nil))))))

(defun union-augmented-theories-fn1+ (lst1 c1 lst2 ans)

; Warning: Keep this in sync with union-augmented-theories-fn1.
; This function returns (union-augmented-theories-fn1 lst1 lst2 ans)
; when c1 is (strip-cdrs lst1).

  (cond ((null lst1) (revappend ans (strip-cdrs lst2)))
        ((null lst2) (revappend ans c1))
        ((int= (car (car lst1)) (car (car lst2)))
         (union-augmented-theories-fn1+ (cdr lst1) (cdr c1) (cdr lst2)
                                        (cons (car c1) ans)))
        ((> (car (car lst1)) (car (car lst2)))
         (union-augmented-theories-fn1+ (cdr lst1) (cdr c1) lst2
                                        (cons (car c1) ans)))
        (t (union-augmented-theories-fn1+ lst1 c1 (cdr lst2)
                                          (cons (cdr (car lst2)) ans)))))

(defun set-difference-augmented-theories-fn1 (lst1 lst2 ans)

; Warning: Keep this in sync with set-difference-augmented-theories-fn1+.

; Let lst1 and lst2 be augmented theories: descendingly ordered lists
; of pairs mapping numes to runes.  We return their set-difference as
; an unaugmented runic theory.  See intersection-augmented-theories-fn1.

  (cond ((null lst1) (revappend ans nil))
        ((null lst2) (revappend ans (strip-cdrs lst1)))
        ((= (car (car lst1)) (car (car lst2)))
         (set-difference-augmented-theories-fn1 (cdr lst1) (cdr lst2) ans))
        ((> (car (car lst1)) (car (car lst2)))
         (set-difference-augmented-theories-fn1
          (cdr lst1) lst2 (cons (cdr (car lst1)) ans)))
        (t (set-difference-augmented-theories-fn1 lst1 (cdr lst2) ans))))

(defun set-difference-augmented-theories-fn1+ (lst1 c1 lst2 ans)

; Warning: Keep this in sync with set-difference-augmented-theories-fn1.
; This function returns (set-difference-augmented-theories-fn1 lst1 lst2 ans)
; when c1 is (strip-cdrs lst1).

  (cond ((null lst1) (revappend ans nil))
        ((null lst2) (revappend ans c1))
        ((= (car (car lst1)) (car (car lst2)))
         (set-difference-augmented-theories-fn1+
          (cdr lst1) (cdr c1) (cdr lst2) ans))
        ((> (car (car lst1)) (car (car lst2)))
         (set-difference-augmented-theories-fn1+
          (cdr lst1) (cdr c1) lst2 (cons (car c1) ans)))
        (t (set-difference-augmented-theories-fn1+
            lst1 c1 (cdr lst2) ans))))

(defun set-difference-theories-fn1 (lst1 lst2 nume wrld ans)

; Lst2 is an augmented runic theory: descendingly ordered list of pairs mapping
; numes to runes.  Lst1 is an unaugmented runic theory, which may be thought of
; as the strip-cdrs of an augmented runic theory.  Nume is either nil or else
; is the nume of the first element of lst1.  We accumulate into ans and
; ultimately return the result of removing all runes in lst2 from lst1, as an
; unaugmented runic theory.

  (cond ((null lst1) (reverse ans))
        ((null lst2) (revappend ans lst1))
        (t (let ((nume (or nume (runep (car lst1) wrld))))
             (assert$
              nume
              (cond
               ((int= nume (car (car lst2)))
                (set-difference-theories-fn1
                 (cdr lst1) (cdr lst2) nil wrld ans))
               ((> nume (car (car lst2)))
                (set-difference-theories-fn1
                 (cdr lst1) lst2 nil wrld (cons (car lst1) ans)))
               (t (set-difference-theories-fn1
                   lst1 (cdr lst2) nume wrld ans))))))))

(defun set-difference-theories-fn (lst1 lst2
                                        lst1-known-to-be-runic
                                        lst2-known-to-be-runic
                                        wrld)

; We make some effort to share structure with lst1 if it is a runic theory.
; Argument lst1-known-to-be-runic is an optimization: if it is true, then lst1
; is known to be a runic theory, so we can skip the runic-theoryp check.

  (cond
   ((or lst1-known-to-be-runic
        (runic-theoryp lst1 wrld))
    (maybe-check-theory
     lst2-known-to-be-runic
     lst2 wrld 'set-difference-theories-fn
     (set-difference-theories-fn1 lst1
                                  (augment-theory lst2 wrld)
                                  nil
                                  wrld
                                  nil)))
   (t
    (check-theory
     lst1 wrld 'set-difference-theories-fn
     (maybe-check-theory
      lst2-known-to-be-runic
      lst2 wrld 'set-difference-theories-fn
      (set-difference-augmented-theories-fn1

; We know that lst1 is not a runic-theoryp, so we open-code for a call of
; augment-theory, which should be kept in sync with the code below.

       (duplicitous-sort-car
        nil
        (convert-theory-to-unordered-mapping-pairs lst1 wrld))
       (augment-theory lst2 wrld)
       nil))))))

(defun no-augmented-rune-based-on (pairs symbols)

; This function is analogous to no-rune-based-on but where members of the first
; argument are not runes, but rather, are each of the form (nume . rune).

  (cond ((null pairs) t)
        ((member-eq (base-symbol (cdar pairs)) symbols)
         nil)
        (t (no-augmented-rune-based-on (cdr pairs) symbols))))

(defun revappend-delete-augmented-runes-based-on-symbols1 (pairs symbols ans)

; This function is analogous to revappend-delete-runes-based-on-symbols1, but
; where members of the first argument are not runes, but rather, are each of
; the form (nume . rune).

  (cond ((null pairs) ans)
        ((member-eq (base-symbol (cdr (car pairs))) symbols)
         (revappend-delete-augmented-runes-based-on-symbols1
          (cdr pairs) symbols ans))
        (t (revappend-delete-augmented-runes-based-on-symbols1
            (cdr pairs) symbols (cons (car pairs) ans)))))

(defun revappend-delete-augmented-runes-based-on-symbols (pairs symbols ans)

; This function is analogous to revappend-delete-runes-based-on-symbols, but
; where members of the first argument are not runes, but rather, are each of
; the form (nume . rune).

  (cond ((or (null symbols) (no-augmented-rune-based-on pairs symbols))
         (revappend ans pairs))
        (t (reverse (revappend-delete-augmented-runes-based-on-symbols1
                     pairs symbols ans)))))

(defun current-theory-fn1 (wrld1 wrld)

; See current-theory-fn.  Here, wrld is a given logical world for which we are
; evaluating (current-theory name), where wrld1 is a tail of wrld ending with
; an event-tuple.  This part of the current-theory code is factored out so that
; tools can do their own computation of wrld1 rather than only computing it as
; the current-theory as of some logical name.  We might do the same for other
; functions, e.g., universal-theory-fn.

; See universal-theory-fn for an explanation of the production of wrld2.

  (let* ((redefined (collect-redefined wrld nil))
         (wrld2 (putprop-x-lst1 redefined 'runic-mapping-pairs
                                *acl2-property-unbound* wrld1)))
    (assert$-runic-theoryp (current-theory1 wrld2 nil nil)
                           wrld)))

(defun current-theory-fn (logical-name wrld)

; Warning: Keep this in sync with union-current-theory-fn and
; set-difference-current-theory-fn.

; We return the theory that was enabled in the world created by the
; event that introduced logical-name.

  (let ((wrld1 (decode-logical-name logical-name wrld)))
    (prog2$
     (or wrld1
         (er hard 'current-theory
             "The name ~x0 was not found in the current ACL2 logical ~
              world; hence no current-theory can be computed for that name."
             logical-name))
     (current-theory-fn1 wrld1 wrld))))

(defun current-theory1-augmented (lst ans redefined)

; Warning: Keep this in sync with current-theory1.

; Lst is a tail of a world.  This function returns the augmented runic theory
; current in the world, lst.  Its definition is analogous to that of
; current-theory1.

  (cond ((null lst)
         #+acl2-metering (meter-maid 'current-theory1-augmented 500)
         (reverse ans)) ; unexpected, but correct
        ((eq (cadr (car lst)) 'runic-mapping-pairs)
         #+acl2-metering (setq meter-maid-cnt (1+ meter-maid-cnt))
         (cond
          ((eq (cddr (car lst)) *acl2-property-unbound*)
           (current-theory1-augmented (cdr lst) ans
                                      (add-to-set-eq (car (car lst))
                                                     redefined)))
          ((member-eq (car (car lst)) redefined)
           (current-theory1-augmented (cdr lst) ans redefined))
          (t
           (current-theory1-augmented (cdr lst)
                                      (append (cddr (car lst)) ans)
                                      redefined))))
        ((and (eq (car (car lst)) 'current-theory-augmented)
              (eq (cadr (car lst)) 'global-value))

; We append the reverse of our accumulated ans to the appropriate standard
; theory, but deleting all the redefined runes.

         #+acl2-metering (meter-maid 'current-theory1-augmented 500)
         (revappend-delete-augmented-runes-based-on-symbols (cddr (car lst))
                                                            redefined ans))
        (t
         #+acl2-metering (setq meter-maid-cnt (1+ meter-maid-cnt))
         (current-theory1-augmented (cdr lst) ans redefined))))

(defun union-current-theory-fn (lst2 lst2-known-to-be-runic wrld)

; Warning: Keep this in sync with current-theory-fn and
; set-difference-current-theory-fn.

; This function returns, with an optimized computation, the value
; (union-theories-fn (current-theory :here) lst2 t wrld).

  (maybe-check-theory
   lst2-known-to-be-runic
   lst2 wrld 'union-current-theory-fn
   (let* ((wrld1 ; as in current-theory-fn, we apply decode-logical-name
           (scan-to-event wrld))
          (redefined (collect-redefined wrld nil))
          (wrld2 (putprop-x-lst1 redefined 'runic-mapping-pairs
                                 *acl2-property-unbound* wrld1)))
     (union-augmented-theories-fn1+
      (current-theory1-augmented wrld2 nil nil)
      (current-theory1 wrld2 nil nil)
      (augment-theory lst2 wrld)
      nil))))

(defmacro union-theories (lst1 lst2)

; Warning: The resulting value must be a runic-theoryp.  See theory-fn-callp.

  (cond ((equal lst1 '(current-theory :here)) ; optimization
         (list 'union-current-theory-fn
               lst2
               (theory-fn-callp lst2)
               'world))
        ((equal lst2 '(current-theory :here)) ; optimization
         (list 'union-current-theory-fn
               lst1
               (theory-fn-callp lst1)
               'world))
        ((theory-fn-callp lst1)
         (list 'union-theories-fn
               lst1
               lst2
               (if (theory-fn-callp lst2)
                   ''both
                 t)
               'world))
        ((theory-fn-callp lst2)
         (list 'union-theories-fn
               lst2
               lst1
               t
               'world))
        (t
         (list 'union-theories-fn
               lst1
               lst2
               nil
               'world))))

(defun set-difference-current-theory-fn (lst2 lst2-known-to-be-runic wrld)

; Warning: Keep this in sync with current-theory-fn and
; union-current-theory-fn.

; This function returns, with an optimized computation, the value
; (set-difference-theories-fn (current-theory :here)
;                             lst2
;                             t ; (theory-fn-callp '(current-theory :here))
;                             wrld).

  (maybe-check-theory
   lst2-known-to-be-runic
   lst2 wrld 'set-difference-current-theory-fn
   (let* ((wrld1 ; as in current-theory-fn, we apply decode-logical-name
           (scan-to-event wrld))
          (redefined (collect-redefined wrld nil))
          (wrld2 (putprop-x-lst1 redefined 'runic-mapping-pairs
                                 *acl2-property-unbound* wrld1)))
     (set-difference-augmented-theories-fn1+
      (current-theory1-augmented wrld2 nil nil)
      (current-theory1 wrld2 nil nil)
      (augment-theory lst2 wrld)
      nil))))

(defmacro set-difference-theories (lst1 lst2)

; Warning: The resulting value must be a runic-theoryp.  See theory-fn-callp.

  (cond ((equal lst1 '(current-theory :here)) ; optimization
         (list 'set-difference-current-theory-fn
               lst2
               (theory-fn-callp lst2)
               'world))
        (t (list 'set-difference-theories-fn
                 lst1
                 lst2
                 (theory-fn-callp lst1)
                 (theory-fn-callp lst2)
                 'world))))

; Now we define a few useful theories.

(defun universal-theory-fn1 (lst ans redefined)

; Lst is a cdr of the current world.  We scan down lst accumulating onto ans
; every rune in every 'runic-mapping-pairs property.  Our final ans is
; descendingly ordered.  We take advantage of the fact that the world is
; ordered reverse-chronologically, so the runes in the first
; 'runic-mapping-pairs we see will have the highest numes.

; If at any point we encounter the 'global-value for the variable
; 'standard-theories then we assume the value is of the form (r-unv r-fn1 r-fn2
; r-fn3), where r-unv is the reversed universal theory as of that world, r-fn1
; is the reversed function symbol theory, r-fn2 is the reversed executable
; counterpart theory, and r-fn3 is the reversed function theory.  If we find
; such a binding we stop and revappend r-unv to our answer and quit.  By this
; hack we permit the precomputation of a big theory and save having to scan
; down world -- which really means save having to swap world into memory.

; At the end of the bootstrap we will save the standard theories just to
; prevent the swapping in of prehistoric conses.

; Note: :REDEF complicates matters.  If a name is redefined the runes based on
; its old definition are invalid.  We can tell that sym has been redefined when
; we encounter on lst a triple of the form (sym RUNIC-MAPPING-PAIRS
; . :ACL2-PROPERTY-UNBOUND).  This means that all runes based on sym
; encountered subsequently must be ignored or deleted (ignored when encountered
; as RUNIC-MAPPING-PAIRS and deleted when seen in the stored standard theories.
; The list redefined contains all such syms encountered.

  (cond ((null lst)
         #+acl2-metering (meter-maid 'universal-theory-fn1 500)
         (reverse ans)) ; unexpected, but correct
        ((eq (cadr (car lst)) 'runic-mapping-pairs)
         #+acl2-metering (setq meter-maid-cnt (1+ meter-maid-cnt))
         (cond
          ((eq (cddr (car lst)) *acl2-property-unbound*)
           (universal-theory-fn1 (cdr lst) ans
                                 (add-to-set-eq (car (car lst)) redefined)))
          ((member-eq (car (car lst)) redefined)
           (universal-theory-fn1 (cdr lst) ans redefined))
          (t (universal-theory-fn1 (cdr lst)
                                   (append-strip-cdrs (cddr (car lst)) ans)
                                   redefined))))
        ((and (eq (car (car lst)) 'standard-theories)
              (eq (cadr (car lst)) 'global-value))
         #+acl2-metering (meter-maid 'universal-theory-fn1 500)
         (revappend-delete-runes-based-on-symbols (car (cddr (car lst)))
                                                  redefined
                                                  ans))
        (t
         #+acl2-metering (setq meter-maid-cnt (1+ meter-maid-cnt))
         (universal-theory-fn1 (cdr lst) ans redefined))))

(defun universal-theory-fn (logical-name wrld)

; Return the theory containing all of the rule names in the world created
; by the event that introduced logical-name.

  (declare (xargs :guard (logical-namep logical-name wrld)))

; It is possible that wrld starts with a triple of the form (name REDEFINED
; . mode) in which case that triple is followed by an arbitrary number of
; triples "renewing" various properties of name.  Among those properties is,
; necessarily, RUNIC-MAPPING-PAIRS.  This situation only arises if we are
; evaluating a theory expression as part of an event that is in fact redefining
; name.  These "mid-event" worlds are odd precisely because they do not start
; on event boundaries (with appropriate interpretation given to the occasional
; saving of worlds and theories).

; Now we are asked to get a theory as of logical-name and hence must decode
; logical name wrt wrld, obtaining some tail of wrld, wrld1.  If we are in the
; act of redefining name then we add to wrld1 the triple unbinding
; RUNIC-MAPPING-PAIRS of name.  Why not add all the renewing triples?  The
; reason is that this is the only renewed property that is relevant to
; universal-theory1, the workhorse here.


  (let* ((wrld1 (decode-logical-name logical-name wrld))
         (redefined (collect-redefined wrld nil))
         (wrld2 (putprop-x-lst1 redefined 'runic-mapping-pairs
                                *acl2-property-unbound* wrld1)))
    (assert$-runic-theoryp (universal-theory-fn1 wrld2 nil nil)
                           wrld)))

(defmacro universal-theory (logical-name)

; Warning: The resulting value must be a runic-theoryp.  See theory-fn-callp.

  (list 'universal-theory-fn
        logical-name
        'world))

(defun function-theory-fn1 (token lst ans redefined)

; Token is either :DEFINITION, :EXECUTABLE-COUNTERPART or something
; else.  Lst is a cdr of the current world.  We scan down lst and
; accumulate onto ans all of the runes of the indicated type (or both
; if token is neither of the above).

; As in universal-theory-fn1, we also look out for the 'global-value of
; 'standard-theories and for *acl2-property-unbound*.  See the comment there.

  (cond ((null lst)
         #+acl2-metering (meter-maid 'function-theory-fn1 500)
         (reverse ans)) ; unexpected, but correct
        ((eq (cadr (car lst)) 'runic-mapping-pairs)
         #+acl2-metering (setq meter-maid-cnt (1+ meter-maid-cnt))
         (cond
          ((eq (cddr (car lst)) *acl2-property-unbound*)
           (function-theory-fn1 token (cdr lst) ans
                                (add-to-set-eq (car (car lst)) redefined)))
          ((member-eq (car (car lst)) redefined)
           (function-theory-fn1 token (cdr lst) ans redefined))
          ((eq (car (cdr (car (cddr (car lst))))) :DEFINITION)

; The test above extracts the token of the first rune in the mapping pairs and
; this is a function symbol iff it is :DEFINITION.

           (function-theory-fn1
            token
            (cdr lst)
            (cond ((eq token :DEFINITION)
                   (cons (cdr (car (cddr (car lst)))) ans))
                  (t (let ((rune-exec (cdr (cadr (cddr (car lst))))))
                       (case token
                         (:EXECUTABLE-COUNTERPART

; Note that we might be looking at the result of storing a :definition rule, in
; which case there will be no :executable-counterpart rune.  So, we check that
; we have something before accumulating it.

                          (if (null rune-exec)
                              ans
                            (cons rune-exec ans)))
                         (otherwise ; :BOTH
                          (cons (cdr (car (cddr (car lst))))
                                (if (null rune-exec)
                                    ans
                                  (cons rune-exec ans))))))))
            redefined))
          (t (function-theory-fn1 token (cdr lst) ans redefined))))
        ((and (eq (car (car lst)) 'standard-theories)
              (eq (cadr (car lst)) 'global-value))
         #+acl2-metering (meter-maid 'function-theory-fn1 500)
         (revappend-delete-runes-based-on-symbols
          (case token
                (:DEFINITION (cadr (cddr (car lst))))
                (:EXECUTABLE-COUNTERPART (caddr (cddr (car lst))))
                (otherwise (cadddr (cddr (car lst)))))
          redefined
          ans))
        (t
         #+acl2-metering (setq meter-maid-cnt (1+ meter-maid-cnt))
         (function-theory-fn1 token (cdr lst) ans redefined))))

(defun function-theory-fn (logical-name wrld)

; Return the theory containing all of the function names in the world
; created by the user event that introduced logical-name.

  (declare (xargs :guard (logical-namep logical-name wrld)))

; See universal-theory-fn for an explanation of the production of wrld2.

  (let* ((wrld1 (decode-logical-name logical-name wrld))
         (redefined (collect-redefined wrld nil))
         (wrld2 (putprop-x-lst1 redefined 'runic-mapping-pairs
                                *acl2-property-unbound* wrld1)))
    (assert$-runic-theoryp (function-theory-fn1 :DEFINITION wrld2 nil nil)
                           wrld)))

(defmacro function-theory (logical-name)

; Warning: The resulting value must be a runic-theoryp.  See theory-fn-callp.

  (list 'function-theory-fn
        logical-name
        'world))

(defun executable-counterpart-theory-fn (logical-name wrld)

; Return the theory containing all of the executable-counterpart names
; in the world created by the event that introduced logical-name.

  (declare (xargs :guard (logical-namep logical-name wrld)))

; See universal-theory-fn for an explanation of the production of wrld2.

  (let* ((wrld1 (decode-logical-name logical-name wrld))
         (redefined (collect-redefined wrld nil))
         (wrld2 (putprop-x-lst1 redefined 'runic-mapping-pairs
                                *acl2-property-unbound* wrld1)))
    (function-theory-fn1 :executable-counterpart wrld2 nil nil)))

(defmacro executable-counterpart-theory (logical-name)

; Warning: The resulting value must be a runic-theoryp.  See theory-fn-callp.

  (list 'executable-counterpart-theory-fn
        logical-name
        'world))

; Having defined the functions for computing the standard theories,
; we'll now define the function for precomputing them.

(defun standard-theories (wrld)
  (list (universal-theory-fn1 wrld nil nil)
        (function-theory-fn1 :definition wrld nil nil)
        (function-theory-fn1 :executable-counterpart wrld nil nil)
        (function-theory-fn1 :both wrld nil nil)))

(defmacro current-theory (logical-name)

; Warning: The resulting value must be a runic-theoryp.  See theory-fn-callp.

  (list 'current-theory-fn logical-name
        'world))

; Essay on Theory Manipulation Performance

; Below we show some statistics on our theory manipulation functions.
; These are recorded in case we someday change these functions and
; wish to compare the old and new implementations.  The expressions
; shown should be executed in raw lisp, not LP, because they involve
; the time function.  These expressions were executed in a newly
; initialized ACL2.  The times are on a Sparc 2 (Rana).

; The following expression is intended as a "typical" heavy duty
; theory expression.  For the record, the universal theory at the time
; of these tests contained 1307 runes.

; (let ((world (w *the-live-state*)))
;   (time
;    (length
;     (union-theories
;      (intersection-theories (current-theory :here)
;                             (executable-counterpart-theory :here))
;      (set-difference-theories (universal-theory :here)
;                               (function-theory :here))))))

; Repeated runs were done.  Typical results were:
;   real time : 0.350 secs
;   run time  : 0.233 secs
;   993

; The use of :here above meant that all the theory functions involved
; just looked up their answers in the 'standard-theories at
; the front of the initialized world.  The following expression forces
; the exploration of the whole world.  In the test, "ACL2-USER" was
; the event printed by :pc -1, i.e., the last event before ending the
; boot.

; (let ((world (w *the-live-state*)))
;   (time
;    (length
;     (union-theories
;      (intersection-theories (current-theory "ACL2-USER")
;                             (executable-counterpart-theory "ACL2-USER"))
;      (set-difference-theories (universal-theory "ACL2-USER")
;                               (function-theory "ACL2-USER"))))))

; Repeated tests produced the following typical results.
;   real time : 0.483 secs
;   run time  : 0.383 secs
;   993
; The first run, however, had a real time of almost 10 seconds because
; wrld had to be paged in.

; The final test stresses sorting.  We return to the :here usage to
; get our theories, but we reverse the output every chance we get so
; as force the next theory function to sort.  In addition, we
; strip-cadrs all the input runic theories to force the reconstruction
; of runic theories from the wrld.

; (let ((world (w *the-live-state*)))
;   (time
;    (length
;     (union-theories
;      (reverse
;       (intersection-theories
;         (reverse (strip-base-symbols (current-theory :here)))
;         (reverse (strip-base-symbols (executable-counterpart-theory :here)))))
;      (reverse
;       (set-difference-theories
;         (reverse (strip-base-symbols (universal-theory :here)))
;         (reverse (strip-base-symbols (function-theory :here)))))))))

; Typical times were
;   real time : 1.383 secs
;   run time  : 0.667 secs
;   411
; The size of the result is smaller because the strip-cadrs identifies
; several runes, e.g., (:DEFINITION fn) and (:EXECUTABLE-COUNTERPART
; fn) both become fn which is then understood as (:DEFINITION fn).

; End of performance data.

(defun end-prehistoric-world (wrld)
  (let* ((wrld1 (global-set-lst
                 (list (list 'untouchable-fns
                             (append *initial-untouchable-fns*
                                     (global-val 'untouchable-fns wrld)))
                       (list 'untouchable-vars
                             (append *initial-untouchable-vars*
                                     (global-val 'untouchable-vars wrld)))
                       (list 'standard-theories
                             (standard-theories wrld))
                       (list 'boot-strap-flg nil)
                       (list 'boot-strap-pass-2 nil)
                       (list 'command-number-baseline-info
                             (let ((command-number-baseline
                                    (next-absolute-command-number wrld)))
                               (make command-number-baseline-info
                                     :current command-number-baseline
                                     :permanent-p t
                                     :original command-number-baseline)))
                       (list 'event-number-baseline
                             (next-absolute-event-number wrld))
                       (list 'skip-proofs-seen nil)
                       (list 'redef-seen nil)
                       (list 'cert-replay nil)
                       (list 'proof-supporters-alist nil)
                       (list 'attachments-at-ground-zero
                             (all-attachments wrld)))
                 (putprop
                  'acl2-defaults-table
                  'table-alist
                  *initial-acl2-defaults-table*
                  (putprop
                   'return-last-table
                   'table-alist
                   *initial-return-last-table*
                   wrld))))
         (thy (current-theory1 wrld nil nil))
         (wrld2 (update-current-theory thy (length thy) wrld1)))
    (add-command-landmark
     :logic
     '(exit-boot-strap-mode)
     nil ; cbd is only needed for user-generated commands
     nil
     (add-event-landmark
      '(exit-boot-strap-mode)
      'exit-boot-strap-mode
      0
      wrld2
      t
      nil
      nil))))

(defun theory-namep (name wrld)

; We return t or nil according to whether name is the name of a theory,
; i.e., a name introduced by deftheory.

  (and (symbolp name)
       (not (eq (getpropc name 'theory t wrld)
                t))))

(defun theory-fn (name wrld)

; We deliver the value of the defined theory named name.

  (declare (xargs :guard t))
  (cond ((theory-namep name wrld)
         (getpropc name 'theory nil wrld))
        (t (er hard?! 'theory
               "The alleged theory name, ~x0, is not the name of a previously ~
                executed deftheory event.  See :DOC theory."
               name))))

(defmacro theory (name)

; Warning: The resulting value must be a runic-theoryp.  See theory-fn-callp.

  (list 'theory-fn name 'world))

(defun redundant-deftheory-p (name runic-theory wrld)
  (equal (getpropc name 'theory t wrld)
         runic-theory))

(defun deftheory-fn (name expr state redundant-okp ctx event-form)

; Warning: If this event ever generates proof obligations, remove it from the
; list of exceptions in install-event just below its "Comment on irrelevance of
; skip-proofs".

; Historical Note:  Once upon a time deftheory-fn did not exist even
; though deftheory did.  We defined deftheory as a macro which expanded
; into a defconstant-fn expression.  In particular,

; (deftheory *a* (union *b* (universe w)))

; was mapped to

; (er-let* ((lst (translate-in-theory-hint
;                   '(union *b* (universe w))
;                   nil
;                   '(deftheory . *a*)
;                   (w state)
;                   state)))
;          (defconstant-fn '*a*
;            (list 'quote lst)
;            state
;            nil))

; Thus, the "semantics" of a successful execution of deftheory was that of
; defconstant.  This suffered from letting theories creep into formulas.  For
; example, one could later write in a proposed theorem (member 'foo *a*) and
; the truth of that proposition depended upon the particular theory computed
; for *a*.  This made it impossible to permit either the use of state in
; "theory expressions" (since different theories could be computed for
; identical worlds, depending on ld-skip-proofsp) or the use of deftheory in
; encapsulate (see below).  The state prohibition forced upon us the ugliness
; of permitting the user to reference the current ACL2 world via the free
; variable W in theory expressions, which we bound appropriately before evaling
; the expressions.

; We abandoned the use of defconstant (now defconst) for these reasons.

; Here is a comment that once illustrated why we did not allow deftheory
; to be used in encapsulate:

; We do not allow deftheory expressions in encapsulate.  This may be a
; severe restriction but it is necessary for soundness given the current
; implementation of deftheory.  Consider the following:

; (encapsulate nil
;   (local (defun foo () 1))
;   (deftheory *u* (all-names w))
;   (defthm foo-thm (member 'foo *u*)))

; where all-names is a user defined function that computes the set of
; all names in a given world.  [Note: Intuitively, (all-names w) is
; (universal-theory nil w).  Depending on how event descriptors are
; handled, that may or may not be correct.  In a recent version of
; ACL2, (universal-theory nil w), if used in an encapsulate, had the
; effect of computing all the names in the theory as of the last
; world-changing form executed by the top-level loop.  But because
; encapsulate did not so mark each term as it executed them,
; universal-theory backed up to the point in w just before the
; encapsulate.  Thus, universal-theory could not be used to get the
; effect intended here.  However, (all-names w) could be defined by
; the user to get what is intended here.]

; When the above sequence is processed in pass 1 of encapsulate *u*
; includes 'foo and hence the defthm succeeds.  But when it is processed
; in pass 2 *u* does not include 'foo and so the assumption of the
; defthm is unsound!  In essence, permitting deftheory in encapsulate is
; equivalent to permitting (w state) in defconst forms.  That is
; disallowed too (as is the use of any variable in an defconst form).
; If you can set a constant as a function of the world, then you can use
; the constant to determine which encapsulate pass you are in.

  (when-logic
   "DEFTHEORY"
   (with-ctx-summarized
    (cond (ctx)
          (t (cons 'deftheory name)))
    (let ((wrld (w state))
          (event-form (or event-form
                          (list 'deftheory name expr))))
      (er-progn
       (chk-all-but-new-name name ctx nil wrld state)
       (er-let* ((theory0 (translate-in-theory-hint expr nil ctx wrld state)))
         (cond
          ((and redundant-okp
                (redundant-deftheory-p name theory0 wrld))
           (stop-redundant-event ctx state))
          (t
           (er-let* ((wrld1 (chk-just-new-name name nil 'theory nil ctx wrld
                                               state)))
             (let ((length0 (length theory0)))
               (mv-let (theory theory-augmented-ignore)

; The following call is similar to the one in update-current-theory.  But here,
; our aim is just to create an appropriate theory, without extending the
; world.

                 (extend-current-theory
                  (global-val 'current-theory wrld)
                  (global-val 'current-theory-length wrld)
                  theory0
                  length0
                  :none
                  wrld)
                 (declare (ignore theory-augmented-ignore))
                 (let ((wrld2 (putprop name 'theory theory wrld1)))

; Note:  We do not permit DEFTHEORY to be made redundant.  If this
; is changed, change the text of the :doc for redundant-events.

                   (install-event length0
                                  event-form
                                  'deftheory
                                  name
                                  nil
                                  nil
                                  nil ; global theory is unchanged
                                  nil
                                  wrld2 state)))))))))))))

; And now we move on to the in-theory event, in which we process a theory
; expression into a theory and then load it into the global enabled
; structure.

(defun get-in-theory-redundant-okp (state)
  (declare (xargs ; :mode :logic ;
                  :stobjs state
                  :guard
                  (alistp (table-alist 'acl2-defaults-table (w state)))))
  (let ((pair (assoc-eq :in-theory-redundant-okp
                        (table-alist 'acl2-defaults-table (w state)))))
    (cond (pair (cdr pair))
          (t ; default
           nil))))

(defmacro set-in-theory-redundant-okp (val)
  (declare (xargs :guard ; note: table event enforces ttag if val is nil
                  (booleanp val)))
  `(with-output
     :off (event summary)
     (progn (table acl2-defaults-table :in-theory-redundant-okp ,val)
            (table acl2-defaults-table :in-theory-redundant-okp))))

(defun in-theory-fn (expr state event-form)

; Warning: If this event ever generates proof obligations, remove it from the
; list of exceptions in install-event just below its "Comment on irrelevance of
; skip-proofs".

  (when-logic
   "IN-THEORY"
   (with-ctx-summarized
    (cond ((atom expr)
           (msg "( IN-THEORY ~x0)" expr))
          ((symbolp (car expr))
           (msg "( IN-THEORY (~x0 ...))"
                (car expr)))
          (t "( IN-THEORY (...))"))
    (let ((wrld (w state))
          (event-form (or event-form
                          (list 'in-theory expr))))
      (er-let*
       ((theory0 (translate-in-theory-hint expr t ctx wrld state)))
       (cond
        ((and (get-in-theory-redundant-okp state)
              (equal theory0 (current-theory-fn :here wrld)))
         (stop-redundant-event ctx state))
        (t
         (let* ((ens1 (ens state))
                (force-xnume-en1 (enabled-numep *force-xnume* ens1))
                (imm-xnume-en1 (enabled-numep *immediate-force-modep-xnume*
                                              ens1))
                (theory0-length (length theory0))
                (wrld1 (update-current-theory theory0 theory0-length wrld))
                (val (if (f-get-global 'script-mode state)
                         :CURRENT-THEORY-UPDATED
                       (list :NUMBER-OF-ENABLED-RUNES theory0-length))))

; Note:  We do not permit IN-THEORY to be made redundant.  If this
; is changed, change the text of the :doc for redundant-events.

           (er-let*
               ((val ; same as input val, if successful
                 (install-event val
                                event-form
                                'in-theory
                                0
                                nil
                                nil
                                :protect
                                nil
                                wrld1 state)))
             (pprogn (if (member-equal
                          expr
                          '((enable (:EXECUTABLE-COUNTERPART
                                     force))
                            (disable (:EXECUTABLE-COUNTERPART
                                      force))
                            (enable (:EXECUTABLE-COUNTERPART
                                     immediate-force-modep))
                            (disable (:EXECUTABLE-COUNTERPART
                                      immediate-force-modep))))
                         state
                       (maybe-warn-about-theory
                        ens1 force-xnume-en1 imm-xnume-en1
                        (ens state) ctx wrld state))
                     (value val)))))))))))

(defun in-arithmetic-theory-fn (expr state event-form)

; Warning: If this event ever generates proof obligations, remove it from the
; list of exceptions in install-event just below its "Comment on irrelevance of
; skip-proofs".

; After Version_3.0, the following differs from the fancier in-theory-fn.  The
; latter calls update-current-theory to deal with the 'current-theory and
; related properties: 'current-theory-augmented, 'current-theory-length, and
; 'current-theory-index.  Someday we may want to make analogous changes to the
; present function.

  (when-logic
   "IN-ARITHMETIC-THEORY"
   (with-ctx-summarized
    (cond ((atom expr)
           (msg "( IN-ARITHMETIC-THEORY ~x0)" expr))
          ((symbolp (car expr))
           (msg "( IN-ARITHMETIC-THEORY (~x0 ...))"
                (car expr)))
          (t "( IN-ARITHMETIC-THEORY (...))"))
    (let ((wrld (w state))
          (event-form (or event-form
                          (list 'in-arithmetic-theory expr))))
      (cond
       ((not (quotep expr))
        (er soft ctx
            "Arithmetic theory expressions must be quoted constants.  ~
             See :DOC in-arithmetic-theory."))
       (t
        (er-let*
          ((theory (translate-in-theory-hint expr t ctx wrld state))
           (ens (load-theory-into-enabled-structure
                 expr theory nil
                 (global-val 'global-arithmetic-enabled-structure wrld)
                 nil nil wrld ctx state)))
          (let ((wrld1 (global-set 'global-arithmetic-enabled-structure ens
                                   wrld)))

; Note:  We do not permit IN-THEORY to be made redundant.  If this
; is changed, change the text of the :doc for redundant-events.

            (install-event (length theory)
                           event-form
                           'in-arithmetic-theory
                           0
                           nil
                           nil
                           nil ; handles its own invariants checking
                           nil
                           wrld1 state)))))))))

(defmacro disable (&rest rst)

; Warning: The resulting value must be a runic-theoryp.  See theory-fn-callp.

  (list 'set-difference-theories
        '(current-theory :here)
        (kwote rst)))

(defmacro enable (&rest rst)

; Warning: The resulting value must be a runic-theoryp.  See theory-fn-callp.

  (list 'union-theories
        '(current-theory :here)
        (kwote rst)))

; The theory-invariant-table maps arbitrary keys to translated terms
; involving only the variables THEORY and STATE:

(defun theory-invariant-table-guard (val world)
  (declare (xargs :guard (plist-worldp-with-formals world)))
  (and (weak-theory-invariant-record-p val)
       (booleanp (access theory-invariant-record val
                         :error))
       (let ((book (access theory-invariant-record val :book)))
         (or (book-name-p book)
             (null book)))
       (let ((tterm (access theory-invariant-record val
                            :tterm)))
         (and (termp tterm world)
              (subsetp-eq (all-vars tterm) '(ens state))))))

(set-table-guard theory-invariant-table
                 (theory-invariant-table-guard val world)
                 :topic theory-invariant)

(defun theory-invariant-fn (term state key error event-form)
  (when-logic
   "THEORY-INVARIANT"
   (with-ctx-summarized
    'theory-invariant
    (er-let* ((tterm
               (translate term '(nil) nil '(state)
                          'theory-invariant (w state) state)))

; known-stobjs ='(state).  All other variables in term are treated as
; non- stobjs.  This is ok because the :guard on the
; theory-invariant-table will check that the only variables involved
; in tterm are THEORY and STATE and when we ev the term THEORY will be
; bound to a non-stobj (and STATE to state, of course).

      (let* ((inv-table (table-alist 'theory-invariant-table
                                     (w state)))
             (key (or key
                      (1+ (length inv-table)))))
        (er-let* ((val (with-output!
                         :off summary
                         (table-fn1 'theory-invariant-table
                                    key
                                    (make theory-invariant-record
                                          :tterm tterm
                                          :error error
                                          :untrans-term term
                                          :book
                                          (active-book-name (w state) state))
                                    :put
                                    nil
                                    'theory-invariant
                                    (w state)
                                    (ens state)
                                    state
                                    event-form))))
          (cond
           ((eq val :redundant)
            (value val))
           (t
            (pprogn
             (cond ((assoc-equal key inv-table)
                    (warning$ 'theory-invariant "Theory"
                              "An existing theory invariant, named ~x0, is ~
                               being overwritten by a new theory invariant ~
                               with that name.~@1"
                              key
                              (cond ((f-get-global 'in-local-flg state)
                                     "  Moreover, this override is being done ~
                                      LOCALly; see :DOC theory-invariant (in ~
                                      particular, the Local Redefinition ~
                                      Caveat there), especially if an error ~
                                      occurs.")
                                    (t ""))))
                   (t state))
             (mv-let (erp val state)
               (revert-world (with-output! :off summary

; Below is the translation of:
;                              (in-theory (current-theory :here))

                               (in-theory-fn '(current-theory :here)
                                             state
                                             '(in-theory
                                               (current-theory :here)))))
               (declare (ignore val))
               (cond
                (erp
                 (er-soft 'theory-invariant "Theory"
                          "The specified theory invariant fails for the ~
                           current ACL2 world, and hence is rejected.  This ~
                           failure can probably be overcome by supplying an ~
                           appropriate in-theory event first."))
                (t (value key)))))))))))))

#+acl2-loop-only
(defmacro theory-invariant (&whole event-form term &key key (error 't))

; Note: This macro "really" expands to a TABLE event (after computing
; the right args for it!) and hence it should inherit the TABLE event's
; semantics under compilation, which is to say, is a noop.  This
; requirement wasn't noticed until somebody put a THEORY-INVARIANT
; event into a book and then the compiled book compiled the logical
; code below and thus loading the .o file essentially tried to
; re-execute the table event after it had already been executed by the
; .lisp code in the book.  A hard error was caused.

; Therefore, we also define this macro as a trivial no-op in raw Lisp.

  (list 'theory-invariant-fn
        (list 'quote term)
        'state
        (list 'quote key)
        (list 'quote error)
        (list 'quote event-form)))

#-acl2-loop-only
(defmacro theory-invariant (&rest args)
  (declare (ignore args))
  nil)

(defmacro incompatible (rune1 rune2 &optional strictp)
  (let ((active-fn (if strictp 'active-or-non-runep 'active-runep)))
    (cond ((and (consp rune1)
                (consp (cdr rune1))
                (symbolp (cadr rune1))
                (consp rune2)
                (consp (cdr rune2))
                (symbolp (cadr rune2)))

; The above condition is similar to conditions in runep and active-runep.

           `(not (and (,active-fn ',rune1)
                      (,active-fn ',rune2))))
          (t (er hard 'incompatible
                 "Each argument to ~x0 should have the shape of a rune, ~
                  (:KEYWORD BASE-SYMBOL), unlike ~x1."
                 'incompatible
                 (or (and (consp rune1)
                          (consp (cdr rune1))
                          (symbolp (cadr rune1))
                          rune2)
                     rune1))))))

(defmacro incompatible! (rune1 rune2)
  `(incompatible ,rune1 ,rune2 t))

; We now begin the development of the encapsulate event.  Often in this
; development we refer to the Encapsulate Essay.  See the comment in
; the function encapsulate-fn, below.

(defconst *generic-bad-signature-string*
  "The object ~x0 is not a legal signature.  A basic signature is of one of ~
   the following two forms:  ((fn sym1 ... symn) => val) or (fn (var1 ... ~
   varn) val).  In either case, keywords may also be specified. See :DOC ~
   signature.")

(defconst *signature-keywords*
  '(:GUARD
    #+:non-standard-analysis :CLASSICALP
    :STOBJS :DFS :FORMALS :GLOBAL-STOBJS :TRANSPARENT))

(defun duplicate-key-in-keyword-value-listp (l)
  (declare (xargs :guard (keyword-value-listp l)))
  (cond ((endp l) nil)
        ((assoc-keyword (car l) (cddr l))
         (car l))
        (t (duplicate-key-in-keyword-value-listp (cddr l)))))

(defun formals-pretty-flags-mismatch-msg (formals pretty-flags
                                                  fn
                                                  formals-top
                                                  pretty-flags-top)

; Pretty-flags-top is a true-listp.  We check elsewhere that formals is a
; true-listp; here we simply ignore its final cdr.  Pretty-flags and formals
; are corresponding NTHCDRs of pretty-flags-top and formals-top.  The result is
; a message explaining why formals-top and pretty-flags-top are incompatible in
; the same signature.

  (declare (xargs :guard (symbol-listp pretty-flags)))
  (cond ((or (atom formals)
             (endp pretty-flags))
         (cond ((and (atom formals)
                     (endp pretty-flags))
                nil)
               (t
                (msg "the specified list of :FORMALS, ~x0, is of length ~x1, ~
                      which does not match the arity of ~x2 specified by ~x3"
                     formals-top (length formals-top)
                     (length pretty-flags-top)
                     (cons fn pretty-flags-top)))))
        ((and (not (equal (symbol-name (car pretty-flags)) "*")) ; stobj argument
              (not (eq (car pretty-flags) (car formals))))
         (let ((posn (- (length formals-top) (length formals))))
           (msg "the specified list of :FORMALS, ~x0, has stobj ~x1 at ~
                 (zero-based) position ~x2, but the argument specified by ~x3 ~
                 at that position is a different stobj, ~x4"
                formals-top (car formals) posn
                (cons fn pretty-flags-top)
                (car pretty-flags))))
        (t (formals-pretty-flags-mismatch-msg
            (cdr formals) (cdr pretty-flags)
            fn formals-top pretty-flags-top))))

(defun chk-global-stobjs-value (x guard fn formals val ctx wrld state)
  (cond ((null x) (value nil))
        ((not (and (consp x)
                   (symbol-listp (car x))
                   (symbol-listp (cdr x))))
         (er soft ctx
             "Illegal signature for ~x0: the value of keyword :GLOBAL-STOBJS ~
              must be a cons pair of the form (x . y) where x and y are lists ~
              of symbols (in fact, stobj names).  The :GLOBAL-STOBJS value ~
              ~x1 is thus illegal.~@2"
             fn x *see-doc-with-global-stobj*))
        ((or (duplicates (car x))
             (duplicates (cdr x))
             (intersection-eq (car x) (cdr x)))
         (er soft ctx
             "Illegal signature for ~x0: the value of keyword :GLOBAL-STOBJS ~
              contains the name~#1~[~/s~] ~&1 more than once, but duplicates ~
              are not allowed.~@2"
             fn
             (or (duplicates (car x))
                 (duplicates (cdr x))
                 (intersection-eq (car x) (cdr x)))
             *see-doc-with-global-stobj*))
        ((and (not (equal x '(nil . nil)))
              (not (member-eq 'state formals)))
         (er soft ctx
             "In the signature for ~x0, it is illegal to specify any stobjs ~
              with the :GLOBAL-STOBJS keyword because ~x1 is not among the ~
              formals for ~x0.~@2"
             fn 'state *see-doc-with-global-stobj*))
        ((and (cdr x)
              (not (eq val 'state))
              (not (and (true-listp val)
                        (member-eq 'state val))))
         (er soft ctx
             "In the signature for ~x0, it is illegal to specify any stobjs ~
              in the CDR of the value of the :GLOBAL-STOBJS keyword (that is, ~
              stobjs that are viewed as updated by WITH-GLOBAL-STOBJ forms) ~
              because ~x1 is not returned by ~x0.~@2"
             fn 'state *see-doc-with-global-stobj*))
        (t
         (er-progn (chk-all-stobj-names (car x) :global-stobjs
                                        (msg ":global-stobjs (~x0 . _)" (car x))
                                        ctx wrld state)
                   (chk-all-stobj-names (cdr x) :global-stobjs
                                        (msg ":global-stobjs (_ . ~x0)" (cdr x))
                                        ctx wrld state)
                   (er-let* ((tguard ; repeated from intro-udf-guards, sigh
                              (cond (guard (translate guard
                                                      t   ; stobjs-out
                                                      t   ; logic-modep
                                                      nil ; known-stobjs
                                                      ctx wrld state))
                                    (t (value nil)))))
                     (cond
                      ((null tguard) (value nil))
                      (t
                       (mv-let (reads writes fns-seen)
                         (collect-global-stobjs tguard wrld nil nil nil)
                         (declare (ignore fns-seen))
                         (cond
                          ((not (subsetp-eq writes (cdr x)))

; This case may be impossible, since writes is presumably nil for tguard.  But
; we cover it anyhow, just to be safe.

                           (er soft ctx
                               "The stobj~#0~[~x0 is~/s ~&0 are each~] bound ~
                                by an updating call of ~x1 in the :GUARD of ~
                                the signature for ~x2 but not among the ~
                                written stobjs in the :GLOBAL-STOBJS of that ~
                                signature.~@3"
                               (set-difference-eq writes (cdr x))
                               'with-global-stobj
                               fn
                               *see-doc-with-global-stobj*))
                          ((not (subsetp-eq reads
                                            (append (car x) (cdr x))))
                           (er soft ctx
                               "The stobj~#0~[~x0 is~/s ~&0 are each~] bound ~
                                by a call of ~x1 in the :GUARD of the ~
                                signature for ~x2 but not among the stobjs in ~
                                the :GLOBAL-STOBJS of that signature.~@3"
                               (set-difference-eq reads
                                                  (append (car x) (cdr x)))
                               'with-global-stobj
                               fn
                               *see-doc-with-global-stobj*))
                          (t (value nil)))))))))))

(defun chk-signature (x ctx wrld state)

; Warning: If you change the acceptable form of signatures, change the raw lisp
; code for encapsulate in axioms.lisp and change signature-fns.

; X is supposed to be the external form of a signature of a function, fn.  This
; function either causes an error (if x is ill-formed) or else returns (insig
; kwd-value-list . wrld1), where: insig is of the form (fn formals' stobjs-in
; stobjs-out), where formals' is an appropriate arglist, generated if
; necessary; kwd-value-list is the keyword-value-listp from the signature (see
; below); and wrld1 is the world in which we are to perform the constraint of
; fn.

; The preferred external form of a signature is of the form:

; ((fn . pretty-flags) => pretty-flag . kwd-value-list)
; ((fn . pretty-flags) => (mv . pretty-flags) . kwd-value-list)

; where fn is a new or redefinable name, pretty-flag is an asterisk or stobj
; name, pretty-flags is a true list of pretty flags, and kwd-value-list
; specifies additional information such as the guard and formals.

  (let ((bad-kwd-value-list-string
         "The object ~x0 is not a legal signature.  It appears to specify ~x1 ~
          as the keyword alist, which however is not syntactically a ~
          keyword-value-listp because ~@2."))
    (mv-let
     (msg fn formals val stobjs dfs kwd-value-list)
     (case-match
       x
       (((fn . pretty-flags1) arrow val . kwd-value-list)
        (cond
         ((not (and (symbolp arrow) (equal (symbol-name arrow) "=>")))
          (mv (msg *generic-bad-signature-string* x) nil nil nil nil nil nil))
         ((not (and (symbol-listp pretty-flags1)
                    (no-duplicatesp-eq
                     (collect-non-*-df pretty-flags1))))
          (mv (msg
               "The object ~x0 is not a legal signature because ~x1 is not ~
                applied to a true-list of distinct symbols but to ~x2 instead."
               x fn pretty-flags1)
              nil nil nil nil nil nil))
         ((not (or (symbolp val)
                   (and (consp val)
                        (eq (car val) 'mv)
                        (symbol-listp (cdr val))
                        (no-duplicatesp-eq
                         (collect-non-*-df (cdr val))))))
          (mv (msg
               "The object ~x0 is not a legal signature because the result, ~
                ... => ~x1, is not a symbol or an MV form containing distinct ~
                symbols."
               x val)
              nil nil nil nil nil nil))
         ((or (member-eq t pretty-flags1)
              (member-eq nil pretty-flags1)
              (eq val t)
              (eq val nil)
              (and (consp val)
                   (or (member-eq t (cdr val))
                       (member-eq nil (cdr val)))))
          (mv (msg
               "The object ~x0 is not a legal signature because it mentions T ~
                or NIL in places that must each be filled by an asterisk (*), ~
                :DF, or a single-threaded object name."
               x)
              nil nil nil nil nil nil))
         ((not (subsetp-eq (collect-non-*-df (if (consp val)
                                                 (cdr val)
                                               (list val)))
                           pretty-flags1))
          (mv (msg
               "The object ~x0 is not a legal signature because the result, ~
                ~x1, refers to one or more single-threaded objects, ~&2, not ~
                displayed among the inputs in ~x3."
               x
               val
               (collect-non-*-df (set-difference-eq (if (consp val)
                                                        (cdr val)
                                                      (list val))
                                                    pretty-flags1))
               (cons fn pretty-flags1))
              nil nil nil nil nil nil))
         ((not (keyword-value-listp kwd-value-list))
          (mv (msg
               bad-kwd-value-list-string
               x
               kwd-value-list
               (reason-for-non-keyword-value-listp kwd-value-list))
              nil nil nil nil nil nil))
         ((duplicate-key-in-keyword-value-listp kwd-value-list)
          (mv (msg "The object ~x0 is not a legal signature because the ~
                    keyword ~x1 appears more than once."
                   x
                   (duplicate-key-in-keyword-value-listp kwd-value-list))
              nil nil nil nil nil nil))
         ((or (assoc-keyword :STOBJS kwd-value-list)
              (assoc-keyword :DFS kwd-value-list))
          (mv (msg "The object ~x0 is not a legal signature.  The ~
                    ~#1~[:STOBJS~/:DFS~] keyword is only legal for the older ~
                    style of signature (but may not be necessary for the ~
                    newer style that you are using); see :DOC signature."
                   x
                   (if (assoc-keyword :STOBJS kwd-value-list) 0 1))
              nil nil nil nil nil nil))
         ((and (assoc-keyword :GUARD kwd-value-list)
               (not (assoc-keyword :FORMALS kwd-value-list)))
          (mv (msg "The object ~x0 is not a legal signature.  The :GUARD ~
                    keyword is only legal for the newer style of signature ~
                    when the :FORMALS keyword is also supplied; see :DOC ~
                    signature."
                   x)
              nil nil nil nil nil nil))
         ((or #+:non-standard-analysis
              (not (booleanp (cadr (assoc-keyword :CLASSICALP
                                                  kwd-value-list))))
              (not (booleanp (cadr (assoc-keyword :TRANSPARENT
                                                  kwd-value-list)))))

; If :CLASSICALP or :TRANSPARENT is not bound in kwd-value-list, then the
; corresponding assoc-keyword call above reduces to (not (booleanp nil)), which
; is false, which is appropriate.

          (mv (msg "The object ~x0 is not a legal signature.  The value of ~
                    the ~x1 keyword must be Boolean; see :DOC signature."
                   x
                   #-:non-standard-analysis
                   :TRANSPARENT
                   #+:non-standard-analysis
                   (if (not (booleanp (cadr (assoc-keyword :CLASSICALP
                                                           kwd-value-list))))
                       :CLASSICALP
                     :TRANSPARENT))
              nil nil nil nil nil nil))
         (t
          (let* ((formals-tail (assoc-keyword :FORMALS kwd-value-list))
                 (formals (if formals-tail
                              (cadr formals-tail)
                            (gen-formals-from-pretty-flags pretty-flags1)))
                 (kwd-value-list (if formals-tail
                                     (remove-keyword :FORMALS kwd-value-list)
                                   kwd-value-list))

; Note:  Stobjs will contain duplicates iff formals does.  Stobjs will
; contain STATE iff formals does.

                 (stobjs (collect-non-*-df pretty-flags1))
                 (dfs (collect-by-position '(:df) pretty-flags1 formals))
                 (msg (and formals-tail
                           (formals-pretty-flags-mismatch-msg
                            formals pretty-flags1
                            fn
                            formals pretty-flags1))))
            (cond (msg (mv (msg "The object ~x0 is not a legal signature ~
                                 because ~@1.  See :DOC signature."
                                x msg)
                           nil nil nil nil nil nil))
                  (t (mv nil fn formals val stobjs dfs kwd-value-list)))))))
       ((fn formals val . kwd-value-list)
        (cond
         ((not (true-listp formals))
          (mv (msg
               "The object ~x0 is not a legal signature because its second ~
                element, representing the formals, is not a true-list."
               x)
              nil nil nil nil nil nil))
         ((not (keyword-value-listp kwd-value-list))
          (mv (msg
               bad-kwd-value-list-string
               x
               kwd-value-list
               (reason-for-non-keyword-value-listp kwd-value-list))
              nil nil nil nil nil nil))
         ((duplicate-key-in-keyword-value-listp kwd-value-list)
          (mv (msg "The object ~x0 is not a legal signature because the keyword ~
                    ~x1 appears more than once."
                   x
                   (duplicate-key-in-keyword-value-listp kwd-value-list))
              nil nil nil nil nil nil))
         ((assoc-keyword :FORMALS kwd-value-list)
          (mv (msg "The object ~x0 is not a legal signature.  The :FORMALS ~
                    keyword is only legal for the newer style of signature; ~
                    see :DOC signature."
                   x)
              nil nil nil nil nil nil))
         ((or #+:non-standard-analysis
              (not (booleanp (cadr (assoc-keyword :CLASSICALP
                                                  kwd-value-list))))
              (not (booleanp (cadr (assoc-keyword :TRANSPARENT
                                                  kwd-value-list)))))

; If :CLASSICALP or :TRANSPARENT is not bound in kwd-value-list, then the
; corresponding assoc-keyword call above reduces to (not (booleanp nil)), which
; is false, which is appropriate.

          (mv (msg "The object ~x0 is not a legal signature.  The value of ~
                    the ~x1 keyword must be Boolean; see :DOC signature."
                   x
                   #-:non-standard-analysis
                   :TRANSPARENT
                   #+:non-standard-analysis
                   (if (not (booleanp (cadr (assoc-keyword :CLASSICALP
                                                           kwd-value-list))))
                       :CLASSICALP
                     :TRANSPARENT))
              nil nil nil nil nil nil))
         (t
          (let* ((stobjs-tail (assoc-keyword :STOBJS kwd-value-list))
                 (dfs-tail (assoc-keyword :DFS kwd-value-list))
                 (dfs (cadr dfs-tail))
                 (kwd-value-list
                  (if (or stobjs-tail dfs-tail)
                      (remove-keyword :STOBJS
                                      (remove-keyword :DFS kwd-value-list))
                    kwd-value-list)))
            (cond ((not stobjs-tail)
                   (let ((stobjs (if (member-eq 'state formals) '(state) nil)))
                     (mv nil fn formals val stobjs dfs kwd-value-list)))
                  ((or (symbolp (cadr stobjs-tail))
                       (symbol-listp (cadr stobjs-tail)))
                   (let* ((stobjs0 (if (symbolp (cadr stobjs-tail))
                                       (list (cadr stobjs-tail))
                                     (cadr stobjs-tail)))
                          (stobjs (if (and (member-eq 'state formals)
                                           (not (member-eq 'state stobjs0)))
                                      (cons 'state stobjs0)
                                    stobjs0)))
                     (mv nil fn formals val stobjs dfs kwd-value-list)))
                  (t (mv (msg
                          "The object ~x0 is not a legal signature because ~
                           the proffered stobj names are ill-formed.  The ~
                           stobj names are expected to be either a single ~
                           symbol or a true list of symbols."
                          x)
                         nil nil nil nil nil nil)))))))
       (& (mv (msg *generic-bad-signature-string* x) nil nil nil nil nil nil)))
     (cond
      (msg (er soft ctx "~@0" msg))
      ((not (subsetp-eq (evens kwd-value-list) *signature-keywords*))
       (er soft ctx
           "The only legal signature keywords are ~&0.  The proposed ~
            signature ~x1 is thus illegal."
           *signature-keywords*
           x))
      (t
       (er-progn
        (chk-all-but-new-name fn ctx 'constrained-function wrld state)
        (chk-arglist formals
                     (not (member-eq 'state stobjs))
                     ctx wrld state)
        (chk-all-stobj-names stobjs
                             :STOBJS?
                             (msg "~x0" x)
                             ctx wrld state)
        (cond ((not (or (symbolp val)
                        (and (consp val)
                             (eq (car val) 'mv)
                             (symbol-listp (cdr val))
                             (> (length val) 2))))
               (er soft ctx
                   "The purported signature ~x0 is not a legal signature ~
                    because ~x1 is not a legal output description.  Such a ~
                    description should either be a symbol or of the form (mv ~
                    sym1 ... symn), where n>=2."
                   x val))
              (t (value nil)))
        (chk-global-stobjs-value (cadr (assoc-keyword :GLOBAL-STOBJS
                                                      kwd-value-list))
                                 (cadr (assoc-keyword :GUARD
                                                      kwd-value-list))
                                 fn formals val ctx wrld state)
        (let* ((syms (cond ((symbolp val) (list val))
                           (t (cdr val))))
               (stobjs-in (compute-stobj-flags formals
                                               stobjs
                                               dfs
                                               wrld))
               (stobjs-out (compute-stobj-flags syms
                                                stobjs
                                                '(:df)
                                                wrld)))
          (cond
           ((not (subsetp (collect-non-nil-df stobjs-out)
                          stobjs-in))
            (er soft ctx
                "It is impossible to return single-threaded objects (such as ~
                 ~&0) that are not among the formals!  Thus, the input ~
                 signature ~x1 and the output signature ~x2 are incompatible."
                (set-difference-eq (collect-non-nil-df stobjs-out)
                                   stobjs-in)
                formals
                val))
           ((not (no-duplicatesp (collect-non-nil-df stobjs-out)))
            (er soft ctx
                "It is illegal to return the same single-threaded object in ~
                 more than one position of the output signature.  Thus, ~x0 ~
                 is illegal because ~&1 ~#1~[is~/are~] duplicated."
                val
                (duplicates (collect-non-nil-df stobjs-out))))
           (t (er-let* ((wrld1 (chk-just-new-name fn
                                                  nil
                                                  (list* 'function
                                                         stobjs-in
                                                         stobjs-out)
                                                  nil ctx wrld state)))
                (value (list* (list fn
                                    formals
                                    stobjs-in
                                    stobjs-out)
                              kwd-value-list
                              wrld1))))))))))))

(defun chk-signatures-rec (signatures ctx wrld state)

; We return a triple (sigs kwd-value-list-lst . wrld) containing the list of
; internal signatures, their corresponding keyword-value-lists, and the final
; world in which we are to do the introduction of these fns, or else cause an
; error.

  (cond ((atom signatures)
         (cond ((null signatures) (value (list* nil nil wrld)))
               (t (er soft ctx
                      "The list of the signatures of the functions ~
                       constrained by an encapsulation is supposed to ~
                       be a true list, but yours ends in ~x0.  See ~
                       :DOC encapsulate."
                      signatures))))
        ((and (consp (cdr signatures))
              (symbolp (cadr signatures))
              (equal (symbol-name (cadr signatures)) "=>"))

; This clause is meant as an optimization helpful to the user.  It is
; an optimization because if we didn't have it here we would proceed
; to apply chk-signature first the (car signatures) -- which will
; probably fail -- and then to '=> -- which would certainly fail.
; These error messages are less understandable than the one we
; generate here.

         (er soft ctx
             "The signatures argument of ENCAPSULATE is supposed to ~
              be a list of signatures.  But you have provided ~x0, ~
              which might be a single signature.  Try writing ~x1."
             signatures
             (list signatures)))
        (t (er-let* ((trip1 (chk-signature (car signatures)
                                           ctx wrld state))
                     (trip2 (chk-signatures-rec (cdr signatures)
                                                ctx (cddr trip1) state)))
                    (let ((insig (car trip1))
                          (kwd-value-list (cadr trip1))
                          (insig-lst (car trip2))
                          (kwd-value-list-lst (cadr trip2))
                          (wrld1 (cddr trip2)))
                      (cond ((assoc-eq (car insig) insig-lst)
                             (er soft ctx
                                 "The name ~x0 is mentioned twice in the ~
                                  signatures of this encapsulation. See :DOC ~
                                  encapsulate."
                                 (car insig)))
                            (t (value (list* (cons insig insig-lst)
                                             (cons kwd-value-list
                                                   kwd-value-list-lst)
                                             wrld1)))))))))
(defun chk-transparent (name val insig-lst kwd-value-list-lst ctx state)
  (cond ((endp kwd-value-list-lst)
         (value nil))
        ((eq val (cadr (assoc-keyword :transparent (car kwd-value-list-lst))))
         (chk-transparent name val
                          (cdr insig-lst) (cdr kwd-value-list-lst)
                          ctx state))
        (t (er soft ctx
               "The signature for ~x0 specifies :transparent t, but the ~
                signature for ~x1 does not.  This is illegal because if any ~
                signature in an encapsulate event specifies :transparent t, ~
                then all must do so.  See :DOC encapsulate."
               (if val name (caar insig-lst))
               (if val (caar insig-lst) name)))))

(defun chk-signatures (signatures ctx wrld state)
  (er-let* ((trip (chk-signatures-rec signatures ctx wrld state))
            (insig-lst (value (car trip)))
            (kwd-value-list-lst (value (cadr trip))))
    (er-progn
     (cond ((or (null kwd-value-list-lst)
                (null (cdr kwd-value-list-lst)))
            (value nil))
           (t (chk-transparent (caar insig-lst)
                               (cadr (assoc-keyword :transparent
                                                    (car kwd-value-list-lst)))
                               (cdr insig-lst)
                               (cdr kwd-value-list-lst)
                               ctx state)))
     (value trip))))

(defun chk-acceptable-encapsulate1 (signatures form-lst ctx wrld state)

; This function checks that form-lst is a plausible list of forms to evaluate
; and that signatures parses into a list of function signatures for new
; function symbols.  We return the internal signatures, corresponding keyword
; alists, and the world in which they are to be introduced, as a triple (insigs
; kwd-alist-lst . wrld1).  This function is executed before the first pass of
; encapsulate.

  (er-progn
   (cond ((not (and (true-listp form-lst)
                    (consp form-lst)
                    (consp (car form-lst))))

; Observe that if the car is not a consp then it couldn't possibly be an
; event.  We check this particular case because we fear the user might get
; confused and write an explicit (progn expr1 ...  exprn) or some other
; single expression and this will catch all but the open lambda case.

          (er soft ctx
              "The arguments to encapsulate, after the first, are ~
               each supposed to be embedded event forms.  There must ~
               be at least one form.  See :DOC encapsulate and :DOC ~
               embedded-event-form."))
         (t (value nil)))
   (chk-signatures signatures ctx wrld state)))

(defun name-introduced (trip functionp)

; Trip is a triple from a world alist.  We seek to determine whether
; this triple introduces a new name, and if so, which name.  We return
; the name or nil.  If functionp is T we only return function names.
; That is, we return nil if the name introduced is not the name of a
; function, e.g., is a theorem or constant.  Otherwise, we return any
; logical name introduced.  The event functions are listed below.
; Beside each is listed the triple that we take as the unique
; indication that that event introduced name.  Only those having
; FORMALS are considered to be function names.

; event function            identifying triple

; defun-fn                   (name FORMALS . &)
; defuns-fn                  (name FORMALS . &)
; defthm-fn                  (name THEOREM . &)
; defaxiom-fn                (name THEOREM . &)
; defconst-fn                (name CONST . &)
; defstobj-fn                (name STOBJ . names)
;                                [Name is a single-threaded
;                                 object, e.g., $st, and has the
;                                 associated recognizers, accessors
;                                 and updaters.  But those names are
;                                 considered introduced by their
;                                 associated FORMALS triples.]
; defabsstobj-fn             (name STOBJ . names) [as above for defstobj-fn]
; deflabel-fn                (name LABEL . T)
; deftheory-fn               (name THEORY . &)
; defchoose-fn               (name FORMALS . &)
; verify-guards-fn           ---
; defmacro-fn                (name MACRO-BODY . &)
; in-theory-fn               ---
; in-arithmetic-theory-fn    ---
; regenerate-tau-database   ---
; push-untouchable-fn        ---
; remove-untouchable-fn      ---
; reset-prehistory           ---
; set-body-fn                ---
; table-fn                   ---
; encapsulate-fn             --- [However, the signature functions
;                                 are introduced with (name FORMALS . &)
;                                 and those names, along with any others
;                                 introduced by the embedded events, are
;                                 returned.]
; include-book-fn            (CERTIFICATION-TUPLE GLOBAL-VALUE
;                              ("name" "user name" "short name"
;                               cert-annotations . book-hash))

; Those marked "---" introduce no names.

; If redefinition has occurred we have to avoid being fooled by trips such
; as (name FORMALS . *acl2-property-unbound*) and
; (name THEOREM . *acl2-property-unbound*).

  (cond ((eq (cddr trip) *acl2-property-unbound*)
         nil)
        ((eq (cadr trip) 'formals)
         (car trip))
        (functionp nil)
        ((member-eq (cadr trip) '(theorem const macro-body label theory stobj))
         (car trip))
        ((and (eq (car trip) 'certification-tuple)
              (eq (cadr trip) 'global-value)
              (cddr trip))

; The initial value of 'certification-tuple is nil (see initialize-
; world-globals) so we filter it out.  Observe that name is a string
; here.  This name is not the name that occurs in the include-book
; event -- that name is called "user name" in the identifying triple
; column above -- but is in fact the full name of the book, complete
; with the current-book-directory.

         (car (cddr trip)))
        (t nil)))

(defun chk-embedded-event-form-orig-form-msg (orig-form state)
  (cond (orig-form
         (msg "  Note: the above form was encountered during processing of ~X01."
              orig-form
              (term-evisc-tuple t state)))
        (t "")))

(defconst *acl2-defaults-table-macros*

; By defining this constant, we make it easy for tool builders to use this list
; in code without cutting and pasting.  (Thanks to Eric Smith for the
; suggestion.)

  '(add-include-book-dir
    add-match-free-override
    defttag
    delete-include-book-dir
    logic
    program
    set-backchain-limit
    set-bogus-defun-hints-ok
    set-bogus-mutual-recursion-ok
    set-case-split-limitations
    set-compile-fns
    set-default-backchain-limit
    set-enforce-redundancy
    set-ignore-ok
    set-irrelevant-formals-ok
    set-let*-abstractionp
    set-match-free-default
    set-measure-function
    set-non-linearp
    set-prover-step-limit
    set-rewrite-stack-limit
    set-ruler-extenders
    set-state-ok
    set-tau-auto-mode
    set-verify-guards-eagerness
    set-well-founded-relation))

(defun chk-embedded-event-form (form orig-form wrld ctx state names
                                     in-local-flg in-encapsulatep
                                     make-event-chk)

; WARNING: Keep this in sync with destructure-expansion, elide-locals-rec,
; make-include-books-absolute, and find-first-non-local-name.

; Note: For a test of this function, see the reference to foo.lisp below.

; Orig-form is used for error reporting.  It is either nil, indicating that
; errors should refer to form, or else it is a form from a superior call of
; this function.  So it is typical, though not required, to call this with
; orig-form = nil at the top level.  If we encounter a macro call and orig-form
; is nil, then we set orig-form to the macro call so that the user can see that
; macro call if the check fails.

; This function checks that form is a tree whose tips are calls of the symbols
; listed in names, and whose interior nodes are each of one of the following
; forms.

; (local &)
; (skip-proofs &)
; (with-cbd dir form) ; dir a string
; (with-current-package pkg form) ; pkg a string
; (with-guard-checking-event g &) ; g in *guard-checking-values*; (quote g) ok
; (with-output ... &)
; (with-prover-step-limit ... &)
; (with-prover-time-limit ... &)
; (make-event #)

; where each & is checked.  The # forms above are unrestricted, although the
; result of expanding the argument of make-event (by evaluation) is checked.
; Note that both 'encapsulate and 'progn are typically in names, and their
; sub-events aren't checked by this function until evaluation time.

; Formerly we also checked here that include-book is only applied to absolute
; pathnames.  That was important for insuring that the book that has been read
; into the certification world is not dependent upon :cbd.  Remember that
; (include-book "file") will find its way into the portcullis of the book we
; are certifying and there is no way of knowing in the portcullis which
; directory that book comes from if it doesn't explicitly say.  However, we now
; use fix-portcullis-cmds to modify include-book forms that use relative
; pathnames so that they use absolute pathnames instead, or cause an error
; trying.

; We allow defaxioms, skip-proofs, and defttags in the portcullis, but we mark
; the book's certificate appropriately.

; In-local-flg is used to enforce restrictions in the context of LOCAL on the
; use of (table acl2-defaults-table ...), either directly or by way of events
; such as defun-mode events and set-compile-fns that set this table.  A non-nil
; value of in-local-flg means that we are in the scope of LOCAL.  In that case,
; if we are lexically within an encapsulate but not LOCAL when restricted to
; the nearest such encapsulate, then in-local-flg is 'local-encapsulate.
; Otherwise, if we are in the scope of LOCAL, but we are in an included book
; and not in the scope of LOCAL with respect to that book, then in-local-flg is
; 'local-include-book.

; Moreover, we do not allow local defaxiom events.  Imagine locally including a
; book that has nil as a defaxiom.  You can prove anything you want in your
; book, and then when you later include the book, there will be no trace of the
; defaxiom in your logical world!

; We do not check that the tips are well-formed calls of the named functions
; (though we do ensure that they are all true lists).

; If names is primitive-event-macros and form can be translated and evaluated
; without error, then it is in fact an embedded event form as described in :DOC
; embedded-event-form.

; We sometimes call this function with names extended by the addition of
; 'DEFPKG.

; If form is rejected, the error message is that printed by str, with #\0 bound
; to the subform (of form) that was rejected.

; We return a value triple (mv erp val state).  If erp is nil then val is the
; event form to be evaluated.  Generally that is the result of macroexpanding
; the input form.  However, if (perhaps after some macroexpansion) form is a
; call of local that should be skipped, then val is nil.

  (let* ((er-str

; Below, the additional er arguments are as follows:
; ~@1: a reason specific to the context, or "" if none is called for.
; ~@2: original form message.
; ~@3: additional explanation, or "".

          "The form ~x0 is not an embedded event form~@1.  See :DOC ~
           embedded-event-form.~@2~@3")
         (local-str "The form ~x0 is not an embedded event form in the ~
                     context of LOCAL~@1.  See :DOC embedded-event-form.~@2~@3")
         (encap-str "The form ~x0 is not an embedded event form in the ~
                     context of ENCAPSULATE~@1.  See :DOC ~
                     embedded-event-form.~@2~@3"))
    (cond ((or (atom form)
               (not (symbolp (car form)))
               (not (true-listp (cdr form))))
           (er soft ctx er-str
               form
               ""
               (chk-embedded-event-form-orig-form-msg orig-form state)
               ""))
          ((and (eq (car form) 'local)
                (consp (cdr form))
                (null (cddr form)))
           (cond
            ((eq (ld-skip-proofsp state) 'include-book)

; Keep this in sync with the definition of the macro local; if we evaluate the
; cadr of the form there, then we need to check it here.

             (value nil))
            (t
             (er-let* ((new-form (chk-embedded-event-form
                                  (cadr form) orig-form wrld ctx state names
                                  t in-encapsulatep
                                  make-event-chk)))
                      (value (and new-form (list (car form) new-form)))))))
          ((and (eq in-local-flg t)
                (consp form)
                (eq (car form) 'table)
                (consp (cdr form))
                (eq (cadr form) 'acl2-defaults-table))
           (er soft ctx local-str
               form
               " because it sets the acl2-defaults-table in a local context.  ~
                A local context is not useful when setting this table, since ~
                the acl2-defaults-table is restored upon completion of ~
                encapsulate, include-book, and certify-book forms; that is, ~
                no changes to the acl2-defaults-table are exported"
               (chk-embedded-event-form-orig-form-msg orig-form state)
               ""))
          ((and (eq in-local-flg t)
                (consp form)
                (member-eq (car form)
                           *acl2-defaults-table-macros*))
           (er soft ctx local-str
               form
               " because it implicitly sets the acl2-defaults-table in a ~
                local context; see :DOC acl2-defaults-table, in particular ~
                the explanation about this error message"
               (chk-embedded-event-form-orig-form-msg orig-form state)
               ""))
          ((and in-local-flg (eq (car form) 'defaxiom))
           (er soft ctx local-str
               form
               " because it adds an axiom whose traces will disappear"
               (chk-embedded-event-form-orig-form-msg orig-form state)
               ""))
          ((and in-encapsulatep (eq (car form) 'defaxiom))
           (er soft ctx encap-str
               form
               " because we do not permit defaxiom events in the scope of an ~
                encapsulate"
               (chk-embedded-event-form-orig-form-msg orig-form state)
               ""))
          ((and in-local-flg
                (member-eq (car form) '(add-include-book-dir!
                                        delete-include-book-dir!)))
           (er soft ctx local-str
               form
               (msg " (see :DOC ~x0)" (car form))
               (chk-embedded-event-form-orig-form-msg orig-form state)
               ""))
          ((and (eq (car form) 'include-book)
                in-encapsulatep
                (or (eq in-local-flg nil)
                    (eq in-local-flg 'local-encapsulate)))

; Through Version_4.2, the error message below added: "We fear that such forms
; will generate unduly large constraints that will impede the successful use of
; :functional-instance lemma instances."  However, this message was printed
; even for encapsulates with empty signatures.

; It is probably sound in principle to lift this restriction, but in that case
; case we will need to visit all parts of the code which could be based on the
; assumption that include-book forms are always local to encapsulate events.
; See for example the comment about encapsulate in make-include-books-absolute;
; the paragraph labeled (2) in the Essay on Hidden Packages (file axioms.lisp);
; and the comment about "all include-books are local" near the end of
; encapsulate-fn.  By no means do we claim that these examples are exhaustive!
; Even if we decide to loosen this restriction, we might want to leave it in
; place for encapsulates with non-empty signatures, for the reason explained in
; the "We fear" quote above.

           (er soft ctx encap-str
               form
               " because we do not permit non-local include-book forms in the ~
                scope of an encapsulate.  Consider moving your include-book ~
                form outside the encapsulates, or else making it local"
               (chk-embedded-event-form-orig-form-msg orig-form state)
               ""))
          ((member-eq (car form) names)

; Names is often primitive-event-macros or an extension, and hence
; contains encapsulate and include-book.  This is quite reasonable,
; since they do their own checking.  And because they restore the
; acl2-defaults-table when they complete, we don't have to worry that
; they are sneaking in a ``local defun-mode.''

           (value form))
          ((and (eq (car form) 'skip-proofs)
                (consp (cdr form))
                (null (cddr form)))
           (pprogn
            (cond ((global-val 'embedded-event-lst wrld)
                   (warning$ ctx "Skip-proofs"
                             "ACL2 has encountered a SKIP-PROOFS form, ~x0, ~
                              in the context of a book or an encapsulate ~
                              event.  Therefore, no logical claims may be ~
                              soundly made in this context.  See :DOC ~
                              SKIP-PROOFS."
                             form))
                  (t state))
            (er-let* ((new-form (chk-embedded-event-form
                                 (cadr form) orig-form wrld ctx state names
                                 in-local-flg in-encapsulatep
                                 make-event-chk)))
                     (value (and new-form (list (car form) new-form))))))
          ((and (member-eq (car form) '(with-cbd
                                        with-current-package
                                        with-guard-checking-event
                                        with-output
                                        with-prover-step-limit
                                        with-prover-time-limit))
                (true-listp form))

; The macro being called will check the details of the form structure.

           (cond
            ((and (eq (car form) 'with-guard-checking-event)
                  (or (atom (cdr form))
                      (let ((val (cadr form)))
                        (not (case-match val
                               (('quote x)
                                (member-eq x *guard-checking-values*))
                               (& (member-eq val *guard-checking-values*)))))))
             (er soft ctx er-str
                 form
                 ""
                 (chk-embedded-event-form-orig-form-msg orig-form state)
                 (msg "~|The macro ~x0 requires the second argument to be a ~
                       constant from the list ~x1, or of the form (QUOTE X) ~
                       for such a constant, X."
                      'with-guard-checking-event
                      *guard-checking-values*)))
            ((and (member-eq (car form) '(with-cbd with-current-package))
                  (not (stringp (cadr form))))
             (er soft ctx er-str
                 form
                 ""
                 (chk-embedded-event-form-orig-form-msg orig-form state)
                 (msg "~|The macro ~x0 requires the second argument to be a ~
                       string when used in an event context."
                      (car form))))
            (t (er-let* ((new-form (chk-embedded-event-form
                                    (car (last form))
                                    orig-form wrld ctx state
                                    names in-local-flg
                                    in-encapsulatep make-event-chk)))
                 (value (and new-form
                             (append (butlast form 1)
                                     (list new-form))))))))
          ((eq (car form) 'make-event)
           (cond ((and make-event-chk

; Here we are doing just a bit of a sanity check.  It's not used when
; redefinition is active, nor is it complete; see below.  But it's cheap and
; it could catch some errors.

                       (not (and (true-listp form)
                                 (or (consp (cadr (member-eq :check-expansion
                                                             form)))
                                     (consp (cadr (member-eq :expansion?
                                                             form))))))

; We avoid this check when redefinition is active, and here's why.  Consider
; the following example.  In the first pass of encapsulate there are no calls
; of make-event so the resulting expansion-alist is empty.  But in the second
; pass, process-embedded-events is called with make-event-chk = t, which
; *would* result in the error below when (foo) is evaluated (because no
; make-event expansion was saved for (foo) in the first pass) -- except, we
; avoid this check when redefinition is active.

;   (redef!)
;   (encapsulate ()
;     (defmacro foo () '(make-event '(defun f (x) x)))
;     (local (defmacro foo () '(defun f (x) (cons x x))))
;     (foo))

; Moreover, this check is not complete.  Consider the following variant of the
; example just above, the only difference being the progn wrapper.

;   (redef!)
;   (encapsulate ()
;     (defmacro foo () '(progn (make-event '(defun f (x) x))))
;     (local (defmacro foo () '(defun f (x) (cons x x))))
;     (foo))

; Because of the progn wrapper, chk-embedded-event-form is called on the
; make-event call with make-event-chk = nil.  So even if we were to avoid the
; redefinition check below, we would not get an error here.

                       (not (ld-redefinition-action state)))
                  (er soft ctx
                      "Either the :check-expansion or :expansion? argument of ~
                       make-event is normally a consp in the present context. ~
                       ~ This is not surprising in some cases, for example, ~
                       when including an uncertified book or calling ~x0 ~
                       explicitly.  But other cases could be evidence of an ~
                       ACL2 bug; consider contacting the ACL2 implementors.  ~
                       Current form:~|~%~X12"
                      'record-expansion
                      form
                      nil))
                 (t (value form))))
          ((eq (car form) 'record-expansion) ; a macro that we handle specially
           (cond ((not (and (cdr form)
                            (cddr form)
                            (null (cdddr form))))
                  (er soft ctx
                      "The macro ~x0 takes two arguments, so ~x1 is illegal."
                      'record-expansion
                      form))
                 (t (er-progn
                     (chk-embedded-event-form (cadr form)
                                              nil
                                              wrld ctx state names
                                              in-local-flg
                                              in-encapsulatep nil)
                     (chk-embedded-event-form (caddr form)
                                              (or orig-form form)
                                              wrld ctx state names
                                              in-local-flg
                                              in-encapsulatep t)))))
          ((getpropc (car form) 'macro-body nil wrld)
           (cond
            ((member-eq (car form)
                        '(mv mv-let translate-and-test with-local-stobj
                             with-global-stobj))
             (er soft ctx er-str
                 form
                 ""
                 (chk-embedded-event-form-orig-form-msg orig-form state)
                 (msg "~|Calls of the macro ~x0 do not generate an event, ~
                       because this macro has special meaning that is not ~
                       handled by ACL2's event-generation mechanism."
                      (car form))))
            (t
             (er-let*
              ((expansion (macroexpand1 form ctx state)))
              (chk-embedded-event-form expansion
                                       (or orig-form form)
                                       wrld ctx state names
                                       in-local-flg
                                       in-encapsulatep make-event-chk)))))
          (t (er soft ctx er-str
                 form
                 ""
                 (chk-embedded-event-form-orig-form-msg orig-form state)
                 "")))))

; We have had a great deal of trouble correctly detecting embedded defaxioms!
; Tests for this have been incorporated into community book
; books/make-event/embedded-defaxioms.lisp.

(defconst *destructure-expansion-wrappers*
  '(local skip-proofs
          with-cbd
          with-current-package
          with-guard-checking-event
          with-output
          with-prover-step-limit
          with-prover-time-limit))

(defun destructure-expansion (form)

; WARNING: Keep this in sync with chk-embedded-event-form and elide-locals-rec.

  (declare (xargs :guard (true-listp form)))
  (cond ((member-eq (car form) *destructure-expansion-wrappers*)
         (mv-let (wrappers base-form)
                 (destructure-expansion (car (last form)))
                 (mv (cons (butlast form 1) wrappers)
                     base-form)))
        (t (mv nil form))))

(defun rebuild-expansion (wrappers form)
  (cond ((endp wrappers) form)
        (t (append (car wrappers)
                   (list (rebuild-expansion (cdr wrappers) form))))))

(defun set-raw-mode-on (state)
  (pprogn (cond ((raw-mode-p state) state)
                (t (f-put-global 'acl2-raw-mode-p t state)))
          (value :invisible)))

(defun set-raw-mode-off (state)
  (pprogn (cond ((raw-mode-p state)
                 (f-put-global 'acl2-raw-mode-p nil state))
                (t state))
          (value :invisible)))

(defmacro set-raw-mode-on! ()
  '(er-progn (ld '((defttag :raw-mode-hack)
                   (set-raw-mode-on state))
                 :ld-prompt nil :ld-verbose nil :ld-post-eval-print nil

; Do we want to allow raw mode to be set inside code?  Since this macro
; traffics in trust tags, we might as well allow it.  So we need to specify a
; value for the following keyword.

                 :ld-user-stobjs-modified-warning :same)
             (value :invisible)))

(defmacro set-raw-mode (flg)
  (declare (xargs :guard (member-equal flg '(t 't nil 'nil))))
  (if (or (null flg)
          (equal flg '(quote nil)))
      '(set-raw-mode-off state)
    '(set-raw-mode-on state)))

(defun alist-to-bindings (alist)
  (cond
   ((endp alist) nil)
   (t (cons (list (caar alist) (kwote (cdar alist)))
            (alist-to-bindings (cdr alist))))))

#-acl2-loop-only
(defun-one-output acl2-raw-eval-form-to-eval (form)
  `(let ((state *the-live-state*)
         ,@(alist-to-bindings *user-stobj-alist*))

; CCL prints "Unused lexical variable" warnings unless we take some
; measures, which we do now.  We notice that we need to include #+cmu for the
; second form, so we might as well include it for the first, too.

     #+(or ccl cmu sbcl)
     ,@(mapcar #'(lambda (x) `(declare (ignorable ,(car x))))
               *user-stobj-alist*)
     #+(or ccl cmu sbcl)
     (declare (ignorable state))
     ,(cond ((and (consp form)
                  (eq (car form) 'in-package)
                  (or (and (consp (cdr form))
                           (null (cddr form)))
                      (er hard 'top-level
                          "IN-PACKAGE takes one argument.  The form ~p0 is ~
                           thus illegal."
                          form)))

; The package must be one that ACL2 knows about, or there are likely to be
; problems involving the prompt and the ACL2 reader.  Also, we want the
; in-package form to reflect in the prompt.

             (list 'in-package-fn (list 'quote (cadr form)) 'state))
            (t form))))

#-acl2-loop-only
(defun chk-stobjs-out-raw (sym expr bad wrld state)

; Sym is a symbol and expr is an expression.  Return t if it is determined that
; expr returns single value, which is a new stobj value for sym if sym names a
; stobj and otherwise is a non-stobj value.

  (declare (ftype (function (t t t t) (values t))
                  stobjs-out-raw))
  (let ((stobjs-out (stobjs-out-raw expr bad wrld state)))
    (if (stobjp sym t wrld)
        (and (consp stobjs-out)
             (eq (car stobjs-out) sym)
             (null (cdr stobjs-out)))
      (equal stobjs-out '(nil)))))

#-acl2-loop-only
(defun stobjs-out-raw (form bad wrld state)

; Warning: If the signature of this function changes, then change the
; corresponding declare form in chk-stobjs-out-raw.

; Bad is a list of symbols that should not be considered to be stobjs,
; presumably because they have been let-bound to non-stobj values.

; This function attempts to return the stobjs-out from evaluating form.  When
; it is unable to determine that, it may return nil, but it may also return a
; list whose length is the number of values returned and whose nth element is
; either a stobj name when that can be determined, else nil.  Soundness should
; not rely on the result: although we expect it to be accurate in nearly all
; cases, the fact that form is arbitrary rather than an ACL2 form, together how
; we mix two kinds of macroexpansion (raw-Lisp and logical), raises suspicion.

  (cond
   ((or (atom form)
        (eq (car form) 'quote))
    (cond ((and (symbolp form)
                (member-eq form bad))
           '(nil))
          ((or (eq form 'state)
               (stobjp form t wrld))
           (list form))
          (t '(nil))))
   ((eq (car form) 'if)
    (and (true-listp form)
         (equal (length form) 4)
         (let ((so-tbr (stobjs-out-raw (caddr form) bad wrld state))
               (so-fbr (stobjs-out-raw (cadddr form) bad wrld state)))
           (cond ((equal so-tbr so-fbr) so-tbr)
                 ((equal (length so-tbr) (length so-fbr))
                  (loop for x in so-tbr as y in so-fbr
                        collect (and (eq x y) x)))
                 (t nil)))))
   ((eq (car form) 'mv)
    (loop for x in (cdr form)
          collect
          (let ((s (stobjs-out-raw x bad wrld state)))
            (cond ((and s (null (cdr s))) (car s))
                  (t nil)))))
   ((eq (car form) 'let) ; (let ((var1 expr1) ...) ... body)
    (and (consp (cdr form))
         (consp (cddr form))
         (doublet-listp (cadr form))
         (let ((new-bad (loop for (sym expr) in (cadr form)
                              when
                              (and (symbolp sym)
                                   (not (member-eq sym bad))
                                   (stobjp sym t wrld)
                                   (not (chk-stobjs-out-raw sym expr bad wrld
                                                            state)))
                              collect sym)))
           (stobjs-out-raw (car (last form))
                           (append new-bad bad)
                           wrld state))))
   ((and (consp (car form))
         (eq (caar form) 'lambda)) ; ((lambda (var1 ...) body) expr1 ...)
    (and (true-listp form)
         (true-listp (car form))
         (let* ((lam (car form))
                (vars (cadr lam))
                (body (car (last lam)))
                (expr-lst (cdr form)))
           (and (symbol-listp vars)
                (equal (length vars) (length expr-lst))
                (let ((new-bad
                       (loop for v in vars
                             as e in expr-lst
                             when
                             (and (not (member-eq v bad))
                                  (stobjp v t wrld)
                                  (not (chk-stobjs-out-raw v e bad wrld
                                                           state)))
                             collect v)))
                  (stobjs-out-raw body (append new-bad bad) wrld state))))))
   ((eq (car form) 'mv-let) ; (mv-let (var1 ... varn) expr ... body)
    (and (consp (cdr form))
         (consp (cddr form))
         (consp (cdddr form))
         (symbol-listp (cadr form))
         (let ((stobjs-out-expr (stobjs-out-raw (caddr form) bad wrld state)))
           (and stobjs-out-expr
                (equal (length (cadr form)) (length stobjs-out-expr))
                (let ((new-bad (loop for v in (cadr form)
                                     as s in stobjs-out-expr
                                     when (and (not (member-eq v bad))
                                               (stobjp v t wrld)
                                               (not (eq v s)))
                                     collect v)))
                  (stobjs-out-raw (car (last form))
                                  (append new-bad bad)
                                  wrld state))))))
   ((member-eq (car form) '(progn return-last))
    (stobjs-out-raw (car (last form)) bad wrld state))
   ((not (symbolp (car form)))
    nil)
   ((getpropc (car form) 'macro-body nil wrld)
    (mv-let (msg val)
      (macroexpand1-cmp form 'stobjs-out-raw wrld
                        (default-state-vars t))
      (cond (msg nil)
            (t (stobjs-out-raw val bad wrld state)))))
   ((getpropc (car form) 'stobjs-out nil wrld))
   (t (multiple-value-bind
       (form flg)
       (macroexpand-1 form)
       (cond ((null flg) nil)
             (t (stobjs-out-raw form bad wrld state)))))))

#-acl2-loop-only
(defun acl2-raw-eval (form state)
  (or (live-state-p state)
      (error "Unexpected state in acl2-raw-eval!"))
  (if (or (eq form :q) (equal form '(EXIT-LD STATE)))
      (mv nil '((NIL NIL STATE) NIL :Q REPLACED-STATE) state)
    (let* ((stobjs-out (stobjs-out-raw form nil (w state) state))
           (vals (multiple-value-list
                  (eval (acl2-raw-eval-form-to-eval form))))
           (eq-len (equal (length stobjs-out) (length vals)))
           (stobjs-out
            (if eq-len
                stobjs-out
              (let ((user-stobj-alist *user-stobj-alist*)
                    pair)
                (loop for x in vals
                      collect
                      (cond
                       ((live-state-p x) 'state)
                       ((setq pair (rassoc x user-stobj-alist))
                        (car pair))
                       (t nil))))))
           (latches (and eq-len
                         (loop for x in stobjs-out
                               as val in vals
                               when (and x
                                         (not (eq x :df))
                                         (not (eq x 'state)))
                               collect (cons x val)))))
      (when eq-len
        (update-user-stobj-alist (put-assoc-eq-alist (user-stobj-alist state)
                                                     latches)
                                 state))
      (assert (equal (length stobjs-out) (length vals)))
      (mv nil
          (cons (if (intersectp-eq stobjs-out *non-executable-user-stobj-lst*)
                    (loop for x in stobjs-out
                          collect
                          (if (member-eq x *non-executable-user-stobj-lst*)
                              nil
                            x))
                  stobjs-out)
                (if (cdr stobjs-out) vals (car vals)))
          state))))

#+acl2-loop-only
(defun acl2-raw-eval (form state)

; We never execute this code in practice, since the raw code will run instead.
; But for consistency with the raw code, we avoid the
; user-stobjs-modified-warning.  Raw-mode is so far from maintaining soundness
; that we feel no need to implement the user-stobjs-modified-warning in the raw
; code.

  (trans-eval-no-warning form 'top-level state t))

(defun get-and-chk-last-make-event-expansion (form wrld ctx state names)
  (let ((expansion (f-get-global 'last-make-event-expansion state)))
    (cond
     (expansion
      (mv-let
       (erp val state)
       (state-global-let*
        ((inhibit-output-lst *valid-output-names*))
        (chk-embedded-event-form form
                                 nil ; orig-form
                                 wrld ctx state names
                                 nil ; in-local-flg
                                 nil ; in-encapsulatep
                                 nil ; make-event-chk
                                 ))
       (declare (ignore val))
       (cond (erp (er soft ctx
                      "Make-event is only legal in event contexts, where it ~
                       can be tracked properly; see :DOC make-event.  The ~
                       form ~p0 has thus generated an illegal call of ~
                       make-event.  This form's evaluation will have no ~
                       effect on the ACL2 logical world."
                      form))
             (t (value expansion)))))
     (t (value nil)))))

(defconst *local-value-triple-elided*

; Warning: Do not change the value of this constant without searching for all
; occurrences of (value-triple :elided) in the sources (especially,
; :doc strings).

  '(local (value-triple :elided)))

(defmacro elide-locals (form)
  `(mv-let (changed-p x)
     (elide-locals-rec ,form)
     (declare (ignore changed-p))
     x))

(mutual-recursion

(defun elide-locals-rec (form)

; WARNING: Keep this in sync with chk-embedded-event-form,
; destructure-expansion, and make-include-books-absolute.

; We assume that form is a legal event form and return (mv changed-p new-form),
; where new-form results from eliding top-level local events from form, and
; changed-p is true exactly when such elision has taken place.

  (cond ((atom form) (mv nil form)) ; note that progn! can contain atoms
        ((equal form *local-value-triple-elided*)
         (mv nil form))
        ((eq (car form) 'local)
         (mv t *local-value-triple-elided*))
        ((eq (car form) 'encapsulate)
         (mv-let (changed-p x)
           (elide-locals-lst (cddr form))
           (cond (changed-p (mv t (list* (car form) (cadr form) x)))
                 (t (mv nil form)))))
        ((member-eq (car form) '(skip-proofs
                                 with-cbd
                                 with-current-package
                                 with-guard-checking-event
                                 with-output
                                 with-prover-time-limit
                                 with-prover-step-limit
                                 record-expansion

; Can time$ really occur in an event context?  At one time we seemed to think
; that time$1 could, but it currently seems doubtful that either time$1 or
; time$ could occur in an event context.  It's harmless to leave the next line,
; but it particularly makes no sense to us to use time$1, so we use time$
; instead.

                                 time$))
         (mv-let (changed-p x)
           (elide-locals-rec (car (last form)))
           (cond ((and (consp x)
                       (eq (car x) 'local)

; A call of record-expansion was inserted by encapsulate, and needs to stay
; there to support redundancy-checking.  See the Essay on Make-event.

                       (not (eq (car form) 'record-expansion)))
                  (mv t x))
                 (changed-p (mv t (append (butlast form 1) (list x))))
                 (t (mv nil form)))))
        ((or (eq (car form) 'progn)
             (and (eq (car form) 'progn!)
                  (not (and (consp (cdr form))
                            (eq (cadr form) :state-global-bindings)))))
         (mv-let (changed-p x)
           (elide-locals-lst (cdr form))
           (cond (changed-p (mv t (cons (car form) x)))
                 (t (mv nil form)))))
        ((eq (car form) 'progn!) ; hence :state-global-bindings case
         (mv-let (changed-p x)
           (elide-locals-lst (cddr form))
           (cond (changed-p (mv t (list* (car form) (cadr form) x)))
                 (t (mv nil form)))))
        (t (mv nil form))))

(defun elide-locals-lst (x)
  (cond ((endp x) (mv nil nil))
        (t (mv-let (changedp1 first)
             (elide-locals-rec (car x))
             (mv-let (changedp2 rest)
               (elide-locals-lst (cdr x))
               (cond ((or changedp1 changedp2)
                      (mv t (cons first rest)))
                     (t (mv nil x))))))))
)

(defun make-record-expansion? (event expansion r-e-p)
  (cond
   ((not r-e-p)
    expansion)
   (t (case-match event
        (('record-expansion a &) ; & is a partial expansion
         (list 'record-expansion a expansion))
        (&
         (list 'record-expansion event expansion))))))

(table acl2-system-table nil nil

; Since there isn't any documentation particularly relevant to this table, we
; avoid using set-table-guard here.

; This table is used when we need to lay down an event marker.  We may find
; other uses for it in the future, in which we will support other keys.  Users
; should stay away from this table since it might change out from under them!
; But there is no soundness issue if they do use it.

       :guard
       (eq key 'empty-event-key))

(defmacro table-put (name key val)

; Just as with table, name isn't quoted and key and val are expressions (where
; key might well be quoted).

  `(TABLE-FN ',name
             '(,key ,val)
             STATE
             '(TABLE ,name ,key ,val)))

(defun maybe-add-event-landmark (state)

; If (and only if) the installed world doesn't end with an event landmark, we
; add one.  We do this with an otherwise-meaningless table event; specifically,
; the table-fn call below is the macroexpansion of the following.

; (table acl2-system-table 'empty-event-key
;        (not (cdr (assoc-eq 'empty-event-key
;                            (table-alist 'acl2-system-table world)))))

; We can check that by executing :trans1 on the above form or by evaluating:

;   (macroexpand1 '(table acl2-system-table 'empty-event-key
;                         (not (cdr (assoc-eq 'empty-event-key
;                                             (table-alist 'acl2-system-table
;                                                          world)))))
;                 'top-level state)

  (cond ((let ((wrld (w state)))
           (not (and (eq (caar wrld) 'event-landmark)
                     (eq (cadar wrld) 'global-value))))
         (state-global-let*
          ((inhibit-output-lst
            (add-to-set-eq 'summary
                           (f-get-global 'inhibit-output-lst state))))
          (table-put acl2-system-table
                     'empty-event-key
                     (not (cdr (assoc-eq 'empty-event-key
                                         (table-alist 'acl2-system-table
                                                      world)))))))
        (t (value nil))))

(defun eval-event-lst (index expansion-alist ev-lst quietp environment
                             in-local-flg last-val other-control kpa
                             caller ctx channel state)

; This function takes a true list of forms, ev-lst, and successively evals each
; one, cascading state through successive elements.  However, it insists that
; each form is an embedded-event-form.  We return a tuple (mv erp value
; expansion-alist kpa-result state), where erp is 'non-event if some member of
; ev-lst is not an embedded event form and otherwise is as explained below.  If
; erp is nil, then: value is the final value (or nil if ev-lst is empty);
; expansion-alist associates the (+ index n)th member E of ev-lst with its
; expansion if there was any make-event expansion subsidiary to E, ordered by
; index from smallest to largest (accumulated in reverse order); and kpa-result
; is derived from kpa as described below.  If erp is not nil, then let n be the
; (zero-based) index of the event in ev-lst that translated or evaluated to
; some (mv erp0 ...) with non-nil erp0.  Then we return (mv t (+ index n)
; state) if the error was during translation, else (mv (list erp0) (+ index n)
; state).  Except, in the special case that there is no error but we find that
; make-event was called under some non-embedded-event form, we return (mv
; 'make-event-problem (+ index n) state).

; Environment is a list containing at most one of 'certify-book or 'pcert, and
; also perhaps 'encapsulate indicate whether we are under a certify-book
; (possibly doing provisional certification) and/or an encapsulate.  Note that
; 'certify-book is not present when certify-book has been called only to write
; out a .acl2x file.

; Other-control is either :non-event-ok, used for progn!, or else t or nil for
; the make-event-chk in chk-embedded-event-form.

; Kpa is generally nil and not of interest, in which case kpa-result (mentioned
; above) is also nil.  However, if eval-event-lst is being called on behalf of
; certify-book, then kpa is initially the known-package-alist just before
; evaluation of the forms in the book.  As soon as a different (hence larger)
; known-package-alist is observed, kpa is changed to the current index, i.e.,
; the index of the event that caused this change to the known-package-alist;
; and this parameter is not changed on subsequent recursive calls and is
; ultimately returned.  Ultimately certify-book will cdr away that many
; expansion-alist entries before calling pkg-names.

; Caller is as in process-embedded-events.  We introduced this argument on the
; advent of setting world global 'cert-replay.  (It wasn't sufficient to query
; the environment argument for this purpose, because we don't want to set
; 'cert-replay here when processing events under a progn.)

; Channel is generally (proofs-co state), but doesn't have to be.

; A non-nil value of quietp suppresses printing of the event and the result.

  (flet ((event-macros (caller)
                       (if (eq caller
                               'eval-some-portcullis-cmds)
                           (cons 'defpkg (primitive-event-macros))
                         (primitive-event-macros))))
    (cond
     ((null ev-lst)
      (pprogn (f-put-global 'last-make-event-expansion nil state)
              (mv nil last-val (reverse expansion-alist) kpa state)))
     (t
      (let ((old-wrld (w state)))
        (pprogn
         (cond
          (quietp state)
          (t
           (io? event nil state
                (channel ev-lst)
                (fms "~%~@0~sr ~@1~*2~#3~[~Q45~/~]~|"
                     (list
                      (cons #\0 (f-get-global 'current-package state))
                      (cons #\1 (defun-mode-prompt-string state))
                      (cons #\2 (list "" ">" ">" ">"
                                      (make-list-ac
                                       (1+ (f-get-global 'ld-level state))
                                       nil nil)))
                      (cons #\3 (if (eq (ld-pre-eval-print state) :never)
                                    1
                                  0))
                      (cons #\4 (car ev-lst))
                      (cons #\5 (term-evisc-tuple nil state))
                      (cons #\r
                            #+:non-standard-analysis
                            (if (f-get-global 'script-mode state)
                                ""
                              "(r)")
                            #-:non-standard-analysis ""))
                     channel state nil))))
         (mv-let
           (erp form state)
           (cond ((eq other-control :non-event-ok)
                  (mv nil (car ev-lst) state))
                 (t (chk-embedded-event-form (car ev-lst)
                                             nil
                                             (w state)
                                             ctx state
                                             (event-macros caller)
                                             in-local-flg
                                             (member-eq 'encapsulate
                                                        environment)
                                             other-control)))
           (cond
            (erp (pprogn (f-put-global 'last-make-event-expansion nil state)
                         (mv 'non-event index nil nil state)))
            ((null form)
             (eval-event-lst (1+ index) expansion-alist (cdr ev-lst) quietp
                             environment in-local-flg nil other-control kpa
                             caller ctx channel state))
            (t
             (mv-let
               (erp trans-ans state)
               (pprogn (f-put-global 'last-make-event-expansion nil state)
                       (if (raw-mode-p state)
                           (acl2-raw-eval form state)

; We avoid the user-stobjs-modified-warning here, since it seems unreasonable
; to warn about the event's result if a user stobj is changed.  Rather, if the
; event itself does evaluation that changes a user stobjs, then that event
; should be held responsible for any such warning.  Thus, make-event takes such
; responsibility for its expansion phase; it is sensitive to LD special
; ld-user-stobjs-modified-warning (see protected-eval and make-event-fn2).

                         (trans-eval-no-warning form ctx state t)))

; If erp is nil, trans-ans is
; ((nil nil state) . (erp' val' replaced-state))
; because ev-lst contains nothing but embedded event forms.

               (let* ((tuple
                       (cond ((eq other-control :non-event-ok)
                              (let* ((stobjs-out (car trans-ans))
                                     (result (replace-stobjs stobjs-out
                                                             (cdr trans-ans))))
                                (if (null (cdr stobjs-out)) ; single value
                                    (list nil result)
                                  result)))
                             (t (cdr trans-ans))))
                      (erp-prime (car tuple))
                      (val-prime (cadr tuple)))
                 (cond
                  ((or erp erp-prime)
                   (pprogn
                    (cond ((and (consp (car ev-lst))
                                (eq (car (car ev-lst)) 'record-expansion))
                           (let ((chan (proofs-co state)))
                             (io? error nil state (chan ev-lst)
                                  (fmt-abbrev "~%Note: The error reported above ~
                                           occurred when processing the ~
                                           make-event expansion of the form ~
                                           ~x0."
                                              (list (cons #\0
                                                          (cadr (car ev-lst))))
                                              0 chan state "~|~%"))))
                          (t state))
                    (f-put-global 'last-make-event-expansion nil state)
                    (mv (if erp t (list erp-prime)) index nil kpa state)))
                  (t
                   (pprogn
                    (cond (quietp state)
                          (t (io? summary nil state
                                  (val-prime channel)
                                  (cond
                                   ((member-eq
                                     'value
                                     (f-get-global 'inhibited-summary-types
                                                   state))
                                    state)
                                   (t
                                    (mv-let
                                      (col state)
                                      (fmt1 "~y0"
                                            (list (cons #\0 val-prime))
                                            0 channel state
                                            (ld-evisc-tuple state))
                                      (declare (ignore col))
                                      state))))))
                    (mv-let
                      (erp expansion0 state)

; We need to cause an error if we have an expansion but are not properly
; tracking expansions.  For purposes of seeing if such tracking is being done,
; it should suffice to do the check in the present world rather than the world
; present before evaluating the form.

                      (get-and-chk-last-make-event-expansion
                       (car ev-lst) (w state) ctx state (event-macros caller))
                      (cond
                       (erp (pprogn
                             (f-put-global 'last-make-event-expansion
                                           nil
                                           state)
                             (mv 'make-event-problem index nil nil state)))
                       (t
                        (mv-let
                          (erp ignored-val state)
                          (cond
                           ((and (eq caller 'certify-book)
                                 (eq (global-val 'cert-replay (w state)) t))
                            (pprogn
                             (set-w 'extension
                                    (global-set 'cert-replay
                                                (cons index old-wrld)
                                                (w state))
                                    state)
                             (maybe-add-event-landmark state)))
                           (t (value nil)))
                          (declare (ignore ignored-val))
                          (cond
                           (erp ; very surprising
                            (mv 'make-event-problem index nil nil state))
                           (t
                            (eval-event-lst
                             (1+ index)
                             (cond
                              (expansion0
                               (acons index
                                      (make-record-expansion?
                                       (car ev-lst)
                                       (mv-let (wrappers base-form)
                                         (destructure-expansion form)
                                         (declare (ignore base-form))
                                         (rebuild-expansion wrappers
                                                            expansion0))

; We only need to add record-expansion when directly under an encapsulate, to
; check redundancy.  See the Essay on Make-event.

                                       (member-eq caller
                                                  '(encapsulate-pass-1
                                                    encapsulate-pass-2)))
                                      expansion-alist))
                              (t expansion-alist))
                             (cdr ev-lst) quietp
                             environment in-local-flg val-prime
                             other-control
                             (cond ((or (null kpa)
                                        (integerp kpa)
                                        (equal kpa
                                               (known-package-alist state)))
                                    kpa)
                                   (t index))
                             caller ctx channel state)))))))))))))))))))))

; After we have evaluated the event list and obtained wrld2, we
; will scrutinize the signatures and exports to make sure they are
; appropriate.  We will try to give the user as much help as we can in
; detecting bad signatures and exports, since it may take him a while
; to recreate wrld2 after fixing an error.  Indeed, he has already
; paid a high price to get to wrld2 and it is a real pity that we'll
; blow him out of the water now.  The guilt!  It's enough to make us
; think about implementing some sort of interactive version of
; encapsulate, when we don't have anything else to do.  (We have since
; implemented redo-flat, which helps with the guilt.)

(defun equal-insig (insig1 insig2)

; Suppose insig1 and insig2 are both internal form signatures, (fn
; formals stobjs-in stobjs-out).  We return t if they are ``equal.''
; But by equal we mean only that the fn, stobjs-in and stobjs-out are
; the same.  If the user has declared that fn has formals (x y z) and
; then witnessed fn with a function with formals (u v w), we don't
; care -- as long as the stobjs among the two lists are the same in
; corresponding positions.  But that information is captured in the
; stobjs-in.

  (and (equal (car insig1) (car insig2))
       (equal (caddr insig1) (caddr insig2))
       (equal (cadddr insig1) (cadddr insig2))))

;; Historical Comment from Ruben Gamboa:
;; I changed this so that non-classical witness functions are
;; not allowed.  The functions introduced by encapsulate are
;; implicitly taken to be classical, so a non-classical witness
;; function presents a (non-obvious) signature violation.

(defun bad-signature-alist (insigs kwd-value-list-lst udf-fns wrld)

; Warning: If you change this function, consider changing the message printed
; by any function that uses the result of this function.

; For ACL2 (as opposed to ACL2(r)), we do not use kwd-value-list-lst.  It is
; convenient though to keep it as a formal, to avoid proliferation of
; #-:non-standard-analysis readtime conditionals.  We are tempted to declare
; kwd-value-list-lst as IGNOREd, in order to avoid the complaint that
; kwd-value-list-lst is an irrelevant formal.  However, ACL2 then complains
; because of the recursive calls of this function.  Fortunately, declaring
; kwd-value-list-lst IGNORABLE also turns off the irrelevance check.

  #-:non-standard-analysis
  (declare (ignorable kwd-value-list-lst))
  (cond ((null insigs) nil)
        ((member-eq (caar insigs) udf-fns)
         (bad-signature-alist (cdr insigs)
                              (cdr kwd-value-list-lst)
                              udf-fns
                              wrld))
        (t (let* ((declared-insig (car insigs))
                  (fn (car declared-insig))
                  (actual-insig (list fn
                                      (formals fn wrld)
                                      (stobjs-in fn wrld)
                                      (stobjs-out fn wrld))))
             (cond
              ((and (equal-insig declared-insig actual-insig)
                    #+:non-standard-analysis

; If the function is specified to be classical, then it had better have a
; classical witness.  But in fact the converse is critical too!  Consider the
; following example.

;   (encapsulate
;    ((g (x) t :classicalp nil))
;    (local (defun g (x) x))
;    (defun f (x)
;      (g x)))

; This is clearly not what we intend: a classical function (f) that depends
; syntactically on a non-classical function (g).  We could then probably prove
; nil (though we haven't done it) by deriving a property P about f that fails
; for some non-classical function h, then deriving the trivial corollary that P
; holds for g in place of f (since f and g are equal), and then functionally
; instantiating this corollary for g mapped to h.  But even if such a proof
; attempt were somehow to fail, we prefer not to allow the situation above,
; which seems bound to lead to unsoundness eventually!

                    (eq (classicalp fn wrld)
                        (let ((tail (assoc-keyword :classicalp
                                                   (car kwd-value-list-lst))))
                          (cond (tail (cadr tail))
                                (t t)))))
               (bad-signature-alist (cdr insigs)
                                    (cdr kwd-value-list-lst)
                                    udf-fns
                                    wrld))
              (t (cons (list fn declared-insig actual-insig)
                       (bad-signature-alist (cdr insigs)
                                            (cdr kwd-value-list-lst)
                                            udf-fns
                                            wrld))))))))

(defmacro if-ns (test tbr fbr ctx)

; This is just (list 'if test tbr fbr), except that we expect test always to be
; false in the standard case.

  #+:non-standard-analysis
  (declare (ignore ctx))
  #-:non-standard-analysis
  (declare (ignore tbr))
  (list 'if
        test
        #+:non-standard-analysis
        tbr
        #-:non-standard-analysis
        `(er hard ,ctx
             "Unexpected intrusion of non-standard analysis into standard ~
              ACL2!  Please contact the implementors.")
        fbr))

(defun tilde-*-bad-insigs-phrase1 (alist)
  (cond ((null alist) nil)
        (t (let* ((fn (caar alist))
                  (dcl-insig (cadar alist))
                  (act-insig (caddar alist)))
             (cons
              (if-ns (equal-insig dcl-insig act-insig)
                     (msg
                      "The signature you declared for ~x0 and the local ~
                       witness for that function do not agree on whether the ~
                       function is classical.  If you are seeing this error ~
                       in the context of an attempt to admit a call of ~
                       DEFUN-SK without a :CLASSICALP keyword supplied, then ~
                       a solution is likely to be the addition of :CLASSICALP ~
                       ~x1 to the DEFUN-SK form."
                      fn
                      nil)
                     (msg
                      "The signature you declared for ~x0 is ~x1, but ~
                       the signature of your local witness for it is ~
                       ~x2."
                      fn
                      (unparse-signature dcl-insig)
                      (unparse-signature act-insig))
                     'tilde-*-bad-insigs-phrase1)
              (tilde-*-bad-insigs-phrase1 (cdr alist)))))))

(defun tilde-*-bad-insigs-phrase (alist)

; Each element of alist is of the form (fn insig1 insig2), where
; insig1 is the internal form of the signature presented by the user
; in his encapsulate and insig2 is the internal form signature of the
; witness.  For each element we print a sentence of the form "The
; signature for your local definition of fn is insig2, but the
; signature you declared for fn was insig1."

  (list "" "~@*" "~@*" "~@*"
        (tilde-*-bad-insigs-phrase1 alist)))

(defun chk-acceptable-encapsulate2 (insigs kwd-value-list-lst wrld ctx state)

; Wrld is a world alist created by the execution of an event list.  Insigs is a
; list of internal form function signatures.  We verify that they are defined
; as functions in wrld and have the signatures listed.

; This is an odd little function because it may generate more than one error
; message.  The trouble is that this wrld took some time to create and yet will
; have to be thrown away as soon as we find one of these errors.  So, as a
; favor to the user, we find all the errors we can.

  (let ((udf-fns

; If we are going to insist on functions being defined (see first error below),
; we might as well insist that they are defined in :logic mode.

         (collect-non-logic-mode insigs wrld)))
    (mv-let
     (erp1 val state)
     (cond
      (udf-fns
       (er soft ctx
           "You provided signatures for ~&0, but ~#0~[that function ~
            was~/those functions were~] not defined in :logic mode by the ~
            encapsulated event list.  See :DOC encapsulate."
           (merge-sort-symbol< udf-fns)))
      (t (value nil)))
     (declare (ignore val))
     (mv-let
      (erp2 val state)
      (let ((bad-sig-alist (bad-signature-alist insigs kwd-value-list-lst
                                                udf-fns wrld)))
        (cond
         (bad-sig-alist
          (er soft ctx
              "The signature~#0~[~/s~] provided for the function~#0~[~/s~] ~
               ~&0 ~#0~[is~/are~] incorrect.  See :DOC encapsulate.  ~*1"
              (strip-cars bad-sig-alist)
              (tilde-*-bad-insigs-phrase bad-sig-alist)))
         (t (value nil))))
      (declare (ignore val))
      (mv (or erp1 erp2) nil state)))))

(defun conjoin-into-alist (fn thm alist)

; Alist is an alist that maps function symbols to terms.  Fn is a function
; symbol and thm is a term.  If fn is not bound in alist we add (fn . thm)
; to it.  Otherwise, we change the binding (fn . term) in alist to
; (fn . (if thm term *nil*)).

  (cond ((null alist)
         (list (cons fn thm)))
        ((eq fn (caar alist))
         (cons (cons fn (conjoin2 thm (cdar alist)))
               (cdr alist)))
        (t (cons (car alist) (conjoin-into-alist fn thm (cdr alist))))))

(defun classes-theorems (classes)

; Classes is the 'classes property of some symbol.  We return the list of all
; corollary theorems from these classes.

  (cond
   ((null classes) nil)
   (t (let ((term (cadr (assoc-keyword :corollary (cdr (car classes))))))
        (if term
            (cons term (classes-theorems (cdr classes)))
          (classes-theorems (cdr classes)))))))

(defun constraints-introduced1 (thms fns ans)
  (cond
   ((endp thms) ans)
   ((ffnnamesp fns (car thms))

; By using union-equal below, we handle the case that an inner encapsulate may
; have both an 'unnormalized-body and 'constraint-lst property, so that if
; 'unnormalized-body has already been put into ans, then we don't include that
; constraint when we see it here.

    (constraints-introduced1 (cdr thms)
                             fns
                             (union-equal (flatten-ands-in-lit (car thms))
                                          ans)))
   (t (constraints-introduced1 (cdr thms) fns ans))))

(defun new-trips-rec (wrld3 proto-wrld3 seen acc)

; See new-trips.

; Note on this recursion: The recursion below is potentially disastrously slow.
; Imagine that proto-wrld3 is a list of 10,000 repetitions of the element e.
; Imagine that wrld3 is the extension produced by adding 1000 more copies of e.
; Then the equal below will fail the first 1000 times, but it will only fail
; after confirming that the first 10,000 e's in wrld3 are the same as the
; corresponding ones in proto-wrld3, i.e., the equal will do a root-and-branch
; walk through proto-wrld3 1000 times.  When finally the equal succeeds it
; potentially does another root-and-branch exploration of proto-wrld3.
; However, this worst-case scenario is not likely.  More likely, if wrld3 is an
; extension of proto-wrld3 then the first element of wrld3 differs from that of
; proto-wrld3 -- because either wrld3 begins with a putprop of a new name or a
; new list of lemmas or some other property.  Therefore, most of the time the
; equal below will fail immediately when the two worlds are not equal.  When
; the two worlds are in fact equal, they will be eq, because wrld3 was actually
; constructed by adding triples to proto-wrld3.  So the equal will succeed on
; its initial eq test and avoid a root-and-branch exploration.  This analysis
; is crucial to the practicality of this recursive scheme.  Our worlds are so
; large we simply cannot afford root-and-branch explorations.

; In fact, we did see performance issues when seen was kept as a list of
; triples.  So, we have restructured it as an alist, whose values are alists,
; in which triple (key1 key2 . val) is found in the alist associated with key1.
; After Version_8.2 we changed seen to be a fast-alist.  With that change we
; saw a reduction in time by 4.7% and a reduction in bytes allocated by 34% for
; including the community book, centaur/sv/top.

  (cond ((equal wrld3 proto-wrld3)
         (prog2$ (fast-alist-free seen)
                 (reverse acc)))
        ((let ((key-alist (hons-get (caar wrld3) seen)))
           (and key-alist ; optimization
                (assoc-eq (cadar wrld3) (cdr key-alist))))
         (new-trips-rec (cdr wrld3) proto-wrld3 seen acc))
        ((eq (cddr (car wrld3)) *acl2-property-unbound*)
         (new-trips-rec (cdr wrld3) proto-wrld3
                        (hons-acons (caar wrld3)
                                    (cons (cdar wrld3)
                                          (cdr (hons-get (caar wrld3) seen)))
                                    seen)
                        acc))
        (t
         (new-trips-rec (cdr wrld3) proto-wrld3
                        (hons-acons (caar wrld3)
                                    (cons (cdar wrld3)
                                          (cdr (hons-get (caar wrld3) seen)))
                                    seen)
                        (cons (car wrld3) acc)))))

(defun new-trips (wrld3 proto-wrld3)

; Important: This function returns those triples in wrld3 that are after
; proto-wrld3, in the same order they have in wrld3. See the comment labeled
; "Important" in the definition of constrained-functions.

; As with the function actual-props, we are only interested in triples that
; aren't superseded by *acl2-property-unbound*.  We therefore do not copy to
; our answer any *acl2-property-unbound* triple or any chronologically earlier
; bindings of the relevant symbol and key!  That is, the list of triples
; returned by this function contains no *acl2-property-unbound* values and
; makes it appear as though the property list was really erased when that value
; was stored.

; Note therefore that the list of triples returned by this function will not
; indicate when a property bound in proto-wrld3 becomes unbound in wrld3.
; However, if a property was stored during the production of wrld3 and the
; subsequently in the production of wrld3 that property was set to
; *acl2-property-unbound*, then the property is gone from the new-trips
; returned here.

; Warning: The value of this function is sometimes used as though it were the
; 'current-acl2-world!  It is a legal property list world.  If it gets into a
; getprop on 'current-acl2-world the answer is correct but slow.  Among other
; things, we use new-trips to compute the ancestors of a definition defined
; within an encapsulate -- knowing that functions used in those definitions but
; defined outside of the encapsulate (and hence, outside of new-trips) will be
; treated as primitive.  That way we do not explore all the way back to ground
; zero when we are really just looking for the subfunctions defined within the
; encapsulate.

; See new-trips-rec for further comments.

  (new-trips-rec wrld3 proto-wrld3 nil nil))

(defun constraints-introduced (new-trips fns ans)

; New-trips is a list of triples from a property list world, none of them with
; cddr *acl2-property-unbound*.  We return the list of all formulas represented
; in new-trips that mention any function symbol in the list fns (each of which
; is in :logic mode), excluding definitional (defuns, defchoose) axioms.  We
; may skip properties such as 'congruences and 'lemmas that can only be there
; if some other property has introduced a formula for which the given
; property's implicit formula is a consequence.  A good way to look at this is
; that the only events that can introduce axioms are defuns, defthm,
; encapsulate, defaxiom, and include-book, and we have ruled out the last two.
; Encapsulate is covered by the 'constraint-lst property.

  (cond
   ((endp new-trips) ans)
   (t (constraints-introduced
       (cdr new-trips)
       fns
       (let ((trip (car new-trips)))
         (case (cadr trip)
           (constraint-lst

; As promised in a comment in encapsulate-constraint, here we explain why the
; 'constraint-lst properties must be considered as we collect up formulas for
; an encapsulate event.  That is, we explain why after virtually moving
; functions in front of an encapsulate where possible, then any
; sub-encapsulate's constraint is a formula that must be collected.  The
; following example illustrates, starting with the following event.

;   (encapsulate
;    ((f1 (x) t)
;     (f2 (x) t))
;    (local (defun f1 (x) x))
;    (local (defun f2 (x) x))
;    (encapsulate
;     ((g (x) t))
;     (local (defun g (x) x))
;     (defthm g-prop (and (equal (f1 x) (g x))
;                         (equal (f2 x) (g x)))
;       :rule-classes nil)))

; Suppose we did not collect up g-prop here, considering it to be a sort of
; definitional axiom for g.  Then we would collect up nothing, which would make
; g a candidate to be moved back, as though we had the following events.  Here,
; we use a skip-proofs to mimic the behavior we are contemplating.

;   (encapsulate
;    ((f1 (x) t)
;     (f2 (x) t))
;    (local (defun f1 (x) x))
;    (local (defun f2 (x) x)))
;
;   (skip-proofs
;    (encapsulate
;     ((g (x) t))
;     (local (defun g (x) x))
;     (defthm g-prop (and (equal (f1 x) (g x))
;                         (equal (f2 x) (g x)))
;       :rule-classes nil)))

; We can then prove nil as follows.

;   (defthm f1-is-f2
;     (equal (f1 x) (f2 x))
;     :hints (("Goal" :use g-prop)))
;
;   (defthm contradiction
;     nil
;     :hints (("Goal" :use ((:functional-instance
;                            f1-is-f2
;                            (f1 (lambda (x) (cons x x)))
;                            (f2 (lambda (x) (consp x)))))))
;     :rule-classes nil)

; The moral of the story is that our treatment of encapsulates for which some
; signature function is ancestral must be analogous to our treatment of
; subversive defuns: their constraints must be considered.  An easy way to
; provide this treatment is for the following call of constraints-introduced to
; collect up constraints.  One might think this unnecessary, since every defthm
; contributing to a constraint has a 'theorem property that will be collected.
; However, an "infected" defun can contribute to a constraint (because neither
; [Front] nor [Back] applies to it within its surrounding encapsulate event),
; and we are deliberately not collecting defun formulas.  Moreover, we prefer
; not to rely on the presence of 'theorem properties for constraints.

            (let ((constraint-lst (cddr trip)))
              (cond ((unknown-constraints-p constraint-lst)

; This case should not happen.  The only symbols with unknown-constraints are
; those introduced in a non-trivial encapsulate (one with non-empty signature
; list).  But we are in such an encapsulate already, for which we cannot yet
; have computed the constraints as unknown-constraints.  So the 'constraint-lst
; property in question is on a function symbol that was introduced in an inner
; encapsulate, which should have been illegal since that function symbol is in
; the scope of two (nested) non-trivial encapsulates, where the inner one
; designates a dependent clause-processor, and such non-unique promised
; encapsulates are illegal.

                     (er hard 'constraints-introduced
                         "Implementation error in constraints-introduced: ~
                          Please contact the ACL2 developers."))
                    ((symbolp constraint-lst)

; Then the constraint list for (car trip) is held in the 'constraint-lst
; property of (cddr trip).  We know that this kind of "pointing" is within the
; current encapsulate, so it is safe to ignore this property, secure in the
; knowledge that we see the real constraint list at some point.

                     ans)
                    (t (constraints-introduced1 (cddr trip) fns ans)))))
           (theorem
            (cond
             ((ffnnamesp fns (cddr trip))
              (union-equal (flatten-ands-in-lit (cddr trip)) ans))
             (t ans)))
           (classes
            (constraints-introduced1
             (classes-theorems (cddr trip)) fns ans))
           (otherwise ans)))))))

(defun putprop-constraints (fn constrained-fns constraint-lst
                               unknown-constraints-p wrld3)

; Wrld3 is almost wrld3 of the encapsulation essay.  We have added all the
; exports, but we have not yet stored the 'constraint-lst properties of the
; functions in the signature of the encapsulate.  Fn is the first function
; mentioned in the signature, while constrained-fns includes the others as well
; as all functions that have any function in the signature as an ancestor.  We
; have determined that the common constraint for all these functions is
; constraint-lst, which has presumably been obtained from all the new theorems
; introduced by the encapsulate that mention any functions in (fn
; . constrained-fns).

; We actually store the symbol fn as the value of the 'constraint-lst property
; for every function in constrained-fns.  For fn, we store a 'constraint-lst
; property of constraint-lst.

; Note that we store a 'constraint-lst property for every function in (fn
; . constrained-fns).  The function constraint-info will find this property
; rather than looking for an 'unnormalized-body or 'defchoose-axiom.

  (putprop-x-lst1
   constrained-fns 'constraint-lst fn
   (putprop
    fn 'constraint-lst constraint-lst
    (cond
     (unknown-constraints-p
      (putprop-x-lst1
       constrained-fns 'constrainedp *unknown-constraints*
       (putprop
        fn 'constrainedp *unknown-constraints*
        wrld3)))
     (t wrld3)))))

(defun maybe-install-acl2-defaults-table (acl2-defaults-table state)
  (cond
   ((equal acl2-defaults-table
           (table-alist 'acl2-defaults-table (w state)))
    (value nil))

; Otherwise, we call table-fn directly, rather than calling table by way of
; eval-event-lst, to circumvent the restriction against calling
; acl2-defaults-table in the context of a LOCAL.

   (t (state-global-let*
       ((inhibit-output-lst (cons 'summary (@ inhibit-output-lst)))
        (modifying-include-book-dir-alist t))
       (table-fn 'acl2-defaults-table
                 `(nil ',acl2-defaults-table :clear)
                 state
                 `(table acl2-defaults-table nil ',acl2-defaults-table
                         :clear))))))

(defun update-for-redo-flat (n ev-lst state)

; Here we update the state globals 'redo-flat-succ and 'redo-flat-fail on
; behalf of a failure of progn, encapsulate, or certify-book.  N is the
; zero-based index of the event in ev-lst that failed.

  (assert$ (and (natp n)
                (< n (length ev-lst)))
           (pprogn
            (f-put-global 'redo-flat-succ
                          (append? (take n ev-lst)
                                   (f-get-global 'redo-flat-succ state))
                          state)
            (if (null (f-get-global 'redo-flat-fail state))
                (f-put-global 'redo-flat-fail
                              (nth n ev-lst)
                              state)
              state))))

(defmacro redo-flat (&key (succ-ld-skip-proofsp 't)
                          (label 'r)
                          (succ 't)
                          (fail 't)
                          (pbt 't)
                          (show 'nil))
  `(if (null (f-get-global 'redo-flat-fail state))
       (pprogn (fms "There is no failure saved from an encapsulate, progn, or ~
                     certify-book.~|"
                    nil (standard-co state) state nil)
               (value :invisible))
     ,(if show
          `(pprogn (fms "List of events preceding the failure:~|~%~x0~|"
                        (list (cons #\0 (f-get-global 'redo-flat-succ state)))
                        (standard-co state) state (ld-evisc-tuple state))
                   (fms "Failed event:~|~%~x0~|"
                        (list (cons #\0 (f-get-global 'redo-flat-fail state)))
                        (standard-co state) state (ld-evisc-tuple state))
                   (value :invisible))
        `(let ((redo-flat-succ (f-get-global 'redo-flat-succ state))
               (redo-flat-fail (f-get-global 'redo-flat-fail state)))
           (state-global-let*
            ((redo-flat-succ redo-flat-succ)
             (redo-flat-fail redo-flat-fail))
            (ld (list ,@(and succ label `('(deflabel ,label)))
                      ,@(and succ (list (list 'list ''ld
                                              (list 'cons
                                                    ''list
                                                    (list 'kwote-lst
                                                          'redo-flat-succ))
                                              :ld-skip-proofsp
                                              succ-ld-skip-proofsp)))
                      ,@(and fail (list (list 'list ''ld
                                              (list 'list
                                                    ''list
                                                    (list 'list
                                                          ''quote
                                                          'redo-flat-fail))
                                              :ld-error-action :continue
                                              :ld-pre-eval-print t)))
                      ,@(and pbt succ label
                             `('(pprogn (newline (proofs-co state)
                                                 state)
                                        (pbt ',label)))))

; It seems a bit dodgy to call redo-flat from within code, but we see no reason
; to prohibit it.  In that case we need to specify a value for the following
; keyword.

                :ld-user-stobjs-modified-warning :same))))))

(defun cert-op (state)

; Possible return values:

; - t              ; Ordinary certification;
;                  ;   also the Complete procedure of provisional certification
; - :create-pcert  ; Pcertify (pcert0) procedure of provisional certification
; - :create+convert-pcert ; Pcertify but also creating .pcert1 file
; - :convert-pcert ; Convert (pcert1) procedure of provisional certification
; - :write-acl2x   ; Write .acl2x file
; - :write-acl2xu  ; Write .acl2x file, allowing uncertified sub-books
; - nil            ; None of the above

  (let ((certify-book-info (f-get-global 'certify-book-info state)))
    (and certify-book-info
         (or (access certify-book-info certify-book-info :cert-op)
             t))))

(defun eval-event-lst-environment (in-encapsulatep state)
  (let* ((x (if in-encapsulatep
                '(encapsulate)
              nil)))
    (case (cert-op state)
      ((nil :write-acl2x :write-acl2xu)
       x)
      ((t :create+convert-pcert)
       (cons 'certify-book x))
      (otherwise ; :create-pcert or :convert-pcert

; We need to avoid eliding locals for make-event forms when building the
; .pcert0 file, unless we are doing the :create+convert-pcert operation.  We
; might as well also not bother eliding locals for building the .pcert1 file as
; well, since ultimately we expect to use the pcert0-file's make-event
; expansions (but we could reconsider this decision if a reason arises).

       (cons 'pcert x)))))

(defun process-embedded-events (caller acl2-defaults-table skip-proofsp pkg
                                       ee-entry ev-lst index make-event-chk
                                       cert-data ctx state)

; Warning: This function uses set-w and hence may only be called within a
; revert-world-on-error.  See the statement of policy in set-w.

; This function is the heart of the second pass of encapsulate, include-book,
; and certify-book.  Caller is in fact one of the symbols 'encapsulate-pass-1,
; 'encapsulate-pass-2, 'include-book, 'certify-book, 'defstobj, or
; 'defabsstobj.  Note: There is no function encapsulate-pass-1, but it is still
; a ``caller.''

; Acl2-defaults-table is either a legal alist value for acl2-defaults-table or
; else is one of :do-not-install or :do-not-install!.  If an alist, then we may
; install a suitable acl2-defaults-table before executing the events in ev-lst,
; and the given acl2-defaults-table is installed as the acl2-defaults-table (if
; it is not already there) after executing those events.  But the latter of
; these is skipped if acl2-defaults-table is :do-not-install, and both are
; skipped if acl2-defaults-table is :do-not-install!.

; The name ee-entry stands for ``embedded-event-lst'' entry.  It is consed onto
; the embedded-event-lst for the duration of the processing of ev-lst.  The
; length of that list indicates how deep these evs are.  For example, if the
; embedded-event-lst is

;   ((defstobj ...)
;    (encapsulate nil)
;    (include-book ...)
;    (encapsulate ((p (x y) (nil nil) (nil)) ...)))

; then the ev-lst is the ``body'' of a defstobj, which occurs in the body of an
; encapsulate, which is in an include-book, which is in an encapsulate.

; The shape of an ee-entry is entirely up to the callers and the customers of
; the embedded-event-lst, with three exceptions:
; (a) the ee-entry must always be a consp;
; (b) if the car of the ee-entry is 'encapsulate then the cadr is the internal
;     form signatures of the functions being constrained; and
; (c) if the car of the ee-entry is 'include-book then the cadr is the
;     full-book-name.
; We refer to the signatures in (b) as insigs below and think of insigs as nil
; for all ee-entries other than encapsulates.

; Ev-lst is the list of alleged events.  Pkg is the value we should use for
; current-package while we are processing the events.  This affects how forms
; are prettyprinted.  It also affects how the prompt looks.

; We first extend the current world of state by insigs (if caller is
; 'encapsulate-pass-2) and extend the embedded event list by ee-entry.  We then
; extend further by doing each of events in ev-lst while ld-skip-proofsp is set
; to skip-proofsp, checking that they are indeed embedded-event-forms.  If that
; succeeds, we restore embedded-event-lst, install the world, and return.

; If caller is not 'encapsulate-pass-2, then the return value includes an
; expansion-alist that records the result of expanding away every make-event
; call encountered in the course of processing the given ev-lst.  Each pair (n
; . ev) in expansion-alist asserts that ev is the result of expanding away
; every make-event call during evaluation of the nth member of ev-lst (starting
; with index for the initial member of ev-lst), though if no such expansion
; took place then this pair is omitted.  If caller is 'certify-book, then the
; return value is the cons of this expansion-alist onto either the initial
; known-package-alist, if that has not changed, or else onto the index of the
; first event that changed the known-package-alist (where the initial
; in-package event has index 0).

; If caller is 'encapsulate-pass-2, then since the final world is in STATE, we
; use the value component of the non-erroneous return triple to return the
; world extended by the signatures (and the incremented depth).  That world,
; called proto-wrld3 in the encapsulate essay and below, is useful only for
; computing (via difference) the names introduced by the embedded events.  We
; still need the expansion-alist described in the preceding paragraph, and we
; also need the value returned by the last event.  So the value returned for
; 'encapsulate-pass-2 is a triple consisting of that value, the
; expansion-alist, and this proto-wrld3.

; If an error is caused by the attempt to embed the events, we print a warning
; message explaining and pass the error up.

; The world names used here are consistent with the encapsulate essay.

  (let* ((wrld1 (w state))
         (kpa (known-package-alist state))
         (old-embedded-event-lst
          (global-val 'embedded-event-lst wrld1))
         (new-embedded-event-lst
          (cons ee-entry old-embedded-event-lst))
         (in-local-flg (f-get-global 'in-local-flg state))

; We now declare the signatures of the hidden functions (when we're in pass 2
; of encapsulate), producing what we here call proto-wrld3.  We also extend the
; embedded event list by ee-entry.  After installing that world in state we'll
; execute the embedded events on it to produce the wrld3 of the encapsulation
; essay.

         (proto-wrld3
          (global-set 'embedded-event-lst new-embedded-event-lst
                      (cond
                       ((eq caller 'encapsulate-pass-2)
                        (intro-udf-lst (cadr ee-entry) (cddr ee-entry)
                                       in-local-flg wrld1 state))
                       (t wrld1))))
         (state (set-w 'extension proto-wrld3 state)))
    (er-progn
     (cond ((not (find-non-hidden-package-entry pkg kpa))
            (er soft 'in-package
                "The argument to IN-PACKAGE must be a known package name, but ~
                 ~x0 is not.  The known packages are~*1"
                pkg
                (tilde-*-&v-strings
                 '&
                 (strip-non-hidden-package-names kpa)
                 #\.)))
           (t (value nil)))

; If we really executed an (in-package-fn pkg state) it would do the check
; above and cause an error if pkg was unknown.  But we just bind
; current-package to pkg (with "unwind protection") and so we have to make the
; check ourselves.

     (mv-let (erp val/expansion-alist/final-kpa state)
       (state-global-let*
        ((current-package pkg)
         (cert-data cert-data)
         (skip-proofs-by-system

; When we pass in a non-nil value of skip-proofsp, we generally set
; skip-proofs-by-system to a non-nil value here so that install-event will not
; store a 'skip-proofs-seen marker in the world saying that the user has
; specified the skipping of proofs.  However, if we are already skipping proofs
; by other than the system, then we do not want to make such an exception.

          (let ((user-skip-proofsp
                 (and (ld-skip-proofsp state)
                      (not (f-get-global 'skip-proofs-by-system state)))))
            (and (not user-skip-proofsp)
                 skip-proofsp)))
         (ld-skip-proofsp skip-proofsp)
         (ld-always-skip-top-level-locals nil))
        (er-progn

; Once upon a time, under the same conditions on caller as shown below, we
; added '(logic) to the front of ev-lst before doing the eval-event-lst below.
; But if the caller is an include-book inside a LOCAL, then the (LOGIC) event
; at the front is rejected by chk-embedded-event-form.  One might wonder
; whether an erroneous ev-lst would have left us in a different state than
; here.  The answer is no.  If ev-lst causes an error, eval-event-lst returns
; whatever the state was at the time of the error and does not do any cleanup.
; The error is passed up to the revert-world-on-error we know is above us,
; which will undo the (logic) as well as anything else we changed.

; The above remark deals with include-book, but the issue is similar for
; defstobj except that we also need to handle ignored and irrelevant formals as
; well.  Actually we may only need to handle these in the case that we do not
; allow defstobj array resizing, for the resizing and length field functions.
; But for simplicity, we always lay them down for defstobj and defabsstobj.

         (cond ((eq acl2-defaults-table :do-not-install!)
                (value nil))
               ((eq caller 'include-book)

; The following is equivalent to (logic), without the PROGN (value :invisible).
; The PROGN is illegal in Common Lisp code because its ACL2 semantics differs
; from its CLTL semantics.  Furthermore, we can't write (TABLE
; acl2-defaults-table :defun-mode :logic) because, like PROGN, its CLTL
; semantics is different.

                (state-global-let*
                 ((inhibit-output-lst (cons 'summary
                                            (@ inhibit-output-lst))))
                 (table-fn 'acl2-defaults-table
                           '(:defun-mode :logic)
                           state
                           '(table acl2-defaults-table
                                   :defun-mode :logic))))
               ((member-eq caller ; see comments above
                           '(defstobj defabsstobj))
                (state-global-let*
                 ((inhibit-output-lst (cons 'summary
                                            (@ inhibit-output-lst))))
                 (er-progn (table-fn 'acl2-defaults-table
                                     '(:defun-mode :logic)
                                     state
                                     '(table acl2-defaults-table
                                             :defun-mode :logic))
                           (table-fn 'acl2-defaults-table
                                     '(:ignore-ok t)
                                     state
                                     '(table acl2-defaults-table
                                             :ignore-ok t))
                           (table-fn 'acl2-defaults-table
                                     '(:irrelevant-formals-ok t)
                                     state
                                     '(table acl2-defaults-table
                                             :irrelevant-formals-ok
                                             t)))))
               (t
                (value nil)))
         (mv-let
           (erp val expansion-alist final-kpa state)
           (pprogn
            (cond ((or (eq caller 'encapsulate-pass-1)
                       (eq caller 'certify-book))
                   (pprogn (f-put-global 'redo-flat-succ nil state)
                           (f-put-global 'redo-flat-fail nil state)))
                  (t state))
            (eval-event-lst index nil
                            ev-lst
                            (and (ld-skip-proofsp state)
                                 (not (eq caller 'certify-book)))
                            (eval-event-lst-environment
                             (in-encapsulatep new-embedded-event-lst
                                              nil)
                             state)
                            in-local-flg
                            nil make-event-chk
                            (cond ((eq caller 'certify-book) kpa)
                                  (t nil))
                            caller ctx (proofs-co state) state))
           (cond (erp (pprogn
                       (cond ((or (eq caller 'encapsulate-pass-1)
                                  (eq caller 'certify-book))
                              (update-for-redo-flat (- val index)
                                                    ev-lst
                                                    state))
                             (t state))
                       (mv erp val state)))
                 (t (er-progn
                     (if (member-eq acl2-defaults-table
                                    '(:do-not-install :do-not-install!))
                         (value nil)
                       (maybe-install-acl2-defaults-table
                        acl2-defaults-table state))
                     (value (list* val expansion-alist final-kpa))))))))
       (cond
        (erp

; The evaluation of the embedded events caused an error.  If skip-proofsp is t,
; then we have a local incompatibility (because we know the events were
; successfully processed while not skipping proofs earlier).  If skip-proofsp
; is nil, we simply have an inappropriate ev-lst.

         (cond
          ((member-eq caller '(defstobj defabsstobj))
           (value (er hard ctx
                      "An error has occurred while ~x0 was defining the ~
                       supporting functions.  This is supposed to be ~
                       impossible!  Please report this error to the ACL2 ~
                       implementors."
                      caller)))
          (t
           (pprogn
            (warning$ ctx nil
                      (cond
                       ((or (eq skip-proofsp nil)
                            (eq skip-proofsp t))
                        "The attempted ~x0 has failed while trying to ~
                         establish the admissibility of one of the (local or ~
                         non-local) forms in ~#1~[the body of the ~
                         ENCAPSULATE~/the book to be certified~].")
                       ((eq caller 'encapsulate-pass-2)
                        "The error reported above is the manifestation of a ~
                         local incompatibility.  See :DOC ~
                         local-incompatibility.  The attempted ~x0 has failed.")
                       (t "The error reported above indicates that this book ~
                           is incompatible with the current logical world.  ~
                           The attempted ~x0 has failed."))
                      (if (or (eq caller 'encapsulate-pass-1)
                              (eq caller 'encapsulate-pass-2))
                          'encapsulate
                        caller)
                      (if (eq caller 'encapsulate-pass-1) 0 1))
            (mv t nil state)))))
        (t

; The evaluation caused no error.  The world inside state is the current one
; (because nothing but events were evaluated and they each install the world).
; Pop the embedded event list and install that world.  We let our caller extend
; it with constraints if that is necessary.  We return proto-wrld3 so the
; caller can compute the difference attributable to the embedded events.  This
; is how the constraints are determined.

         (let ((state
                (set-w 'extension
                       (global-set 'embedded-event-lst
                                   old-embedded-event-lst
                                   (w state))
                       state)))
           (cond ((eq caller 'encapsulate-pass-2)
                  (value (list* (car val/expansion-alist/final-kpa)
                                (cadr val/expansion-alist/final-kpa)
                                proto-wrld3)))
                 ((eq caller 'certify-book)
                  (value (cdr val/expansion-alist/final-kpa)))
                 (t (value
                     (cadr val/expansion-alist/final-kpa)))))))))))

(defun constrained-functions (exported-fns sig-fns new-trips)

; New-trips is the list of triples introduced into wrld3 from proto-wrld3,
; where wrld3 is the world created from proto-wrld3 by the second pass of an
; encapsulate, the one in which local events have been skipped.  (See the
; encapsulate essay.)  We return all the functions in exported-fns that,
; according to the world segment represented by new-trips, have a member of
; sig-fns among their ancestors.  We include sig-fns in the result as well.

; We are allowed to return a larger set of functions, if for no other reason
; than that we can imagine adding (equal (foo x) (foo x)) for some foo in
; sig-fns to the ancestors of any member of exported-fn.

; Important:  The new-trips needs to be in the same order as in wrld3, because
; of the call of instantiable-ancestors below.

  (cond
   ((endp exported-fns) sig-fns)
   (t (let ((ancestors
             (instantiable-ancestors (list (car exported-fns)) new-trips nil)))
        (cond
         ((intersectp-eq sig-fns ancestors)
          (cons (car exported-fns)
                (constrained-functions (cdr exported-fns) sig-fns new-trips)))
         (t (constrained-functions (cdr exported-fns) sig-fns new-trips)))))))

(defun collect-logicals (names wrld)

; Names is a list of function symbols.  Collect the :logic ones.

  (cond ((null names) nil)
        ((logicp (car names) wrld)
         (cons (car names) (collect-logicals (cdr names) wrld)))
        (t (collect-logicals (cdr names) wrld))))

(defun exported-function-names (new-trips)
  (cond ((endp new-trips)
         nil)
        (t (let ((new-name (name-introduced (car new-trips) t)))

; Because of the second argument of t, above, new-name is known to be
; a function name.

             (cond (new-name
                    (cons new-name (exported-function-names (cdr new-trips))))
                   (t (exported-function-names (cdr new-trips))))))))

(defun get-subversives (fns wrld)
  (cond ((endp fns) nil)
        (t (let ((j (getpropc (car fns) 'justification nil wrld)))
             (cond ((and j
                         (access justification j :subversive-p))
                    (cons (car fns)
                          (get-subversives (cdr fns) wrld)))
                   (t (get-subversives (cdr fns) wrld)))))))

(defun ancestral-ffn-symbs-lst (lst trips ans)
  (let ((fns (instantiable-ffn-symbs-lst lst trips ans nil)))
    (instantiable-ancestors fns trips ans)))

(defun encapsulate-constraint (sig-fns exported-names new-trips wrld)

; This function implements the algorithm described in the first paragraph of
; the section of :DOC constraint labeled "Second cut at constraint-assigning
; algorithm."  A read of that paragraph may help greatly in understanding the
; comments below.

; Sig-fns is the list of functions appearing in the signature of an
; encapsulate.  Exported-names is the list of all functions introduced
; (non-locally) in the body of the encapsulate (it doesn't include sig-fns).
; New-trips is the list of property list triples added to the initial world to
; form wrld.  Wrld is the result of processing the non-local events in body.

; We return (mv constraints constrained-fns subversive-fns infectious-fns fns),
; where constraints is a list of the formulas that constrain all of the
; functions listed in constrained-fns.  Subversive-fns is a list of exported
; functions which are not ``tight'' wrt the initial world (see
; subversive-cliquep).  Infectious-fns is the list of fns (other than
; subversive-fns) whose defuns are in the constraint.  This could happen
; because some non-subversive definition is ancestral in the constraint.  Fns
; is the list of all exported-names not moved forward, i.e., for which some
; function in sig-fns is ancestral.

; We do not actually rearrange anything.  Instead, we compute the constraint
; formula generated by this encapsulate as though we had pulled certain events
; out before generating it.

  (assert$
   sig-fns
   (let* ((fns

; Here we implement the [Front] rule mentioned in the Structured Theory paper,
; i.e. where we (virtually) move every axiomatic event that we can to be in
; front of the encapsulate.  (We say "virtually" because we do not actually
; move anything, although we create a property list world that is essentially
; based our having done the moves.)  What's left is the list we define here:
; the function symbols introduced by the encapsulate for which the signature
; functions are ancestral.  Fns includes the signature functions.

           (constrained-functions
            (collect-logicals exported-names wrld)
            sig-fns
            new-trips))
          (subversive-fns
           (get-subversives exported-names wrld))
          (formula-lst1

; Having in essence applied the [Front] rule, the remaining work is related to
; the [Back] rule mentioned in the Structured Theory paper, in which certain
; axiomatic events are (virtually) moved to after the encapsulate event.  We
; collect up formulas that will definitely stay inside the encapsulate,
; avoiding of course formulas that are to be moved in front.  We start with
; subversive definitional axioms and then gather all non-definitional formulas
; for which some signature function is ancestral -- equivalently (and this is
; what we implement here), all non-definitional formulas that mention at least
; one function symbol in fns.

; A long comment in constraints-introduced explains why we collect up
; 'constraint-lst properties here, rather than restricting ourselves to
; formulas from defun and defchoose events.

           (constraints-introduced
            new-trips fns
            (constraints-list subversive-fns wrld nil nil)))
          (constrained-fns

; The functions to receive a constraint from this encapsulate are those that
; remain introduced inside the encapsulate: the sig-fns and subversive
; functions, and all functions ancestral in one or more of the above-collected
; formulas.  We intersect with fns because, as stated above, we do not want to
; include functions whose introducing axioms can be moved in front of the
; encapsulate.

           (intersection-eq fns
                            (ancestral-ffn-symbs-lst formula-lst1 new-trips
                                                     (append subversive-fns
                                                             sig-fns))))
          (infectious-fns

; The "infected" functions are those from the entire set of to-be-constrained
; functions (those introduced inside the encapsulate in spite of the [Front]
; and [Back] rules) that are neither signature functions nor subversive.

           (set-difference-eq
            (set-difference-eq constrained-fns subversive-fns)
            sig-fns))
          (constraints

; Finally, we obtain all constraints.  Recall that we built formula-lst1 above
; without including any definitions; so now we include those.  Perhaps we only
; need defun and defchoose axioms at this point, having already included
; constraint-lst properties; but to be safe we go ahead and collect all
; constraints.

; We apply remove-guard-holders[-weak] in order to clean up a bit.  Consider
; for example:

; (defun-sk foo (x) (forall e (implies (member e x) (integerp e))))

; If you then evaluate

; (getpropc 'foo-witness 'constraint-lst)

; you'll see a much simpler result, with return-last calls removed, than if we
; did not apply remove-guard-holders-weak-lst here.  Out of an abundance of
; caution (perhaps more than is necessary), we avoid removing guard holders
; from quoted lambdas by calling remove-guard-holders-weak-lst rather than
; remove-guard-holders-lst, i.e., by avoiding the application of
; possibly-clean-up-dirty-lambda-objects-lst.  That is, it might be sound to
; clean up dirty lambdas here, as is our convention when calling
; remove-guard-holders, but we are playing it safe here.  If that causes
; problems then we can think harder about whether it is sound.

           (remove-guard-holders-weak-lst
            (constraints-list infectious-fns wrld formula-lst1 nil)
            (remove-guard-holders-lamp))))
     (mv constraints constrained-fns subversive-fns infectious-fns fns))))

(defun bogus-exported-compliants (names exports-with-sig-ancestors sig-fns
                                        wrld)

; Names is a list of function symbols exported from an encapsulate event.
; Exports-with-sig-ancestors contains each element of names that has at least
; one signature function of that encapsulate among its ancestors.  We return
; those elements of names whose body or guard has at least one ancestor in
; sig-fns, except for those that are constrained, because the guard proof
; obligations may depend on local properties.  Consider the following example.

; (encapsulate
;  ((f (x) t))
;  (local (defun f (x) (declare (xargs :guard t)) (consp x)))
;  (defun g (x)
;    (declare (xargs :guard (f x)))
;    (car x)))

; Outside the encapsulate, we do not know that (f x) suffices as a guard for
; (car x).

; We considered exempting non-executable functions, but if we are to bother
; with their guard verification, it seems appropriate to insist that the guard
; proof obligation really does hold in the theory produced by the encapsulate,
; not merely in the temporary theory of the first pass of the encapsulate.

; See also the comment about this function in intro-udf.

  (cond ((endp names) nil)
        ((and (eq (symbol-class (car names) wrld) :common-lisp-compliant)
              (not (getpropc (car names) 'constrainedp nil wrld))

; We can only trust guard verification for (car names) if its guard proof
; obligation can be moved forward.  We could in principle save that proof
; obligation, or perhaps we could recompute it; and then we could check that no
; signature function is ancestral.  But an easy sufficient condition for
; trusting that the guard proof obligation doesn't depend on functions
; introduced in the encapsulate, and one that does not seem overly restrictive,
; is to insist that neither the body of the function nor its guard have any
; signature functions as ancestors.

              (or (member-eq (car names) exports-with-sig-ancestors)
                  (intersectp-eq sig-fns (instantiable-ancestors
                                          (all-fnnames
                                           (guard (car names) nil wrld))
                                          wrld
                                          nil))))
         (cons (car names)
               (bogus-exported-compliants
                (cdr names) exports-with-sig-ancestors sig-fns wrld)))
        (t (bogus-exported-compliants
            (cdr names) exports-with-sig-ancestors sig-fns wrld))))

(defun remove-type-prescription-cert-data (cert-data)
  (remove1-assoc-eq :type-prescription cert-data))

(defun encapsulate-return-value-p (val)
  (case-match val
    ((:return-value &) t)
    (& nil)))

(defun transparent-mismatch (transparent infectious-fns wrld)
  (cond ((endp infectious-fns) nil)

; We skip functions introduced by defun in subsidiary encapsulates, as we can
; only require :transparent to match for functions introduced in encapsulate
; signatures.

        ((or (not (getpropc (car infectious-fns) 'constrainedp nil wrld))
             (iff transparent
                  (transparent-fn-p (canonical-sibling (car infectious-fns)
                                                       wrld)
                                    wrld)))
         (transparent-mismatch transparent (cdr infectious-fns) wrld))
        (t
         (cons (car infectious-fns)
               (transparent-mismatch transparent (cdr infectious-fns) wrld)))))

(defun encapsulate-pass-2 (insigs kwd-value-list-lst ev-lst
                                  saved-acl2-defaults-table only-pass-p ctx
                                  state)

; Warning: This function uses set-w and hence may only be called within a
; revert-world-on-error.  See the statement of policy in set-w.

; This is the second pass of the encapsulate event.  We assume that the
; installed world in state is wrld1 of the encapsulate essay.  We assume that
; chk-acceptable-encapsulate1 has approved of wrld1 and
; chk-acceptable-encapsulate2 has approved of the wrld2 generated in with
; ld-skip-proofsp nil.  Insigs is the internal form signatures list.  We either
; cause an error and return a state in which wrld1 is current or else we return
; normally and return a state in which wrld3 of the essay is current.  In the
; case of normal return and only-pass-p = nil, the value is a list containing

; * constrained-fns - the functions for which a new constraint-lst will
;   be stored, each with a 'siblings property equal to constrained-fns

; * retval - the value returned

; * constraints - the corresponding list of constraints

; * exported-names - the exported names

; * subversive-fns - the subversive (non-tight) functions encountered

; * infectious-fns - list of (non-subversive) fns whose defun equations were
;   moved into the constraint

; However, if only-pass-p = t, then we return (cons expansion-alist retval)
; where expansion-alist maps, in reverse increasing order, indices of events in
; ev-lst to the result of expanding away make-event calls.

; This information is used by the output routines.

; Note:  The function could be declared to return six values, but we would
; rather use the standard state and error primitives and so it returns three.

  (let* ((wrld1 (w state))
         (saved-unknown-constraints-table
          (table-alist 'unknown-constraints-table wrld1)))
    (er-let* ((val/expansion-alist/proto-wrld3

; The following process-embedded-events, which requires world reversion on
; errors, is protected by virtue of being in encapsulate-pass-2, which also
; requires such reversion.

; Note: The proto-wrld3 returned below is wrld1 above extended by the
; signatures.  The installed world after this process-embedded-events has the
; non-local events of ev-lst in it.

               (state-global-let*
                ((in-local-flg

; As we start processing the events in the encapsulate, we are no longer in the
; lexical scope of LOCAL for purposes of disallowing setting of the
; acl2-defaults-table.

                  (and (f-get-global 'in-local-flg state)
                       'local-encapsulate)))
                (process-embedded-events
                 'encapsulate-pass-2
                 saved-acl2-defaults-table
                 'include-book
                 (current-package state)
                 (list* 'encapsulate insigs

; The non-nil final cdr signifies that we are in pass 2 of encapsulate; see
; context-for-encapsulate-pass-2.

                        (or kwd-value-list-lst
                            t))
                 ev-lst 0

; If only-pass-p is t then we need to allow make-event with :check-expansion
; that is not a cons.  Consider the following example.

; (encapsulate ()
;   (make-event '(defun test3 (x) (cons x x))))

; When this encapsulate skips its first pass, it will encounter the indicated
; make-event, for which :check-expansion is implicitly nil.  This would result
; in an error from the call of chk-embedded-event-form in eval-event-lst if
; that call were made with make-event-chk = t.

                 (not only-pass-p) ; make-event-chk
                 (if (null insigs)
                     (f-get-global 'cert-data state)

; By restricting the use of :type-prescription cert-data (from the first pass
; of the encapsulate, or in the case of including a book, from the book's
; certificate), we avoid potential risk of introducing a bug in the
; determination of constraints.  Perhaps we are being too conservative; for
; example, we are already careful (in putprop-type-prescription-lst) not to
; store a runic type-prescription rule for a subversive function.  But the
; potential downside of this extra care seems very small, and the upside is
; that we don't have to think about the issue!

                   (remove-type-prescription-cert-data
                    (f-get-global 'cert-data state)))
                 ctx state))))
      (let* ((expansion-alist (cadr val/expansion-alist/proto-wrld3))
             (proto-wrld3 (cddr val/expansion-alist/proto-wrld3))
             (wrld (w state))
             (new-trips (new-trips wrld proto-wrld3))
             (empty-p (and (null insigs)
                           (not (assoc-eq 'event-landmark new-trips))))
             (fast-cert-extension
              (and empty-p
                   (eq (fast-cert-mode state) t) ; optimization
                   (f-get-global 'certify-book-info state)
                   (assoc-eq 'top-level-cltl-command-stack new-trips)))
             (retval (if fast-cert-extension
                         :trivial-extension-for-fast-cert
                       (car val/expansion-alist/proto-wrld3))))
        (cond
         ((and empty-p
               (not fast-cert-extension))
          (let ((state (set-w 'retraction wrld1 state)))
            (value (cons :empty-encapsulate expansion-alist))))
         (t
          (pprogn
           (cond
            (fast-cert-extension ; hence empty-p

; Since empty-p is true, there are no events introduced by this encapsulate,
; presumably because all events in pass 2 are either local or redundant.
; Normally we consider this to be an "empty encapsulate" and we retract the
; world rather than to keep whatever properties may have been added to the
; world.  However, when certifying a book with fast-cert mode active, we need
; to preserve any extensions that have been made to the
; top-level-cltl-command-stack on behalf of non-local events that are redundant
; with existing local events.

; The extensions to the top-level-cltl-command-stack are for non-local
; redundant defun, defmacro, defconst, defchoose, defstobj, and defabsstobj
; events.  Rather than enumerate those event types, we just say "definition" in
; the following observation.

             (observation ctx
                          "This encapsulate event does not introduce any new ~
                           events, but it has encountered at least one ~
                           non-local definition that was redundant with an ~
                           existing local definition."))
            (t state))
           (let* ((exported-names (exported-function-names new-trips))
                  (unknown-constraints-table
                   (table-alist 'unknown-constraints-table (w state)))
                  (unknown-constraints-p
                   (and insigs ; unknown-constraints are for this encapsulate
                        (not (equal unknown-constraints-table
                                    saved-unknown-constraints-table))))
                  (transparent
                   (cadr (assoc-keyword :transparent
                                        (car kwd-value-list-lst)))))
             (cond
              ((and unknown-constraints-p exported-names)
               (er soft ctx
                   "A partial-encapsulate must introduce only the functions ~
                    listed in its signature.  However, the signature's list ~
                    of names, ~x0, is missing the function name~#1~[~/s~] ~
                    ~&1, also introduced by that encapsulate.  See :DOC ~
                    partial-encapsulate."
                   (strip-cars insigs)
                   exported-names))
              ((and unknown-constraints-p transparent)

; It's not allowed to attach to a function with unknown-constraints, so there
; is no point in making such a function transparent, since it can't receive an
; attachment (well, at least without a trust tag).  This restriction simplifies
; the implementation at least a little, for example by not being concerned
; about overwriting an unknown-constraints value for the 'attachment property
; by a transparent-rec value (with (make transparent-rec ...) below).

               (er soft ctx
                   "A partial-encapsulate must not specify :transparent t in ~
                    its signature.  However, the signature with list of names ~
                    ~x0 does just that.  See :DOC transparent-functions."
                   (strip-cars insigs)))

; At one time we added a case here to cause an error here when expansion-alist
; is non-nil and only-pass-p is nil (with an exception made for when
; redefinition is active).  Our expectation was that in this case, the
; expansion-alist created by the first pass makes it impossible to create an
; expansion-alist in the second pass.  However, Pete Manolios sent us an
; example in October, 2019 that turned out to show this expectation to be
; incorrect.  Here is a slightly simplified version of his example.

;   (make-event
;    '(encapsulate
;       nil
;       (defun f (x) x)
;       (make-event
;        (pprogn (princ$ 1 (standard-co state) state)
;                (value '(value-triple nil))))))
;
;   (encapsulate
;     nil
;     (defun g (x) x) ; probably any non-redundant event here is OK
;     (make-event
;      '(encapsulate
;         nil
;         (defun f (x) x)
;         (make-event
;          (pprogn (princ$ 2 (standard-co state) state)
;                  (value '(value-triple nil)))))))

; In the first pass, the inner encapsulate in the second top-level encapsulate
; is not seen to be redundant, because the make-event isn't yet expanded.  In
; the second pass, however, the make-event has been expanded everywhere so we
; can see the redundancy with the first top-level encapsulate by tracing
; redundant-encapsulatep:

;   1> (REDUNDANT-ENCAPSULATEP
;           NIL
;           ((DEFUN F (X) X)
;            (RECORD-EXPANSION
;                 (MAKE-EVENT (PPROGN (PRINC$ 2 (STANDARD-CO STATE) STATE)
;                                     (VALUE '(VALUE-TRIPLE NIL))))
;                 (VALUE-TRIPLE NIL)))
;           (ENCAPSULATE
;                NIL (DEFUN F (X) X)
;                (RECORD-EXPANSION
;                     (MAKE-EVENT (PPROGN (PRINC$ 2 (STANDARD-CO STATE) STATE)
;                                         (VALUE '(VALUE-TRIPLE NIL))))
;                     (VALUE-TRIPLE NIL)))
;           |current-acl2-world|)
;   <1 (REDUNDANT-ENCAPSULATEP
;           (ENCAPSULATE
;                NIL (DEFUN F (X) X)
;                (RECORD-EXPANSION
;                     (MAKE-EVENT (PPROGN (PRINC$ 1 (STANDARD-CO STATE) STATE)
;                                         (VALUE '(VALUE-TRIPLE NIL))))
;                     (VALUE-TRIPLE NIL))))

; That redundancy is stored in the expansion-alist produced by the second pass
; of the inner encapsulate.

; We have decided to ignore the expansion-alist from the second pass, rather
; than (for example) replacing original expansions.  After all, when we do the
; second pass of an encapsulate, we use the expansion-alist from the first
; pass.  What we want is that every later execution of the encapsulate with
; ld-skip-proofsp = 'include-book, whether from include-book or a superior
; encapsulate, will use the same expansion-alist as was used during the
; original second pass of the encapsulate: and again, that's the
; expansion-alist from the first pass.  Of course, ACL2 won't see the
; redundancy of the encapsulate during that later execution with
; ld-skip-proofsp = 'include-book, just as it did't see that redundancy during
; the original second pass of the encapsulate.  Of course, ACL2 will likely
; (always?) see that its sub-events that change the world are redundant.

; Note that here we are only talking about the (not only-pass-p) case.  If the
; second pass is the only pass, we simply process the events that we are given
; and we handle the resulting expansion-alist in the normal way.

              ((null insigs)
               (value (if only-pass-p
                          (cons expansion-alist retval)
                        (list nil retval nil exported-names))))
              (t

; We are about to collect the constraint generated by this encapsulate on the
; signature functions.  We ``optimize'' one common case: if this is a top-level
; encapsulation with a non-empty signature (so it introduces some constrained
; functions but no superior encapsulate does so), with no dependent
; clause-processor and no encapsulate in its body that introduces any
; constrained functions, then we may use the theorems [Front] and [Back] of the
; ``Structured Theory'' paper to ``rearrange'' the events within this
; encapsulate.  Otherwise, we do not rearrange things.  Of course, the whole
; point is moot if this encapsulate has an empty signature -- there will be no
; constraints anyway.

               (let* ((new-trips (new-trips wrld wrld1))
                      (sig-fns (strip-cars insigs)))
                 (mv-let
                   (constraints constrained-fns subversive-fns infectious-fns
                                exports-with-sig-ancestors)
                   (encapsulate-constraint sig-fns exported-names new-trips
                                           wrld)
                   (let ((transparent-mismatch

; We look for every member of infectious-fns that was introduced in a signature
; with :transparent value in disagreement with that of sig-fns.  Note that
; constrained-fns is the disjoint union of the signature functions (sig-fns),
; subversive-fns (all with 'justification property, hence not constrained), and
; infectious-fns.

                          (transparent-mismatch transparent infectious-fns
                                                wrld)))
                     (cond
                      (transparent-mismatch
                       (if transparent
                           (er soft ctx
                               "The signature~#0~[~/s~] of the proposed ~
                                encapsulate event ~#0~[specifies~/specify~] ~
                                :transparent t (for ~&0).  But function ~
                                symbol~#1~[~/s~] ~&1 ~#1~[is~/are~] not ~
                                marked as transparent in ~#1~[its subsidiary ~
                                encapsulate signature~/their subsidiary ~
                                encapsulate signatures~].  This is illegal; ~
                                see :DOC transparent-functions."
                               sig-fns transparent-mismatch)
                         (er soft ctx
                             "The signature~#0~[~/s~] of the proposed ~
                              encapsulate event ~#0~[does~/do~] not specify ~
                              :transparent t (for ~&0).  But function ~
                              symbol~#1~[~/s~] ~&1 ~#1~[is~/are~] marked with ~
                              :transparent t in ~#1~[its subsidiary ~
                              encapsulate signature~/their subsidiary ~
                              encapsulate signatures~].  This is illegal; see ~
                              :DOC transparent-functions."
                             sig-fns transparent-mismatch)))
                      (t
                       (let* ((wrld2
                               (putprop-constraints
                                (car sig-fns)
                                (remove1-eq (car sig-fns) constrained-fns)
                                (if unknown-constraints-p
                                    (cons *unknown-constraints*
                                          (all-fnnames1
                                           t
                                           constraints

; The following contains sig-fns.  That is arranged by
; set-unknown-constraints-supporters, and is enforced (in case the table is set
; directly rather than with set-unknown-constraints-supporters) by
; unknown-constraints-table-guard.

                                           (cdr (assoc-eq
                                                 :supporters
                                                 unknown-constraints-table))))
                                  constraints)
                                unknown-constraints-p
                                (if constrained-fns
                                    (assert$
                                     (subsetp-eq subversive-fns
                                                 constrained-fns)
                                     (assert$
                                      (subsetp-eq infectious-fns
                                                  constrained-fns)
                                      (putprop-x-lst1
                                       constrained-fns
                                       'siblings

; Normally we don't care which of the siblings is first, i.e., is the
; canonical-sibling.  But in the case that we are introducing transparent
; functions, we want it to be a function with a non-nil 'constrained property,
; so that we can store information about transparent functions there.

                                       (if (and transparent
                                                (not (member-eq
                                                      (car constrained-fns)
                                                      sig-fns)))
                                           (cons (car sig-fns)
                                                 (remove1 (car sig-fns)
                                                          constrained-fns))
                                         constrained-fns)
                                       (if transparent ; see comment above
                                           (putprop (car sig-fns)
                                                    'constrainedp
                                                    (make transparent-rec
                                                          :names nil)
                                                    wrld)
                                         wrld))))
                                  wrld)))
                              (state (set-w 'extension wrld2 state))
                              (bogus-exported-compliants
                               (bogus-exported-compliants
                                exported-names exports-with-sig-ancestors sig-fns
                                wrld2)))
                         (cond
                          (bogus-exported-compliants
                           (er soft ctx
                               "For the following function~#0~[~/s~] ~
                                introduced by this encapsulate event, guard ~
                                verification may depend on local properties ~
                                that are not exported from the encapsulate ~
                                event: ~&0.  Consider delaying guard ~
                                verification until after the encapsulate ~
                                event, for example by using :verify-guards ~
                                nil."
                               bogus-exported-compliants))
                          (t (value
                              (if only-pass-p
                                  (cons expansion-alist retval)
                                (list constrained-fns
                                      retval
                                      (if unknown-constraints-p
                                          *unknown-constraints*
                                        constraints)
                                      exported-names
                                      subversive-fns
                                      infectious-fns)))))))))))))))))))))

; Here I have collected a sequence of encapsulates to test the implementation.
; After each is an undo.  They are not meant to co-exist.  Just eval each
; of the forms in this comment.  You should never get an error.

; (set-state-ok t)
;
; (defun test (val)
;   (declare (xargs :mode :program))
;   (if val
;       'ok
;     (er hard 'test "This example failed!")))
;
; ; I start with a collection of simple encapsulates, primarily to test the
; ; handling of signatures in their three forms.  I need a stobj.
;
; (defstobj $s x y)
;
; ; Here is a simple, typical encapsulate.
; (encapsulate ((p (x) t))
;   (local (defun p (x) (declare (ignore x)) t))
;   (defthm booleanp-p (booleanp (p x))))
;
; (test
;  (equal
;   (getpropc 'p 'constraint-lst)
;   '((booleanp (P X)))))
;
; (u)
;
; ; The next set just look for errors that should never happen.
;
;   The following all cause errors.
;
;   (encapsulate (((p x) => x))
;                (local (defun p (x) x)))
;
;   (encapsulate ((p x) => x)
;                (local (defun p (x) x)))
;
;   (encapsulate (((p x $s) => (mv x $s)))
;                (local (defun p (x $s) (declare (xargs :stobjs ($s))) (mv x $s))))
;
;   (encapsulate (((p * state $s) => state))
;                (local (defun p (x state $s)
;                         (declare (xargs :stobjs nil) (ignore x $s))
;                         state)))
;
;   (encapsulate (((p * state *) => $s))
;                (local (defun p (x state $s)
;                         (declare (xargs :stobjs $s) (ignore x state))
;                         $s)))
;
;   ; Here are some of the "same" errors provoked in the old notation.
;
;   (encapsulate ((p (x $s) (mv * $s) :stobjs *))
;                (local (defun p (x $s) (declare (xargs :stobjs ($s))) (mv x $s))))
;
;   (encapsulate ((p (* state $s) state))
;                (local (defun p (x state $s)
;                         (declare (xargs :stobjs nil) (ignore x $s))
;                         state)))
;
;   (encapsulate ((p (y state $s) $s))
;                (local (defun p (x state $s)
;                         (declare (xargs :stobjs $s) (ignore x state))
;                         $s)))
;
;   (encapsulate ((p (x state y) $s))
;                (local (defun p (x state $s)
;                         (declare (xargs :stobjs $s) (ignore x state))
;                         $s)))
;
; ; The rest of my tests are concerned with the constraints produced.
;
; ; Here is one that contains a function that can be moved forward out
; ; of encapsulate, even though it is used in the constraint.  Note that
; ; not every theorem proved becomes a constraint.  The theorem evp-+ is
; ; moved forward too.
;
; (encapsulate ((p (x) t))
;   (local (defun p (x) (declare (ignore x)) 2))
;   (defun evp (n) (if (zp n) t (if (zp (- n 1)) nil (evp (- n 2)))))
;   (defthm evp-+ (implies (and (integerp i)
;                               (<= 0 i)
;                               (evp i)
;                               (integerp j)
;                               (<= 0 j)
;                               (evp j))
;                          (evp (+ i j))))
;   (defthm evp-p (evp (p x))))
;
; (test
;  (equal
;   (getpropc 'p 'constraint-lst)
;   '((EVP (P X)))))
;
; (u)
;
; ; This illustrates a function which uses the signature function p but
; ; which can be moved back out of the encapsulate.  The only constraint
; ; on p is (EVP (P X)).
;
; ; But if the function involves the constrained function, it cannot
; ; be moved forward.  It may be moved back, or it may become part of the
; ; constraint, depending on several things.
;
; ; Case 1.  The function uses p in a benign way and nothing is proved
; ; about the function.
;
; (encapsulate ((p (x) t))
;   (local (defun p (x) (ifix x)))
;   (defun mapp (x)
;     (if (consp x)
;         (cons (p (car x)) (mapp (cdr x)))
;       nil))
;   (defthm integerp-p (integerp (p x))))
;
; (test
;  (and (equal (getpropc 'p 'constraint-lst)
;              '((integerp (p x))))
;       (equal (getpropc 'mapp 'constraint-lst)
;              nil)))
;
; (u)
;
; ; The constraint, above, on p is (INTEGERP (P X)).
;
; ; Case 2.  The function is subversive, i.e., uses p in a way critical to
; ; its termination.
;
; (encapsulate ((p (x) t))
;   (local (defun p (x) (cdr x)))
;   (defthm len-p (implies (consp x) (< (len (p x)) (len x))))
;   (defun bad (x)
;     (if (consp x)
;         (not (bad (p x)))
;       t)))
;
; (test
;  (and (equal (getpropc 'p 'constraint-lst)
; ; Modified for v3-5:
;              (reverse '((EQUAL (BAD X)
;                                (IF (CONSP X)
;                                    (NOT (BAD (P X)))
;                                    'T))
; ;                        (IF (EQUAL (BAD X) 'T)
; ;                            'T
; ;                            (EQUAL (BAD X) 'NIL))
;                         (IMPLIES (CONSP X)
;                                  (< (LEN (P X)) (LEN X))))))
;       (equal (getpropc 'bad 'constraint-lst)
;              'p)))
;
; (u)
;
; ; The constraint above is associated both with p and bad.  That is, if you
; ; functionally instantiate p, the new function must satisfy the axiom for bad
; ; too, which means you must instantiate bad.  Similarly, if you instantiate
; ; bad, you must instantiate p.
;
; ; It would be better if you did this:
;
; (encapsulate ((p (x) t))
;   (local (defun p (x) (cdr x)))
;   (defthm len-p (implies (consp x) (< (len (p x)) (len x)))))
;
; (test
;  (equal (getpropc 'p 'constraint-lst)
;         '((IMPLIES (CONSP X)
;                    (< (LEN (P X)) (LEN X))))))
;
; ; The only constraint on p is
; ; (IMPLIES (CONSP X) (< (LEN (P X)) (LEN X))).
; ; Now you can define bad outside:
;
; (defun bad (x)
;   (declare (xargs :measure (len x)))
;   (if (consp x)
;       (not (bad (p x)))
;     t))
;
; (u)
; (u)
;
; ; Case 3.  The function uses p in a benign way but something is proved
; ; about the function, thus constraining p.
;
; (encapsulate ((p (x) t))
;   (local (defun p (x) (ifix x)))
;   (defun mapp (x)
;     (if (consp x)
;         (cons (p (car x)) (mapp (cdr x)))
;       nil))
;   (defthm mapp-is-a-list-of-ints
;     (integer-listp (mapp x))))
;
; (test
;  (and (equal (getpropc 'p 'constraint-lst)
;              '((EQUAL (MAPP X)
;                       (IF (CONSP X)
;                           (CONS (P (CAR X)) (MAPP (CDR X)))
;                           'NIL))
; ; No longer starting with v3-5:
; ;              (TRUE-LISTP (MAPP X))
;                (INTEGER-LISTP (MAPP X))))
;       (equal (getpropc 'mapp 'constraint-lst)
;              'p)))
;
; (u)
;
; ; The constraint above, on both p and mapp, is
; ; (AND (EQUAL (MAPP X)
; ;             (AND (CONSP X)
; ;                  (CONS (P (CAR X)) (MAPP (CDR X)))))
; ;      (TRUE-LISTP (MAPP X))
; ;      (INTEGER-LISTP (MAPP X)))
;
; ; Here is another case of a subversive definition, illustrating that
; ; we do not just check whether the function uses p but whether it uses
; ; p ancestrally.
;
; (encapsulate ((p (x) t))
;   (local (defun p (x) (cdr x)))
;   (defun bad1 (x) (p x))
;   (defun bad2 (x)
;     (if (consp x)
;         (not (bad2 (bad1 x)))
;       t)))
;
; (test
;  (and (equal (getpropc 'p 'constraint-lst)
;              '((EQUAL (BAD1 X) (P X))
;                (EQUAL (BAD2 X)
;                       (IF (CONSP X)
;                           (NOT (BAD2 (BAD1 X)))
;                           'T))
; ; No longer starting with v3-5:
; ;              (IF (EQUAL (BAD2 X) 'T)
; ;                  'T
; ;                  (EQUAL (BAD2 X) 'NIL))
;                ))
;       (equal (getpropc 'bad1 'constraint-lst)
;              'p)
;       (equal (getpropc 'bad2 'constraint-lst)
;              'p)
;       (equal (getpropc 'bad2 'induction-machine nil)
;              nil)))
;
;
; (u)
;
; (encapsulate ((p (x) t))
;   (local (defun p (x) (cdr x)))
;   (defun bad1 (x)
;     (if (consp x) (bad1 (cdr x)) (p x)))
;   (defun bad2 (x)
;     (if (consp x)
;         (not (bad2 (bad1 x)))
;       t)))
;
; (test
;  (and (equal (getprop 'p 'constraint-lst nil 'current-acl2-world (w state))
;              '((EQUAL (BAD1 X)
;                       (IF (CONSP X)
;                           (BAD1 (CDR X))
;                           (P X)))
;                (EQUAL (BAD2 X)
;                       (IF (CONSP X)
;                           (NOT (BAD2 (BAD1 X)))
;                           'T))
; ; No longer starting with v3-5:
; ;              (IF (EQUAL (BAD2 X) 'T)
; ;                  'T
; ;                  (EQUAL (BAD2 X) 'NIL))
;                ))
;       (equal (getprop 'bad1 'constraint-lst nil 'current-acl2-world (w state))
;              'p)
;       (equal (getprop 'bad2 'constraint-lst nil 'current-acl2-world (w state))
;              'p)
;       (not (equal (getprop 'bad1 'induction-machine nil
;                            'current-acl2-world (w state))
;                   nil))
;       (equal (getprop 'bad2 'induction-machine nil
;                       'current-acl2-world (w state))
;              nil)))
;
; (u)
;
; ; Once up a time we had a bug in encapsulate, because subversiveness was
; ; based on the induction machine rather than the termination machine
; ; and no induction machine is constructed for mutually recursive definitions.
; ; Here is an example that once led to unsoundness:
;
; (encapsulate
;  ((fn1 (x) t))
;  (local (defun fn1 (x)
;           (cdr x)))
;  (mutual-recursion
;   (defun fn2 (x)
;     (if (consp x)
;         (not (fn3 (fn1 x)))
;       t))
;   (defun fn3 (x)
;     (if (consp x)
;         (not (fn3 (fn1 x)))
;       t))))
;
; (test
;  (and (equal (getprop 'fn1 'constraint-lst nil 'current-acl2-world (w state))
; ; Reversed as shown starting with v3-5:
;              '((EQUAL (FN2 X)
;                       (IF (CONSP X)
;                           (NOT (FN3 (FN1 X)))
;                           'T))
; ; No longer starting with v3-5:
; ;              (IF (EQUAL (FN2 X) 'T)
; ;                  'T
; ;                  (EQUAL (FN2 X) 'NIL))
;                (EQUAL (FN3 X)
;                       (IF (CONSP X)
;                           (NOT (FN3 (FN1 X)))
;                           'T))
; ; No longer starting with v3-5:
; ;              (IF (EQUAL (FN3 X) 'T)
; ;                  'T
; ;                  (EQUAL (FN3 X) 'NIL))
;                ))
;       (equal (getprop 'fn2 'constraint-lst nil 'current-acl2-world (w state))
;              'fn1)
;       (equal (getprop 'fn3 'constraint-lst nil 'current-acl2-world (w state))
;              'fn1)
;       (equal (getprop 'fn2 'induction-machine nil
;                       'current-acl2-world (w state))
;              nil)
;       (equal (getprop 'fn3 'induction-machine nil
;                       'current-acl2-world (w state))
;              nil)))
;
; ; Now, fn1, fn2, and fn3 share both definitional constraints.
;
; ; It is possible to prove the following lemma
;
; (defthm lemma
;   (not (equal (fn1 '(a)) '(a)))
;   :rule-classes nil
;   :hints (("Goal" :use (:instance fn3 (x '(a))))))
;
; ; But in the unsound version it was then possible to functionally
; ; instantiate it, choosing the identity function for fn1, to derive
; ; a contradiction.  Here is the old killer:
;
; ; (defthm bad
; ;   nil
; ;   :rule-classes nil
; ;   :hints (("Goal" :use (:functional-instance lemma (fn1 identity)))))
;
; (u)
; (u)
;
; ; Now when you do that you have to prove an impossible theorem about
; ; fn3, namely
;
; ; (equal (fn3 x) (if (consp x) (not (fn3 x)) t))
;
; ; The only way to prove this is to show that nothing is a cons.
;
; ; This examples shows that a function can call a subversive one and
; ; not be subversive.
;
; (encapsulate ((p (x) t))
;   (local (defun p (x) (cdr x)))
;   (defun bad1 (x) (p x))            ; tight: non-recursive
;
;   (defun bad2 (x)                   ; not tight: recursive call involves
;     (if (consp x)                   ; a fn (bad1) defined inside the encap
;         (not (bad2 (bad1 x)))
;       t))
;   (defun bad3 (x)
;     (if (consp x)
;         (bad2 (bad3 (cdr x)))
;       nil)))                        ; tight: even though it calls bad2
;
; ; Bad2 is swept into the constraint because it is not tight (subversive).  Bad1
; ; is swept into it because it introduces a function (bad1) used in the enlarged
; ; constraint.  Bad3 is not swept in.  Indeed, bad3 is moved [Back].
;
; (test
;  (and (equal (getprop 'p 'constraint-lst nil 'current-acl2-world (w state))
;              '((EQUAL (BAD1 X) (P X))
;                (EQUAL (BAD2 X)
;                       (IF (CONSP X)
;                           (NOT (BAD2 (BAD1 X)))
;                           'T))
; ; No longer starting with v3-5:
; ;              (IF (EQUAL (BAD2 X) 'T)
; ;                  'T
; ;                  (EQUAL (BAD2 X) 'NIL))
;                ))
;       (equal (getprop 'bad1 'constraint-lst nil 'current-acl2-world (w state))
;              'p)
;       (equal (getprop 'bad2 'constraint-lst nil 'current-acl2-world (w state))
;              'p)
;       (equal (getprop 'bad3 'constraint-lst nil 'current-acl2-world (w state))
;              nil)
;       (equal (getprop 'bad2 'induction-machine nil
;                       'current-acl2-world (w state))
;              nil)
;       (not (equal (getprop 'bad3 'induction-machine nil
;                            'current-acl2-world (w state))
;                   nil))))
;
; (u)
;
; ; Now what about nested encapsulates?
;
; ; Let us first consider the two simplest cases:
;
; (encapsulate ((p (x) t))
;   (local (defun p (x) (declare (ignore x)) 23))
;   (encapsulate nil
;      (defthm lemma1 (equal x x) :rule-classes nil)
;      (defthm main (equal x x) :rule-classes nil))
;   (defthm integerp-p (integerp (p x))))
;
; ; We are permitted to rearrange this, because the inner encap has a nil
; ; signature.  So we get what we expect:
;
; (test
;  (equal
;   (getprop 'p 'constraint-lst nil 'current-acl2-world (w state))
;   '((integerp (P X)))))
;
; (u)
;
; ; The other simple case is
;
; (encapsulate nil
;    (defthm lemma1 (equal x x) :rule-classes nil)
;    (defthm main (equal x x) :rule-classes nil)
;    (encapsulate ((p (x) t))
;                 (local (defun p (x) (declare (ignore x)) 23))
;                 (defun benign (x)
;                   (if (consp x) (benign (cdr x)) x))
;                 (defthm integerp-p (integerp (p x)))))
;
; ; Note that benign doesn't constrain p, because the containing encap
; ; contains no sig fns.
;
; (test
;  (equal
;   (getprop 'p 'constraint-lst nil 'current-acl2-world (w state))
;   '((integerp (P X)))))
;
; (u)
;
; ; If we have a pair of encaps, each of which introduces a sig fn,
; ; we lost the ability to rearrange things in v3-6-1 but not v4-0:
;
; (encapsulate ((p1 (x) t))
;              (local (defun p1 (x) x))
;              (defun benign1 (x)
;                (if (consp x) (benign1 (cdr x)) t))
;              (defthm p1-constraint (benign1 (p1 x)))
;              (encapsulate  ((p2 (x) t))
;                            (local (defun p2 (x) x))
;                            (defun benign2 (x)
;                              (if (consp x) (benign2 (cdr x)) t))
;                            (defthm p2-constraint (benign2 (p2 x)))))
;
; (test
;  (and (equal (getprop 'p1 'constraint-lst nil 'current-acl2-world (w state))
;              '((BENIGN1 (P1 X))))
;       (equal (getprop 'p2 'constraint-lst nil 'current-acl2-world (w state))
;              '((BENIGN2 (P2 X))))
;       (equal (getprop 'benign2 'constraint-lst nil 'current-acl2-world (w state))
;              nil)
;       (equal (getprop 'benign1 'constraint-lst nil 'current-acl2-world (w state))
;              nil)))
;
; (u)
;
; (encapsulate ((f1 (x) t))
;              (local (defun f1 (x) (declare (ignore x)) 0))
;              (defun bad (x)
;                (if (consp x)
;                    (if (and (integerp (bad (cdr x)))
;                             (<= 0 (bad (cdr x)))
;                             (< (bad (cdr x)) (acl2-count x)))
;                        (bad (bad (cdr x)))
;                      (f1 x))
;                  0)))
;
; (test
;  (and (equal (getprop 'f1 'constraint-lst nil 'current-acl2-world (w state))
; ; No longer generates this constraint starting with v3-5:
; ;              '((EQUAL (BAD X)
; ;                       (IF (CONSP X)
; ;                           (IF (IF (INTEGERP (BAD (CDR X)))
; ;                                   (IF (NOT (< (BAD (CDR X)) '0))
; ;                                       (< (BAD (CDR X)) (ACL2-COUNT X))
; ;                                       'NIL)
; ;                                   'NIL)
; ;                               (BAD (BAD (CDR X)))
; ;                               (F1 X))
; ;                           '0)))
;              nil)
;       (equal
;        (getprop 'bad 'constraint-lst nil 'current-acl2-world (w state))
; ; No longer starting with v3-5:
; ;      'f1
;        nil
;        )
; ; No longer subversive, starting with v3-5:
; ;      (equal
;        (getprop 'bad 'induction-machine nil 'current-acl2-world (w state))
; ;       nil)
;        ))
;
; (u)
;
;
; ; Here is a sample involving defchoose.  In this example, the signature
; ; function is ancestral in the defchoose axiom.
;
; (encapsulate ((p (y x) t))
;              (local (defun p (y x) (member-equal y x)))
;              (defchoose witless x (y) (p y x))
;              (defthm consp-witless
;                (consp (witless y))
;                :rule-classes :type-prescription
;                :hints (("Goal" :use (:instance witless (x (cons y nil)))))))
;
; (test
;  (and (equal (getprop 'p 'constraint-lst nil 'current-acl2-world (w state))
;              '((IMPLIES (P Y X)
;                         ((LAMBDA (X Y) (P Y X)) (WITLESS Y) Y))
;                (CONSP (WITLESS Y))))
;       (equal
;        (getprop 'witless 'constraint-lst nil 'current-acl2-world (w state))
;        'p)
;       (equal
;        (getprop 'witless 'defchoose-axiom nil 'current-acl2-world (w state))
;        '(IMPLIES (P Y X)
;                  ((LAMBDA (X Y) (P Y X)) (WITLESS Y) Y)))))
;
; (u)
;
; ; and in this one it is not, indeed, the defchoose function can be
; ; moved to the [Front] even though it is used in the constraint of p.
;
; (encapsulate ((p (y x) t))
;              (local (defun p (y x) (member-equal y x)))
;              (defchoose witless x (y) (member-equal y x))
;              (defthm p-constraint (p y (witless y))
;                :hints (("Goal" :use (:instance witless (x (cons y nil)))))))
;
; (test
;  (and (equal (getprop 'p 'constraint-lst nil 'current-acl2-world (w state))
;              '((p y (witless y))))
;       (equal
;        (getprop 'witless 'constraint-lst nil 'current-acl2-world (w state))
;        nil)
;       (equal
;        (getprop 'witless 'defchoose-axiom nil 'current-acl2-world (w state))
;        '(IMPLIES (member-equal Y X)
;                  ((LAMBDA (X Y) (member-equal Y X)) (WITLESS Y) Y)))))
;
; (u)
;
; (quote (the end of my encapsulate tests -- there follow two undo commands))
; (u)
; (u)

(defun tilde-@-abbreviate-object-phrase (x)

; This function produces a tilde-@ phrase that describes the
; object x, especially if it is a list.  This is just a hack
; used in error reporting.

  (cond ((atom x) (msg "~x0" x))
        ((symbol-listp x)
         (cond ((< (length x) 3)
                (msg "~x0" x))
               (t
                (msg "(~x0 ... ~x1)"
                     (car x)
                     (car (last x))))))
        ((atom (car x))
         (cond ((and (consp (cdr x))
                     (atom (cadr x)))
                (msg "(~x0 ~x1 ...)"
                     (car x)
                     (cadr x)))
               (t
                (msg "(~x0 ...)"
                     (car x)))))
        ((atom (caar x))
         (cond ((and (consp (cdar x))
                     (atom (cadar x)))
                (msg "((~x0 ~x1 ...) ...)"
                     (caar x)
                     (cadar x)))
               (t
                (msg "((~x0 ...) ...)"
                     (caar x)))))
        (t "(((...) ...) ...)")))

(defun encapsulate-ctx (signatures form-lst)

; This function invents a suitable error context, ctx, for an
; encapsulate with the given signatures and form-lst.  The args have
; not been translated or checked.  Thus, this function is rough.
; However, we have to have some way to describe to the user which
; encapsulation is causing the problem, since we envision them often
; being nested.  Our guess is that the signatures, if non-nil, will be
; the most recognizable aspect of the encapsulate.  Otherwise, we'll
; abbreviate the form-lst.

  (cond
   (signatures
    (cond ((and (consp signatures)
                (consp (car signatures))
                (consp (caar signatures)))
           (msg "( ENCAPSULATE (~@0 ...) ...)"
                (tilde-@-abbreviate-object-phrase (car signatures))))
          (t
           (msg "( ENCAPSULATE ~@0 ...)"
                (tilde-@-abbreviate-object-phrase signatures)))))
   (form-lst
    (msg "( ENCAPSULATE NIL ~@0 ...)"
         (tilde-@-abbreviate-object-phrase (car form-lst))))
   (t "( ENCAPSULATE NIL)")))

(defun print-encapsulate-msg1 (insigs form-lst state)
  (declare (ignore insigs))
  (cond
   ((ld-skip-proofsp state) state)
   (t
    (io? event nil state
         (form-lst)
         (fms "To verify that the ~#0~[~/~n1 ~]encapsulated event~#0~[~/s~] ~
               correctly extend~#0~[s~/~] the current theory we will evaluate ~
               ~#0~[it~/them~].  The theory thus constructed is only ~
               ephemeral.~|~#2~[~%Encapsulated Event~#0~[~/s~]:~%~/~]"
              (list (cons #\0 form-lst)
                    (cons #\1 (length form-lst))
                    (cons #\2 (if (eq (ld-pre-eval-print state) :never) 1 0)))
              (proofs-co state)
              state nil)))))

(defun print-encapsulate-msg2 (insigs form-lst state)
  (declare (ignore insigs))
  (cond
   ((ld-skip-proofsp state) state)
   (t
    (io? event nil state
         (form-lst)
         (fms "End of Encapsulated Event~#0~[~/s~].~%"
              (list (cons #\0 form-lst))
              (proofs-co state)
              state nil)))))

(defun print-encapsulate-msg3/exported-names (insigs lst)

; This returns a list of tilde-@ phrases.  The list always has either
; 0 or 1 things in it.  The single element describes the exports of
; an encapsulation (if any).  Insigs is the list of internal form
; signatures of the constrained fns.

  (cond ((null lst)

; Say nothing if there are no additional names.

         nil)
        (insigs
         (list (msg "In addition to ~&0, we export ~&1.~|~%"
                    (strip-cars insigs)
                    lst)))
        (t (list (msg "We export ~&0.~|~%"
                      lst)))))

(defun print-encapsulate-msg3/constraints (constrained-fns constraints wrld)

; Note that constraints can be *unknown-constraints*, with the obvious meaning.

  (cond
   ((null constraints)

; It's tempting in this case to say something like, "No new constraints are
; associated with any function symbols."  However, one could argue with that
; statement, since DEFUN introduces constraints in some sense, for example.
; This problem does not come up if there are constrained functions, since in
; that case (below), we are honestly reporting all of the constraints on the
; indicated functions.  So, we simply print nothing in the present case.

    nil)
   ((null constrained-fns)
    (er hard 'print-encapsulate-msg3/constraints
        "We had thought that the only way that there can be constraints is if ~
         there are constrained functions.  See ~
         print-encapsulate-msg3/constraints."))
   ((eq constraints *unknown-constraints*)
    (list
     (msg "Unknown-constraints are associated with ~#0~[the function~/both of ~
           the functions~/every one of the functions~] ~&1.  See :DOC ~
           partial-encapsulate.~|~%"
          (let ((n (length constrained-fns)))
            (case n
              (1 0)
              (2 1)
              (otherwise 2)))
          constrained-fns)))
   (t (list
       (msg "The following constraint is associated with ~#0~[the ~
             function~/both of the functions~/every one of the functions~] ~
             ~&1:~|~%~p2~|"
            (let ((n (length constrained-fns)))
              (case n
                    (1 0)
                    (2 1)
                    (otherwise 2)))
            constrained-fns
            (untranslate (conjoin constraints) t wrld))))))

(defun print-encapsulate-msg3 (ctx insigs form-lst exported-names
                                   constrained-fns constraints-introduced
                                   subversive-fns infectious-fns
                                   wrld state)

; This function prints a sequence of paragraphs, one devoted to each
; constrained function (its arities and constraint) and one devoted to
; a summary of the other names created by the encapsulation.

  (cond
   ((ld-skip-proofsp state) state)
   (t
    (io? event nil state
         (infectious-fns ctx subversive-fns wrld constraints-introduced
                         constrained-fns exported-names insigs form-lst)
         (pprogn
          (fms "Having verified that the encapsulated event~#0~[ ~
                validates~/s validate~] the signatures of the ~
                ENCAPSULATE event, we discard the ephemeral theory ~
                and extend the original theory as directed by the ~
                signatures and the non-LOCAL events.~|~%~*1"
               (list
                (cons #\0 form-lst)
                (cons #\1
                      (list "" "~@*" "~@*" "~@*"
                            (append
                             (print-encapsulate-msg3/exported-names
                              insigs exported-names)
                             (print-encapsulate-msg3/constraints
                              constrained-fns constraints-introduced
                              wrld)
                             ))))
               (proofs-co state)
               state
               (term-evisc-tuple nil state))
          (print-defun-msg/signatures (strip-cars insigs) wrld state)
          (if subversive-fns
              (warning$ ctx "Infected"
                        "Note that ~&0 ~#0~[is~/are~] ``subversive.'' See ~
                         :DOC subversive-recursions.  Thus, ~#0~[its ~
                         definitional equation infects~/their definitional ~
                         equations infect~] the constraint of this ~
                         en~-cap~-su~-la~-tion.  Furthermore, ~#0~[this ~
                         function~/these functions~] will not suggest any ~
                         induction schemes or type-prescription rules to the ~
                         theorem prover. If possible, you should remove ~
                         ~#0~[this definition~/these definitions~] from the ~
                         encapsulate and introduce ~#0~[it~/them~] ~
                         afterwards.  A constraint containing a definitional ~
                         equation is often hard to use in subsequent ~
                         functional instantiations."
                        subversive-fns)
            state)
          (if infectious-fns
              (warning$ ctx "Infected"
                        "Note that the defining event~#0~[~/s~] for ~&0 ~
                         infect~#0~[s~/~] the constraint of this ~
                         en~-cap~-su~-la~-tion.  That can be caused because a ~
                         function ancestrally involves the constrained ~
                         functions of an encapsulate and is ancestrally ~
                         involved in the constraining theorems of those ~
                         functions.  In any case, if at all possible, you ~
                         should move ~#0~[this defining event~/these defining ~
                         events~] out of the encapsulation.  A constraint ~
                         containing the formula of such an event is often ~
                         hard to use in subsequent functional instantiations. ~
                         ~ See :DOC infected-constraints and perhaps :DOC ~
                         subversive-recursions for discussion of related ~
                         issues."
                        infectious-fns)
            state))))))

(mutual-recursion

(defun find-first-non-local-name (x wrld primitives state-vars)

; Keep this in sync with chk-embedded-event-form and primitive-event-macros;
; see comments below.

; This function is used heuristically to help check redundancy of encapsulate
; events.

; X is allegedly an embedded event form, though we do not guarantee this.  It
; may be a call of some user macro and thus completely unrecognizable to us.
; But it could be a call of one of our primitive fns.  We are interested in the
; question "If x is successfully executed, what is a logical name it will
; introduce?"  Since no user event will introduce nil, we use nil to indicate
; that we don't know about x (or, equivalently, that it is some user form we
; don't recognizer, or that it introduces no names, or that it is ill-formed
; and will blow up).  Otherwise, we return a logical name that x will create.
; We are interested only in returning symbols, not book-names or packages.

  (let ((val
         (case-match x

; We are typically looking at events inside an encapsulate form.  Below, we
; handle local and defun first, since these are the most common.  We then
; handle all event forms in (primitive-event-macros) that introduce a new name
; that is a symbol.  Finally, we deal with compound event forms that are
; handled by chk-embedded-event-form.  Note: As of this writing, it is
; surprising that make-event is not in (primitive-event-macros).  But we handle
; it here, too.

           (('local . &) nil)
           (('defun name . &) name)

; Others from (primitive-event-macros); see comment above.

           (('defaxiom name . &) name)
           (('defchoose name . &) name)
           (('defconst name . &) name)
           (('deflabel name . &) name)
           (('defmacro name . &) name)
           (('deftheory name . &) name)
           (('defuns (name . &) . &) name)
           (('defstobj name . &) name)
           (('defabsstobj name . &) name)
           (('defthm name . &) name)
           (('encapsulate (((name . &) arrow . &)
                           . &)
                          . &)
            (and (symbolp arrow)
                 (equal (symbol-name arrow) "=>")
                 name))
           (('encapsulate ((name . &)
                           . &)
                          . &)
            name)
           (('encapsulate nil . ev-lst)
            (find-first-non-local-name-lst ev-lst wrld primitives state-vars
                                           nil))
           (('mutual-recursion ('defun name . &) . &) name)
           (('make-event ('verify-termination-fn ('quote names)
                                                 'state))
            (and names (car names)))
           (('make-event . &) ; special case: no good way to get the name
            :make-event)
           (('progn . ev-lst)
            (find-first-non-local-name-lst ev-lst wrld primitives state-vars
                                           nil))
           (('verify-guards name . &) name)

; Keep the following in sync with chk-embedded-event-form; see comment above.

           ((sym . lst)
            (cond ((not (symbolp sym))
                   nil)
                  ((member-eq sym '(skip-proofs
                                    with-cbd
                                    with-current-package
                                    with-guard-checking-event
                                    with-output
                                    with-prover-step-limit
                                    with-prover-time-limit))
                   (find-first-non-local-name (car (last lst))
                                              wrld primitives state-vars))
                  ((member-eq sym primitives) nil)
                  ((getpropc (car x) 'macro-body nil wrld)
                   (mv-let
                    (erp expansion)
                    (macroexpand1-cmp x 'find-first-non-local-name wrld
                                      state-vars)
                    (and (not erp)
                         (find-first-non-local-name expansion wrld primitives
                                                    state-vars))))
                  (t nil)))
           (& nil))))
    (and (symbolp val)
         val)))

(defun find-first-non-local-name-lst (lst wrld primitives state-vars ans)

; Challenge: If lst is a true list of embedded event forms that is
; successfully processed with ld-skip-proofsp nil, name one name that
; would be created.  Now lst might not be a list of embedded event
; forms.  Or the forms might be doomed to cause errors or might be
; unrecognizable user macro calls.  So we return nil if we can't spot a
; suitable name.  Otherwise we return a name.  The only claim made is
; this: if we return non-nil and lst were successfully processed, then
; that name is a logical name that would be created.  Consequently, if
; that name is new in a world, we know that this lst has not been
; processed before.

  (cond ((atom lst) ans)
        (t (let ((ans2 (find-first-non-local-name (car lst) wrld primitives
                                                  state-vars)))
             (cond ((eq ans2 :make-event)
                    (find-first-non-local-name-lst (cdr lst) wrld primitives
                                                   state-vars :make-event))
                   (ans2)
                   (t (find-first-non-local-name-lst (cdr lst) wrld primitives
                                                     state-vars ans)))))))
)

(defun equal-mod-elide-locals1 (form)

; We assume that form can be translated.

  (cond ((atom form)
         form)
        ((eq (car form) 'local)
         *local-value-triple-elided*)
        ((member-eq (car form) '(skip-proofs
                                 with-cbd
                                 with-current-package
                                 with-guard-checking-event
                                 with-output
                                 with-prover-time-limit
                                 with-prover-step-limit
                                 record-expansion
                                 time$))
         (equal-mod-elide-locals1 (car (last form))))
        (t form)))

(mutual-recursion

(defun equal-mod-elide-locals (ev1 ev2)

; This function will ideally return true when (elide-locals-rec ev1) agrees
; with (elide-locals-rec ev2).  However, this function avoids consing.  This
; function also does a bit more than ignore top-level local events, as it also
; ignores certain wrappers even in non-local contexts.

  (let ((ev1 (equal-mod-elide-locals1 ev1))
        (ev2 (equal-mod-elide-locals1 ev2)))
    (cond
     ((equal ev1 ev2) t)
     ((not (eq (car ev1) (car ev2))) nil)
     ((eq (car ev1) 'progn)
      (equal-mod-elide-locals-lst (cdr ev1) (cdr ev2)))
     ((eq (car ev1) 'progn!)
      (let ((bindings-p1 (and (consp (cdr ev1))
                              (eq (cadr ev1) :state-global-bindings)))
            (bindings-p2 (and (consp (cdr ev2))
                              (eq (cadr ev2) :state-global-bindings))))
        (and (eq bindings-p1 bindings-p2)
             (cond (bindings-p1
                    (equal-mod-elide-locals-lst (cdddr ev1) (cdddr ev2)))
                   (t
                    (equal-mod-elide-locals-lst (cdr ev1) (cdr ev2)))))))
     ((eq (car ev1) 'encapsulate)
      (and (equal (cadr ev1) (cadr ev2))
           (equal-mod-elide-locals-lst (cddr ev1) (cddr ev2))))
     (t nil))))

(defun equal-mod-elide-locals-lst (lst1 lst2)
  (cond ((endp lst1) (null lst2))
        (t (and (equal-mod-elide-locals (car lst1) (car lst2))
                (equal-mod-elide-locals-lst (cdr lst1) (cdr lst2))))))
)

(defun corresponding-encap-events (old-evs new-evs r-e-p ans)

; The parameter r-e-p is for the "record expansions property" as discussed in a
; comment in function corresponding-encaps.

  (cond
   ((endp old-evs)
    (and (null new-evs)
         ans))
   ((endp new-evs)
    nil)
   (t (let ((old-ev (car old-evs))
            (new-ev (car new-evs)))
        (cond ((equal old-ev new-ev)
               (corresponding-encap-events (cdr old-evs) (cdr new-evs) r-e-p ans))
              ((and r-e-p
                    (eq (car old-ev) 'record-expansion)
                    (equal (cadr old-ev) new-ev))
               (corresponding-encap-events (cdr old-evs) (cdr new-evs)
                                           r-e-p :expanded))
              ((equal-mod-elide-locals old-ev new-ev)
               (corresponding-encap-events (cdr old-evs) (cdr new-evs)
                                           r-e-p :expanded))
              (t nil))))))

(defun corresponding-encaps (old new r-e-p)

; See the comment below for a discussion of parameter r-e-p.

  (assert$
   (eq (car new) 'encapsulate)
   (and (eq (car old) 'encapsulate)
        (true-listp new)
        (equal (cadr old) (cadr new))
        (corresponding-encap-events (cddr old)
                                    (cddr new)

; Warning: The following comment is referenced in :DOC redundant-encapsulate.
; If it is modified or moved, then consider modifying that documentation
; accordingly.

; The parameter r-e-p says whether to consider event E in the new encapsulate
; to correspond to an event (record-expansion E ...) in the old encapsulate.
; It is nil when this check is taking place during include-book, and otherwise
; is t.

; As noted in the Essay on Make-event, we defeat one of the criteria for events
; to "match up" (correspond) in an old and new encapsulate, when checking
; redundancy of the new encapsulate: the case that the old event is a call of
; record-expansion and the new event equals the first argument of that call.
; The example below shows why: these three books certified before adding the
; r-e-p argument to corresponding-encap-events, which we are setting here to
; nil during include-book.  After the addition of that argument, top.lisp no
; longer certifies.

;   $ cat sub-book-1.lisp
;   (in-package "ACL2")
;   (encapsulate ()
;     (record-expansion (defun f () 2)
;                       (defun f () 1)))
;   (defthm f-is-1
;     (equal (f) 1))
;   $ cat sub-book-2.lisp
;   (in-package "ACL2")
;   (encapsulate ()
;     (defun f () 2))
;   (defthm f-is-2
;     (equal (f) 2))
;   $ cat top.lisp
;   (in-package "ACL2")
;   (include-book "sub-book-1")
;   (include-book "sub-book-2")
;   (defthm nil-is-true
;     nil
;     :hints (("Goal" :use (f-is-1 f-is-2) :in-theory nil))
;     :rule-classes nil)
;   $

; Here is how one can think about the criterion mentioned above, i.e., for the
; new event E to be the first argument of the old event (record-expansion E
; ...).  When certifying a book, and also when evaluating events directly under
; LD, the expansion of a make-event call -- where that call might be the result
; of macroexpansion -- the expansion hasn't yet been determined, and ACL2 has a
; right to determine the expansion in any reasonable manner.  The criterion
; above, based on record-expansion in the event in the old encapsulate, is
; sufficiently reasonable.  However, when including a certified book, the
; expansion is already determined by the book's certificate -- assuming the
; book is certified, but we have decided not to complicate this code with a
; restriction to the certified case.  Theorems in the included book may well
; depend on that expansion, as in the examples sub-book-1.lisp and
; sub-book-2.lisp above.  It is not reasonable (or sound!) to change those
; expansions, which is why, in the include-book case, we pass nil for the
; "record expansions property" argument (r-e-p) of corresponding-encap-events.

; By the way, in ordinary usage as opposed to the counterfeit calls of
; record-expansion in sub-book-1.lisp and sub-book-2.lisp above, this r-e-p =
; nil restriction (below) in the include-book case is probably no restriction
; at all.  That's because the relevant event stored in the new encapsulate is
; itself likely a call of record-expansion, which is unlikely to be the first
; argument of record-expansion in the corresponding event of the old
; encapsulate.

                                    r-e-p
                                    t))))

(defun redundant-encapsulatep-result (x old-ev-wrld wrld state)
  (cond ((store-cltl-command-for-redundant-def state)
         (let ((event-tuple (cddr (car old-ev-wrld))))
           (cond ((access-event-tuple-local-p event-tuple)
                  (list* :update-top-level-cltl-command-stack
                         x
                         (new-top-level-cltl-command-stack
                          (access-event-tuple-depth event-tuple)
                          (global-val 'top-level-cltl-command-stack wrld)
                          (cdr old-ev-wrld))))
                 (t x))))
        (t x)))

(defun redundant-encapsulate-tuplep (event-form mode ruler-extenders vge
                                                event-number wrld wrld0 state
                                                r-e-p)

; We return non-nil iff the non-prehistoric (if that's where we start) part of
; wrld later than the given absolute event number (unless it's nil) contains an
; event-tuple whose form is essentially equal to event-form.  We return t if
; they are equal, else we return the old form.  See also the Essay on
; Make-event.

; See corresponding-encaps for a discussion of argument r-e-p.

  (cond ((or (null wrld)
             (and (eq (caar wrld) 'command-landmark)
                  (eq (cadar wrld) 'global-value)
                  (equal (access-command-tuple-form (cddar wrld))
                         '(exit-boot-strap-mode)))
             (and (integerp event-number)
                  (eq (cadar wrld) 'absolute-event-number)
                  (integerp (cddar wrld))
                  (<= (cddar wrld) event-number)))
         nil)
        ((and (eq (caar wrld) 'event-landmark)
              (eq (cadar wrld) 'global-value)
              (let* ((old-event-form (access-event-tuple-form (cddar wrld)))
                     (equal? (and (eq (car old-event-form) 'encapsulate)
                                  (corresponding-encaps
                                   old-event-form event-form r-e-p))))
                (and equal?
                     (let ((adt (table-alist 'acl2-defaults-table wrld)))
                       (and
                        (eq (default-defun-mode-from-table adt) mode)
                        (equal (default-ruler-extenders-from-table adt)
                               ruler-extenders)
                        (eql (default-verify-guards-eagerness-from-table adt)
                             vge)
                        (redundant-encapsulatep-result
                         (if (eq equal? :expanded)
                             old-event-form
                           t)
                         wrld wrld0 state)))))))
        (t (redundant-encapsulate-tuplep event-form mode ruler-extenders vge
                                         event-number (cdr wrld) wrld0 state
                                         r-e-p))))

(defun redundant-encapsulatep (signatures ev-lst event-form wrld state)

; We wish to know if is there an event-tuple in wrld that is redundant with
; event-form (see :doc redundant-encapsulate).  We do know that event-form is
; an encapsulate with the given two arguments.  We don't know if event-form
; will execute without error.  But suppose we could find a name among
; signatures and ev-lst that is guaranteed to be created if event-form were
; successful.  Then if that name is new, we know we won't find event-form in
; wrld and needn't bother looking.  If the name is old and was introduced by a
; corresponding encapsulate (in the sense that the signatures agree and each
; form of the new encapsulate either suitably agrees the corresponding form of
; the old encapsulate -- see corresponding-encaps), then the event is
; redundant.  Otherwise, if this correspondence test fails or if we can't even
; find a name, then we could suffer the search through wrld.  We have found a
; rather dramatic performance improvements (26% of the time cut when including
; community book centaur/sv/tutorial/alu) by doing what we do now, which is to
; avoid that search when we don't find such a name or any make-event call, even
; after macroexpansion.  But we expect most encapsulates to have a readily
; recognized name among their new args and most encapsulates are not redundant,
; so we think most of the time, we'll find a name and it will be new.

; If we find that the current encapsulate is redundant, then we return t unless
; the earlier corresponding encapsulate is not equal to it, in which case we
; return that earlier encapsulate, which is stored in expanded form.  See also
; the Essay on Make-event.  Otherwise we return nil.

  (cond
   (signatures
    (let ((name (case-match signatures
                  ((((name . &) arrow . &) . &)
                   (and (symbolp arrow)
                        (equal (symbol-name arrow) "=>")
                        name))
                  (((name . &) . &)
                   name))))
      (and name
           (symbolp name)
           (not (new-namep name wrld))
           (let* ((wrld-tail (lookup-world-index
                              'event
                              (getpropc name 'absolute-event-number 0 wrld)
                              wrld))
                  (event-tuple (cddr (car wrld-tail)))
                  (old-event-form (access-event-tuple-form
                                   event-tuple))
                  (equal? (corresponding-encaps
                           old-event-form
                           event-form
                           (null (global-val 'include-book-path wrld)))))
             (and
              equal?
              (let ((old-adt
                     (table-alist 'acl2-defaults-table wrld-tail))
                    (new-adt
                     (table-alist 'acl2-defaults-table wrld)))
                (and
                 (eq (default-defun-mode-from-table old-adt)
                     (default-defun-mode-from-table new-adt))
                 (equal (default-ruler-extenders-from-table old-adt)
                        (default-ruler-extenders-from-table new-adt))
                 (eql (default-verify-guards-eagerness-from-table
                        old-adt)
                      (default-verify-guards-eagerness-from-table
                        new-adt))
                 (redundant-encapsulatep-result (if (eq equal? :expanded)
                                                    old-event-form
                                                  t)
                                                wrld-tail wrld state))))))))
   (t (let* ((name0 (find-first-non-local-name-lst ev-lst
                                                   wrld
                                                   (primitive-event-macros)
                                                   (default-state-vars nil)
                                                   nil))
             (name (and (not (eq name0 :make-event)) name0)))
        (and name0
             (or (not name)

; A non-local name need not be found.  But if one is found, then redundancy
; fails if that name is new.

                 (not (new-namep name wrld)))
             (let ((new-adt (table-alist 'acl2-defaults-table wrld)))
               (redundant-encapsulate-tuplep
                event-form
                (default-defun-mode-from-table new-adt)
                (default-ruler-extenders-from-table new-adt)
                (default-verify-guards-eagerness-from-table new-adt)
                (and name
                     (getpropc name 'absolute-event-number nil wrld))
                wrld
                wrld
                state
                (null (global-val 'include-book-path wrld)))))))))

(defun mark-missing-as-hidden-p (a1 a2)

; A1 and a2 are known-package-alists.  Return the result of modifying a1 by
; marking the following non-hidden entries as hidden: those that are either
; missing from a2 or hidden in a2.

  (cond ((endp a1) nil)
        ((and (not (package-entry-hidden-p (car a1)))
              (let ((entry
                     (find-package-entry (package-entry-name (car a1)) a2)))
                (or (not entry)
                    (package-entry-hidden-p entry))))
         (cons (change-package-entry-hidden-p (car a1) t)
               (mark-missing-as-hidden-p (cdr a1) a2)))
        (t
         (cons (car a1)
               (mark-missing-as-hidden-p (cdr a1) a2)))))

(defun known-package-alist-included-p (a1 a2)

; Return true if every package-entry in a1 is present in a2, and moreover, is
; present non-hidden in a2 if present non-hidden in a1.

  (cond ((endp a1) t)
        (t (and (let ((a2-entry (find-package-entry
                                 (package-entry-name (car a1)) a2)))
                  (and a2-entry
                       (or (package-entry-hidden-p (car a1))
                           (not (package-entry-hidden-p a2-entry)))))
                (known-package-alist-included-p (cdr a1) a2)))))

(defun encapsulate-fix-known-package-alist (pass1-k-p-alist pass2-k-p-alist
                                                            wrld)

; Pass1-k-p-alist is the known-package-alist from the end of the first pass of
; an encapsulate, and we are now at the end of the second pass in the given
; world, wrld, where the known-package-alist is pass2-k-p-alist.  The latter
; may be missing some package-entries from the former because of defpkg events
; that were only executed under locally included books in the first pass.  We
; return the result of setting the known-package-alist of the given world by
; marking each package-entry in pass1-k-p-alist that is missing in the current
; world's known-package-alist with hidden-p equal to t.

; We only call this function when pass1-k-p-alist does not equal
; pass2-k-p-alist.  We don't rely on that, but this assumption explains why we
; don't optimize here by checking for equality.

; The call of known-package-alist-included-p below checks that the second pass
; does not introduce any packages beyond those introduced in the first pass,
; nor does the second pass "promote" any package to non-hidden that was hidden
; in the first pass.  We rely on this fact in order to use the
; known-package-alist from the first pass as a basis for the alist returned, so
; that any package-entry present in the second pass's alist is present in the
; result alist, and moreover is non-hidden in the result if non-hidden in the
; second pass's alist.

; In fact we believe that the known-package-alist at the end of the second pass
; of an encapsulate is the same as at the beginning of the encapsulate, since
; local events are all skipped and include-books are all local.  However, we do
; not rely on this belief.

  (assert$
   (known-package-alist-included-p pass2-k-p-alist pass1-k-p-alist)
   (global-set 'known-package-alist
               (mark-missing-as-hidden-p pass1-k-p-alist pass2-k-p-alist)
               wrld)))

(defun subst-by-position1 (alist lst index acc)

; See the comment in subst-by-position.

  (cond ((endp alist)
         (revappend acc lst))
        ((endp lst)
         (er hard 'subst-by-position1
             "Implementation error: lst is an atom, so unable to complete ~
              call ~x0."
             `(subst-by-position1 ,alist ,lst ,index ,acc)))
        ((eql index (caar alist))
         (subst-by-position1 (cdr alist) (cdr lst) (1+ index)
                             (cons (cdar alist) acc)))
        (t
         (subst-by-position1 alist (cdr lst) (1+ index)
                             (cons (car lst) acc)))))

(defun subst-by-position (alist lst index)

; Alist associates index-based positions in lst with values.  We
; return the result of replacing each element of lst with its corresponding
; value from alist.  Alist should have indices in increasing order and should
; only have indices i for which index+i is less than the length of lst.

  (cond (alist
         (cond ((< (caar alist) index)
                (er hard 'subst-by-position
                    "Implementation error: The alist in subst-by-position ~
                     must not start with an index less than its index ~
                     argument, so unable to compute ~x0."
                    `(subst-by-position ,alist ,lst ,index)))
               (t (subst-by-position1 alist lst index nil))))
        (t ; optimize for common case
         lst)))

(defun dfp-terms (stobjs-in formals)
  (declare (xargs :guard (and (symbol-listp formals)
                              (symbol-listp stobjs-in)
                              (eql (length formals)
                                   (length stobjs-in)))))
  (map-predicate 'dfp
                 (collect-by-position '(:df) stobjs-in formals)))

(defun intro-udf-guards (insigs kwd-value-list-lst wrld-acc wrld ctx state)

; Insigs is a list of signatures, each in the internal form (list fn formals
; stobjs-in stobjs-out); see chk-signature.  Kwd-value-list-lst corresponds
; positionally to insigs.  We return an extension of wrld-acc in which the
; 'guard property has been set according to insigs.

; Wrld is the world we used for translating guards.  Our intention is that it
; is used in place of the accumulator, wrld-acc, because it is installed.

  (cond
   ((endp insigs) (value wrld-acc))
   (t (er-let*
       ((tguard
         (let ((tail (assoc-keyword :GUARD (car kwd-value-list-lst))))
           (cond (tail (translate (cadr tail)
                                  t   ; stobjs-out for logic, not exec
                                  t   ; logic-modep
                                  nil ; known-stobjs
                                  ctx wrld state))
                 (t (value nil))))))
       (let* ((insig (car insigs))
              (fn (car insig))
              (formals (cadr insig))
              (stobjs-in (caddr insig))
              (stobjs (collect-non-nil-df stobjs-in))
              (stobj-terms (stobj-recognizer-terms stobjs wrld))
              (dfp-terms (dfp-terms stobjs-in formals)))
         (er-progn
          (cond (tguard (chk-free-vars fn formals tguard "guard for" ctx
                                       state))
                (t (value nil)))
          (intro-udf-guards
           (cdr insigs)
           (cdr kwd-value-list-lst)
           (putprop-unless fn 'guard
                           (cond (tguard (conjoin (append stobj-terms
                                                          dfp-terms
                                                          (list tguard))))
                                 (t (conjoin (append stobj-terms
                                                     dfp-terms))))
                           *t* wrld-acc)
           wrld ctx state)))))))

(defun intro-udf-global-stobjs (insigs kwd-value-list-lst wrld-acc)

; Insigs is a list of signatures, each in the internal form (list fn formals
; stobjs-in stobjs-out); see chk-signature.  Kwd-value-list-lst corresponds
; positionally to insigs.  We return an extension of wrld-acc in which the
; 'global-stobjs property has been set according to insigs.

  (cond
   ((endp insigs) wrld-acc)
   (t (intro-udf-global-stobjs
       (cdr insigs)
       (cdr kwd-value-list-lst)
       (putprop-unless (caar insigs)
                       'global-stobjs
                       (cadr (assoc-keyword :global-stobjs
                                            (car kwd-value-list-lst)))
                       nil wrld-acc)))))

(defun intro-udf-non-classicalp (insigs kwd-value-list-lst wrld)
  (cond ((endp insigs) wrld)
        (t (let* ((insig (car insigs))
                  (fn (car insig))
                  (kwd-value-list (car kwd-value-list-lst))
                  (tail (assoc-keyword :CLASSICALP kwd-value-list))
                  (val (if tail (cadr tail) t)))
             (intro-udf-non-classicalp (cdr insigs)
                                       (cdr kwd-value-list-lst)
                                       (putprop-unless fn
                                                       'classicalp
                                                       val
                                                       t ; default
                                                       wrld))))))

(defun assoc-proof-supporters-alist (sym alist)
  (cond ((endp alist) nil)
        ((if (consp (caar alist)) ; namex key is a consp
             (member-eq sym (caar alist))
           (eq sym (caar alist)))
         (car alist))
        (t (assoc-proof-supporters-alist sym (cdr alist)))))

(defun update-proof-supporters-alist-3 (names local-alist old new wrld)
  (cond ((endp names) (mv (reverse old) new))
        ((getpropc (car names) 'absolute-event-number nil wrld)

; We'd like to say that if the above getprop is non-nil, then (car names)
; is non-local.  But maybe redefinition was on and some local event redefined
; some name from before the encapsulate.  Oh well, redefinition isn't
; necessarily fully supported in every possible way, and that obscure case is
; one such way.  Note that we get here with a wrld that has already erased old
; properties of signature functions (if they are being redefined), via
; chk-acceptable-encapsulate; so at least we don't need to worry about those.

         (update-proof-supporters-alist-3
          (cdr names) local-alist
          (cons (car names) old)
          new
          wrld))
        (t
         (let ((car-names-supporters
                (cdr (assoc-proof-supporters-alist (car names) local-alist))))
           (update-proof-supporters-alist-3
            (cdr names) local-alist
            old
            (strict-merge-symbol< car-names-supporters new nil)
            wrld)))))

(defun posn-first-non-event (names wrld idx)
  (cond ((endp names) nil)
        ((getpropc (car names) 'absolute-event-number nil wrld)
         (posn-first-non-event (cdr names) wrld (1+ idx)))
        (t idx)))

(defun update-proof-supporters-alist-2 (names local-alist wrld)
  (let ((n (posn-first-non-event names wrld 0)))
    (cond ((null n) names)
          (t (mv-let (rest-old-event-names rest-new-names)
                     (update-proof-supporters-alist-3
                      (nthcdr n names) local-alist nil nil wrld)
                     (strict-merge-symbol<
                      (append (take n names) rest-old-event-names)
                      rest-new-names
                      nil))))))

(defun update-proof-supporters-alist-1 (namex names local-alist
                                              proof-supporters-alist
                                              wrld)
  (assert$
   names ; sanity check; else we wouldn't have updated at install-event
   (let ((non-local-names
          (update-proof-supporters-alist-2 names local-alist wrld)))
     (cond ((getpropc (if (symbolp namex) namex (car namex))
                      'absolute-event-number nil wrld)
; See comment for similar getprop call in  update-proof-supporters-alist-2.
            (mv local-alist
                (if non-local-names
                    (acons namex non-local-names proof-supporters-alist)
                  proof-supporters-alist)))
           (t (mv (acons namex non-local-names local-alist)
                  proof-supporters-alist))))))

(defun update-proof-supporters-alist (new-proof-supporters-alist
                                      proof-supporters-alist
                                      wrld)

; Both alists are indexed by namex values that occur in reverse order of
; introduction; for example, the caar (if non-empty) is the most recent namex.

  (cond ((endp new-proof-supporters-alist)
         (mv nil proof-supporters-alist))
        (t (mv-let
            (local-alist proof-supporters-alist)
            (update-proof-supporters-alist (cdr new-proof-supporters-alist)
                                           proof-supporters-alist
                                           wrld)
            (update-proof-supporters-alist-1
             (caar new-proof-supporters-alist)
             (cdar new-proof-supporters-alist)
             local-alist
             proof-supporters-alist
             wrld)))))

(defun install-proof-supporters-alist (new-proof-supporters-alist
                                       installed-wrld
                                       wrld)
  (let ((saved-proof-supporters-alist
         (global-val 'proof-supporters-alist installed-wrld)))
    (mv-let (local-alist proof-supporters-alist)
            (update-proof-supporters-alist
             new-proof-supporters-alist
             saved-proof-supporters-alist
             installed-wrld)
            (declare (ignore local-alist))
            (global-set 'proof-supporters-alist proof-supporters-alist wrld))))

(defun empty-encapsulate (ctx state)
  (pprogn (observation ctx
                       "The submitted encapsulate event has created no new ~
                        ACL2 events, and thus is leaving the ACL2 logical ~
                        world unchanged.  See :DOC encapsulate.")
          (value :empty-encapsulate)))

(defun cert-data-tp-from-runic-type-prescription (fn wrld)
  (let ((lst (getpropc fn 'type-prescriptions nil wrld)))
    (and lst
         (let* ((tp (car (last lst)))
                (rune (access type-prescription tp :rune)))
           (and (eq (base-symbol rune) fn)
                (assert$
                 (null (cddr rune))
                 (assert$
                  (equal (access type-prescription tp :term)
                         (fcons-term fn (formals fn wrld)))
                  (assert$
                   (null (access type-prescription tp :hyps))
                   (assert$
                    (null (access type-prescription tp :backchain-limit-lst))
                    tp)))))))))

(defun cert-data-tps-from-fns (fns wrld acc)

; Warning: this function ignores :program mode functions, as does the use of
; cert-data :type-prescription entries in general.  If later we want to include
; :program mode functions, we'll need to think about how to deal with the
; possibility that a function is first defined in :program mode and then
; reclassified into :logic mode.

; Note that fns may have duplicates, but this is harmless.

  (cond ((endp fns) acc)
        (t
         (cert-data-tps-from-fns
          (cdr fns)
          wrld
          (let ((fn (car fns)))
            (if (or (programp fn wrld)
                    (hons-get fn acc))
                acc
              (let ((tp (cert-data-tp-from-runic-type-prescription fn wrld)))
                (if tp
                    (hons-acons fn tp acc)
                  acc))))))))

(defun cert-data-for-certificate (fns translate-cert-data wrld)

; Warning: Consider all cert-data keys here and in all other functions with
; this warning.  There is no need to consider the key :pass1-saved here.
; Moreover, keep the order of keys here the same as the order of keys produced
; by cert-data-fal: this one is used by certify-book and that one by
; include-book.

  (acons :type-prescription
         (cert-data-tps-from-fns fns wrld nil)
         (acons :translate

; Note that we do not need to restrict translate-cert-data to fns even when
; fast-cert mode is active, since the world global 'translate-cert-data is not
; modified for local events.

; We avoid saving translate-cert-data if there has been redefinition (which
; would require a trust tag used during certification).  That may be overly
; conservative, especially since all bets are officially off when there is
; redefinition.  Moreover, we already avoid using a translate-cert-data-record
; during include-book if there is another record of the same type; see
; get-translate-cert-data-record, comment (a).  So we are simply using an
; abundance of caution here in a very rare case (redefinition during
; certify-book) using a very inexpensive check.

                (and (not (global-val 'redef-seen wrld))

; We could use (fast-alist-fork translate-cert-data nil) below, to accommodate
; the possibility that a function symbol might be associated initially with one
; record and then later with two records, thus shadowing the initial
; association.  Such shadowing cannot happen currently unless there is
; redefinition, and at any rate the elimination of shadowed pairs is optional,
; so we don't bother at this point.

                     (make-fast-alist translate-cert-data))
                nil)))

(defun top-level-user-fns-rec (cltl-command-lst acc)
  (cond ((endp cltl-command-lst) acc)
        (t (top-level-user-fns-rec
            (cdr cltl-command-lst)
            (if (eq (caar cltl-command-lst) 'defuns)
                (reverse-strip-cars (cdddr (car cltl-command-lst))
                                    acc)
              acc)))))

(defun top-level-user-fns (cltl-command-lst acc)

; This function returns a list of all function symbols introduced in wrld that
; meet all of the following criteria: they are introduced non-locally, at the
; top level (not under an included book), and after the boot-strap.  They are
; returned in reverse order of their introduction in wrld.

; Note: The list returned by this function may have duplicates due to
; reclassifying a function from program mode to logic mode and also (though
; this shouldn't happen during certification) redefinition.

  (cond ((endp cltl-command-lst) (reverse acc))
        (t (top-level-user-fns
            (cdr cltl-command-lst)
            (if (eq (caar cltl-command-lst) 'defuns)
                (reverse-strip-cars (cdddr (car cltl-command-lst))
                                    acc)
              acc)))))

(defun cert-data-tps-1 (defs wrld acc)
  (cond
   ((endp defs) acc)
   (t
    (let ((fn (caar defs)))
      (cert-data-tps-1
       (cdr defs)
       wrld
       (cond
        ((or (programp fn wrld)
             (hons-get fn acc))
         acc)
        (t
         (hons-acons fn
                     (cert-data-tp-from-runic-type-prescription fn wrld)
                     acc))))))))

(defun cert-data-tps (old-wrld new-wrld installed-wrld acc)

; Installed-wrld is the currently-installed world (otherwise this function
; could be very slow).  New-wrld is a tail (i.e., some nthcdr) of
; installed-wrld.  Old-wrld is a tail of new-wrld.  At the top level, we return
; a fast-alist whose keys are function symbols in :logic mode (with respect to
; installed-wrld) defined after old-wrld in new-wrld, and whose value for key
; fn is the runic type-prescription for fn in installed-wrld, if any, else nil.
; In general, acc is a fast-alist and we extend acc to a fast-alist that
; includes the key-value pairs described above.

  (cond ((equal old-wrld new-wrld) acc)
        (t
         (cert-data-tps
          old-wrld
          (cdr new-wrld)
          installed-wrld
          (cond
           ((and (eq (caar new-wrld) 'cltl-command)
                 (eq (cadar new-wrld) 'global-value)
                 (eq (car (cddr (car new-wrld))) 'defuns)
                 (not (eq (cadr (cddr (car new-wrld))) :program)))
            (cert-data-tps-1 (cdddr (cddr (car new-wrld)))
                             installed-wrld
                             acc))
           (t acc))))))

(defun cert-data-pass1-saved (old-wrld new-wrld)

; Warning: Consider all cert-data keys here and in all other functions with
; this warning.

; New-wrld is the currently-installed world (otherwise this function could be
; very slow).  Old-wrld is a tail of new-wrld.  We return an alist mapping
; :pass1-saved to t and :type-prescription to a cert-data entry.  That entry is
; a fast-alist whose keys are function symbols in :logic mode (with respect to
; new-wrld) defined after old-wrld in new-wrld, and whose value for key fn is
; the runic type-prescription for fn in new-wrld, if any, else nil.

; This structure is read only during the include-book phase of certify-book and
; the second pass of encapsulate, neither of which allows the use of saved
; translate information from the first pass.  So we do not consider the
; :translate key here.

  (acons :type-prescription
         (cert-data-tps old-wrld new-wrld new-wrld nil)
         (acons :pass1-saved
                t
                nil)))

(defun functional-substitution-p (alist wrld)

; We assume that alist is a valid translated functional substitution for some
; world.  The only question here is whether every function symbol is a
; :logic-mode function symbol in wrld.

  (cond ((endp alist) t)
        (t (let ((fn1 (caar alist))
                 (fn2 (cdar alist)))
             (and (function-symbolp fn1 wrld)
                  (if (symbolp fn2)
                      (and (function-symbolp fn2 wrld)
                           (logicp fn2 wrld))
                    (case-match fn2
                      (('lambda & x)
                       (logic-termp x wrld))
                      (& (er hard 'functional-substitution-p
                             "Unexpected entry in alleged functional ~
                              substitution:~x0"
                             (car alist)))))
                  (functional-substitution-p (cdr alist) wrld))))))

(defun new-proved-functional-instances-alist (old new wrld acc)

; Wrld is a world.  New is an extension of old, where both are lists of
; proved-functional-instances-alist-entry records.  We return the extension of
; old obtained by restricting new to those records whose names all exist in
; wrld, where we assume that all records in old meet that criterion.

  (cond ((equal old new) (revappend acc old))
        (t
         (new-proved-functional-instances-alist
          old
          (cdr new) wrld
          (let* ((rec (car new))
                 (name
                  (access proved-functional-instances-alist-entry rec
                          :constraint-event-name))
                 (restricted-alist
                  (access proved-functional-instances-alist-entry rec
                          :restricted-alist))
                 (behalf-of-event-name
                  (access proved-functional-instances-alist-entry rec
                          :behalf-of-event-name)))
            (cond
             ((and (logicp name wrld)
                   (functional-substitution-p restricted-alist wrld))
              (cond ((and (symbolp behalf-of-event-name)
                          (formula behalf-of-event-name nil wrld))
                     (cons rec acc))
                    (t (cons (change proved-functional-instances-alist-entry
                                     rec
                                     :behalf-of-event-name 0)
                             acc))))
             (t acc)))))))

(defmacro fast-alist-free-cert-data-on-exit (cert-data form)

; Warning: Consider all cert-data keys here and in all other functions with
; this warning.  There is no need to consider the key :pass1-saved here.

  `(let* ((cert-data-to-free ,cert-data)
          (cert-data-entry-tp-to-free
           (cdr (assoc-eq :type-prescription cert-data-to-free))))
     (fast-alist-free-on-exit
      cert-data-entry-tp-to-free
      (let ((cert-data-entry-tr-to-free
             (cdr (assoc-eq :translate cert-data-to-free))))
        (fast-alist-free-on-exit
         cert-data-entry-tr-to-free
         (check-vars-not-free (cert-data-to-free
                               cert-data-entry-tp-to-free
                               cert-data-entry-tr-to-free)
                              ,form))))))

(defun encapsulate-fn (signatures ev-lst state event-form)

; Important Note:  Don't change the formals of this function without reading
; the *initial-event-defmacros* discussion in axioms.lisp.

; The Encapsulate Essay

; The motivation behind this event is to permit one to extend the theory by
; introducing function symbols, and theorems that describe their properties,
; without completely tying down the functions or including all of the lemmas
; and other hacks necessary to lead the system to the proofs.  Thus, this
; mechanism replaces the CONSTRAIN event of Nqthm.  It also offers one way of
; getting some name control, comparable to scopes.  However, it is better than
; just name control because the "hidden" rules are not just apparently hidden,
; they simply don't exist.

; Encapsulate takes two main arguments.  The first is a list of
; "signatures" that describe the function symbols to be hidden.  By
; signature we mean the formals, stobjs-in and stobjs-out of the
; function symbol.  The second is a list of events to execute.  Some
; of these events are tagged as "local" events and the others are not.
; Technically, each element of ev-lst is either an "event form" or
; else an s-expression of the form (LOCAL ev), where ev is an "event
; form."  The events of the second form are the local events.
; Informally, the local events are present only so that we can justify
; (i.e., successfully prove) the non-local events.  The local events
; are not visible in the final world constructed by an encapsulation.

; Suppose we execute an encapsulation starting with ld-skip-proofsp nil in
; wrld1.  We will actually make two passes through the list of events.  The
; first pass will execute each event, proving things, whether it is local or
; not.  This will produce wrld2.  In wrld2, we check that every function symbol
; in signatures is defined and has the signature alleged.  Then we back up to
; wrld1, declare the hidden functions with the appropriate signatures
; (producing what we call proto-wrld3) and replay only the non-local events.
; (Note: if redefinitions are allowed and are being handled by query, the user
; will be presented with two queries for each redefining non-local event.
; There is no assurance that he answers the same way both times and different
; worlds may result.  C'est la vie avec redefinitions.)  During this replay we
; skip proofs.  Having constructed that world we then collect all of the
; theorems that mention any of the newly-introduced functions and consider the
; resulting list as the constraint for all those functions.  (This is a
; departure from an earlier, unsound implementation, in which we only collected
; theorems mentioning the functions declared in the signature.)  However, we
; "optimize" by constructing this list of theorems using only those
; newly-introduced functions that have as an ancestor at least one function
; declared in the signature.  In particular, we do not introduce any
; constraints if the signature is empty, which is reasonable since in that
; case, we may view the encapsulate event the same as we view a book.  At any
; rate, the world we obtain by noting this constraint on the appropriate
; functions is called wrld3, and it is the world produced by a successful
; encapsulation.  By putting enough checks on the kinds of events executed we
; can guarantee that the formulas assumed to create wrld3 from wrld1 are
; theorems that were proved about defined functions in wrld2.

; This is a non-trivial claim and will be the focus of much of our discussion
; below.  This discussion could be eliminated if the second pass consisted of
; merely adding to wrld1 the formulas of the exported names, obtained from
; wrld2.  We do not do that because we want to be able to execute an
; encapsulation quickly if we process one while skipping proofs.  That is,
; suppose the user has produced a script of some session, including some
; encapsulations, and the whole thing has been processed with ld-skip-proofsp
; nil, once upon a time.  Now the user wants to assume that script and and
; continue -- i.e., he is loading a "book".

; Suppose we hit the encapsulation when skipping proofs.  Suppose we are
; again in wrld1 (i.e., processing the previous events of this script
; while skipping proofs has inductively left us in exactly the same
; state as when we did them with proofs).  We are given the event list
; and the signatures.  We want to do here exactly what we did in the
; second pass of the original proving execution of this encapsulate.
; Perhaps more informatively put, we want to do in the second pass of
; the proving execution exactly what we do here -- i.e., the relative
; paucity of information available here (we only have wrld1 and not
; wrld2) dictates how we must handle pass two back there.  Remember, our
; goal is to ensure that the final world we create, wrld3, is absolutely
; identical to that created above.

; Our main problem is that the event list is in untranslated form.
; Two questions arise.

; (1) If we skip an event because it is tagged LOCAL, how will we know
; we can execute (or even translate) the subsequent events without
; error?  For example, suppose one of the events skipped is the
; defmacro of deflemma, and then we see a (deflemma &).  We will have
; to make sure this doesn't happen.  The key here is that we know that
; the second pass of the proving execution of this encapsulate did
; whatever we're doing and it didn't cause an error.  But this is an
; important point about the proving execution of an encapsulate: even
; though we make a lot of checks before the first pass, it is possible
; for the second pass to fail.  When that happens, we'll revert back
; to wrld1 for sanity.  This is unfortunate because it means the user
; will have to suffer through the re-execution of his event list
; before seeing if he has fixed the last error.  We should eventually
; provide some sort of trial encapsulation mechanism so the user can
; see if he's got his signatures and exports correctly configured.

; (2) How do we know that the formulas generated during the second
; pass are exactly the same as those generated during the first pass?
; For example, one of the events might be:

; (if (ld-skip-proofsp state)
;     (defun foo () 3)
;     (defun foo () 2))

; In this case, (foo) would be 2 in wrld2 but 3 in wrld3.

; The key to the entire story is that we insist that the event list
; consist of certain kinds of events.  For lack of a better name, we
; call these "embedded event forms".  Not everything the user might
; want to type in an interactive ACL2 session is an embedded event
; form!  Roughly speaking, an event form translates to a PROGN of
; "primitive events", where the primitive events are appropriate calls
; of such user-level functions as defun and defthm.  By "appropriate"
; we mean STATE only appears where specified by the stobjs-in for each
; event.  The other arguments, e.g., the name of a defthm, must be
; occupied by state free terms -- well, almost.  We allow uses of w so
; that the user can compute things like gensyms wrt the world.  In a
; rough analogy with Lisp, the events are those kinds of commands that
; are treated specially when they are seen at the top-level of a file
; to be compiled.

; Events have the property that while they take state as an argument
; and change it, their changes to the world are a function only of the
; world (and their other arguments).  Because of this property, we
; know that if s1 and s1' are states containing the same world, and s2
; and s2' are the states obtained by executing an event on the two
; initial states, respectively, then the worlds of s2 and s2' are
; equal.

; Thus ends the encapsulate essay.

  (let ((ctx (encapsulate-ctx signatures ev-lst)))
    (with-ctx-summarized
     ctx
     (let* ((wrld1 (w state))
            (saved-proved-functional-instances-alist
             (global-val 'proved-functional-instances-alist wrld1))
            (saved-acl2-defaults-table
             (table-alist 'acl2-defaults-table wrld1))
            (event-form (or event-form
                            (list* 'encapsulate signatures ev-lst))))
       (revert-world-on-error
        (let ((r (redundant-encapsulatep signatures ev-lst event-form wrld1
                                         state)))
          (cond
           (r
            (mv-let (r new-top-level-cltl-command-stack)
              (if (and (consp r)
                       (eq (car r) :update-top-level-cltl-command-stack))
                  (mv (cadr r) (cddr r))
                (mv r nil))
              (pprogn
               (if (eq r t)
                   state
                 (f-put-global 'last-make-event-expansion r state))
               (er-progn
                (if new-top-level-cltl-command-stack
                    (let ((state
                           (set-w 'extension
                                  (global-set?
                                   'top-level-cltl-command-stack
                                   new-top-level-cltl-command-stack
                                   wrld1
                                   (global-val 'top-level-cltl-command-stack
                                               wrld1))
                                  state)))
                      (maybe-add-event-landmark state))
                  (value nil))
                (stop-redundant-event
                 ctx state
                 :extra-msg
                 (and (not (eq r t))
                      "(This event is redundant with a previous encapsulate ~
                       event even though the two might not be equal; see :DOC ~
                       redundant-encapsulate.)"))))))
           ((and (not (eq (ld-skip-proofsp state) 'include-book))
                 (not (eq (ld-skip-proofsp state) 'include-book-with-locals))
                 (not (eq (ld-skip-proofsp state) 'initialize-acl2)))

; Ld-skip-proofsp is either t or nil.  But whatever it is, we will be
; processing the LOCAL events.  We are no longer sure why we do so when
; ld-skip-proofsp is t, but a reasonable theory is that in such a case, the
; user's intention is to do everything that one does other than actually
; calling prove -- so in particular, we do both passes of an encapsulate.

            (er-let*
                ((trip (chk-acceptable-encapsulate1 signatures ev-lst
                                                    ctx wrld1 state)))
              (let* ((insigs (car trip))
                     (names (strip-cars insigs))
                     (kwd-value-list-lst (cadr trip))
                     (wrld1 (cddr trip)))
                (pprogn
                 (set-w 'extension
                        (global-set 'proof-supporters-alist nil wrld1)
                        state)
                 (print-encapsulate-msg1 insigs ev-lst state)
                 (er-let*
                     ((expansion-alist
                       (state-global-let*
                        ((in-local-flg

; As we start processing the events in the encapsulate, we are no longer in the
; lexical scope of LOCAL for purposes of disallowing setting of the
; acl2-defaults-table.

                          (and (f-get-global 'in-local-flg state)
                               'local-encapsulate)))
                        (process-embedded-events
                         'encapsulate-pass-1
                         saved-acl2-defaults-table
                         (ld-skip-proofsp state)
                         (current-package state)
                         (list 'encapsulate insigs)
                         ev-lst 0 nil

; If the value V of state global 'cert-data is non-nil, then presumably we are
; including a book, and thus we aren't even here, i.e., we aren't executing
; pass 1 of encapsulate.  (Actually, an exception could be during make-event
; expansion; but cert-data is not saved from make-event expansion, so that
; shouldn't be a problem as long as the expected event is generated by the
; expansion.)  But just to be safe, we pass nil below rather than V, since we
; want to be sure not to use V in local events.  (Imagine that after this
; encapsulate there is a global defun of foo that is associated in the global
; cert-data with information from the local defun of foo inside the present
; encapsulate.)

                         nil ; cert-data
                         ctx state))))
                   (let* ((wrld2 (w state))
                          (post-pass-1-skip-proofs-seen
                           (global-val 'skip-proofs-seen wrld2))
                          (post-pass-1-include-book-alist-all
                           (global-val 'include-book-alist-all wrld2))
                          (post-pass-1-pcert-books
                           (global-val 'pcert-books wrld2))
                          (post-pass-1-ttags-seen
                           (global-val 'ttags-seen wrld2))
                          (post-pass-1-proof-supporters-alist
                           (global-val 'proof-supporters-alist wrld2))
                          (post-pass-1-cert-replay
                           (global-val 'cert-replay wrld2))
                          (post-pass-1-proved-functional-instances-alist
                           (global-val 'proved-functional-instances-alist wrld2))
                          (cert-data

; We currently save cert-data only for trivial encapsulates.  See the Essay on
; Cert-data.

                           (and (null insigs)
                                (cert-data-pass1-saved wrld1 wrld2))))
                     (fast-alist-free-cert-data-on-exit
                      cert-data
                      (state-global-let*
                       ((cert-data cert-data))
                       (pprogn
                        (print-encapsulate-msg2 insigs ev-lst state)
                        (er-progn
                         (chk-acceptable-encapsulate2 insigs kwd-value-list-lst
                                                      wrld2 ctx state)
                         (let* ((pass1-kpa
                                 (global-val 'known-package-alist wrld2))
                                (new-ev-lst
                                 (subst-by-position expansion-alist ev-lst 0))
                                (state (set-w 'retraction wrld1 state))
                                (new-event-form
                                 (and expansion-alist
                                      (list* 'encapsulate signatures
                                             new-ev-lst))))
                           (er-let* ((temp

; The following encapsulate-pass-2 is protected by the revert-world-on
; error above.
                                      (encapsulate-pass-2
                                       insigs
                                       kwd-value-list-lst
                                       new-ev-lst
                                       saved-acl2-defaults-table nil ctx state)))
                             (pprogn
                              (f-put-global 'last-make-event-expansion
                                            new-event-form
                                            state)
                              (cond
                               ((eq (car temp) :empty-encapsulate)
                                (empty-encapsulate ctx state))
                               (t
                                (let* ((wrld3 (w state))
                                       (constrained-fns (nth 0 temp))
                                       (retval (nth 1 temp))
                                       (constraints-introduced (nth 2 temp))
                                       (exports (nth 3 temp))
                                       (subversive-fns (nth 4 temp))
                                       (infectious-fns (nth 5 temp))
                                       (final-proved-fnl-inst-alist
                                        (and

; The following test that constrained-fns is nil is an optimization, since
; otherwise we won't use final-proved-fnl-inst-alist.  See the comment below
; where final-proved-fnl-inst-alist is used; if we change that, then this
; optimization might no longer be suitable.

                                         (null constrained-fns)
                                         (new-proved-functional-instances-alist
                                          saved-proved-functional-instances-alist
                                          post-pass-1-proved-functional-instances-alist
                                          wrld3
                                          nil)))
                                       (pass2-kpa
                                        (global-val 'known-package-alist
                                                    wrld3))
                                       (eq-pass12-kpa
                                        (equal pass1-kpa pass2-kpa)))
                                  (pprogn
                                   (if (eq retval
                                           :trivial-extension-for-fast-cert)
                                       (assert$
                                        (and (null insigs)
                                             (null exports)
                                             (null constrained-fns)
                                             (null constraints-introduced)
                                             (null subversive-fns)
                                             (null infectious-fns))
                                        state)
                                     (print-encapsulate-msg3
                                      ctx insigs new-ev-lst exports
                                      constrained-fns constraints-introduced
                                      subversive-fns infectious-fns wrld3
                                      state))
                                   (er-let*
                                       ((wrld3a (intro-udf-guards
                                                 insigs
                                                 kwd-value-list-lst
                                                 (intro-udf-global-stobjs
                                                  insigs
                                                  kwd-value-list-lst
                                                  wrld3)
                                                 wrld3 ctx state))
                                        #+:non-standard-analysis
                                        (wrld3a (value
                                                 (intro-udf-non-classicalp
                                                  insigs kwd-value-list-lst
                                                  wrld3a))))
                                     (install-event
                                      (cond
                                       ((encapsulate-return-value-p retval)
                                        (cadr retval))
                                       ((null names) t)
                                       ((null (cdr names)) (car names))
                                       (t names))
                                      (or new-event-form event-form)
                                      'encapsulate
                                      (or names 0)
                                      nil nil
                                      t
                                      ctx
                                      (let* ((wrld4
                                              (if eq-pass12-kpa
                                                  wrld3a
                                                (encapsulate-fix-known-package-alist
                                                 pass1-kpa pass2-kpa wrld3a)))
                                             (wrld5 (global-set?
                                                     'ttags-seen
                                                     post-pass-1-ttags-seen
                                                     wrld4
                                                     (global-val 'ttags-seen
                                                                 wrld3)))
                                             (wrld6 (install-proof-supporters-alist
                                                     post-pass-1-proof-supporters-alist
                                                     wrld3
                                                     wrld5))
                                             (wrld7 (cond
                                                     ((or (global-val 'skip-proofs-seen

; We prefer that an error report about skip-proofs in certification world be
; about a non-local event.

                                                                      wrld3)
                                                          (null
                                                           post-pass-1-skip-proofs-seen))
                                                      wrld6)
                                                     (t (global-set
                                                         'skip-proofs-seen
                                                         post-pass-1-skip-proofs-seen
                                                         wrld6))))
                                             (wrld8 (global-set?
                                                     'include-book-alist-all
                                                     post-pass-1-include-book-alist-all
                                                     wrld7
                                                     (global-val
                                                      'include-book-alist-all
                                                      wrld3)))
                                             (wrld9 (global-set?
                                                     'pcert-books
                                                     post-pass-1-pcert-books
                                                     wrld8
                                                     (global-val
                                                      'pcert-books
                                                      wrld3)))
                                             (wrld10
                                              (if (and post-pass-1-cert-replay
                                                       (not eq-pass12-kpa)
                                                       (not (global-val
                                                             'cert-replay
                                                             wrld3)))

; The 'cert-replay world global supports the possible avoidance of rolling back
; the world after the first pass of certify-book, before doing the local
; incompatibility check using include-book.  We believe that at one time we
; only set cert-replay in install-event, but that led to a bug in handling
; hidden defpkg events: see the Essay on Hidden Packages for relevant
; background, and see community books directory misc/hidden-defpkg-checks/ for
; an example of a soundness bug related to hidden defpkg events.  Notice though
; that there is no such concern if eq-pass12-kpa holds, i.e., if the
; known-package-alist is the same after the first pass as after the second
; pass, i.e., no packages have become hidden or disappeared with the second
; pass.  But wait: Suppose we are certifying a book B and there is an earlier
; local include-book that introduces package P, and a local include-book in
; this encapsulate also introduces P.  Would we somehow be missing P as a
; hidden defpkg, since we are ignoring it here when setting 'cert-replay?  No,
; because that earlier local include-book would already have set cert-replay.

; Warning: Keep this in sync with the setting of 'cert-replay in install-event
; (and its callee, set-cert-replay-p), which is for events that are local or
; are evaluated with relaxed guard-checking.  Unlike that case, we do not need
; to check below in the certify-book-info case that we are outside
; include-book.  That's because if we were inside include-book, then we would
; not be here because the test (not (eq (ld-skip-proofsp state)
; 'include-book)), above, would be false -- well, except maybe in a weird
; make-event case, but if we set cert-replay a bit too aggressively here in
; very rare cases, that's OK.

                                                  (global-set
                                                   'cert-replay
                                                   (if (f-get-global
                                                        'certify-book-info
                                                        state)
                                                       t
                                                     (cons
                                                      (cons (- (max-absolute-command-number
                                                                wrld3))
                                                            nil)
                                                      (scan-to-command
                                                       wrld1)))
                                                   wrld9)
                                                wrld9))
                                             (wrld11
                                              (if (null constrained-fns)

; If there are constrained functions, we probably can still store proved
; functional instances that don't depend on the newly-constrained functions, by
; conservativity.  But it seems reasonably unlikely that this case needs to be
; added, and it would take some thought (could perhaps easily be done in an
; unsound way).  So we'll keep it simple here, and perhaps add that additional
; support only when requested.  If so, the consider the binding of
; final-proved-fnl-inst-alist, where there is an optimization that will likely
; need to be changed.

                                                  (global-set
                                                   'proved-functional-instances-alist
                                                   final-proved-fnl-inst-alist
                                                   wrld10)
                                                wrld10)))
                                        wrld11)
                                      state)))))))))))))))))))

           (t ; (ld-skip-proofsp state) = 'include-book
;                                         'include-book-with-locals or
;                                         'initialize-acl2

; We quietly execute our second pass.

            (er-let*
                ((trip (chk-signatures signatures ctx wrld1 state)))
              (let* ((insigs (car trip))
                     (names (strip-cars insigs))
                     (kwd-value-list-lst (cadr trip))
                     (wrld1 (cddr trip)))
                (pprogn
                 (set-w 'extension wrld1 state)
                 (er-let*

; The following encapsulate-pass-2 is protected by the revert-world-on
; error above.

                     ((expansion-alist0/retval
                       (encapsulate-pass-2
                        insigs kwd-value-list-lst ev-lst saved-acl2-defaults-table
                        t ctx state)))
                   (let* ((empty-encapsulate-p
                           (eq (car expansion-alist0/retval) :empty-encapsulate))
                          (expansion-alist
                           (if empty-encapsulate-p
                               (cdr expansion-alist0/retval)
                             (car expansion-alist0/retval)))
                          (retval (and (not empty-encapsulate-p) ; else unused
                                       (cdr expansion-alist0/retval)))
                          (wrld3 (w state))
                          (new-event-form
                           (and expansion-alist
                                (list* 'encapsulate signatures
                                       (subst-by-position expansion-alist
                                                          ev-lst
                                                          0)))))
                     (pprogn
                      (f-put-global 'last-make-event-expansion
                                    new-event-form
                                    state)
                      (cond
                       (empty-encapsulate-p
                        (empty-encapsulate ctx state))
                       (t
                        (er-let*
                            ((wrld3a (intro-udf-guards
                                      insigs kwd-value-list-lst
                                      (intro-udf-global-stobjs
                                       insigs
                                       kwd-value-list-lst
                                       wrld3)
                                      wrld3 ctx state))
                             #+:non-standard-analysis
                             (wrld3a (value (intro-udf-non-classicalp
                                             insigs kwd-value-list-lst wrld3a))))
                          (install-event (cond
                                          ((encapsulate-return-value-p retval)
                                           (cadr retval))
                                          ((null names) t)
                                          ((null (cdr names)) (car names))
                                          (t names))
                                         (if expansion-alist
                                             new-event-form
                                           event-form)
                                         'encapsulate
                                         (or names 0)
                                         nil nil
                                         nil ; irrelevant, since we are skipping proofs
                                         ctx

; We have considered calling encapsulate-fix-known-package-alist on wrld3a, just
; as we do in the first case (when not doing this on behalf of include-book).
; But we do not see a need to do so, both because all include-books are local
; and hence skipped (hence the known-package-alist has not changed from before
; the encapsulate), and because we do not rely on tracking packages during
; include-book, :puff (where ld-skip-proofsp is include-book-with-locals), or
; initialization.

                                         wrld3a
                                         state)))))))))))))))
     :event-type 'encapsulate)))

(defun progn-fn1 (ev-lst progn!p bindings state)

; Important Note:  Don't change the formals of this function without reading
; the *initial-event-defmacros* discussion in axioms.lisp.

; If progn!p is nil, then we have a progn and bindings is nil.  Otherwise we
; have a progn! and bindings is a list of bindings as for state-global-let*.

  (let ((ctx (cond (ev-lst
                    (msg "( PROGN~s0 ~@1 ...)"
                         (if progn!p "!" "")
                         (tilde-@-abbreviate-object-phrase (car ev-lst))))
                   (t (if progn!p "( PROGN!)" "( PROGN)"))))
        (in-encapsulatep
         (in-encapsulatep (global-val 'embedded-event-lst (w state)) nil)))
    (with-ctx-summarized
     ctx
     (revert-world-on-error
      (state-global-let*
       ((inside-progn-fn1 t))
       (mv-let
         (erp val expansion-alist ignore-kpa state)
         (pprogn
          (f-put-global 'redo-flat-succ nil state)
          (f-put-global 'redo-flat-fail nil state)
          (eval-event-lst
           0 nil
           ev-lst
           (or (ld-skip-proofsp state)
               progn!p) ; quietp
           (eval-event-lst-environment in-encapsulatep state)
           (f-get-global 'in-local-flg state)
           nil
           (if progn!p
               :non-event-ok

; It is unknown here whether make-event must have a consp :check-expansion, but
; if this progn is in such a context, chk-embedded-event-form will check that
; for us.

             nil)
           nil
           'progn-fn1 ctx (proofs-co state) state))
         (declare (ignore ignore-kpa))
         (pprogn
          (if erp
              (update-for-redo-flat val ev-lst state)
            state)
          (cond ((eq erp 'non-event)
                 (er soft ctx
                     "PROGN may only be used on legal event forms (see :DOC ~
                    embedded-event-form).  Consider using ER-PROGN instead."))
                (erp

; The component events are responsible for reporting errors.

                 (silent-error state))
                (t (pprogn (f-put-global 'last-make-event-expansion
                                         (and expansion-alist
                                              (cons (if progn!p 'progn! 'progn)
                                                    (if bindings
                                                        (assert$
                                                         progn!p
                                                         `(:state-global-bindings
                                                           ,bindings
                                                           ,@(subst-by-position
                                                              expansion-alist
                                                              ev-lst
                                                              0)))
                                                      (subst-by-position
                                                       expansion-alist
                                                       ev-lst
                                                       0))))
                                         state)
                           (value (and (not (f-get-global 'acl2-raw-mode-p
                                                          state))

; If we allow a non-nil value in raw-mode (so presumably we are in progn!, not
; progn), then it might be a bad-lisp-objectp.  Of course, in raw-mode one can
; assign bad lisp objects to state globals which then become visible out of
; raw-mode -- so the point here isn't to make raw-mode sound.  But this nulling
; out in raw-mode should prevent most bad-lisp-objectp surprises from progn!.

                                       val)))))))))
     :event-type 'progn)))

(defun progn-fn (ev-lst state)
  (progn-fn1 ev-lst nil nil state))

(defun progn!-fn (ev-lst bindings state)
  (state-global-let* ((acl2-raw-mode-p (f-get-global 'acl2-raw-mode-p state))
                      (ld-okp (let ((old (f-get-global 'ld-okp state)))
                                (if (eq old :default) nil old))))
                     (progn-fn1 ev-lst t bindings state)))

; Now we develop the book mechanism, which shares a lot with what
; we've just done.  In the discussion that follows, Unix is a
; trademark of Bell Laboratories.

; First, a broad question:  how much security are we trying to provide?
; After all, one could always fake a .cert file, say by calling checksum
; oneself.  Our claim is simply that we only fully "bless" certification runs,
; from scratch, of entire collections of books, without intervention.  Thus,
; there is no soundness problem with using (include-book "hd:ab.lisp") in a
; book certified in a Unix file system and having it mean something completely
; different on the Macintosh.  Presumably the attempt to certify this
; collection on the Macintosh would simply fail.

; How portable do we intend book-names to be?  Suppose that one has a
; collection of books, some of which include-book some of the others, where all
; of these include-books use relative path names.  Can we set things up so that
; if one copies all of these .lisp and .cert files to another file system,
; preserving the hierarchical directory relationship, then we can guarantee
; that this collection of books is certifiable (modulo resource limitations)?
; The answer is yes if one avoids absolute pathnames: see :DOC
; project-dir-alist, and note that we use Unix-style pathnames within ACL2 --
; see :doc pathname, and see the Essay on Pathnames in interface-raw.lisp.
; (Before Version_2.5 we also supported a notion of structured pathnames,
; similar to the "structured directories" concept in CLtL2.  However, the CLtL2
; notion was just for directories, not file names, and we "deprecated"
; structured pathnames by deleting their documentation around Version_2.5.  We
; continued to support structured pathnames through Version_2.8 for backwards
; compatibility, but no longer.)  Also see the Essay on Book-names.

; Note.  It is important that regardless of what initial information we store
; in the state that is based on the surrounding operating system, this
; information not be observable in the logical theory.  For example, it would
; really be unfortunate if we did something like:

;  (defconst *foo*
;    #+mswindows 'win
;    #-mswindows 'not-win)

; because then we could certify a book in one ACL2 that contains a theorem
; (equal *foo* 'win), and include this book in another world where that theorem
; fails, thus deriving a contradiction.  In fact, we make the operating-system
; part of the state (as a world global), and figure everything else out about
; book-names using that information.


; The portcullis of a book consists of two things, a sequence of
; commands which must be executed with ld-skip-proofs nil without error
; and an include-book-alist-like structure which must be a subset of
; include-book-alist afterwards.  We describe the structure of an
; include-book-alist below.

(defun include-book-alist-subsetp (alist1 alist2)

; The include-book-alist contains elements of the
; general form         example value

; (full-book-name     ; "/usr/home/moore/project/arith.lisp" ; could be sysfile
;  user-book-name     ; "project/arith.lisp"
;  familiar-name      ; "arith"
;  cert-annotations   ; ((:SKIPPED-PROOFSP . sp)
;                        (:AXIOMSP . axp)
;                        (:TTAGS . ttag-alistp))
;  . book-hash)       ; 12345678 or
;                     ; (:BOOK-LENGTH . 3011) (:BOOK-WRITE-DATE . 3638137372)

; The include-book-alist becomes part of the certificate for a book, playing a
; role in both the pre-alist and the post-alist.  In the latter role some
; elements may be marked (LOCAL &).  When we refer to parts of the
; include-book-alist entries we have tried to use the tedious names above, to
; help us figure out what is used where.  Please try to preserve this
; convention.

; Cert-annotations is an alist.  The alist has three possible keys:
; :SKIPPED-PROOFSP, :AXIOMSP, and :TTAGS.  The possible values of the first two
; are t, nil, or ?, indicating the presence, absence, or possible presence of
; skip-proof forms or defaxioms, respectively.  The forms in question may be
; either LOCAL or non-LOCAL and are in the book itself (not just in some
; subbook).  Even though the cert-annotations is an alist, we compare
; include-book-alists with equality on that component, not ``alist equality.''
; So we are NOT free to drop or rearrange keys in these annotations.

; If the book is uncertified, the book-hash value is nil.  Otherwise it is an
; alist by default, but if the value of state global 'book-hash-alistp was nil
; at certification time, then the book-hash value is a checksum; see function
; book-hash-alist and see :doc book-hash.

; Suppose the two alist arguments are each include-book-alists from different
; times.  We check that the first is a subset of the second, in the sense that
; the (familiar-name cert-annotations . book-hash) parts of the first are all
; among those of the second.  We ignore the full names and the user names
; because they may change as the book or connected book directory moves around.

  (subsetp-equal (strip-cddrs alist1)
                 (strip-cddrs alist2)))

(defun cbd-fn (state)
  (or (f-get-global 'connected-book-directory state)
      (er hard? 'cbd
          "The connected book directory has apparently not yet been set.  ~
           This could be a sign that the top-level ACL2 loop, generally ~
           entered using (LP), has not yet been entered.")))

(defmacro cbd nil
  `(cbd-fn state))

(defun get-portcullis-cmds (wrld cmds cbds names ctx state)

; When certify-book is called, we scan down wrld to collect all the user
; commands (more accurately: their make-event expansions) into cmds.  This
; answer is part of the portcullis of the certificate, once it has been cleaned
; up by fix-portcullis-cmds and new-defpkg-list.  We also collect into cbds the
; connected-book-directory values for cmds.

  (cond
   ((null wrld) (mv nil cmds cbds state))
   ((and (eq (caar wrld) 'command-landmark)
         (eq (cadar wrld) 'global-value))
    (let ((form0 (access-command-tuple-form (cddar wrld)))
          (cbd (access-command-tuple-cbd (cddar wrld))))
      (cond ((equal form0 '(exit-boot-strap-mode))
             (mv nil cmds cbds state))
            (t (mv-let
                 (erp val state)
                 (chk-embedded-event-form form0 nil wrld ctx state names nil
                                          nil nil)
                 (cond
                  (erp (mv erp nil nil state))
                  (t
                   (let* ((exp (access-command-tuple-last-make-event-expansion
                                (cddar wrld)))
                          (form
                           (if exp

; We restore LOCAL and other wrappers.  Before we did this we had problems as
; indicated by the tests below.

;;; Test 1
; acl2
; (local (make-event (prog2$ (cw "@@@ Stuff @@@~%")
;                            '(local (defun f2 (x) x)))
;                    :check-expansion t))
; (certify-book "foo" ?)
; (quit)
; acl2
; ; Should not print "Stuff", but formerly did so.
; (include-book "foo")

;;; Test 2
; acl2
; (local (make-event '(defun f2 (x) x)))
; (certify-book "foo" ?)
; (quit)
; acl2
; (include-book "foo")
; ; Should fail, but formerly did not.
; (pe 'f2)
; ; Formerly, this presented a name conflict that shouldn't exist.
; (defun f2 (x y) (cons x y))

;;; Test 3:  A local event that's not from make-event was also in the world
;;; after include-book, when it didn't belong.
; acl2
; (local (progn (defun f1 (x) x) (make-event '(defun f2 (x) x))))
; (certify-book "foo" ?)
; (quit)
; acl2
; (include-book "foo")
; ; Should fail, but formerly did not.
; (pe 'f1)
; ; Formerly, this presented a name conflict that shouldn't exist.
; (defun f1 (x y) (cons x y))
; ; Should fail, but doesn't.
; (pe 'f2)
; ; Formerly, this presented a name conflict that shouldn't exist.
; (defun f2 (x y) (cons x y))

;;; Test 4: It's actually not just about local; it's about other wrappers too.
;;; Formerly the setting of guard-checking to nil was being ignored.
; acl2
; (defun bad (x) (declare (xargs :mode :program)) (car x))
; (with-guard-checking-event
;   nil
;   (make-event (prog2$ (car 3) '(local (defun f2 (x) x)))
;               :check-expansion t))
; (certify-book "foo" ?)
; (quit)
; acl2
; (include-book "foo")

                               (mv-let (wrappers base-form)
                                 (destructure-expansion val)
                                 (declare (ignore base-form))
                                 (rebuild-expansion wrappers exp))
                             form0)))
                     (get-portcullis-cmds
                      (cdr wrld)
                      (cons form cmds)
                      (cons cbd cbds)
                      names ctx state)))))))))
   (t (get-portcullis-cmds (cdr wrld) cmds cbds names ctx state))))

#-acl2-loop-only
(progn

(defvar *canonical-unix-pathname-action*

; The value can be nil, :warning, or :error.  It is harmless for the value to
; be nil, which will just cause canonicalization of filenames by
; canonical-unix-pathname to fail silently, returning the unchanged filename.
; But the failures we are considering are those for which (truename x) is some
; non-nil value y and yet (truename y) is not y.  We prefer to know about such
; cases, but the user is welcome to replace :error here with :warning or :nil
; and rebuild ACL2.

  :error)

(defun canonical-unix-pathname (x dir-p state)

; This function returns either nil or a Unix filename, which is a valid ACL2
; string.

; Warning: Although it may be tempting to use pathname-device in this code, be
; careful if you do!  Camm Maguire sent an example in which GCL on Windows
; returned ("Z:") as the value of (pathname-device (truename "")), and it
; appears that this is allowed by the Lisp standard even though we might expect
; most lisps to return a string rather than a list.

; X is a string representing a filename in the host OS.  First suppose dir-p is
; nil.  Return nil if there is no file with name x.  Otherwise, return a
; Unix-style filename equivalent to x, preferably one that is canonical.  If
; the file exists but we fail to find a canonical pathname with the same
; truename, we may warn or cause an error; see
; *canonical-unix-pathname-action*.

; If dir-p is true, then return the value above unless it corresponds to a file
; that is not a directory, or if the "true" name cannot be determined, in which
; case return nil.

  (let* ((truename (our-truename x))
         (result
          (and truename
               (let ((dir (pathname-directory truename))
                     (name (pathname-name truename))
                     (type (pathname-type truename)))
                 (and (implies dir-p
                               (not (or (stringp name) (stringp type))))
                      (assert$ (and (true-listp dir)
                                    #+gcl
                                    (member (car dir)
                                            '(:ROOT ; for backward compatibility
                                              #+cltl2
                                              :ABSOLUTE)
                                            :test #'eq)
                                    #-gcl
                                    (eq (car dir) :ABSOLUTE))
                               (let* ((mswindows-drive
                                       (mswindows-drive (namestring truename)
                                                        state))
                                      (tmp (if mswindows-drive
                                               (concatenate 'string
                                                            mswindows-drive
                                                            "/")
                                             "/")))
                                 (dolist (x dir)
                                   (when (stringp x)
                                     (setq tmp
                                           (concatenate 'string tmp x "/"))))
                                 (when (stringp name)
                                   (setq tmp (concatenate 'string tmp name)))
                                 (when (stringp type)
                                   (setq tmp
                                         (concatenate 'string tmp "." type)))
                                 (let ((namestring-tmp
                                        (namestring (truename tmp)))
                                       (namestring-truename
                                        (namestring truename)))
                                   (cond
                                    ((equal namestring-truename
                                            namestring-tmp)
                                     tmp)
                                    ((and mswindows-drive

; In Windows, it appears that the value returned by truename can start with
; (for example) "C:/" or "c:/" depending on whether "c" is capitalized in the
; input to truename.  (See the comment in mswindows-drive1.)  Since tmp is
; constructed from mswindows-drive and components of truename, we are really
; just doing a minor sanity check here, so we content ourselves with a
; case-insensitive string-equality check.  That seems reasonable for Windows,
; whose pathnames are generally (as far as we know) considered to be
; case-insensitive.

                                          (string-equal namestring-truename
                                                        namestring-tmp))
                                     tmp)
                                    (t (case *canonical-unix-pathname-action*
                                         (:warning
                                          (let ((state *the-live-state*))
                                            (warning$ 'canonical-unix-pathname
                                                      "Pathname"
                                                      "Unable to compute ~
                                                      canonical-unix-pathname ~
                                                      for ~x0.  (Debug info: ~
                                                      truename is ~x1 while ~
                                                      (truename tmp) is ~x2.)"
                                                      x
                                                      namestring-truename
                                                      namestring-tmp)))
                                         (:error
                                          (er hard 'canonical-unix-pathname
                                              "Unable to compute ~
                                              canonical-unix-pathname for ~
                                              ~x0.  (Debug info: truename is ~
                                              ~x1 while (truename tmp) is ~
                                              ~x2.)"
                                              x
                                              namestring-truename
                                              namestring-tmp)))
                                       (and (not dir-p) ; indeterminate if dir-p
                                            x)))))))))))
    (and result
         (pathname-os-to-unix result

; At one time the next argument was (os (w state)).  But we changed that when
; calling this function during the boot-strap, when (w state) was still nil.

                              (get-os)
                              state))))

(defun unix-truename-pathname (x dir-p state)

; X is intended to be a Unix-style pathname.  If x is not a string or the file
; named by x does not exist, then we return nil.  Otherwise, assuming dir-p is
; nil, we return the corresponding truename, also Unix-style, if we can compute
; it; else we return x.  If dir-p is true, however, and the above-referenced
; file is not a directory, then return nil.

; Notice that we do not modify state, here or in the ACL2 interface to this
; function, canonical-pathname.  We imagine that the result depends on the
; file-clock of the state, which must change if any files actually change.

  (and (stringp x)
       (canonical-unix-pathname (pathname-unix-to-os x state)
                                dir-p
                                state)))

)

#-acl2-loop-only
(defun chk-live-state-p (fn state)
  (or (live-state-p state)

; It is perhaps a bit extreme to call interface-er, which calls (raw Lisp)
; error.  But this is the conservative thing to do, and it doesn't cause a
; problem with the rewriter provided fn is constrained; see the comment about
; chk-live-state-p in rewrite.

      (interface-er "Function ~x0 was passed a non-live state!"
                    fn)))

#-acl2-loop-only
(defun-overrides canonical-pathname (pathname dir-p state)

; This is essentially an interface to raw Lisp function unix-truename-pathname.
; See the comments for that function.

  (unix-truename-pathname pathname dir-p state))

#+acl2-loop-only
(defproxy canonical-pathname (* * state)

; We use defproxy for now because state-p is still in :program mode; a
; partial-encapsulate comes later in the boot-strap (see
; boot-strap-pass-2-a.lisp).

  => *)

(defun canonical-dirname! (pathname ctx state)
  (declare (xargs :guard t))
  (or (canonical-pathname pathname t state)
      (let ((x (canonical-pathname pathname nil state)))
        (cond (x (er hard? ctx
                     "The file ~x0 is not known to be a directory."
                     x))
              (t (er hard? ctx
                     "The directory ~x0 does not exist."
                     pathname))))))

(defun directory-of-absolute-pathname (pathname)
  (let* ((lst (coerce pathname 'list))
         (rlst (reverse lst))
         (temp (member *directory-separator* rlst)))
    (coerce (reverse temp) 'string)))

(defun extend-pathname+ (dir0 file-name canon-p state)

; See extend-pathname, which is similar.  The present function has an extra
; argument, canon-p: when true, the result is either canonical or nil; when
; false, the result is still canonical if possible, but otherwise we do the
; best we can, making at least the resulting directory canonical if possible.

  (let* ((wrld (w state))
         (os (os wrld))
         (ctx 'extend-pathname)
         (dir (if (keywordp dir0)
                  (project-dir-lookup dir0 (project-dir-alist wrld) ctx)
                dir0))
         (file-name1 (expand-tilde-to-user-home-dir
                      file-name os ctx state))
         (abs-filename (cond
                        ((absolute-pathname-string-p file-name1 nil os)
                         file-name1)
                        (t
                         (our-merge-pathnames dir file-name1))))
         (canonical-filename (if (keywordp dir0)
                                 abs-filename ; already canonical
                               (canonical-pathname abs-filename nil state))))
    (or canonical-filename

; If a canonical filename doesn't exist, then presumably the file does not
; exist.  But perhaps the directory exists; we try that next.

        (and
         (not canon-p)
         (let ((len (length abs-filename)))
           (assert$
            (not (eql len 0)) ; absolute filename starts with "/"
            (cond
             ((eql (char abs-filename (1- (length abs-filename)))
                   #\/) ; we have a directory, which we know doesn't exist
              abs-filename)
             (t

; Let's go ahead and at least try to canonicalize the directory of the file (or
; parent directory, in the unlikely event that we have a directory).

              (let* ((dir0 (directory-of-absolute-pathname abs-filename))
                     (len0 (length dir0))
                     (dir1 (assert$ (and (not (eql len0 0))
                                         (eql (char dir0 (1- len0))
                                              #\/))
                                    (canonical-pathname dir0 t state))))
                (cond (dir1 (concatenate 'string dir1
                                         (subseq abs-filename len0 len)))
                      (t ; return something not canonical; at least we tried!
                       abs-filename)))))))))))

(defun extend-pathname (dir0 file-name state)

; Dir0 is a string representing an absolute directory name or a keyword
; representing a project directory, and file-name is a string representing a
; file or directory name.  We return a string representing the interpretation
; of file-name with respect to dir0.  We attempt to return such a string that
; is a canonical pathname, e.g., with soft links resolved.  If you want to
; insist that the result be canonical, returning nil otherwise, use
; extend-pathname+ instead (with argument canon-p = t).

  (extend-pathname+ dir0 file-name nil state))

(defun maybe-add-separator (str)
  (if (and (not (equal str ""))
           (eql (char str (1- (length str))) *directory-separator*))
      str
    (string-append str *directory-separator-string*)))

(defun set-cbd-fn1 (dir state)

; See set-cbd-fn for explanation.

  (pprogn
   (increment-file-clock state)
   #+acl2-loop-only
   (assign connected-book-directory dir)
   #-acl2-loop-only
   (without-interrupts
    (setq *default-pathname-defaults*

; Dir may be nil during the boot-strap.  In that case we are returning to an
; initial situation, so we reset *default-pathname-defaults* to represent the
; current working directory.

          (pathname (or dir (our-pwd))))
    (assign connected-book-directory dir))))

(defun set-cbd-fn-dir (str os ctx state)

; See set-cbd-fn.  Here we return either a new value for cbd or else a cons
; that is the value of a ~@0 fmt in the error message.

  (cond
   ((not (stringp str))
    (cond ((and (null str)
                (f-get-global 'boot-strap-flg state))

; This special case is expected.

           nil)
          (t
           (msg "The argument cbd must be a string, unlike ~x0.  See :DOC cbd."
                str))))
   (t (let ((str (expand-tilde-to-user-home-dir str os ctx state)))
        (cond
         ((absolute-pathname-string-p str nil os)
          (maybe-add-separator (canonical-dirname! str ctx state)))
         ((not (absolute-pathname-string-p
                (f-get-global 'connected-book-directory state)
                t
                os))
          (msg "An attempt was made to set the connected book directory (cbd) ~
                using relative pathname ~p0, but surprisingly, the existing ~
                cbd is ~p1, which is not an absolute pathname.  This appears ~
                to be an implementation error; please contact the ACL2 ~
                implementors."
               str
               (f-get-global 'connected-book-directory state)))
         (t
          (maybe-add-separator
           (canonical-dirname! (our-merge-pathnames
                                (f-get-global 'connected-book-directory state)
                                str)
                               ctx
                               state))))))))

(defun set-cbd-fn (str state)

; We attempt to reduce potential confusion by having Lisp special variable
; *default-pathname-defaults* track the cbd.  Quoting the CL HyperSpec Section
; 19.2.3 (Merging Pathnames):

;   Except as explicitly specified otherwise, for functions that manipulate or
;   inquire about files in the file system, the pathname argument to such a
;   function is merged with *default-pathname-defaults* before accessing the
;   file system (as if by merge-pathnames).

; And quoting "Function MERGE-PATHNAMES":

;   merge-pathnames pathname &optional default-pathname default-version
;   ...
;   default-pathname---a pathname designator. The default is the value of
;   *default-pathname-defaults*.
;   ...
;   If pathname does not specify a host, device, directory, name, or type, each
;   such component is copied from default-pathname.

  (cond
   ((and str                ; avoid a boot-strap problem
         (equal (cbd) str)) ; optimization to avoid canonical-dirname!
    (value nil))
   (t
    (let* ((os (os (w state)))
           (ctx (cons 'set-cbd str))
           (val (set-cbd-fn-dir str os ctx state)))
      (cond ((consp val)
             (er soft ctx "~@0" val))
            (t (set-cbd-fn1 val state)))))))

(defmacro set-cbd (str)
  `(set-cbd-fn ,str state))

(defun set-cbd-state (str state)

; This is similar to set-cbd-fn, but returns state and should be used only when
; no error is expected.

  (mv-let (erp val state)
          (set-cbd-fn str state)
          (declare (ignore val))
          (prog2$
           (and erp
                (er hard 'set-cbd-state
                    "Implementation error: Only use ~x0 when it is known that ~
                     this will not cause an error."
                    'set-cbd-state))
           state)))

#-acl2-loop-only
(defmacro with-cbd-raw (binder dir form)
  (assert (member binder
                  '(state-free-global-let* state-free-global-let*-safe)
                  :test 'eq))

; The two binders above are only used in raw Lisp, so we are free to generate
; raw Lisp code.

  `(let ((*default-pathname-defaults* ,(if (eq dir :same)
                                           '*default-pathname-defaults*
                                         dir)))
     (,binder ((connected-book-directory *default-pathname-defaults*))
              ,form)))

(defmacro with-cbd (dir form)

; ACL2 is supposed to keep the cbd and Lisp variable
; *default-pathname-defaults* in sync.  So it would be a mistake merely to bind
; the connected-book-directory with state-global-let*; we want to bind
; *default-pathname-defaults* as well.  The code below accomplishes this task.

; A special case is when dir is :SAME, meaning that we want to protect the cbd
; and *default-pathname-defaults* but we don't want to modify them going in.

; Note that (with-cbd dir form) is only accepted by ACL2 when form evaluates to
; an error triple.  But since form can be an event, form can evaluate to
; something else in raw Lisp; for example, in (with-cbd dir (defun ...)), the
; call of defun returns a single value in raw Lisp.  But such event forms in
; raw Lisp are the only way we can get a violation of the requirement that form
; evaluates to an error triple, and in those cases, we don't care about the
; value returned by with-cbd, as noted in a comment below.

; In an event context we require dir to be a string, for two reasons.  One
; reason is a concern about soundness: although we have not proved nil with the
; earlier implementation without that restriction, it seems best not to allow
; the expression to depend on state.  (Make-event may seem to have the same
; problem, but careful tracking of expansions, including redundancy for
; encapsulates and the expansion-alist of a certificate file, should take care
; of such concerns for make-event.)  The second reason for dir to be a string
; is to support make-include-books-absolute, which takes advantage of the
; string being truly a string.  (We could get around that by redefining
; with-cbd to be a make-event that replaces the string expression by its value,
; but then non-event uses of with-cbd would be prohibited, which would even
; break our own source code!)

  (let ((form #+acl2-loop-only
              form
              #-acl2-loop-only
              `(let ((result (multiple-value-list ,form)))
                 (cond ((and (= (length result) 3)
                             (eq (caddr result) *the-live-state*))
                        (values-list result))
                       (t ; otherwise value doesn't matter; see comment above
                        (value nil))))))
    `(state-global-let* ((connected-book-directory (cbd) set-cbd-state))
                        ,(if (eq dir :same)
                             form
                           `(pprogn (set-cbd-state ,dir state)
                                    ,form)))))

(defmacro with-current-package (pkg form)

; ACL2 generally keeps the current-package and Lisp variable *package* in sync;
; in particular, read-object binds *package* to the package indicated by ACL2's
; current-package.  So it would be a mistake merely to bind the current-package
; with state-global-let*; we want to bind *package* as well.  The code below
; accomplishes this task.

; See with-cbd for discussion of technical details, which are analogous to
; those here.  Note that with-cbd has a bit different form since it must do
; more than bind the cbd -- it must call set-cbd so that
; *default-pathname-defaults* tracks the cbd.

  (let ((form #+acl2-loop-only
              form
              #-acl2-loop-only
              `(let ((result (multiple-value-list ,form)))
                 (cond ((and (= (length result) 3)
                             (eq (caddr result) *the-live-state*))
                        (values-list result))
                       (t ; otherwise value doesn't matter; see comment above
                        (value nil))))))
    `(state-global-let*
      ((current-package ,pkg set-current-package-state))
      ,form)))

(defun parse-book-name (dir x extension ctx state)

; This function takes a directory name, dir, and a user-supplied string, x,
; representing a book, and returns (mv str full dir familiar), where str is the
; full-book-string (an absolute pathname string), full is the corresponding
; full-book-name (hence either str or a corresponding sysfile), dir is the
; directory name, and familiar is the familiar name string.  Extension is
; either nil or ".lisp" and the full-book-name is given the extension if it is
; non-nil.  (If needed we can consider extensions other than ".lisp", in which
; case we will need to think carefully about the use of extend-pathname to
; generate canonical pathnames.)

; Given dir                and x with extension=".lisp"
; "/usr/home/moore/"           "nasa-t3/arith"       ; user name
; this function may produce
; (mv "/usr/home/moore/nasa-t3/arith.lisp"           ; full-book-string
;     "/usr/home/moore/nasa-t3/arith.lisp"           ; full-book-name
;     "/usr/home/moore/nasa-t3/"                     ; directory name
;     "arith")                                       ; familiar name

; However, if the project-dir-alist maps keyword :moore to "/usr/home/moore/",
; then the second value returned -- the full-book-name would be as follows.

;     (:moore . "nasa-t3/arith.lisp")                ; full-book-name

; We work with Unix-style pathnames.

; Note that this function merely engages in string processing.  It does not
; actually guarantee that the named file exists or that the various names are
; in any sense well-formed.  It does not change the connected book directory.
; If x is not a string, an error normally occurs, but the result is logically
; (mv nil nil nil x).  Thus, if the full-book-string or full-book-name returned
; is nil, we know something is wrong and the short name returned is whatever
; junk the user supplied.

; That said, we attempt to find a canonical pathname, which for example
; eliminates soft links.  But to do that we need to know the file that is
; expected to exist.  We call that file x+ below: it is dir/x.lisp, since the
; given user-supplied string is intended not to have the .lisp extension
; already.

  (cond
   ((and extension
         (not (equal extension ".lisp")))
    (mv (er hard ctx
            "Calls of parse-book-name with non-nil extension other than ~
             \".lisp\" are not supported.  The call ~x0 is thus illegal."
            `(parse-book-name ,dir ,x ,extension ,ctx state))
        nil nil x))
   ((stringp x)
    (cond
     ((search "//" x)
      (mv (er hard ctx
              "The filename~|~x0~|is illegal because it has consecutive ~
               directory separators, //."
              x)
          nil nil x))
    (t
     (let* ((x+ (concatenate 'string x ".lisp"))
            (full-book-string0 (extend-pathname dir x+ state))
            (pos0 (search *directory-separator-string* full-book-string0
                          :from-end t))
            (dir0 (assert$ pos0
                           (subseq full-book-string0 0 (1+ pos0))))
            (len0 (length full-book-string0))
            (len0-5 (- len0 5))
            (full-book-string
             (cond (extension full-book-string0)
                   ((string-suffixp ".lisp" full-book-string0)
                    (subseq full-book-string0 0 len0-5))
                   (t

; If full-book-string0 doesn't end in .lisp, yet it was computed from dir/x by
; extend-pathname, which we believe can only change the extension if the result
; is a canonical pathname.  If our thinking is wrong on this, then we'll learn
; something when we get a complaint about the following error!

                    (er hard ctx
                        "A file with pathname ~x0 appears to have canonical ~
                         pathname ~x1, which unfortunately does not also end ~
                         in \".lisp\"!  Note that ACL2 requires that a book's ~
                         filename ends in \".lisp\" even after resolving soft ~
                         links."
                        x+ full-book-string0))))
            (familiar (subseq full-book-string0 (1+ pos0) len0-5)))
       (mv full-book-string
           (filename-to-book-name full-book-string (w state))
           dir0
           familiar)))))
   (t (mv (er hard ctx
              "The object ~x0 was found as a book name where a string was ~
               expected."
              x)
          nil nil x))))

; We now develop code to "fix" the commands in the certification world before
; placing them in the portcullis of the certificate, in order to eliminate
; relative pathnames in include-book forms.  See the comment in
; fix-portcullis-cmds.

#-acl2-loop-only ; actually only needed for ccl
(defun *1*-symbolp (x)
  (and (symbolp x)
       (let ((pkg-name (ignore-errors (symbol-package-name x))))
         (and pkg-name
              (string-prefixp *1*-pkg-prefix* ; i.e., *1*-package-prefix*
                              pkg-name)))))

(mutual-recursion

(defun make-include-books-absolute-1 (form cbd dir names localp ctx state)

; WARNING: Keep this in sync with chk-embedded-event-form,
; destructure-expansion, and elide-locals-rec.

; Form is a command from the current ACL2 world that is known to be an embedded
; event form with respect to names.  However, it is not necessarily an event
; that would actually be stored: in particular, add-include-book-dir (also
; ..-dir!) can take a relative pathname in the command, but may be stored as an
; event using an absolute pathname; and make-event uses this function to
; convert some relative to absolute pathnames in the make-event expansion of
; form.

; This function can replace relative pathnames by absolute pathnames in each of
; the following situations.

; (a) We are converting commands in a certification world so that they are
;     suitable for storing in the portcullis commands section of a certificate
;     file.

; (b) We are creating a make-event expansion.

; In the case of (a), we want to make some pathnames absolute in include-book,
; add-include-book-dir!, and add-include-book-dir forms -- possibly using
; sysfile notation (see sysfile-p) -- so that such pathnames are appropriate
; even if the book and its certificate file are moved.  See the comment in
; fix-portcullis-cmds for discussion of case (a).  In the case of (b) we do
; this as well, just in case the make-event form is ultimately in the
; certification world.  It is tempting not to bother if we are processing the
; event from a book, during include-book or certify-book, since then we know
; it's not in the portcullis.  But rather than think about how making those
; special cases might affect redundancy, we always handle make-event.

; Starting after Version_3.6.1, we allow an include-book pathname for a
; portcullis command to remain a relative pathname if it is relative to the cbd
; of the book.  That change avoided a failure to certify community book
; books/fix-cert/test-fix-cert1.lisp (now defunct) that initially occurred when
; we started including portcullis commands in the checksum, caused by the
; renaming of an absolute pathname in an include-book portcullis command.  Note
; that since a make-event in a certification world is evaluated without knowing
; the ultimate cbd for certification, we always convert to an absolute pathname
; in case (b), the make-event case.

; Cbd is the connected-book-directory just after evaluating form, and hence
; (since form is an embedded event form) also just before evaluating form.  Dir
; is the directory of the book being certified (case (a)), but is nil for the
; make-event case (case (b)).

  (cond
   ((atom form) (mv nil form)) ; This should never happen.
   ((member-eq (car form) '(local skip-proofs))
    (cond
     ((and (eq (car form) 'local)
           (not localp))

; Local events will be skipped when including a book, and in particular when
; evaluating portcullis commands from a book's certificate, so we can ignore
; local events then.

      (mv nil form))
     (t (mv-let (changedp x)
          (make-include-books-absolute-1
           (cadr form) cbd dir names localp ctx state)
          (cond (changedp (mv t (list (car form) x)))
                (t (mv nil form)))))))
   ((eq (car form) 'progn)

; Since progn! has forms that need not be events, we don't try to deal with it.
; We consider this not to present any soundness problems, since progn!
; requires a ttag.

    (mv-let (changedp rest)
      (make-include-books-absolute-lst
       (cdr form) cbd dir names localp ctx state)
      (cond (changedp (mv t (cons (car form) rest)))
            (t (mv nil form)))))
   ((eq (car form) 'value)
    (mv nil form))
   ((eq (car form) 'include-book)

; Consider the case that we are processing the portcullis commands for a book,
; bk, that is in the process of being certified.  We want to ensure that form,
; an include-book form, refers to the same book as when originally processed as
; it does when later being processed as a portcullis command of bk.  When bk is
; later included, the connected-book-directory will be bound to dir, which is
; the directory of the book being certified.  Therefore, if the
; connected-book-directory at the time form was processed, namely cbd, is the
; same as dir, then we do not need bk to be an absolute pathname: the same
; connected-book-directory as when originally processed (namely, cbd) will be
; used as the connected-book-directory when the book is being included as a
; portcullis command of bk (namely, connected-book-directory dir).
; Well... actually, if bk is a project book, and if the project books are
; moved, then cbd and dir will change but their equality (and inequality) will
; be preserved.

; If cbd is nil then we are recovering portcullis commands from an existing
; certificate, so relative pathnames have already been converted to absolute
; pathnames when necessary, and no conversion is needed here.

; If cbd is non-nil and dir is nil, then we are converting pathnames for some
; purposes other than the portcullis of a book being certified, so there is no
; need to convert to an absolute pathname.

; If we have an absolute pathname, either by conversion or because the
; include-book originally referenced an absolute pathname under a project books
; directory, then we convert to use a book-name.

; To summarize much of the above: if cbd is nil or if cbd and dir are equal, we
; can skip any pathname conversion and fall through to the next top-level COND
; branch, where form is returned unchanged -- except in both cases, an absolute
; pathname under a project books directory :d is replaced using :dir :d.

    (assert$
     (keyword-value-listp (cddr form)) ; as form is a legal include-book event
     (cond
      ((assoc-keyword :dir form)

; We do not need to convert a relative pathname to an absolute pathname if the
; :dir argument already specifies how to do this.  Recall that the table guard
; of the acl2-defaults-table specifies that :dir arguments are absolute
; pathnames; similarly for include-book-dir!-table and the project-dir-alist.

       (mv nil form))
      ((not (equal cbd dir)) ; always true in case (b)
       (assert$
        (stringp cbd)
        (mv-let (full-book-string full-book-name directory-name familiar-name)
          (parse-book-name cbd (cadr form) nil ctx state)
          (declare (ignore directory-name familiar-name))
          (cond ((consp full-book-name) ; (sysfile-p full-book-name)
                 (mv t
                     (list* 'include-book
                            (sysfile-filename full-book-name)
                            :dir (sysfile-key full-book-name)
                            (cddr form))))
                ((assert$ (equal full-book-name full-book-string)
                          (and dir

; Note that if dir is nil, then we are doing this on behalf of make-event so
; that the expansion-alist of a .cert file is relocatable.  In that case, there
; is no need to make the book-name absolute, since the usual reason -- a change
; of cbd -- doesn't apply in the middle of a book certification.  Note that if
; the make-event occurs in a certification world, then fix-portcullis-cmds will
; fix, as appropriate, any expansion that is an include-book.

                               (not (equal full-book-string (cadr form)))))
                 (mv t
                     (list* 'include-book
                            full-book-string
                            (cddr form))))
                (t (mv nil form))))))
      (t

; If the book's name is an absolute pathname, we may convert it to a sysfile to
; support book relocation.  If however the book's name is a relative pathname
; then we leave it unchanged.  We could avoid calling filename-to-book-name by
; checking first if the filename is an absolute pathname, but we see no reason
; to bother.

       (assert$
        (stringp (cadr form))
        (let ((book-name (filename-to-book-name (cadr form) (w state))))
          (cond ((consp book-name) ; (sysfile-p book-name)
                 (mv t
                     (list* 'include-book
                            (sysfile-filename book-name)
                            :dir (sysfile-key book-name)
                            (cddr form))))
                (t (mv nil form)))))))))
   ((member-eq (car form)
               '(add-include-book-dir add-include-book-dir!))

; This case is very similar to the include-book case handled in the preceding
; COND branch, above.  See that case for explanatory comments.  In order to see
; an unfortunate include-book failure WITHOUT this case, try the following.  We
; assume two directories, D and D/SUB/, and trivial books D/foo.lisp and
; D/SUB/bar.lisp.

; In directory D, start up ACL2 and then:

; (add-include-book-dir :main "./")
; (certify-book "foo" 1)
; (u)
; :q
; (save-exec "my-acl2" "testing")

; Then in directory D/SUB/, start up ../my-acl2 and then:

; (include-book "foo" :dir :main)
; (certify-book "bar" 2)

; Finally, in directory D/SUB/, start up ../my-acl2 and then:

; (include-book "bar")

; You'll see this error:

; ACL2 Error in ( INCLUDE-BOOK "foo" ...):  There is no file named
; "D/SUB/foo.lisp" that can be opened for input.

    (cond
     ((consp (caddr form)) ; (sysfile-p (caddr form))

; Form is a command form from the user, so sysfile syntax for (caddr form) does
; not guarantee that this truly is a valid sysfile as would be returned as a
; full-book-name from parse-book-name.  But that's OK; even if not,
; relocatability should be guaranteed by the prefix requirement on the
; project-dir-alist (see its :DOC).

      (mv nil form))
     ((not (equal cbd dir)) ; always true in case (b)
      (assert$
       (stringp cbd)
       (mv t
           (list (car form)
                 (cadr form)
                 (filename-to-book-name (extend-pathname cbd (caddr form) state)
                                        (w state))))))
     (t

; If the book's name is an absolute pathname, we convert it to a full-book-name
; to support book relocation.  If however the book's name is a relative
; pathname then we leave it unchanged.  We could avoid calling
; filename-to-book-name by checking first if the filename is an absolute
; pathname, but we see no reason to bother.

      (let ((book-name (filename-to-book-name (caddr form) (w state))))
        (cond ((consp book-name) ; (sysfile-p book-name)
               (mv t (list (car form)
                           (cadr form)
                           book-name)))
              (t (mv nil form)))))))
   ((member-eq (car form) names)

; Note that we do not have a special case for encapsulate.  Every include-book
; inside an encapsulate is local (see chk-embedded-event-form), hence would not
; be changed by this function anyhow.  If we allow non-local include-books in
; an encapsulate, then we will need to add a case for encapsulate that is
; similar to the case for progn.

    (mv nil form))
   ((eq (car form) 'make-event) ; already fixed
    (mv nil form))
   ((eq (car form) 'with-cbd)
    (assert$
; Since we are in an event context, (cadr form) is a string.  See comments in
; with-cbd.
     (stringp (cadr form))
     (let ((new-cbd (set-cbd-fn-dir (cadr form) (os (w state)) ctx state)))
       (cond ((consp new-cbd)
              (mv (er hard ctx
                      "A call of with-cbd has unexpectedly referenced a ~
                       directory, ~x0, that does not exist in the current ~
                       context.  The error message produced is as ~
                       follows.~|~%~@1"
                      (cadr form)
                      new-cbd)
                  form))
             (t
              (assert$
               (stringp new-cbd) ; fails only when nil in the boot-strap
               (mv-let (changedp x)
                 (make-include-books-absolute-1
                  (car (last form))
                  new-cbd new-cbd names localp ctx state)
                 (cond (changedp (mv t (append (butlast form 1) (list x))))
                       (t (mv nil form))))))))))
   ((and (member-eq (car form) '(with-current-package
                                 with-guard-checking-event
                                 with-output
                                 with-prover-step-limit
                                 with-prover-time-limit))
         (consp (cdr form)))
    (mv-let (changedp x)
      (make-include-books-absolute-1
       (car (last form))
       cbd dir names localp ctx state)
      (cond (changedp (mv t (append (butlast form 1) (list x))))
            (t (mv nil form)))))
   ((getpropc (car form) 'macro-body)
    (mv-let (erp x)
      (macroexpand1-cmp form ctx (w state)
                        (default-state-vars t))
      (cond (erp (mv (er hard erp "~@0" x) nil))
            (t (make-include-books-absolute-1 x cbd dir names localp ctx
                                              state)))))
   (t (mv nil
          (er hard ctx
              "Implementation error in make-include-books-absolute-1:  ~
               unrecognized event type, ~x0.  Make-include-books-absolute ~
               needs to be kept in sync with chk-embedded-event-form.  Please ~
               send this error message to the implementors."
              (car form))))))

(defun make-include-books-absolute-lst (forms cbd dir names localp ctx state)

; For each form F in forms, if F is not changed by
; make-include-books-absolute-1 then it is returned unchanged in the result.

  (if (endp forms)
      (mv nil nil)
    (mv-let (changedp-1 first)
      (make-include-books-absolute-1
       (car forms) cbd dir names localp ctx state)
      (mv-let (changedp-2 rest)
        (make-include-books-absolute-lst
         (cdr forms) cbd dir names localp ctx state)
        (cond (changedp-1 (mv t (cons first rest)))
              (changedp-2 (mv t (cons (car forms) rest)))
              (t (mv nil forms)))))))
)

(defun make-include-books-absolute (form cbd dir names localp ctx state)
  (mv-let (changedp new-form)
    (make-include-books-absolute-1 form cbd dir names localp ctx state)
    (if changedp
        new-form
      form)))

(defun first-known-package-alist (wrld-segment)
  (cond
   ((null wrld-segment)
    nil)
   ((and (eq (caar wrld-segment) 'known-package-alist)
         (eq (cadar wrld-segment) 'global-value))
    (let* ((kpa  (cddar wrld-segment)))
      (if (eq kpa *acl2-property-unbound*)

; We do not expect to find *acl2-property-unbound* here.  If we do find it,
; then we cause an error.

          (er hard 'first-known-package-alist
              "Implementation error!  Unexpected find of unbound ~
               known-package-alist value!  Please contact the ACL2 ~
               implementors and send this message.")
        kpa)))
   (t
    (first-known-package-alist (cdr wrld-segment)))))

(defun defpkg-items-rec (new-kpa old-kpa ctx w state acc)

; For background on the discussion below, see the Essay on Hidden Packages.

; We are given a world w (for example, the certification world of a
; certify-book command).  Old-kpa is the known-package-alist of w.  New-kpa is
; another known-package-alist, which may include entries not in old-kpa (for
; example, the known-package-alist after executing each event in the
; admissibility pass of certify-book).  We return a list of "defpkg items" for
; names of new-kpa not in old-kpa, where each item is of the form (list name
; imports body doc book-path).  The intention is that the item can be used to
; form a defpkg event with indicated name, body, doc and book-path, where body
; may have been modified from a corresponding defpkg event so that it is
; suitable for evaluation in w.  Here, book-path is the book-path to be used if
; such an event is to be added to the end of the portcullis commands in the
; certificate of a book being certified.

; It is helpful for efficiency if w is the current-acl2-world or a reasonably
; short extension of it, since we call termp and untranslate on that world.

  (cond
   ((endp new-kpa) (value acc))
   (t (let* ((e (car new-kpa))
             (n (package-entry-name e)))
        (cond
         ((find-package-entry n old-kpa)
          (defpkg-items-rec (cdr new-kpa) old-kpa ctx w state acc))
         (t
          (let* ((imports (package-entry-imports e))
                 (event (package-entry-defpkg-event-form e))
                 (name (cadr event))
                 (body (caddr event))
                 (doc (cadddr event))
                 (tterm (package-entry-tterm e))
                 (book-path (package-entry-book-path e)))
            (mv-let (erp pair state)

; It's perfectly OK for erp to be non-nil here.  That case is handled below.
; So if you have called break-on-error and wind up here, it's a reasonable bet
; that it's nothing to worry about!

              (simple-translate-and-eval body nil nil
                                         "The second argument to defpkg"
                                         ctx w state nil)
              (defpkg-items-rec
                (cdr new-kpa) old-kpa ctx w state
                (cons (list name
                            imports
                            (assert$
                             event
                             (assert$
                              (equal n name)
                              (cond ((and (not erp)
                                          (or (equal (cdr pair) ; optimization
                                                     imports)
                                              (equal (sort-symbol-listp
                                                      (cdr pair))
                                                     imports))
                                          (equal tterm (car pair)))
                                     body)
                                    ((termp tterm w)
                                     tterm)
                                    (t
                                     (kwote imports)))))
                            doc
                            book-path)
                      acc))))))))))

(defun new-defpkg-p (new-kpa old-kpa)
  (cond ((endp new-kpa) nil)
        (t (or (not (find-package-entry (package-entry-name (car new-kpa))
                                        old-kpa))
               (new-defpkg-p (cdr new-kpa) old-kpa)))))

(defun defpkg-items (new-kpa old-kpa ctx w state)

; This is just a wrapper for defpkg-items-rec, with error output turned off
; (because of calls of translate).  See the comment for defpkg-items-rec.

  (cond
   ((new-defpkg-p new-kpa old-kpa)
    (state-global-let*
     ((inhibit-output-lst (cons 'error
                                (f-get-global 'inhibit-output-lst state)))
      (inhibit-er-hard t))
     (mv-let
       (erp val state)
       (defpkg-items-rec new-kpa old-kpa ctx w state nil)
       (assert$
        (null erp)
        (value val)))))
   (t (value nil))))

(defun new-defpkg-list2 (imports all-defpkg-items acc seen)

; Extends acc with items (cons pkg-name rest) from all-defpkg-items not already
; in acc or seen for which pkg-name is the symbol-package-name of a symbol in
; imports.

  (cond
   ((endp imports)
    acc)
   (t
    (let ((p (symbol-package-name (car imports))))
      (cond
       ((or (assoc-equal p acc)
            (assoc-equal p seen))
        (new-defpkg-list2 (cdr imports) all-defpkg-items acc seen))
       (t (let ((item (assoc-equal p all-defpkg-items)))
            (cond (item (new-defpkg-list2
                         (cdr imports)
                         all-defpkg-items
                         (cons item acc)
                         seen))
                  (t (new-defpkg-list2
                      (cdr imports) all-defpkg-items acc seen))))))))))

(defun make-hidden-defpkg (name imports/doc/book-path)

; Warning: Keep this in sync with equal-modulo-hidden-defpkgs.

  (let ((imports (car imports/doc/book-path))
        (doc (cadr imports/doc/book-path))
        (book-path (caddr imports/doc/book-path)))
    `(defpkg ,name ,imports ,doc ,book-path t)))

(defun new-defpkg-list1
  (defpkg-items all-defpkg-items base-kpa earlier-kpa added-defpkgs)

; See the comment in new-defpkg-list.  Here, we maintain an accumulator,
; added-defpkgs, that contains the defpkg events that need to be added based on
; what we have already processed in defpkg-items, in reverse order.

  (cond
   ((endp defpkg-items)
    added-defpkgs)
   (t
    (let* ((added-defpkgs
            (new-defpkg-list1 (cdr defpkg-items) all-defpkg-items base-kpa
                              earlier-kpa added-defpkgs))
           (item (car defpkg-items))
           (name (car item)))
      (cond
       ((find-package-entry name base-kpa)
        added-defpkgs)
       (t ; we want to add event, so may need to add some already "discarded"
        (cons (make-hidden-defpkg name (cddr item))
              (new-defpkg-list1
               (new-defpkg-list2 (cadr item) ; imports
                                 all-defpkg-items nil added-defpkgs)
               all-defpkg-items

; We are considering all defpkg events added in support of import lists.  We
; need to take the appropriate closure in order to get all supporting defpkg
; events that are not represented in earlier-kpa, so this call uses earlier-kpa
; in place of base-kpa.

               earlier-kpa
               earlier-kpa added-defpkgs))))))))

(defun new-defpkg-list (defpkg-items base-kpa earlier-kpa)

; For background on the discussion below, see the Essay on Hidden Packages.

; Defpkg-items is a list of "defpkg items" each of the form (list name imports
; body doc book-path) representing a list of package definitions.  We return a
; list of defpkg events, corresponding to some of these defpkg items, that can
; be executed in a world whose known-package-alist is earlier-kpa.  The primary
; reason a defpkg is in the returned list is that its package is not in
; base-kpa (not even hidden).  The second reason is that we need to define a
; package P1 not already in earlier-kpa if we add another package P2 whose
; import list contains a symbol in package P1; we close under this process.

; This function is called at the end of the include-book phase of certify-book.
; In that case, base-kpa is the known-package-alist at that point, earlier-kpa
; is the known-package-alist of the certification world, and defpkg-items
; contains an item for each name of a package in the known-package-alist at the
; end of the earlier, admissibility pass of certify-book that was not defined
; in the certification world.  To illustrate the "second reason" above, let us
; suppose that the book being certified contains forms (include-book "book1")
; and (local (include-book "book2")), where book1 defines (defpkg "PKG1" ...)
; and book2 defines (defpkg "PKG2" '(PKG1::SYM)).  Then we want to add the
; definition of "PKG2" to the portcullis, but in order to do so, we need to add
; the definition of "PKG1" as well, even though it will eventually be included
; by way of book1.  And, we need to be sure to add the defpkg of "PKG1" before
; that of "PKG2".

; This function is also called on behalf of puff-fn1, where defpkg-items
; corresponds to the packages in known-package-alist in the world at completion
; of the command about to be puffed, and base-kpa and earlier-kpa correspond to
; the known-package-alist just before that command.  In that case there is no
; need for the "second reason" above, but for simplicity we call this same
; function.

  (cond
   ((null defpkg-items) ; optimization
    nil)
   (t (reverse (remove-duplicates-equal
                (new-defpkg-list1 defpkg-items defpkg-items base-kpa
                                  earlier-kpa nil))))))

(mutual-recursion

; We check that a given term or list of terms is acceptable even if (cdr
; (assoc-eq ':ignore-ok (table-alist 'acl2-defaults-table w))) is nil.

(defun term-ignore-okp (x)
  (cond ((or (atom x)
             (fquotep x))
         t)
        ((symbolp (ffn-symb x))
         (term-list-ignore-okp (fargs x)))
        (t ; lambda
         (and (null (set-difference-eq (lambda-formals (ffn-symb x))
                                       (all-vars (lambda-body (ffn-symb x)))))
              (term-list-ignore-okp (fargs x))))))

(defun term-list-ignore-okp (x)
  (cond ((endp x) t)
        ((term-ignore-okp (car x))
         (term-list-ignore-okp (cdr x)))
        (t nil)))

)

(defun hidden-defpkg-events1 (kpa w ctx state acc)

; Warning: Keep this in sync with hidden-defpkg-events-simple.

  (cond
   ((endp kpa) (value (reverse acc)))
   ((not (package-entry-hidden-p (car kpa)))
    (hidden-defpkg-events1 (cdr kpa) w ctx state acc))
   (t
    (let* ((e (car kpa))
           (n (package-entry-name e))
           (imports (package-entry-imports e))
           (event (package-entry-defpkg-event-form e))
           (name (cadr event))
           (body (caddr event))
           (doc (cadddr event))
           (tterm (package-entry-tterm e))
           (book-path (package-entry-book-path e)))
      (mv-let
       (erp pair state)
       (simple-translate-and-eval body nil nil
                                  "The second argument to defpkg"
                                  ctx w state nil)
       (hidden-defpkg-events1
        (cdr kpa) w ctx state
        (cons `(defpkg ,name
                 ,(assert$
                   event
                   (assert$
                    (equal n name)
                    (cond ((and (not erp)
                                (or (equal (cdr pair) ; optimization
                                           imports)
                                    (equal (sort-symbol-listp
                                            (cdr pair))
                                           imports))
                                (equal tterm (car pair)))
                           (if (term-ignore-okp tterm)
                               body
                             (kwote imports)))
                          ((and (termp tterm w)
                                (term-ignore-okp tterm))
                           tterm)
                          (t
                           (kwote imports)))))
                 ,doc
                 ,book-path
                 t)
              acc)))))))

(defun hidden-defpkg-events (kpa w ctx state)
  (state-global-let*
   ((inhibit-output-lst *valid-output-names*))
   (hidden-defpkg-events1 kpa w ctx state nil)))

(defun fix-portcullis-cmds1 (dir cmds cbds ans names ctx state)
  (cond
   ((null cmds) ans)
   (t (let ((cmd (make-include-books-absolute (car cmds) (car cbds) dir
                                              names nil ctx state)))
        (fix-portcullis-cmds1 dir
                              (cdr cmds)
                              (cdr cbds)
                              (cons cmd ans)
                              names ctx state)))))

(defun fix-portcullis-cmds (dir cmds cbds names wrld ctx state)

; This function is called during certification of a book whose directory's
; absolute pathname is dir.  It modifies cmds by making relative pathnames
; absolute when necessary, and also by adding defpkg events for hidden packages
; from the certification world, as explained in the Essay on Hidden Packages.
; We explain these two aspects in turn.

; Certify-book needs to insist that each pathname for an include-book in the
; portcullis refer to the intended file, in particular so that the actual file
; read is not dependent upon cbd.  Consider for example:

; :set-cbd "/usr/home/moore/"
; (include-book "prelude")
; :set-cbd "/usr/local/src/library/"
; (certify-book "user")

; A naive implementation would provide a portcullis for "user" that contains
; (include-book "prelude").  But there is no clue as to the directory on which
; "prelude" resides.

; We deal with the issue above by allowing relative pathnames for include-book
; commands in the certification world, but modifying them, when necessary, to
; be appropriate absolute pathnames.  We say "when necessary" because
; include-book-fn sets the cbd to the directory of the book, so if the relative
; pathname resolves against that cbd to be the correct full-book-name, then no
; modification is necessary.

; This function takes the original cmds and a list of embedded event forms.  We
; return a list of commands that is guaranteed to be free of include-books with
; inappropriate relative pathnames, that nevertheless is equivalent to the
; original cmds from the standpoint of subsequent embedded events.  (Or, we
; return an error, but in fact we believe that that will not happen.)

; As mentioned at the outset above, this function also adds defpkg events.  We
; trust that the portcullis is a legal sequence of commands (actually, events),
; so the only point is to add hidden packages as per the Essay on Hidden
; Packages.

; Call this function using the same names parameter as that used when verifying
; that cmds is a list of embedded event forms.

  (let ((new-cmds (fix-portcullis-cmds1 dir cmds cbds nil names ctx state)))
    (er-let* ((new-defpkgs (hidden-defpkg-events
                            (global-val 'known-package-alist wrld)
                            wrld ctx state)))
      (value (revappend new-cmds new-defpkgs)))))

(defun collect-uncertified-books (alist)

; Alist is an include-book-alist and thus contains elements of the form
; described in include-book-alist-subsetp.  A typical element is
; (full-book-name user-book-name familiar-name cert-annotations . book-hash)
; and book-hash is nil if the book has not been certified.

  (cond ((null alist) nil)
        ((null (cddddr (car alist)))  ; book-hash
         (cons (caar alist)           ; full-book-name
               (collect-uncertified-books (cdr alist))))
        (t (collect-uncertified-books (cdr alist)))))

(defun chk-in-package (channel file empty-okp ctx state)

; Channel must be an open input object channel.  We assume (for error
; reporting purposes) that it is associated with the file named file.
; We read the first form in it and cause an error unless that form is
; an in-package.  If it is an in-package, we return the package name.

  (state-global-let*
   ((current-package "ACL2"))
   (mv-let (eofp val state)
           (read-object channel state)
           (cond
            (eofp (cond (empty-okp (value nil))
                        (t (er soft ctx
                               "The file ~x0 is empty.  An IN-PACKAGE form, ~
                                at the very least, was expected."
                               file))))
            ((and (true-listp val)
                  (= (length val) 2)
                  (eq (car val) 'in-package)
                  (stringp (cadr val)))
             (cond
              ((find-non-hidden-package-entry (cadr val)
                                              (known-package-alist state))
               (value (cadr val)))
              (t (er soft ctx
                     "The argument to IN-PACKAGE must be a known ~
                      package name, but ~x0, used in the first form ~
                      in ~x1, is not.  The known packages are ~*2~@3"
                     (cadr val)
                     file
                     (tilde-*-&v-strings
                      '&
                      (strip-non-hidden-package-names
                       (known-package-alist state))
                      #\.)
                     (if (global-val 'include-book-path (w state))
                         (msg "~%NOTE: This error might be eliminated by ~
                               certifying the book mentioned above.  See :DOC ~
                               certify-book.")
                       "")))))
            (t (er soft ctx
                   "The first form in ~x0 was expected to be ~
                    (IN-PACKAGE \"pkg\") where \"pkg\" is a known ~
                    ACL2 package name.  See :DOC book-contents.  The first ~
                    form was, in fact, ~x1."
                   file val))))))

(defmacro ill-formed-certificate-er (ctx mark file1 file2
                                         &optional
                                         (bad-object 'nil bad-objectp))

; Mark should be a symbol or a msg.

  `(er soft ,ctx
      "The certificate for the book ~x0 is ill-formed.  Delete or rename the ~
       file ~x1 and recertify ~x0.  Remember that the certification world for ~
       ~x0 is described in the portcullis of ~x1 (see :DOC portcullis) so you ~
       might want to look at ~x1 to remind yourself of ~x0's certification~ ~
       world.~|Debug note for developers:~|~@2~@3"
      ,file1 ,file2
      ,(if (and (consp mark)
                (eq (car mark) 'quote)
                (symbolp (cadr mark)))
           (symbol-name (cadr mark))
         mark)
      ,(if bad-objectp

; Developer debug:
;          `(msg "~|Bad object: ~X01" ,bad-object nil)

           `(msg "~|Bad object: ~x0" ,bad-object)
         "")))

(defun include-book-er-warning-summary (keyword suspect-book-action-alist
                                                state)

; See include-book-er for how this result is used.  We separate out this part
; of the computation so that we know whether or not something will be printed
; before computing the warning or error message.

; We return nil to cause a generic error, a keyword to cause an error
; suggesting the use of value t for that keyword, and a string for a potential
; warning.

  (let ((keyword-string
         (case keyword
           (:uncertified-okp "Uncertified")
           (:skip-proofs-okp "Skip-proofs")
           (:defaxioms-okp "Defaxioms")
           (t (if (eq keyword t)
                  nil
                (er hard 'include-book-er
                    "Include-book-er does not know the include-book keyword ~
                      argument ~x0."
                    keyword))))))
    (cond
     ((eq keyword t) nil)
     ((assoc-eq keyword suspect-book-action-alist)
      (cond
       ((cdr (assoc-eq keyword suspect-book-action-alist))
        (cond
         ((if (eq keyword :skip-proofs-okp)
              (not (f-get-global 'skip-proofs-okp-cert state))
            (and (eq keyword :defaxioms-okp)
                 (not (f-get-global 'defaxioms-okp-cert state))))

; Although suspect-book-action-alist allows this (implicit) include-book, we
; are attempting this include-book underneath a certify-book that disallows
; this keyword.  We signify this case by overloading warning-summary to be this
; keyword.

          keyword)
         (t keyword-string)))
       (t keyword)))
     (t (er hard 'include-book-er
            "There is a discrepancy between the keywords in the ~
             suspect-book-action-alist, ~x0, and the keyword, ~x1, supplied ~
             to include-book-er."
            suspect-book-action-alist
            keyword)))))

(defun include-book-er1 (file1 file2 msg warning-summary ctx state)

; Warning: Include-book-er assumes that this function returns (value nil) if
; there is no error.

  (cond
   ((null warning-summary)
    (er soft ctx "~@2" file1 file2 msg))
   ((symbolp warning-summary) ; keyword
    (cond
     ((member-eq (cert-op state)
                 '(nil :write-acl2xu)) ; not certification's fault
      (er soft ctx
          "~@0  This is illegal because we are currently attempting ~
           include-book with ~x1 set to NIL.  You can avoid this error by ~
           using a value of T for ~x1; see :DOC include-book."
          (msg "~@2" file1 file2 msg)
          warning-summary))
     (t ; certification's fault
      (er soft ctx
          "~@0  This is illegal because we are currently attempting ~
           certify-book; see :DOC certify-book."
          (msg "~@2" file1 file2 msg)))))
   (t (pprogn (warning$ ctx warning-summary "~@2" file1 file2 msg)
              (value nil)))))

(defun include-book-er (file1 file2 msg keyword suspect-book-action-alist ctx
                              state)

; Warning: The computation of cert-obj in include-book-fn1 assumes that this
; function returns (value nil) when not returning an error.

; Depending on various conditions we either do nothing and return (value nil),
; print a warning, or cause an error.  File1 and file2 are the full-book-name
; and its .cert file, respectively.  (Well, sometimes file2 is nil -- we never
; use it ourselves but msg might and supplies it when needed.)  Msg is an
; arbitrary ~@ fmt message, which is used as the error message and used in the
; warning message.  Suspect-book-action-alist is the alist manufactured by
; include-book, specifying the values of its keyword arguments.  Among these
; are arguments that control our behavior on these errors.  Keyword specifies
; the kind of error this is, using the convention that it is either t, meaning
; cause an error, or the keyword used by include-book to specify the behavior.
; For example, if this error reports the lack of a certificate, then keyword is
; :uncertified-okp.

  (let ((warning-summary
         (include-book-er-warning-summary keyword suspect-book-action-alist
                                          state)))

; If warning-summary is nil, we cause an error.  Otherwise, it is summary
; of the desired warning.

    (include-book-er1 file1 file2 msg warning-summary ctx state)))

(defun post-alist-from-channel (x y ch state)

; Ch is an object input channel opened to a certificate file.  We assume that
; all necessary packages exist so that we can read objects from ch without
; errors caused by unknown package names in symbols occurring in the portcullis
; commands or make-event expansions.  If that assumption may not hold, consider
; using post-alist-from-pcert1 instead.

  (mv-let (eofp obj state)
          (cond ((member-eq y ; last object read
                            '(:expansion-alist :cert-data))

; We really don't need this special case, given the assumptions expressed in
; the comment above.  But we might as well use read-object-suppress here, since
; maybe it does less consing.  However, we cannot do the same for
; :BEGIN-PORTCULLIS-CMDS, because an indefinite number of event forms follows
; that keyword (until :END-PORTCULLIS-CMDS).

                 (mv-let (eofp state)
                         (read-object-suppress ch state)
                         (mv eofp nil state)))
                (t (read-object ch state)))
          (cond ((or eofp
                     (eq obj :PCERT-INFO))
                 (mv x state))
                (t (post-alist-from-channel y obj ch state)))))

(defun certificate-file-and-input-channel1 (full-book-string cert-op state)
  (let ((cert-name (convert-book-string-to-cert full-book-string cert-op)))
    (mv-let
     (ch state)
     (open-input-channel cert-name :object state)
     (mv ch cert-name state))))

(defmacro pcert-op-p (cert-op)
  `(member-eq ,cert-op '(:create-pcert :create+convert-pcert :convert-pcert)))

(defrec cert-obj

; This record represents information stored in a certificate file.  The
; pre-alist and post-alist use full-book-names, which may be either absolute
; pathname strings or sysfiles to support relocation.

  ((cmds . pre-alist)
   post-alist
   (expansion-alist . cert-data)
   .

; The :pcert-info field is used for provisional certification.  Its value is
; either an expansion-alist that has not had locals elided (as per elide-locals
; and related functions), or one of tokens :proved or :unproved.  Note that an
; expansion-alist, even a nil value, implicitly indicates that proofs have been
; skipped when producing the corresponding certificate file (a .pcert0 file);
; the explicit value :unproved is stored when constructing a cert-obj from a
; .pcert1 file.

   pcert-info)
  t)

(defun get-cert-obj-and-cert-filename (full-book-name state)
  #+acl2-loop-only
  (declare (ignore full-book-name))
  #+acl2-loop-only
  (mv-let (erp val state)
    (read-acl2-oracle state)
    (let ((val (and (not erp)
                    (consp val)
                    (weak-cert-obj-p (car val))
                    (stringp (cdr val)))))
      (mv (car val) (cdr val) state)))
  #-acl2-loop-only
  (let ((entry (and *hcomp-book-ht*
                    (gethash full-book-name *hcomp-book-ht*))))
    (cond
     (entry (mv (access hcomp-book-ht-entry entry :cert-obj)
                (access hcomp-book-ht-entry entry :cert-filename)
                state))
     (t (mv nil nil state)))))

(defun certificate-file-and-input-channel (full-book-string full-book-name
                                                            old-cert-op state)

; This function returns (mv cert-obj cert-filename cert-op state), as described
; below.  If input full-book-name is nil, then cert-obj is a cert-obj record
; based on a certificate file, cert-filename, as discussed below.  Otherwise
; (if input full-book-name is non-nil), we expect to find cert-obj associated
; with full-book-name in *hcomp-book-ht*, in which case cert-filename comes
; from cert-obj.

; Finally, suppose that input full-book-name is nil.  Old-cert-op is non-nil
; when we are looking for an existing certificate file built for that cert-op.
; Otherwise we first look for a .cert file, then a .pcert0 file, and otherwise
; (finally) a .pcert1 file.  We prefer a .pcert0 to a .pcert1 file simply
; because a .pcert1 file is produced by copying from a .pcert0 file; thus a
; .pcert1 file may be incomplete if it is consulted while that copying is in
; progress.  (The .pcert0 file, on the other hand, is produced atomically just
; as a .cert file is produced atomically, by moving a temporary file.)

  (mv-let (cert-obj cert-filename state)
    (if full-book-name
        (get-cert-obj-and-cert-filename full-book-name state)
      (mv nil nil state))
    (cond
     (cert-obj
      (mv cert-obj cert-filename state))
     (old-cert-op
      (mv-let (ch cert-name state)
        (certificate-file-and-input-channel1 full-book-string old-cert-op
                                             state)
        (mv ch cert-name state)))
     (t
      (mv-let ; try .cert first
        (ch cert-name state)
        (certificate-file-and-input-channel1 full-book-string t state)
        (cond (ch (mv ch cert-name state))
              (t (mv-let ; try .pcert0 next
                   (ch cert-name state)
                   (certificate-file-and-input-channel1 full-book-string
                                                        :create-pcert
                                                        state)
                   (cond (ch (mv ch cert-name state))
                         (t (mv-let ; finally try .pcert1
                              (ch cert-name state)
                              (certificate-file-and-input-channel1
                               full-book-string :convert-pcert state)
                              (mv ch cert-name state))))))))))))

(defun cert-annotations-and-checksum-from-cert-file (full-book-string state)

; See the requirement in post-alist-from-channel, regarding necessary packages
; existing.

  (mv-let
   (ch cert-name state)
   (certificate-file-and-input-channel full-book-string

; This function is only called in error reporting.  We supply nil for
; full-book-name since we prefer to read the cert file rather than to rely on
; what is stored in hcomp hash tables.

                                       nil
                                       (if (eq (cert-op state)
                                               :convert-pcert)
                                           :create-pcert
                                         nil)
                                       state)
   (declare (ignore cert-name))
   (cond (ch (mv-let (x state)
                     (post-alist-from-channel nil nil ch state)
                     (pprogn (close-input-channel ch state)
                             (value (cdddr (car x))))))
         (t (silent-error state)))))

(defun tilde-@-cert-post-alist-phrase (full-book-string familiar-name
                                                        cdr-reqd-entry
                                                        cdr-actual-entry
                                                        state)
  (declare (ignore cdr-reqd-entry))
  (mv-let (erp pair state)
          (cert-annotations-and-checksum-from-cert-file full-book-string state)
          (mv (let ((cert-maybe-unchanged-p
                     (cond (erp ; certificate was deleted
                            nil)
                           ((null (cdr cdr-actual-entry))

; But it is possible that checksum in the current include-book-alist is nil
; only because of a problem with a subsidiary book.  So we don't want to print
; a scary "AND NOTE" below in this case.

                            t)
                           (t
                            (equal cdr-actual-entry pair)))))
                (cond (erp
                       (msg "~|AND NOTE that file ~x0 does not currently ~
                             exist, so you will need to recertify ~x1 and the ~
                             books that depend on it (and, if you are using ~
                             an image created by save-exec, then consider ~
                             rebuilding that image)"
                            (concatenate 'string familiar-name ".cert")
                            familiar-name))
                      (cert-maybe-unchanged-p
                       " so book recertification is probably required")
                      (t
                       (msg "~|AND NOTE that file ~x0 changed after ~x1 was ~
                             included, so you should probably undo back ~
                             through the command that included ~x1 (or, if ~
                             you are using an image created by save-exec, ~
                             consider rebuilding that image)"
                            (concatenate 'string familiar-name ".cert")
                            familiar-name))))
              state)))

(defun assoc-familiar-name (familiar-name alist)
  (cond ((endp alist) nil)
        ((equal familiar-name (caddr (car alist)))
         (car alist))
        (t (assoc-familiar-name familiar-name (cdr alist)))))

(defun tilde-*-book-hash-phrase1 (reqd-alist actual-alist state)

; The two alists are include-book-alists.  Thus, each element of each is of the
; form (full-book-name directory-name familiar-name cert-annotations
; . book-hash).  For each entry (cert-annotations . book-hash) in reqd-alist we
; either find a corresponding entry for the same full-book-name in actual-alist
; (note that we ignore the directory-name and familiar-name, which may differ
; between the two but are irrelevant) or else we return a message.

  (cond
   ((null reqd-alist) (mv nil state))
   (t (let* ((reqd-entry (cdddr (car reqd-alist)))
             (familiar-name (caddr (car reqd-alist)))
             (full-book-name (car (car reqd-alist)))
             (actual-element (assoc-equal full-book-name actual-alist))
             (actual-entry (cdddr actual-element)))
        (cond
         ((null actual-entry)

; At one time we believed that there must be an entry for full-book-name,
; erroneously thinking that otherwise we would have caused an error when trying
; to include the book (or process its portcullis commands).  We have seen that
; this need not be the case when the certificate was built in a different
; directory, so that the full-book-name, which is from the certificate, can
; differ from the full-book-name in the world that corresponds to the same
; familiar-name.

          (let* ((pair (assoc-familiar-name familiar-name actual-alist))
                 (wrld (w state))
                 (full-book-string
                  (book-name-to-filename full-book-name
                                         wrld
                                         'tilde-*-book-hash-phrase1))
                 (msg
                  (cond (pair (msg "-- its certificate requires the book ~
                                    \"~s0\", but that book has not been ~
                                    included although the book \"~s1\" -- ~
                                    which has the same familiar name as that ~
                                    required book (but with a different ~
                                    full-book-name; see :DOC full-book-name) ~
                                    -- has been included"
                                   full-book-string
                                   (book-name-to-filename (car pair)
                                                          wrld
                                                          'tilde-*-book-hash-phrase1)))
                        (t    (msg "-- its certificate requires the book ~
                                    \"~s0\", but that book has not been ~
                                    included, nor has any book with the same ~
                                    familiar name as that required book (see ~
                                    :DOC full-book-name) -- perhaps the ~
                                    certificate file changed during inclusion ~
                                    of some superior book"
                                   full-book-string)))))
            (mv-let
              (msgs state)
              (tilde-*-book-hash-phrase1 (cdr reqd-alist)
                                         actual-alist
                                         state)
              (mv (cons msg msgs)
                  state))))
         ((equal reqd-entry actual-entry)
          (tilde-*-book-hash-phrase1 (cdr reqd-alist)
                                     actual-alist
                                     state))
         (t
          (mv-let
            (msgs state)
            (tilde-*-book-hash-phrase1 (cdr reqd-alist)
                                       actual-alist
                                       state)
            (let ((full-book-string
                   (book-name-to-filename full-book-name
                                          (w state)
                                          'tilde-*-book-hash-phrase1)))
              (mv-let
                (phrase state)
                (tilde-@-cert-post-alist-phrase full-book-string
                                                familiar-name
                                                reqd-entry
                                                actual-entry
                                                state)
                (mv (cons
                     (cond
                      ((null (cdr actual-entry))
                       (msg "-- its certificate requires the uncertified book ~
                           ~x0~@1"
                            full-book-string
                            phrase))
                      (t
                       (msg "-- its certificate requires the book \"~s0\" with ~
                           certificate annotations~|  ~x1~|and book hash ~x2, ~
                           but we have included ~@3~@4"
                            full-book-string
                            (car reqd-entry) ;;; cert-annotations
                            (cdr reqd-entry) ;;; book-hash
                            (msg "a version of ~x0 with certificate ~
                                  annotations~|  ~x1~|and book-hash ~x2,"
                                 familiar-name
                                 (car actual-entry) ; cert-annotations
                                 (cdr actual-entry))
                            phrase)))
                     msgs)
                    state))))))))))

(defun tilde-*-book-hash-phrase (reqd-alist actual-alist state)

; The two alists each contain pairs of the form (full-book-name user-book-name
; familiar-name cert-annotations . book-hash).  Reqd-alist shows what is
; required and actual-alist shows what is actual (presumably, present in the
; world's include-book-alist).  We know reqd-alist ought to be an `include-book
; alist subset' of actual-alist but it is not.

  (mv-let
    (phrase1 state)
    (tilde-*-book-hash-phrase1 reqd-alist
                               actual-alist
                               state)
    (mv (list "~|" "~|~@*" "~|~@*;~|" "~|~@*;~|"
              phrase1)
        state)))

(defun get-cmds-from-portcullis1 (eval-hidden-defpkgs ch ctx state ans)

; Keep this in sync with equal-modulo-hidden-defpkgs, make-hidden-defpkg, and
; the #-acl2-loop-only and #+acl2-loop-only definitions of defpkg.

; Also keep this in sync with chk-raise-portcullis2.

; We read successive forms from ch, stopping when we get to
; :END-PORTCULLIS-CMDS and returning the list of forms read, which we
; accumulate onto ans as we go.  Ans should be nil initially.

  (mv-let (eofp form state)
          (read-object ch state)
          (cond
           (eofp (mv t nil state))
           ((eq form :END-PORTCULLIS-CMDS)
            (value (reverse ans)))
           ((and eval-hidden-defpkgs
                 (case-match form
                   (('defpkg & & & & 't) t)
                   (& nil)))
            (er-progn (trans-eval-default-warning form ctx state
; Perhaps aok could be t, but we use nil just to be conservative.
                                                  nil)
                      (get-cmds-from-portcullis1
                       eval-hidden-defpkgs ch ctx state (cons form ans))))
           (t (get-cmds-from-portcullis1
               eval-hidden-defpkgs ch ctx state (cons form ans))))))

(defun hidden-defpkg-events-simple (kpa acc)

; Warning: Keep this in sync with hidden-defpkg-events.

  (cond
   ((endp kpa) (reverse acc))
   ((not (package-entry-hidden-p (car kpa)))
    (hidden-defpkg-events-simple (cdr kpa) acc))
   (t
    (let* ((e (car kpa))
           (n (package-entry-name e))
           (imports (package-entry-imports e))
           (event (package-entry-defpkg-event-form e))
           (name (cadr event)))
      (hidden-defpkg-events-simple
       (cdr kpa)
       (cons `(defpkg ,name
                ,(assert$
                  event
                  (assert$
                   (equal n name)
                   (kwote imports))))
             acc))))))

(defun get-cmds-from-portcullis (file1 file2 eval-hidden-defpkgs ch ctx state)

; In order to read the certificate's portcullis for a book that has been
; included only locally in the construction of the current world, we may need
; to evaluate the hidden packages (see the Essay on Hidden Packages)
; created by that book.  We obtain the necessary defpkg events by calling
; hidden-defpkg-events-simple below.

; See the comment about "eval hidden defpkg events" in chk-raise-portcullis.

  (revert-world-on-error
   (let* ((wrld (w state))
          (events (hidden-defpkg-events-simple
                   (global-val 'known-package-alist wrld)
                   nil)))
     (er-progn
      (if events
          (state-global-let*
           ((inhibit-output-lst (remove1-eq 'error *valid-output-names*)))
           (trans-eval-default-warning (cons 'er-progn events) ctx state t))
        (value nil))
      (mv-let
       (erp val state)
       (get-cmds-from-portcullis1 eval-hidden-defpkgs ch ctx state nil)
       (cond (erp (ill-formed-certificate-er
                   ctx 'get-cmds-from-portcullis
                   file1 file2))
             (t (pprogn (if events ; optimization
                            (set-w! wrld state)
                          state)
                        (value val)))))))))

(defun convert-book-string-to-port (x)

; X is a book pathname (a string).  We generate the corresponding .port file
; name.  See the related function, convert-book-name-to-cert-name.

  (concatenate 'string
               (remove-lisp-suffix x nil)
               "port"))

(defun chk-raise-portcullis2 (file1 file2 ch-or-cmds port-file-p ctx state ans)

; Keep this in sync with get-cmds-from-portcullis1.

; We read successive forms from ch-or-cmds, which is either a channel or a
; list, and trans-eval them.  We stop when we get to the end or, in the common
; case that port-file-p is false and ch-or-cmds is a channel,
; :END-PORTCULLIS-CMDS.  We may cause an error.  It is assumed that each form
; evaluated is a DEFPKG or an event form and is responsible for installing its
; world in state.  This assumption is checked by chk-acceptable-certify-book,
; before a .cert file or .port file is written.  (The user might violate this
; convention by manually editing a .port file, but .port files are only used
; when including uncertified books, where all bets are off anyhow.)  We return
; the list of forms read, which we accumulate onto ans as we go.  Ans should be
; nil initially.

  (mv-let (eofp form ch-or-cmds state)
    (cond ((null ch-or-cmds) ; case of empty list, not channel
           (mv t nil nil state))
          ((symbolp ch-or-cmds) ; channel
           (mv-let (eofp form state)
             (read-object ch-or-cmds state)
             (mv eofp form ch-or-cmds state)))
          (t ; ch-or-cmds is a true-list
           (mv nil (car ch-or-cmds) (cdr ch-or-cmds) state)))
    (cond
     (eofp
      (cond ((or (null ch-or-cmds) ; list case, not channel
                 port-file-p)
             (value (reverse ans)))
            (t (ill-formed-certificate-er
                ctx
                'chk-raise-portcullis2{port}
                file1 file2))))
     ((and (eq form :END-PORTCULLIS-CMDS)
           (not port-file-p))
      (assert$ (not (listp ch-or-cmds)) ; channel case, not list
               (value (reverse ans))))
     (t (mv-let
          (error-flg trans-ans state)
          (trans-eval-default-warning form
                                      (msg (if port-file-p
                                               "the .port file for ~x0"
                                             "the portcullis for ~x0")
                                           file1)
                                      state
                                      t)

; If error-flg is nil, trans-ans is of the form
; ((nil nil state) . (erp' val' replaced-state))
; because form is a DEFPKG or event form.

          (let ((erp-prime (car (cdr trans-ans))))
            (cond
             ((or error-flg erp-prime) ;erp'
              (pprogn
               (cond
                (port-file-p
                 (warning$ ctx "Portcullis"
                           "The error reported above was caused while ~
                                 trying to execute commands from file ~x0 ~
                                 while including uncertified book ~x1.  In ~
                                 particular, we were trying to execute ~x2 ~
                                 when the error occurred.  Because of this ~
                                 error, we cannot complete the include-book ~
                                 operation for the above book, in the current ~
                                 world.  You can perhaps eliminate this error ~
                                 by removing file ~x0."
                           (convert-book-string-to-port file1)
                           file1
                           form))
                (t
                 (warning$ ctx "Portcullis"
                           "The error reported above was caused while ~
                                 trying to raise the portcullis for the book ~
                                 ~x0.  In particular, we were trying to ~
                                 execute ~x1 when the error occurred.  ~
                                 Because we cannot raise the portcullis, we ~
                                 cannot include this book in this world.  ~
                                 There are two standard responses to this ~
                                 situation.  Either change the current ~
                                 logical world so that this error does not ~
                                 occur, e.g., redefine one of your functions, ~
                                 or recertify the book in a different ~
                                 environment."
                           file1 form)))
               (mv t nil state)))
             (t (chk-raise-portcullis2 file1 file2 ch-or-cmds port-file-p
                                       ctx state
                                       (cons form ans))))))))))

(defun chk-raise-portcullis1 (file1 file2 ch-or-cert-obj port-file-p ctx state)

; After resetting the acl2-defaults-table, we read and eval each of the forms
; specified by ch-or-cert-obj -- which may be a channel, and otherwise is a
; valid cert-obj record from which we obtain the :cmds field -- until we get to
; the end, which may be marked by :END-PORTCULLIS-CMDS (see
; chk-raise-portcullis2).  However, we temporarily skip proofs (in an error
; protected way).  We return the list of command forms in the portcullis.

  (state-global-let*
   ((ld-skip-proofsp 'include-book)
    (skip-proofs-by-system t)
    (in-local-flg

; As we start processing events on behalf of including a book, we are no longer
; in the lexical scope of LOCAL for purposes of disallowing setting of the
; acl2-defaults-table.

     (and (f-get-global 'in-local-flg state)
          'local-include-book)))
   (er-progn
    (maybe-install-acl2-defaults-table

; The point here is to re-create the environment in which the book to be
; included was originally certified.  If we do not install the original
; acl2-defaults-table then we can, for example, certify a book defining (foo
; x) = (car x), then in a new session include this book after
; (set-verify-guards-eagerness 2), and then get a hard error with (foo 3).

     *initial-acl2-defaults-table*
     state)
    (chk-raise-portcullis2 file1 file2
                           (if (symbolp ch-or-cert-obj) ; channel, not cert-obj
                               ch-or-cert-obj
                             (access cert-obj ch-or-cert-obj :cmds))
                           port-file-p ctx state nil))))

(defun mark-local-included-books (post-alist1 post-alist2)

; See make-certificate-file for an explanation of this function.  Roughly
; speaking, we copy post-alist1 (which is the include-book-alist after the
; events in the main book were successfully proved) and every time we find a
; non-local book in it that is not in post-alist2 (which is the
; include-book-alist after the main book was included by certify-book's second
; pass), we mark that element LOCAL.  We know that post-alist2 is a subset of
; post-alist1.  Thus, if we then throw out all the elements marked LOCAL we get
; post-alist2.

; One might ask why we mark post-alist1 this way rather than just put
; post-alist2 into the certificate object in the first place.  One reason
; is to allow a hand inspection of the certificate to see exactly what
; versions of the local subbooks participated in the certification.  But a more
; critical reason is to note the use of skip-proofs in locally included
; subbooks; see the Essay on Skip-proofs.

; Recall that each element of an include-book-alist is (full-book-name
; user-book-name familiar-name cert-annotations . book-hash).  We only look at
; the full-book-name components below.

  (cond ((null post-alist1) nil)
        ((eq (caar post-alist1) 'local)
         (cons (car post-alist1)
               (mark-local-included-books (cdr post-alist1) post-alist2)))
        ((assoc-equal (caar post-alist1) post-alist2)
         (cons (car post-alist1)
               (mark-local-included-books (cdr post-alist1) post-alist2)))
        (t (cons (list 'local (car post-alist1))
                 (mark-local-included-books (cdr post-alist1) post-alist2)))))

(defun unmark-and-delete-local-included-books (post-alist3)

; See make-certificate-file for an explanation of this function.  Roughly
; speaking, this function undoes what mark-local-included-books does.  If
; post-alist3 is the result of marking post-alist1 and post-alist2, then this
; function produces post-alist2 from post-alist3.  Given our use of it, it
; produces the include-book-alist you should have after any successful
; inclusion of the main book.

  (cond ((null post-alist3) nil)
        ((eq (caar post-alist3) 'LOCAL)
         (unmark-and-delete-local-included-books (cdr post-alist3)))
        (t (cons (car post-alist3)
                 (unmark-and-delete-local-included-books (cdr post-alist3))))))

(defun earlier-acl2-versionp (version1 version2)

; This function ignores the part of each version string after the first
; parenthesis (if any).  While it is no longer used in the sources (as of May
; 1, 2010), it is used in community book books/hacking/ and is a handy utility,
; so we leave it here.

  (mv-let (major1 minor1 incrl1 rest1)
    (parse-version version1)
    (declare (ignore rest1))
    (mv-let (major2 minor2 incrl2 rest2)
      (parse-version version2)
      (declare (ignore rest2))
      (cond
       ((or (null major1) (null major2))
        (er hard 'earlier-acl2-versionp
            "We are surprised to find an ACL2 version string, ~x0, that ~
               cannot be parsed."
            (if (null major1)
                version1
              version2)))
       (t
        (or (< major1 major2)
            (and (int= major1 major2)
                 (assert$ (and (natp minor1) (natp minor2))
                          (or (< minor1 minor2)
                              (and (int= minor1 minor2)
                                   (< incrl1 incrl2)))))))))))

(defun acl2-version-r-p (version)
  (let ((p (position #\( version)))
    (and p
         (< (+ p 2) (length version))
         (equal (subseq version p (+ p 3)) "(r)"))))

(defun ttag-alistp (x)

; We don't check that pathnames are absolute, but that isn't important here.

  (cond ((atom x)
         (null x))
        (t (and (consp (car x))
                (symbolp (caar x))
                (true-listp (cdar x))
                (book-name-listp (remove1 nil (cdar x)))
                (ttag-alistp (cdr x))))))

(defun cert-annotationsp (x)
  (case-match x
    (((':SKIPPED-PROOFSP . sp)
      (':AXIOMSP . ap)
      . ttags-singleton)
     (and (member-eq sp '(t nil ?))
          (member-eq ap '(t nil ?))
          (or (null ttags-singleton)
              (case-match ttags-singleton
                (((':TTAGS . ttags))
                 (ttag-alistp ttags))
                (& nil)))))
    (& nil)))

(defconst *trivial-book-hash* :trivial-book-hash)

(defun cert-hash (old-cert-hash cmds pre-alist post-alist
                                expansion-alist cert-data state)

; If old-cert-hash is non-nil, then we compute a hash whose type (integer or
; *trivial-book-hash*) matches the type of old-cert-hash.  Otherwise, we
; compute a hash (which could be written into a certificate) that is an integer
; unless state global 'book-hash-alistp is true, in which case it is the token
; *trivial-book-hash*.

  (cond ((if old-cert-hash
             (integerp old-cert-hash)
           (not (f-get-global 'book-hash-alistp state)))

; The inputs are potential fields of a cert-obj record.  We deliberately omit
; the :pcert-info field of a cert-obj from the checksum: we don't want the
; checksum changing from the .pcert0 file to the .pcert1 file, and anyhow, its
; only function is to assist in proofs for the Convert procedure of provisional
; certification.

         (check-sum-obj
          (cons (cons cmds pre-alist)
                (list* post-alist expansion-alist cert-data))))
        (t *trivial-book-hash*)))

(defun include-book-alist-entry-p (entry)
  (and (consp entry)
       (book-name-p (car entry))
       (consp (cdr entry))
       (stringp (cadr entry)) ; user-book-name
       (consp (cddr entry))
       (stringp (caddr entry)) ; familiar-name
       (consp (cdddr entry))
       (cert-annotationsp (cadddr entry)) ; cert-annotations
       (let ((book-hash (cddddr entry)))
         (case-match book-hash
           (((':BOOK-LENGTH . book-length)
             (':BOOK-WRITE-DATE . book-write-date))
            (and (natp book-length)
                 (natp book-write-date)))
           (& (integerp book-hash))))))

(defun sysfile-to-filename (x state)
  (cond ((sysfile-p x)
         (extend-pathname (sysfile-key x)
                          (sysfile-filename x)
                          state))
        (t x)))

(defun keyword-listp (x)
  (declare (xargs :guard t))
  (if (consp x)
      (and (keywordp (car x))
           (keyword-listp (cdr x)))
    (null x)))

(defun read-file-into-template (template ch state acc)

; Ch is a channel pointing to a tail of some file.  Template is a list for
; which each member is either a distinct keyword or nil.  We return a list of
; values in one-one correspondence with template, corresponding to values that
; have been read in order from ch -- except, each keyword value is a
; "placeholder" that indicates an optional value preceded by the indicated
; keyword.  For example, suppose template is (:k1 :k2 nil :k3 :k4 nil), and
; forms in the tail of the file indicated by ch are (:k1 a b :k4 c d).  Then
; the value returned is the list (a nil b nil c d), since :k2 and :k3 are
; missing.

; Suppose however that the first form in the tail of the file is :k2.  In that
; case we don't want to return a first value of :k2 for :k1; rather, we return
; nil for :k1 and consider :k2 to be present.

; On the other hand, suppose that the first form in the tail of the file is
; :k3.  Since in the template nil resides between :k1 and :k3, then the value
; corresponding to :k3 cannot be the next value to be read.  So to simplify
; this function, we assume that no keyword in template can be a value that is
; to be returned -- such a keyword must always be a placeholder.

; The error triple may have a non-nil error component.  We confess that in
; order to make sense of such a return, one needs to read the code below.

; Note that it is an error to have a "stray" value, that is, to read a value
; that is not associated with any member of template.

  (cond
   ((null template)

; It is an error to have a "stray" value.

    (mv-let (eofp val state)
      (read-object ch state)
      (cond (eofp (value (reverse acc)))
            (t (mv 'stray-value1 (list val template) state)))))
   (t
    (mv-let (eofp val state)
      (read-object ch state)
      (cond
       (eofp
        (cond
         ((keyword-listp template)
          (value (revappend acc (make-list (length template)))))
         (t (mv 'eof template state))))
       ((null (car template))
        (read-file-into-template (cdr template)
                                 ch
                                 state
                                 (cons val acc)))
       ((eq val (car template)) ; simple case of reading next keyword
        (mv-let (eofp val state)
          (read-object ch state)
          (cond
           (eofp (mv 'eof template state))
           (t (read-file-into-template (cdr template)
                                       ch
                                       state
                                       (cons val acc))))))
       (t

; We have read a value V that is not the keyword that is the next member of
; template.  We assign nil to every keyword in template until either we find V
; or we find nil.  If we find V, then we read one more value to assign to V.
; Otherwise V is already the next value.

        (let ((posn-kwd-val (and (keywordp val)
                                 (position-eq val template)))
              (posn-nil (position-eq nil template)))
          (cond
           (posn-kwd-val
            (cond
             ((and posn-nil
                   (< posn-nil posn-kwd-val))
              (mv :kwd-late
                  (list posn-kwd-val
                        posn-nil
                        template)
                  state))
             (t (mv-let (eofp val2 state)
                  (read-object ch state)
                  (cond (eofp (mv 'eof val state))
                        (t (read-file-into-template
                            (cdr (nthcdr posn-kwd-val template))
                            ch
                            state
                            (cons val2
                                  (make-list-ac posn-kwd-val nil acc)))))))))
           (posn-nil
            (read-file-into-template
             (cdr (nthcdr posn-nil template))
             ch
             state
             (cons val
                   (make-list-ac posn-nil nil acc))))
           (t ; no template element available for this value
            (assert$
             (keyword-listp template)
             (mv 'stray-value2 (list val template) state)))))))))))

(defun cert-data-fal (cert-data)

; Warning: Consider all cert-data keys here and in all other functions with
; this warning.  There is no need to consider the key :pass1-saved here.
; Moreover, keep the order of keys here the same as the order of keys produced
; by cert-data-for-certificate: this one is used by include-book and that one
; by certify-book.

; Cert-data is the value of :cert-data from a certificate file.  In general,
; this function is equivalent to the identity function on alists: we expect the
; serialize reader and writer to preserve the fast-alist nature of the
; :type-prescription field of cert-data.  However, this function is nontrivial
; if the certificate file is written without the serialize writer.

  (let* ((pair1 (assoc-eq :translate cert-data))
         (a1 (if pair1
                 (acons :translate
                        (make-fast-alist (cdr pair1))
                        nil)
               nil))
         (pair2 (assoc-eq :type-prescription cert-data))
         (a2 (if pair2
                 (acons :type-prescription
                        (make-fast-alist (cdr pair2))
                        a1)
               a1)))
    a2))

(defun include-book-alistp-1 (x local-markers-allowedp)
  (cond
   ((atom x) (null x))
   (t (and (consp (car x))
           (let ((entry (car x)))
             (cond ((and (consp entry)
                         (eq (car entry) 'local))
                    (and local-markers-allowedp
                         (consp (cdr entry))
                         (null (cddr entry))
                         (include-book-alist-entry-p (cadr entry))))
                   (t (include-book-alist-entry-p entry))))
           (include-book-alistp-1 (cdr x) local-markers-allowedp)))))

(defun include-book-alistp (x local-markers-allowedp)

; We check whether x is a legal include-book-alist in the given version.  If
; local-markers-allowedp we consider entries of the form (LOCAL e) to be legal
; if e is legal; otherwise, LOCAL is given no special meaning.  (We expect to
; give this special treatment for post-alists; see the comments in
; make-certificate-file.)

  (include-book-alistp-1 x local-markers-allowedp))

(defun include-book-raw-error (str state)
  #+acl2-loop-only
  (declare (ignore str))
  #-acl2-loop-only
  (error str)
  (value nil))

(defun chk-raise-portcullis (file1 file2 ch-or-cert-obj light-chkp caller
                                   ctx state
                                   suspect-book-action-alist evalp)

; File1 is a full-book-string and file2 is the corresponding certificate file.
; Ch is either an open object input channel to the certificate or a valid
; cert-obj record based on the certificate.  We have already read past the
; initial (in-package "ACL2"), acl2-version and the :BEGIN-PORTCULLIS-CMDS in
; ch.  We now read successive commands and, if evalp is true, evaluate them in
; state.  Ld-skip-proofsp is 'include-book for this operation because these
; commands have all been successfully carried out in a boot strap world.  If
; this doesn't cause an error, then we read the optional :expansion-alist,
; cert-data, pre- and post- alists, and final cert-hash.  If the pre- and
; post-alists are not present or are of the wrong type, or if values are of the
; wrong type or there is additional text in the file, or the final cert-hash is
; inaccurate, we may cause an error.

; Light-chkp is t when we are content to avoid rigorous checks on the
; certificate, say because we are simply interested in some information that
; need not be fully trusted.

; Unless we are told to ignore the pre-alist, we check that it is a subset of
; the current include-book-alist.  Failure of this check may lead either to an
; error or to the assumption that the book is uncertified, according to the
; suspect-book-action-alist.  If we don't cause an error we return either the
; certificate object, which is a cert-obj record, or else we return nil,
; indicating that the book is presumed uncertified.

  (with-reckless-readtable

; We may use with-reckless-readtable above because the files we are reading
; were written out automatically, not by users.

   (er-let*
       ((portcullis-cmds
         (if evalp
             (chk-raise-portcullis1 file1 file2 ch-or-cert-obj nil ctx state)
           (assert$

; As of this writing, when we are allowing a cert-obj to be obtained using
; hcomp hash tables, evalp is true.  So when evalp is false, ch-or-cert-obj is
; a channel, hence a symbol.  If that changes then below, when ch-or-cert-obj
; is a list rather than a channel, we should return (access cert-obj
; ch-or-cert-obj :cmds).

            (symbolp ch-or-cert-obj)
            (get-cmds-from-portcullis
             file1 file2

; When we are raising the portcullis on behalf of the Convert procedure of
; provisional certification, we may need to eval hidden defpkg events from the
; portcullis.  Each such eval is logically a no-op (other than restricting
; potential logical extensions made later with defpkg), but it permits reading
; the rest of the certificate file.  See the comment in chk-bad-lisp-object for
; an example from Sol Swords showing how this can be necessary.

             (eq caller 'convert-pcert)
             ch-or-cert-obj ctx state)))))
     (cond
      ((consp ch-or-cert-obj)

; We skipped the following check when reading the certificate into
; ch-or-cert-obj during the early load of the compiled file.  (See the Appendix
; to the Essay on Hash Table Support for Compilation.)  So we do it now.

       (cond ((include-book-alist-subsetp
               (access cert-obj ch-or-cert-obj :pre-alist)
               (global-val 'include-book-alist (w state)))
              (value ch-or-cert-obj))
             (t
              (include-book-raw-error
               "There is a problem with the certificate, which may be ~
                described below in detail."
               state))))
      (t
       (mv-let (erp tuple state)
         (read-file-into-template '(:expansion-alist
                                    :cert-data
                                    nil ; pre-alist
                                    nil ; post-alist3
                                    nil ; cert-hash1
                                    :pcert-info)
                                  ch-or-cert-obj state nil)
         (cond
          (erp (if (eq caller 'include-book-raw)
                   (include-book-raw-error
                    "Ill-formed certificate"
                    state)
                 (ill-formed-certificate-er
                  ctx
                  'chk-raise-portcullis{read-file-into-template}
                  file1 file2)))
          (t
           (let* ((expansion-alist (nth 0 tuple))
                  (cert-data (cert-data-fal (nth 1 tuple)))
                  (pre-alist (nth 2 tuple))
                  (post-alist3 (nth 3 tuple))
                  (cert-hash1 (nth 4 tuple))
                  (pcert-info (if (eq caller 'convert-pcert)
                                  (nth 5 tuple)
                                nil))
                  (unexpected-from-book-name

; We consider the book to be uncertified if the full-book-name doesn't match
; the sysfile stored for the book in its certificate.  Note that (caar
; post-alist3) represents the book being included.  When the book was
; certified, the post-alist was created after pass 1 from (global-val
; 'include-book-alist-all (w state)), so the topmost entry is the most recent,
; hence for the book being included.

                   (and (consp post-alist3)
                        (consp (car post-alist3))
                        (sysfile-p (caar post-alist3))
                        (let ((filename
                               (book-name-to-filename (caar post-alist3)
                                                      (w state)
                                                      ctx)))
                          (and (not (equal filename file1))
                               filename)))))
             (er-let* ((pre-alist
                        (cond ((include-book-alistp pre-alist nil)
                               (value pre-alist))
                              ((eq caller 'include-book-raw)
                               (include-book-raw-error
                                "Ill-formed certificate"
                                state))
                              (t (ill-formed-certificate-er
                                  ctx
                                  'chk-raise-portcullis{pre-alist-2}
                                  file1 file2 pre-alist))))
                       (post-alist3
                        (cond ((include-book-alistp post-alist3 t)
                               (value post-alist3))
                              ((eq caller 'include-book-raw)
                               (include-book-raw-error
                                "Ill-formed certificate"
                                state))
                              (t (ill-formed-certificate-er
                                  ctx
                                  'chk-raise-portcullis{post-alist-2}
                                  file1 file2 post-alist3))))
                       (cert-hash2
                        (value (and (not light-chkp) ; optimization
                                    (cert-hash
                                     cert-hash1
                                     portcullis-cmds ; :cmds
                                     pre-alist       ; :pre-alist
                                     post-alist3     ; :post-alist
                                     expansion-alist ; :expansion-alist
                                     cert-data       ; :cert-data
                                     state))))
                       (actual-alist
                        (value (global-val 'include-book-alist (w state)))))
               (cond
                ((and (not light-chkp)
                      (not (equal cert-hash1 cert-hash2)))
                 (if (eq caller 'include-book-raw)
                     (include-book-raw-error
                      "Ill-formed certificate"
                      state)
                   (ill-formed-certificate-er
                    ctx
                    'chk-raise-portcullis{cert-hash}
                    file1 file2
                    (list :cert-hash1 cert-hash1 :cert-hash2 cert-hash2

; Developer debug:
;                :portcullis-cmds portcullis-cmds
;                :pre-alist pre-alist
;                :post-alist3 post-alist3
;                :expansion-alist expansion-alist

                          ))))
                ((and (not light-chkp)
                      (or unexpected-from-book-name
                          (and (not (eq caller 'include-book-raw))

; See above where we do this include-book-alist-subsetp check on the cert-obj
; being saved here -- we are here during the early load of the compiled file.

                               (not (include-book-alist-subsetp
                                     pre-alist
                                     actual-alist)))))

; Note: Sometimes I have wondered how the expression above deals with LOCAL
; entries in the alists in question, because include-book-alist-subsetp does
; not handle them.  The answer is: there are no LOCAL entries in a pre-alist --
; note that if the certification world has local events then those are dropped
; from the certification world before building the pre-alists (see
; certify-book-fn, and for some potentially helpful background see the Essay on
; Hidden Packages Added by Certify-book.

; Our next step is to call include-book-er, but we break up that computation so
; that we avoid needless computation (potentially reading certificate files) if
; no action is to be taken.

                 (if (eq caller 'include-book-raw)
                     (include-book-raw-error
                      "Unexpected error"
                      state)
                   (let ((warning-summary
                          (include-book-er-warning-summary
                           :uncertified-okp
                           suspect-book-action-alist
                           state)))
                     (cond
                      ((or (and (equal warning-summary "Uncertified")
                                (warning-disabled-p "Uncertified"))
                           (eq caller 'include-book-raw))
                       (value nil))
                      (unexpected-from-book-name
                       (include-book-er1 file1 file2

; The uses of ~| below are to ensure that both book filenames start in column
; 0, to make it easy to see their difference.  We avoid concluding with a
; newline because two spaces may be printed before printing another sentence,
; for example, during certification: " This is illegal because we are currently
; attempting certify-book; see :DOC certify-book."

                                         (msg "The book being ~
                                               included,~|~s0,~%is not in the ~
                                               location expected for the ACL2 ~
                                               executable being used:~|~s1."
                                              file1
                                              unexpected-from-book-name)
                                         warning-summary ctx state))
                      (t (mv-let (msgs state)
                           (tilde-*-book-hash-phrase pre-alist actual-alist
                                                     state)
                           (include-book-er1 file1 file2
                                             (cons
                                              "After evaluating the ~
                                               portcullis commands for the ~
                                               book ~x0:~|~*3."
                                              (list (cons #\3 msgs)))
                                             warning-summary ctx state)))))))
                (t (value (make cert-obj
                                :cmds portcullis-cmds
                                :cert-data cert-data
                                :pre-alist pre-alist
                                :post-alist post-alist3
                                :expansion-alist expansion-alist
                                :pcert-info pcert-info))))))))))))))

(defun chk-certificate-file1 (file1 file2 ch-or-cert-obj light-chkp
                                    caller ctx state suspect-book-action-alist
                                    evalp)

; File1 is a book name and file2 is its associated certificate file name.
; Ch-or-cert-obj is a channel to file2 or a cert-obj record based on that file.
; We assume we have read the initial (in-package "ACL2") and temporarily
; slipped into that package.  Our caller will restore it.  We now read the rest
; of file2 if ch-or-cert-obj is a channel and otherwise consult ch-or-cert-obj,
; and either open the portcullis (skipping evaluation if evalp is nil) and
; return a cert-obj record or nil if we are assuming the book, or we cause an
; error.

; Input suspect-book-action-alist is irrelevant if caller is 'include-book-raw.

; If ch-or-cert-obj is a cert-obj record, then we assume that certain checks
; were made previously when constructing that cert-obj from file2, so we do not
; make them here.  We also assume in that case that state global
; 'fast-cert-status has already been updated if necessary.

; When those checks are to be made then the tedious code below makes them, and
; we here document that code.  The first thing we look for is the ACL2 Version
; number printed immediately after the in-package.  This function is made more
; complicated by four facts.  We do not know for sure that the certificate file
; is well-formed in any version.  Also, we do not know whether include-book-er
; causes an error or just prints a warning (because that is determined by
; suspect-book-action-alist and the values of the state globals
; defaxioms-okp-cert and skip-proofs-okp-cert).  Suppose we read a purported
; version string, val, that does not match the current acl2-version.  Then we
; cause an include-book-er which may or may not signal an error.  If it does
; not then we are to assume the uncertified book so we must proceed with the
; certificate check as though the version were ok.  Basically this means we
; want to call chk-raise-portcullis, but we must first make sure we've read to
; the beginning of the portcullis.  If val looks like an ACL2 Version string,
; then this file is probably a well-formed Version 1.9+ file and we must read
; the :BEGIN-PORTCULLIS-CMDS before proceeding.  Otherwise, this isn't
; well-formed and we cause an error.

; See the Essay on Fast-cert for discussion related to code below that involves
; hackp or fast-cert-status.

  (cond
   ((consp ch-or-cert-obj) ; cert-obj
    (chk-raise-portcullis file1 file2 ch-or-cert-obj light-chkp
                          caller ctx state
                          suspect-book-action-alist evalp))
   (t
    (mv-let
      (eofp version0 state)
      (read-object ch-or-cert-obj state)
      (cond
       ((and eofp (symbolp ch-or-cert-obj))
        (if (eq caller 'include-book-raw)
            (include-book-raw-error
             "Reached end-of-file while reading version."
             state)
          (ill-formed-certificate-er
           ctx 'chk-certificate-file1{empty}
           file1 file2)))
       (t
        (let* ((acl2-version (f-get-global 'acl2-version state))
               (hackp (consp version0))
               (version (if hackp (car version0) version0))
               (fast-cert-status (f-get-global 'fast-cert-status state))
               (version-okp
                (or (equal version0 acl2-version)
                    (and fast-cert-status
                         (equal version acl2-version)))))
          (pprogn
           (cond ((and hackp
                       fast-cert-status
                       (not (fast-cert-included-book fast-cert-status)))

; This is admittedly very early in the include-book process to put a string
; into the fast-cert-status (thus making fast-cert mode enabled for the
; session).  After all, the book may be uncertified, in which case one could
; very reasonably argue that including this uncertified book gives no more
; reason to consider the session to be tainted than including any other
; uncertified book: either way, shouldn't we be able to undo and then certify
; some book later?  But we change fast-cert-status here nonetheless, for two
; reasons.  One reason is our own convenience: we have in hand here, as the
; value of local variable hackp, the information that the certificate is a
; fast-cert certificate (i.e., the book was certified with fast-cert mode
; enabled).  But a second reason is to protect against the possibility (even if
; only a future possibility) that including this book, which was certified with
; fast-cert mode enabled, could pollute the session somehow.

                  (let ((s (sysfile-to-filename file1 state)))
                    (f-put-global 'fast-cert-status
                                  (if (consp fast-cert-status)
                                      (list s)
                                    s)
                                  state)))
                 (t state))
           (cond
            (version-okp
             (mv-let
               (eofp key state)
               (read-object ch-or-cert-obj state)
               (cond
                (eofp
                 (if (eq caller 'include-book-raw)
                     (include-book-raw-error
                      "Reached end-of-file after reading version."
                      state)
                   (ill-formed-certificate-er
                    ctx
                    'chk-certificate-file1{begin-portcullis-cmds-1}
                    file1 file2)))
                ((not (eq key :begin-portcullis-cmds))
                 (if (eq caller 'include-book-raw)
                     (include-book-raw-error
                      "Expected :BEGIN-PORTCULLIS-CMDS."
                      state)
                   (ill-formed-certificate-er
                    ctx
                    'chk-certificate-file1{begin-portcullis-cmds-2}
                    file1 file2 key)))
                (t (chk-raise-portcullis file1 file2 ch-or-cert-obj light-chkp
                                         caller ctx state
                                         suspect-book-action-alist evalp)))))
            ((eq caller 'include-book-raw)
             (include-book-raw-error
              (concatenate 'string
                           "Illegal version string read: "
                           (if (stringp version)
                               version
                             "expected a string or list of a string"))
              state))
            (t
             (let ((msg
                    (cond
                     ((equal version
                             acl2-version) ; so fast-cert mode is disabled
                      (cons
                       "~x0 was certified using fast-cert mode enabled, but ~
                        fast-cert mode is currently disabled.  See :DOC ~
                        fast-cert.  No compiled file will be loaded with this ~
                        book."
                       nil))
                     ((not (equal (acl2-version-r-p acl2-version)
                                  (acl2-version-r-p version)))
                      (cons
                       "We do not permit ACL2 books to be processed by ~
                        ACL2(r) or vice versa.  ~x0 was certified with ~sa ~
                        but this is ~sb.  No compiled file will be loaded ~
                        with this book."
                       (list (cons #\a version)
                             (cons #\b acl2-version))))
                     (t
                      (cons "~x0 was apparently certified with ~sa.  The ~
                             inclusion of this book in the current ACL2 may ~
                             render this ACL2 session unsound!  We recommend ~
                             you recertify the book with the current version, ~
                             ~sb.  See :DOC version.  No compiled file will ~
                             be loaded with this book."
                            (list (cons #\a version)
                                  (cons #\b acl2-version)))))))
               (mv-let
                 (erp val state)
                 (include-book-er
                  file1 file2
                  msg
                  :uncertified-okp
                  suspect-book-action-alist
                  ctx state)

; Because the book was certified under a different version of ACL2, we
; consider it uncertified and, at best, return nil rather than a
; certificate object below.  Of course, we might yet cause an error.

                 (cond
                  (erp (mv erp val state))
                  ((and (stringp version)
                        (<= 13 (length version))
                        (equal (subseq version 0 13) "ACL2 Version "))
                   (mv-let
                     (eofp key state)
                     (read-object ch-or-cert-obj state)
                     (cond
                      (eofp
                       (ill-formed-certificate-er
                        ctx
                        'chk-certificate-file1{begin-portcullis-cmds-3}
                        file1 file2))
                      ((not (eq key :begin-portcullis-cmds))
                       (ill-formed-certificate-er
                        ctx
                        'chk-certificate-file1{begin-portcullis-cmds-4}
                        file1 file2 key))
                      (t (er-progn
                          (chk-raise-portcullis file1 file2 ch-or-cert-obj
                                                light-chkp caller ctx state
                                                suspect-book-action-alist t)
                          (value nil))))))
                  (t (ill-formed-certificate-er
                      ctx
                      'chk-certificate-file1{acl2-version}
                      file1 file2 version)))))))))))))))

(defun certificate-file (full-book-string state)
  (mv-let (ch cert-name state)
          (certificate-file-and-input-channel full-book-string nil nil state)
          (pprogn (cond (ch (close-input-channel ch state))
                        (t state))
                  (mv (and ch cert-name) state))))

(defun defconst-form-to-elide (ev)
  (case-match ev
    (('defconst & ('quote &))
     t)
    (& nil)))

(mutual-recursion

(defun hcomp-elided-defconst-alist2 (index ev alist)

; Warning: Keep this in sync with subst-by-position-eliding-defconst2.

  (case-match ev
    (('defconst name ('quote &))
     (acons index (cons name (caddr ev)) alist))
    (('progn . lst)
     (hcomp-elided-defconst-alist2-lst index lst alist))
    (('encapsulate & . lst)
     (hcomp-elided-defconst-alist2-lst index lst alist))
    (('record-expansion & x)
     (hcomp-elided-defconst-alist2 index x alist))
    (('with-guard-checking-event & x)
     (hcomp-elided-defconst-alist2 index x alist))
    (('skip-proofs x)
     (hcomp-elided-defconst-alist2 index x alist))
    (('with-output . lst)
     (hcomp-elided-defconst-alist2-lst index (car (last lst)) alist))
    (('with-prover-step-limit & & x)
     (hcomp-elided-defconst-alist2-lst index x alist))
    (('with-prover-step-limit & x)
     (hcomp-elided-defconst-alist2-lst index x alist))
    (& alist)))

(defun hcomp-elided-defconst-alist2-lst (index lst alist)
  (cond ((endp lst) alist)
        (t (hcomp-elided-defconst-alist2
            index
            (car lst)
            (hcomp-elided-defconst-alist2-lst index (cdr lst) alist)))))
)

;;; !! Replaces hcomp-elided-defconst-alist-1
(defun hcomp-elided-defconst-alist1 (alist)
  (declare (xargs :guard (alistp alist)))
  (cond ((endp alist) nil)
        (t (let ((index (caar alist))
                 (ev (cdar alist)))
             (hcomp-elided-defconst-alist2
              index
              ev
              (hcomp-elided-defconst-alist1 (cdr alist)))))))

(defun hcomp-elided-defconst-alist (cert-obj)
  (declare (xargs :guard (and (weak-cert-obj-p cert-obj)
                              (alistp (access cert-obj cert-obj
                                              :expansion-alist)))))
  (cond
   ((null cert-obj) nil)
   (t (hcomp-elided-defconst-alist1
       (access cert-obj cert-obj :expansion-alist)))))

(defun convert-cert-file-to-pcert-op (file)

; This function is based on convert-book-string-to-cert, to provide a pcert-op
; of :create-pcert or :convert-pcert when the given certificate filename ends
; in "pcert0" or "pcert1" respectively, else nil.

  (cond ((string-suffixp "pcert0" file)
         :create-pcert)
        ((string-suffixp "pcert1" file)
         :convert-pcert)
        (t nil)))

(defun chk-certificate-file (file1 dir full-book-name caller ctx state
                                   suspect-book-action-alist evalp)

; File1 is a full-book-string.  Dir is either nil or the directory of file1.
; Full-book-name is the full-book-name corresponding to file1 if caller is
; 'include-book; otherwise full-book-name is irrelevant.  An error-triple is
; returned, as described below.

; Caller is 'include-book-raw during the early loading of compiled files; see
; the Essay on Hash Table Support for Compilation, especially the Appendix,
; "Saving space by eliding certain defconst forms".  In that case, failures are
; silent: in case of a problem, there is no warning generated and nil is the
; returned value.  Also, the input suspect-book-action-alist is irrelevant if
; caller is 'include-book-raw.

; We see whether there is a certificate on file for it.  If so, and we can get
; past the portcullis (evaluating it if evalp is true), we return the
; certificate object, a cert-obj record, or nil if we presume the book is
; uncertified.

; This function may actually execute some events or even some DEFPKGs as part
; of the raising of the portcullis in the case that evalp is true.  Depending
; on the caller, we do not enforce the requirement that the books included by
; the portcullis commands have the specified book-hash values, and (for
; efficiency) we do not check the cert-hash for the certificate object
; represented in the certificate file.  This feature is used when we use this
; function to recover from an old certificate the portcullis commands to
; recertify the file.

; We make the convention that if a file has no certificate or has an invalid
; certificate, we will either assume it anyway or cause an error depending on
; suspect-book-action-alist.  In the case that we pronounce this book
; uncertified, we return nil.

  (let ((dir (or dir
                 (directory-of-absolute-pathname file1))))
    (mv-let
      (ch-or-cert-obj file2 state)
      (certificate-file-and-input-channel file1
                                          full-book-name
                                          (if (eq caller 'convert-pcert)
                                              :create-pcert
                                            nil)
                                          state)
      (cond
       ((null ch-or-cert-obj)
        (if (eq caller 'include-book-raw)
            (include-book-raw-error
              "Certificate is unavailable."
              state)
          (include-book-er file1 file2
                           "There is no certificate on file for ~x0.  See ~
                            :DOC uncertified-books."
                           :uncertified-okp
                           suspect-book-action-alist
                           ctx state)))
       (t #-acl2-loop-only
          (when (not (symbolp ch-or-cert-obj))

; We suppressed the bad-lisp-object check earlier, when obtaining the cert-obj
; (namely ch-or-cert-obj) while doing the early load of the compiled file.  See
; the binding below of *bad-lisp-object-ok* in chk-certificate-file.  So we do
; that check now.

            (chk-bad-lisp-object ch-or-cert-obj))
          (er-let* ((pkg (if (symbolp ch-or-cert-obj)
                             (chk-in-package ch-or-cert-obj file2 nil ctx
                                             state)
                           (value "ACL2"))))
            (cond
             ((not (equal pkg "ACL2"))
              (if (eq caller 'include-book-raw)
                  (include-book-raw-error
                   (concatenate
                    'string
                    "Unexpected package name read from certificate: "
                    (if (stringp pkg)
                        pkg
                      "Not a string"))
                   state)
                (ill-formed-certificate-er
                 ctx 'chk-certificate-file{pkg} file1 file2 pkg)))
             (t
              (with-cbd
               dir
               (state-global-let*
                ((current-package "ACL2"))
                (let ((saved-wrld (w state))
                      #-acl2-loop-only
                      (*bad-lisp-object-ok*
                       (cond
                        ((eq caller 'include-book-raw)

; We avoid checks on packages not yet defined in ACL2 when loading compiled
; files early in an include-book.  We will do that check later, in the call of
; chk-bad-lisp-object in chk-certificate-file.  See also the section "Appendix:
; Saving space by eliding certain defconst forms" of the Essay on Hash Table
; Support for Compilation.

                         (assert (symbolp ch-or-cert-obj))
                         t)
                        (t *bad-lisp-object-ok*)))
                      #-acl2-loop-only
                      (*defeat-slow-alist-action*
                       (if (eq caller 'include-book-raw)
                           (or *defeat-slow-alist-action*
                               'stolen)
                         *defeat-slow-alist-action*)))
                  (mv-let (error-flg val state)
                    (chk-certificate-file1
                     file1 file2
                     ch-or-cert-obj
                     (case caller ; light-chkp
                       ((convert-pcert include-book include-book-raw) nil)
                       (puff t)
                       (otherwise
                        (er hard ctx
                            "Implementation error in chk-certificate-file: ~
                             Unexpected case!")))
                     caller ctx state
                     suspect-book-action-alist evalp)
                    (let* ((pcert-op (convert-cert-file-to-pcert-op file2))
                           (val (cond ((and val
                                            pcert-op
                                            (not (access cert-obj val
                                                         :pcert-info)))

; We don't print a :pcert-info field to the .pcert1 file, because it will
; ultimately be moved to a .cert file.  (We could live with such fields in
; .cert files, but we are happy to avoid dealing with them.)  We also don't
; bother printing a :pcert-info field to a .pcert0 file when its value is nil
; (perhaps an arbitrary decision).  We now deal with the above observations.

                                       (change cert-obj val
                                               :pcert-info
                                               (if (eq pcert-op :create-pcert)
                                                   :unproved
                                                 (assert$
                                                  (eq pcert-op :convert-pcert)
                                                  :proved))))
                                      (t val))))
                      (pprogn
                       (if (symbolp ch-or-cert-obj)
                           (close-input-channel ch-or-cert-obj state)
                         state)
                       (cond
                        (error-flg
                         (pprogn

; Chk-certificate-file1 may have evaluated portcullis commands from the
; certificate before determining that there is an error (e.g., due to a
; checksum problem that might have been caused by a package change).  It might
; be confusing to a user to see those portcullis commands survive after a
; report that the book is uncertified, so we restore the world.

                          (set-w! saved-wrld state)
                          (if (eq caller 'include-book-raw)
                              (include-book-raw-error
                               "An error was encountered when checking the ~
                                certificate file."
                               state)
                            (include-book-er file1 file2
                                             "An error was encountered when ~
                                              checking the certificate file ~
                                              for ~x0."
                                             :uncertified-okp
                                             suspect-book-action-alist
                                             ctx state))))
                        (t
                         #-acl2-loop-only
                         (when (eq caller 'include-book-raw)
                           (setq *hcomp-cert-obj* val)
                           (setq *hcomp-elided-defconst-alist*
                                 (hcomp-elided-defconst-alist val))
                           (setq *hcomp-cert-filename* file2))
                         (value val)))))))))))))))))

; All of the above is used during an include-book to verify that a
; certificate is well-formed and to raise the portcullis of the book.
; It happens that the code is also used by certify-book to recover the
; portcullis of a book from an old certificate.  We now continue with
; certify-book's checking, which next moves on to the question of
; whether the environment in which certify-book was called is actually
; suitable for a certification.

(defun equal-modulo-hidden-defpkgs (cmds1 cmds2)

; Keep this in sync with get-cmds-from-portcullis1, make-hidden-defpkg, and the
; #-acl2-loop-only and #+acl2-loop-only definitions of defpkg.

; Test equality of cmds1 and cmds2, except that cmds2 may have hidden defpkg
; events missing from cmds1.

  (cond ((endp cmds2) (endp cmds1))
        ((and cmds1
              (equal (car cmds1) (car cmds2)))
         (equal-modulo-hidden-defpkgs (cdr cmds1) (cdr cmds2)))
        (t (let ((cmd (car cmds2)))
             (case-match cmd
               (('defpkg & & & & 't) ; keep in sync with make-hidden-defpkg
                (equal-modulo-hidden-defpkgs cmds1 (cdr cmds2)))
               (& nil))))))

(defun cert-obj-for-convert (full-book-string dir pre-alist fixed-cmds
                                            suspect-book-action-alist
                                            ctx state)

; Here we check that the pre-alists and portcullis commands correspond, as
; explained in the error messages below.  See also certify-book-finish-convert
; and certify-book-fn, respectively, for analogous checks on the post-alists
; and expansion-alists.

  (er-let* ((cert-obj (chk-certificate-file
                       full-book-string dir

; The following argument could legally be a full-book-name computed from
; full-book-string, which would allow chk-certificate-file to attempt to use a
; cert-obj previously saved in hcomp hash tables.  However, we do not expect
; those hash tables to be populated here, so there is no point in computing
; that full-book-name.

                       nil
                       'convert-pcert ctx state
                       suspect-book-action-alist nil)))
    (cond ((not (equal-modulo-hidden-defpkgs fixed-cmds
                                             (access cert-obj cert-obj :cmds)))
           (er soft ctx
               "The Convert procedure of provisional certification requires ~
                that the current ACL2 world at the start of that procedure ~
                agrees with the current ACL2 world present at the start of ~
                the Pcertify procedure.  However, these worlds appear to ~
                differ!  To see the current commands, use :pbt! 1.  To see ~
                the portcullis commands from the .pcert0 file, evaluate the ~
                following form:~|~Y01~|Now compare the result of that ~
                evaluation, ignoring DEFPKG events whose fifth argument (of ~
                five) is T, with (``fixed'') portcullis commands of the ~
                current ACL2 world:~|~y2"
               `(er-let* ((cert-obj
                           (chk-certificate-file ,full-book-string ,dir
                                                 'convert-pcert ',ctx state
                                                 ',suspect-book-action-alist
                                                 nil)))
                  (value (access cert-obj cert-obj :cmds)))
               nil
               fixed-cmds))
          ((not (equal pre-alist
                       (access cert-obj cert-obj :pre-alist)))
           (er soft ctx
               "The Convert procedure of provisional certification requires ~
                that the include-book-alist at the start of that procedure ~
                (the ``pre-alist'') agrees with the one present at the start ~
                of the Pcertify procedure.  However, these appear to differ!  ~
                The current world's pre-alist is:~|~%  ~y0~|~%The pre-alist ~
                from the Pcertify procedure (from the .pcert0 file) is:~|~%  ~
                ~y1~|~%"
               pre-alist
               (access cert-obj cert-obj :pre-alist)))
          (t (value cert-obj)))))

(defun chk-acceptable-certify-book1 (user-book-name full-book-string
                                                    full-book-name
                                                    dir k cmds
                                                    cbds names cert-op
                                                    suspect-book-action-alist
                                                    wrld ctx state)

; This function is checking the appropriateness of the environment in which
; certify-book is called.

; This subroutine is called after we have the k proposed portcullis commands
; and wrld; cmds and cbds are lists of the same length, returned by
; (get-portcullis-cmds wrld nil nil names ctx state).

; Unless we cause an error, we return a cert-obj constructed from the
; certificate file for the given book, file.

; Note that for the Convert procedure of provisional certification, we keep the
; expansion-alist and cert-data (and pcert-info) from the existing .pcert0
; file.  But in all other cases, we do not keep these.

  (let ((pre-alist-cert-wrld (global-val 'include-book-alist wrld))
        (uncert-books
         (and (not (eq cert-op :write-acl2xu)) ; else uncertified books are OK
              (collect-uncertified-books

; During the Pcertify and Convert procedures of provisional certification, the
; value of 'include-book-alist-all can be based on the inclusion of books that
; have a certificate file with suffix .pcert0 or .pcert1.  This is OK because
; for purposes of those procedures, we really do consider such books to be
; certified.

               (global-val 'include-book-alist-all wrld)))))
    (cond
     ((not (eq (default-defun-mode wrld) :logic))
      (er soft ctx
          "Books must be certified in :LOGIC mode.  The current mode is ~x0."
          (default-defun-mode wrld)))
     ((and (not (integerp k))
           (not (symbol-name-equal k "?")))
      (er soft ctx
          "The second argument to certify-book must be a natural number or ~
           the symbol ? (in any package).  You supplied ~x0.  See :DOC ~
           certify-book."
          k))
     ((and (not (symbol-name-equal k "?"))
           (not (eql k (length cmds))))
      (er soft ctx
          "Your certify-book command specifies a certification world of ~
           length ~x0 but it is actually of length ~x1.  Perhaps you intended ~
           to issue a command of the form: (certify-book ~x2 ~x1 ...).  See ~
           :DOC certify-book."
          k (length cmds) user-book-name))
     ((assoc-equal full-book-name pre-alist-cert-wrld)

; Why do we do this?  By ensuring that file is not in the include-book-alist
; initially, we ensure that it gets into the alist only at the end when we
; include-book the book.  This lets us cdr it off.  If it happened to be the
; alist initially, then the include-book would not add it and the cdr wouldn't
; remove it.  See the end of the code for certify-book.

      (er soft ctx
          "We cannot certify ~x0 in a world in which it has already been ~
           included."
          full-book-string))
     (uncert-books
      (let ((uncert-book-filenames
             (book-name-lst-to-filename-lst uncert-books
                                            (project-dir-alist wrld)
                                            ctx)))
        (er soft ctx
            "It is impossible to certify any book in the current world ~
             because it is built upon ~*0 which ~#1~[is~/are~] uncertified."
            (tilde-*-&v-strings '& uncert-book-filenames #\,)
            uncert-book-filenames)))
     (t
      (er-let* ((fixed-cmds
                 (cond ((null cbds) (value cmds))
                       (t

; Now that we know we have a list of embedded event forms, we are ready to
; replace relative pathnames by absolute pathnames.  See fix-portcullis-cmds.
; At one time we considered not fixing the portcullis commands when the cert-op
; is :write-acl2x or :write-acl2xu.  But we keep it simple here and fix
; unconditionally.

                        (fix-portcullis-cmds dir cmds cbds names
                                             wrld ctx state)))))
        (cond
         ((eq cert-op :convert-pcert)
          (cert-obj-for-convert full-book-string dir pre-alist-cert-wrld
                                fixed-cmds suspect-book-action-alist ctx
                                state))
         (t
          (value
           (make cert-obj
                 :cmds fixed-cmds
                 :pre-alist nil       ; not-needed
                 :post-alist nil      ; not needed
                 :expansion-alist nil ; explained above
                 :cert-data nil       ; explained above
                 )))))))))

(defun translate-book-names (book-names cbd ctx msg project-dir-alist state
                                        acc)

; Book-names is a list consisting of book-names (each of which might or might
; not have a ".lisp" suffix) and possibly nil.  We return a list that leaves
; nil unchanged but otherwise replaces each book-name with a corresponding
; full-book-name that has a ".lisp" suffix, where a relative pathname is
; interpreted with respect to the input cbd.  Msg a message used in error
; reporting (as is obvious in the code below).

  (declare (xargs :guard (true-listp book-names))) ; one member can be nil
  (cond ((endp book-names)
         (value (reverse acc)))
        ((null (car book-names)) ; possible for book-name associated with ttag
         (translate-book-names (cdr book-names) cbd ctx msg
                               project-dir-alist state (cons nil acc)))
        ((not (book-name-p (car book-names)))
         (er soft ctx
             "The name ~x0~@1 is not a valid book-name.  See :DOC book-name."
             (car book-names) msg))
        (t (translate-book-names
            (cdr book-names) cbd ctx msg project-dir-alist state
            (cons (filename-to-book-name-1
                   (extend-pathname cbd
                                    (possibly-add-lisp-extension
                                     (book-name-to-filename-1 (car book-names)
                                                              project-dir-alist
                                                              ctx))
                                    state)
                   project-dir-alist)
                  acc)))))

(defun fix-ttags (ttags cbd ctx project-dir-alist state seen acc)

; Seen is a list of symbols, nil at the top level.  We use this argument to
; enforce the lack of duplicate ttags.  Acc is the accumulated list of ttags to
; return, which may include symbols and lists (sym file1 ... filek).

  (declare (xargs :guard (true-listp ttags)))
  (cond ((endp ttags)
         (value (reverse acc)))
        (t (let* ((ttag (car ttags))
                  (sym0 (if (consp ttag) (car ttag) ttag))
                  (sym (and (symbolp sym0)
                            sym0
                            (intern (symbol-name sym0) "KEYWORD"))))
             (cond
              ((not (and sym ; hence sym is a keyword
                         (or (atom ttag)
                             (book-name-listp (remove1-eq nil (cdr ttag))))))
               (er soft ctx
                   "A :ttags value for certify-book or include-book must ~
                    either be the keyword :ALL or else a list, each of whose ~
                    members is one of the following: a non-nil symbol, or the ~
                    CONS of a non-nil symbol onto a true list consisting of ~
                    strings and at most one nil.  The value ~x0 is thus an ~
                    illegal member of such a list."
                   ttag))
              ((member-eq sym seen)
               (er soft ctx
                   "A :ttags list may not reference the same ttag more than ~
                    once, but the proposed list references ~x0 more than once."
                   sym))
              ((symbolp ttag)
               (fix-ttags (cdr ttags) cbd ctx project-dir-alist state
                          (cons sym seen)
                          (cons sym acc)))
              (t
               (er-let* ((full-book-names
                          (translate-book-names (cdr ttag) cbd ctx
                                                (msg ", which has been ~
                                                      associated with ttag ~
                                                      ~x0, "
                                                     (car ttag))
                                                project-dir-alist
                                                state nil)))
                        (fix-ttags (cdr ttags) cbd ctx project-dir-alist state
                                   (cons sym seen)
                                   (cons (cons sym full-book-names)
                                         acc)))))))))


(defun chk-well-formed-ttags (ttags cbd ctx state)
  (cond ((null ttags)
         (value nil))
        ((and (symbolp ttags)
              (equal (symbol-name ttags) "ALL"))
         (value :all))
        ((not (true-listp ttags))
         (er soft ctx
             "A valid :ttags value must either be :all or a true list,  The ~
              following value is thus illegal: ~x0."
             ttags))
        (t (let ((wrld (w state)))
             (fix-ttags ttags cbd ctx
                        (project-dir-alist wrld)
                        state nil nil)))))

(defun check-certificate-file-exists (full-book-string cert-op ctx state)

; A certificate file is required: either the .pcert0 file, in case cert-op
; specifies the Convert procedure of provisional certification, or else because
; a certify-book command has specified recovery of the certification world from
; an existing certificate (argument k = t).  We cause an error when the
; certificate file is missing.

  (mv-let (ch cert-name state)
          (certificate-file-and-input-channel1 full-book-string
                                               (cond ((eq cert-op
                                                          :convert-pcert)
                                                      :create-pcert)
                                                     (t t))
                                               state)
          (cond
           (ch (pprogn (close-input-channel ch state)
                       (value nil)))
           ((eq cert-op :convert-pcert)
            (er soft ctx
                "The file ~x0 cannot be opened for input; perhaps it is ~
                 missing.  But that file is required for the Convert ~
                 procedure of provisional certification of the book ~x1."
                cert-name full-book-string))
           (t ; argument k is t for certify-book
            (er soft ctx
                "There is no certificate (.cert) file for ~x0.  But you told ~
                 certify-book to recover the certi~-fication world from the ~
                 old certificate.  You will have to construct the ~
                 certi~-fication world by hand (by executing the desired ~
                 commands in the current logical world) and then call ~
                 certify-book again."
                full-book-string)))))

(defun illegal-to-certify-check (before-p ctx state)

; See the Essay on Illegal-states.

  (cond ((f-get-global 'illegal-to-certify-message state)
         (er soft ctx
             "It is illegal to certify a book in this session, as explained ~
              by the message on a possible invariance violation, printed ~
              earlier ~@0.  To see the message again, evaluate ~
              the following form:~|~x1"
             (if before-p
                 "in this session"
               "during the certification attempt")
             '(fmx "~@0~%~%" (@ illegal-to-certify-message))))
        (t (value nil))))

(defun chk-acceptable-certify-book (book-name full-book-string full-book-name
                                              dir suspect-book-action-alist
                                              cert-op k ctx state)

; This function determines that it is ok to run certify-book on
; full-book-name/full-book-string, cert-op, and k.  Unless an error is caused
; we return a cert-obj that contains, at least, the two parts of the
; portcullis, where the commands are adjusted to include make-event expansions
; of commands in the certification world.  If cert-op is :convert-pcert then we
; check that the portcullis commands from the certification world agree with
; those in the .pcert0 file, and we fill in fields of the cert-obj based on the
; contents of the .pcert0 file.

; Dir is either nil or the directory of full-book-string.

  (let ((names (cons 'defpkg (primitive-event-macros)))
        (wrld (w state))
        (dir (or dir
                 (directory-of-absolute-pathname full-book-string))))
    (er-progn
     (cond ((and (ld-skip-proofsp state)
                 (not (eq cert-op ':write-acl2xu)))
            (er soft ctx
                "Certify-book must be called with ld-skip-proofsp set to nil ~
                 (except when writing .acl2x files in the case that ~
                 set-write-acl2x has specified skipping proofs)."))
           ((f-get-global 'in-local-flg state)
            (er soft ctx
                "Certify-book may not be called inside a LOCAL command."))
           ((and (global-val 'skip-proofs-seen wrld)
                 (not (cdr (assoc-eq :skip-proofs-okp
                                     suspect-book-action-alist))))
            (er soft ctx
                "At least one event in the current ACL2 world was executed ~
                 with proofs skipped, either with a call of skip-proofs or by ~
                 setting ``LD special'' variable '~x0 to a non-nil value.  ~
                 ~@1(If you did not explicitly use ~
                 skip-proofs or set-ld-skip-proofsp, or call ld with ~
                 :ld-skip-proofsp not nil, then some other function did so, ~
                 for example, rebuild or :puff.)  Certification is therefore ~
                 not allowed in this world unless you supply certify-book ~
                 with :skip-proofs-okp t.  See :DOC certify-book."
                'ld-skip-proofsp
                (let ((x (global-val 'skip-proofs-seen wrld)))
                  (if (and (consp x) ; always true?
                           (eq (car x) :include-book))
                      (msg "Such an event was introduced via the ~
                            included book, ~x0.  "
                           (book-name-to-filename (cadr x) wrld ctx))
                    (msg "Such an event was:~|~%  ~y0~%"
                         x)))))
           ((global-val 'redef-seen wrld)
            (er soft ctx
                "At least one command in the current ACL2 world was executed ~
                 while the value of state global variable '~x0 was not ~
                 nil:~|~%  ~y1~%Certification is therefore not allowed in ~
                 this world.  You can use :ubt to undo back through this ~
                 command; see :DOC ubt."
                'ld-redefinition-action
                (global-val 'redef-seen wrld)))
           ((and (not (pcert-op-p cert-op))
                 (global-val 'pcert-books wrld))
            (let ((books (global-val 'pcert-books wrld)))
              (er soft ctx
                  "Certify-book has been invoked in an ACL2 world that ~
                   includes the book~#0~[ below, which is~/s below, each of ~
                   which is~] only provisionally certified: there is a ~
                   certificate file with extension .pcert0 or .pcert1, but ~
                   not with extension .cert.~|~%~@1~|~%A certify-book command ~
                   is thus illegal in this world unless a :pcert keyword ~
                   argument is specified to be :create or :convert."

; This error message may be printed with sysfiles.  It is of a sufficiently low
; level that this seems reasonable: good information is more important than a
; pleasant shape.

                books
                (print-indented-list-msg books 2 ""))))
           ((ttag wrld)

; We disallow an active ttag at certification time because we don't want to
; think about certain oddly redundant defttag events.  Consider for example
; executing (defttag foo), and then certifying a book containing the following
; forms, (certify-book "foo" 1 nil :ttags ((foo nil))), indicating that ttag
; foo is only active at the top level, not inside a book.

; (defttag foo)

; (defun f ()
;   (declare (xargs :mode :program))
;   (sys-call "ls" nil))

; The defttag expands to a redundant table event, hence would be allowed.
; Perhaps this is OK, but it is rather scary since we then have a case of a
; book containing a defttag of which there is no evidence of this in any "TTAG
; NOTE" string or in the book's certificate.  While we see no real problem
; here, since the defttag really is ignored, still it's very easy for the user
; to work around this situation by executing (defttag nil) before
; certification; so we take this conservative approach.

            (er soft ctx
                "It is illegal to certify a book while there is an active ~
                 ttag, in this case, ~x0.  Consider undoing the corresponding ~
                 defttag event (see :DOC ubt) or else executing ~x1.  See ~
                 :DOC defttag."
                (ttag wrld)
                '(defttag nil)))
           (t (value nil)))
     (illegal-to-certify-check t ctx state)
     (cond ((eq cert-op :convert-pcert)
; Cause early error now if certificate file is missing.
            (check-certificate-file-exists full-book-string cert-op ctx state))
           (t (value nil)))
     (mv-let
      (erp cmds cbds state)
      (get-portcullis-cmds wrld nil nil names ctx state)
      (cond
       (erp (silent-error state))
       (t (chk-acceptable-certify-book1 book-name
                                        full-book-string full-book-name
                                        dir k cmds
                                        cbds names cert-op
                                        suspect-book-action-alist wrld ctx
                                        state)))))))

(defun print-objects (lst ch state)
  (cond ((null lst) state)
        (t (pprogn (print-object$ (car lst) ch state)
                   (print-objects (cdr lst) ch state)))))

(defun replace-initial-substring (s old old-length new)

; Old is a string with length old-length.  If s is a string with old as an
; initial subsequence, then replace the initial subsequence of s by new.
; Otherwise, return s.

  (cond ((and (stringp s)
              (> (length s) old-length)
              (equal old (subseq s 0 old-length)))
         (concatenate 'string new (subseq s old-length
                                          (length s))))
        (t s)))

(defun replace-string-prefix-in-tree (tree old old-length new)

; Search through the given tree, and for any string with prefix old (which has
; length old-length), replace that prefix with new.  This could be coded much
; more efficiently, by avoiding re-consing unchanged structures.

  (cond ((atom tree)
         (replace-initial-substring tree old old-length new))
        (t (cons (replace-string-prefix-in-tree (car tree) old old-length new)
                 (replace-string-prefix-in-tree (cdr tree) old old-length
                                                new)))))

(defmacro with-output-object-channel-sharing (chan filename body
                                                   &optional chan0)

; Attempt to open an output channel in a way that allows structure sharing, as
; per print-circle.  Except, if chan0 is non-nil, then it is a channel already
; opened with this macro, and we use chan0 instead.

; Warning: The code in body is responsible for handling failure to open an
; output channel and, if it does open a channel, for closing it.

  (declare (xargs :guard ; avoid eval twice in macro expansion
                  (and (symbolp chan) (symbolp chan0))))
  #+acl2-loop-only
  `(mv-let
    (,chan state)
    (if ,chan0
        (mv ,chan0 state)
      (open-output-channel ,filename :object state))
    ,body)
  #-acl2-loop-only
  `(if (and (null ,chan0) *print-circle-stream*)
       (error "A stream is already open for printing with structure sharing, ~
               so we cannot~%open such a stream for file ~s."
              ,filename)
     (mv-let
      (,chan state)
      (if ,chan0
          (mv ,chan0 state)
        (open-output-channel ,filename :object state))
      (let ((*print-circle-stream*
             (if ,chan0
                 *print-circle-stream*
               (and ,chan (get-output-stream-from-channel ,chan)))))
        ,body))))

(defun elide-locals-and-split-expansion-alist (alist acl2x-alist x y)

; This function supports provisional certification.  It takes alist, an
; expansion-alist that was produced during the Pcertify (not Pcertify+)
; procedure without eliding locals.  It extends x and y (initially both nil)
; and reverses each, to return (mv x y), where x is the result of eliding
; locals from alist, and y is the result of accumulating original entries from
; alist that were changed before going into x, but only those that do not
; already equal corresponding entries in acl2x-alist (another expansion-alist).
; We will eventually write the elided expansion-alist (again, obtained by
; accumulating into x) into the :EXPANSION-ALIST field of the .pcert0 file, and
; the non-elided part (again, obtained by accumulating into y) will become the
; value of the :PCERT-INFO field of the .pcert0 file.  The latter will be
; important for providing a suitable expansion-alist for the Convert procedure
; of provisional certification, where local events are needed in order to
; support proofs.

  (cond ((endp alist)
         (mv (reverse x) (reverse y)))
        (t (assert$ ; the domain of acl2x-alist is extended by alist
            (or (null acl2x-alist)
                (<= (caar alist) (caar acl2x-alist)))
            (let ((acl2x-alist-new
                   (cond ((and acl2x-alist
                               (eql (caar alist) (caar acl2x-alist)))
                          (cdr acl2x-alist))
                         (t acl2x-alist))))
              (mv-let (changedp form)
                      (elide-locals-rec (cdar alist))
                      (cond
                       (changedp (elide-locals-and-split-expansion-alist
                                  (cdr alist)
                                  acl2x-alist-new
                                  (acons (caar alist) form x)
                                  (cond ((and acl2x-alist ; optimization
                                              (equal (car alist)
                                                     (car acl2x-alist)))
                                         y)
                                        (t (cons (car alist) y)))))
                       (t (elide-locals-and-split-expansion-alist
                           (cdr alist)
                           acl2x-alist-new
                           (cons (car alist) x)
                           y)))))))))

(defun make-certificate-file1 (file portcullis certification-file
                                    post-alist3
                                    expansion-alist cert-data pcert-info
                                    cert-op ctx state)

; See make-certificate-file.

; Warning: For soundness, we need to avoid using iprinting when writing to
; certificate files.  We do all such writing with print-object$, which does not
; use iprinting.

; Warning: The use of with-output-object-channel-sharing and
; with-print-defaults below should be kept in sync with analogous usage in
; copy-pcert0-to-pcert1.

  (assert$
   (not (member-eq cert-op ; else we exit certify-book-fn before this point
                   '(:write-acl2x :write-acl2xu)))
   (assert$
    (implies (eq cert-op :convert-pcert)
             (eq (cert-op state) :create+convert-pcert))
    (with-output-object-channel-sharing
     ch certification-file
     (cond
      ((null ch)
       (er soft ctx
           "We cannot open a certificate file for ~x0.  The file we tried to ~
            open for output was ~x1."
           file
           certification-file))
      (t (with-print-defaults
          ((current-package "ACL2")
           (print-circle (f-get-global 'print-circle-files state))
           (print-readably t))
          (pprogn
           (print-object$ '(in-package "ACL2") ch state)
           (print-object$

; If fast-cert is in ACCEPT mode and no fast-cert book has yet been included,
; then there is no need to mark this book as a fast-cert book.  Here we break
; the abstraction of fast-cert-mode to avoid evaluating the form (f-get-global
; 'fast-cert-status state) twice.

            (if (let ((status (f-get-global 'fast-cert-status state)))
                  (and status
                       (or (atom status) ; fast-cert mode is active
                           (fast-cert-included-book status))))
                (list (f-get-global 'acl2-version state))
              (f-get-global 'acl2-version state))
                          ch state)
           (print-object$ :BEGIN-PORTCULLIS-CMDS ch state)
           (print-objects

; We could apply hons-copy to (car portcullis) here, but we don't.  See the
; Remark on Fast-alists in install-for-add-trip-include-book.

            (car portcullis) ch state)
           (print-object$ :END-PORTCULLIS-CMDS ch state)
           (cond (expansion-alist
                  (pprogn (print-object$ :EXPANSION-ALIST ch state)
                          (print-object$

; We could apply hons-copy to expansion-alist here, but we don't.  See the
; Remark on Fast-alists in install-for-add-trip-include-book.

                           expansion-alist ch state)))
                 (t state))
           (cond (cert-data
                  (pprogn (print-object$ :cert-data ch state)
                          (print-object$ cert-data ch state)))
                 (t state))
           (print-object$ (cdr portcullis) ch state)
           (print-object$ post-alist3 ch state)
           (print-object$
            (cert-hash nil
                       (car portcullis)             ; :cmds
                       (cdr portcullis)             ; :pre-alist
                       post-alist3                  ; :post-alist
                       expansion-alist              ; :expansion-alist
                       cert-data
                       state)
            ch state)
           (cond (pcert-info
                  (pprogn (print-object$ :PCERT-INFO ch state)
                          (print-object$

; We could apply hons-copy to pcert-info (as it may be an expansion-alist
; without local elision), but we don't.  See the Remark on Fast-alists in
; install-for-add-trip-include-book.

                           pcert-info ch state)))
                 (t state))
           (close-output-channel ch state)
           (value certification-file)))))))))

(defun make-certificate-file (file portcullis post-alist1 post-alist2
                                   expansion-alist cert-data pcert-info
                                   cert-op ctx state)

; This function writes out, and returns, a certificate file.  We first give
; that file a temporary name, based originally on the expectation that
; afterwards, compilation is performed and then the certificate file is renamed
; to its suitable .cert name.  This way, we expect that that the compiled file
; will have a write date that is later than (or at least, not earlier than) the
; write date of the certificate file; yet, we can be assured that "make"
; targets that depend on the certificate file's existence will be able to rely
; implicitly on the compiled file's existence as well.  After Version_4.3 we
; arranged that even when not compiling we use a temporary file, so that (we
; hope) once the .cert file exists, it has all of its contents.

; We assume file is a full-book-string.  The portcullis is a pair (cmds
; . pre-alist), as follows.  Cmds is the list of portcullis commands that
; created the world in which the certification was done.  Pre-alist is the
; include-book-alist in the "portcullis world" that is the certification world
; except that local commands, if any, are skipped there.  Post-alist1 is the
; include-book-alist after proving the events in file and post-alist2 is the
; include-book-alist after just including the events in file.  If they are
; different it is because the book included some subbooks within LOCAL forms
; and those subbooks did not get loaded for post-alist2.

; To verify that a subsequent inclusion is ok, we really only need post-alist2.
; That is, if the book included some LOCAL subbook then it is not necessary
; that that subbook even exist when we include the main book.  On the other
; hand, we trace calls of skip-proofs using the call of
; skipped-proofsp-in-post-alist in include-book-fn, which requires
; consideration of LOCALly included books; and besides, it might be useful to
; know what version of the subbook we used during certification, although the
; code at the moment makes no use of that.  So we massage post-alist1 so that
; any subbook in it that is not in post-alist2 is marked LOCAL.  Thus,
; post-alist3, below, will be of the form

; ((full1 user1 familiar1 cert-annotations1 . book-hash1)
;  ...
;  (LOCAL (fulli useri familiari cert-annotationsi . book-hashi))
;  ...
;  (fullk userk familiark cert-annotationsk . book-hashk))

; and thus is not really an include-book-alist.  By deleting the LOCAL
; elements from it we obtain post-alist2.

; We write a certificate file for file.  The certificate file has the
; following form:

; (in-package "ACL2")
; "ACL2 Version x.y"
; :BEGIN-PORTCULLIS-CMDS  ; this is here just to let us check that the file
; cmd1                    ; is not a normal list of events.
; ...
; cmdk
; :END-PORTCULLIS-CMDS
; pre-alist
; post-alist3
; cert-hash

; where cert-hash may be the checksum of ((cmds . pre-alist) . post-alist3) --
; see function cert-hash.

; The reason the portcullis commands are written this way, rather than
; as a single object, is that we can't read them all at once since
; they may contain DEFPKGs.  We have to read and eval the cmdi
; individually.

  (let* ((certification-file (convert-book-string-to-cert file cert-op))
         (post-alist3 (mark-local-included-books post-alist1 post-alist2)))
    (er-progn
     (cond ((include-book-alistp post-alist3 t)
            (value nil))
           (t (er soft ctx
                  "Ill-formed post-alist encountered in file ~x0:~|~x1"
                  certification-file post-alist3)))
     (make-certificate-file1 file portcullis
                             (concatenate 'string certification-file ".temp")
                             post-alist3 expansion-alist cert-data
                             pcert-info cert-op ctx state))))

(defun make-certificate-files (full-book-string portcullis post-alist1
                                                post-alist2 expansion-alist
                                                cert-data pcert-info cert-op ctx
                                                state)

; This function returns a renaming alist with entries (temp-file
; . desired-file).

  (cond
   ((eq cert-op :create+convert-pcert)
    (er-let* ((pcert0-file
               (make-certificate-file full-book-string portcullis
                                      post-alist1 post-alist2
                                      expansion-alist cert-data pcert-info
                                      :create-pcert ctx state))
              (pcert1-file
               (make-certificate-file full-book-string portcullis
                                      post-alist1 post-alist2
                                      expansion-alist cert-data
                                      nil ; pcert-info for .pcert1 file
                                      :convert-pcert ctx state)))
      (value (list (cons pcert0-file
                         (convert-book-string-to-cert
                          full-book-string
                          :create-pcert))
                   (cons pcert1-file
                         (convert-book-string-to-cert
                          full-book-string
                          :convert-pcert))))))
   (t (er-let* ((cert-file
                 (make-certificate-file full-book-string portcullis
                                        post-alist1 post-alist2
                                        expansion-alist cert-data pcert-info
                                        cert-op ctx state)))
        (value (list (cons cert-file
                           (convert-book-string-to-cert
                            full-book-string
                            cert-op))))))))

; We now develop a general-purpose read-object-file, which expects
; the given file to start with an IN-PACKAGE and then reads into that
; package all of the remaining forms of the file, returning the list
; of all forms read.

(defun open-input-object-file (file ctx state)

; If this function returns without error, then a channel is returned.
; In our use of this function in INCLUDE-BOOK we know file is a string.
; Indeed, it is a book name.  But we write this function slightly more
; ruggedly so that read-object-file, below, can be used on an
; arbitrary alleged file name.

  (cond ((stringp file)
         (mv-let (ch state)
                 (open-input-channel file :object state)
                 (cond ((null ch)
                        (er soft ctx
                            "There is no file named ~x0 that can be ~
                             opened for input."
                            file))
                       (t (value ch)))))
        (t (er soft ctx
               "File names in ACL2 must be strings, so ~x0 is not a ~
                legal file name."
               file))))

(defun read-object-file1 (channel state ans)

; Channel is an open input object channel.  We have verified that the
; first form in the file is an in-package and we are now in that
; package.  We read all the remaining objects in the file and return
; the list of them.

  (mv-let (eofp val state)
          (read-object channel state)
          (cond (eofp (value (reverse ans)))
                (t (read-object-file1 channel state (cons val ans))))))

(defun read-object-file (file ctx state)

; We open file for object input (causing an error if file is
; inappropriate).  We then get into the package specified by the
; (in-package ...) at the top of file, read all the objects in file,
; return to the old current package, close the file and exit,
; returning the list of all forms read (including the IN-PACKAGE).

  (er-let* ((ch (open-input-object-file file ctx state))
            (new-current-package (chk-in-package ch file nil ctx state)))
           (state-global-let*
            ((current-package new-current-package))
            (er-let* ((lst (read-object-file1 ch state nil)))
                     (let ((state (close-input-channel ch state)))
                       (value (cons (list 'in-package new-current-package)
                                    lst)))))))

(defun chk-cert-annotations
  (cert-annotations portcullis-skipped-proofsp portcullis-cmds full-book-string
                    suspect-book-action-alist
                    ctx state)

; Warning: Chk-cert-annotations and chk-cert-annotations-post-alist are nearly
; duplicates of one another.  If you change one, e.g., to add a new kind of
; annotation and its checker, change the other.

  (er-progn
   (cond
    (portcullis-skipped-proofsp

; After Version_3.4, we don't expect this case to be evaluated, because we
; already checked the certification world for skipped proofs in
; chk-acceptable-certify-book.  For now, we leave this inexpensive check for
; robustness.  If we find a reason that it's actually necessary, we should add
; a comment here explaining that reason.

     (include-book-er
      full-book-string nil
      (cons "The certification world for book ~x0 contains one or more ~
             SKIP-PROOFS events~@3."
            (list (cons #\3
                        (if (and (consp portcullis-skipped-proofsp)
                                 (eq (car portcullis-skipped-proofsp)
                                     :include-book))
                            (msg " under (subsidiary) book \"~@0\""
                                 (cadr portcullis-skipped-proofsp))
                          ""))))
      :skip-proofs-okp
      suspect-book-action-alist ctx state))
    ((eq (cdr (assoc-eq :skipped-proofsp cert-annotations)) nil)
     (value nil))
    ((eq (cdr (assoc-eq :skipped-proofsp cert-annotations)) t)
     (include-book-er full-book-string nil
                      (if portcullis-cmds
                          "The book ~x0 (including events from its portcullis) ~
                           contains one or more SKIP-PROOFS events."
                        "The book ~x0 contains one or more SKIP-PROOFS events.")
                      :skip-proofs-okp
                      suspect-book-action-alist ctx state))
    (t (include-book-er full-book-string nil
                        (if portcullis-cmds
                            "The book ~x0 (including events from its ~
                             portcullis) may contain SKIP-PROOFS events."
                          "The book ~x0 may contain SKIP-PROOFS events.")
                        :skip-proofs-okp
                        suspect-book-action-alist ctx state)))
   (cond
    ((eq (cdr (assoc :axiomsp cert-annotations)) nil)
     (value nil))
    ((eq (cdr (assoc :axiomsp cert-annotations)) t)
     (include-book-er full-book-string nil
                      (if portcullis-cmds
                          "The book ~x0 (including events from its portcullis) ~
                           contains one or more DEFAXIOM events."
                        "The book ~x0 contains one or more DEFAXIOM events.")
                      :defaxioms-okp
                      suspect-book-action-alist ctx state))
    (t (include-book-er full-book-string nil
                        (if portcullis-cmds
                            "The book ~x0 (including events from its ~
                             portcullis) may contain DEFAXIOM events."
                          "The book ~x0 may contain DEFAXIOM events.")
                        :defaxioms-okp
                        suspect-book-action-alist ctx state)))))

(defun chk-cert-annotations-post-alist
  (post-alist portcullis-cmds full-book-string suspect-book-action-alist ctx
              state)

; Warning: Chk-cert-annotations and chk-cert-annotations-post-alist are nearly
; duplicates of one another.  If you change one, e.g., to add a new kind of
; annotation and its checker, change the other.

; We are in the process of including the book with filename full-book-string.
; Post-alist is its locally-marked include-book alist as found in the .cert
; file.  We look at every entry (LOCAL or not) and check that its cert
; annotations are consistent with the suspect-book-action-list.

  (cond
   ((endp post-alist) (value nil))
   (t

; An entry in the post-alist is (full user familiar cert-annotations . chk).
; It may optionally be embedded in a (LOCAL &) form.

      (let* ((localp (eq (car (car post-alist)) 'local))
             (full-subbook (if localp
                               (car (cadr (car post-alist)))
                             (car (car post-alist))))
             (cert-annotations (if localp
                                   (cadddr (cadr (car post-alist)))
                                 (cadddr (car post-alist)))))
        (er-progn
         (cond
          ((eq (cdr (assoc-eq :skipped-proofsp cert-annotations)) nil)
           (value nil))
          ((eq (cdr (assoc-eq :skipped-proofsp cert-annotations)) t)
           (include-book-er
            full-book-string nil
            (cons "The book ~x0~sp~#a~[~/ locally~] includes ~xb, which ~
                   contains one or more SKIP-PROOFS events."
                  (list (cons #\a (if localp 1 0))
                        (cons #\b full-subbook)
                        (cons #\p (if portcullis-cmds
                                      " (including events from its portcullis)"
                                    ""))))
            :skip-proofs-okp
            suspect-book-action-alist ctx state))
          (t (include-book-er
              full-book-string nil
              (cons "The book ~x0~sp~#a~[~/ locally~] includes ~xb, which ~
                     may contain SKIP-PROOFS events."
                    (list (cons #\a (if localp 1 0))
                          (cons #\b full-subbook)
                          (cons #\p (if portcullis-cmds
                                        " (including events from its portcullis)"
                                      ""))))
              :skip-proofs-okp
              suspect-book-action-alist ctx state)))
         (cond
          ((eq (cdr (assoc :axiomsp cert-annotations)) nil)
           (value nil))
          ((eq (cdr (assoc :axiomsp cert-annotations)) t)
           (include-book-er
            full-book-string nil
            (cons "The book ~x0~sp~#a~[~/ locally~] includes ~xb, which ~
                   contains one or more DEFAXIOM events."
                  (list (cons #\a (if localp 1 0))
                        (cons #\b full-subbook)
                        (cons #\p (if portcullis-cmds
                                      " (including events from its portcullis)"
                                    ""))))
            :defaxioms-okp
            suspect-book-action-alist ctx state))
          (t (include-book-er
              full-book-string nil
              (cons "The book ~x0~sp~#a~[~/ locally~] includes ~xb, which ~
                     may contain DEFAXIOM events."
                    (list (cons #\a (if localp 1 0))
                          (cons #\b full-subbook)
                          (cons #\p (if portcullis-cmds
                                        " (including events from its ~
                                         portcullis)"
                                      ""))))
              :defaxioms-okp
              suspect-book-action-alist ctx state)))
         (chk-cert-annotations-post-alist (cdr post-alist)
                                          portcullis-cmds
                                          full-book-string
                                          suspect-book-action-alist
                                          ctx state))))))

(defun chk-input-object-file (file ctx state)

; This checks that an object file named file can be opened for input.  It
; either causes an error or returns t.  It can change the state -- because it
; may open and close a channel to the file -- and it may well be that the file
; does not exist in the state returned!  C'est la guerre.  The purpose of this
; function is courtesy to the user.  It is nice to rather quickly determine, in
; include-book for example, whether an alleged file exists.

  (er-let* ((ch (cond
                 ((null (canonical-pathname file nil state))
                  (er soft ctx
                      "The file ~x0 does not exist."
                      file))
                 (t (open-input-object-file file ctx state)))))
           (let ((state (close-input-channel ch state)))
             (value t))))

(defun include-book-dir (dir state)
  (declare
   (xargs :stobjs state
          :guard
          (and (symbolp dir)
               (or (not (raw-include-book-dir-p state))
                   (and (symbol-alistp
                         (f-get-global 'raw-include-book-dir!-alist state))
                        (symbol-alistp
                         (f-get-global 'raw-include-book-dir-alist state))))
               (let ((wrld (w state)))
                 (and (alistp (table-alist 'acl2-defaults-table wrld))
                      (alistp (cdr (assoc-eq :include-book-dir-alist
                                             (table-alist 'acl2-defaults-table
                                                          wrld))))
                      (alistp (table-alist 'include-book-dir!-table wrld)))))
          :guard-hints (("Goal" :in-theory (enable state-p1)))))
  (cond
   ((and (keywordp dir)
         (project-dir-lookup dir (project-dir-alist (w state)) nil)))
   ((raw-include-book-dir-p state)
    (or (cdr (assoc-eq dir (f-get-global 'raw-include-book-dir!-alist state)))
        (cdr (assoc-eq dir (f-get-global 'raw-include-book-dir-alist state)))))
   (t
    (let ((wrld (w state)))
      (or (cdr (assoc-eq dir
                         (cdr (assoc-eq :include-book-dir-alist
                                        (table-alist 'acl2-defaults-table
                                                     wrld)))))
          (cdr (assoc-eq dir
                         (table-alist 'include-book-dir!-table wrld))))))))

(defmacro include-book-dir-with-chk (soft-or-hard ctx dir)
  `(let ((ctx ,ctx)
         (dir ,dir))
     (let ((dir-value (include-book-dir dir state)))
       (cond ((null dir-value) ; hence, dir is not :system
              (er ,soft-or-hard ctx
                  "The legal values for the :DIR argument are keywords that ~
                   include those in the global project-dir-alist (see :DOC ~
                   project-dir-alist) as well as those added by a call of ~
                   ~v0.  However, that argument is ~x1, which is not ~@2."
                  '(add-include-book-dir add-include-book-dir!)
                  dir
                  (cond
                   ((keywordp dir)
                    (msg
                     "among the list of those legal values, ~x0"
                     (strip-cars
                      (union-eq
                       (project-dir-alist (w state))
                       (append
                        (cdr (assoc-eq :include-book-dir-alist
                                       (table-alist 'acl2-defaults-table
                                                    (w state))))
                        (table-alist 'include-book-dir!-table
                                     (w state)))))))
                   (t "a keyword"))))
             (t ,(if (eq soft-or-hard 'soft)
                     '(value dir-value)
                   'dir-value))))))

(defun accumulate-post-alist (post-alist include-book-alist)

; Post-alist is a tail of a post-alist from the certificate of a book.
; Include-book-alist is an include-book-alist, typically a value of world
; global 'include-book-alist-all.  We accumulate post-alist into
; include-book-alist, stripping off each LOCAL wrapper.

  (cond ((endp post-alist) include-book-alist)
        (t (let* ((entry0 (car post-alist))
                  (entry (if (eq (car entry0) 'LOCAL)
                             (cadr entry0)
                           entry0)))
             (cond
              ((member-equal entry include-book-alist)
               (accumulate-post-alist (cdr post-alist) include-book-alist))
              (t (cons entry
                       (accumulate-post-alist (cdr post-alist)
                                              include-book-alist))))))))

(defun skipped-proofsp-in-post-alist (post-alist)
  (cond
   ((endp post-alist) nil)
   (t

; An entry in the post-alist is (full user familiar cert-annotations . chk).
; It may optionally be embedded in a (LOCAL &) form.

    (let* ((localp (eq (car (car post-alist)) 'local))
           (cert-annotations (if localp
                                 (cadddr (cadr (car post-alist)))
                               (cadddr (car post-alist)))))
      (cond
       ((cdr (assoc-eq :skipped-proofsp cert-annotations))
        (if localp
            (car (cadr (car post-alist)))
          (car (car post-alist))))
       (t (skipped-proofsp-in-post-alist (cdr post-alist))))))))

(defun book-hash-alist (full-book-string state)

; Since we are computing this value as we write out a .cert file, we don't have
; an easy way to store information about that file, even though we might want
; to store its length as extra information for the hash.

  (mv-let
    (book-write-date state)
    (file-write-date$ full-book-string state)
    (mv-let
      (book-length state)
      (file-length$ full-book-string state)
      (value `((:BOOK-LENGTH . ,book-length)
               (:BOOK-WRITE-DATE . ,book-write-date))))))

(defun book-hash (old-book-hash full-book-string portcullis-cmds
                                expansion-alist cert-data book-ev-lst state)

; This function computes a hash for post-alists in .cert files.  It is a bit
; odd because get-portcullis-cmds gives the results of make-event expansion but
; book-ev-lst does not.  But that seems OK.

  (cond ((if old-book-hash
             (integerp old-book-hash)
           (not (f-get-global 'book-hash-alistp state)))

; The inputs are potential fields of a cert-obj record.  We deliberately omit
; the :pcert-info field of a cert-obj from the checksum: we don't want the
; checksum changing from the .pcert0 file to the .pcert1 file, and anyhow, its
; only function is to assist in proofs for the Convert procedure of provisional
; certification.

         (value (check-sum-obj (list* portcullis-cmds
                                      expansion-alist
                                      book-ev-lst
                                      cert-data))))
        (t (book-hash-alist full-book-string state))))

; For a discussion of early loading of compiled files for include-book, which
; is supported by the next few forms, see the Essay on Hash Table Support for
; Compilation.

#+acl2-loop-only
(defmacro with-hcomp-bindings (do-it form)
  (declare (ignore do-it))
  form)

#-acl2-loop-only
(defmacro with-hcomp-bindings (do-it form)
  (let ((ht-form (and do-it '(make-hash-table :test 'eq))))
    `(let ((*hcomp-fn-ht*       ,ht-form)
           (*hcomp-const-ht*    ,ht-form)
           (*hcomp-macro-ht*    ,ht-form)
           (*hcomp-fn-alist*    nil)
           (*hcomp-const-alist* nil)
           (*hcomp-macro-alist* nil)
           (*declaim-list* nil)
           (*hcomp-cert-obj* nil)
           (*hcomp-cert-filename* nil)
           (*hcomp-elided-defconst-alist* nil))
       ,@(and do-it
              '((declare (type hash-table
                               *hcomp-fn-ht*
                               *hcomp-const-ht*
                               *hcomp-macro-ht*))))
       ,form)))

#+acl2-loop-only
(defmacro with-hcomp-ht-bindings (form)
  form)

#-acl2-loop-only
(defmacro with-hcomp-ht-bindings (form)

; Consider a call of include-book-fn.  If it is on behalf of certify-book-fn,
; then a call of with-hcomp-bindings (in certify-book-fn) has already bound the
; *hcomp-xxx-ht* variables.  Otherwise, this macro binds them, as needed for
; the calls under include-book-fn1 of chk-certificate-file (which evaluates
; portcullis commands) and process-embedded-events, in order to use the
; relevant values stored in the three hash tables associated with the book from
; the early load of its compiled file.  Note that since these three hash table
; variables are destructively modified, we won't lose changes to them in the
; behalf-of-certify-flg case when we pop these bindings.

; Warning: Behalf-of-certify-flg and full-book-name need to be bound where this
; macro is called.

  `(let* ((entry (and (not behalf-of-certify-flg)
                      (and *hcomp-book-ht* ; for load without compiled file
                           (gethash full-book-name *hcomp-book-ht*))))
          (*hcomp-fn-ht*
           (if behalf-of-certify-flg
               *hcomp-fn-ht*
             (and entry (access hcomp-book-ht-entry entry :fn-ht))))
          (*hcomp-const-ht*
           (if behalf-of-certify-flg
               *hcomp-const-ht*
             (and entry (access hcomp-book-ht-entry entry :const-ht))))
          (*hcomp-macro-ht*
           (if behalf-of-certify-flg
               *hcomp-macro-ht*
             (and entry
                  (access hcomp-book-ht-entry entry :macro-ht)))))
     ,form))

(defun get-declaim-list (state)
  #+acl2-loop-only
  (read-acl2-oracle state)
  #-acl2-loop-only
  (value *declaim-list*))

(defun tilde-@-book-stack-msg (reason load-compiled-stack ctx wrld)

; Reason is t if the present book was to be included with :load-compiled-file
; t; it is nil if we are only to warn on missing compiled files; and otherwise,
; it is the full-book-name of a parent book that was to be included with
; :load-compiled-file t.

  (let* ((project-dir-alist (project-dir-alist wrld))
         (stack-rev (book-name-lst-to-filename-lst
                     (reverse (strip-cars load-compiled-stack))
                     project-dir-alist
                     ctx))
         (reason (if (sysfile-p reason)
                     (book-name-to-filename-1 reason project-dir-alist ctx)
                   reason))
         (arg
          (cond
           (stack-rev
            (msg "  Here is the sequence of books with loads of compiled or ~
                  expansion files that have led down to the printing of this ~
                  message, where the load for each is halted during the load ~
                  for the next:~|~%~*0"
                 `("  <empty>" ; what to print if there's nothing to print
                   "  ~s*"     ; how to print the last element
                   "  ~s*~|"   ; how to print the 2nd to last element
                   "  ~s*~|"   ; how to print all other elements
                   ,stack-rev)))
           (t "  No load was in progress for any parent book."))))
    (cond ((eq reason t)
           (msg "  This is an error because an include-book for this book ~
                 specified :LOAD-COMPILE-FILE ~x0; see :DOC include-book.~@1"
                reason arg))
          (reason
           (msg "  This is an error because we are underneath an include-book ~
                 for~|  ~y0that specified :LOAD-COMPILE-FILE ~x1; see :DOC ~
                 include-book.~@2"
                reason t arg))
          (t arg))))

(defun convert-book-string-to-acl2x (x)

; X is a book pathname (a string).  We generate the corresponding acl2x
; filename, in analogy to how convert-book-string-to-cert generates a
; certificate filename.

; See the Essay on .acl2x Files (Double Certification).

  (concatenate 'string
               (remove-lisp-suffix x nil)
               "acl2x"))

(defun acl2x-alistp (x index len)
  (cond ((atom x)
         (and (null x)
              (< index len)))
        ((consp (car x))
         (and (integerp (caar x))
              (< index (caar x))
              (acl2x-alistp (cdr x) (caar x) len)))
        (t nil)))

(defun read-acl2x-file (acl2x-file full-book-string len acl2x ctx state)
  (mv-let
   (acl2x-date state)
   (file-write-date$ acl2x-file state)
   (cond
    ((not acl2x)
     (pprogn (cond (acl2x-date
                    (warning$ ctx "acl2x"
                              "Although the file ~x0 exists, it is being ~
                               ignored because keyword option :ACL2X T was ~
                               not supplied to certify-book."
                              acl2x-file full-book-string))
                   (t state))
             (value nil)))
    (t (mv-let
        (book-date state)
        (file-write-date$ full-book-string state)
        (cond
         ((or (not (natp acl2x-date))
              (not (natp book-date))
              (< acl2x-date book-date))
          (cond
           ((eq acl2x :optional)
            (value nil))
           (t
            (er soft ctx
                "Certify-book has been instructed with option :ACL2X T to ~
                 read file ~x0.  However, this file ~#1~[does not exist~/has ~
                 not been confirmed to be at least as recent as the book ~
                 ~x2~].  See :DOC set-write-acl2x."
                acl2x-file
                (if acl2x-date 1 0)
                full-book-string))))
         (t (er-let* ((chan (open-input-object-file acl2x-file ctx state)))
              (state-global-let*
               ((current-package "ACL2"))
               (cond
                (chan (mv-let
                       (eofp val state)
                       (read-object chan state)
                       (cond
                        (eofp (er soft ctx
                                  "No form was read in acl2x file ~x0.~|See ~
                                   :DOC certify-book."
                                  acl2x-file))
                        ((acl2x-alistp val 0 len)
                         (pprogn
                          (observation ctx
                                       "Using expansion-alist containing ~n0 ~
                                        ~#1~[entries~/entry~/entries~] from ~
                                        file ~x2."
                                       (length val)
                                       (zero-one-or-more val)
                                       acl2x-file)
                          (value val)))
                        (t (er soft ctx
                               "Illegal value in acl2x file:~|~x0~|See :DOC ~
                                certify-book."
                               val)))))
                (t (value nil))))))))))))

(defun eval-port-file (full-book-string ctx state)
  (let ((port-file (convert-book-string-to-port full-book-string))
        (dir (directory-of-absolute-pathname full-book-string)))
    (pprogn
     (mv-let
      (ch state)
      (open-input-channel port-file :object state)
      (cond
       ((null ch)
        (value nil))
       (t
        (er-let* ((pkg (chk-in-package ch port-file t ctx state)))
          (cond
           ((null pkg) ; empty .port file
            (value nil))
           ((not (equal pkg "ACL2"))
            (er soft ctx
                "File ~x0 is corrupted.  It was expected either to contain no ~
                 forms or to start with the form (in-package \"ACL2\")."
                port-file))
           (t
            (prog2$

; We use observation-cw just below, instead of observation, because we do not
; want to inhibit these observations during include-book.  One can still
; inhibit OBSERVATION output globally with set-inhibit-output-lst in order to
; turn off all such messages.

             (observation-cw ctx
                             "Reading .port file, ~s0."
                             port-file)
             (with-cbd
              dir
              (state-global-let*
               ((current-package "ACL2"))
               (mv-let (error-flg val state)
                 (revert-world-on-error
                  (with-reckless-readtable

; Here we read the .port file.  We use with-reckless-readtable so that we can
; read characters such as #\Null; otherwise, for example, we get an error using
; CCL if we certify a book on top of the command (make-event `(defconst
; *new-null* ,(code-char 0))).  Note that the .port file is not intended to be
; written directly by users, so we can trust that we are reading back in what
; was written unless a different host Lisp was used for reading and writing the
; .port file.  Fortunately, the .port file is generally only used when
; including uncertified books, where all bets are off.

; Note that chk-raise-portcullis1 resets the acl2-defaults-table just as would
; be done when raising the portcullis of a certified book.

                   (chk-raise-portcullis1 full-book-string port-file ch t
                                          ctx state)))
                 (pprogn
                  (close-input-channel ch state)
                  (cond (error-flg (silent-error state))
                        (t (pprogn
                            (cond
                             ((null val)

; We considered printing "Note: file ~x0 contains no commands.~|", but that
; could be annoying since in this common case, the user might not even be
; thinking about .port files.

                              state)
                             (t
                              (io? event nil state
                                   (port-file val)
                                   (fms "ACL2 has processed the ~n0 ~
                                         command~#1~[~/s~] in file ~x2.~|"
                                        (list (cons #\0 (length val))
                                              (cons #\1 val)
                                              (cons #\2 port-file))
                                        (proofs-co state) state nil))))
                            (value val))))))))))))))))))

(defun getenv! (str state)

; This is just getenv$, except that "" is coerced to nil.

  (declare (xargs :stobjs state :guard (stringp str)))
  (er-let* ((temp (getenv$ str state)))
    (value (and (not (equal temp ""))
                temp))))

(defun update-pcert-books (full-book-name pcert-p wrld)
  (cond (pcert-p
         (global-set 'pcert-books
                     (cons full-book-name
                           (global-val 'pcert-books wrld))
                     wrld))
        (t wrld)))

(defconst *projects/apply/base-sysfile*
  (make-sysfile :system "projects/apply/base.lisp"))

; The next major function defined below is include-book-fn1.  To improve
; readability we have separated out various parts of its code into the
; definitions below, up to the definition of include-book-fn1.

(defun include-book-cert-obj-prelim (behalf-of-certify-flg
                                     uncertified-okp
                                     full-book-string full-book-name
                                     suspect-book-action-alist
                                     directory-name ctx wrld state)

; Return an error triple.  The value in the non-error case is either nil or a
; cert-obj record.  Suppose the value is not nil.  Then this cert-obj record
; contains the result of raising the portcullis.  It includes
; include-book-alist entries for the files that are to be brought in by this
; inclusion.  Then the first element of post-alist is the one for this book.
; It should look like this: (full-book-name' user-book-name' familiar-name
; cert-annotations . book-hash), where the first two names are irrelevant here
; because they reflect where the book was when it was certified rather than
; where the book resides now.  However, the familiar-name, cert-annotations and
; the book-hash ought to be those for the current book.

; Note that at this point, it is still possible that the certificate is invalid
; (e.g., out of date).

  (cond (behalf-of-certify-flg (value nil))
        ((f-get-global 'ignore-cert-files state)
         (cond
          ((eq uncertified-okp nil)

; Include-book-er returns an error or (value nil).

           (include-book-er
            full-book-string nil
            (if (equal full-book-name
                       (f-get-global 'ignore-cert-files state))
                "Include-book is specifying :UNCERTIFIED-OKP :IGNORE-CERTS, ~
                 which requires that its certificate file (if any) must be ~
                 ignored."
              (msg "A superior include-book event for ~x0 has specified ~
                    :UNCERTIFIED-OKP :IGNORE-CERTS, which requires that the ~
                    certificate files (if any) for its sub-books must be ~
                    ignored."
                   (book-name-to-filename
                    (f-get-global 'ignore-cert-files state)
                    wrld
                    ctx)))
            :uncertified-okp
            suspect-book-action-alist
            ctx state))
          (t (value nil))))
        (t (with-hcomp-ht-bindings
            (chk-certificate-file full-book-string
                                  directory-name
                                  full-book-name
                                  'include-book ctx state
                                  suspect-book-action-alist
                                  t)))))

(defun include-book-ok-familiar-name-and-hash (cert-obj
                                               post-alist
                                               familiar-name full-book-string
                                               post-alist-book-hash
                                               ev-lst-book-hash
                                               suspect-book-action-alist
                                               ctx state)
  (er-let* ((no-errp-1

; Notice that we are reaching inside the certificate object to retrieve
; information about the book from the post-alist.  (Car post-alist)) is in
; fact of the form (full-book-name user-book-name familiar-name
; cert-annotations . book-hash).

             (cond
              ((and cert-obj
                    (not (equal (caddr
                                 (car post-alist))
                                familiar-name)))
               (include-book-er
                full-book-string nil
                (cons
                 "The cer~-ti~-fi~-cate on file for ~x0 lists the book under ~
                  the name ~x3 whereas we were expecting it to give the name ~
                  ~x4.  While one can often move a certified book from one ~
                  directory to another after cer~-ti~-fi~-ca~-tion, we insist ~
                  that it keep the same familiar name.  This allows the ~
                  cer~-ti~-fi~-cate file to contain the familiar name, making ~
                  it easier to identify which cer~-ti~-fi~-cates go with ~
                  which files and inspiring a little more confidence that the ~
                  cer~-ti~-fi~-cate really does describe the alleged file.  ~
                  In the present case, it looks as though the familiar ~
                  book-name was changed after cer~-ti~-fi~-ca~-tion.  For ~
                  what it is worth, the book-hash of the file at ~
                  cer~-ti~-fi~-ca~-tion was ~x5.  Its book-hash now is ~x6."
                 (list
                  (cons #\3 (caddr (car post-alist)))
                  (cons #\4 familiar-name)
                  (cons #\5 post-alist-book-hash)
                  (cons #\6 ev-lst-book-hash)))
                :uncertified-okp
                suspect-book-action-alist
                ctx state))
              (t (value t))))
            (no-errp-2
             (cond
              ((and cert-obj
                    (not (equal post-alist-book-hash
                                ev-lst-book-hash)))
               (include-book-er
                full-book-string nil
                (cons
                 "~|The certificate for ~x0 lists the book-hash of that book ~
                  as ~x3.  But its book-hash is now computed to be ~x4.~|See ~
                  :DOC book-hash-mismatch."
                 (list (cons #\3 post-alist-book-hash)
                       (cons #\4 ev-lst-book-hash)))
                :uncertified-okp
                suspect-book-action-alist
                ctx state))
              (t (value t)))))
    (value (and no-errp-1 no-errp-2))))

(defun include-book-process-embedded-events (ev-lst
                                             directory-name ttags-info
                                             cert-obj cert-ttags cert-data
                                             behalf-of-certify-flg
                                             full-book-string full-book-name
                                             skip-proofsp expansion-alist
                                             ctx state)

; This function is called by include-book-fn1, to process the events in the
; given book, and to return the new value to be installed for state global
; ttags-allowed in the case that the book is considered to be certified.  The
; following conditions (at least) hold on the parameters of that call.

; - If input cert-obj is nil, then input ttags-info is also nil.
; - The include-book-path begins with full-book-name.

; That call is also made in the context of revert-world-on-error, which
; protects the process-embedded-events call below.

  (with-cbd
   directory-name
   (state-global-let*
    ((axiomsp nil)
     (ttags-allowed
      (if cert-obj
          cert-ttags
        (f-get-global 'ttags-allowed state)))
     (skip-notify-on-defttag
      (and ttags-info ; hence cert-obj is non-nil
           full-book-string))
     (match-free-error nil)
     (guard-checking-on
      t) ; see Essay on Guard Checking
     (in-local-flg
      (and (f-get-global 'in-local-flg state)
           'local-include-book))
     (including-uncertified-p (not cert-obj)))
    (er-progn
     (with-hcomp-ht-bindings
      (process-embedded-events
       'include-book

; We do not allow this call of process-embedded-events to set the ACL2 defaults
; table at the end.  For, consider the case that (defttag foo) has been
; executed just before the (include-book "bar") being processed.  At the start
; of this process-embedded-events we clear the acl2-defaults-table, removing
; any :ttag.  If we try to restore the acl2-defaults-table at the end of this
; process-embedded-events, we will fail because the include-book-path was
; extended to include the full-book-name for "bar", and the restoration
; installs a :ttag of foo, yet in our example there is no :ttags argument for
; (include-book "bar").  So, instead we directly set the 'table-alist property
; of 'acl2-defaults-table for the install-event call below.

; Moreover, if we are doing the include-book pass of a certify-book command,
; then we also do not allow process-embedded-events to set the ACL2 defaults
; table at the beginning.

       (if behalf-of-certify-flg
           :do-not-install!
         :do-not-install)
       skip-proofsp
       (cadr (car ev-lst))
       (list 'include-book full-book-name)
       (subst-by-position expansion-alist
                          (cdr ev-lst)
                          1)
       1
       (and (eq skip-proofsp 'include-book)

; We want to skip the make-event check when including a book that we already
; know (at this point) is uncertified (except when done as part of
; certify-book).

            (or (and cert-obj t)
                behalf-of-certify-flg))
       cert-data ctx state))
     (value (if ttags-info ; hence cert-obj is non-nil
                (car ttags-info)
              (f-get-global 'ttags-allowed state)))))))

(defun include-book-certified-p (cert-obj post-alist actual-alist
                                          suspect-book-action-alist
                                          full-book-string ctx state)

; This function is called by include-book-fn1, which supplies parameters
; satisfying constraints not described here.

  (cond
   ((null cert-obj) (value nil))
   ((not (include-book-alist-subsetp
          (unmark-and-delete-local-included-books
           (cdr post-alist))
          actual-alist))

; Our next step is to call include-book-er, but we break up that computation so
; that we avoid needless computation (potentially reading certificate files) if
; no action is to be taken.

    (let ((warning-summary (include-book-er-warning-summary
                            :uncertified-okp
                            suspect-book-action-alist
                            state)))
      (cond
       ((and (equal warning-summary "Uncertified")
             (warning-disabled-p "Uncertified"))
        (value nil))
       (t
        (mv-let (msgs state)
          (tilde-*-book-hash-phrase
           (unmark-and-delete-local-included-books (cdr post-alist))
           actual-alist
           state)
          (include-book-er1
           full-book-string nil
           (cons "After processing the events in the book ~x0:~*3."
                 (list (cons #\3 msgs)))
           warning-summary ctx state))))))
   (t (value t))))

(defun include-book-certification-tuple (certified-p
                                         cert-full-book-name full-book-name
                                         user-book-name familiar-name
                                         cert-annotations ev-lst-book-hash)

; This function is called by include-book-fn1, which supplies parameters
; satisfying constraints not described here.

  (cond
   (certified-p

; Below we use the full-book-name derived from the certificate (if valid),
; cert-full-book-name, rather than full-book-name (from the parse of the
; user-book-name), in certification-tuple.  Intuitively, cert-full-book-name is
; the unique representative of the class of all legal full-book-names
; (including those that involve soft links).  Before Version_2.7 we used
; full-book-name rather than cert-full-book-name, and this led to problems as
; shown in the example below.  Now this might no longer be any sort of issue,
; because it's not clear that the cert-full-book-name and full-book-name can
; differ here; see the comment in include-book-fn1 regarding "We try the
; redundancy check again".

;;;   % ls temp*/*.lisp
;;;   temp1/a.lisp  temp2/b.lisp  temp2/c.lisp
;;;   % cat temp1/a.lisp
;;;   (in-package "ACL2")
;;;   (defun foo (x) x)
;;;   % cat temp2/b.lisp
;;;   (in-package "ACL2")
;;;   (defun goo (x) x)
;;;   % cat temp2/c.lisp
;;;   (in-package "ACL2")
;;;   (defun hoo (x) x)
;;;   %
;;;
;;; Below, two absolute pathnames are abbreviated as <path1> and <path2>.
;;;
;;; In temp2/ we LD a file with the following forms.
;;;
;;;   (certify-book "<path1>/a")
;;;   :u
;;;   (include-book "../temp1/a")
;;;   (certify-book "b" 1)
;;;   :ubt! 1
;;;   (include-book "b")
;;;   (certify-book "c" 1)
;;;
;;; We then see the following error.  The problem is that <path1> involved symbolic
;;; links, and hence did not match up with the entry in the world's
;;; include-book-alist made by (include-book "../temp1/a") which expanded to an
;;; absolute pathname that did not involve symbolic links.
;;;
;;;   ACL2 Error in (CERTIFY-BOOK "c" ...):  During Step 3 , we loaded different
;;;   books than were loaded by Step 2!  Perhaps some other user of your
;;;   file system was editing the books during our Step 3?  You might think
;;;   that some other job is recertifying the books (or subbooks) and has
;;;   deleted the certificate files, rendering uncertified some of the books
;;;   needed here.  But more has happened!  Some file has changed!
;;;
;;;   Here is the include-book-alist as of the end of Step 2:
;;;   (("<path2>/temp2/c.lisp"
;;;         "c" "c" ((:SKIPPED-PROOFSP) (:AXIOMSP))
;;;         . 48180423)
;;;    ("<path2>/temp2/b.lisp"
;;;         "b" "b" ((:SKIPPED-PROOFSP) (:AXIOMSP))
;;;         . 46083312)
;;;    (LOCAL ("<path1>/a.lisp"
;;;                "<path1>/a"
;;;                "a" ((:SKIPPED-PROOFSP) (:AXIOMSP))
;;;                . 43986201))).
;;;
;;;   And here is the alist as of the end of Step 3:
;;;   (("<path2>/temp2/c.lisp"
;;;         "c" "c" ((:SKIPPED-PROOFSP) (:AXIOMSP))
;;;         . 48180423)
;;;    ("<path2>/temp2/b.lisp"
;;;         "b" "b" ((:SKIPPED-PROOFSP) (:AXIOMSP))
;;;         . 46083312)
;;;    ("<path2>/temp1/a.lisp"
;;;         "<path2>/temp1/a"
;;;         "a" ((:SKIPPED-PROOFSP) (:AXIOMSP))
;;;         . 43986201)).
;;;
;;;   Frequently, the former has more entries than the latter because the
;;;   former includes LOCAL books. So compare corresponding entries, focusing
;;;   on those in the latter.  Each entry is of the form (name1 name2 name3
;;;   alist . book-hash).  Name1 is the full name, name2 is the name as written
;;;   in an include-book event, and name3 is the ``familiar'' name of the
;;;   file. The alist indicates the presence or absence of problematic forms in
;;;   the file, such as DEFAXIOM events.  For example, (:AXIOMSP . T) means
;;;   there were defaxiom events; (:AXIOMSP . NIL) -- which actually prints as
;;;   (:AXIOMSP) -- means there were no defaxiom events. Finally, book-hash is
;;;   either an integer checksum on the contents of the file at the time it
;;;   was certified, an alist (see book-hash-alist), or else book-hash is nil
;;;   indicating that the file is not certified.  Note that if the book-hash is
;;;   nil, the entry prints as (name1 name2 name3 alist).  Go figure.
;
;
;;;   Summary
;;;   Form:  (CERTIFY-BOOK "c" ...)
;;;   Rules: NIL
;;;   Warnings:  Guards
;;;   Time:  0.01 seconds (prove: 0.00, print: 0.00, other: 0.01)
;
;;;   ******** FAILED ********  See :DOC failure  ******** FAILED ********
;;;    :ERROR
;;;   ACL2 !>

    (list* cert-full-book-name
           user-book-name
           familiar-name
           cert-annotations
           ev-lst-book-hash))
   (t

; The certification tuple below is marked as uncertified (by setting its
; book-hash field to nil).

    (list* full-book-name
           user-book-name
           familiar-name
           nil
           nil))))

(defun include-book-pcert-p (certified-p cert-obj full-book-string ctx state)

; This function is called by include-book-install-event, which supplies
; parameters satisfying constraints not described here.

  (cond ((and certified-p
              (access cert-obj cert-obj :pcert-info))
         (pprogn
          (cond ((or (pcert-op-p (cert-op state))
                     (warning-off-p
                      "Provisionally certified"
                      state))
                 state)
                (t (mv-let
                     (erp pcert-envp state)
                     (getenv! "ACL2_PCERT" state)
                     (assert$
                      (not erp)
                      (cond
                       (pcert-envp state)
                       (t
                        (warning$
                         ctx
                         ("Provisionally certified")
                         "The book ~s0 was only provisionally certified ~
                          (proofs ~s1)."
                         full-book-string
                         (if (eq (access cert-obj cert-obj :pcert-info)
                                 :proved)
                             "completed"
                           "skipped"))))))))
          (value t)))
        (t (value nil))))

(defun include-book-install-event (certified-p
                                   behalf-of-certify-flg cert-obj
                                   cddr-event-form full-book-string
                                   cert-full-book-name full-book-name
                                   old-include-book-path certification-tuple
                                   post-alist ttags-info old-ttags-seen
                                   saved-acl2-defaults-table
                                   old-skip-proofs-seen
                                   cert-obj-skipped-proofsp
                                   ctx wrld3 state)

; This function is called by include-book-fn1, which supplies parameters
; satisfying constraints not described here.

  (er-let* ((declaim-list (get-declaim-list state))
            (pcert-p (include-book-pcert-p certified-p cert-obj
                                           full-book-string ctx state)))
    (install-event
     (if behalf-of-certify-flg
         declaim-list
       (let ((name (or cert-full-book-name
                       full-book-name)))
         (if (f-get-global 'script-mode state)
             name
           (book-name-to-filename name wrld3 ctx))))
     (list* 'include-book

; We use the unique representative of the book's filename provided by the one
; in the .cert file, when the certificate is valid before execution of this
; event), namely, cert-full-book-name; otherwise, we use the full-book-string
; parsed from what the user supplied.  (These might always agree; see comment
; in include-book-fn1 on "We try the redundancy check again".)  Either way,
; we have an absolute pathname, which is useful for the :puff and :puff*
; commands.  These could fail before Version_2.7 because the relative path name
; stored in the event was not sufficient to find the book at :puff/:puff* time.

            (remove-lisp-suffix
             (if cert-full-book-name
                 (book-name-to-filename cert-full-book-name wrld3 ctx)
               full-book-string)
             t)
            cddr-event-form)
     'include-book full-book-string nil nil t ctx
     (let* ((wrld4
             (update-pcert-books
              full-book-name
              pcert-p
              (global-set
               'include-book-path old-include-book-path
               (global-set
                'certification-tuple certification-tuple
                (global-set
                 'include-book-alist
                 (add-to-set-equal
                  certification-tuple
                  (global-val 'include-book-alist wrld3))
                 (global-set
                  'include-book-alist-all
                  (add-to-set-equal
                   certification-tuple
                   (accumulate-post-alist
                    (cdr post-alist)
                    (global-val 'include-book-alist-all wrld3)))
                  wrld3))))))
            (wrld5
             (if ttags-info ; hence certified-p
                 (global-set? 'ttags-seen
                              (cdr ttags-info)
                              wrld4
                              old-ttags-seen)
               wrld4))
            (wrld6
             (if (equal (table-alist 'acl2-defaults-table wrld3)
                        saved-acl2-defaults-table)
                 wrld5
               (putprop 'acl2-defaults-table
                        'table-alist
                        saved-acl2-defaults-table
                        wrld5)))
            (wrld7
             (cond ((or old-skip-proofs-seen
                        (not certified-p))
                    wrld6)
                   (t
                    (let ((full-book-name
                           (if cert-obj-skipped-proofsp

; We prefer that an error report about skip-proofs in certification world be
; about a non-local event.

                               full-book-name
                             (skipped-proofsp-in-post-alist post-alist))))
                      (if full-book-name
                          (global-set 'skip-proofs-seen
                                      (list :include-book full-book-name)
                                      wrld6)
                        (if (global-val 'skip-proofs-seen
                                        wrld3) ; installed world

; In this case, the included book is certified and also, since
; old-skip-proofs-seen = nil, no proofs had been skipped at the time execution
; began for this include-book.  So if the world after including the book has
; skip-proofs-seen set, we restore the value to nil.

                            (global-set 'skip-proofs-seen nil wrld6)
                          wrld6))))))
            (wrld8

; Various events need the answer to the question: have the apply$ books been
; included?  E.g., defwarrant needs that to succeed in its fn-equal congruence
; proofs.  And the rewriter asks that when considering optimizing the use of
; EV$-OPENER on calls of EV$ on quoted terms.  So we memoize the answer here.
; We arrange that the world global projects/apply/base-includedp is t or nil
; according to whether the book is in include-book-alist.  Note that
; include-book-alist and projects/apply/base-includedp are both world globals,
; so they will stay in sync even with :ubt and local include-book events.

             (if (equal full-book-name
                        *projects/apply/base-sysfile*)
                 (global-set 'projects/apply/base-includedp
                             t
                             wrld7)
               wrld7)))
       wrld8)
     state)))

(defun include-book-fn1 (user-book-name state
                                        load-compiled-file
                                        expansion-alist/cert-data
                                        uncertified-okp
                                        defaxioms-okp
                                        skip-proofs-okp
                                        ttags
                                        ctx
                                        full-book-string
                                        full-book-name
                                        directory-name
                                        familiar-name
                                        cddr-event-form)

; Input expansion-alist/cert-data is nil except when this call is from an
; attempt to certify full-book-name, in which case it is of the form (cons E
; C).  In that case, this function was invoked by a call of include-book-fn
; invoked by certify-book-fn, and E is an expansion-alist generated from
; make-event calls, while C is cert-data extracted from pass 1 of the attempted
; certification.

  #+acl2-loop-only (declare (ignore load-compiled-file))
  (let* ((wrld1 (w state))
         (behalf-of-certify-flg (consp expansion-alist/cert-data))
         (old-skip-proofs-seen (global-val 'skip-proofs-seen wrld1))
         (active-book-name (active-book-name wrld1 state))
         (old-ttags-seen (global-val 'ttags-seen wrld1))
         #-acl2-loop-only
         (*defeat-slow-alist-action* (or *defeat-slow-alist-action*
                                         'stolen))
         #-acl2-loop-only
         (*inside-include-book-fn* (if behalf-of-certify-flg
                                       'hcomp-build
                                     t))
         (old-include-book-path
          (global-val 'include-book-path wrld1))
         (saved-acl2-defaults-table
          (table-alist 'acl2-defaults-table wrld1))

; If you add more keywords to the suspect-book-action-alist, make sure you do
; the same to the list constructed by certify-book-fn.  You might wish to
; handle the new warning summary in warning1.

         (uncertified-okp-effective (if (member-eq (cert-op state)
                                                   '(nil :write-acl2xu))
                                        uncertified-okp
                                      nil))
         (suspect-book-action-alist
          (list (cons :uncertified-okp uncertified-okp-effective)
                (cons :defaxioms-okp defaxioms-okp)
                (cons :skip-proofs-okp skip-proofs-okp)))
         (include-book-alist0 (global-val 'include-book-alist wrld1)))
    (revert-world-on-error
     (cond
      ((and (not (f-get-global 'boot-strap-flg state))
            full-book-name
            (assoc-equal full-book-name include-book-alist0))
       (stop-redundant-event ctx state))
      (t
       (let ((wrld2 (global-set 'include-book-path
                                (cons full-book-name old-include-book-path)
                                wrld1)))
         (pprogn
          (set-w 'extension wrld2 state)
          (er-let* ((cert-obj-prelim
                     (include-book-cert-obj-prelim
                      behalf-of-certify-flg uncertified-okp-effective
                      full-book-string full-book-name
                      suspect-book-action-alist directory-name
                      ctx wrld1 state))
                    (cert-data-prelim
                     (value
                      (if cert-obj-prelim ; hence not behalf-of-certify-flg
                          (access cert-obj cert-obj-prelim :cert-data)
                        (cdr expansion-alist/cert-data)))))
            (fast-alist-free-cert-data-on-exit
             cert-data-prelim
             (er-let* ((redef
                        (chk-new-stringp-name 'include-book full-book-name ctx
                                              wrld2 state))
                       (post-alist-prelim
                        (value (and cert-obj-prelim
                                    (access cert-obj cert-obj-prelim
                                            :post-alist))))
                       (cert-full-book-name-prelim
                        (value (car (car post-alist-prelim)))))
               (cond

; We try the redundancy check again, because it will be cert-full-book-name
; that is stored on the world's include-book-alist, not full-book-name if the
; two book-names differ.  Can this actually happen?  (That's not clear as of
; October 2022, with the new effort to make parse-book-name return a
; full-book-name and full-book-string that are canonical.)

                ((and cert-full-book-name-prelim
                      (not (equal full-book-name cert-full-book-name-prelim))
                      (not (f-get-global 'boot-strap-flg state))
                      (assoc-equal cert-full-book-name-prelim
                                   include-book-alist0))

; Chk-certificate-file calls chk-certificate-file1, which calls
; chk-raise-portcullis, which calls chk-raise-portcullis1, which evaluates, for
; example, maybe-install-acl2-defaults-table.  So we need to revert the world
; here.

; Notice that cert-full-book-name-prelim comes from a certificate file that
; might be invalid (for example, out of date).  So it might surprise the user
; to find that this bogus certificate file is impeding the inclusion of the
; unspecified book with name full-book-name.  However, we expect this situation
; to be extremely rare, and we believe it's sound simply to ignore the given
; include-book event by treating it as redundant.

                 (pprogn (set-w 'retraction wrld1 state)
                         (stop-redundant-event ctx state)))
                (t
                 (er-let* ((ignored-val

; We must read the .port file if the necessary packages haven't yet been
; defined (unless state global 'port-file-enabled indicates that we should
; never load .port files), before reading events in the book.

                            (cond ((or cert-obj-prelim
                                       behalf-of-certify-flg
                                       (not (f-get-global 'port-file-enabled
                                                          state)))
                                   (value nil))
                                  (t (eval-port-file full-book-string ctx
                                                     state))))
                           (ev-lst
                            (read-object-file full-book-string ctx state))
                           (post-alist-book-hash-prelim
                            (value (cddddr (car post-alist-prelim))))
                           (ev-lst-book-hash
                            (if cert-obj-prelim ; hence not behalf-of-certify-flg
                                (book-hash post-alist-book-hash-prelim
                                           full-book-string
                                           (access cert-obj cert-obj-prelim
                                                   :cmds)
                                           (access cert-obj cert-obj-prelim
                                                   :expansion-alist)
                                           cert-data-prelim
                                           ev-lst
                                           state)
                              (value nil)))
                           (ok-familiar-name-and-hash
                            (include-book-ok-familiar-name-and-hash
                             cert-obj-prelim post-alist-prelim familiar-name
                             full-book-string post-alist-book-hash-prelim
                             ev-lst-book-hash suspect-book-action-alist ctx
                             state)))
                   (let* ((cert-obj
                           (and ok-familiar-name-and-hash cert-obj-prelim))
                          (cert-data
                           (and (or cert-obj
                                    behalf-of-certify-flg)
                                cert-data-prelim))
                          (post-alist (and cert-obj
                                           post-alist-prelim))
                          (expansion-alist
                           (cond (behalf-of-certify-flg
                                  (car expansion-alist/cert-data))
                                 (cert-obj
                                  (access cert-obj cert-obj :expansion-alist))
                                 (t nil)))
                          (cert-annotations
                           (cadddr (car post-alist)))
                          (cert-ttags
                           (cdr (assoc-eq :ttags cert-annotations)))
                          (cert-obj-skipped-proofsp
                           (and cert-obj
                                (cdr (assoc-eq :skipped-proofsp
                                               cert-annotations))))
                          (warn-for-ttags-default
                           (and (eq ttags :default)
                                (not (warning-off-p "Ttags" state))))
                          (ttags (if (eq ttags :default)
                                     :all
                                   ttags)))
                     #-acl2-loop-only
                     (when (and (not cert-obj)
                                (not behalf-of-certify-flg)
                                *hcomp-book-ht*)

; The book is not certified, but we may have loaded compiled definitions for it
; into its hash tables.  We eliminate any such hash tables now, before calling
; process-embedded-events.  Note that we may have already evaluated the
; portcullis commands from an invalid certificate using these hash tables.
; However, even before we implemented early loading of compiled files for
; include book (as described in the Essay on Hash Table Support for
; Compilation), we loaded portcullis commands in such cases -- and we have
; checked that the compiled (or expansion) file is no older than the
; certificate file, to ensure that the hash tables really do go with the
; certificate.  So at least we have not compounded the error of evaluating
; portcullis commands by using the relevant values from the hash tables.

                       (remhash full-book-name *hcomp-book-ht*))
                     (er-let* ((ttags
                                (chk-well-formed-ttags ttags directory-name
                                                       ctx state))
                               (ignored-val
                                (cond
                                 ((or cert-obj-skipped-proofsp
                                      (and cert-obj
                                           (cdr (assoc-eq :axiomsp
                                                          cert-annotations))))
                                  (chk-cert-annotations
                                   cert-annotations
                                   nil
                                   (access cert-obj cert-obj :cmds)
                                   full-book-string
                                   suspect-book-action-alist
                                   ctx state))
                                 (t (value nil))))
                               (ttags-info
                                (cond
                                 ((not cert-obj)
                                  (value nil))
                                 (t
                                  (er-progn

; We check that the ttags supplied as an argument to include-book are
; sufficiently inclusive to allow the ttags from the certificate.  No global
; state is updated, not even 'ttags-allowed; this is just a check.

                                   (chk-acceptable-ttags1
                                    cert-ttags
                                    nil ; the active-book-name is irrelevant
                                    ttags
                                    nil    ; ttags-seen is irrelevant
                                    :quiet ; do not print ttag notes
                                    ctx state)

; From the check just above, we know that the ttags supplied as arguments are
; sufficient to allow the certificate's ttags.  We next check that the global
; ttags-allowed are also sufficient to allow the certificate's ttags.  The
; following call returns a pair to be bound to ttags-info (above), consisting
; of a refined ttags-allowed and an extended ttags-seen.  It prints all
; relevant ttag notes if the book is certified; below, we bind
; skip-notify-on-defttag in that case so that we don't see ttag notes for
; individual events in the book.

                                   (chk-acceptable-ttags1

; With some effort, perhaps we could find a way to avoid causing an error when
; this call of chk-acceptable-ttags1 returns an error.  But that would take
; some effort; see the Essay on Trust Tags (Ttags).

                                    cert-ttags active-book-name
                                    (f-get-global 'ttags-allowed state)
                                    old-ttags-seen
                                    (if warn-for-ttags-default
                                        (cons ctx full-book-string)
                                      t)
                                    ctx state)))))
                               (skip-proofsp

; At one time we bound this variable to 'initialize-acl2 in some cases.  But we
; prefer now to use 'include-book here in all cases, as illustrated by an
; example from Eric Smith.  His book included forms (local (include-book
; "bar")) and (local (my-macro)), where my-macro is defined in bar.lisp.  With
; 'initialize-acl2, chk-embedded-event-form recurs through the local calls and
; reports that (my-macro) is not an embedded event form (because the local
; inclusion of "bar" prevents my-macro from being defined).  With
; 'include-book, we can include the book.  More generally, Eric would like
; uncertified books to be treated by include-book much like certified books, in
; order to assist his development process.  That seems reasonable.

                                (value 'include-book))
                               (ttags-allowed1
                                (include-book-process-embedded-events
                                 ev-lst directory-name ttags-info
                                 cert-obj cert-ttags cert-data
                                 behalf-of-certify-flg
                                 full-book-string full-book-name
                                 skip-proofsp expansion-alist ctx state)))
                       (let* ((wrld3 (w state))
                              (actual-alist
                               (global-val 'include-book-alist wrld3)))
                         (er-let*
                             ((certified-p
                               (include-book-certified-p
                                cert-obj post-alist actual-alist
                                suspect-book-action-alist full-book-string
                                ctx state))
                              (cert-obj-skipped-proofsp
                               (value (and certified-p
                                           cert-obj-skipped-proofsp)))
                              (post-alist
                               (value (and certified-p post-alist)))
                              (ttags-info
                               (value (and certified-p ttags-info))))
                           (er-progn

; Now we check that all the subbooks of this one are also compatible with the
; current settings of suspect-book-action-alist.  The car of post-alist is
; the part that deals with full-book-name itself.  So we deal below with the
; cdr, which lists the subbooks.  The cert-obj may be nil, which makes the test
; below a no-op.

                            (chk-cert-annotations-post-alist
                             (cdr post-alist) ; nil if not certified-p
                             (and certified-p
                                  (access cert-obj cert-obj :cmds))
                             full-book-string
                             suspect-book-action-alist
                             ctx state)
                            (let* ((cert-full-book-name
                                    (cond (certified-p
                                           cert-full-book-name-prelim)
                                          (t full-book-name)))
                                   (certification-tuple
                                    (include-book-certification-tuple
                                     certified-p
                                     cert-full-book-name full-book-name
                                     user-book-name familiar-name
                                     (and certified-p
                                          (cadddr (car post-alist)))
                                     ev-lst-book-hash)))
                              (er-progn
                               #-acl2-loop-only
                               (cond
                                ((eq load-compiled-file :comp)
                                 (compile-for-include-book full-book-string
                                                           full-book-name
                                                           certified-p
                                                           ctx
                                                           state))
                                (t (value nil)))
                               (pprogn
                                (redefined-warning redef ctx state)
                                (if certified-p
                                    (f-put-global 'ttags-allowed
                                                  ttags-allowed1
                                                  state)
                                  state)
                                (include-book-install-event
                                 certified-p behalf-of-certify-flg cert-obj
                                 cddr-event-form full-book-string
                                 cert-full-book-name full-book-name
                                 old-include-book-path certification-tuple
                                 post-alist ttags-info old-ttags-seen
                                 saved-acl2-defaults-table old-skip-proofs-seen
                                 cert-obj-skipped-proofsp
                                 ctx wrld3 state))))))))))))))))))))))

(defun chk-include-book-inputs (load-compiled-file
                                uncertified-okp
                                defaxioms-okp
                                skip-proofs-okp
                                ctx state)

  (let ((er-str "The ~x0 argument of include-book must be ~v1.  The value ~x2 ~
                 is thus illegal.  See :DOC include-book."))
    (cond
     ((not (member-eq load-compiled-file *load-compiled-file-values*))
      (er soft ctx er-str
          :load-compiled-file
          *load-compiled-file-values*
          load-compiled-file))
     ((not (member-eq uncertified-okp '(t nil :ignore-certs)))
      (er soft ctx er-str
          :uncertified-okp
          '(t nil :ignore-certs)
          uncertified-okp))
     ((not (member-eq defaxioms-okp '(t nil)))
      (er soft ctx er-str
          :defaxioms-okp
          '(t nil)
          defaxioms-okp))
     ((not (member-eq skip-proofs-okp '(t nil)))
      (er soft ctx er-str
          :skip-proofs-okp
          '(t nil)
          skip-proofs-okp))
     (t (value nil)))))

(defun include-book-fn (user-book-name state
                                       load-compiled-file
                                       expansion-alist/cert-data
                                       uncertified-okp
                                       defaxioms-okp
                                       skip-proofs-okp
                                       ttags
                                       dir
                                       event-form)

; Note that the acl2-defaults-table is initialized when raising the portcullis.
; As of this writing, this happens by way of a call of chk-certificate-file in
; include-book-fn1, as chk-certificate-file calls chk-certificate-file1, which
; calls chk-raise-portcullis, etc.

; When this function is called by certify-book-fn, expansion-alist/cert-data is
; (cons E C), where E an expansion-alist generated from make-event calls and C
; is cert-data extracted from pass1.  Otherwise, expansion-alist/cert-data is
; nil.

  (with-ctx-summarized
   (cons 'include-book user-book-name)
   (state-global-let*
    ((compiler-enabled (f-get-global 'compiler-enabled state))
     (port-file-enabled (f-get-global 'port-file-enabled state))
     (warnings-as-errors nil))
    (pprogn
     (cond ((and (not (eq load-compiled-file :default))
                 (not (eq load-compiled-file nil))
                 (not (f-get-global 'compiler-enabled state)))
            (warning$ ctx "Compiled file"
                      "Ignoring value ~x0 supplied for include-book keyword ~
                       parameter :LOAD-COMPILED-FILE, treating it as ~x1 ~
                       instead, because of an earlier evaluation of ~x2; see ~
                       :DOC compilation."
                      load-compiled-file
                      nil
                      '(set-compiler-enabled nil state)))
           (t state))
     (er-let* ((dir-value
                (cond (dir (include-book-dir-with-chk soft ctx dir))
                      (t (value (cbd))))))
       (mv-let
         (full-book-string full-book-name directory-name familiar-name)
         (parse-book-name dir-value user-book-name ".lisp" ctx state)
         (er-progn
          (chk-input-object-file full-book-string ctx state)
          (chk-include-book-inputs load-compiled-file
                                   uncertified-okp
                                   defaxioms-okp
                                   skip-proofs-okp
                                   ctx state)
          (state-global-let*
           ((ignore-cert-files (or (f-get-global 'ignore-cert-files state)
                                   (and (eq uncertified-okp :ignore-certs)
                                        full-book-name))))
           (let* ((behalf-of-certify-flg
                   (not (null expansion-alist/cert-data)))
                  (load-compiled-file0 load-compiled-file)
                  (load-compiled-file (and (f-get-global 'compiler-enabled
                                                         state)
                                           load-compiled-file))
                  (cddr-event-form
                   (if (and event-form
                            (eq load-compiled-file0
                                load-compiled-file))
                       (cddr event-form)
                     (append
                      (if (not (eq load-compiled-file
                                   :default))
                          (list :load-compiled-file
                                load-compiled-file)
                        nil)
                      (if (not (eq uncertified-okp t))
                          (list :uncertified-okp
                                uncertified-okp)
                        nil)
                      (if (not (eq defaxioms-okp t))
                          (list :defaxioms-okp
                                defaxioms-okp)
                        nil)
                      (if (not (eq skip-proofs-okp t))
                          (list :skip-proofs-okp
                                skip-proofs-okp)
                        nil)))))
             (cond ((or behalf-of-certify-flg
                        #-acl2-loop-only *hcomp-book-ht*
                        (null load-compiled-file))

; So, *hcomp-book-ht* was previously bound by certify-book-fn or in the other
; case, below.

                    (include-book-fn1
                     user-book-name state load-compiled-file
                     expansion-alist/cert-data
                     uncertified-okp defaxioms-okp skip-proofs-okp
                     ttags
; The following were bound above:
                     ctx full-book-string full-book-name
                     directory-name familiar-name cddr-event-form))
                   (t
                    (let #+acl2-loop-only ()
                         #-acl2-loop-only
                         ((*hcomp-book-ht* (make-hash-table :test 'equal)))

; Since *hcomp-book-ht* is nil, we are in the process of evaluating a top-level
; call of include-book.  We create *hcomp-book-ht* and populate it with keys
; for that top-level book and all (recursively) included books; see the Essay
; on Hash Table Support for Compilation.

                         #-acl2-loop-only
                         (include-book-raw-top full-book-string full-book-name
                                               directory-name
                                               load-compiled-file dir ctx state)
                         (include-book-fn1
                          user-book-name state load-compiled-file
                          expansion-alist/cert-data
                          uncertified-okp defaxioms-okp skip-proofs-okp
                          ttags
; The following were bound above:
                          ctx full-book-string full-book-name
                          directory-name familiar-name
                          cddr-event-form)))))))))))))

(defun spontaneous-decertificationp1 (ibalist alist files)

; Ibalist is an include-book alist, while alist is the strip-cddrs of an
; include-book alist.  Thus, an entry in ibalist is of the form (full-book-name
; user-book-name familiar-name cert-annotations . book-hash), while an entry in
; alist is (familiar-name cert-annotations . book-hash).  We know, from
; context, that (subsetp-equal (strip-cddrs ibalist) alist) fails.  Thus, there
; are entries in ibalist that are not ``in'' alist, where ``in'' compares
; (familiar-name cert-annotations . book-hash) tuples.  We determine whether
; each such entry fails only because the book-hash in the ibalist is nil while
; that in a corresponding entry in the alist is non-nil.  If so, then the most
; likely explanation is that a concurrent process is recertifying certain books
; and deleted their .cert files.  We return the list of all files which have
; been decertified.

  (cond ((endp ibalist) files)
        (t (let* ((familiar-name1 (caddr (car ibalist)))
                  (cert-annotations1 (cadddr (car ibalist)))
                  (book-hash1 (cddddr (car ibalist)))
                  (temp (assoc-equal familiar-name1 alist))
                  (cert-annotations2 (cadr temp))
                  (book-hash2 (cddr temp)))
             (cond
              (temp
               (cond
                ((equal (cddr (car ibalist)) temp)

; This entry is identical to its mate in alist.  So we keep
; looking.
                 (spontaneous-decertificationp1 (cdr ibalist) alist files))
                ((and (or (null cert-annotations1)
                          (equal cert-annotations1 cert-annotations2))
                      (equal book-hash1 nil)
                      book-hash2)

; The full-book-name (car (car ibalist)) spontaneously decertified.
; So we collect it and keep looking.

                 (spontaneous-decertificationp1 (cdr ibalist) alist
                                                (cons (car (car ibalist))
                                                      files)))
                (t nil)))
              (t nil))))))

(defun spontaneous-decertificationp (alist1 alist2)

; We know that alist1 is not an include-book-alist-subset of alist2.
; We check whether this is precisely because some files which were
; certified in alist2 are not certified in alist1.  If so, we return
; the list of all such files.  But if we find any other kind of
; discrepancy, we return nil.

  (spontaneous-decertificationp1 alist1 (strip-cddrs alist2) nil))

(defun remove-duplicates-equal-from-end (lst acc)
  (cond ((endp lst) (reverse acc))
        ((member-equal (car lst) acc)
         (remove-duplicates-equal-from-end (cdr lst) acc))
        (t (remove-duplicates-equal-from-end (cdr lst) (cons (car lst) acc)))))

(defun include-book-alist-subsetp-failure-witnesses (alist1 strip-cddrs-alist2 acc)

; We accumulate into acc all members of alist1 that serve as counterexamples to
; (include-book-alist-subsetp alist1 alist2), where strip-cddrs-alist2 =
; (strip-cddrs alist2).

  (cond ((endp alist1) acc)
        (t (include-book-alist-subsetp-failure-witnesses
            (cdr alist1)
            strip-cddrs-alist2
            (if (member-equal (cddr (car alist1)) strip-cddrs-alist2)
                acc
              (cons (car alist1) acc))))))

; Essay on Guard Checking

; We bind the state global variable guard-checking-on to t in certify-book-fn
; and in include-book-fn (using state-global-let*), as well as in prove and
; puff-fn1.  We bind it to nil in pc-single-step-primitive.  We do not bind
; guard-checking-on in defconst-fn.  Here we explain these decisions.

; We prefer to bind guard-checking-on to a predetermined fixed value when
; certifying or including books.  Why?  Book certification is a logical act.
; :Set-guard-checking is intended to be extra-logical, giving the user control
; over evaluation in the interactive loop, and hence we do not want it to
; affect how books are processed, either during certification or during
; inclusion.

; So the question now is whether to bind guard-checking-on to t or to nil for
; book certification and for book inclusion.  (We reject :none and :all because
; they can be too inefficient.)  We want it to be the case that if a book is
; certified, then subsequently it can be included.  In particular, it would be
; unfortunate if certification is done in an environment with guard checking
; off, and then later we get a guard violation when including the book with
; guard checking on.  So we should bind guard-checking-on the same in
; certify-book as in include-book.

; We argue now for binding guard-checking-on to t in certify-book-fn (and
; hence, as argued above, in include-book-fn as well).  Consider this scenario
; brought to our attention by Eric Smith: one certifies a book with
; guard-checking-on bound to nil, but then later gets a guard violation when
; loading that book during a demo using LD (with the default value of t for
; guard-checking-on).  Horrors!  So we bind guard-checking-on to t in
; certify-book-fn, to match the default in the loop.

; We note that raw Lisp evaluation should never take place for the body of a
; defconst form (outside the boot-strap), because the raw Lisp definition of
; defconst avoids such evaluation when the name is already bound, which should
; be the case from prior evaluation of the defconst form in the ACL2 loop.
; Value-triple also is not evaluated in raw Lisp, where it is defined to return
; nil.

; We bind guard-checking-on to nil in prove, because proofs can use evaluation
; and such evaluation should be done in the logic, without regard to guards.

; It can be important to check guards during theory operations like
; union-theory.  For example, with guard checking off in Version_2.9, one gets
; a hard Lisp error upon evaluation of the following form.

; (in-theory (union-theories '((:rewrite no-such-rule))
;                            (current-theory 'ground-zero)))

; (Aside.  One does not get such an error in Version_2.8, because *1* functions
; checked guards of system functions regardless of the value of
; guard-checking-on; but we have abandoned that aggressive approach, relying
; instead on safe-mode.)  Our solution is to bind guard-checking-on to t in
; eval-theory-expr, which calls simple-translate-and-eval and hence causes the
; guards to be checked.

; Note that guard-checking-on is bound to nil in pc-single-step-primitive.  We
; no longer recall why, but we may as well preserve that binding.

(defun expansion-filename (file)

; We use a .lsp suffix instead of .lisp for benefit of the makefile system,
; which by default looks for .lisp files to certify.

; File can be either an ACL2 filename or an OS filename (see the Essay on
; Pathnames).  We add the ".lisp" suffix either way.  This could be problematic
; in the case that one adds the suffix to an ACL2 filename with this function,
; and then converts the result to an OS filename -- is that really the same as
; converting the ACL2 filename to an OS filename and then adding the suffix?
; We believe that yes, these are the same, since the conversion of a filename
; is presumably a matter of converting the individual bytes or characters, in
; order.

  (let ((len (length file)))
    (assert$ (equal (subseq file (- len 5) len) ".lisp")
             (concatenate 'string
                          (subseq file 0 (- len 5))
                          "@expansion.lsp"))))

#-acl2-loop-only
(defun write-*1*-defuns-to-expansion-file (compressed-cltl-command-stack chan
                                                                         state)

; This function is a variant of compile-uncompiled-*1*-defuns, suitable for
; writing *1* definitions to the expansion file.  The code here is considerably
; simpler than that of compile-uncompiled-*1*-defuns.  One key reason is that
; here we assume that print-controls and such are already set as part of
; writing the expansion file; another is that our use of the
; compressed-cltl-command-stack avoids the need to consider compilation for *1*
; functions of built-in functions.

  (let ((seen (make-hash-table :test 'eq))
        (wrld (w state))
        (defs nil))
    (dolist (cmd compressed-cltl-command-stack)
      (when (eq (car cmd) 'defuns)
        (let ((defun-mode (cadr cmd)))
          (dolist (def (cdddr cmd))
            (let ((*1*fn (*1*-symbol (car def))))
              (assert$
               (fboundp *1*fn) ; surely defined at expansion-file writing time
               (when (not (gethash *1*fn seen))
                 (setf (gethash *1*fn seen) t)
                 (push (cons 'defun
                             (oneify-cltl-code
                              defun-mode
                              def
                              (getpropc (car def) 'stobj-function nil wrld)
                              wrld))
                       defs))))))))
    (print-object$ (cons 'progn defs) chan state)))

(defconst *elided-defconst* 'elided-defconst)

(defun elided-defconst-form (ev index)
  `(defconst ,(cadr ev) ; name
; Since (,*elided-defconst* ,index) evaluates to (quote val) for the desired
; value, val, we take the cadr, since then evaluation of (cadr
; (,*elided-defconst* ,index)) produces the desired value.
     (cadr ,(list *elided-defconst* (list 'quote (cadr ev)) index))))

(mutual-recursion

(defun subst-by-position-eliding-defconst2 (ev index)

; Warning: Keep this in sync with hcomp-elided-defconst-alist2.

  (case (car ev)
    (defconst
      (if (defconst-form-to-elide ev)
          (elided-defconst-form ev index)
        ev))
    (progn
      (cons 'progn
            (subst-by-position-eliding-defconst2-lst (cdr ev) index)))
    (encapsulate
      (list* 'encapsulate
             (cadr ev)
             (subst-by-position-eliding-defconst2-lst (cddr ev) index)))
    ((record-expansion with-guard-checking)
     (subst-by-position-eliding-defconst2 (caddr ev) index))
    (skip-proofs
     (subst-by-position-eliding-defconst2 (cadr ev) index))
    ((with-output with-prover-step-limit)
     (subst-by-position-eliding-defconst2 (car (last ev)) index))
    (otherwise ev)))

(defun subst-by-position-eliding-defconst2-lst (lst index)
  (cond ((endp lst) nil)
        (t (cons (subst-by-position-eliding-defconst2 (car lst) index)
                 (subst-by-position-eliding-defconst2-lst (cdr lst) index)))))
)

(defun subst-by-position-eliding-defconst1 (alist lst index acc)

; See the comment in subst-by-position-eliding-defconst.

  (cond ((endp alist)
         (revappend acc lst))
        ((endp lst)
         (er hard 'subst-by-position-eliding-defconst1
             "Implementation error: lst is an atom, so unable to complete ~
              call ~x0."
             `(subst-by-position-eliding-defconst1
               ,alist ,lst ,index ,acc)))
        ((eql index (caar alist))
         (let ((ev (cdar alist)))
           (subst-by-position-eliding-defconst1
            (cdr alist) (cdr lst) (1+ index)
            (cons (subst-by-position-eliding-defconst2 ev index)
                  acc))))
        (t
         (subst-by-position-eliding-defconst1 alist (cdr lst) (1+ index)
                                              (cons (car lst) acc)))))


(defun subst-by-position-eliding-defconst (alist lst index)

; This function differs from subst-by-position only in that it elides defconst
; forms, as discussed in section "Appendix: Saving space by eliding certain
; defconst forms" of the Essay on Hash Table Support for Compilation.

  (cond (alist
         (cond ((< (caar alist) index)
                (er hard 'subst-by-position-eliding-defconst
                    "Implementation error: The alist in ~
                     subst-by-position-eliding-defconst must not start with ~
                     an index less than its index argument, so unable to ~
                     compute ~x0."
                    `(subst-by-position-eliding-defconst ,alist ,lst ,index)))
               (t (subst-by-position-eliding-defconst1 alist lst index nil))))
        (t ; optimize for common case
         lst)))

(defun write-expansion-file (portcullis-cmds declaim-list new-fns-exec
                                             compressed-cltl-command-stack
                                             expansion-filename expansion-alist
                                             pkg-names
                                             ev-lst known-package-alist
                                             ctx state)

; Expansion-filename is the expansion file for a certified book (or, a book
; whose certification is nearly complete) that has been through
; include-book-fn.  (We call set-current-package below instead of the
; corresponding f-put-global as a partial check that this inclusion has taken
; place.)  We write out that expansion file, instead causing an error if we
; cannot open it.

; The following issue came up when attempting to compile an expansion file with
; GCL that had been created with CCL.  (We don't officially support using more
; than one host Lisp on the same files, but it's convenient sometimes to do
; that anyhow.)  The community book in question was
; books/projects/legacy-defrstobj/typed-record-tests.lisp, and "classic" ACL2
; was used, not the hons version, ACL2(h).  The event that caused the trouble
; was this one:

;   (make-event
;    `(def-typed-record char
;       :elem-p        (characterp x)
;       :elem-list-p   (character-listp x)
;       :elem-fix      (character-fix x)
;       :elem-default  ,(code-char 0)
;       ;; avoid problems with common-lisp package
;       :in-package-of foo))

; In the expansion file, (code-char 0) was written by CCL as #\Null:
; write-expansion-file calls print-object$ (and print-objects, which calls
; print-object$), and print-object$ calls prin1, which prints "readably".  Now
; our ACL2 readtable can't handle #\Null, but we call compile-certified-file on
; the expansion file, and that calls acl2-compile-file, and that binds
; *readtable* to *reckless-acl2-readtable*.  But the latter binds #\ to the old
; character reader, which can handle #\Null in CCL, but not in GCL.

  #+acl2-loop-only
  (declare (ignore new-fns-exec compressed-cltl-command-stack pkg-names
                   known-package-alist))
  (with-output-object-channel-sharing
   ch expansion-filename
   (cond
    ((null ch)
     (er soft ctx
         "We cannot open expansion file ~s0 for output."
         expansion-filename))
    (t
     (with-print-defaults
      ((current-package "ACL2")
       (print-circle (f-get-global 'print-circle-files state))
       (print-readably t))
      (pprogn
       (io? event nil state
            (expansion-filename)
            (fms! "Note: Writing book expansion file, ~s0."
                  (list (cons #\0 expansion-filename))
                  (proofs-co state) state nil))

; Note: We replace the in-package form at the top of the original file, because
; we want to print in the ACL2 package.  See the Essay on Hash Table Support
; for Compilation.

       (print-object$ '(in-package "ACL2") ch state)

; The next forms introduce packages so that ensuing defparameter forms can be
; read in.  The form (maybe-introduce-empty-pkg-1 name) generates defpackage
; forms for name, which are no-ops when the packages already exist.  For GCL it
; seems important to put all the defpackage forms at the top of any file to
; compile, immediately after the initial in-package form; otherwise we have
; seen scary warnings in GCL 2.6.7.  So we lay down these defpackage forms
; first, and then we lay down maybe-introduce-empty-pkg-2 calls in order to
; tell ACL2 that any such packages not already known to ACL2 are acceptable,
; provided they have no imports.  (If they have imports then they must have
; been defined in raw Lisp, and ACL2 should complain.  They might even have
; been defined in raw Lisp if they do not have imports, of course, but there
; are limits to how hard we will work to protect the user who traffics in raw
; Lisp evaluation.)

       #-acl2-loop-only
       (let ((ans1 nil)
             (ans2 nil))
         (dolist (entry known-package-alist)
           (let ((pkg-name (package-entry-name entry)))
             (when (not (member-equal
                         pkg-name ; from initial known-package-alist
                         '("ACL2-USER" "ACL2-PC" "BIB"
                           "ACL2-INPUT-CHANNEL"
                           "ACL2-OUTPUT-CHANNEL"
                           "ACL2" "COMMON-LISP" "KEYWORD")))
               (push `(maybe-introduce-empty-pkg-1 ,pkg-name) ans1)
               (push `(maybe-introduce-empty-pkg-2 ,pkg-name) ans2))))
         (dolist (pkg-name pkg-names)

; To see why we need these forms, consider the following book.

; (in-package "ACL2")
; (local (include-book "arithmetic/equalities" :dir :system))
; (make-event (list 'defun (intern$ "FOO" "ACL2-ASG") '(x) 'x))

; Without these forms, we get a hard Lisp error when include-book attempts to
; load the compiled file, because *hcomp-fn-alist* is defined using the symbol
; acl2-asg::foo, which is in a package not yet known at the time of the load.

           (push `(maybe-introduce-empty-pkg-1 ,pkg-name) ans1)
           (push `(maybe-introduce-empty-pkg-2 ,pkg-name) ans2))
         (print-objects ans1 ch state)
         (print-objects ans2 ch state))
       #-acl2-loop-only
       (mv-let (fn-alist const-alist macro-alist)
               (hcomp-alists-from-hts)
               (pprogn (print-object$ `(setq *hcomp-fn-alist*
                                         ',fn-alist)
                                      ch state)
                       (print-object$ `(setq *hcomp-const-alist*
                                         ',const-alist)
                                      ch state)
                       (print-object$ `(setq *hcomp-macro-alist*
                                         ',macro-alist)
                                      ch state)))
       (print-object$ '(hcomp-init) ch state)
       (newline ch state)
       (cond (declaim-list
              (pprogn (princ$ ";;; Declaim forms:" ch state)
                      (newline ch state)
                      (princ$ (concatenate 'string "#+"
                                           (symbol-name
                                            (f-get-global 'host-lisp state)))
                              ch state)
                      (print-object$ (cons 'progn (reverse declaim-list))
                                     ch state)))
             (t (princ$ ";;; Note: There are no declaim forms to print." ch state)))

; The following would cause a guard violation if using fms with channel ch,
; since the file-type of the channel ch is :object, not :character.  This issue
; was ignored (perhaps not noticed) until work undertaken in July and August,
; 2023, that upgraded the symbol-class of fms! to be :common-lisp-compliant.
; With that change, books/system/check-system-guards.lisp failed to certify
; because of that guard violation.  However, there was already a princ$ call
; further below under #-acl2-loop-only, so following that precedent, we use
; format here conditioned by #-acl2-loop-only.  Some day we may install a more
; principle change.

       #-acl2-loop-only
       (progn (format
               (get-output-stream-from-channel ch)
               "~%;;; Printing ~s portcullis command~a followed by ~
                book contents,~%;;; with make-event expansions."
               (length portcullis-cmds)
               (if (cdr portcullis-cmds) "s" ""))
              state)

; We print a single progn for all top-level events in order to get maximum
; sharing with compact printing.

       (print-object$ (cons 'progn
                            (append portcullis-cmds
                                    (subst-by-position-eliding-defconst
                                     expansion-alist (cdr ev-lst) 1)))
                      ch state)
       (newline ch state)
       #-acl2-loop-only
       (progn (when new-fns-exec
                (princ ";;; *1* function definitions to compile:"
                       (get-output-stream-from-channel ch))

; No newline is needed here, as compile-uncompiled-*1*-defuns uses
; print-object$, which starts by printing a newline.

; We untrace functions before attempting any compilation, in case there is any
; inlining or other use of symbol-functions.  But first we save the traced
; symbol-functions, and then we restore them immediately afterwards.  We don't
; use untrace$ and trace$ because trace$ may require a trust tag that is no
; longer available, for example if (break-on-error) has been invoked.

                (let ((trace-specs (f-get-global 'trace-specs state))
                      retrace-alist)
                  (unwind-protect
                      (dolist (spec trace-specs)
                        (let* ((fn (car spec))
                               (*1*fn (*1*-symbol fn))
                               (old-fn (get fn 'acl2-trace-saved-fn))
                               (old-*1*fn (get *1*fn 'acl2-trace-saved-fn)))
                          (when old-fn
                            (push (cons fn (symbol-function fn))
                                  retrace-alist)
                            (setf (symbol-function fn)
                                  old-fn))
                          (when old-*1*fn
                            (push (cons *1*fn (symbol-function *1*fn))
                                  retrace-alist)
                            (setf (symbol-function *1*fn)
                                  old-*1*fn))))
                    (write-*1*-defuns-to-expansion-file
                     compressed-cltl-command-stack ch state))
                  (dolist (pair retrace-alist)
                    (let ((fn (car pair))
                          (val (cdr pair)))
                      (setf (symbol-function fn) val))))
                (newline ch state))
              state)
       (close-output-channel ch state)
       (value expansion-filename)))))))

(defun collect-ideal-user-defuns1 (tl wrld ans)
  (cond
   ((or (null tl)
        (and (eq (caar tl) 'command-landmark)
             (eq (cadar tl) 'global-value)
             (equal (access-command-tuple-form (cddar tl))
                    '(exit-boot-strap-mode))))
    ans)
   ((and (eq (caar tl) 'cltl-command)
         (eq (cadar tl) 'global-value)
         (equal (caddar tl) 'defuns))
    (collect-ideal-user-defuns1
     (cdr tl)
     wrld
     (cond
      ((null (cadr (cddar tl)))

 ; Defun-mode-flg = nil means encapsulate or :non-executable.  In this case we
 ; do not pick up the function, but that's OK because we don't care if it is
 ; executed efficiently.  Warning: If we decide to pick it up after all, then
 ; make sure that the symbol-class is not :program, since after Version_4.1 we
 ; allow non-executable :program mode functions.

       ans)
      ((eq (symbol-class (caar (cdddr (cddar tl))) wrld) :ideal)
       (append (strip-cars (cdddr (cddar tl))) ans))
      (t ans))))
   (t (collect-ideal-user-defuns1 (cdr tl) wrld ans))))

(defun collect-ideal-user-defuns (wrld)

; We scan wrld down to command 0 (but not into prehistory), collecting those
; fns which were (a) introduced with defun or defuns and (b) are :ideal.

  (collect-ideal-user-defuns1 wrld wrld nil))

(defun set-difference-eq-sorted (lst1 lst2 ans)

; Lst1 and lst2 are sorted by symbol<.  If ans is nil, then we return the
; difference of lst1 and lst2, sorted by symbol<.

  (cond ((null lst1) (reverse ans))
        ((null lst2) (revappend ans lst1))
        ((eq (car lst1) (car lst2))
         (set-difference-eq-sorted (cdr lst1) (cdr lst2) ans))
        ((symbol< (car lst1) (car lst2))
         (set-difference-eq-sorted (cdr lst1) lst2 (cons (car lst1) ans)))
        (t (set-difference-eq-sorted lst1 (cdr lst2) ans))))

(defun pkg-names0 (x base-kpa acc)
  (cond ((consp x)
         (pkg-names0
          (cdr x) base-kpa
          (pkg-names0 (car x) base-kpa acc)))
        ((and x ; optimization
              (symbolp x))
         (let ((name (symbol-package-name x)))
           (cond ((or (member-equal name acc)
                      (find-package-entry name base-kpa))
                  acc)
                 (t (cons name acc)))))
        (t acc)))

(defun hons-union-ordered-string-lists (x y)
  (cond ((null x) y)
        ((null y) x)
        ((hons-equal x y)
         x)
        ((hons-equal (car x) (car y))
         (hons (car x)
               (hons-union-ordered-string-lists (cdr x) (cdr y))))
        ((string< (car x) (car y))
         (hons (car x)
               (hons-union-ordered-string-lists (cdr x) y)))
        (t ; (string< (car y) (car x))
         (hons (car y)
               (hons-union-ordered-string-lists x (cdr y))))))

(defun pkg-names (x base-kpa)

; For an explanation of the point of this function, see the comment at the call
; of pkg-names in certify-book-fn.

; X is an object (for our application, an expansion-alist or cert-data) and
; base-kpa is the known-package-alists of the certification world.

; We return a list including package names of symbols supporting (the tree) x.
; We do *not* take any sort of transitive closure; that is, for the name of a
; package pkg1 in the returned list and the name of a package pkg2 for a symbol
; imported into pkg1, it does not follow that the name of pkg2 is in the
; returned list.  (Note: The transitive closure operation performed by
; new-defpkg-list will take care of this closure for us.)

  (cond
   ((null x) ; optimization
    nil)
   (t (merge-sort-lexorder (pkg-names0 x base-kpa nil)))))

(defun delete-names-from-kpa-rec (names kpa)
  (cond ((endp kpa)
         nil)
        ((member-equal (package-entry-name (car kpa)) names)
         (delete-names-from-kpa-rec names (cdr kpa)))
        (t
         (cons (car kpa)
               (delete-names-from-kpa-rec names (cdr kpa))))))

(defun delete-names-from-kpa (names kpa)
  (cond ((null names) kpa) ; optimization for common case
        (t (delete-names-from-kpa-rec names kpa))))

(defun print-certify-book-step-2 (ev-lst expansion-alist pcert0-file acl2x-file
                                         state)
  (io? event nil state
       (ev-lst expansion-alist pcert0-file acl2x-file)
       (fms "* Step 2:  There ~#0~[were no forms in the file. Why are you ~
             making such a silly book?~/was one form in the file.~/were ~n1 ~
             forms in the file.~]  We now attempt to establish that each ~
             form, whether local or non-local, is indeed an admissible ~
             embedded event form in the context of the previously admitted ~
             ones.~@2~%"
            (list (cons #\0 (zero-one-or-more ev-lst))
                  (cons #\1 (length ev-lst))
                  (cons #\2
                        (cond (expansion-alist
                               (msg "  Note that we are substituting ~n0 ~
                                     ~#1~[form~/forms~], as specified in ~
                                     file~#2~[~x2~/s ~&2~], for ~#1~[a ~
                                     corresponding top-level ~
                                     form~/corresponding top-level forms~] in ~
                                     the book."
                                    (length expansion-alist)
                                    expansion-alist
                                    (if pcert0-file
                                        (if acl2x-file
                                            (list pcert0-file acl2x-file)
                                          (list pcert0-file))
                                      (list acl2x-file))))
                              (t ""))))
            (proofs-co state) state nil)))

(defun print-certify-book-step-3 (index port-index port-non-localp state)
  (io? event nil state
       (index port-index port-non-localp)
       (cond
        (index
         (assert$
          (and (posp index)
               (null port-index))
          (fms "* Step 3:  That completes the admissibility check.  Each form ~
                read was an embedded event form and was admissible.  We now ~
                retract back to the ~#0~[initial world~/world created by ~
                admitting the first event~/world created by the first ~n1 ~
                events~]~#2~[~/ after the initial IN-PACKAGE form~] and try ~
                to include~#2~[~/ the remainder of~] the book; see :DOC ~
                local-incompatibility.~%"
               (list (cons #\0 (zero-one-or-more (1- index)))
                     (cons #\1 (1- index))
                     (cons #\2 (if (int= 1 index) 0 1)))
               (proofs-co state) state nil)))
        (port-index
         (fms "* Step 3:  That completes the admissibility check.  Each form ~
               read was an embedded event form and was admissible.  We now ~
               retract the world, back through the ~n0 command after the ~
               initial (boot-strap) world.~@1  Next we will try to execute the ~
               remainder of the events in the certification world, and ~
               finally we will try to include the book; see :DOC ~
               local-incompatibility.~%"
              (list (cons #\0 (list (1+ port-index)))
                    (cons #\1 (if port-non-localp
                                  (msg "  Note that the rollback is caused by ~
                                        evaluation of an event after relaxing ~
                                        guard-checking from its default of T.")
                                "")))
              (proofs-co state) state nil))
        ((eq (fast-cert-mode state) t)
         (fms "* Step 3:  That completes the admissibility check.  Each form ~
               read was an embedded event form and was admissible.  Fast-cert ~
               mode is active, so we skip the check for local ~
               incompatibilities.~%"
              nil (proofs-co state) state nil))
        (t
         (fms "* Step 3:  That completes the admissibility check.  Each form ~
               read was an embedded event form and was admissible.  No LOCAL ~
               or SET-GUARD-CHECKING forms make it necessary to check for ~
               local incompatibilities, so we skip that check.~%"
              nil (proofs-co state) state nil)))))

(defun print-certify-book-guards-warning
  (full-book-string new-bad-fns all-bad-fns k ctx state)
  (let* ((new-bad-fns
          (sort-symbol-listp
           new-bad-fns))
         (all-bad-fns
          (sort-symbol-listp
           all-bad-fns))
         (extra-bad-fns
          (set-difference-eq-sorted
           all-bad-fns
           new-bad-fns
           nil)))
    (warning$ ctx ("Guards")
              "~#1~[~/The book ~x0 defines the function~#2~[ ~&2, which has ~
               not had its~/s ~&2, which have not had their~] guards ~
               verified.  ~]~#3~[~/~#1~[For the book ~x0, its~/Moreover, this ~
               book's~] included sub-books ~#4~[~/and/or its certification ~
               world ~]define function~#5~[ ~&5, which has not had its~/s ~
               ~&5, which have not had their~] guards verified.  ~]See :DOC ~
               guards."
              full-book-string
              (if new-bad-fns 1 0)
              new-bad-fns
              (if extra-bad-fns 1 0)
              (if (eql k 0) 0 1)
              extra-bad-fns)))

(defun chk-certify-book-step-3 (post-alist2 post-alist1 ctx state)
  (cond
   ((not (include-book-alist-subsetp post-alist2 post-alist1))
    (let ((files (spontaneous-decertificationp post-alist2 post-alist1)))
      (cond
       (files
        (er soft ctx
            "During Step 3, we loaded the uncertified ~#0~[book ~&0.  This ~
             book was certified when we looked at it~/books ~&0. These books ~
             were certified when we looked at them~] in Step 2!  The most ~
             likely explanation is that some concurrent job, possibly by ~
             another user of your file system, is currently recertifying ~
             ~#0~[this book~/these books~] (or subbooks of ~#0~[it~/them~]).  ~
             That hypothetical job might have deleted the certificate files ~
             of the books in question, rendering ~#0~[this one~/these~] ~
             uncertified.  If this explanation seems likely, we recommend ~
             that you identify the other job and wait until it has ~
             successfully completed."
            files))
       (t
        (er soft ctx
            "During Step 3, we loaded different books than were loaded by ~
             Step 2!  Sometimes this happens when the meaning of ``:dir ~
             :system'' for include-book has changed, usually because some ~
             included books were previously certified with an ACL2 image ~
             whose filename differs from that of the current ACL2 image.  ~
             Here are the tuples produced by Step 3 of the form ~X04 whose ~
             CDDRs are not in the list of tuples produced by Step ~
             2:~|~%~X14~|~%Perhaps some other user of your file system was ~
             editing the books during our Step 3? You might think that some ~
             other job is recertifying the books (or subbooks) and has ~
             deleted the certificate files, rendering uncertified some of the ~
             books needed here.  But more has happened!  Some file has ~
             changed (as indicated above)!~%~%DETAILS.  Here is the ~
             include-book-alist as of the end of Step 2:~%~X24.~|~%And here ~
             is the alist as of the end of Step 3:~%~X34.~|~%Frequently, the ~
             former has more entries than the latter because the former ~
             includes LOCAL books. So compare corresponding entries, focusing ~
             on those in the latter.  Each entry is of the form (name1 name2 ~
             name3 alist . book-hash). Name1 is the full name, name2 is the ~
             name as written in an include-book event, and name3 is the ~
             ``familiar'' name of the file. The alist indicates the presence ~
             or absence of problematic forms in the file, such as DEFAXIOM ~
             events.  For example, (:AXIOMSP . T) means there were defaxiom ~
             events; (:AXIOMSP . NIL) -- which actually prints as (:AXIOMSP) ~
             -- means there were no defaxiom events. Finally, book-hash is ~
             either an integer checksum based on the contents of the file at ~
             the time it was certified, an alist indicating the size and ~
             write-date of the book, or nil to indicate that the file is not ~
             certified.  Note that if the book-hash is nil, the entry prints ~
             as (name1 name2 name3 alist).  Go figure."
            '(:full-book-name
              :user-book-name
              :familiar-name
              :cert-annotations
              . :book-hash)
            (include-book-alist-subsetp-failure-witnesses
             post-alist2
             (strip-cddrs post-alist1)
             nil)
            post-alist1
            post-alist2
            nil)))))
   (t (value nil))))

(defun print-certify-book-step-4 (full-book-string cert-op state)
  (io? event nil state
       (full-book-string cert-op)
       (fms "* Step 4:  Write the certificate for ~x0 in ~x1.~%"
            (list
             (cons #\0 full-book-string)
             (cons #\1
                   (convert-book-string-to-cert full-book-string cert-op)))
            (proofs-co state) state nil)))

(defun print-certify-book-step-5 (full-book-string state)
  (io? event nil state
       (full-book-string)
       (fms "* Step 5:  Compile the functions defined in ~x0.~%"
            (list (cons #\0 full-book-string))
            (proofs-co state) state nil)))

(defun hcomp-build-from-state (cltl-command-stack state)
  #+acl2-loop-only
  (declare (ignore cltl-command-stack))
  #+acl2-loop-only
  (read-acl2-oracle state)
  #-acl2-loop-only
  (hcomp-build-from-state-raw (reverse cltl-command-stack) state))

; Essay on .acl2x Files (Double Certification)

; Sometimes make-event expansion requires a trust tag, but the final event does
; not, in which case we may want a "clean" certificate that does not depend on
; a trust tag.  For example, a make-event form might call an external tool to
; generate an ordinary ACL2 event.  Certify-book solves this problem by
; supporting a form of "double certification" that can avoid putting trust tags
; into the certificate.  This works by saving the expansion-alist from a first
; certification of foo.lisp into file foo.acl2x, and then certifying in a way
; that first reads foo.acl2x to avoid redoing make-event expansions, thus
; perhaps avoiding the need for trust tags.  One could even certify on a
; separate machine first in order to generate foo.acl2x, for added security.

; Key to the implementation of this ``double certification'' is a new state
; global, write-acl2x, which is set in order to enable writing of the .acl2x
; file.  Also, a new certify-book keyword argument, :ttagsx, overrides :ttags
; if write-acl2x is true.  So the flow is as follows, where a single
; certify-book command is used in both certifications, with :ttagsx specifying
; the ttags used in the first certification and :ttags specifying the ttags
; used in the second certification (perhaps nil).
;
; First certification: (set-write-acl2x t state) and certify, writing out
; foo.acl2x.  Second certification: Replace forms as per foo.acl2x; write out
; foo.cert.

; Why do we use a state global, rather than adding a keyword option to
; certify-book?  The reason is that it's easier this way to provide makefile
; support: the same .acl2 file can be used for each of the two certifications
; if the makefile sends an extra set-write-acl2x form before the first
; certification.  (And, that is what is done in community books file
; books/Makefile-generic.)

; Note that include-book is not affected by this proposal, because foo.acl2x is
; not consulted: its effect is already recorded in the .cert file produced by
; the second certify-book call.  However, after that certification, the
; certificate is not polluted by ttags that were needed only for make-event
; expansion (assuming :check-expansion has its default value of nil in each
; case).

; Some details:

; - If write-acl2x has value t, then we overwrite an existing .acl2x file.  (If
;   there is demand we could cause an error instead; maybe we'll support value
;   :overwrite for that.  But we don't have any protection against overwriting
;   .cert files, so we'll start by not providing any for .acl2x files, either.)
;   If write-acl2x has value nil, then certify-book will use the .acl2x file if
;   it exists and is not older than the .lisp file; but it will never insist on
;   a .acl2x file (though the Makefile could do that).  We could consider
;   adding an argument to certify-book that insists on having an up-to-date
;   .acl2x file.

; - If write-acl2x has value t, we exit as soon as the .acl2x file is written.
;   Not only does this avoid computation necessary for writing a .cert file,
;   but also it avoids potential confusion with makefiles, so that presence of
;   a .cert file indicates that certification is truly complete.

; - When foo.acl2x exists and write-acl2x has value nil, we check that the form
;   read is suitable input to subst-by-position: an alist with increasing posp
;   keys, whose last key does not exceed the number of events to process.

; - Consider the input expansion-alist used by the second certify-book call,
;   taken from the .acl2x file (to substitute for top-level forms in the book),
;   and consider an arbitrary entry (index . form) from that input
;   expansion-alist such that index doesn't appear in the generated
;   expansion-alist written to the .cert file.  Before writing that generated
;   expansion-alist to the .cert file, we first add every such (index . form)
;   to the generated expansion-alist, to make complete the recording of all
;   replacements of top-level forms from the source book.  Note that in this
;   case form is not subject to make-event expansion, or else index would have
;   been included already in the generated expansion-alist.

; - Note that one could create the .acl2x file manually to contain any forms
;   one likes, to be processed in place of forms in the source book.  There is
;   no problem with that.

; - The same use of *print-circle* will be made in writing out the .acl2x file
;   as is used when writing the :expansion-alist to the .cert file.

; One might think that one would have to incorporate somehow the checksum of
; the .acl2x file.  But the logical content of the certified book depends only
; on the .lisp file and the expansion-alist recorded in the .cert file, not on
; the .acl2x file (which was only used to generate that recorded
; expansion-alist).  We already have a mechanism to check those: in particular,
; chk-raise-portcullis (called by chk-certificate-file1) checks the checksum of
; the certificate object against the final value in the .cert file.

; Makefile support is available; see community books file
; books/Makefile-generic.

(defproxy acl2x-expansion-alist (* state)

; We use defproxy for now because state-p is still in :program mode; a
; partial-encapsulate comes later in the boot-strap (see
; boot-strap-pass-2-a.lisp).

; Users are welcome to attach their own function to acl2x-expansion-alist,
; because it is only called (by write-acl2x-file) to write out a .acl2x file,
; not to write out a .cert file.  We pass in state because some users might
; want to read from the state, for example, obtaining values of state globals.
; Indeed, for this reason, Jared Davis and Sol Swords requested the addition of
; state as a parameter.

  => *)

(defun hons-copy-with-state (x state)
  (declare (xargs :guard (state-p state)))
  (declare (ignore state))
  (hons-copy x))

(defun identity-with-state (x state)
  (declare (xargs :guard (state-p state)))
  (declare (ignore state))
  x)

(defattach (acl2x-expansion-alist
; User-modifiable; see comment in the defstub just above.

; At one time we used hons-copy-with-state here, but we are concerned that this
; will interfere with fast-alists.  See the Remark on Fast-alists in
; install-for-add-trip-include-book.

            identity-with-state)
  :skip-checks t)

(defun write-acl2x-file (expansion-alist acl2x-file ctx state)
  (with-output-object-channel-sharing
   ch acl2x-file
   (cond
    ((null ch)
     (er soft ctx
         "We cannot open file ~x0 for output."
         acl2x-file))
    (t (with-print-defaults
        ((current-package "ACL2")
         (print-circle (f-get-global 'print-circle-files state))
         (print-readably t))
        (pprogn
         (io? event nil state
              (acl2x-file)
              (fms "* Step 3: Writing file ~x0 and exiting certify-book.~|"
                   (list (cons #\0 acl2x-file))
                   (proofs-co state) state nil))
         (print-object$ (acl2x-expansion-alist expansion-alist state) ch state)
         (close-output-channel ch state)
         (value acl2x-file)))))))

(defun merge-into-expansion-alist1 (acl2x-expansion-alist
                                    computed-expansion-alist
                                    acc)
  (declare (xargs :measure (+ (len acl2x-expansion-alist)
                              (len computed-expansion-alist))))
  (cond ((endp acl2x-expansion-alist)
         (revappend acc computed-expansion-alist))
        ((endp computed-expansion-alist)
         (revappend acc acl2x-expansion-alist))
        ((eql (caar acl2x-expansion-alist)
              (caar computed-expansion-alist))
         (merge-into-expansion-alist1 (cdr acl2x-expansion-alist)
                                      (cdr computed-expansion-alist)
                                      (cons (car computed-expansion-alist)
                                            acc)))
        ((< (caar acl2x-expansion-alist)
            (caar computed-expansion-alist))
         (merge-into-expansion-alist1 (cdr acl2x-expansion-alist)
                                      computed-expansion-alist
                                      (cons (car acl2x-expansion-alist)
                                            acc)))
        (t ; (> (caar acl2x-expansion-alist) (caar computed-expansion-alist))
         (merge-into-expansion-alist1 acl2x-expansion-alist
                                      (cdr computed-expansion-alist)
                                      (cons (car computed-expansion-alist)
                                            acc)))))

(defun acl2x-alistp-domains-subsetp (x y)

; WARNING: each of x and y should be an acl2x-alistp (for suitable lengths).

  (cond ((null x) t)
        ((endp y) nil)
        ((eql (caar x) (caar y))
         (acl2x-alistp-domains-subsetp (cdr x) (cdr y)))
        ((< (caar x) (caar y))
         nil)
        (t ; (> (caar x) (caar y))
         (acl2x-alistp-domains-subsetp x (cdr y)))))

(defun merge-into-expansion-alist (acl2x-expansion-alist
                                   computed-expansion-alist)

; Note: Computed expansion-alist can be a value for the :pcert-info field of a
; cert-obj that represents the empty expansion-alist (:unproved or :proved).

; Each argument is an expansion-alist, i.e., an alist whose keys are increasing
; positive integers (see acl2x-alistp).  We return the expansion-alist whose
; domain is the union of the domains of the two inputs, mapping each index to
; its value in computed-expansion-alist if the index keys into that alist, and
; otherwise to its value in acl2x-expansion-alist.

; We optimize for the common case that every key of acl2x-expansion-alist is a
; key of computed-expansion-alist.

; See the Essay on .acl2x Files (Double Certification).

  (cond ((atom computed-expansion-alist) ; see comment above
         acl2x-expansion-alist)
        ((acl2x-alistp-domains-subsetp acl2x-expansion-alist
                                       computed-expansion-alist)
         computed-expansion-alist)
        (t (merge-into-expansion-alist1 acl2x-expansion-alist
                                        computed-expansion-alist
                                        nil))))

(defun restrict-expansion-alist (index expansion-alist)

; Return the subsequence of expansion-alist that eliminates all indices smaller
; than index.  It is assumed that expansion-alist has numeric keys in ascending
; order.

  (cond ((endp expansion-alist)
         nil)
        ((< (caar expansion-alist) index)
         (restrict-expansion-alist index (cdr expansion-alist)))
        (t expansion-alist)))

(defun elide-locals-from-expansion-alist (alist acc)
  (cond ((endp alist) (reverse acc))
        (t (elide-locals-from-expansion-alist
            (cdr alist)
            (cons (cons (caar alist)
                        (elide-locals (cdar alist)))
                  acc)))))

(defun write-port-file (full-book-string cmds ctx state)
  (let ((port-file (convert-book-string-to-port full-book-string)))
    (with-output-object-channel-sharing
     ch port-file
     (cond
      ((null ch)
       (er soft ctx
           "We cannot open file ~x0 for output."
           port-file))
      (t (pprogn
          (io? event nil state
               (port-file)
               (fms! "Note: Writing .port file, ~s0.~|"
                     (list (cons #\0 port-file))
                     (proofs-co state) state nil))
          (with-print-defaults
           ((current-package "ACL2")
            (print-circle (f-get-global 'print-circle-files state))
            (print-readably t))
           (pprogn
            (print-object$ '(in-package "ACL2") ch state)
            (print-objects

; We could apply hons-copy to cmds here, but we don't.  See the
; Remark on Fast-alists in install-for-add-trip-include-book.

             cmds ch state)
            (close-output-channel ch state)
            (value port-file)))))))))

(defmacro save-parallelism-settings (form)
  #-acl2-par
  form
  #+acl2-par
  `(state-global-let*
    ((waterfall-parallelism (f-get-global 'waterfall-parallelism state))
     (waterfall-printing (f-get-global 'waterfall-printing state))
     (total-parallelism-work-limit
      (f-get-global 'total-parallelism-work-limit state))
     (total-parallelism-work-limit-error
      (f-get-global 'total-parallelism-work-limit-error state)))
    ,form))

(defun include-book-alist-equal-modulo-local (old-post-alist new-post-alist)

; This check is a stricter one than is done by include-book-alist-subsetp.  It
; is appropriate for the Convert procedure of provisional certification, where
; old-post-alist comes from the .pcert0 file and new-post-alist results from
; the proof pass of the Convert procedure, since there is no reason for those
; two alists to differ (other than the fact that some members of the old
; post-alist were marked as local at the end of the include-book pass of the
; Pcertify procedure).

  (cond ((atom old-post-alist) (atom new-post-alist))
        ((atom new-post-alist) nil)
        ((and (consp (car old-post-alist))
              (eq (car (car old-post-alist)) 'local))
         (and (equal (cadr (car old-post-alist)) (car new-post-alist))
              (include-book-alist-equal-modulo-local (cdr old-post-alist)
                                                     (cdr new-post-alist))))
        ((equal (car old-post-alist) (car new-post-alist))
         (include-book-alist-equal-modulo-local (cdr old-post-alist)
                                                (cdr new-post-alist)))
        (t nil)))

(defun copy-object-channel-until-marker (marker ch-from ch-to state)
  (mv-let (eofp obj state)
          (read-object ch-from state)
          (cond ((or eofp
                     (eq obj marker))
                 state)
                (t (pprogn (print-object$ obj ch-to state)
                           (copy-object-channel-until-marker
                            marker ch-from ch-to state))))))

(defun copy-pcert0-to-pcert1 (from to ctx state)

; Warning: The use of with-output-object-channel-sharing and
; with-print-defaults below should be kept in sync with analogous usage in
; make-certificate-file1.

  (mv-let (ch-from state)
          (open-input-channel from :object state)
          (cond ((null ch-from)
                 (er soft ctx
                     "Unable to open file ~x0 for input (to copy to file ~x1)."
                     from to))
                (t (with-output-object-channel-sharing
                    ch-to to
                    (with-print-defaults
                     ((current-package "ACL2")
                      (print-circle (f-get-global 'print-circle-files state))
                      (print-readably t))
                     (cond ((null ch-to)
                            (pprogn
                             (close-input-channel ch-from state)
                             (er soft ctx
                                 "Unable to open file ~x0 for output (to copy ~
                                  into from file ~x1)."
                                 to from)))
                           (t (pprogn (copy-object-channel-until-marker
                                       :pcert-info
                                       ch-from ch-to state)
                                      (close-input-channel ch-from state)
                                      (close-output-channel ch-to state)
                                      (value :invisible))))))))))

(defun touch? (filename old-filename ctx state)

; Filename must exist and be at least as recent as old-filename, which must
; also exist in order to touch filename -- with one exception: if old-filename
; is nil, then we unconditionally touch filename.

; The present implementation uses the Unix/Linux utility, "touch".  Windows
; environments might or might not have this utility.  If not, then a clean
; error should occur.  It should be easy enough to create Windows-only code for
; this function, for example that copies filename to a temporary, deletes
; filename, and then moves the temporary to filename.

; Note: We should perhaps either require that the input filenames are as
; expected for the underlying OS, or else convert them with
; pathname-unix-to-os.  But we see (March 2012) that file-write-date$ does not
; take care of this issue.  So we will defer consideration of that issue here,
; especially since touch? already requires the Unix "touch" utility.

  (cond
   ((null old-filename)
    (value (sys-call "touch" (list filename))))
   (t (mv-let
        (old-filename-date state)
        (file-write-date$ old-filename state)
        (mv-let
          (filename-date state)
          (file-write-date$ filename state)
          (cond ((and old-filename-date
                      filename-date
                      (<= old-filename-date filename-date))
                 (prog2$ (sys-call "touch" (list filename))
                         (mv-let (status state)
                           (sys-call-status state)
                           (cond ((zerop status)
                                  (value nil))
                                 (t (er soft ctx
                                        "Obtained non-zero exit status ~x0 ~
                                         when attempting to touch file ~x0 ."
                                        status filename))))))
                (t (value nil))))))))

(defun convert-book-string-to-compiled (full-book-string state)

; The given full-book-string can either be a Unix-style or an OS-style pathname.

  (concatenate 'string
               (remove-lisp-suffix full-book-string nil)
               (f-get-global 'compiled-file-extension state)))

(defun certify-book-finish-convert (new-post-alist old-post-alist
                                                   full-book-string ctx state)

; Here we check that the post-alists correspond, as explained in the error
; message below.  See also cert-obj-for-convert for a check on the pre-alists
; and portcullis commands and certify-book-fn for a check on the
; expansion-alists.

  (cond ((include-book-alist-equal-modulo-local old-post-alist new-post-alist)
         (let ((pcert0-name (convert-book-string-to-cert full-book-string
                                                         :create-pcert))
               (pcert1-name (convert-book-string-to-cert full-book-string
                                                         :convert-pcert))
               (compiled-name (convert-book-string-to-compiled
                               full-book-string state)))
           (er-progn (copy-pcert0-to-pcert1 pcert0-name pcert1-name ctx state)

; Arrange that compiled file is not older than new certificate file.

                     (touch? compiled-name pcert0-name ctx state)
                     (value pcert1-name))))
        (t (er soft ctx
               "Two sequences of included books unexpectedly differ: one from ~
                the first pass of the Pcertify procedure, and one at the end ~
                of the Convert procedure.  Here is the include-book-alist as ~
                of the end of the first pass of the Pcertify ~
                procedure:~%~X02.~|~%And here is the include-book-alist at ~
                the end of Convert procedure:~%~X12."
               old-post-alist
               new-post-alist
               nil))))

#-acl2-loop-only
(defun delete-cert-files (full-book-string)
  (loop for cert-op in '(:create-pcert :convert-pcert t)
        do
        (let ((cert-file
               (pathname-unix-to-os
                (convert-book-string-to-cert full-book-string cert-op)
                *the-live-state*)))
          (when (probe-file cert-file)
            (delete-file cert-file)))))

(defun include-book-alist-uncertified-books (alist acc ctx wrld state)

; Alist is a post-alist from a certificate file, which was constructed from the
; "proof" pass of certify-book, even if proofs were actually skipped in the
; Pcertify step of provisional certification.  We use that alist to do a
; lightweight check for uncertified books, collecting all that we find.  That
; check is simply that for each entry in the alist, the included sub-book from
; that entry (even if locally included) has a .cert file with a write date at
; least as recent as that sub-book.

; It is clear by induction on the tree of books that if no uncertified book is
; found this way, then assuming that all .cert files were created by ACL2 in
; the proper way, all books in the alist are indeed certified.

  (cond ((endp alist) (value acc))
        (t (let* ((entry0 (car alist))
                  (entry (if (eq (car entry0) 'local)
                             (cadr entry0)
                           entry0))
                  (full-book-string (book-name-to-filename (car entry) wrld
                                                           ctx))
                  (cert-name (convert-book-string-to-cert full-book-string t)))
             (mv-let
              (book-date state)
              (file-write-date$ full-book-string state)
              (mv-let
               (cert-date state)
               (file-write-date$ cert-name state)
               (include-book-alist-uncertified-books
                (cdr alist)
                (cond ((and book-date
                            cert-date
                            (<= book-date cert-date))
                       acc)
                      (t (cons full-book-string acc)))
                ctx wrld state)))))))

(defun count-forms-in-channel (ch state n)
  (mv-let (eofp state)
          (read-object-suppress ch state)
          (cond (eofp (mv n state))
                (t (count-forms-in-channel ch state (1+ n))))))

(defun skip-forms-in-channel (n ch state)
  (cond ((zp n) (mv nil state))
        (t (mv-let (eofp state)
                   (read-object-suppress ch state)
                   (cond (eofp (mv eofp state))
                         (t (skip-forms-in-channel (1- n) ch state)))))))

(defun post-alist-from-pcert1-1 (n first-try-p pcert1-file msg ctx state)

; The post-alist is at zero-based position n or, if first-try-p is true,
; position n-2.

  (mv-let (chan state)
    (open-input-channel pcert1-file :object state)
    (cond
     ((null chan)
      (er soft ctx "~@0" msg))
     (t
      (mv-let
        (eofp state)
        (skip-forms-in-channel n chan state)
        (cond
         (eofp ; How can this be?  We just read n forms!
          (pprogn
           (close-input-channel chan state)
           (er soft ctx
               "Implementation error: Unexpected end of file, reading ~x0 ~
                forms from file ~x1.  Please contact the ACL2 implementors."
               n pcert1-file)))
         (t
          (mv-let
            (eofp post-alist state)
            (read-object chan state)
            (cond
             (eofp
              (er soft ctx
                  "Implementation error: Unexpected end of file, reading ~x0 ~
                   forms and then one more form from file ~x1.  Please ~
                   contact the ACL2 implementors."
                  n pcert1-file))
             ((eq post-alist :PCERT-INFO) ; then try again
              (pprogn
               (close-input-channel chan state)
               (cond
                (first-try-p
                 (post-alist-from-pcert1-1 (- n 2) nil pcert1-file msg ctx state))
                (t (er soft ctx
                       "Implementation error: Unexpectedly we appear to have ~
                        two occurrences of :PCERT-INFO at the top level of ~
                        file ~x0, at positions ~x1 and ~x2."
                       pcert1-file (+ n 2) n)))))
             (t (pprogn (close-input-channel chan state)
                        (cond ((include-book-alistp post-alist t)
                               (value post-alist))
                              (t (er soft ctx
                                     "Ill-formed post-alist encountered in ~
                                      file ~x0:~|~x1"
                                     pcert1-file post-alist))))))))))))))

(defun post-alist-from-pcert1 (pcert1-file msg ctx state)
  (mv-let
   (chan state)
   (open-input-channel pcert1-file :object state)
   (cond
    ((null chan)
     (er soft ctx "~@0" msg))
    (t
     (mv-let
      (len state)
      (count-forms-in-channel chan state 0)
      (pprogn
       (close-input-channel chan state)
       (assert$
        (<= 2 len) ; len should even be at least 7
        (post-alist-from-pcert1-1 (- len 2) t pcert1-file msg ctx state))))))))

(defun certificate-post-alist (pcert1-file cert-file full-book-name ctx state)
  (er-let* ((post-alist
             (post-alist-from-pcert1
              pcert1-file
              (msg "Unable to open file ~x0 for input, hence cannot complete ~
                    its renaming to ~x1."
                   pcert1-file cert-file)
              ctx state)))
           (cond ((equal (caar post-alist) full-book-name)
                  (value post-alist))
                 (t (er soft ctx
                        "Ill-formed post-alist encountered: expected its caar ~
                         to be the full-book-name ~x0, but the post-alist ~
                         encountered was ~x1."
                        full-book-name post-alist)))))

(defun certify-book-finish-complete (full-book-string full-book-name ctx state)

; Wart: Perhaps we should convert compiled-file and expansion-file to OS-style
; pathnames in some places below, as for some other files.  But we discovered
; this issue just before the Version_5.0 release, so we prefer not to do such a
; thing at this point.

  (let ((pcert0-file
         (convert-book-string-to-cert full-book-string :create-pcert))
        (pcert1-file
         (convert-book-string-to-cert full-book-string :convert-pcert))
        (cert-file
         (convert-book-string-to-cert full-book-string t))
        (compiled-file
         (convert-book-string-to-compiled full-book-string state))
        (expansion-file
         (expansion-filename full-book-string)))
    (er-let* ((post-alist
               (certificate-post-alist pcert1-file cert-file full-book-name ctx
                                       state))
              (uncertified-books
               (include-book-alist-uncertified-books
                (cdr post-alist) ; car is for full-book-name
                nil              ; accumulator
                ctx (w state) state)))
      (cond
       (uncertified-books
        (er soft ctx
            "Unable to complete the renaming of ~x0 to ~x1, because ~
             ~#2~[~/each of ~]the following included book~#2~[~/s~] does not ~
             have a .cert file that is at least as recent as that included ~
             book: ~&2."
            pcert1-file
            cert-file
            uncertified-books))
       (t #-acl2-loop-only
          (let ((pcert1-file-os (pathname-unix-to-os pcert1-file state))
                (cert-file-os (pathname-unix-to-os cert-file state)))
            (when (probe-file cert-file-os)
              (delete-file cert-file-os))
            (rename-file pcert1-file-os cert-file-os))
          (pprogn
           (fms "Note: Renaming file ~x0 to ~x1.~|"
                (list (cons #\0 pcert1-file)
                      (cons #\1 cert-file))
                (standard-co state) state nil)
           (er-progn
            (touch? cert-file pcert0-file ctx state)
            (touch? compiled-file pcert0-file ctx state)
            (touch? expansion-file pcert0-file ctx state)
            (value cert-file))))))))

(defun expansion-alist-conflict (acl2x-expansion-alist
                                 elided-expansion-alist)

; Returns (mv bad-entry expected), where bad-entry is an entry in
; acl2x-expansion-alist that, when locally elided, does not correspond to an
; entry in elided-expansion-alist, either because its index does not exist in
; elided-expansion-alist -- in which case expected is nil -- or because the
; corresponding entry (i.e., with same index) in elided-expansion-alist differs
; from its local elision -- in which case expected is that corresponding entry.

  (cond ((endp acl2x-expansion-alist) (mv nil nil))
        ((endp elided-expansion-alist)
         (mv (car acl2x-expansion-alist) nil))
        ((< (caar acl2x-expansion-alist)
            (caar elided-expansion-alist))
         (mv (car acl2x-expansion-alist) nil))
        ((eql (caar acl2x-expansion-alist)
              (caar elided-expansion-alist))
         (cond ((equal (elide-locals (cdar acl2x-expansion-alist))
                       (cdar elided-expansion-alist))
                (expansion-alist-conflict (cdr acl2x-expansion-alist)
                                          (cdr elided-expansion-alist)))
               (t (mv (car acl2x-expansion-alist)
                      (car elided-expansion-alist)))))
        (t ; (< (caar elided-expansion-alist) (caar acl2x-expansion-alist))
         (expansion-alist-conflict (cdr acl2x-expansion-alist)
                                   elided-expansion-alist))))

(defun symbol-package-name-set (syms acc)
  (declare (xargs :guard (and (symbol-listp syms)
                              (true-listp acc))))
  (cond ((endp syms) acc)
        (t (symbol-package-name-set
            (cdr syms)
            (add-to-set-equal (symbol-package-name (car syms))
                              acc)))))

(defun names-of-symbols-in-package (syms package acc)
  (declare (xargs :guard (symbol-listp syms)))
  (cond ((endp syms) acc)
        (t (names-of-symbols-in-package
            (cdr syms)
            package
            (if (equal (symbol-package-name (car syms))
                       package)
                (cons (symbol-name (car syms)) acc)
              acc)))))

(defun symbol-list-to-package-alist1 (syms packages acc)
  (declare (xargs :guard (and (symbol-listp syms)
                              (true-listp packages)
                              (alistp acc))))
  (cond ((endp packages) acc)
        (t (symbol-list-to-package-alist1
            syms
            (cdr packages)
            (acons (car packages)
                   (names-of-symbols-in-package syms (car packages) nil)
                   acc)))))

(defun symbol-list-to-package-alist (syms)

; To verify guards:

; (defthm true-listp-symbol-package-name-set
;   (equal (true-listp (symbol-package-name-set syms acc))
;          (true-listp acc)))

  (declare (xargs :guard (symbol-listp syms)))
  (symbol-list-to-package-alist1 syms
                                 (symbol-package-name-set syms nil)
                                 nil))

(defun bookdata-alist1 (full-book-name collect-p trips port-pkgs
                                       port-books books
                                       port-consts consts
                                       port-fns fns
                                       port-labels labels
                                       port-macros macros
                                       port-stobjs stobjs
                                       port-theories theories
                                       port-thms thms)

; See maybe-write-bookdata.

  (cond
   ((endp trips)
    (list :pkgs          port-pkgs
          :port-books    port-books
          :books         books
          :port-consts   (symbol-list-to-package-alist port-consts)
          :consts        (symbol-list-to-package-alist consts)
          :port-fns      (symbol-list-to-package-alist port-fns)
          :fns           (symbol-list-to-package-alist fns)
          :port-labels   (symbol-list-to-package-alist port-labels)
          :labels        (symbol-list-to-package-alist labels)
          :port-macros   (symbol-list-to-package-alist port-macros)
          :macros        (symbol-list-to-package-alist macros)
          :port-stobjs   (symbol-list-to-package-alist port-stobjs)
          :stobjs        (symbol-list-to-package-alist stobjs)
          :port-theories (symbol-list-to-package-alist port-theories)
          :theories      (symbol-list-to-package-alist theories)
          :port-thms     (symbol-list-to-package-alist port-thms)
          :thms          (symbol-list-to-package-alist thms)))
   (t
    (let ((trip (car trips)))
      (cond
       ((and (eq (car trip) 'INCLUDE-BOOK-PATH)
             (eq (cadr trip) 'GLOBAL-VALUE))
        (bookdata-alist1
         full-book-name
         (cond ((null (cddr trip))
                'port)
               (t (equal (car (cddr trip))
                         full-book-name)))
         (cdr trips)
         port-pkgs
         (cond ((and (eq collect-p 'port)
                     (cddr trip)
                     (not (equal (car (cddr trip))
                                 full-book-name)))
                (cons (car (cddr trip))
                      port-books))
               (t port-books))
         (cond ((and (eq collect-p t)
                     (cddr trip))
                (assert$ ; collect-p = t, so we are already in full-book-name
                 (not (equal (car (cddr trip))
                             full-book-name))
                 (cons (car (cddr trip))
                       books)))
               (t books))
         port-consts consts
         port-fns fns
         port-labels labels
         port-macros macros
         port-stobjs stobjs
         port-theories theories
         port-thms thms))
       ((not collect-p)
        (bookdata-alist1
         full-book-name nil (cdr trips) port-pkgs
         port-books books
         port-consts consts
         port-fns fns
         port-labels labels
         port-macros macros
         port-stobjs stobjs
         port-theories theories
         port-thms thms))
       ((and (eq (car trip) 'EVENT-LANDMARK)
             (eq (cadr trip) 'GLOBAL-VALUE)
             (eq (access-event-tuple-type (cddr trip)) 'DEFPKG))
        (bookdata-alist1
         full-book-name collect-p (cdr trips)
         (assert$ (eq collect-p 'port) ; defpkg cannot be in the current book
                  (cons (access-event-tuple-namex (cddr trip))
                        port-pkgs))
         port-books books
         port-consts consts
         port-fns fns
         port-labels labels
         port-macros macros
         port-stobjs stobjs
         port-theories theories
         port-thms thms))
       (t
        (let ((name (name-introduced trip nil)))
          (cond
           (name
            (case (cadr trip)
              (FORMALS
               (bookdata-alist1
                full-book-name collect-p (cdr trips) port-pkgs
                port-books books
                port-consts consts
                (if (eq collect-p 'port)
                    (cons name port-fns)
                  port-fns)
                (if (eq collect-p 'port)
                    fns
                  (cons name fns))
                port-labels labels
                port-macros macros
                port-stobjs stobjs
                port-theories theories
                port-thms thms))
              (THEOREM
               (bookdata-alist1
                full-book-name collect-p (cdr trips) port-pkgs
                port-books books
                port-consts consts
                port-fns fns
                port-labels labels
                port-macros macros
                port-stobjs stobjs
                port-theories theories
                (if (eq collect-p 'port)
                    (cons name port-thms)
                  port-thms)
                (if (eq collect-p 'port)
                    thms
                  (cons name thms))))
              (CONST
               (bookdata-alist1
                full-book-name collect-p (cdr trips) port-pkgs
                port-books books
                (if (eq collect-p 'port)
                    (cons name port-consts)
                  port-consts)
                (if (eq collect-p 'port)
                    consts
                  (cons name consts))
                port-fns fns
                port-labels labels
                port-macros macros
                port-stobjs stobjs
                port-theories theories
                port-thms thms))
              (STOBJ
               (bookdata-alist1
                full-book-name collect-p (cdr trips) port-pkgs
                port-books books
                port-consts consts
                port-fns fns
                port-labels labels
                port-macros macros
                (if (eq collect-p 'port)
                    (cons name port-stobjs)
                  port-stobjs)
                (if (eq collect-p 'port)
                    stobjs
                  (cons name stobjs))
                port-theories theories
                port-thms thms))
              (LABEL
               (bookdata-alist1
                full-book-name collect-p (cdr trips) port-pkgs
                port-books books
                port-consts consts
                port-fns fns
                (if (eq collect-p 'port)
                    (cons name port-labels)
                  port-labels)
                (if (eq collect-p 'port)
                    labels
                  (cons name labels))
                port-macros macros
                port-stobjs stobjs
                port-theories theories
                port-thms thms))
              (THEORY
               (bookdata-alist1
                full-book-name collect-p (cdr trips) port-pkgs
                port-books books
                port-consts consts
                port-fns fns
                port-labels labels
                port-macros macros
                port-stobjs stobjs
                (if (eq collect-p 'port)
                    (cons name port-theories)
                  theories)
                (if (eq collect-p 'port)
                    theories
                  (cons name theories))
                port-thms thms))
              (MACRO-BODY
               (bookdata-alist1
                full-book-name collect-p (cdr trips) port-pkgs
                port-books books
                port-consts consts
                port-fns fns
                port-labels labels
                (if (eq collect-p 'port)
                    (cons name port-macros)
                  port-macros)
                (if (eq collect-p 'port)
                    macros
                  (cons name macros))
                port-stobjs stobjs
                port-theories theories
                port-thms thms))
              (GLOBAL-VALUE

; Then name-introduced is a full-book-name, but we extend books
; above already using include-book-path.

               (assert$
                (eq (car trip) 'CERTIFICATION-TUPLE)
                (bookdata-alist1
                 full-book-name collect-p (cdr trips) port-pkgs
                 port-books books
                 port-consts consts
                 port-fns fns
                 port-labels labels
                 port-macros macros
                 port-stobjs stobjs
                 port-theories theories
                 port-thms thms)))
              (otherwise
               (er hard 'bookdata-alist1
                   "Unexpected case for the cadr of ~x0"
                   trip))))
           (t (bookdata-alist1
               full-book-name collect-p (cdr trips) port-pkgs
               port-books books
               port-consts consts
               port-fns fns
               port-labels labels
               port-macros macros
               port-stobjs stobjs
               port-theories theories
               port-thms thms))))))))))

(defun bookdata-alist (full-book-name wrld)
  (assert$
   (null (global-val 'INCLUDE-BOOK-PATH wrld))
   (let* ((boot-strap-wrld
           (lookup-world-index 'command
                               (relative-to-absolute-command-number 0 wrld)
                               wrld))
          (boot-strap-len (length boot-strap-wrld))
          (wrld-len (length wrld))
          (new-trips (first-n-ac-rev (- wrld-len boot-strap-len) wrld nil)))
     (bookdata-alist1 full-book-name 'port new-trips nil
                      nil nil nil nil nil nil nil nil
                      nil nil nil nil nil nil nil nil))))

(defun maybe-write-bookdata (full-book-string full-book-name wrld ctx state)

; We are given a full-book-string and corresponding full-book-name, say for
; foo.lisp.  Then when state global 'write-bookdata is not :never, and either
; it's also not nil or environment variable ACL2_WRITE_BOOKDATA is non-empty,
; then certification of full-book-name will cause a file foo__bookdata.out to
; be written.  That file will be of the form (full-book-name . kwd-values),
; where kwd-values is a keyword-value-listp that associates keywords with lists
; as follows.  In each case, only events in the world after including the book
; are considered, hence not events that are merely local or events events
; within other books, but including events from the portcullis (certification
; world) for foo.lisp.  The keyword :books is associated with the list of
; full-book-names of included books.  Each other keyword is associated with an
; alist that associates each key, a package name, with a list of symbol-names
; for symbols in that package that are introduced for that keyword, as follows.

; :CONSTS   - constant symbol introduced by defconst
; :FNS      - function symbol: introduced by defun, defuns, or defchoose;
;             or constrained
; :LABELS   - symbol introduced by deflabel
; :MACROS   - macro name introduced by defmacro
; :STOBJS   - stobj name introduced by defstobj or defabsstobj
; :THEORIES - theory name introduced by deftheory
; :THMS     - theorem name introduced by defthm or defaxiom

  (let ((write-bookdata (f-get-global 'write-bookdata state)))
    (cond
     ((eq write-bookdata :never)
      state)
     (t
      (mv-let (erp val state)
        (if write-bookdata
            (value t)
          (getenv! "ACL2_WRITE_BOOKDATA" state))
        (assert$
         (null erp)
         (cond
          (val
           (let ((outfile (concatenate 'string
                                       (remove-lisp-suffix full-book-string t)
                                       "__bookdata.out")))
             (mv-let
               (channel state)
               (open-output-channel outfile :object state)
               (cond ((null channel)
                      (prog2$ (er hard ctx
                                  "Error in maybe-write-bookdata: Unable to ~
                                  open file ~x0 for output."
                                  outfile)
                              state))
                     (t (pprogn
                         (print-object$-fn (cons full-book-name
                                                 (bookdata-alist full-book-name
                                                                 wrld))
                                           nil ; serialize-character
                                           channel
                                           state)
                         (close-output-channel channel state)))))))
          (t state))))))))

(defun fromto (i j)
  (declare (xargs :guard (and (rationalp i) (rationalp j))))
  (if (< j i)
      nil
    (cons i (fromto (1+ i) j))))

(defun remove-smaller-keys-from-sorted-alist (index alist)

; Alist is an alist whose keys are rational numbers.  Return the tail of alist,
; if any, starting with a key that is at least as large as index.  Thus, if
; alist is sorted, then we return its tail of entries at least as large as
; index.

  (cond ((endp alist) nil)
        ((< (caar alist) index)
         (remove-smaller-keys-from-sorted-alist index (cdr alist)))
        (t alist)))

(defun cert-include-expansion-alist (index expansion-alist)

; We are ready to call include-book-fn after the initial processing of all
; events in a book by certify-book.  But we have already retracted the world to
; the world, w, just before position index, where index=1 corresponds the first
; event after the book's in-package event, hence to the certification world.
; We want to fool include-book-fn into skipping all events that were already
; processed in creating w.  So we replace expansion-alist by one that
; associates every index in the half-open interval [1,index) with a no-op.

  (append (pairlis$ (fromto 1 (1- index))
                    (make-list (1- index)
                               :initial-element '(value-triple nil)))
          (remove-smaller-keys-from-sorted-alist index expansion-alist)))

(defun read-useless-runes2 (r alist fal filename ctx state)

; See read-useless-runes1.

  (declare (xargs :guard (and (rationalp r)
                              (< 0 r)
                              (<= r 1)
                              (alistp alist)
                              (true-list-listp alist))))
  (cond ((endp alist) (value fal))
        ((atom (car alist))
         (er soft ctx
             "Illegal entry in file ~x0 (not a cons): ~x1."
             filename (car alist)))
        ((not (symbolp (caar alist)))
         (er soft ctx
             "Illegal entry in file ~x0 (CAR is not a symbol): ~x1."
             filename (caar alist)))
        ((not (useless-runes-report-p (cdar alist)))
         (er soft ctx
             "Illegal entry in file ~x0 (CDR is not a list of triples): ~x1."
             filename (cdar alist)))
        (t
         (let* ((key (caar alist))
                (new0 (strip-caddrs (cdar alist)))
                (new (if (= r 1) ; optimization
                         new0
                       (take (ceiling (* r (length new0)) 1) new0)))
                (old (cdr (hons-get key fal))))
           (read-useless-runes2 r
                                (cdr alist)
                                (hons-acons key (cons new old) fal)
                                filename ctx state)))))

(defun read-useless-runes1 (r alist filename ctx state)

; Each key in alist is associated with a list L, but we want only the initial
; segment S from shortening L by a factor of r, 0 < r <= 1 (rounded up with
; ceiling).  We return a fast alist whose keys are the keys in alist, where key
; k is associated just once with the list of shortened values paired with k in
; alist, in order.  We check the shape as we go.

  (declare (xargs :guard (and (rationalp r)
                              (< 0 r)
                              (<= r 1)
                              (alistp alist)
                              (true-list-listp alist))))
  (read-useless-runes2 r (reverse alist) nil filename ctx state))

(defun read-file-iterate-safe (channel acc state
                                       #-acl2-loop-only &aux
                                       #-acl2-loop-only error-start-pos)


; In #-cltl2, this is just read-file-iterate, with nil elements removed
; from the result.

; But in #+cltl2, this variant of read-file-iterate avoids read errors, e.g.,
; due to symbols with nonexistent packages.  Logically, it skips over a form
; when directed to do so by the oracle.  Under the hood, it skips over a form
; when the attempt to read it causes an error, by backing up to the beginning
; of the form and then skipping over it.

  #-cltl2 ; handler-case can be undefined, e.g., in non-ANSI GCL
  (mv-let (eof obj state)
    (read-file-iterate channel acc state)
    (mv eof (remove-eq nil obj) state))
  #+(and cltl2 acl2-loop-only)
  (mv-let (eof obj state)
    (mv-let (erp val state)
      (read-acl2-oracle state)
      (declare (ignore erp))
      (cond (val (mv-let (eof state)
                   (read-object-suppress channel state)
                   (mv eof nil state)))
            (t
             (read-object channel state))))
    (cond (eof (mv (reverse acc) state))
          (t
           (read-file-iterate-safe channel
                                   (if (eq obj nil)
                                       acc
                                     (cons obj acc))
                                   state))))
  #+(and cltl2 (not acl2-loop-only))
  (mv
   (loop
    (let ((pos (file-position (get-input-stream-from-channel channel))))
      (mv-let (eof obj state)
        (handler-case (read-object channel state)
          (error (condition)
                 (declare (ignore condition))
                 (progn (setq error-start-pos pos)
                        (mv nil nil state))))
        (cond
         (eof (return (reverse acc)))
         (t
          (when error-start-pos

; When read breaks in the middle of an expression it seems to leave the
; file-pointer there rather than to proceed to the end of the original
; expression.  So we go back to where we were, and then read the entire object,
; throwing it away.

            (file-position (get-input-stream-from-channel channel)
                           error-start-pos)
            (setq error-start-pos nil)
            (read-object-suppress channel state))
          (setq acc (if (eq obj nil)
                        acc
                      (cons obj acc))))))))
   state))

(defun useless-runes-env-info (useless-runes-r/w useless-runes-r/w-p ldp state)

; We return an error triple whose value is either nil, indicating that the
; useless-runes value does not come from an environment variable, or else a
; triple (var val . val-ld) where: var is an environment variable (either
; ACL2_USELESS_RUNES or ACL2_USELESS_RUNES_LD); val is the value of that
; variable (a non-empty string); and val-ld is the value of
; ACL2_USELESS_RUNES_LD when that value is string-equal to "CERT" and thus
; points to ACL2_USELESS_RUNES, else is nil.

  (cond
   ((and useless-runes-r/w-p
         (or (null useless-runes-r/w)
             ldp))

; If :useless-runes was supplied explicitly as nil to certify-book, or was
; supplied as any value to ld, then ignore environment variables.

    (value nil))
   ((null ldp)
    (er-let* ((val (getenv! "ACL2_USELESS_RUNES" state))  )
      (value (and val (list* "ACL2_USELESS_RUNES" val nil)))))
   (t (er-let* ((val-ld (getenv! "ACL2_USELESS_RUNES_LD" state))
                (val (getenv! "ACL2_USELESS_RUNES" state)))
        (cond
         ((string-equal val-ld "CERT")
          (value (and val (list* "ACL2_USELESS_RUNES" val val-ld))))
         (t
          (value (and val-ld (list* "ACL2_USELESS_RUNES_LD" val-ld nil)))))))))

(defun useless-runes-source-msg (env-info useless-runes-r/w ldp)
  (cond (env-info
         (let ((val (car env-info))
               (var (cadr env-info))
               (val-ld (cddr env-info)))
           (msg "the value ~x0 of environment variable ~s1~@2"
                val var
                (if val-ld
                    (assert$
                     ldp
                     (msg " (because environment variable ~
                           ACL2_USELESS_RUNES_LD has value ~s0)"
                          val-ld))
                  ""))))
        (t (msg "~x0 keyword option :useless-runes ~x1"
                (if ldp 'ld 'certify-book)
                useless-runes-r/w))))

(defun read-useless-runes (full-book-string env-info useless-runes-r/w val ldp
                                            ctx state)

; Env-info and val come from function useless-runes-value: val is a rational
; number from -1 to 1 inclusive whose absolute value indicates the fraction of
; runes to collect from the appropriate @useless-runes.lsp file for each event
; (a negative number indicates that it's OK if that file does not exist); and
; env-info, which is only used for error reporting, indicates the source of
; val.

; This function returns an error triple whose value is a fast-alist mapping
; each key, a name, to a list of lists of runes.  The call of read-file causes
; an error if the @useless-runes.lsp file doesn't exist (or isn't readable).

; We copy code from read-file, but avoid that function so that we can fail
; silently.

; Notice the use of with-packages-unhidden.  We would like to ensure that when
; ACL2 reads a @useless-runes.lsp file, there isn't a reader error due to an
; unknown package.  One way we could have done this is to read the
; @useless-runes.lsp on demand, getting the next form for each event, rather
; than to read the entire file early in the certification or ld process as we
; do now.  That would work fine initially: the next name would match the next
; name of a defun(s), defthm, or verify-guards event, and by then the
; corresponding list of runes would use only known packages.  But imagine what
; happens as, over time, the book is edited to rearrange, add, or remove
; events.  The @useless-runes.lsp would be much less tolerant of those changes
; than it is during the implemented approach, which is to use
; with-packages-unhidden to "unhide" hidden packages from the book's
; portcullis, so that we can (we think) get all packages from sub-books before
; reading the @useless-runes.lsp.  Those packages are logically there anyhow
; after reading the portcullis commands -- it's just a courtesy to the user to
; cause errors when an operation (especially symbol-package-name) relies on a
; hidden package.

  (assert$
   (and (rationalp val)
        (not (zerop val))
        (<= -1 val)
        (<= val 1))
   (let ((useless-runes-filename (useless-runes-filename full-book-string)))
     (with-packages-unhidden
      (mv-let (channel state)
        (open-input-channel useless-runes-filename :object state)
        (cond (channel
               (er-let* ((alist
                          (state-global-let*
                           ((current-package "ACL2" set-current-package-state))
                           (mv-let (alist state)
                             (read-file-iterate-safe channel nil state)
                             (value alist)))))
                 (pprogn (io? event nil state
                              (useless-runes-filename)
                              (fms! "; Note: Consulting useless-runes ~
                                     file,~|; ~s0."
                                    (list (cons #\0 useless-runes-filename))
                                    (standard-co state) state nil))
                         (close-input-channel channel state)
                         (read-useless-runes1 (abs val)
                                              alist useless-runes-filename
                                              ctx state))))
              ((< val 0) (value nil))
              (t (er soft ctx
                     "Unable to open file ~x0 for reading useless-runes data, ~
                      as specified by ~@1; see :DOC useless-runes."
                     useless-runes-filename
                     (useless-runes-source-msg env-info
                                               useless-runes-r/w
                                               ldp)))))))))

(defun free-useless-runes (useless-runes state)
  (cond
   ((null useless-runes) state)
   (t (case (access useless-runes useless-runes :tag)
        (FAST-ALIST
         (prog2$ (fast-alist-free (access useless-runes useless-runes :data))
                 state))
        (CHANNEL
         (close-output-channel (car (access useless-runes useless-runes :data))
                               state))
        (t (prog2$ (er hard 'free-useless-runes
                       "Implementation error: Unexpected value of ~
                        useless-runes, ~x0"
                       useless-runes)
                   state))))))

(defun useless-runes-value (useless-runes-r/w useless-runes-r/w-p
                                              ldp ctx state)

; Useless-runes-r/w is the value supplied with option :useless-runes of
; certify-book (when ldp is nil) or ld (when ldp is t), if that is supplied;
; useless-runes-r/w-p is true when that option is supplied, else nil.

; We return an error triple whose value is a pair (env-info . val), where:
; env-info indicates the role of environment variables responsible for the
; value, val, if any -- see useless-runes-env-info -- else nil; and val is
; WRITE, nil, or a non-zero rational between -1 and 1 inclusive whose absolute
; value represents the fraction of the useless-runes for a given event that
; should be kept disabled.  An exception is that the "pair" may be nil, which
; represents env-info = val = nil.  A negative number indicates that the
; @useless-runes.lsp need not exist, while a positive number results in an
; error if that file does not exist.

; (We could allow 0 for val, but that would mean the same as nil, and we
; prefer not to have two values that mean the same thing.)

; We ignore useless-runes info in ACL2(r), by making it seem that the call to
; certify-book always includes ":useless-runes nil".  If we decide later not to
; do this, we will be safe in avoiding interference with useless-runes files
; created for (standard) ACL2 because useless-runes files for ACL2(r) will be
; in .sysr/ rather than in .sys/; see useless-runes-filename.

; We use a different mechanism for avoiding useless-runes in ACL2(p) than in
; ACL2(r); see with-useless-runes-aux.  It's not clear which is better, but
; it's also not clear that there's much reason to change either one at this
; point.

  #+non-standard-analysis
  (declare (ignore useless-runes-r/w useless-runes-r/w-p))
  (let ((useless-runes-r/w
         #+non-standard-analysis nil
         #-non-standard-analysis useless-runes-r/w)
        (useless-runes-r/w-p
         #+non-standard-analysis t
         #-non-standard-analysis useless-runes-r/w-p))
    (er-let* ((env-info (useless-runes-env-info useless-runes-r/w
                                                useless-runes-r/w-p
                                                ldp
                                                state)))
      (mv-let (env-var env-val val-ld)
        (cond (env-info (mv (car env-info) (cadr env-info) (cddr env-info)))
              (t (mv nil nil nil)))
        (cond
         ((and env-info
               (string-equal env-val "WRITE")
               (not ldp))

; A value of "write" from an environment variable takes priority over a non-nil
; :useless-runes option of certify-book.

          (value (cons env-info 'write)))
         (t
          (case useless-runes-r/w
            (:write (value (cons nil 'write)))
            (:read  (value (cons nil 1)))
            (:read? (value (cons nil -1)))
            ((nil)
             (cond
              (useless-runes-r/w-p (value nil)) ; honor an explicit nil value
              ((or (null env-info)
                   (string-equal env-val "NIL"))
               (value nil))
              ((or (string-equal env-val "READ")
                   (equal env-val "100"))
               (value (cons env-info 1)))
              ((or (string-equal env-val "READ?")
                   (equal env-val "-100"))
               (value (cons env-info -1)))
              (t ; read a number between 1 and 99
               (let* ((len (length env-val))
                      (sign (if (and (not (zerop len))
                                     (eql (char env-val 0) #\-))
                                1
                              0))
                      (str (if (int= sign 1)
                               (subseq env-val 1 len)
                             env-val))
                      (len2 (if (int= sign 1)
                                (1- len)
                              len))
                      (percent (and (or (int= len2 1)
                                        (int= len2 2))
                                    (all-digits-p (coerce str 'list) 10)
                                    (decimal-string-to-number str len2 0))))
                 (cond (percent (value
                                 (cons env-info
                                       (/ percent
                                          (if (int= sign 1) -100 100)))))
                       (t (er soft ctx
                              "Illegal value ~x0 for environment variable ~
                               ~@1.  See :DOC useless-runes."
                              env-val
                              (cond
                               (val-ld
                                (assert$
                                 ldp
                                 (msg " (because environment variable ~
                                       ACL2_USELESS_RUNES_LD has value ~s0)"
                                      val-ld)))
                               (t env-var)))))))))
            (t ; should be an integer value
             (cond

; In ACL2(r), i.e., when #+non-standard-analysis, useless-runes-r/w is nil.
; Therefore the first COND branch below can be ignored in that case.  We would
; leave it there unconditionally anyhow, to avoid having an extra readtime
; conditional, but Allegro CL warns otherwise when building ACL2: "Warning:
; Type NULL is incompatible for numeric operation."

              #-non-standard-analysis
              ((and (integerp useless-runes-r/w)
                    (not (zerop useless-runes-r/w))
                    (<= -100 useless-runes-r/w)
                    (<= useless-runes-r/w 100))
               (value (cons nil (/ useless-runes-r/w 100))))
              (t (er soft ctx
                     "Illegal value ~x0 for certify-book parameter ~
                      :USELESS-RUNES.  See :DOC useless-runes."
                     useless-runes-r/w)))))))))))

(defun initial-useless-runes (full-book-string useless-runes-r/w
                                               useless-runes-r/w-p
                                               ldp ctx state)

; This function is called only for initializing the state global 'useless-runes
; for a call of certify-book or ld.  When it does so, it opens a suitable
; channel in the 'write case, and it reads in the fast-alist in the 'read case.

  (let ((bookp (and (stringp full-book-string)
                    (let ((len (length full-book-string)))
                      (and (< 5 len)
                           (terminal-substringp
                            ".lisp" full-book-string 4 (1- len)))))))
    (cond
     ((not (or useless-runes-r/w-p
               bookp))

; Since the :useless-runes keyword argument was not supplied, and since the
; filename argument is not a string ending in ".lisp", we don't consult the
; environment.

      (value nil))
     (t
      (er-let* ((pair (useless-runes-value useless-runes-r/w useless-runes-r/w-p
                                           ldp ctx state))
                (env-info (value (car pair)))
                (val (value (cdr pair)))
                (full-book-string
                 (cond ((or (null val) ; then full-book-string is irrelevant
                            (not ldp))
                        (value full-book-string))
                       (bookp
                        (value (extend-pathname
                                (f-get-global 'connected-book-directory state)
                                full-book-string
                                state)))
                       (t ; hence useless-runes-r/w-p is true
                        (er soft ctx
                            "A non-nil :useless-runes argument is only ~
                             permitted for a call of ~x0 when the first ~
                             argument is a string ending in \".lisp\".  But ~
                             the first argument is ~x1."
                            'ld full-book-string)))))
        (cond
         ((null val) (value nil))
         ((eq val 'write)
          (let ((useless-runes-filename
                 (useless-runes-filename full-book-string)))
            (mv-let (chan state)
              (open-output-channel useless-runes-filename :character state)
              (cond
               ((null chan)
                (er soft ctx
                    "Unable to open file ~x0 for writing useless-runes data (as ~
                 specified by ~@1); see :DOC useless-runes."
                    useless-runes-filename
                    (useless-runes-source-msg env-info useless-runes-r/w ldp)))
               (t (value (make useless-runes
                               :tag 'CHANNEL
                               :data (cons chan
                                           (strip-cars
                                            (known-package-alist state)))
                               :full-book-string full-book-string)))))))
         (t
          (assert$
           (and (rationalp val)
                (<= -1 val)
                (not (zerop val))
                (<= val 1))
           (er-let* ((fal (read-useless-runes full-book-string
                                              env-info
                                              useless-runes-r/w
                                              val ldp ctx state)))
             (value (make useless-runes
                          :tag 'FAST-ALIST
                          :data fal
                          :full-book-string full-book-string)))))))))))

(defun maybe-refresh-useless-runes (useless-runes)

; This function is called by f-put-ld-specials to restore useless-runes after
; completion of a subsidiary call of ld or certify-book.  It's not clear that
; this is necessary, but we play it safe in case the fast-alist has somehow
; been stolen.

  (cond ((and useless-runes
              (eq (access useless-runes useless-runes :tag)
                  'FAST-ALIST))
         (change useless-runes useless-runes
                 :data
                 (make-fast-alist (access useless-runes useless-runes :data))))
        (t useless-runes)))

(defun update-useless-runes (useless-runes state)

; Call this when the value of state global 'useless-runes is to be replaced
; with the given useless-runes (a useless-runes record or nil) with no further
; use of the old value.

  (pprogn (free-useless-runes (f-get-global 'useless-runes state)
                              state)
          (f-put-global 'useless-runes
                        (maybe-refresh-useless-runes useless-runes)
                        state)))

(defun eval-some-portcullis-cmds (port-index portcullis-cmds ctx state)
  (state-global-let*
   ((ld-skip-proofsp 'include-book)
    (skip-proofs-by-system t))
   (mv-let (erp val expansion-alist ignore-kpa state)
     (eval-event-lst 0       ; irrelevant
                     nil     ; expansion-alist
                     (nthcdr port-index portcullis-cmds)
                     t                                    ; quietp
                     nil                                  ; environment
                     nil                                  ; in-local-flg
                     nil                                  ; last-val
                     nil                                  ; other-control
                     nil                                  ; kpa
                     'eval-some-portcullis-cmds     ; caller
                     ctx (proofs-co state) state)
     (declare (ignore expansion-alist ignore-kpa))
     (mv erp val state))))

; Essay on Hidden Packages Added by Certify-book

; See the Essay on Hidden Packages for relevant background.  Here we give some
; implementation-level explanations of the addition of hidden defpkg events to
; the portcullis commands in a certificate file.  We'll generally use names of
; let-bound variables in certify-book-fn.

; First, let's give some names here to the relevant worlds.

;   cert-wrld: the certification world, which includes local portcullis events
;     (i.e., they were actually executed).

;   rollback-wrld: the world immediately after rollback, which will be a proper
;     initial segment of cert-wrld when there are any local portcullis events,
;     but not otherwise.  This is irrelevant (and undefined) if there are no
;     local events in the portcullis or the book (not counting events local to
;     encapsulates, of course).

;   portcullis-wrld: same as cert-wrld if that world doesn't have local events,
;     else, the result of re-executing (non-local) portcullis commands after
;     rollback into cert-wrld

;   wrld-post-pass1: the world after pass 1

;   wrld2: the world after pass 2

; Next, here are the key pieces of the hidden defpkg handling in
; certify-book-fn.

;   defpkg-items: This represents the defpkg events (hidden or not) present in
;     wrld-post-pass1 that are not present (even as hidden defpkgs) in
;     rollback-wrld if there is rollback, else in the certification world.  The
;     point is that logically, as per the Essay on Hidden Packages, those
;     package definitions need to be present after including the book.  Thus,
;     defpkg-items includes the set new-defpkg-list (computed below) of all
;     defpkg events to be added to the end of the portcullis commands as hidden
;     defpkg events.  Note that packages for some of defpkg-items might not
;     need to be added, however, if they are in wrld2.  Defpkg-items ensures
;     (with translate and/or termp checks) that the generated hidden defpkg
;     events can be evaluated in portcullis-wrld.

;   pkg-names: These are the names of packages needed before reading the
;     expansion-alist or cert-data when we include the book.  Unlike other
;     hidden packages added, these might not be needed logically -- but they're
;     needed just for readability of the :cert-data field of a .cert file.
;     NOTE: these can be introduced as hidden defpkgs, because their purpose is
;     to support reading the :cert-data and :expansion-alist fields of the
;     .cert file when including a book, and chk-bad-lisp-object avoids checking
;     packages when inside include book -- so all we need is for the package to
;     exist in Lisp, not in ACL2 proper.  (Yep, that's kind of funky.)

;   new-defpkg-list: This list of hidden defpkg events is added to the end of
;     the portcullis commands.  It is "closed" in the sense that if a package
;     is included, so are the packages of all symbols imported into that
;     package, though of course those symbols' packages needn't be added for
;     packages already present at the start of including the book (hence
;     argument earlier-kpa of function new-defpkg-list).

; Now we discuss the algorithm for adding hidden defpkg events to the end of
; the portcullis commands.

; First, defpkg-items collects all defpkgs in wrld-post-pass1 that are
; missing in rollback-wrld, where the bodies should be translatable in
; portcullis-wrld since that's where they will be executed.  The last
; argument of defpkg-items should be sufficient to guarantee that -- it
; can be portcullis-wrld or any earlier world if necessary (in
; particular, rollback-wrld if we rolled back into the portcullis
; commands).  If rollback is into the book events, then translate will
; be inefficient when we use portcullis-wrld = cert-wrld, but that's how
; it's always been so I think we can live with that.

; Next, pkg-names is computed as above, in portcullis-world.

; Before we discuss new-defpkg-list, let's introduce an important
; notion.  A list L of package definitions is "closed" if every imported
; symbol's package has a definition in L.  An invariant of the logical
; world is that its known-package-alist is closed.

; Finally we call (new-defpkg-list defpkg-items base-kpa earlier-kpa),
; where defpkg-items is as above, and base-kpa and earlier-kpa are
; as follows.

; - Base-kpa is unchanged from before.  It's the known-package-alist
;   for packages that we don't need to add, which is all those from
;   wrld2 except for those named by pkg-names, since we need those in
;   the portcullis so as to be able to read the :expansion-alist and
;   :cert-data when including the book.

; - Earlier-kpa is a closed set of packages that we know we do not need
;   to add as hidden packages.

; New-defpkg-list returns the smallest closed set of packages contained
; in defpkg-items that includes packages in defpkg-items that are
; missing from base-kpa.

; End of Essay on Hidden Packages Added by Certify-book

(defun compress-cltl-command-stack-rec (stack fal)

; See the Essay on Fast-cert.

  (cond
   ((endp stack) (strip-cdrs (fast-alist-free fal)))
   (t (compress-cltl-command-stack-rec
       (cdr stack)
       (let ((x (car stack)))
         (case-match x
           (('defuns mode & . defs)
            (assert$
             (and (alistp defs) defs)
             (let* ((name (caar defs))
                    (pair (hons-get name fal)))
               (cond
                (pair (let ((old (cdr pair)))
                        (cond
                         ((and (eq (cadr old) :program) ; old mode
                               (eq mode :logic))
                          (hons-acons name
                                      `(defuns :logic reclassifying
                                         ,@defs)
                                      fal))
                         (t fal))))
                (t

; Unlike the case above, here we do not need to put 'reclassifying into x.  The
; reason is that if this definition is truly reclassifying a non-local defun
; when including a book, then we would be in the preceding case.

                 (hons-acons name x fal))))))
           ((defx name . &)
            (cond ((and (member-eq defx
                                   '(defconst defmacro defstobj defabsstobj))
                        (hons-get name fal))
                   fal)
                  (t (hons-acons name x fal))))
           (& (hons-acons nil x fal))))))))

(defun compress-cltl-command-stack (stack)

; See the Essay on Fast-cert.

  (compress-cltl-command-stack-rec (reverse stack) nil))

(defun event-data-channel (full-book-string write-event-data
                                             write-event-data-p ctx state)
  (er-let* ((write-event-data (if write-event-data-p
                                  (value write-event-data)
                                (getenv! "ACL2_WRITE_EVENT_DATA" state))))
    (cond
     ((null write-event-data) (value nil))
     (t (let ((filename (event-data-filename full-book-string t)))
          (mv-let (channel state)
            (open-output-channel filename :object state)
            (cond ((null channel)
                   (er soft ctx
                       "Unable to open output channel for writing event-data ~
                        to file ~x0"
                       filename))
                  (t (value channel)))))))))

; The next major function defined below is certify-book-fn.  To improve
; readability we have separated out various parts of its code into the
; definitions below, up to the definition of certify-book-fn.

(defun chk-acceptable-certify-book-prelim (user-book-name acl2x ttagsxp ctx
                                                          state)

; These checks are carried out early by certify-book.

  (cond
   ((not (eq (caar (w state)) 'COMMAND-LANDMARK))

; If we remove this restriction, then we need to change get-portcullis-cmds (at
; the least) so as not to look only for command markers.

    (er soft ctx
        "Certify-book can only be run at the top-level, either directly in ~
         the top-level loop or at the top level of LD."))
   ((and (stringp user-book-name)
         (let ((len (length user-book-name)))
           (and (<= 10 len) ; 10 = (length "@expansion")
                (equal (subseq user-book-name (- len 10) len)
                       "@expansion"))))
    (er soft ctx
        "Book filenames may not end in \"@expansion\"."))
   ((not (booleanp acl2x)) ; also checked in certify-book guard
    (er soft ctx
        "The argument :ACL2X for certify-book must take on the value of T or ~
         NIL.  The value ~x0 is thus illegal.  See :DOC certify-book."
        acl2x))
   ((and ttagsxp (not acl2x))
    (er soft ctx
        "The  :TTAGSX argument for certify-book may only be supplied if ~
         :ACL2X is T.  See :DOC set-write-acl2x."))
   ((and (not acl2x)
         (f-get-global 'write-acl2x state))
    (er soft ctx
        "Apparently set-write-acl2x has been evaluated with argument value ~
         ~x0, yet certify-book is being called without supplying keyword ~
         argument :ACL2X T.  This is illegal.  See :DOC set-write-acl2x.  If ~
         you do not intend to write a .acl2x file, you may wish to evaluate ~
         ~x1."
        (f-get-global 'write-acl2x state)
        '(set-write-acl2x nil state)))
   (t (value nil))))

(defun certify-book-write-port (write-port pcert ctx state)

; Convert the write-port argument of certify-book to a suitable value, causing
; an error when appropriate.

  (cond ((member-eq write-port '(t nil))
         (value write-port))
        ((eq write-port :default)
         (cond (pcert

; We have seen a "convert" failure (for creating the .pcert1 file) for
; community book
; books/workshops/2011/verbeek-schmaltz/sources/correctness.lisp.  The problem
; seems to be that build system automatically creates .port files that are
; loaded, but more .port files are around when building correctness.pcert1 file
; than when building correctness.pcert1.pcert0.  Our solution is to make the
; default for :write-port be nil, instead of t, when doing any step of
; provisional certification -- even when ACL2_WRITE_PORT is set, so as to
; defeat the build system's attempt to build .port files when doing
; pcertification steps.

                (value nil))
               (t (er-let* ((str (getenv! "ACL2_WRITE_PORT" state)))
                    (value (cond (str (intern$ (string-upcase str) "ACL2"))
                                 (t t))))))) ; default
        (t (er soft ctx
               "Illegal :write-port argument, ~x0.  See :DOC certify-book."))))

(defun certify-book-cert-op (pcert pcert-env write-acl2x ctx state)

; Return the cert-op to use for certify-book (see comments in cert-op), causing
; an error when appropriate.

  (cond ((and write-acl2x pcert)
         (er soft ctx
             "It is illegal to specify the writing  of a .acl2x file when a ~
              non-nil value for :pcert (here, ~x1) is specified~@0."
             pcert
             (cond (pcert-env
                    " (even when the :pcert argument is supplied, as in this ~
                     case, by an environment variable)")
                   (t ""))))
        (write-acl2x
         (value (if (consp write-acl2x) :write-acl2xu :write-acl2x)))
        (t (case pcert
             (:create (value :create-pcert))
             (:convert (value :convert-pcert))
             ((t) (value :create+convert-pcert))
             ((nil) (value t))
             (otherwise
              (er soft ctx
                  "Illegal value of :pcert, ~x0~@1.  See :DOC certify-book."
                  pcert
                  (cond (pcert-env
                         (msg " (from environment variable ACL2_PCERT_ARG=~x0"
                              pcert-env))
                        (t ""))))))))

(defun certify-book-compile-flg (compile-flg cert-op ctx state)

; Convert the compile-flg argument of certify-book by taking into account the
; cert-op and environment.

  (er-let* ((env-compile-flg (getenv! "ACL2_COMPILE_FLG" state)))
    (cond ((or (and env-compile-flg
                    (string-equal env-compile-flg "ALL"))
               (eq compile-flg :all))
           (value t))
          ((or (eq cert-op :convert-pcert)
               (null (f-get-global 'compiler-enabled state)))
           (value nil))
          ((not (eq compile-flg :default))
           (value compile-flg))
          ((or (null env-compile-flg)
               (string-equal env-compile-flg "T"))
           (value t))
          ((string-equal env-compile-flg "NIL")
           (value nil))
          (t (er soft ctx
                 "Illegal value, ~x0, for environment variable ~
                  ACL2_COMPILE_FLG.  The legal values are (after converting ~
                  to uppercase) \"\", \"T\", \"NIL\", \"\", and \"ALL\"."
                 env-compile-flg)))))

(defun print-certify-book-step-1 (fast-cert-p full-book-string cert-op
                                              fast-cert-mode state)
  (io? event nil state
       (fast-cert-p full-book-string cert-op fast-cert-mode)
       (fms "CERTIFICATION ATTEMPT~#h~[~|**using fast-cert mode**~|~/ ~
             ~]~@0FOR ~x1~%~s2~@3~%~%*~ Step 1: Read ~x1 and compute its ~
             book-hash.~%"
            (list (cons #\h (if fast-cert-p 0 1))
                  (cons #\0 (case cert-op
                              ((:write-acl2xu :write-acl2x)
                               "(for writing .acl2x file) ")
                              (:create-pcert
                               "(for writing .pcert0 file) ")
                              (:create+convert-pcert
                               "(for writing .pcert0 and .pcert1 files) ")
                              (:convert-pcert
                               "(for writing .pcert1 file) ")
                              (t "")))
                  (cons #\1 full-book-string)
                  (cons #\2 (f-get-global 'acl2-version state))
                  (cons #\3 (if (and fast-cert-mode
                                     (not fast-cert-p))
                                "~|Note that fast-cert mode is enabled but ~
                                 will be ignored during certification, except ~
                                 for noting in the certificate file that ~
                                 fast-cert mode was enabled during ~
                                 certification."
                              "")))
            (proofs-co state) state nil)))

(defun certify-book-expansion-alist0 (cert-op cert-obj acl2x-expansion-alist
                                              full-book-string acl2x-file
                                              ctx state)

; This is just acl2x-expansion-alist unless the cert-op is :convert-pcert, in
; which case it is the expansion-alist to use when processing the book's events
; for the convert step.

  (cond ((eq cert-op :convert-pcert)
         (let ((elided-expansion-alist
                (access cert-obj cert-obj :expansion-alist)))
           (mv-let (bad-entry elided-entry)
             (expansion-alist-conflict
              acl2x-expansion-alist
              elided-expansion-alist)
             (cond
              (bad-entry (er soft ctx
                             "The following expansion-alist entry from file ~
                              ~x0 is unexpected:~|~x1~|~@2"
                             acl2x-file
                             bad-entry
                             (cond (elided-entry
                                    (msg "It was expected to correspond to ~
                                          the following entry from the ~
                                          :expansion-alist in file ~x0:~|~x1"
                                         (convert-book-string-to-cert
                                          full-book-string
                                          :create-pcert)
                                         elided-entry))
                                   (t ""))))
              (t (value (merge-into-expansion-alist
                         (merge-into-expansion-alist elided-expansion-alist
                                                     acl2x-expansion-alist)
                         (access cert-obj cert-obj :pcert-info))))))))
        (t (value acl2x-expansion-alist))))

(defun certify-book-step-2 (ev-lst expansion-alist0 cert-op full-book-string
                                   acl2x-file ttags-allowed wrld1
                                   directory-name write-acl2x full-book-name
                                   saved-acl2-defaults-table ctx state)

; This function processes a book's events for certify-book after printing a
; suitable message.  It thus updates the state, and in particular the world.
; It returns a tuple of the following form.

;   (skipped-proofsp ; true when a top-level event skips proofs
;    portcullis-skipped-proofsp ; true when skip-proofsp at start
;    axiomsp ; state global value after running events
;    ttags-seen ; world global value after running events
;    include-book-alist-all ; world global value after running events
;    expansion-alist ; suitable expansion-alist (see below)
;    expansion-alist-to-check ; see comments below
;    translate-cert-data ; world global value after running events
;    )

  (pprogn
   (print-certify-book-step-2
    ev-lst expansion-alist0
    (and (eq cert-op :convert-pcert)
         (convert-book-string-to-cert full-book-string :create-pcert))
    acl2x-file state)
   (state-global-let*
    ((ttags-allowed ttags-allowed)
     (user-home-dir

; We disallow ~/ in subsidiary include-book forms, because its meaning will be
; different when the superior book is included if the user changes (see :doc
; pathname).  We do not make a similar binding in Step 3, because it calls
; include-book-fn and we do want to allow the argument to certify-book to start
; with ~/.  Step 3 presumably doesn't call any include-book forms not already
; considered in Step 2, so this decision should be OK.

      nil)

; We will accumulate into the flag axiomsp whether any axioms have been added,
; starting with those in the portcullis.  We can identify axioms in the
; portcullis by asking if the current nonconstructive axioms are different from
; those at the end of boot-strap.

     (axiomsp
      (not (equal
            (global-val ; axioms as of boot-strap
             'nonconstructive-axiom-names
             (scan-to-landmark-number 'event-landmark
                                      (global-val 'event-number-baseline wrld1)
                                      wrld1))
            (global-val ; current axiomx
             'nonconstructive-axiom-names
             wrld1))))
     (ld-redefinition-action nil))
    (with-cbd
     directory-name
     (revert-world-on-error
      (er-let* ((portcullis-skipped-proofsp
                 (value
                  (and (global-val 'skip-proofs-seen (w state))
                       t)))
                (expansion-alist-and-index

; The fact that we are under 'certify-book means that all calls of
; include-book will insist that the :uncertified-okp action is nil, meaning
; errors will be caused if uncertified books are read.

                 (process-embedded-events
                  'certify-book
                  saved-acl2-defaults-table
                  (or (eq cert-op :create-pcert)
                      (and (consp write-acl2x)
                           (car write-acl2x)))
                  (cadr (car ev-lst))
                  (list 'certify-book full-book-name)
                  (subst-by-position expansion-alist0

; See the Essay on .acl2x Files (Double Certification).

                                     (cdr ev-lst)
                                     1)
                  1 nil nil 'certify-book state))
                (ignore (pprogn (chk-absstobj-invariants state)
                                (illegal-to-certify-check nil ctx state)))
                (expansion-alist
                 (value (cond (write-acl2x
                               (assert$ ; disallowed pcert
                                (null expansion-alist0)
                                (car expansion-alist-and-index)))
                              ((eq cert-op :convert-pcert) :irrelevant) ; unused
                              (t
                               (merge-into-expansion-alist
                                expansion-alist0
                                (car expansion-alist-and-index)))))))
        (cond
         (write-acl2x
          (assert$
           (not (eq cert-op :convert-pcert))

; See the Essay on .acl2x Files (Double Certification).  Below we will exit
; certify-book-fn, so the value returned here for pass1-result will be
; ignored.

           (write-acl2x-file expansion-alist acl2x-file ctx state)))
         (t
          (let ((expansion-alist
                 (cond ((or (eq cert-op :create-pcert)
                            (eq cert-op :convert-pcert))

; The value here is irrelevant for :convert-pcert.  We avoid eliding locals for
; :create-pcert (except when pcert = t, since then we are doing just what we
; would do for ordinary certification without pcert), hence we elide along the
; way); we'll take care of that later, after dealing with pkg-names to support
; reading the unelided expansion-alist members from the .pcert0 file during the
; Convert procedure.

                        expansion-alist)
                       (t (elide-locals-from-expansion-alist expansion-alist
                                                             nil)))))
            (value
             (list (let ((val (global-val 'skip-proofs-seen (w state))))
                     (and val

; Here we are trying to record whether there was a skip-proofs form in the
; present book or its portcullis commands, not merely on behalf of an included
; book.  The post-alist will record such information for included books, and is
; consulted by skipped-proofsp-in-post-alist.  See the comment about this
; comment in install-event.

                          (not (eq (car val) :include-book))))
                   portcullis-skipped-proofsp
                   (f-get-global 'axiomsp state)
                   (global-val 'ttags-seen (w state))
                   (global-val 'include-book-alist-all (w state))
                   expansion-alist

; The next form represents the part of the expansion-alist that needs to be
; checked for new packages, in the sense described above the call below of
; pkg-names.

                   (let ((index0 (cdr expansion-alist-and-index)))
                     (cond ((eq cert-op :convert-pcert)

; Presumably the packages defined in the portcullis commands of the .pcert0
; file, as computed by chk-acceptable-certify-book1, are sufficient for reading
; the expansion-alist.

                            nil)
                           ((integerp index0)
                            (restrict-expansion-alist index0 expansion-alist))
                           (t

; Index0 is essentially "infinity" -- eval-event-lst (on behalf of
; process-embedded-events) never found an extension of the known-package-alist.
; There is thus no part of expansion-alist that needs checking!

                            nil)))
                   (global-val 'translate-cert-data (w state)))))))))))))

(defun certify-book-convert-pcert (full-book-string full-book-name
                                                    user-book-name
                                                    familiar-name
                                                    portcullis-cmds0 cert-obj
                                                    ev-lst cert-annotations
                                                    post-alist1 ctx state)

; This function completes certify-book after step 2 when cert-op is
; :convert-pcert.

  (er-let* ((book-hash
             (book-hash nil full-book-string portcullis-cmds0
                        (access cert-obj cert-obj :expansion-alist)
                        (access cert-obj cert-obj :cert-data)
                        ev-lst state))
            (extra-entry (value (list* full-book-name
                                       user-book-name
                                       familiar-name
                                       cert-annotations
                                       book-hash))))
    (certify-book-finish-convert
     (cons extra-entry post-alist1)
     (access cert-obj cert-obj :post-alist)
     full-book-string ctx state)))

(defun certify-book-step-3-info (fast-cert-p wrld1 wrld-post-pass1)

; Return a tuple used in step 3 of certify-book.

  (let* ((rollback-pair ; nil or consp

; There is no rollback with fast-cert mode active, hence no rollback-pair.

          (and (not fast-cert-p)
               (global-val 'cert-replay wrld-post-pass1)))
         (index (assert$
                 (listp rollback-pair)

; If cert-replay was set while processing events in the book, then index is
; positive since the call of process-embedded-events above is made with index =
; 1 and index is incremented with each event in its main subroutine,
; eval-event-lst.

                 (and (posp (car rollback-pair))
                      (car rollback-pair))))
         (port-index

; When non-nil, this is how many of portcullis-cmds0 to discard before
; re-execution after the world is rolled back into the portcullis commands.
; Thus, we will be re-executing (nthcdr port-index portcullis-cmds0).  So for
; example, if we roll back through the first command after the boot-strap
; world, then we want to start with that first command, so port-index is 0; to
; start with the second command, port-index should be 1 so that we discard only
; the first; to start with the third command, then port-index should be 2; and
; so on.

          (and rollback-pair
               (not index)

; Note that (car rollback-pair) is the negative of the
; max-absolute-command-number at the point where 'cert-replay was set.

               (- (- (car (car rollback-pair)))
                  (access command-number-baseline-info
                          (global-val 'command-number-baseline-info
                                      wrld-post-pass1)
                          :original))))
         (port-non-localp
          (and port-index
               (not (cdr (car rollback-pair)))))
         (rollback-wrld
          (if rollback-pair
              (cdr rollback-pair)
            wrld1))
         (cert-data-pass1-saved
          (and

; When the variable rollback-pair is nil, we won't be including the book for
; the local incompatibility check.  Since cert-data-pass1-saved is only used
; during that include-book, we therefore won't need it either when
; rollback-pair is nil.

           rollback-pair
           (cert-data-pass1-saved
            (if index
                rollback-wrld

; In this case, where index is nil but rollback-pair is not, we know that
; port-index is non-nil -- we will roll back the world to rollback-wrld, which
; implies rolling back all events in the book and at least one portcullis
; command.  Should we include rolled-back events from the portcullis in the
; cert-data?  It seems that we could, but we aren't including other events from
; the portcullis, so that would be odd.  Those who want the use of cert-data to
; speed up include-book can restrict the portcullis commands to defpkg and
; include-book events.

              wrld1)
            wrld-post-pass1))))
    (mv rollback-pair index port-index
        port-non-localp
        rollback-wrld
        cert-data-pass1-saved)))

(defun certify-book-step-3+ (rollback-pair
                             rollback-wrld port-index portcullis-cmds0
                             compile-flg cert-op expansion-alist
                             acl2x-expansion-alist fast-cert-p
                             wrld1-known-package-alist index
                             cert-data-pass1-saved uncertified-okp
                             defaxioms-okp skip-proofs-okp ttags-seen
                             translate-cert-data expansion-alist-to-check
                             full-book-string post-alist1 directory-name ev-lst
                             full-book-name user-book-name familiar-name
                             cert-annotations pass1-known-package-alist
                             acl2x-file pre-alist-wrld1 k expansion-alist0
                             saved-acl2-defaults-table wrld1 event-data-channel
                             ctx state)

; This function completes book certification when cert-op is not
; :convert-pcert, starting at step 3, hence starting by possibly rolling back
; the world and including the book.

  #+acl2-loop-only
  (declare (ignore event-data-channel))
  (pprogn
   (cond
    (rollback-pair
     (set-w 'retraction rollback-wrld state))
    (t state))
   (let ((rollback-wrld-known-package-alist
          (and rollback-pair ; else don't care
               (global-val 'known-package-alist rollback-wrld))))
     (er-progn
      (if port-index
          (eval-some-portcullis-cmds port-index portcullis-cmds0 ctx state)
        (value nil))
      (pprogn
       #+(and gcl (not acl2-loop-only))

; In GCL, object code (from .o files) may be stored in read-only memory, which
; is not collected by sgc.  In particular, such code just loaded from
; include-book forms (during the admissibility check pass) is now garbage but
; may stay around awhile.  Ultimately one would expect GCL to do a full garbage
; collect when relocating the hole, but by then it may have allocated many
; pages unnecessarily; and pages are never deallocated.  By collecting garbage
; now, we may avoid the need to allocate many pages during this coming
; (include-book) pass of certification.

; However, it is far from clear that we are actually reclaiming the space we
; intend to reclaim.  So we may want to delete this code.  It seems to cost
; about 1/4 second per book certification for the ACL2 regression suite (as of
; 5/07).

       (progn
         (cond ((and (not *gcl-large-maxpages*)
                     (fboundp 'si::sgc-on)
                     (funcall 'si::sgc-on))
                (funcall 'si::sgc-on nil)
                (si::gbc t)
                (funcall 'si::sgc-on t))
               (t (si::gbc t)))
         state)
       (with-hcomp-bindings
        compile-flg

; It may seem strange to call with-hcomp-bindings here -- after all, we call
; include-book-fn below, and we may think that include-book-fn will ultimately
; call load-compiled-book, which calls with-hcomp-bindings.  However, when
; include-book-fn is called on behalf of certify-book, it avoids calling
; include-book-raw and hence avoids calling load-compiled-book; it processes
; events without first doing a load in raw Lisp.  It is up to us to bind the
; *hcomp-xxx* variables here, so that add-trip can use them as it is processing
; events on behalf of the call below of include-book-fn, where
; *inside-include-book-fn* is 'hcomp-build.

        (mv-let
          (expansion-alist pcert-info)
          (cond ((eq cert-op :create-pcert)
                 (elide-locals-and-split-expansion-alist
                  expansion-alist acl2x-expansion-alist
                  nil nil))
                (t (mv expansion-alist
                       (if (eq cert-op
                               :create+convert-pcert)
                           :proved
                         nil))))
          (er-let* ((portcullis-wrld
                     (value (if port-index (w state) wrld1)))
                    (pre-alist
                     (value (cond (fast-cert-p

; With fast-cert mode active, we don't roll back the world, so we might have
; local-include book commands in the certification world.  We punt and simply
; record nil here for the pre-alist, which forces us to rely on the build
; system to check that the included books from the portcullis commands (or at
; least those that would be included non-locally at include-book time) are all
; certified.  Future work could perhaps sort out which included books are local
; and hence to be ignored here.

                                   nil)
                                  (port-index (global-val 'include-book-alist
                                                          portcullis-wrld))
                                  (t pre-alist-wrld1))))
                    (portcullis-wrld-known-package-alist
                     (value (global-val 'known-package-alist portcullis-wrld)))
                    (defpkg-items

; We collect information on enough packages at the end of pass 1 to include
; those that would be missing if instead local events are skipped.  These
; packages may become hidden defpkgs; see new-defpkg-list below, and for a more
; thorough discussion see the Essay on Hidden Packages Added by Certify-book.

                      (if fast-cert-p
; We don't bother with hidden packages when fast-cert mode is active.
                          (value nil)
                        (defpkg-items
                          pass1-known-package-alist
                          (if rollback-pair
                              rollback-wrld-known-package-alist
                            wrld1-known-package-alist)
                          ctx portcullis-wrld state)))
                    (cltl-command-stack0
                     (value (if fast-cert-p
                                (compress-cltl-command-stack
                                 (global-val 'top-level-cltl-command-stack
                                             (w state)))

; If fast-cert mode is not active, then we will compute an appropriate
; cltl-command-stack later, when we need it.

                              nil)))
                    (declaim-list
                     (state-global-let*
                      ((ld-redefinition-action nil))

; Note that we do not bind connected-book-directory before calling
; include-book-fn, because it will bind it for us.  We leave the directory set
; as it was when we parsed user-book-name to get full-book-name, so that
; include-book-fn will parse user-book-name the same way again.

                      (er-progn
                       (hcomp-build-from-state (if fast-cert-p
                                                   cltl-command-stack0
                                                 (global-val
                                                  'top-level-cltl-command-stack
                                                  (w state)))
                                               state)
                       (cond
                        (rollback-pair
                         (include-book-fn
                          user-book-name state nil
                          (cons (if index ; rollback is into book
                                    (cert-include-expansion-alist
                                     index
                                     expansion-alist)
; Else the world is rolled back into the certification world.
                                  expansion-alist)
                                cert-data-pass1-saved)
                          uncertified-okp defaxioms-okp skip-proofs-okp
                          ttags-seen nil nil))
                        (t (get-declaim-list state))))))
                    (ignore (cond (rollback-pair

; There is a long comment in include-book-fn1 about not allowing
; "process-embedded-events to set the ACL2 defaults table at the end".  So if
; we are doing an include-book here, we take care of that setting explicitly,
; thus ensuring that the original acl2-defaults-table is in place after the
; include-book-fn call above.

                                   (maybe-install-acl2-defaults-table
                                    saved-acl2-defaults-table
                                    state))
                                  (t (value nil)))))
            (let* ((wrld2
; This is the world after include-book (if include-book was evaluated).
                    (w state))
                   (cltl-command-stack (if fast-cert-p
                                           cltl-command-stack0
                                         (global-val
                                          'top-level-cltl-command-stack
                                          wrld2)))
                   (new-fns (top-level-user-fns cltl-command-stack nil))
                   (cert-data-pass2 (cert-data-for-certificate
                                     new-fns translate-cert-data wrld2))
                   (pkg-names

; Warning: If the following comment is modified or deleted, visit its reference
; in pkg-names.  Also see the comments at the top of :doc note-3-2 for a
; discussion of this issue, and especially, for more context see the Essay on
; Hidden Packages Added by Certify-book.

; We may need to create a (hidden) defpkg after the portcullis commands in
; order to read the certificate's expansion-alist or cert-data before
; evaluating events from the book.  As long as there have been no new defpkg
; events in pass 1 since the end of the portcullis command evaluation, there is
; no problem.  (Note that make-event-fn calls bad-lisp-objectp to check that
; the expansion is readable after evaluating the make-event call, so there is
; no additional worry about packages introduced in support of those
; expansions.)  But once we get a new package during pass 1, any subsequent
; form in the expansion-alist may need that new package to be defined in order
; for ACL2 to read the expansion-alist from the .cert file.  Here we take the
; first step towards finding (hidden) packages that need to be added for the
; expansion-alist or cert-data.

; We use expansion-alist-to-check here, which is the part of expansion-alist
; after the first event in the book that added a package during pass 1 -- no
; earlier event is of concern here.

                    (pkg-names (cons expansion-alist-to-check cert-data-pass2)
                               portcullis-wrld-known-package-alist))
                   (new-defpkg-list
; See the Essay on Hidden Packages Added by Certify-book.
                    (new-defpkg-list defpkg-items
                                     (delete-names-from-kpa
                                      pkg-names
                                      (global-val 'known-package-alist wrld2))
                                     (if rollback-pair
                                         rollback-wrld-known-package-alist
                                       wrld1-known-package-alist)))
                   (include-book-alist-wrld2
                    (global-val 'include-book-alist wrld2))
                   (post-alist2 (cond (fast-cert-p

; We punt here as we do for post-alist1; see the comment on "punt" above for
; post-alist1.

                                       nil)
                                      (rollback-pair

; In this case, include-book-fn was evaluated above.  The following call of cdr
; removes the certification tuple stored by the include-book-fn itself.  That
; pair is guaranteed to be the car because it is the most recently added one
; (with add-to-set-equal) and we know it was not already a member of the list
; because chk-acceptable-certify-book1 checked that.  Could a file include
; itself?  It could try.  But if (include-book file) is one of the events in
; file, then the attempt to (include-book file) will cause infinite recursion
; -- because we don't put file on the list of files we've included (and hence
; recognize as redundant) until after we've completed the processing.

                                       (cdr include-book-alist-wrld2))
                                      (t include-book-alist-wrld2))))
              (fast-alist-free-cert-data-on-exit
               cert-data-pass2
               (pprogn
                (maybe-write-bookdata full-book-string full-book-name wrld2 ctx
                                      state)
                (mv-let
                  (new-bad-fns all-bad-fns)
                  (cond ((or fast-cert-p
                             (warning-disabled-p "Guards"))
                         (mv nil nil))
                        (t (mv (collect-ideals new-fns wrld2 nil)
                               (collect-ideal-user-defuns wrld2))))
                  (cond ((or new-bad-fns all-bad-fns)
                         (print-certify-book-guards-warning
                          full-book-string
                          new-bad-fns all-bad-fns
                          k ctx state))
                        (t state)))
                (er-progn
                 (chk-certify-book-step-3 post-alist2 post-alist1 ctx state)
                 (with-cbd

; This binding is for the call of compile-certified-file below, though perhaps
; there will be other uses.

                  directory-name
                  (pprogn
; Write certificate.
                   (print-certify-book-step-4 full-book-string cert-op state)
                   (er-let* ((portcullis-cmds
                              (value
                               (append? portcullis-cmds0 new-defpkg-list)))
                             (book-hash
                              (book-hash nil full-book-string portcullis-cmds
                                         expansion-alist cert-data-pass2 ev-lst
                                         state))
                             (extra-entry
                              (value (list* full-book-name
                                            user-book-name
                                            familiar-name
                                            cert-annotations
                                            book-hash)))

; It is important to write the compiled file before installing the certificate
; file, since "make" dependencies look for the .cert file, whose existence
; should thus imply the existence of an intended compiled file.  However, we
; need the compiled file to have a later write date (see load-compiled-book).
; So our approach if compile-flg is true is to write the certificate file
; first, but with a temporary name, and then move it to its final name after
; compilation (if any) has completed.

                             (temp-alist
                              (make-certificate-files
                               full-book-string
                               (cons portcullis-cmds pre-alist)
                               (cons extra-entry post-alist1)
                               (cons extra-entry post-alist2)
                               expansion-alist cert-data-pass2 pcert-info
                               cert-op ctx state))
                             (os-compiled-file
                              (cond
                               (compile-flg
; We only use the value of compile-flg when #-acl2-loop-only.
                                (pprogn
                                 (print-certify-book-step-5 full-book-string
                                                            state)
                                 (er-progn
                                  (write-expansion-file
                                   portcullis-cmds
                                   declaim-list new-fns cltl-command-stack
                                   (expansion-filename full-book-string)
                                   expansion-alist pkg-names ev-lst
                                   pass1-known-package-alist ctx state)
                                  #-acl2-loop-only
                                  (let* ((os-expansion-filename
                                          (pathname-unix-to-os
                                           (expansion-filename
                                            full-book-string)
                                           state))
                                         (os-compiled-file
                                          (compile-certified-file
                                           os-expansion-filename
                                           full-book-string
                                           state)))
                                    (when (not (f-get-global
                                                'save-expansion-file
                                                state))
                                      (delete-expansion-file
                                       os-expansion-filename
                                       full-book-string
                                       state))
                                    (value os-compiled-file)))))
                               (t
                                #-acl2-loop-only
                                (delete-auxiliary-book-files full-book-string)
                                (value nil)))))
                       (er-progn
                        #-acl2-loop-only
                        (progn
; Install temporary certificate file(s).
                          (delete-cert-files full-book-string)
                          (loop for pair in temp-alist
                                do
                                (rename-file
                                 (pathname-unix-to-os (car pair) state)
                                 (pathname-unix-to-os (cdr pair) state)))
                          (when event-data-channel
                            (let ((old (pathname-unix-to-os
                                        (event-data-filename full-book-string
                                                             t)
                                        state))
                                  (new (pathname-unix-to-os
                                        (event-data-filename full-book-string
                                                             nil)
                                        state)))
                              (when (probe-file new)
                                (delete-file new))
                              (rename-file old new)))
                          (when
                              (and
                               os-compiled-file

; Ensure that os-compiled-file is more recent than .cert file, since rename-file
; is not guaranteed to preserve the write-date.  We first check the
; file-write-date of the .cert file, since we have found that to be almost 3
; orders of magnitude faster than touch? in CCL.

                               (loop with
                                     compile-date =
                                     (file-write-date os-compiled-file)
                                     for pair in temp-alist
                                     thereis
                                     (< compile-date
                                        (file-write-date$ (cdr pair) state))))
                            (touch? os-compiled-file nil ctx state))
                          (value nil))
                        (pprogn
                         (cond
                          (expansion-alist0

; Note that we are not in the Convert procedure.  So we know that
; expansion-alist0 came from a .acl2x file, not a .pcert0 file.

                           (observation
                            ctx
                            "Used expansion-alist obtained from file ~x0."
                            acl2x-file))
                          (t state))
                         (value full-book-string))))))))))))))))))

(defun certify-book-fn (user-book-name k compile-flg defaxioms-okp
                                       skip-proofs-okp ttags ttagsx ttagsxp
                                       acl2x write-port pcert
                                       useless-runes-r/w useless-runes-r/w-p
                                       write-event-data write-event-data-p
                                       state)

; For a discussion of the addition of hidden defpkg events to the portcullis,
; see the Essay on Hidden Packages Added by Certify-book, above.  Also see the
; Essay on Fast-cert for discussion pertaining to fast-cert mode.

  (with-ctx-summarized
   (cons 'certify-book user-book-name)
   (er-progn
    (chk-acceptable-certify-book-prelim user-book-name acl2x ttagsxp ctx state)
    (state-global-let*
     ((warnings-as-errors nil))
     (save-parallelism-settings
      (er-let* ((pcert-env (cond ((eq pcert :default)
                                  (getenv! "ACL2_PCERT_ARG" state))
                                 (t (value nil))))
                (pcert (cond ((not pcert-env)
                              (value (if (eq pcert :default)
                                         nil
                                       pcert)))

; For the remaining cases we know pcert-env is not nil, hence pcert = :default.

                             ((string-equal pcert-env "T")
                              (value t))
                             (t (value (intern (string-upcase pcert-env)
                                               "KEYWORD")))))
                (ttags-seen0 (value (global-val 'ttags-seen (w state)))))
        (mv-let
          (full-book-string full-book-name directory-name familiar-name)
          (parse-book-name (cbd) user-book-name ".lisp" ctx state)
          (cond
           ((eq pcert :complete)
            (certify-book-finish-complete full-book-string full-book-name
                                          ctx state))
           (t
            (er-let* ((write-port
                       (certify-book-write-port write-port pcert ctx state))
                      (write-acl2x
                       (value (f-get-global 'write-acl2x state)))
                      (cert-op
                       (certify-book-cert-op pcert pcert-env write-acl2x ctx
                                             state))
                      (skip-proofs-okp
                       (value (cond ((eq skip-proofs-okp :default)
                                     (consp write-acl2x))
                                    (t skip-proofs-okp))))
                      (uncertified-okp (value (consp write-acl2x)))
                      (ttagsx (value (if ttagsxp ttagsx ttags)))
                      (ttags (chk-well-formed-ttags
                              (if write-acl2x ttagsx ttags)
                              (cbd) ctx state))
                      (ttags-allowed/ttags-seen-ignored
                       (chk-acceptable-ttags1

; We check whether the ttags in the certification world are legal for the given
; ttags, and if so we refine ttags, as described in chk-acceptable-ttag1.

                        ttags-seen0
                        nil ; correct active-book-name, but irrelevant
                        ttags
                        nil    ; irrelevant value for ttags-seen
                        :quiet ; ttags in cert. world: already reported
                        ctx state))
                      (event-data-channel
                       (if (member-eq cert-op '(t :convert-pcert
                                                  :create+convert-pcert))
                           (event-data-channel full-book-string
                                               write-event-data
                                               write-event-data-p ctx state)
                         (value nil)))
                      (certify-book-info-0
                       (value (make certify-book-info
                                    :full-book-name full-book-name
                                    :cert-op cert-op
                                    :event-data-channel event-data-channel))))
              (state-global-let*
               ((compiler-enabled (f-get-global 'compiler-enabled state))
                (port-file-enabled (f-get-global 'port-file-enabled state))
                (certify-book-info certify-book-info-0)
                (match-free-error nil)
                (defaxioms-okp-cert defaxioms-okp)
                (skip-proofs-okp-cert skip-proofs-okp)
                (guard-checking-on ; see Essay on Guard Checking
                 t))
               (er-let* ((compile-flg
                          (certify-book-compile-flg compile-flg cert-op ctx
                                                    state))
                         (saved-acl2-defaults-table
                          (value (table-alist 'acl2-defaults-table
                                              (w state))))

; If you add more keywords to this list, make sure you do the same to the list
; constructed by include-book-fn.

                         (suspect-book-action-alist
                          (value
                           (list (cons :uncertified-okp uncertified-okp)
                                 (cons :defaxioms-okp defaxioms-okp)
                                 (cons :skip-proofs-okp skip-proofs-okp))))
                         (cert-obj

; The following call can modify (w state) by evaluating portcullis commands
; from an existing certificate file.

                          (chk-acceptable-certify-book
                           user-book-name full-book-string full-book-name
                           directory-name suspect-book-action-alist cert-op k
                           ctx state))
                         (portcullis-cmds0 (value (access cert-obj cert-obj
                                                          :cmds)))
                         (old-useless-runes
                          (value (f-get-global 'useless-runes state)))
                         (useless-runes


; By now, we should have ensured that all portcullis commands have been run
; (consider the case of certify-book with k=t), so that packages are all
; available.

                          (initial-useless-runes full-book-string
                                                 useless-runes-r/w
                                                 useless-runes-r/w-p
                                                 nil ctx state))
                         (ignore (cond (write-port
                                        (write-port-file full-book-string
                                                         portcullis-cmds0
                                                         ctx state))
                                       (t (value nil)))))
                 (let* ((wrld1 ; from chk-acceptable-certify-book
                         (w state))
                        (pre-alist-wrld1
                         (global-val 'include-book-alist wrld1))
                        (wrld1-known-package-alist
                         (global-val 'known-package-alist wrld1))
                        (acl2x-file
                         (convert-book-string-to-acl2x full-book-string))
                        (fast-cert-mode (fast-cert-mode state))
                        (fast-cert-p

; Maybe later we'll support fast-cert for pcert, but not now.

                         (and (not pcert)
                              (eq fast-cert-mode t))))
                   (pprogn
                    (f-put-global 'useless-runes useless-runes state)
                    (print-certify-book-step-1 fast-cert-p full-book-string
                                               cert-op fast-cert-mode state)
                    (er-let* ((ev-lst
                               (let (#-acl2-loop-only
                                     (*acl2-error-msg*
                                      *acl2-error-msg-certify-book-step1*))
                                 (read-object-file full-book-string ctx
                                                   state)))
                              (acl2x-expansion-alist
; See the Essay on .acl2x Files (Double Certification).
                               (cond (write-acl2x (value nil))
                                     (t (read-acl2x-file acl2x-file
                                                         full-book-string
                                                         (length ev-lst)
                                                         acl2x ctx state))))
                              (expansion-alist0
                               (certify-book-expansion-alist0
                                cert-op cert-obj acl2x-expansion-alist
                                full-book-string acl2x-file ctx state))
                              (pass1-result ; processes events
                               (certify-book-step-2
                                ev-lst expansion-alist0 cert-op
                                full-book-string acl2x-file
                                (car ttags-allowed/ttags-seen-ignored)
                                wrld1 directory-name write-acl2x
                                full-book-name saved-acl2-defaults-table ctx
                                state)))
                      (cond
                       (write-acl2x ; early exit
                        (value acl2x-file))
                       (t
                        (let* ((pass1-known-package-alist
                                (global-val 'known-package-alist (w state)))
                               (skipped-proofsp
                                (nth 0 pass1-result))
                               (portcullis-skipped-proofsp
                                (nth 1 pass1-result))
                               (axiomsp
                                (nth 2 pass1-result))
                               (ttags-seen
                                (nth 3 pass1-result))
                               (new-include-book-alist-all
                                (nth 4 pass1-result))
                               (expansion-alist
                                (nth 5 pass1-result))
                               (expansion-alist-to-check
                                (nth 6 pass1-result))
                               (translate-cert-data
                                (nth 7 pass1-result))
                               (cert-annotations
                                (list

; We set :skipped-proofsp in the certification annotations to t or nil
; according to whether there were any skipped proofs in either the
; portcullis or the body of this book (not subbooks).

                                 (cons :skipped-proofsp skipped-proofsp)

; We similarly set :axiomsp to t or nil.  As above, subbooks are not considered
; here.

                                 (cons :axiomsp axiomsp)
                                 (cons :ttags ttags-seen)))
                               (post-alist1 (if fast-cert-p

; With fast-cert mode active, we don't roll back the world, so we might have
; local-include book commands in the world.  We punt and simply record nil here
; for this post-alist, which forces us to rely on the build system to check
; that the included books (or at least those that would be included non-locally
; at include-book time) are all certified.  Future work could perhaps sort out
; which included books are local and hence to be ignored here.

                                                nil
                                              new-include-book-alist-all)))
                          (er-progn
                           (chk-cert-annotations
                            cert-annotations portcullis-skipped-proofsp
                            portcullis-cmds0 full-book-string
                            suspect-book-action-alist ctx state)
                           (cond
                            ((eq cert-op :convert-pcert)
                             (certify-book-convert-pcert
                              full-book-string full-book-name user-book-name
                              familiar-name portcullis-cmds0 cert-obj ev-lst
                              cert-annotations post-alist1 ctx
                              state))
                            (t
                             (mv-let
                               (rollback-pair index port-index
                                              port-non-localp
                                              rollback-wrld
                                              cert-data-pass1-saved)
                               (certify-book-step-3-info fast-cert-p wrld1
                                                         (w state))
                               (fast-alist-free-cert-data-on-exit
                                cert-data-pass1-saved
                                (pprogn
                                 (update-useless-runes old-useless-runes state)
                                 (if event-data-channel
                                     (close-output-channel event-data-channel
                                                           state)
                                   state)
                                 (print-certify-book-step-3 index
                                                            port-index
                                                            port-non-localp
                                                            state)
                                 (certify-book-step-3+
                                  rollback-pair rollback-wrld port-index
                                  portcullis-cmds0 compile-flg cert-op
                                  expansion-alist acl2x-expansion-alist
                                  fast-cert-p wrld1-known-package-alist index
                                  cert-data-pass1-saved uncertified-okp
                                  defaxioms-okp skip-proofs-okp ttags-seen
                                  translate-cert-data expansion-alist-to-check
                                  full-book-string post-alist1 directory-name
                                  ev-lst full-book-name user-book-name
                                  familiar-name cert-annotations
                                  pass1-known-package-alist acl2x-file
                                  pre-alist-wrld1 k expansion-alist0
                                  saved-acl2-defaults-table wrld1
                                  event-data-channel ctx
                                  state)))))))))))))))))))))))))

#+acl2-loop-only
(defmacro certify-book (user-book-name
                        &optional
                        (k '0)
                        (compile-flg ':default)
                        &key
                        (defaxioms-okp 'nil)
                        (skip-proofs-okp ':default)
                        (ttags 'nil)
                        (ttagsx 'nil ttagsxp)
                        (acl2x 'nil)
                        (write-port ':default)
                        (pcert ':default)
                        (useless-runes 'nil useless-runes-p)
                        (write-event-data 'nil write-event-data-p))
  (declare (xargs :guard (and (booleanp acl2x)
                              (member-eq compile-flg
                                         '(nil t :all

; We allow :default as a way for generated certify-book commands to specify
; explicitly that they take compile-flg from environment variable
; ACL2_COMPILE_FLG.

                                               :default)))))
  (list 'certify-book-fn
        (list 'quote user-book-name)
        (list 'quote k)
        (list 'quote compile-flg)
        (list 'quote defaxioms-okp)
        (list 'quote skip-proofs-okp)
        (list 'quote ttags)
        (list 'quote ttagsx)
        (list 'quote ttagsxp)
        (list 'quote acl2x)
        (list 'quote write-port)
        (list 'quote pcert)
        (list 'quote useless-runes)
        (list 'quote useless-runes-p)
        (list 'quote write-event-data)
        (list 'quote write-event-data-p)
        'state))

(defmacro certify-book! (user-book-name &optional
                                        (k '0)
                                        (compile-flg 't compile-flg-supplied-p)
                                        &rest args)
  (declare (xargs :guard (and (integerp k) (<= 0 k))))
  `(er-progn (ubt! ,(1+ k))
             ,(if compile-flg-supplied-p
                  `(certify-book ,user-book-name ,k ,compile-flg ,@args)
                `(certify-book ,user-book-name ,k))))

; Next we implement defchoose and defun-sk.

(defun redundant-defchoosep (name event-form wrld)
  (let* ((old-ev (get-event name wrld)))
    (and
     old-ev
     (case-match old-ev
       (('defchoose !name old-bound-vars old-free-vars old-body . old-rest)
        (case-match event-form
          (('defchoose !name new-bound-vars new-free-vars new-body . new-rest)
           (and (equal old-bound-vars new-bound-vars)
                (equal old-free-vars new-free-vars)
                (equal old-body new-body)
                (eq (cadr (assoc-keyword :strengthen old-rest))
                    (cadr (assoc-keyword :strengthen new-rest)))))))))))

(defun chk-arglist-for-defchoose (args bound-vars-flg ctx state)
  (cond ((arglistp args) (value nil))
        ((not (true-listp args))
         (er soft ctx
             "The ~#0~[bound~/free~] variables of a DEFCHOOSE event must be a ~
              true list but ~x1 is not."
             (if bound-vars-flg 0 1)
             args))
        (t (mv-let (culprit explan)
                   (find-first-bad-arg args)
                   (er soft ctx
                       "The ~#0~[bound~/free~] variables of a DEFCHOOSE event ~
                        must be a true list of distinct, legal variable names.  ~
                        ~x1 is not such a list.  The element ~x2 violates the ~
                        rules because it ~@3."
                       (if bound-vars-flg 0 1)
                       args culprit explan)))))

(defun without-warnings-fn (form)
  `(state-global-let*
    ((inhibit-output-lst (f-get-global 'inhibit-output-lst state)))
    (pprogn
     (f-put-global 'inhibit-output-lst
                   (add-to-set-eq 'warning
                                  (f-get-global 'inhibit-output-lst state))
                   state)
     ,form)))

(defmacro without-warnings (form)
  (without-warnings-fn form))

(defun translate-ignore-ok (x stobjs-out logic-modep known-stobjs ctx w state)
  (let ((w (putprop 'acl2-defaults-table 'table-alist
                    (put-assoc-equal-fast :ignore-ok t
                                          (table-alist 'acl2-defaults-table w))
                    w)))
    (translate x stobjs-out logic-modep known-stobjs ctx w state)))

(defmacro translate-without-warnings-ignore-ok (&rest args)

; To see why we may want to turn off warnings during translate, consider the
; following example.

;   (set-ignore-ok :warn)
;   (defchoose foo (x) (y z) (< 0 y))

; We expect a warning saying that x and z are unused.  But we don't want a
; second warning like the following from defchoose-constraint's use of
; translate, because it will make no sense to the user:

;   ACL2 Warning [Ignored-variables] in ( DEFCHOOSE FOO ...):  The variable
;   X is not used in the body of the LET expression that binds X.  But
;   X is not declared IGNOREd or IGNORABLE.  See :DOC set-ignore-ok.

; Additionally, because the body of the defchoose is already translated, we
; lose IGNORABLE declarations from inside it.  IGNORE declarations are dealt
; with by wrapping the lambda argument in HIDE, but we don't have such a hack
; for dealing with IGNORABLE.  So we actually set IGNORE-OK to T temporarily
; here to avoid erroring out in such cases.  Otherwise, the following form will
; unexpectedly produce an error:

; (defchoose foo (x) () (let ((y nil)) (declare (ignorable y)) (consp x)))

; Do we need to inhibit warnings given that we're turning on ignore-ok?  The
; user code on which this is run has already been translated, so any legitimate
; warnings for that have already been issued.  Any new warnings from this
; translation would therefore be either artifacts from re-translating the
; translation of the user code, or else warnings about the system code wrapped
; around it, neither of which the user will want to see.

  `(without-warnings (translate-ignore-ok ,@args)))

(defun defchoose-constraint-basic (fn bound-vars formals tbody ctx wrld state)

; It seems a pity to translate tbody, since it's already translated, but that
; seems much simpler than the alternatives.

  (cond
   ((null (cdr bound-vars))
    (er-let*
     ((consequent (translate-without-warnings-ignore-ok
                   `(let ((,(car bound-vars) ,(cons fn formals)))
                      ,tbody)
                   t t t ctx wrld state)))
     (value (fcons-term*
             'implies
             tbody
             consequent))))
   (t
    (er-let*
     ((consequent (translate-without-warnings-ignore-ok
                   `(mv-let ,bound-vars
                            ,(cons fn formals)
                            ,tbody)
                   t t t ctx wrld state)))
     (value (fcons-term*
             'if

; We originally needed the following true-listp conjunct in order to prove
; guard conjectures generated by mv-nth in defun-sk.  After v4-1, we tried
; removing it, but regression failed at lemma Bezout1-property in community
; book books/workshops/2006/cowles-gamboa-euclid/Euclid/ed3.lisp.  So we have
; avoided making a change here after v4-1, after all.

             (fcons-term*
              'true-listp
              (cons-term fn formals))
             (fcons-term*
              'implies
              tbody
              consequent)
             *nil*))))))

(defun generate-variable-lst-simple (var-lst avoid-lst)

; This is a simple variant of generate-variable-lst, to apply to a list of
; variables.

  (cond ((null var-lst) nil)
        (t
         (let ((old-var (car var-lst)))
           (mv-let (str n)
                   (strip-final-digits (symbol-name old-var))
                   (let ((new-var
                          (genvar (find-pkg-witness old-var) str (1+ n)
                                  avoid-lst)))
                     (cons new-var (generate-variable-lst-simple
                                    (cdr var-lst)
                                    (cons new-var avoid-lst)))))))))

(defun defchoose-constraint-extra (fn bound-vars formals body)

; WARNING: If the following comment is removed, then eliminate the reference to
; it in :doc defchoose.

; Note that :doc conservativity-of-defchoose contains an argument showing that
; we may assume that there is a definable enumeration, enum, of the universe.
; Thus, for any definable property that is not always false, there is a "least"
; witness, i.e., a least n for which (enum n) satisfies that property.  Thus, a
; function defined with defchoose is definable: pick the least witness if there
; is one, else nil.  From this definition it is clear that the following
; formula holds, where formals2 is a copy of formals that is disjoint both from
; formals and from bound-vars, and where tbody2 is the result of replacing
; formals by formals2 in tbody, the translated body of the defchoose.  (If
; bound-vars is a list of length 1, then we use let rather than mv-let in this
; formula.)

; (or (equal (fn . formals)
;            (fn . formals2))
;     (mv-let (bound-vars (fn . formals))
;       (and tbody
;            (not tbody2)))
;     (mv-let (bound-vars (fn . formals2))
;       (and tbody2
;            (not tbody1))))

; We now outline an argument for the :non-standard-analysis case, which in fact
; provides justification for both defchoose axioms.  The idea is to assume that
; there is a suitable well-ordering for the ground-zero theory and that the
; ground-zero theory contains enough "invisible" functions so that this
; property is preserved by extensions (as discussed in the JAR paper "Theory
; Extensions in ACL2(r) by Gamboa and Cowles).  Here is a little more detail,
; but a nice challenge is to work this out completely.

; The idea of the proof is first to start with what the above paper calls an
; "r-complete" GZ: basically, a ground-zero theory satisfying induction and
; transfer that contains a function symbol for each defun and defun-std.  We
; can preserve r-completeness as we add defun, defun-std, encapsulate, and
; defchoose events (again, as in the above paper).  The key idea for defchoose
; is that GZ should also have a binary symbol, <|, that is axiomatized to be a
; total order.  That is, <| is a "definable well order", in the sense that
; there are axioms that guarantee for each phi(x) that (exists x phi) implies
; that (exists <|-least x phi).  The trick is to add the well-ordering after
; taking a nonstandard elementary extension of the standard reals MS, where
; every function over the reals is represented in MS as the interpretation of a
; function symbol.

; Still as in the above paper, there is a definable fn for the above defchoose,
; obtained by picking the least witness.  Moreover, if body is classical then
; we can first conjoin it with (standard-p bound-var), choose the <|-least
; bound-var with a classical function using defun-std, and then show by
; transfer that this function witnesses the original defchoose.

  (let* ((formals2 (generate-variable-lst-simple formals
                                                 (append bound-vars formals)))
         (body2
          `(let ,(pairlis$ formals (pairlis$ formals2 nil))
             ,body))
         (equality `(equal (,fn ,@formals) (,fn ,@formals2))))
    (cond ((null (cdr bound-vars))
           (let ((bound-var (car bound-vars)))
             `(or ,equality
                  (let ((,bound-var (,fn ,@formals)))
                    (and ,body (not ,body2)))
                  (let ((,bound-var (,fn ,@formals2)))
                    (and ,body2 (not ,body))))))
          (t
           `(or ,equality
                (mv-let (,@bound-vars)
                        (,fn ,@formals)
                        (and ,body (not ,body2)))
                (mv-let (,@bound-vars)
                        (,fn ,@formals2)
                        (and ,body2 (not ,body))))))))

(defun defchoose-constraint (fn bound-vars formals body tbody strengthen ctx
                                wrld state)
  (er-let* ((basic (defchoose-constraint-basic fn bound-vars formals tbody ctx
                     wrld state)))
           (cond
            (strengthen
             (er-let* ((extra
                        (translate-without-warnings-ignore-ok
                         (defchoose-constraint-extra fn bound-vars formals
                           body)
                         t t t ctx wrld state)))
               (value (conjoin2 basic extra))))
            (t (value basic)))))

(defun defchoose-fn (def state event-form)

; Warning: If this event ever generates proof obligations, remove it from the
; list of exceptions in install-event just below its "Comment on irrelevance of
; skip-proofs".

  (declare (xargs :guard (true-listp def))) ; def comes from macro call
  (when-logic
   "DEFCHOOSE"
   (with-ctx-summarized
    (cons 'defchoose (car def))
    (let* ((wrld (w state))
           (event-form (or event-form (cons 'defchoose def)))
           (raw-bound-vars (cadr def))
           (valid-keywords '(:strengthen))
           (ka (nthcdr 4 def)) ; def is the argument list of a defchoose call
           (kap (keyword-value-listp ka))
           (strengthen (and kap
                            (cadr (assoc-keyword :strengthen ka)))))
      (er-progn
       (chk-all-but-new-name (car def) ctx 'constrained-function wrld state)
       (cond
        ((not (and kap
                   (null (strip-keyword-list valid-keywords ka))))
         (er soft ctx
             "Defchoose forms must have the form (defchoose fn bound-vars ~
              formals body), with optional keyword argument~#0~[~/s~] ~&0.  ~
              However, ~x1 does not have this form.  See :DOC defchoose."
             valid-keywords
             event-form))
        ((not (booleanp strengthen))
         (er soft ctx
             "The :strengthen argument of a defchoose event must be t or nil. ~
              The event ~x0 is thus illegal."
             event-form))
        ((redundant-defchoosep (car def) event-form wrld)
         (stop-redundant-event ctx state
                               :name (car def)))
        (t
         (enforce-redundancy
          event-form ctx wrld
          (cond
           ((null raw-bound-vars)
            (er soft ctx
                "The bound variables of a defchoose form must be non-empty.  ~
                 The form ~x0 is therefore illegal."
                event-form))
           (t
            (let ((fn (car def))
                  (bound-vars (if (atom raw-bound-vars)
                                  (list raw-bound-vars)
                                raw-bound-vars))
                  (formals (caddr def))
                  (body (cadddr def)))
              (er-progn
               (chk-arglist-for-defchoose bound-vars t ctx state)
               (chk-arglist-for-defchoose formals nil ctx state)
               (er-let* ((tbody (translate body t t t ctx wrld state))
                         (wrld (chk-just-new-name fn nil 'function nil ctx wrld
                                                  state)))
                 (cond
                  ((intersectp-eq bound-vars formals)
                   (er soft ctx
                       "The bound and free variables of a defchoose form must ~
                        not intersect, but their intersection for the form ~
                        ~x0 is ~x1."
                       event-form
                       (intersection-eq bound-vars formals)))
                  (t
                   (let* ((body-vars (all-vars tbody))
                          (bound-and-free-vars (append bound-vars formals))
                          (ignored (set-difference-eq bound-and-free-vars
                                                      body-vars))
                          (ignore-ok (cdr (assoc-eq
                                           :ignore-ok
                                           (table-alist 'acl2-defaults-table
                                                        wrld))))
                          (ignored-vars-string
                           "The variable~#0~[ ~&0~ does~/s ~&0 do~] not occur ~
                            in the body of the form ~x1.  However, ~#0~[this ~
                            variable~/each of these variables~] appears in ~
                            the bound variables or the formals of that form.  ~
                            In order to avoid this error, see :DOC ~
                            set-ignore-ok."))
                     (cond
                      ((not (subsetp-eq body-vars bound-and-free-vars))
                       (er soft ctx
                           "All variables in the body of a defchoose form ~
                            must appear among the bound or free variables ~
                            supplied in that form.  However, the ~
                            ~#0~[variable ~x0 does~/variables ~&0 do~] not ~
                            appear in the bound or free variables of the form ~
                            ~x1, even though ~#0~[it appears~/they appear~] ~
                            in its body."
                           (reverse
                            (set-difference-eq body-vars bound-and-free-vars))
                           event-form))
                      ((and ignored
                            (null ignore-ok))
                       (er soft ctx
                           ignored-vars-string
                           ignored event-form))
                      (t
                       (pprogn
                        (cond
                         ((and ignored
                               (eq ignore-ok :warn))
                          (warning$ ctx "Ignored-variables"
                                    ignored-vars-string
                                    ignored event-form))
                         (t state))
                        (let* ((stobjs-in
                                (compute-stobj-flags formals nil nil wrld))
                               (stobjs-out
                                (compute-stobj-flags bound-vars nil nil wrld))
                               (wrld
                                #+:non-standard-analysis
                                (putprop
                                 fn 'classicalp
                                 (classical-fn-list-p (all-fnnames tbody) wrld)
                                 wrld)
                                #-:non-standard-analysis
                                wrld)
                               (wrld
                                (putprop
                                 fn 'constrainedp t
                                 (putprop
                                  fn 'hereditarily-constrained-fnnames
                                  (list fn)
                                  (putprop
                                   fn 'symbol-class
                                   :common-lisp-compliant
                                   (putprop-unless
                                    fn 'stobjs-out stobjs-out nil
                                    (putprop-unless
                                     fn 'stobjs-in stobjs-in nil
                                     (putprop
                                      fn 'formals formals
                                      wrld))))))))
                          (er-let*
                              ((constraint
                                (defchoose-constraint
                                  fn bound-vars formals body tbody strengthen
                                  ctx wrld state)))
                            (install-event fn
                                           event-form
                                           'defchoose
                                           fn
                                           nil
                                           `(defuns nil nil

; Keep the following in sync with intro-udf-lst2.

                                              (,fn
                                               ,formals
                                               ,(null-body-er fn formals nil)))
                                           :protect
                                           ctx
                                           (putprop
                                            fn 'defchoose-axiom constraint
                                            wrld)
                                           state))))))))))))))))))))))

(defconst *defun-sk-keywords*
  '(:quant-ok :skolem-name :thm-name :rewrite :strengthen
              :constrain :verbose
              #+:non-standard-analysis :classicalp))

(defun non-acceptable-defun-sk-p (name args body quant-ok rewrite exists-p
                                       dcls)

; Since this is just a macro, we only do a little bit of vanilla checking,
; leaving it to the real events to implement the most rigorous checks.

  (let ((bound-vars (and (true-listp body) ;this is to guard cadr
                         (cadr body)
                         (if (atom (cadr body))
                             (list (cadr body))
                           (cadr body)))))
    (cond
     ((and rewrite exists-p)
      (msg "It is illegal to supply a :rewrite argument for a defun-sk form ~
            that uses the exists quantifier.  See :DOC defun-sk."))
     ((and (keywordp rewrite)
           (not (member-eq rewrite '(:direct :default))))
      (msg "The only legal keyword values for the :rewrite argument of a ~
            defun-sk are :direct and :default.  ~x0 is thus illegal."
           rewrite))
     ((not (and (plausible-dclsp dcls)
                (not (get-string dcls))))
      (let ((str "The ~@0 of a DEFUN-SK event must be of the form (dcl ... ~
                  dcl), where each dcl is a DECLARE form.  The DECLARE forms ~
                  may contain TYPE, IGNORE, and XARGS entries, where the ~
                  legal XARGS keys are ~&1.  The following value for the ~@0 ~
                  is thus illegal: ~x2. See :DOC DEFUN-SK."))
        (msg str
             "DECLARE forms"
             *xargs-keywords*
             dcls)))
     ((not (true-listp args))
      (msg "The second argument of DEFUN-SK must be a true list of legal ~
            variable names, but ~x0 is not a true-listp."
           args))
     ((not (arglistp args))
      (mv-let
        (culprit explan)
        (find-first-bad-arg args)
        (msg "The formal parameters (second argument) of a DEFUN-SK form must ~
             be a true list of distinct, legal variable names.  ~x0 is not ~
             such a list.  The element ~x1 violates the rules because it ~@2."
             args culprit explan)))
     ((not (and (true-listp body)
                (equal (length body) 3)
                (member-eq (car body) '(forall exists))
                (true-listp bound-vars)
                (null (collect-non-legal-variableps bound-vars))))
      (msg "The body (last argument) of a DEFUN-SK form must be a true list of ~
            the form (Q vars term), where Q is ~x0 or ~x1 and vars is a ~
            variable or a true list of variables.  The body ~x2 is therefore ~
            illegal."
           'forall 'exists body))
     ((member-eq 'state bound-vars)
      (msg "The body (last argument) of a DEFUN-SK form must be a true list of ~
            the form (Q vars term), where vars represents the bound ~
            variables.  The bound variables must not include STATE.  The body ~
            ~x0 is therefore illegal."
           body))
     ((null (cadr body))
      (msg "The variables of the body of a DEFUN-SK, following the quantifier ~
            EXISTS or FORALL, must be a non-empty list.  However, in DEFUN-SK ~
            of ~x0, they are empty."
           name))
     ((intersectp-eq bound-vars args)
      (msg "The formal parameters of a DEFUN-SK form must be disjoint from ~
            the variables bound by its body.  However, the ~#0~[variable ~x0 ~
            belongs~/variables ~&0 belong~] to both the formal parameters, ~
            ~x1, and the bound variables, ~x2."
           (intersection-eq bound-vars args)
           args bound-vars))
     ((and (not quant-ok)
           (or (tree-occur-eq 'forall (caddr body))
               (tree-occur-eq 'exists (caddr body))))
      (msg "The symbol ~x0 occurs in the term you have supplied to DEFUN-SK, ~
            namely, ~x1.  By default, this is not allowed.  Perhaps you ~
            believe that DEFUN-SK can appropriately handle quantifiers other ~
            than one outermost quantifier; however, this is not the case.  If ~
            however you really intend this DEFUN-SK form to be executed, ~
            simply give a non-nil :quant-ok argument.  See :DOC defun-sk."
           (if (tree-occur-eq 'forall (caddr body))
               'forall
             'exists)
           body))
     (t nil))))

(defun definition-rule-name (name)
  (declare (xargs :guard (symbolp name)))
  (add-suffix name "-DEFINITION"))

(defmacro verify-guards? (guard-p &rest args)

; The form (verify-guards? <flg> <fn> ...) causes guard verification of <fn> to
; take place under the same conditions for it to take place when <fn> is
; defined except for ignoring the :verify-guards xargs and where <flg> is t iff
; there is a :guard xarg.  Thus, it is up to the caller to supply an
; appropriate value for guard-p, which probably makes this macro not very
; useful in general (hence it is not documented), though it is just what is
; needed in defun-sk-fn.

  (declare (xargs :guard (booleanp guard-p)))
  (cond
   (guard-p
    `(make-event
      (if (int= (default-verify-guards-eagerness (w state))
                0)
          '(value-triple :skipped)
        '(verify-guards ,@args))
      :expansion? ; Don't store expansion if eagerness is 1 (the default).
      (verify-guards ,@args)))
   (t
    `(make-event
      (if (member (default-verify-guards-eagerness (w state))
                  '(2 3))
          '(verify-guards ,@args)
        '(value-triple :skipped))
      :expansion? ; Don't store expansion if eagerness is 1 (the default).
      (value-triple :skipped)))))

(defun parse-defun-sk-dcls (dcls)

; This function returns multiple values (mv erp guard-p verify-guards-p
; non-exec-p guard-hints dcls), where if erp is non-nil then it is a message
; suitable for a ~@ fmt directive, and otherwise:

; - guard-p is t if dcls contains a type declaration or a :guard xarg, else is
;   nil;
; - verify-guards-p is t or nil if dcls uniquely associates xargs
;  :verify-guards with t or nil, respectively, and otherwise is '?;
; - non-exec-p is t if :non-executable is uniquely associated with t in dcls,
;   else is nil;
; - guard-hints is the unique supplied value of :guard-hints if any, else is
;   nil; and
; - dcls results from the input dcls by ensuring that :verify-guards has value
;   nil and if the :guard is t (implicitly or explicitly), it is listed first
;   in its own declare form.

; Note that erp is non-nil if any of :verify-guards, :non-executable, or
; :guard-hints is associated with two or more distinct values in dcls.

; The reason we put :guard t in its own declare form is to assist in redundancy
; checking.  This is a bit of overkill in general, since we don't expect two
; defun-sk calls to be the same except for the placement of (equivalent)
; declarations.  But when the first defun-sk specifies :guard t and the second
; specifies no guard, then we would like these to generate the same inner
; encapsulate, where :verify-guards nil is specified on the defun (guard
; verification comes after the inner encapsulate).

  (let* ((guard-p (and (fetch-dcl-fields '(type :guard) dcls) t))
         (verify-guards-fields (remove-duplicates-equal
                                (fetch-dcl-field :verify-guards dcls)))
         (verify-guards-p (cond ((equal verify-guards-fields '(t)) t)
                                ((equal verify-guards-fields '(nil)) nil)
                                ((equal verify-guards-fields nil) '?)
                                (t 'error)))
         (non-exec-p-fields (remove-duplicates-equal
                             (fetch-dcl-field :non-executable dcls)))
         (non-exec-p (cond ((cdr non-exec-p-fields) 'error)
                           ((consp non-exec-p-fields)
                            (car non-exec-p-fields))
                           (t t)))
         (guard-hints-fields (fetch-dcl-field :guard-hints dcls))
         (guard-hints (cond ((cdr guard-hints-fields) 'error)
                            (t (car guard-hints-fields))))
         (dcls (cons '(declare (xargs :verify-guards nil))
                     (strip-dcls '(:guard-hints)
                                 (if (eq verify-guards-p t)
                                     (strip-dcls '(:verify-guards) dcls)
                                   dcls))))
         (dcls (let ((guards (fetch-dcl-fields '(:guard) dcls)))
                 (cond ((member-equal guards '((t) ('t) nil))
                        (cons `(declare (xargs :guard t))
                              (strip-dcls '(:guard) dcls)))
                       (t dcls)))))
    (cond ((or (eq verify-guards-p 'error)
               (eq non-exec-p 'error)
               (eq guard-hints 'error))
           (mv (msg "There are at least two~#0~[~/ distinct~] values ~
                     associated with XARGS declaration keyword ~x1.  See :DOC ~
                     defun-sk."
                    (if (eq guard-hints 'error) 0 1)
                    (if (eq verify-guards-p 'error)
                        :verify-guards
                      (if (eq non-exec-p 'error)
                          :non-executable
                        :guard-hints)))
               nil nil nil nil nil))
          (t (mv nil guard-p verify-guards-p non-exec-p guard-hints dcls)))))

(defun map-with-output (kwd arg forms)
  (declare (xargs :guard (true-listp forms)))
  (pairlis-x1 'with-output
              (pairlis-x1 kwd
                          (pairlis-x1 arg
                                      (pairlis$ forms nil)))))

(defun defun-sk-fn (form name args rest)

; Warning: Keep this function in sync with make-apply$-warrant-defun-sk.  For
; an explanation, see the comment below about the 5th element.

  (declare (xargs :mode :program))
  (let ((ctx `(defun-sk . ,name)))
    (mv-let
      (erp dcls-and-body keyword-alist)
      (partition-rest-and-keyword-args rest *defun-sk-keywords*)
      (cond
       (erp

; If the defstobj has been admitted, this won't happen.

        (er hard ctx
            "The keyword arguments to the DEFUN-SK event must appear after ~
             the body.  The allowed keyword arguments are ~&0, and these may ~
             not be duplicated.  Thus, ~x1 is ill-formed."
            *defun-sk-keywords*
            form))
       (t
        (let* ((quant-ok (cdr (assoc-eq :quant-ok keyword-alist)))
               (skolem-name (cdr (assoc-eq :skolem-name keyword-alist)))
               (thm-name (cdr (assoc-eq :thm-name keyword-alist)))
               (constrained-pair (assoc-eq :constrain keyword-alist))
               (constrained (cdr constrained-pair))
               (verbose (cdr (assoc-eq :verbose keyword-alist)))
               (def-name (cond ((eq constrained t)
                                (definition-rule-name name))
                               ((symbolp constrained)
                                constrained)
                               (t (er hard ctx
                                      "The :constrain argument of DEFUN-SK ~
                                       must be a symbol, but ~x0 is not."
                                      constrained))))
               (rewrite (cdr (assoc-eq :rewrite keyword-alist)))
               (strengthen (cdr (assoc-eq :strengthen keyword-alist)))
               #+:non-standard-analysis
               (classicalp-p (and (assoc-eq :classicalp keyword-alist) t))
               #+:non-standard-analysis
               (classicalp (let ((pair (assoc-eq :classicalp keyword-alist)))
                             (if pair
                                 (cdr pair)
                               t)))
               (dcls0 (butlast dcls-and-body 1))
               (body (car (last dcls-and-body)))
               (exists-p (and (true-listp body)
                              (eq (car body) 'exists)))
               (msg (non-acceptable-defun-sk-p name args body quant-ok rewrite
                                               exists-p dcls0)))
          (if msg
              `(er soft ',ctx "~@0" ',msg)
            (mv-let (erp guard-p verify-guards-p non-exec-p guard-hints dcls)
              (parse-defun-sk-dcls dcls0)
              (if erp ; a msgp
                  `(er soft ',ctx "~@0" ',erp)
                (let* ((bound-vars (and (true-listp body)
                                        (or (symbolp (cadr body))
                                            (true-listp (cadr body)))
                                        (cond ((atom (cadr body))
                                               (list (cadr body)))
                                              (t (cadr body)))))
                       (body-guts (and (true-listp body) (caddr body)))
                       (defchoose-body (if exists-p
                                           body-guts
                                         `(not ,body-guts)))
                       (skolem-name
                        (or skolem-name
                            (add-suffix name "-WITNESS")))
                       (stobjs (fetch-dcl-field :STOBJS dcls))
                       (dfs (fetch-dcl-field :DFS dcls))
                       (skolem-call `(,skolem-name ,@args))
                       (skolem-call (if (or stobjs dfs)
                                        `(non-exec ,skolem-call)
                                      skolem-call))
                       (defun-body
                         (if (= (length bound-vars) 1)
                             `(let ((,(car bound-vars) ,skolem-call))
                                ,body-guts)
                           `(mv-let (,@bound-vars)
                              ,skolem-call
                              ,body-guts)))
                       (thm-name
                        (or thm-name
                            (add-suffix name
                                        (if exists-p "-SUFF" "-NECC"))))
                       (defun-form
                         `(,(if non-exec-p 'defun-nx 'defun)
                           ,name ,args ,@dcls ,defun-body))
                       (defun-constraint
                         (and constrained ; optimization
                              `(defthm ,def-name
                                 (equal (,name ,@args)
                                        ,defun-body)
                                 :rule-classes :definition)))
                       (encap-forms
                        `((logic)
                          (set-match-free-default :all)
                          (set-inhibit-warnings "Theory" "Use" "Free" "Non-rec"
                                                "Infected")

; The following encapsulate, which is the 5th element of the returned
; encapsulate, introduces the witness function and then any constrained
; function using that witness.  When defun-sk is used to define an apply$
; warrant function for fn, this encapsulate is the event that introduces
; APPLY$-WARRANT-fn.  The function make-apply$-warrant-defun-sk assumes that it
; can grab this event with NTH 5.  It then checks that the grabbed event is an
; encapsulate that introduces the witness, just as a sanity check.  If the
; sanity check fails, it's because defun-sk-fn and make-apply$-warrant-defun-sk
; got out of sync!  Just make sure that the latter function always knows how to
; find the event creating the apply$ warrant function.

                          (encapsulate
                            (((,skolem-name ,@(make-list (length args)
                                                         :initial-element '*))
                              =>
                              ,(if (= (length bound-vars) 1)
                                   '*
                                 (cons 'mv
                                       (make-list (length bound-vars)
                                                  :initial-element '*)))
                              #+:non-standard-analysis
                              ,@(and classicalp-p
                                     `(:classicalp ,classicalp)))
                             ,@(and constrained
                                    `((,name
                                       ,args
                                       t
                                       ,@(and stobjs
                                              `(:stobjs ,@stobjs))
                                       ,@(and dfs
                                              `(:dfs ,@dfs))
                                       ,@(and guard-p
                                              (mv-let (ign guard)
                                                (dcls-guard-raw-from-def
                                                 (cdr defun-form)

; It is safe to pass nil in for the world because we are meeting the conditions
; of dcls-guard-raw-from-def: an explicit :STOBJS keyword is added above if
; there are stobjs, and SATISFIES declarations are checked in the local
; defun-form.

                                                 nil)
                                                (declare (ignore ign))
                                                `(:guard ,guard)))
                                       #+:non-standard-analysis
                                       ,@(and classicalp-p
                                              `(:classicalp ,classicalp))))))
                            (local (in-theory '(implies)))
                            (local
                             (encapsulate ; ignorable unsupported for defchoose
                               ()
                               (set-ignore-ok t) ; local to encapsulate
                               (defchoose ,skolem-name ,bound-vars ,args
                                 ,defchoose-body
                                 ,@(and strengthen
                                        '(:strengthen t)))))
                            ,@(and strengthen
                                   `((defthm ,(add-suffix skolem-name
                                                          "-STRENGTHEN")
                                       ,(defchoose-constraint-extra
                                          skolem-name bound-vars args
                                          defchoose-body)
                                       :hints (("Goal"
                                                :use ,skolem-name
                                                :in-theory
                                                (theory 'minimal-theory)))
                                       :rule-classes nil)))
                            ,@(cond (constrained
                                     `((local ,defun-form)
                                       ,defun-constraint
                                       (local (in-theory (disable (,name))))))
                                    (t
                                     `(,defun-form
                                        (in-theory (disable (,name))))))
                            (defthm ,thm-name
                              ,(cond (exists-p
                                      `(implies ,body-guts
                                                (,name ,@args)))
                                     ((eq rewrite :direct)
                                      `(implies (,name ,@args)
                                                ,body-guts))
                                     ((member-eq rewrite '(nil :default))
                                      `(implies (not ,body-guts)
                                                (not (,name ,@args))))
                                     (t rewrite))
                              :hints (("Goal"
                                       :use (,skolem-name ,name)
                                       :in-theory (theory 'minimal-theory)))))
                          (extend-pe-table ,name ,form)
                          ,@(and (not constrained)
                                 (case verify-guards-p
                                   ((t)
                                    `((verify-guards ,name
                                        ,@(and guard-hints
                                               (list :hints guard-hints)))))
                                   ((nil)
                                    nil)
                                   (otherwise ; '?
                                    `((verify-guards?
                                       ,guard-p
                                       ,name
                                       ,@(and guard-hints
                                              (list :hints guard-hints)))))))
                          (value-triple '(:return-value ,name)
                                        :on-skip-proofs t))))
                  (cond
                   (verbose `(encapsulate () ,@encap-forms))
                   (t `(with-output
                         :off (:other-than error summary)
                         :ctx ',ctx
                         :summary-off value
                         :gag-mode nil
                         (encapsulate
                           ()
                           ,@(map-with-output :off 'summary
                                              encap-forms)))))))))))))))

; Because make-apply$-warrant-defun-sk is so dependent on defun-sk-fn, we
; define that function now, after introducing a couple of helper functions.
; But make-apply$-warrant-defun-sk isn't needed until we define defwarrant.

(defun tameness-conditions (ilks var)
  (declare (xargs :mode :program))
  (cond ((endp ilks) nil)
        ((eq (car ilks) :FN)
         (cons `(TAMEP-FUNCTIONP (CAR ,var))
               (tameness-conditions (cdr ilks) (list 'CDR var))))
        ((eq (car ilks) :EXPR)
         (cons `(TAMEP (CAR ,var))
               (tameness-conditions (cdr ilks) (list 'CDR var))))
        (t (tameness-conditions (cdr ilks) (list 'CDR var)))))

(defun successive-cadrs (formals var)
  (declare (xargs :mode :program))
  (cond ((endp formals) nil)
        (t
         (cons `(CAR ,var)
               (successive-cadrs (cdr formals) (list 'CDR var))))))

(defun make-apply$-warrant-defun-sk (fn formals bdg trans1-flg)

; This function creates the defun-sk event that introduces APPLY$-WARRANT-fn
; after (fn . formals) has been confirmed to have badge bdg.  If trans1-flg is
; nil, it returns an explicit defun-sk form; if trans1-flg is t it returns the
; encapsulate into which defun-sk expands.  (Note that the resulting encapsulate
; is not fully translated, just expanded as per the defun-sk macro.)

; This function works by creating the untranslated defun-sk and then, if
; necessary, calling defun-sk-fn -- the macro expander for defun-sk -- to get
; the result.  However, defun-sk-fn actually returns an encapsulate that does
; several things, among which is an inner encapsulate that creates
; APPLY$-WARRANT-fn.  We need to recover that inner encapsulate from the result
; of defun-sk-fn.  That inner encapsulate is known to be the 5th element of the
; result!  However, we do a sanity check, just in case.  The sanity check
; confirms that the thing we recover is an ENCAPSULATE that introduces
; APPLY$-WARRANT-fn.  A hard error is signalled if it is not.

; Warning: Keep this function in sync with defun-sk-fn.

  (let* ((name (warrant-name fn))
         (form
          (cond ((eq (access apply$-badge bdg :ilks) t)
                 `(defun-sk ,name ()
                    (forall (args)
                      (and
                       (equal (badge-userfn ',fn) ',bdg)
                       (equal (apply$-userfn ',fn args)
                              ,(if (eql (access apply$-badge bdg :out-arity) 1)
                                   `(,fn ,@(successive-cadrs formals 'args))
                                   `(mv-list
                                     ',(access apply$-badge bdg :out-arity)
                                     (,fn ,@(successive-cadrs formals 'args)))))))
                    :constrain t))
                (t (let* ((hyp-list (tameness-conditions (access apply$-badge bdg :ilks)
                                                         'ARGS))
                          (hyp (if (null (cdr hyp-list))
                                   (car hyp-list)
                                   `(AND ,@hyp-list))))
                     `(defun-sk ,name ()
                        (forall (args)
                          (implies
                           ,hyp
                           (and
                            (equal (badge-userfn ',fn) ',bdg)
                            (equal (apply$-userfn ',fn args)
                                   ,(if (eql (access apply$-badge bdg :out-arity) 1)
                                        `(,fn ,@(successive-cadrs formals 'args))
                                        `(mv-list
                                          ',(access apply$-badge bdg :out-arity)
                                          (,fn ,@(successive-cadrs formals 'args))))))))
                        :constrain t))))))
    (cond
     ((null trans1-flg) form)
     (t (let* ((defun-sk-event (defun-sk-fn form name nil (cdddr form)))
               (with-output-p (eq (car defun-sk-event) 'with-output))
               (defun-sk-event (if with-output-p
                                   (car (last defun-sk-event))
                                 defun-sk-event))
               (crux (nth 5 defun-sk-event))
               (crux (if with-output-p (car (last crux)) crux))
               (constrained-fn (and (consp crux)
                                    (eq (car crux) 'ENCAPSULATE)
                                    (consp (nth 1 crux))
                                    (consp (car (nth 1 crux)))
                                    (consp (car (car (nth 1 crux))))
; Return the name of the first constrained fn introduced by this ENCAPSULATE:
                                    (car (car (car (nth 1 crux)))))))
          (cond
           ((eq constrained-fn
                (add-suffix name "-WITNESS"))
            crux)
           (t (er hard 'make-apply$-warrant-defun-sk
                  "Make-apply$-warrant-defun-sk, when called on the function ~
                   symbol ~x0, expected to find an ENCAPSULATE constraining ~
                   ~x1 as the 5th element of the form created by ~
                   DEFUN-SK-EVENT.  But that sanity check failed.  This ~
                   indicates that make-apply$-warrant-defun-sk and ~
                   defun-sk-event are no longer in sync.  Please advise the ~
                   ACL2 implementors!"
                  name
                  (add-suffix name "-WITNESS")))))))))

(defmacro defun-sk (&whole form name args &rest rest)
  (defun-sk-fn form name args rest))

; Here is the defstobj event.  Note that many supporting functions have been
; moved from this file to basis-a.lisp, in support of ACL2 "toothbrush"
; applications.

; We start with the problem of finding the arguments to the defstobj event.
; The form looks likes

; (defstobj name ... field-descri ...
;           :renaming alist
;           :inline flag)

; where the :renaming and :inline keyword arguments are optional.  This syntax
; is not supported by macros because you can't have an &REST arg and a &KEYS
; arg without all the arguments being in the keyword style.  So we use &REST
; and implement the new style of argument recovery.

; Once we have partitioned the args for defstobj, we'll have recovered the
; field-descriptors and a renaming alist.  Our next step is to check that the
; renaming alist is of the correct form.

(defun doublet-style-symbol-to-symbol-alistp (x)
  (cond ((atom x) (equal x nil))
        (t (and (consp (car x))
                (symbolp (caar x))
                (consp (cdar x))
                (symbolp (cadar x))
                (null (cddar x))
                (doublet-style-symbol-to-symbol-alistp (cdr x))))))

; Then, we can use the function defstobj-fnname to map the default
; symbols in the defstobj to the function names the user wants us to
; use.  (It is defined elsewhere because it is needed by translate.)

(defun chk-legal-defstobj-name (name state)
  (cond ((eq name 'state)
         (er soft (cons 'defstobj name)
             "STATE is an illegal name for a user-declared ~
              single-threaded object."))
        ((string-prefixp *with-global-stobj-prefix* (symbol-name name))
         (er soft (cons 'defstobj name)
             "The name ~x0 is not a legal stobj name because its name starts ~
              with ~x1.  Such names are reserved for use in the expansions of ~
              ~x2 calls."
             name *with-global-stobj-prefix* 'with-global-stobj))
        ((legal-variablep name)
         (value nil))
        (t
         (er soft (cons 'defstobj name)
             "The symbol ~x0 may not be declared as a single-threaded object ~
              name because it is not a legal variable name."
             name))))

(defun chk-unrestricted-guards-for-type-spec-term (names wrld ctx state)

; This function is intended to be run on the names called in the translation of
; a type-spec to a term, to check that the term is well-guarded.  We are only
; concerned with each name, pred, that comes from (SATISFIES pred) -- but pred
; is thus unary, so we can exempt non-unary functions from the check.  That's
; important; for example, < may be in names, for example as a result of
; translating the type-spec (unsigned-byte 30) to a term.

  (cond
   ((null names) (value nil))
   ((or (not (eq (arity (car names) wrld) 1)) ; not from SATISFIES
        (equal (guard (car names) nil wrld) *t*))
    (chk-unrestricted-guards-for-type-spec-term (cdr names) wrld ctx state))
   (t (er soft ctx
          "The guard for ~x0 is ~p1.  But in order to use ~x0 in the ~
           type-specification of a single-threaded object it must ~
           have a guard of T."
          (car names)
          (untranslate (guard (car names) nil wrld) t wrld)))))

(defun chk-stobj-field-type-term (term type init field name type-string str
                                       ctx wrld state)
  (er-let* ((pair (simple-translate-and-eval term
                                             (list (cons 'x init))
                                             nil
                                             (msg "The type ~x0" term)
                                             ctx
                                             wrld
                                             state
                                             nil)))

; pair is (tterm . val), where tterm is a term and val is its value
; under x<-init.

    (er-progn
     (chk-common-lisp-compliant-subfunctions
      nil (list field) (list (car pair))
      wrld str ctx state)
     (chk-unrestricted-guards-for-type-spec-term
      (all-fnnames (car pair))
      wrld ctx state)
     (cond
      ((not (cdr pair))
       (er soft ctx
           "The value specified by the :initially keyword, namely ~x0, fails ~
            to satisfy the declared type ~x1~@2 for the ~x3 field of ~x4."
           init type type-string field name))
      (t (value nil))))))

(defun chk-stobj-field-etype (etype type field name initp init arrayp
                                    non-memoizable
                                    child-stobj-memoizable-error-string
                                    ctx wrld state)
  (let* ((stobjp (stobjp etype t wrld))
         (etype-term        ; used only when (not stobjp)
          (and (not stobjp) ; optimization
               (translate-declaration-to-guard etype 'x wrld)))
         (etype-error-string
          "The element type specified for the ~x0 field of ~x1, namely ~x2, ~
           is not recognized by ACL2 as a type-spec (see :DOC type-spec) or ~
           as a user-defined stobj name."))
    (cond
     (stobjp

; Defstobj-raw-init-fields depends on this check.  Also see the comment above
; explaining how stobj-let depends on this check.

      (cond ((eq etype 'state)
             (er soft ctx
                 etype-error-string
                 field name etype))
            ((and non-memoizable
                  (not (getpropc etype 'non-memoizable nil wrld)))
             (er soft ctx
                 child-stobj-memoizable-error-string
                 name etype))
            ((null initp) (value nil))
            (t (er soft ctx
                   "The :initially keyword must be omitted for a :type ~
                    specified as an array of stobjs or a hash-table of ~
                    stobjs.  But for :type ~x0, :initially is specified as ~
                    ~x1 for the ~x2 field of ~x3."
                   type init field name))))
     ((null etype-term)
      (er soft ctx
          etype-error-string
          field name etype))
     (t
      (chk-stobj-field-type-term etype-term etype init field name
                                 (msg " in the ~@0 specification"
                                      (if arrayp "array" "hash-table"))
                                 "auxiliary function"
                                 ctx wrld state)))))

(defun chk-stobj-field-descriptor (name field-descriptor non-memoizable
                                        ctx wrld state)

; See the comment just before chk-acceptable-defstobj1 for an explanation of
; our handling of Common Lisp compliance.

; The argument, non-memoizable, is the value of the :non-memoizable keyword of
; the defstobj event introducing name.  Let us consider whether there is a need
; to add a check about :non-memoizable for the case of a stobj with stobj
; fields.

; On the one hand, it is fine for the parent stobj to be memoizable regardless
; of whether any child stobjs are non-memoizable.  Suppose that some child
; stobj is non-memoizable but the (new) parent stobj is memoizable.  The
; concern is the case that some memoized function reads the parent twice on the
; same inputs when between those reads, some child stobj has changed without
; any flushing of memoization tables (because the child stobj is
; non-memoizable).  But the only way to change a child stobj is by way of
; stobj-let, which flushes the memo table for each function that takes the
; parent stobj as an argument (since the parent is memoizable).

; On the other hand, suppose that some child stobj is memoizable but the (new)
; parent stobj is non-memoizable.  In this case, stobj-let does not flush the
; parent stobj's memo tables, and we return to the soundness bug illustrated in
; a comment in stobj-let-fn-raw.

  (cond
   ((symbolp field-descriptor) (value nil))
   (t
    (er-progn
     (cond ((and (consp field-descriptor)
                 (symbolp (car field-descriptor))
                 (keyword-value-listp (cdr field-descriptor))
                 (member-equal (length field-descriptor) '(1 3 5 7 9))
                 (let ((keys (odds field-descriptor)))
                   (and (no-duplicatesp keys)
                        (subsetp-eq keys '(:type :element-type :initially
                                                 :resizable)))))
            (value nil))
           (t (er soft ctx
                  "The field descriptors of a single-threaded object ~
                   definition must be a symbolic field-name or a list of the ~
                   form (field-name :type type :initially val), where ~
                   field-name is a symbol.  The :type and :initially keyword ~
                   assignments are optional and their order is irrelevant.  ~
                   The purported descriptor ~x0 for a field in ~x1 is not of ~
                   this form."
                  field-descriptor
                  name)))
     (let* ((field (car field-descriptor))
            (type (if (assoc-keyword :type (cdr field-descriptor))
                      (cadr (assoc-keyword :type (cdr field-descriptor)))
                    t))
            (element-type (cadr (assoc-keyword :element-type
                                               (cdr field-descriptor))))
            (initp (assoc-keyword :initially (cdr field-descriptor)))
            (init (if initp (cadr initp) nil))
            (resizable (if (assoc-keyword :resizable (cdr field-descriptor))
                           (cadr (assoc-keyword :resizable
                                                (cdr field-descriptor)))
                         nil))
            (child-stobj-memoizable-error-string
             "It is illegal to declare stobj ~x0 as :NON-MEMOIZABLE, because ~
              it has a child stobj, ~x1, that was not thus declared.  See ~
              :DOC defstobj."))
       (cond
        ((and resizable (not (eq resizable t)))
         (er soft ctx
             "The :resizable value in the ~x0 field of ~x1 is illegal:  ~x2.  ~
              The legal values are t and nil."
             field name resizable))
        ((and (consp type)
              (eq (car type) 'array))
         (cond
          ((not (and (true-listp type)
                     (equal (length type) 3)
                     (true-listp (caddr type))
                     (equal (length (caddr type)) 1)))
           (er soft ctx
               "When a field descriptor specifies an ARRAY :type, the type ~
                must be of the form (ARRAY etype (n)).  Note that we only ~
                support single-dimensional arrays.  The purported ARRAY :type ~
                ~x0 for the ~x1 field of ~x2 is not of this form."
               type field name))
          (t (let* ((type0 (fix-stobj-array-type type wrld))
                    (etype (cadr type0))
                    (n (car (caddr type0))))
               (cond
                ((not (natp n))
                 (er soft ctx
                     "An array dimension must be a non-negative integer or a ~
                      defined constant whose value is a non-negative integer. ~
                      ~ The :type ~x0 for the ~x1 field of ~x2 is thus ~
                      illegal."
                     type0 field name))
                ((and element-type
                      (not (or (eq element-type t)
                               (equal element-type etype))))
                 (er soft ctx
                     "When the :element-type keyword is specified for a stobj ~
                      array field, it must be either T or the type specified ~
                      for the elements of the array by its :type keyword.  ~
                      The :element-type of ~x0 is thus illegal for :type ~x1."
                     element-type type))
                (t
                 (chk-stobj-field-etype etype type field name initp init t
                                        non-memoizable
                                        child-stobj-memoizable-error-string
                                        ctx wrld state)))))))
        ((or element-type
             (assoc-keyword :resizable (cdr field-descriptor)))
         (er soft ctx
             "The ~#0~[:resizable~/:element-type~] keyword is only legal for ~
              array types, hence is illegal for the ~x1 field of ~x2."
             (if element-type 1 0)
             field
             name))
        ((and (consp type)
              (eq (car type) 'hash-table))
         (cond ((not (and (true-listp type)
                          (member (length type) '(2 3 4))))
                (er soft ctx
                    "A hash-table type must be a true-list of length 2, 3, or ~
                     4.  The type ~x0 is thus illegal.  See :DOC defstobj.~%"
                    type))
               (t (let* ((type (fix-stobj-hash-table-type type wrld))
                         (test (stobj-hash-table-test type))
                         (size (stobj-hash-table-init-size type))
                         (etype (stobj-hash-table-element-type type)))
                    (cond ((not (member-eq test '(eq eql equal hons-equal)))
                           (er soft ctx
                               "A hash-table test must be ~v0.  The test ~
                                given was ~x1.  See :DOC defstobj.~%"
                               '(eq eql hons-equal equal)
                               test))
                          ((and size
                                (not (natp size)))
                           (er soft ctx
                               "A hash-table type must specify the size (the ~
                                optional second argument) as nil or a natural ~
                                number, either directly or using a defined ~
                                constant.  The type ~x0 is thus illegal.  See ~
                                :DOC defstobj.~%"
                               type))
                          ((not (eq etype t))
                           (chk-stobj-field-etype
                            etype type field name initp init nil non-memoizable
                            child-stobj-memoizable-error-string ctx wrld
                            state))
                          (t (value nil)))))))
        ((and (consp type)
              (eq (car type) 'stobj-table))
         (cond ((not (and (true-listp type)
                          (member (length type) '(1 2))))
                (er soft ctx
                    "A stobj-table type must be a true-list of length 1 or 2, ~
                     interpreted as (STOBJ-TABLE) or (STOBJ-TABLE SIZE).  The ~
                     type ~x0 is thus illegal.~%"
                    type))
               (t (let ((type (fix-stobj-table-type type wrld)))
                    (cond ((and (cdr type)
                                (not (natp (cadr type))))
                           (er soft ctx
                               "A stobj-table type of the form (STOBJ-TABLE ~
                                SIZE) must specify SIZE as a natural number, ~
                                either directly or using a defined constant.  ~
                                The type ~x0 is thus illegal.~%"
                               type))
                          (t (value nil)))))))
        (t (let* ((stobjp (stobjp type t wrld))
                  (type-term         ; used only when (not stobjp)
                   (and (not stobjp) ; optimization
                        (translate-declaration-to-guard type 'x wrld)))
                  (type-error-string
                   "The :type specified for the ~x0 field of ~x1, namely ~x2, ~
                    is not recognized by ACL2 as a type-spec (see :DOC ~
                    type-spec) or as a user-defined stobj name."))
             (cond
              (stobjp

; Defstobj-raw-init-fields depends on this check.  Also see the comment above
; explaining how stobj-let depends on this check.

               (cond ((eq type 'state)
                      (er soft ctx
                          type-error-string
                          field name type))
                     ((and non-memoizable
                           (not (getpropc type 'non-memoizable nil wrld)))
                      (er soft ctx
                          child-stobj-memoizable-error-string
                          name type))
                     ((null initp) (value nil))
                     (t (er soft ctx
                            "The :initially keyword must be omitted for a ~
                             :type specified as a stobj.  But for :type ~x0, ~
                             :initially is specified as ~x1 for the ~x2 field ~
                             of ~x3."
                            type init field name))))
              ((null type-term)
               (er soft ctx
                   type-error-string
                   field name type))
              (t
               (chk-stobj-field-type-term type-term type init field name ""
                                          "body" ctx wrld state)))))))))))

(defun chk-acceptable-defstobj-renaming
  (name field-descriptors renaming ctx state default-names)

; We collect up all the default names and then check that the domain
; of renaming contains no duplicates and is a subset of the default
; names.  We already know that field-descriptors is well-formed and
; that renaming is a doublet-style symbol-to-symbol alist.

  (cond
   ((endp field-descriptors)
    (let ((default-names (list* (defstobj-fnname name :recognizer :top nil)
                                (defstobj-fnname name :creator :top nil)
                                (reverse default-names)))
          (domain (strip-cars renaming)))
      (cond
       ((null renaming)

; In this case, the default-names are the names the user intends us to use.

        (cond
         ((not (no-duplicatesp-eq default-names))
          (er soft ctx
              "The field descriptors are illegal because they require ~
               the use of the same name for two different functions.  ~
               The duplicated name~#0~[ is~/s are~] ~&0.  You must ~
               change the component names so that no conflict occurs. ~
               ~ You may then wish to use the :RENAMING option to ~
               introduce your own names for these functions.  See ~
               :DOC defstobj."
              (duplicates default-names)))
         (t (value nil))))
       ((not (no-duplicatesp-eq default-names))
        (er soft ctx
            "The field descriptors are illegal because they require ~
             the use of the same default name for two different ~
             functions.  The duplicated default name~#0~[ is~/s are~] ~
             ~&0.  You must change the component names so that no ~
             conflict occurs.  Only then may you use the :RENAMING ~
             option to rename the default names."
            (duplicates default-names)))
       ((not (no-duplicatesp-eq domain))
        (er soft ctx
            "No two entries in the :RENAMING alist may mention the ~
             same target symbol.  Your alist, ~x0, contains ~
             duplications in its domain."
            renaming))
       ((not (subsetp domain default-names))
        (er soft ctx
            "Your :RENAMING alist, ~x0, mentions ~#1~[a function ~
             symbol~/function symbols~] in its domain which ~
             ~#1~[is~/are~] not among the default symbols to be ~
             renamed.  The offending symbol~#1~[ is~/s are~] ~&1.  ~
             The default defstobj names for this event are ~&2."
            renaming
            (set-difference-equal domain default-names)
            default-names))
       (t (value nil)))))
   (t (let* ((field (if (atom (car field-descriptors))
                        (car field-descriptors)
                      (car (car field-descriptors))))
             (type (if (consp (car field-descriptors))
                       (or (cadr (assoc-keyword :type
                                                (cdr (car field-descriptors))))
                           t)
                     t))
             (key2 (defstobj-fnname-key2 type)))
        (chk-acceptable-defstobj-renaming
         name (cdr field-descriptors) renaming ctx state
         (list* (defstobj-fnname field :updater key2 nil)
                (defstobj-fnname field :accessor key2 nil)
                (defstobj-fnname field :recognizer key2 nil)
                (cond ((eq key2 :array)
                       (list* (defstobj-fnname field :length key2 nil)
                              (defstobj-fnname field :resize key2 nil)
                              default-names))
                      ((or (eq key2 :hash-table)
                           (eq key2 :stobj-table))
                       (list* (defstobj-fnname field :boundp key2 nil)
                              (defstobj-fnname field :accessor? key2 nil)
                              (defstobj-fnname field :remove key2 nil)
                              (defstobj-fnname field :count key2 nil)
                              (defstobj-fnname field :clear key2 nil)
                              (defstobj-fnname field :init key2 nil)
                              default-names))
                      (t default-names))))))))

; The functions introduced by defstobj are all defined with :VERIFY-GUARDS T.
; This means we must ensure that their guards and bodies are compliant.  Most
; of this stuff is mechanically generated by us and is guaranteed to be
; compliant.  But there is a way that a user defined function can sneak in.
; The user might use a type-spec such as (satisfies foo), where foo is a user
; defined function.

; To discuss the guard issue, we name the functions introduced by defstobj,
; following the convention used in the comment in defstobj-template.  The
; recognizer for the stobj itself will be called namep, and the creator will be
; called create-name.  For each field, the following names are introduced:
; recog-name - recognizer for the field value; accessor-name - accessor for the
; field; updater-name - updater for the field; length-name - length of array
; field; resize-name - resizing function for array field.

; We are interested in determining the conditions we must check to ensure that
; each of these functions is Common Lisp compliant.  Both the guard and the
; body of each function must be compliant.  Inspection of
; defstobj-axiomatic-defs reveals the following.

; Namep is defined in terms of primitives and the recog-names.  The guard for
; namep is T.  The body of namep is always compliant, if the recog-names are
; compliant and have guards of T.

; Create-name is a constant with a guard of T.  Its body is always compliant.

; Recog-name has a guard of T.  The body of recog-name is interesting from the
; guard verification perspective, because it may contain translated type-spec
; such as (satisfies foo) and so we must check that foo is compliant.  We must
; also check that the guard of foo is T, because the guard of recog-name is T
; and we might call foo on anything.

; Accessor-name is not interesting: its guard is namep and its body is
; primitive.  We will have checked that namep is compliant.

; Updater-name is not interesting: its guard may involve translated type-specs
; and will involve namep, but we will have checked their compliance already.

; Length-name and resize-name have guards that are calls of namep, and their
; bodies are known to satisfy their guards.

; So it all boils down to checking the compliance of the body of recog-name,
; for each component.  Note that we must check both that the type-spec only
; involves compliant functions and that every non-system function used has a
; guard of T.

(defun chk-acceptable-defstobj1 (name field-descriptors ftemps renaming
                                      non-memoizable ctx wrld state names
                                      const-names)

; We check whether it is legal to define name as a single-threaded
; object with the description given in field-descriptors.  We know
; name is a legal (and new) stobj name and we know that renaming is a
; symbol to symbol doublet-style alist.  But we know nothing else.  We
; either signal an error or return the world in which the event is to
; be processed (thus implementing redefinitions).  Names is, in
; general, the actual set of names that the defstobj event will
; introduce.  That is, it contains the images of the default names
; under the renaming alist.  We accumulate the actual names into it as
; we go and check that it contains no duplicates at the termination of
; this function.  All of the names in names are to be defined as
; functions with :VERIFY-GUARDS T.  See the comment above about
; Common Lisp compliance.

  (cond
   ((endp ftemps)
    (let* ((recog-name (defstobj-fnname name :recognizer :top renaming))
           (creator-name (defstobj-fnname name :creator :top renaming))
           (names (list* recog-name creator-name names)))
      (er-progn
       (chk-all-but-new-name recog-name ctx 'function wrld state)
       (chk-all-but-new-name creator-name ctx 'function wrld state)
       (chk-acceptable-defstobj-renaming name field-descriptors renaming
                                         ctx state nil)
       (cond ((and renaming

; If renaming is nil, then the no-duplicates check is already made in
; chk-acceptable-defstobj-renaming.  Note that we take advantage of renaming
; being non-nil in the error message below.

                   (not (no-duplicatesp-eq names)))
              (er soft ctx
                  "The field descriptors are illegal because they require the ~
                   use of the same name for two different functions.  The ~
                   duplicated name~#0~[ is~/s are~] ~&0.  You must change the ~
                   supplied :RENAMING option so that no conflict occurs."
                  (duplicates names)))
             (t (value nil)))

; Note: We insist that all the names be new.  In addition to the
; obvious necessity for something like this, we note that this does
; not permit us to have redundantly defined any of these names.  For
; example, the user might have already defined a field recognizer,
; PCP, that is identically defined to what we will lay down.  But we
; do not allow that.  We basically insist that we have control over
; every one of these names.

       (chk-just-new-names names 'function nil ctx wrld state)
       (chk-just-new-names const-names 'const nil ctx wrld state))))
   (t

; An element of field-descriptors (i.e., of ftemps) is either a symbolic field
; name, field, or else of the form (field :type type :element-type element-type
; :initially val), where any of the keyword fields can be omitted and
; :element-type is legal only when :type specifies an array.  Val must be an
; evg, i.e., an unquoted constant like t, nil, 0 or undef (the latter meaning
; the symbol 'undef).  :Type defaults to the unrestricted type t and :initially
; defaults to nil.  Type is either a primitive type, as recognized by
; translate-declaration-to-guard-gen, or a stobj name, or else is of the form
; (array ptype (n)), where ptype is a primitive type or stobj name and n is an
; positive integer constant.  If type is a stobj name or an array of such, then
; :initially must be omitted.

    (er-progn
     (chk-stobj-field-descriptor name (car ftemps) non-memoizable ctx wrld
                                 state)
     (let* ((field (if (atom (car ftemps))
                       (car ftemps)
                     (car (car ftemps))))
            (type (if (consp (car ftemps))
                      (or (cadr (assoc-keyword :type
                                               (cdr (car ftemps))))
                          t)
                    t))
            (key2 (defstobj-fnname-key2 type))
            (boundp-name (defstobj-fnname field :boundp key2 renaming))
            (accessor?-name (defstobj-fnname field :accessor? key2
                              renaming))
            (remove-name (defstobj-fnname field :remove key2
                           renaming))
            (count-name (defstobj-fnname field :count key2 renaming))
            (clear-name (defstobj-fnname field :clear key2 renaming))
            (init-name (defstobj-fnname field :init key2 renaming))
            (fieldp-name (defstobj-fnname field :recognizer key2 renaming))
            (accessor-name (defstobj-fnname field :accessor key2 renaming))
            (accessor-const-name (defconst-name accessor-name))
            (updater-name (defstobj-fnname field :updater key2 renaming))
            (length-name (defstobj-fnname field :length key2 renaming))
            (resize-name (defstobj-fnname field :resize key2 renaming)))
       (er-progn
        (chk-all-but-new-name fieldp-name ctx 'function wrld state)
        (chk-all-but-new-name accessor-name ctx 'function wrld state)
        (chk-all-but-new-name updater-name ctx 'function wrld state)
        (chk-all-but-new-name accessor-const-name ctx 'const wrld state)
        (cond
         ((eq key2 :array)
          (er-progn (chk-all-but-new-name length-name ctx 'function wrld state)
                    (chk-all-but-new-name resize-name ctx 'function wrld state)))
         ((or (eq key2 :hash-table)
              (eq key2 :stobj-table))
          (er-progn (chk-all-but-new-name boundp-name ctx
                                          'function wrld state)
                    (if (eq key2 :hash-table)
                        (chk-all-but-new-name accessor?-name ctx
                                              'function wrld state)
                      (value nil))
                    (chk-all-but-new-name remove-name ctx
                                          'function wrld state)
                    (chk-all-but-new-name count-name ctx
                                          'function wrld state)
                    (chk-all-but-new-name init-name ctx
                                          'function wrld state)
                    (chk-all-but-new-name clear-name ctx
                                          'function wrld state)))
         (t (value nil)))
        (chk-acceptable-defstobj1 name field-descriptors (cdr ftemps)
                                  renaming non-memoizable ctx wrld state
                                  (list* fieldp-name
                                         accessor-name
                                         updater-name
                                         (cond
                                          ((eq key2 :array)
                                           (list* length-name
                                                  resize-name
                                                  names))
                                          ((eq key2 :hash-table)
                                           (list* boundp-name
                                                  accessor?-name
                                                  remove-name
                                                  count-name
                                                  clear-name
                                                  init-name
                                                  names))
                                          ((eq key2 :stobj-table)
                                           (list* boundp-name
                                                  remove-name
                                                  count-name
                                                  clear-name
                                                  init-name
                                                  names))
                                          (t names)))
                                  (cons accessor-const-name
                                        const-names))))))))

(defun old-field-descriptors (name wrld)
  (assert$
   (getpropc name 'stobj nil wrld)
   (let ((ev (get-event name wrld)))
     (and ev
          (assert$
           (and (eq (car ev) 'defstobj)
                (eq (cadr ev) name))
           (mv-let (erp field-descriptors key-alist)
             (partition-rest-and-keyword-args (cddr ev) *defstobj-keywords*)
             (declare (ignore key-alist))
             (and (null erp)
                  field-descriptors)))))))

(defun redundant-defstobjp (name args wrld)
  (and (getpropc name 'stobj nil wrld)
       (let ((ev (get-event name wrld)))
         (and ev
              (eq (car ev) 'defstobj)
              (eq (cadr ev) name)
              (equal (cddr ev) args)))))

(defun congruent-stobj-fields (fields1 fields2)
  (cond ((endp fields1) (null fields2))
        (t (let ((x1 (car fields1))
                 (x2 (car fields2)))
             (and (if (symbolp x1)
                      (symbolp x2)
                    (and (consp x1)
                         (consp x2)
                         (equal (cdr x1) (cdr x2))))
                  (congruent-stobj-fields (cdr fields1) (cdr fields2)))))))

(defun chk-acceptable-defstobj (name args ctx wrld state)

; We check that (defstobj name . args) is well-formed and either
; signals an error or returns nil.

  (cond
   ((not (symbolp name))
    (er soft ctx
        "The first argument of a DEFSTOBJ event must be a symbol.  Thus, ~x0 ~
         is ill-formed."
        (list* 'defstobj name args)))
   (t
    (mv-let
     (erp field-descriptors key-alist)
     (partition-rest-and-keyword-args args *defstobj-keywords*)
     (cond
      (erp
       (er soft ctx
           "The keyword arguments to the DEFSTOBJ event must appear after all ~
            field descriptors.  The allowed keyword arguments are ~&0, and ~
            these may not be duplicated, and must be followed by the ~
            corresponding value of the keyword argument.  Thus, ~x1 is ~
            ill-formed."
           *defstobj-keywords*
           (list* 'defstobj name args)))
      ((redundant-defstobjp name args wrld)
       (value 'redundant))
      (t
       (let ((renaming (cdr (assoc-eq :renaming key-alist)))
             (inline (cdr (assoc-eq :inline key-alist)))
             (congruent-to (cdr (assoc-eq :congruent-to key-alist)))
             (non-memoizable (cdr (assoc-eq :non-memoizable key-alist)))
             (non-executable (cdr (assoc-eq :non-executable key-alist))))
         (cond
          ((not (booleanp inline))
           (er soft ctx
               "DEFSTOBJ requires the :INLINE keyword argument to have a ~
                Boolean value.  See :DOC defstobj."))
          ((not (and (booleanp non-memoizable)
                     (booleanp non-executable)))
           (er soft ctx
               "DEFSTOBJ requires the ~x0 keyword argument to ~
                have a Boolean value.  See :DOC defstobj."
               (if (booleanp non-memoizable)
                   :NON-EXECUTABLE
                 :NON-MEMOIZABLE)))
          ((and congruent-to
                (not (stobjp congruent-to t wrld)))
           (er soft ctx
               "The :CONGRUENT-TO field of a DEFSTOBJ must either be nil or ~
                the name of an existing stobj, but the value ~x0 is neither.  ~
                See :DOC defstobj."
               congruent-to))
          ((and congruent-to ; hence stobjp holds, hence symbolp holds
                (getpropc congruent-to 'absstobj-info nil wrld))
           (er soft ctx
               "The symbol ~x0 is the name of an abstract stobj in the ~
                current ACL2 world, so it is not legal for use as the ~
                :CONGRUENT-TO argument of DEFSTOBJ."
               congruent-to))
          ((and congruent-to
                (not (congruent-stobj-fields
                      field-descriptors
                      (old-field-descriptors congruent-to wrld))))
           (er soft ctx
               "A non-nil :CONGRUENT-TO field of a DEFSTOBJ must be the name ~
                of a stobj that has the same shape as the proposed new stobj. ~
                ~ However, the proposed stobj named ~x0 does not have the ~
                same shape as the existing stobj named ~x1.  See :DOC ~
                defstobj."
               name congruent-to))
          ((and congruent-to
                (not (eq non-memoizable
                         (getpropc congruent-to 'non-memoizable nil wrld))))
           (er soft ctx
               "Congruent stobjs must agree on whether or not they are ~
                specified as :NON-MEMOIZABLE.  However, this fails for the ~
                proposed stobj, ~x0, which is specified as :CONGRUENT-TO the ~
                stobj ~x1, since ~x2 is specified with :NON-MEMOIZABLE T but ~
                ~x3 is not.  See :DOC defstobj."
               name
               congruent-to
               (if non-memoizable name congruent-to)
               (if non-memoizable congruent-to name)))
          (t
           (er-progn

; The defstobj name itself is not subject to renaming.  So we check it
; before we even bother to check the well-formedness of the renaming alist.

            (chk-all-but-new-name name ctx 'stobj wrld state)
            (cond ((member-eq name
                              '(i v k ht-size rehash-size rehash-threshold))

; Not only is 'v used in the logical definition of an updater when the field is
; not a child stobj (or array of such) -- also 'v is used in the raw definition
; of the updater in all cases.

                   (er soft ctx
                       "DEFSTOBJ does not allow single-threaded objects with ~
                        the names ~v0, because those symbols may be used as ~
                        formals, along with the new stobj name itself, in ~
                        ``primitive'' stobj functions that will be defined."
                       '(i v k ht-size rehash-size rehash-threshold)))
                  (t (value nil)))
            (chk-legal-defstobj-name name state)
            (cond ((not (doublet-style-symbol-to-symbol-alistp renaming))
                   (er soft ctx
                       "The :RENAMING argument to DEFSTOBJ must be an alist ~
                        containing elements of the form (sym sym), where each ~
                        element of such a doublet is a symbol. Your argument, ~
                        ~x0, is thus illegal."
                       renaming))
                  (t (value nil)))
            (er-let*
                ((wrld1 (chk-just-new-name name nil 'stobj nil ctx wrld state))
                 (wrld2 (chk-just-new-name (the-live-var name)
                                           nil 'stobj-live-var nil ctx wrld1
                                           state)))
              (chk-acceptable-defstobj1 name field-descriptors field-descriptors
                                        renaming non-memoizable
                                        ctx wrld2 state nil nil))))))))))))

; Essay on Defstobj Definitions

; Consider the following defstobj:

;   (defstobj $st
;     (flag :type t :initially run)
;     (pc   :type (integer 0 255) :initially 128)
;     (mem  :type (array (integer 0 255) (256)) :initially 0)
;     :renaming ((pc pcn)))

; If you call (defstobj-template '$st '((flag ...) ...)) you will get
; back a ``template'' which is sort of a normalized version of the
; event with the renaming applied and all the optional slots filled
; appropriately.  (See the definition of defstobj-template for details.)
; Let template be that template.

; To see the logical definitions generated by this defstobj event, invoke
;   (defstobj-axiomatic-defs '$st template (w state))

; To see the raw lisp definitions generated, invoke
;   (defstobj-raw-defs '$st template nil (w state))

; The *1* functions for the functions are all generated by oneifying
; the axiomatic defs.

; To see the defconsts generated, invoke
;   (defstobj-defconsts
;     (strip-accessor-names (access defstobj-template template
;                                   :field-templates))
;     0)

; It is important the guard conjectures for these functions be
; provable!  They are assumed by the admission process!  To prove
; the guards for the defstobj above, it helped to insert the following
; lemma after the defun of memp but before the definition of memi.

;   (defthm memp-implies-true-listp
;     (implies (memp x)
;              (true-listp x)))

; Even without this lemma, the proof succeeded, though it took much
; longer and involved quite a few generalizations and inductions.

; If you change any of the functions, I recommend generating the axiomatic
; defs for a particular defstobj such as that above and proving the guards.

; Up through v2-7 we also believed that we ensured that the guards in the
; axiomatic defs are sufficient for the raw defs.  However, starting with v2-8,
; this became moot because of the following claim: the raw Lisp functions are
; only called on live stobjs (this change, and others involving :inline, were
; contributed by Rob Sumners).  We believe this claim because of the following
; argument.  Note that there is an exception for the recognizer, which can be
; applied to an ordinary object, but we do not consider this exception here.
;
;   a) The *1* function now has an additional requirement that not only does
;      guard checking pass, but also, all of the stobjs arguments passed in
;      must be the live stobjs in order to execute raw Common Lisp.
;   b) Due to the syntactic restrictions that ACL2 enforces, we know that the
;      direct correspondence between live stobjs and stobj arguments in the
;      raw Common Lisp functions will persist throughout evaluation.
;      -- This can be proven by induction over the sequence of function calls
;         in any evaluation.
;      -- The base case is covered by the binding of stobj parameters to
;         the global live stobj in the acl2-loop, or by the restrictions
;         placed upon with-local-stobj, with-global-stobj, and stobj-let.
;      -- The induction step is proven by the signature requirements of
;         functions that access and/or update stobjs.

; A reasonable question is: Should the guard for resize-name be
; strengthened so as to disallow sizes of at least (1- (expt 2 28))?
; Probably there is no need for this.  Logically, there is no such
; restriction; it is OK for the implementation to insist on such a
; bound when actually executing.

; We introduce the idea of the "template" of a defstobj, which includes a
; normalized version of the field descriptors under the renaming.  See
; basis-a.lisp for defrec forms defstobj-field-template and defstobj-template.

(defun defstobj-field-fns-axiomatic-defs (top-recog var n field-templates wrld)

; Wrld is normally a logical world, but it can be nil when calling this
; function from raw Lisp.

; Warning:  See the guard remarks in the Essay on Defstobj Definitions.

; We return a list of defs (see defstobj-axiomatic-defs) for all the accessors,
; updaters, and optionally, array resizing and length, of a single-threaded
; resource.

; Warning: Each updater definition should immediately follow the corresponding
; accessor definition, so that this is the case for the list of definitions
; returned by defstobj-axiomatic-defs.  That list of definitions gives rise to
; the :names field of the 'stobj property laid down by defstobj-fn, and
; function chk-stobj-updaters1 assumes that it will find each updater
; definition in that list immediately after the corresponding accessor
; definition.

  (cond
   ((endp field-templates)
    nil)
   (t (let* ((field-template (car field-templates))
             (type (access defstobj-field-template field-template :type))
             (arrayp (and (consp type) (eq (car type) 'array)))
             (hashp (and (consp type) (eq (car type) 'hash-table)))
             (init0 (access defstobj-field-template field-template :init))
             (etype (cond (arrayp (cadr type))
                          (hashp (stobj-hash-table-element-type type))
                          (t nil)))
             (creator (get-stobj-creator (or etype type) wrld))
             (init (if creator
                       `(non-exec (,creator))
                     (and init0 (kwote init0))))
             (hash-test (and hashp (stobj-hash-table-test type)))
             (stobj-tablep (and (consp type) (eq (car type) 'stobj-table)))
             (stobjp
              (cond (etype (and (not (eq etype 'state))
                                (stobjp etype t wrld)))
                    (t (and (not (eq type 'state))
                            (stobjp type t wrld)))))
             (stobj-formal (and stobjp (or etype type)))
             (v-formal (or stobj-formal 'v))
             (stobj-xargs (and stobj-formal
                               `(:stobjs ,stobj-formal)))
             (type-term         ; used in guard
              (and (not arrayp)
                   (not hashp)
                   (not stobj-tablep)
                   (if (or (null wrld) ; called from raw Lisp, so guard ignored
                           stobj-formal)
                       t
                     (translate-declaration-to-guard type v-formal wrld))))
             (etype-term               ; used in guard
              (and (or arrayp hashp)   ; else etype-term is not used
                   (if (or (null wrld) ; called from raw Lisp, so guard ignored
                           stobj-formal)
                       t
                     (translate-declaration-to-guard etype v-formal wrld))))
             (array-length (and arrayp (car (caddr type))))
             (accessor-name (access defstobj-field-template
                                    field-template
                                    :accessor-name))
             (updater-name (access defstobj-field-template
                                   field-template
                                   :updater-name))
             (length-name (access defstobj-field-template
                                  field-template
                                  :length-name))
             (resize-name (access defstobj-field-template
                                  field-template
                                  :resize-name))
             (resizable (access defstobj-field-template
                                field-template
                                :resizable))
             (other (access defstobj-field-template
                            field-template
                            :other))
             (boundp-name (nth 0 other))
             (accessor?-name (nth 1 other))
             (remove-name (nth 2 other))
             (count-name (nth 3 other))
             (clear-name (nth 4 other))
             (init-name (nth 5 other)))
        (cond
         (arrayp
          (append
           `((,length-name (,var)
                           (declare (xargs :guard (,top-recog ,var)
                                           :verify-guards t)
                                    ,@(and (not resizable)
                                           `((ignore ,var))))
                           ,(if resizable
                                `(len (nth ,n ,var))
                              array-length))
             (,resize-name
              (i ,var)
              (declare (xargs :guard (,top-recog ,var)
                              :verify-guards t)
                       ,@(and (not resizable)
                              '((ignore i))))
              ,(if resizable
                   `(update-nth ,n
                                (resize-list (nth ,n ,var) i ,init)
                                ,var)
                 `(prog2$ (hard-error
                           ',resize-name
                           "The array field corresponding to accessor ~x0 of ~
                            stobj ~x1 was not declared :resizable t.  ~
                            Therefore, it is illegal to resize this array."
                           (list (cons #\0 ',accessor-name)
                                 (cons #\1 ',var)))
                          ,var)))
             (,accessor-name (i ,var)
                             (declare (xargs :guard
                                             (and (,top-recog ,var)
                                                  (integerp i)
                                                  (<= 0 i)
                                                  (< i (,length-name ,var)))
                                             :verify-guards t))
                             (nth i (nth ,n ,var)))
             (,updater-name (i ,v-formal ,var)
                            (declare
                             (xargs :guard
                                    (and (,top-recog ,var)
                                         (integerp i)
                                         (<= 0 i)
                                         (< i (,length-name ,var))

; We avoid laying down the stobj recognizer twice for a child stobj (although
; that would nevertheless be removed by the use of stobj-optp).

                                         ,@(if (eq etype-term t)
                                               nil
                                             (list etype-term)))
                                    :verify-guards t
                                    ,@stobj-xargs))
                            ,(let ((form
                                    `(update-nth-array ,n i ,v-formal ,var)))
                               (if stobj-formal `(non-exec ,form) form))))
           (defstobj-field-fns-axiomatic-defs
             top-recog var (+ n 1) (cdr field-templates) wrld)))
         ((or hashp stobj-tablep)
          (flet ((common-guard (hash-test var top-recog etype-term)
                               (cond ((eq hash-test 'eq)
                                      `(and (,top-recog ,var)
                                            (symbolp k)
                                            ,@(and etype-term
                                                   (not (eq etype-term t))
                                                   (list etype-term))))
                                     ((eq hash-test 'eql)
                                      `(and (,top-recog ,var)
                                            (eqlablep k)
                                            ,@(and etype-term
                                                   (not (eq etype-term t))
                                                   (list etype-term))))
                                     (t

; This case includes the case of stobj-tablep.  Note that a stobj-table's
; underlying hash table doesn't use stobj names as keys (see
; current-stobj-gensym) and the keys are all symbols anyhow.  So even though k
; should be a symbol, there is no need to complicate the guard with that
; requirement.

                                      (if (and etype-term
                                               (not (eq etype-term t)))
                                          `(and (,top-recog ,var)
                                                ,etype-term)
                                        `(,top-recog ,var))))))
            (append
             `(,(cond (hashp
                       `(,accessor-name
                         (k ,var)
                         (declare (xargs :guard
                                         ,(common-guard hash-test var top-recog
                                                        nil)
                                         :verify-guards t))
                         ,(if (null init)
                              `(cdr (hons-assoc-equal k (nth ,n ,var)))
                            `(let ((pair (hons-assoc-equal k (nth ,n ,var))))
                               (if pair (cdr pair) ,init)))))
                      (t
                       `(,accessor-name
; We use v for the default, since we know that v is not ,var.
                         (k ,var v)
                         (declare (xargs :guard
                                         ,(common-guard hash-test var top-recog
                                                        nil)
                                         :verify-guards t))
                         (let ((pair (hons-assoc-equal k (nth ,n ,var))))
                           (if pair (cdr pair) v)))))
               (,updater-name
                (k ,v-formal ,var)
                (declare (xargs :guard ,(common-guard hash-test var top-recog
                                                      etype-term)
                                :verify-guards t
                                ,@stobj-xargs))
                ,(let ((form
                        `(update-nth ,n
                                     (cons (cons k ,v-formal) (nth ,n ,var))
                                     ,var)))
                   (if stobj-formal `(non-exec ,form) form)))
               (,boundp-name
                (k ,var)
                (declare (xargs :guard ,(common-guard hash-test var top-recog
                                                      nil)
                                :verify-guards t))
                (consp (hons-assoc-equal k (nth ,n ,var))))
               ,@(and hashp ; skip this for a stobj-table
                      `((,accessor?-name
                         (k ,var)
                         (declare (xargs :guard
                                         ,(common-guard hash-test var top-recog
                                                        nil)
                                         :verify-guards t))
                         (mv (,accessor-name k ,var)
                             (,boundp-name k ,var)))))
               (,remove-name
                (k ,var)
                (declare (xargs :guard ,(common-guard hash-test var top-recog
                                                      nil)
                                :verify-guards t))
                (update-nth ,n (hons-remove-assoc k (nth ,n ,var)) ,var))
               (,count-name
                (,var)
                (declare (xargs :guard (,top-recog ,var)))
                (count-keys (nth ,n ,var)))
               (,clear-name
                (,var)
                (declare (xargs :guard (,top-recog ,var)))
                (update-nth ,n nil ,var))
               (,init-name
                (ht-size rehash-size rehash-threshold ,var)
                (declare (xargs :guard
                                (and (,top-recog ,var)
                                     (or (natp ht-size)
                                         (not ht-size))
                                     (or (and (rationalp rehash-size)
                                              (<= 1 rehash-size))
                                         (not rehash-size))
                                     (or (and (rationalp rehash-threshold)
                                              (<= 0 rehash-threshold)
                                              (<= rehash-threshold 1))
                                         (not rehash-threshold))))
                         (ignorable ht-size rehash-size rehash-threshold))
                (update-nth ,n nil ,var)))
             (defstobj-field-fns-axiomatic-defs
               top-recog var (+ n 1) (cdr field-templates) wrld))))
         (t ; scalar case
          (append
           `((,accessor-name (,var)
                             (declare (xargs :guard (,top-recog ,var)
                                             :verify-guards t))
                             (nth ,n ,var))
             (,updater-name (,v-formal ,var)
                            (declare (xargs :guard
                                            ,(if (or (eq type-term t)

; We avoid laying down the stobj recognizer twice for a child stobj (although
; that would nevertheless be removed by the use of stobj-optp).

                                                     stobj-xargs)
                                                 `(,top-recog ,var)
                                               (assert$
                                                type-term
                                                `(and ,type-term
                                                      (,top-recog ,var))))
                                            :verify-guards t
                                            ,@stobj-xargs))
                            ,(if stobj-formal
                                 `(non-exec
                                   (update-nth ,n ,v-formal ,var))
                               `(update-nth ,n ,v-formal ,var))))
           (defstobj-field-fns-axiomatic-defs
             top-recog var (+ n 1) (cdr field-templates) wrld))))))))

(defun defstobj-axiomatic-init-fields (field-templates wrld)

; Keep this in sync with defstobj-raw-init-fields.

  (cond
   ((endp field-templates) nil)
   (t (let* ((field-template (car field-templates))
             (type (access defstobj-field-template
                           field-template
                           :type))
             (arrayp (and (consp type) (eq (car type) 'array)))
             (hashp (and (consp type) (eq (car type) 'hash-table)))
             (stobj-tablep (and (consp type) (eq (car type) 'stobj-table)))
             (array-size (and arrayp (car (caddr type))))
             (init0 (access defstobj-field-template
                            field-template
                            :init))
             (creator (get-stobj-creator (if arrayp (cadr type) type)
                                         wrld))
             (init (if creator
                       `(non-exec (,creator))
                     (kwote init0))))
        (cond
         (arrayp
          (cons `(make-list ,array-size :initial-element ,init)
                (defstobj-axiomatic-init-fields (cdr field-templates) wrld)))
         ((or hashp stobj-tablep)
          (cons nil
                (defstobj-axiomatic-init-fields (cdr field-templates) wrld)))
         (t ; whether the type is given or not is irrelevant
          (cons init
                (defstobj-axiomatic-init-fields
                  (cdr field-templates) wrld))))))))

(defun defstobj-creator-def (creator-name field-templates wrld)

; This function generates the logic initialization code for the given stobj
; name.

  `(,creator-name
    ()
    (declare (xargs :guard t :verify-guards t))
    (list ,@(defstobj-axiomatic-init-fields field-templates wrld))))

(defun defstobj-axiomatic-defs (name template wrld)

; Warning:  See the guard remarks in the Essay on Defstobj Definitions.

; Template is the defstobj-template for name and args and thus
; corresponds to some (defstobj name . args) event.  We generate the
; #+acl2-loop-only defs for that event and return a list of defs.  For
; each def it is the case that (defun . def) is a legal defun; and
; these defs can be executed in the order returned.

; These defs are processed to axiomatize the recognizer, accessor and
; updater functions for the single-threaded resource.  They are also
; oneified when we process the defstobj CLTL-COMMAND to define the *1*
; versions of the functions.  Finally, parts of them are re-used in
; raw lisp code when the code is applied to an object other than the
; live one.

; WARNING: If you change the formals of these generated axiomatic defs, be sure
; to change the formals of the corresponding raw defs.

; Warning: Each updater definition in the list returned should immediately
; follow the corresponding accessor definition, as guaranteed by the call of
; defstobj-field-fns-axiomatic-defs, below.  This is important because
; defstobj-axiomatic-defs provides the 'stobj property laid down by
; defstobj-fn, and the function chk-stobj-updaters1 assumes that it will find
; each updater definition in the :names field of that property immediately
; after the corresponding accessor definition.

; See the Essay on Defstobj Definitions.

  (let ((field-templates (access defstobj-template template :field-templates)))
    (append
     (defstobj-component-recognizer-axiomatic-defs name template
       field-templates wrld)
     (list*
      (defstobj-creator-def
        (access defstobj-template template :creator)
        field-templates wrld)
      (defstobj-field-fns-axiomatic-defs
        (access defstobj-template template :recognizer)
        name 0 field-templates wrld)))))

(defun put-stobjs-in-and-outs1 (name field-templates wrld)

; See put-stobjs-in-and-outs for a table that explains what we're doing.

  (cond
   ((endp field-templates) wrld)
   (t (let* ((field-template (car field-templates))
             (type (access defstobj-field-template field-template
                           :type))
             (acc-fn (access defstobj-field-template field-template
                             :accessor-name))
             (upd-fn (access defstobj-field-template field-template
                             :updater-name))
             (length-fn (access defstobj-field-template field-template
                                :length-name))
             (resize-fn (access defstobj-field-template field-template
                                :resize-name))
             (other (access defstobj-field-template
                            field-template
                            :other))
             (boundp-fn (nth 0 other))
             (accessor?-fn (nth 1 other))
             (remove-fn (nth 2 other))
             (count-fn (nth 3 other))
             (clear-fn (nth 4 other))
             (init-fn (nth 5 other)))
        (put-stobjs-in-and-outs1
         name
         (cdr field-templates)
         (cond
          ((and (consp type)
                (eq (car type) 'array))
           (let* ((etype (cadr type))
                  (stobj-flg (if (eq etype 'double-float)
                                 :df
                               (and (stobjp etype t wrld)
                                    etype))))
             (putprop
              length-fn 'stobjs-in (list name)
              (putprop
               resize-fn 'stobjs-in (list nil name)
               (putprop
                resize-fn 'stobjs-out (list name)
                (putprop
                 acc-fn 'stobjs-in (list nil name)
                 (putprop-unless
                  acc-fn 'stobjs-out (list stobj-flg) '(nil)
                  (putprop
                   upd-fn 'stobjs-in (list nil stobj-flg name)
                   (putprop
                    upd-fn 'stobjs-out (list name) wrld)))))))))
          ((and (consp type)
                (member-eq (car type) '(hash-table stobj-table)))
           (let* ((etype (stobj-hash-table-element-type type))
                  (stobj-flg (if (eq etype 'double-float)
                                 :df
                               (and (stobjp etype t wrld)
                                    etype))))
             (putprop
              init-fn 'stobjs-in (list nil nil nil name)
              (putprop
               init-fn 'stobjs-out (list name)
               (putprop
                clear-fn 'stobjs-in (list name)
                (putprop
                 clear-fn 'stobjs-out (list name)
                 (putprop
                  count-fn 'stobjs-in (list name)
                  (putprop
                   remove-fn 'stobjs-in (list nil name)
                   (putprop
                    remove-fn 'stobjs-out (list name)
                    (putprop
                     boundp-fn 'stobjs-in (list nil name)
                     (putprop
; Note that 'stobjs-out for acc-fn in the stobj-table case is placed further
; below.
                      acc-fn 'stobjs-in (if (eq (car type) 'hash-table)
                                            (list nil name)

; See the comment in put-stobjs-in-and-outs about *stobj-table-stobj*.

                                          (list nil name *stobj-table-stobj*))
                      (putprop-unless
                       acc-fn 'stobjs-out (list stobj-flg) '(nil)
                       (putprop
                        upd-fn 'stobjs-in
                        (if (eq (car type) 'stobj-table)

; See the comment in put-stobjs-in-and-outs about *stobj-table-stobj*.

                            (list nil *stobj-table-stobj* name)
                          (list nil stobj-flg name))
                        (putprop
                         upd-fn 'stobjs-out (list name)
                         (if (eq (car type) 'hash-table)
                             (putprop
                              accessor?-fn 'stobjs-in (list nil name)
                              wrld)

; See the comment in put-stobjs-in-and-outs about *stobj-table-stobj*.

                           (putprop acc-fn 'stobjs-out
                                    (list *stobj-table-stobj*)
                                    wrld))))))))))))))))
          (t
           (let ((stobj-flg (if (eq type 'double-float)
                                :df
                              (and (stobjp type t wrld)
                                   type))))
             (putprop
              acc-fn 'stobjs-in (list name)
              (putprop-unless
               acc-fn 'stobjs-out (list stobj-flg) '(nil)
               (putprop
                upd-fn 'stobjs-in (list stobj-flg name)
                (putprop
                 upd-fn 'stobjs-out (list name) wrld))))))))))))

(defun put-stobjs-in-and-outs (name template wrld)

; We are processing a (defstobj name . args) event for which template is the
; template.  Wrld is a world containing the definitions of the accessors,
; updaters and recognizers of the stobj -- all of which were processed before
; we declared that name is a stobj.  Wrld now also contains the belated
; declaration that name is a stobj.  We now put the STOBJS-IN and STOBJS-OUT
; properties for the appropriate names.

; Here are relevant functions and their settings, where we write "table" to
; cover both the hash-table and stobj-table case.  Note that there is no
; accessor? for a stobj-table.

; We use the special value *stobj-table-stobj*, abbreviated below as "?", to
; represent the fact that the third argument and the value of a stobj-table
; accessor call are an arbitrary stobj, as is the second argument of a
; stobj-table updater call.  Since those calls are not allowed directly in
; code, but only by way of stobj-let (rather implicitly), we do not expect to
; see erroneous uses of this special stobjs-in value.  Note that the definition
; of function guard-clauses takes advantage of stobjs-in and stobjs-out values
; involving *stobj-table-stobj* to recognize stobj-table field accesses.

;      fn                  stobjs-in          stobjs-out
; topmost recognizer       (name)             (nil)
; creator                  ()                 (name)
; field recogs             (nil ...)          (nil)
; simple accessor          (name)             (nil)
; hash-table accessor      (nil name)         (nil)
; stobj-table accessor     (nil name ?)       (?)
; array accessor           (nil name)         (nil)
; simple updater           (nil name)         (name)
; hash-table updater       (nil nil name)     (name)
; stobj-table updater      (nil ? name)       (name)
; array updater            (nil nil name)     (name)
; table boundp             (nil name)         (nil)
; hash-table accessor?     (nil name)         (nil nil)
; table remove             (nil name)         (name)
; table count              (name)             (nil)
; table clear              (name)             (name)
; table init               (nil nil nil name) (name)

; The entries above not involving name were correctly computed before we knew
; that name was a stobj and hence are correct in wrld now.

; It is important to realize, in the case of the topmost recognizer, that the
; appearance of name in the stobjs-in setting can be interpreted to mean ``the
; stobj name MAY be supplied here'' as opposed to ``MUST be supplied here.''

  (let ((recog-name (access defstobj-template template :recognizer))
        (creator-name (access defstobj-template template :creator))
        (field-templates (access defstobj-template template :field-templates)))
    (put-stobjs-in-and-outs1 name
                             field-templates
                             (putprop creator-name
                                      'STOBJS-OUT
                                      (list name)
                                      (putprop recog-name
                                               'STOBJS-IN
                                               (list name)
                                               wrld)))))

(defun defconst-name-alist (lst n)
  (if (endp lst)
      nil
    (cons (cons n (defconst-name (car lst)))
          (defconst-name-alist (cdr lst) (1+ n)))))

(defun accessor-array (name field-names)
  (let ((len (length field-names)))
    (compress1 name
               (cons `(:HEADER :DIMENSIONS (,len)
                               :MAXIMUM-LENGTH ,(+ 1 len)
                               :DEFAULT nil ; should be ignored
                               :NAME ,name
                               :ORDER :none)
                     (defconst-name-alist field-names 0)))))

(defun put-defstobj-invariant-risk (field-templates wrld)

; See put-invariant-risk.

  (cond ((endp field-templates) wrld)
        (t (let* ((field-template (car field-templates))
                  (type (access defstobj-field-template field-template :type)))
             (put-defstobj-invariant-risk
              (cdr field-templates)
              (cond ((eq type t)
                     wrld)
                    (t

; The following example from Jared Davis and Sol Swords shows why even arrays
; with elements of type t need to be considered for invariant-risk.

;   To start:

;       (defstobj foo
;         (foo-ch  :type character :initially #\a)
;         (foo-arr :type (array t (3))))

;   The idea is to cause an invalid write to foo-arr that will
;   overwrite foo-ch.  To do this, it is helpful to know the
;   relative addresses of foo-ch and foo-arr.  We can find this
;   out from raw Lisp, but once we know it, it seems pretty
;   reliable, so in the final version there's no need to enter
;   raw Lisp.

;       :q
;       (let ((ch-addr  (ccl::%address-of (aref *the-live-foo* 0)))
;             (arr-addr (ccl::%address-of (aref *the-live-foo* 1))))
;         (list :ch   ch-addr
;               :arr  arr-addr
;               :diff (- ch-addr arr-addr)))
;       (lp)

;   An example result on one invocation on our machine is:

;       (:CH 52914053289693 :ARR 52914053289501 :DIFF 192)

;   When we quit ACL2 and resubmit this, we typically get
;   different offsets for CH and ARR, but the :DIFF seems to be
;   consistently 192.  (In principle, it probably could
;   sometimes be different because it probably depends on how
;   the memory allocation happens to fall out, but in practice
;   it seems to be reliable).  If you want to reproduce this and
;   your machine gets a different result, you may need to adjust
;   the index that you write to to provoke the problem.

;   Since CCL's (array t ...) probably uses 8-byte elements, we
;   should write to address (/ 192 8) = 24.  To do that we will
;   need a program mode function that writes to foo-arri to
;   avoid ACL2's guards from preventing the out-of-bounds write.

;       (defun attack (n v foo)
;         (declare (xargs :mode :program :stobjs foo))
;         (update-foo-arri n v foo))

;   Now we can do something like this:

;       (attack 24 100 foo)

;   After the attack, (foo-ch foo) returns something that Emacs
;   prints as #\^Z, and (char-code (foo-ch foo)) reports 800,
;   which is of course not valid for an ACL2 character.

                     (let ((updater (access defstobj-field-template
                                            field-template
                                            :updater-name)))
                       (putprop updater 'invariant-risk updater wrld)))))))))

(defun defstobj-fn (name args state event-form)

; Warning: If this event ever generates proof obligations (other than those
; that are always skipped), remove it from the list of exceptions in
; install-event just below its "Comment on irrelevance of skip-proofs".

  (with-ctx-summarized
   (msg "( DEFSTOBJ ~x0 ...)" name)
   (let ((event-form (or event-form (list* 'defstobj name args)))
         (wrld0 (w state)))
     (er-let* ((wrld1 (chk-acceptable-defstobj name args ctx wrld0 state)))
       (cond
        ((eq wrld1 'redundant)
         (stop-redundant-event ctx state
                               :name name))
        (t
         (enforce-redundancy
          event-form ctx wrld0
          (let* ((template (defstobj-template name args wrld1))
                 (field-templates (access defstobj-template template
                                          :field-templates))
                 (field-names (strip-accessor-names field-templates))
                 (defconsts (defstobj-defconsts field-names 0))
                 (field-const-names (strip-cadrs defconsts))
                 (ax-def-lst (defstobj-axiomatic-defs name template wrld1))
                 (raw-def-lst (defstobj-raw-defs name template nil wrld1))
                 (recog-name (access defstobj-template template :recognizer))
                 (creator-name (access defstobj-template template :creator))
                 (names

; Warning: Each updater should immediately follow the corresponding accessor --
; and, this is guaranteed by the call of defstobj-axiomatic-defs, above) -- so
; that the 'stobj property laid down below has a :names field that puts each
; updater immediately after the corresponding accessor, as assumed by function
; chk-stobj-let/updaters.

                  (strip-cars ax-def-lst))
                 (the-live-var (the-live-var name))
                 (congruent-to (access defstobj-template template
                                       :congruent-to))
                 (non-memoizable (access defstobj-template template
                                         :non-memoizable))
                 (non-executable (access defstobj-template template
                                         :non-executable)))
            (er-progn
             (cond ((set-equalp-equal names
                                      (strip-cars raw-def-lst))
                    (value nil))
                   (t (value
                       (er hard ctx
                           "Defstobj-axiomatic-defs and defstobj-raw-defs are ~
                            out of sync!  They should each define the same ~
                            set of names.  Here are the functions with ~
                            axiomatic defs that have no raw defs:  ~x0.  And ~
                            here are the functions with raw defs but no ~
                            axiomatic ones:  ~x1."
                           (set-difference-equal
                            names
                            (strip-cars raw-def-lst))
                           (set-difference-equal
                            (strip-cars raw-def-lst)
                            names)))))
             (revert-world-on-error
              (pprogn
               (set-w 'extension wrld1 state)
               (er-progn
                (process-embedded-events 'defstobj
                                         (table-alist 'acl2-defaults-table wrld1)
                                         (or (ld-skip-proofsp state) t)
                                         (current-package state)
                                         (list 'defstobj name names)
                                         (append

; See the comments about defstobj in process-embedded-events for dealing with
; (set-ignore-ok t) and (set-irrelevant-formals-ok t).

                                          (pairlis-x1 'defun ax-def-lst)
                                          defconsts

; We disable the executable-counterpart of the creator function.  The creator's
; *1* function always does a throw, which is not useful during proofs.

                                          `((encapsulate
                                             ()
                                             (set-inhibit-warnings "theory")
                                             (in-theory
                                              (disable
                                               (:executable-counterpart
                                                ,creator-name))))))
                                         0
                                         t ; might as well do make-event check
                                         (f-get-global 'cert-data state)
                                         ctx state)


; The processing above will define the functions in the logic, using
; defun, and that, in turn, will define their *1* counterparts in
; Lisp.  But because of code in defuns-fn, the processing above will
; not define the raw Lisp versions of the functions themselves
; (normally that would be derived from the axiomatic defs just
; processed).  Instead, we will store a CLTL-COMMAND below that
; handles the raw Lisp defs only.

; What follows is hard to follow and rather arcane.  Why do we include
; name in the ee-entry computed above, (defstobj name names)?  That
; entry will be added to the embedded-event-lst by
; process-embedded-events and be inspected by the individual defuns
; done.  Those defuns will recognize their fn name, fn, among names,
; to detect that they are being done as part of a defstobj.  The defun
; will pick up the stobj name, name, from the ee-entry and build it
; into the ignorep entry of the defun CLTL-COMMAND, to be processed by
; add-trip.  In add-trip, the stobj name, name, will find its way into
; the oneify-cltl-code that generates the *1* body for fn.  That body
; contains a throw upon detection of a guard error.  The object thrown
; contains the stobjs-in of the offensive expression, so we will know
; how to print it.  But the stobjs-in of fn is incorrectly set in the
; world right now -- more accurately, will be incorrectly set in the
; world in which the defun is done and the throw form is constructed
; -- because we have not yet declared name to be a stobj.  Indeed, we
; cannot declare it to be a stobj yet since we are defining functions
; that treat it as an ordinary list.  This is the stobj version of the
; super-defun-wart problem.

                (let* ((wrld2 (w state))
                       (congruent-stobj-rep
                        (and congruent-to
                             (congruent-stobj-rep congruent-to wrld2)))
                       (wrld3
                        (put-defstobj-invariant-risk
                         field-templates
                         (putprop
                          name 'congruent-stobj-rep congruent-stobj-rep
                          (putprop-unless
                           name 'non-memoizable non-memoizable nil
                           (putprop

; Here I declare that name is Common Lisp compliant.  Below I similarly declare
; the-live-var.  All elements of the namex list of an event must have the same
; symbol-class.

                            name 'symbol-class :common-lisp-compliant
                            (put-stobjs-in-and-outs
                             name template

; Rockwell Addition: It is convenient for the recognizer to be in a
; fixed position in this list, so I can find out its name.

                             (putprop
                              name 'stobj
                              (make stobj-property
                                    :live-var the-live-var
                                    :recognizer recog-name
                                    :creator creator-name
                                    :names
; See the comment in the binding of names above.
                                    (append (set-difference-eq
                                             names
                                             (list recog-name
                                                   creator-name))
                                            field-const-names))
                              (putprop-x-lst1
                               names 'stobj-function name
                               (putprop-x-lst1
                                field-const-names 'stobj-constant name
                                (putprop
                                 the-live-var 'stobj-live-var name
                                 (putprop
                                  the-live-var 'symbol-class
                                  :common-lisp-compliant
                                  (putprop
                                   name
                                   'accessor-names
                                   (accessor-array name field-names)
                                   wrld2))))))))))))
                       (discriminator
                        (cons 'defstobj
                              (make
                               defstobj-redundant-raw-lisp-discriminator-value
                               :event event-form
                               :recognizer recog-name
                               :creator creator-name
                               :congruent-stobj-rep
                               (or congruent-stobj-rep name)
                               :non-memoizable non-memoizable
                               :non-executable non-executable))))

; The property 'stobj marks a single-threaded object name.  Its value is a
; stobj-property record containing all the names associated with this object.

; Every supporting function is marked with the property
; 'stobj-function, whose value is the object name.  The live var name
; is marked with 'stobj-live-var, whose value is the object name.

; CHEAT:  I ought, at this point,
;                 (pprogn
;                  (update-user-stobj-alist
;                   (cons (cons name (create-stobj name template))
;                         (user-stobj-alist state))
;                   state)

; That is, I should add to the user-stobj-alist in state an entry for
; this new stobj, binding its name to its initial value.  But I don't
; want to create the logical counterpart of its initial value -- the
; function create-stobj cannot be used this way (only uses
; resulting from with-local-stobj will pass translate), and we do
; not want to hack our way through the admission of this function
; which is apparently consing a stobj into an alist.  Instead, I rely
; on the live object representing the stobj.  This live object is
; created when the CLTL-COMMAND below is processed by add-trip.
; Add-trip evals the init form in raw lisp to create the live object
; and assign it to global variables.  It also creates array-based
; accessors and updaters.  It then stores this live object in the
; user-stobj-alist of the state just as suggested above, provided this
; is not a redefinition.  (For a redefinition of the stobj, it does a
; put-assoc-eq rather than a cons.)

; The down-side to this cheat is that this only works while
; defstobj-fn is a :program mode function called on the live state,
; where the raw code operates.  If I admitted this function to the
; logic and then called it on the live state, I would get an effect on
; the live state not explained by the code.  Furthermore, if I called
; it on a fake state, I would get a new fake state in which the new
; stobj was not on the user-stobj-alist.

; It will be a while before these discrepancies bother me enough to
; fix.  As long as this is a :program mode function, we won't be able
; to prove that its effect on state is contrary to its semantics as
; expressed here.

                  (install-event name
                                 event-form
                                 'defstobj

; Note: The namex generated below consists of the single-threaded
; object name, the live variable name, and then the names of all the
; functions introduced.  Big-d-little-d-event knows it can cdr past
; the first two elements of the namex of a defstobj to find the list
; of functions involved.

                                 (list* name the-live-var names)
                                 nil
                                 `(defstobj ,name
                                    ,the-live-var
                                    ,(defstobj-raw-init template)
                                    ,raw-def-lst
                                    ,discriminator
                                    ,ax-def-lst
                                    ,event-form)
                                 t
                                 ctx
                                 wrld3
                                 state))))))))))))))

; Essay on the Correctness of Abstract Stobjs

; In this Essay we provide a semantic foundation for abstract stobjs that shows
; the critical role of :CORRESPONDENCE, :PRESERVED, and :GUARD-THM lemmas.  Our
; goal is to explain why the logical definitions of abstract stobj primitives
; are reflected correctly by Lisp evaluation.  It may be helpful to read the
; :doc topic for defabsstobj before reading this Essay.  It may also be helpful
; to look at examples involving defabsstobj; community book
; books/demos/defabsstobj-example-1.lisp is particularly simple and may be
; sufficient.

; This Essay argues that we have a sound foundation for abstract stobjs, based
; on a model of computation.  It does not consider local stobjs, which we
; believe would not present any surprises.  An interesting future project could
; be to formalize this argument in ACL2 (or any proof assistant), even
; extending to local stobjs.

; Our motivation is to understand why non-erroneous evaluation in the ACL2 loop
; produces results that "correspond" to what is expected logically.  To that
; end, we introduce below a general notion of E*-correspondence that reduces to
; equality for ordinary objects but is suitable for stobjs as well.  In
; particular, we expect that when an input term evaluates to an abstract stobj,
; s, then the evaluation result "corresponds" (in the E*-correspondence
; relation) to the value provably equal to the input term with respect to the
; current logical state.  In summary: evaluation uses foundational stobjs and
; :EXEC primitives for abstract stobjs, and this Essay formalizes this notion
; of evaluation and shows how it corresponds to purely logical computation
; using :LOGIC functions for each abstract stobj.

; Below, we may designate a function symbol f as a "stobj primitive (for s)"
; (or, "s-primitive") when f is introduced by a defstobj or (more often)
; defabsstobj event (for stobj s).  In the case of defabsstobj, we may write
; f_E and f_L for the function symbols associated with f (perhaps by default)
; by the :EXEC and :LOGIC keywords, respectively; these may be called the :EXEC
; (s-)primitive and :LOGIC (s-)primitive.  A stobj primitive other than the
; recognizer or creator may be called a "stobj export".

; This Essay models evaluation using live stobjs, as performed in the top-level
; loop.  (We do not consider here evaluation without live stobjs, as is carried
; out on ground terms during proofs, as :LOGIC primitives are used there for
; evaluation.)  But the replacement of ACL2 objects by live stobjs in raw Lisp
; is not what's new for abstract stobjs, so we avoid that implementation level.
; Rather, we deal in this Essay only with ACL2 objects.  That is: our modeling
; of evaluation uses ACL2 objects, even when modeling evaluation that takes
; place in raw Lisp using live stobjs.

; (That said, there are clearly issues to address to ensure that raw Lisp
; evaluation involving live stobjs is truly modeled by our evaluator.  The
; anti-aliasing restriction implemented in
; no-duplicate-indices-checks-for-stobj-let-actuals is an example of how we
; avoid a non-applicative child stobj modification that would not be modeled by
; our purely functional object-level evaluator.)

; We introduce two kinds of evaluation: the :EXEC evaluator models how ACL2
; actually does evaluation (again, avoiding consideration of live stobjs),
; while the :LOGIC evaluator models evaluation in the logic.  The only
; difference between the :EXEC and :LOGIC evaluators is how they define each
; abstract stobj primitive: to call its :EXEC or :LOGIC primitive,
; respectively.  We take it as self-evident that :LOGIC evaluation soundly
; represents logical definitions and :EXEC evaluation represents actual ACL2
; evaluation in its read-eval-print loop.  We will show below how these two
; evaluators run in lock-step with respect to corresponding alists with a
; common domain.  Each alist binds variables to values, where for each abstract
; stobj name in the common domain: its values in the :EXEC and :LOGIC evaluator
; alists satisfy the correspondence predicate for that abstract stobj.  All
; evaluations enforce guards on stobj primitives.  (The ACL2 implementation
; does so as well, even when guard-checking is nil or :none.)

; This Essay lays out how and why these two evaluations correspond.  We
; implicitly rely below on the single-threadedness checks done by ACL2.  We
; ignore stobj hash-table and array primitives (such as array resizing) that we
; see as not causing complications.  (Throughout this Essay, by "hash-table
; fields" we mean to include stobj-table fields.)  We also ignore errors other
; than guard violations; see the Essay on Illegal-states, in
; *inside-absstobj-update* for how incomplete abstract stobj updates are
; handled by the implementation.

; Remark.  The careful reader might have noticed that a variable v is bound to
; a stobj if v is the name of a stobj, even in a context where v was not
; declared to be a stobj.  (Think: (defstobj st fld), (defun foo (st) st).)  We
; gloss over this sort of unimportant detail here, as this issue can be
; resolved by suitable renaming.

; We do not use the ACL2 function EV directly in this essay, but our notions of
; evaluation are related to it.  (See the Essay on EV for background on EV.)
; :LOGIC evaluation closely follows EV.  In particular, EV traffics in
; so-called "latches", which are alists that represent stobj values.  For our
; abstract modeling of evaluation, we ignore EV's latches and state, while for
; convenience, we treat every stobj name as representing a stobj (as though
; there were latches that include every stobj name that is free in the given
; term).  Imagine that at the end of each top-level evaluation, each stobj
; returned is latched into the (implicit) global state, much as trans-eval
; updates the user-stobj-alist of the state.  Thus, when we show that the
; results of :EXEC and :LOGIC evaluation correspond, we are implicitly showing
; that the updated :EXEC and :LOGIC states also correspond -- a crucial
; invariant, since the implicit state supplies stobj values for the next
; top-level evaluation.

; Definitions.  Let al be an alist mapping variables to values.  We say that a1
; is A-proper if for every pair <s,x> in al such that s is a stobj name, x
; satisfies the :EXEC recognizer for s if s is in A, else x satisfies the
; recognizer for s (equivalently, x satisfies the :LOGIC recognizer for s).
; Note that when we discuss notions like "satisfies" we are of course
; referencing logic, not evaluation).  When A is the empty set, {}, we may call
; an A-proper alist "L-proper" ("L" for "logic").  When A is the set of all
; abstract stobj names in the (implicit) current ACL2 world, we may call an
; A-proper alist "E-proper" ("E" for "exec").

; We view the :LOGIC and :EXEC evaluators as special cases of a class of
; evaluators that we now introduce.  Fix an ACL2 world and let A be a set of
; abstract stobj names; :EXEC evaluation is the case that A is the set of all
; abstract stobj names, while :LOGIC evaluation is the case where A is the
; empty set.  A-evaluation is modeled by a function we call ev+ with the
; following signature, where "+" suggests the extra argument A, below.

;   (ev+ term alist A)
;   =
;   (mv erp r)

; Here is a brief informal description of ev+.  The inputs are term, a term; A,
; a set of abstract stobj names; and alist, an A-proper alist mapping variables
; to values whose domain includes the free variables of term.  (This last part
; isn't necessary; we could treat missing free variables as being mapped to
; nil.  We'll feel free to be a bit careless about this domain requirement.)
; The outputs erp and r represent what we call an "error indicator" and a
; "return value", respectively, as follows.  Erp is nil when no guard violation
; has been encountered, in which case r is the return value, which is a list in
; the multiple-value case.  (Indeed, ev+ treats mv the same as list; more
; precisely, ev+ operates on terms for which macros, including mv and list,
; have been expanded away.)  Otherwise erp is t and r is an alist associating
; the names of stobjs bound in al with their post-evaluation values, that is,
; from the input alist at the time of the guard violation.  In particular, if
; no stobj is changed and erp is t, then r is the restriction of the input
; alist to the set of stobj names.

; Note that we are not obligated to consider aborts, since we consider all bets
; to be off in that case.  Of course, as a practical matter we prefer that
; aborts avoid the creation of bad states.  We believe that we could extend our
; argument by modeling aborts through adding an oracle argument to ev+, where
; erp is t when an abort is indicated by the oracle.  However, we don't take
; that step in this Essay.

; We omit a detailed definition of ev+, which would contain no big surprises;
; but we discuss key cases.

; - CASE (ev+ v a0 A), where v is a variable

;   Return (mv nil val), where val is the value of v in a0.

; - CASE (ev+ (quote x) a0 A)

;   Return (mv nil x).

; - CASE (ev+ (f t1 ... tk) a0 A), where f is a function symbol or lambda, but
;   f is not a stobj primitive for a stobj in A

;   First compute each (ev+ ti a0 A) = (mv ei xi) from 1 to k, returning (mv ei
;   xi) if and when we encounter ei = t.  If each ei is nil then for formals
;   (v1 ... vk), guard g, and body b of f, bind each vi to xi to create alist
;   a1; then compute (ev+ g a1 A) = (mv eg xg) for i from 1 to k.  If some eg
;   is t or xg is nil then return (mv t a0') where a0' is the restriction of a0
;   to stobjs.  Otherwise (i.e., each eg = nil and each xg is non-nil), compute
;   (ev+ b a1 A) = (mv e x).  If e is nil then return (mv nil x).  Otherwise,
;   -- with the following exceptions for errors (i.e., guard errors) -- return
;   (mv t a0'), where a0' is produced by updating the stobj entries of a0 with
;   corresponding stobj results from the alist, x.  In the following
;   exceptional cases a0' is just the restriction of a0 to stobj names.

;   - EXCEPTION 1: stobj-let update of a child stobj

;     The term (f t1 ... tk) is the translation of a stobj-let form when at
;     least one ti is a stobj accessor for a field of stobj type, and therefore
;     f is a lambda.  Then if there is an error during evaluation of the
;     lambda, we throw away the child stobj binding rather than updating it in
;     the alist, a0.  In the actual implementation we would actually expect to
;     get an error in this case.  See the use of with-inside-absstobj-update in
;     stobj-let-fn-raw (which takes advantage of special variable
;     *inside-absstobj-update* much as we use it for non-atomic exports of
;     abstract stobjs).

;   - EXCEPTION 2: with-local-stobj

;     Translation of a with-local-stobj form creates a lambda application with
;     a stobj creator as an argument.  If an error occurs during evaluation of
;     the body of a lambda with a stobj creator argument, we define a0' to
;     avoid updating the binding (if any) for that stobj.

;   - EXCEPTION 3: f is a stobj primitive for a stobj not in A

;     In this case, after successfully checking the guard for f, we avoid guard
;     checking while evaluating the corresponding call of the :LOGIC primitive
;     f_L for f, as though (with-guard-checking :none ...) were wrapped around
;     that call.  We should model this separately, say, with a variant of ev+
;     that treats all guards as t, uses logical axioms for evaluation (e.g.,
;     (car 3) is nil), and isn't concerned about whether the input alist is
;     A-proper.  But for simplicity we'll keep that implicit; all properties of
;     ev+ carry over of course since we are not changing the structure of its
;     definition (only changing the guards, ignoring stobjs, and "completing"
;     the axioms).  Note that since we never get a guard violation during such
;     evaluation, the stobjs-out are irrelevant if A is empty.

; - CASE (ev+ (f t1 ... tk) a0 A), where f is a stobj primitive for a stobj s0
;   in A (hence s0 is an abstract stobj)

;   The only difference from the case above is that the body, b, of f is
;   considered to be (f_E v1 ... vk).

; As suggested above, we may refer to (ev+ ... {}) as :LOGIC evaluation, and we
; may refer to (ev+ ... A) as :EXEC evaluation when A is the set of all
; abstract stobj names (in the current world).  The use of :LOGIC and :EXEC
; primitives in respective logical and raw Lisp definitions of the abstract
; stobj primitives (see defabsstobj-raw-def and defabsstobj-axiomatic-defs,
; resp.) is key to the observation that :LOGIC evaluation represents evaluation
; in the logic and :EXEC evaluation represents evaluation actually carried out
; by ACL2.  For convenience we introduce abbreviations ev_E and ev_L as
; follows, for an implicit ACL2 world, w.

;   :EXEC evaluation:
;   (ev_E term alist) = (ev+ term alist A)
;      where A is the set of all abstract stobj names in w

;   :LOGIC evaluation:
;   (ev_L term alist) = (ev+ term alist {})

; Remark.  Ev+ is defined without allowing the use of attachments.  However, we
; consider the use of attachments in a world w to be nothing more than
; evaluation in a world whose theory is the evaluation theory of w.  (See the
; Evaluation History Theorem in the Essay on Defattach.)  Thus, we could define
; ev+ to allow attachments simply by considering ev+ to take place in that
; world, w.  Thus attachments do not present any additional issues, and we
; ignore them for the rest of this Essay.  -|

; We next put forward definitions and lemmas that support the statement and
; proof of the theorem below.  We omit the lemmas' proofs by computational
; induction, which we believe are straightforward.  Note that we have long
; relied heavily on some of these lemmas; ACL2 could be badly broken if they
; failed to hold.

; Definition.  For an alist a, let Q(a), the "quotation of" a, be the result of
; replacing each pair <var,val> in a by <var,(quote val)>.  -|

; Our first lemma connects :LOGIC evaluation to what is logically valid.
; Although it only applies to logic-mode terms, our main theorem does not have
; that restriction; this works out because Lemma 1 is applied to abstract stobj
; primitives and their guards, which are always guard-verified logic-mode
; functions.

; Lemma 1.  Let term be a logic-mode term and let al be an L-proper alist, and
; assume that (ev_L term al) = (mv nil r).  Then it is a theorem (of the
; current world) that term/Q(al) = (quote r).  -|

; We note a sort of converse that follows trivially: if (ev_L term a) = (mv nil
; r) and it is a theorem that term/Q(a) = (quote r'), then r = r'.

; The next two lemmas give sufficient conditions for the error indicator to be
; nil when dealing with guard-verified functions.

; Lemma 2.  Let al be an L-proper alist.  If f is a guard-verified function
; with guard g, then (ev_L g al) = (mv nil r) for some r.  -|

; Lemma 3.  Let al be an L-proper alist.  Let f be a guard-verified function
; with formals (v1 ... vk) and suppose that al binds each vi.  Let g be the
; guard of f, and assume that (ev_L g al) = (mv nil r_g) where r_g is non-nil.
; Then (ev_L (f v1 ... vk) al) = (mv nil r) for some r.  -|

; Note that by Lemma 1, the value r computed in Lemma 3 for a call of f is such
; that the equality (f v1 ... vk)/Q(al) = (quote r) is a theorem of the current
; world.

; Lemma 4.  Assume that world w2 is a initial segment of world w1, u is a term
; of w2, and al is an alist whose domain includes the set of variables of u,
; which is assumed E-proper or L-proper with respect to w1 for (a) or (b)
; below, respectively.  Then:
;
; (a) The value of (ev_E u al) is the same when computed with respect to w2 as
;     when computed with respect to w1, assuming that all abstract stobj
;     variables of u are in w2.

; (b) The value of (ev_L u al) is the same when computed with respect to w2 as
;     when computed with respect to w1.  -|

; Lemma 5.  If a1 and a2 agree on all the free variables of the term u, then
; (ev+ u a1 A) = (ev+ u a2 A) for every A.  In particular, (ev_L u a1) = (ev_L
; u a2) and (ev_E u a1) = (ev_E u a2).  -|

; We may use Lemma 5 implicitly, for example by being able to assume
; implicitly, when considering (ev+ u al A), that the domain of al is the set
; of free variables of u.

; Our final lemma is trivial by definition of ev+ (the final equation holds
; because both sides equal (ev+ bf a2 A) where bf is the body of f).

; Lemma 6.  Let al be an alist, let f be a function symbol or lambda with
; formals (v1 ... vk), let (t1 ... tk) be a list of terms, and let g be the
; guard for f (considered as t for a lambda).  Assume that (ev+ ti al A) = (mv
; nil xi) for each i, and let a2 be the alist ((v1 . x1) ... (vk . xk)).
; Assume that (ev+ g a2 A) = (mv nil val_g) where val_g is non-nil.  Then (ev+
; (f t1 ... tk) al A) = (ev+ (f v1 ... vk) a2 A).  -|

; Remark.  A reason we need the invariant that stobjs satisfy their :LOGIC
; recognizers is to satisfy the hypotheses of the CORRESPONDENCE, PRESERVED,
; and GUARD-THM theorems.  But why do we care that :EXEC recognizers hold?  We
; care because we want evaluation in raw Lisp to complete without guard
; violations.  As noted at the outset of this Essay, we are not trying to prove
; correctness of raw Lisp evaluation; still, guaranteeing that guards are met
; is something minimal that we are happy to do.  -|

; There are complications when an abstract stobj's foundation can itself be an
; abstract stobj. There are also complications when a stobj can have a child
; stobj that is an abstract stobj (or is an array or hash table that contains
; abstract stobjs).  We ignore these complications for now, in particular for
; the "narrow version" of the main theorem, which depends on a correspondingly
; narrower version of E*-correspondence, namely, E-correspondence.  After
; proving the theorem we will return to the general version.

; The following definition formalizes a notion of correspondence between two
; objects or two alists, x and y.  It is motivated by evaluations (ev_E u a_E)
; = (mv nil x) and (ev_L u a_L) = (mv nil y) for corresponding alists a_E and
; a_L.  When abstract stobjs are not involved, this notion of correspondence
; reduces to x = y.  But if u returns an abstract stobj, s, then we require the
; correspondence predicate for s to hold for the pair <x,y>.  The
; multiple-values case is similar: in particular, if u has stobjs-out (s1
; ... sk) where k > 1, x = (x1 ... xk), and y = (y1 ... yk), and si is an
; abstract stobj name, then <xi,yi> should satisfy the correspondence predicate
; for si.

; Definition (E-correspondence).  Let s be a stobj name (abstract or concrete)
; or nil, and let x and y be arbitrary objects.  (Note: Often s is implicit
; from the context.)  Then x E-corresponds to y with respect to s when the
; following conditions are all met.

; - If s is nil or a concrete stobj name, then x = y.

; - If s is an abstract stobj name, the pair <x,y> satisfies the correspondence
;   predicate for s.

; - If s is an abstract stobj name, then x satisfies the :EXEC recognizer for
;   s, that is, the recognizer for the foundational stobj for s.

; - If s is a stobj name, then y satisfies the :LOGIC recognizer for s
;   (equivalently, the recognizer for s).

; The notion of E-correspondence naturally extends to two alists a1 and a2 by
; requiring that they have the same domain and for all <s,x> and <s,y> in a1
; and a2 respectively, x E-corresponds to y with respect to s.  A clearly
; equivalent condition is that a1 is E-proper, a2 is L-proper, and for all
; <s,x> and <s,y> in a1 and a2 respectively: if s is not an abstract stobj name
; then x = y, and otherwise the correspondence predicate for s holds for the
; pair <x,y>.  -|

; We are ready for our main theorem about evaluation.

; Theorem: Evaluation Preserves Correspondence (narrow version).  Fix an ACL2
; world w.  Assume that the alist a_E E-corresponds to the alist a_L, let u be
; a term of w, and let error indicators and return values be defined as
; follows.

;   (mv erp_E r_E) = (ev_E u a_E)
;   (mv erp_L r_L) = (ev_L u a_L).

; Then erp_E = erp_L and r_E E-corresponds to r_L.

; Proof.  We induct on the number of abstract stobjs in w.  The base case,
; where there are no abstract stobjs, is essentially trivial by computational
; induction, since if there are no abstract stobjs then E-correspondence of a_E
; and a_L implies their equality, and the evaluators ev_L and ev_E are the
; same.  The only thing to check, for E-correspondence of the identical
; results, is that stobj recognizers all hold on stobjs in the result.  We take
; this as obvious due to the single-threadedness restrictions imposed by ACL2.

; So assume that w defines at least one abstract stobj, and let s0 be the
; abstract stobj introduced last in w.  Let w2 be the initial segment of w
; consisting of all events preceding the introduction of s0; so by the
; inductive hypothesis, the theorem holds for w2.

; We now proceed by computational (sub-)induction on (ev_L u a_L).  The result
; is obvious if u is a variable or a quoted constant.  Suppose then that u is
; (f t1 ... tk). Let (v1 ... vk) be the formals of f.  By definition of ev+,
; both (ev_E u a_E) and (ev_L u a_L) first evaluate each ti, which by the
; computational inductive hypothesis yield respectively the pairs (mv ei xi)
; and (mv ei yi) for the same ei and E-corresponding xi and yi.  If any ei is
; t, then (ev_E u a_E) = (mv t xi) and (ev_L u a_L) = (mv t yi) and we are done
; by the (computational) inductive hypothesis; so assume that each ei is nil.
; Now form alists b_E and b_L that bind each formal vi of f to xi and yi,
; respectively; these alists are E-corresponding since (as noted above) xi and
; yi are E-corresponding.  Let g be the guard of f.  By the computational
; inductive hypothesis, (ev_E g b_E) = (ev_L g b_L).  If this common value has
; a non-nil error indicator, or if it is (mv nil nil), then (ev_E u a_E) = (mv
; t a_E') and (ev_L u a_L) = (mv t a_L'), where a_E' and a_L' are the
; respective restrictions of a_E and a_L to stobj names.  Now a_E' and a_L'
; E-correspond because a_E and a_L E-correspond (by hypothesis), which
; concludes the proof in the case of a guard violation.  So we may assume the
; following for some value, val_g.

; (1)     (ev_L g b_L) = (ev_E g b_E) = (mv nil val_g) and val_g is non-nil

; If f is not a stobj primitive, then the desired conclusion is immediate from
; the computational inductive hypothesis applied to corresponding evaluations
; of the body of f.  If f is a concrete stobj primitive then we treat it
; specially (see Exception 3 above) since using the body would violate guards
; (in particular when recurring with nth on the cdr of the stobj to access a
; field).  But we are assuming here that child fields are never abstract
; stobjs; thus E-correspondence reduces to equality, and the conclusion is
; immediate.

; So assume that f is an s-primitive where s is an abstract stobj.  First
; suppose that s is not s0.  The following equations hold by (1), Lemma 6, and
; the definition of ev+.

;         (ev_E u a_E) = (ev_E (f v1 ... vk) b_E)
;         (ev_L u a_L) = (ev_L (f v1 ... vk) b_L)

; Since we are in the case that s is not s0, therefore s0 is not among the
; formals of f since f is defined in w2, before s0 is introduced.  The
; conclusion follows immediately from Lemma 4 and the (top-level) inductive
; hypothesis applied to w2.

; We are left with the case that s is s0.  Assume that some formal vi of f is
; s0; otherwise the argument is similar but a bit simpler.  So we represent the
; formals of f as (v1 ... s0 ... vk).  For notational simplicity we consider
; only the case that f returns a single value; the general case differs only by
; considering each specific position's result.

; Let f_E be the :EXEC version of f and let s0$c be the foundational stobj for
; s0.  Also let Corr0 be the correspondence predicate for s0, let s0_E =
; b_E(s0), and let s0_L = b_L(s0).  Thus Corr0 holds of <s0_E,s0_L> since, as
; noted above, b_E and b_L are E-corresponding (and thus s0_E E-corresponds to
; s0_L with respect to s0).

; By (1) and Lemma 1, the following is a theorem.

; (1')     g/Q(b_L) = (quote val_g).

; Let g_E be the guard of f_E.  Let b_L' be the result of adding the pair
; <s0$c,s0_E> to b_L; thus it is a theorem that g/Q(b_L') = (quote val_g) by
; Lemma 5, since s$c does not occur free in g, because s$c is not a formal of
; f.  (This observation is justified by the following excerpt taken from :doc
; defabsstobj, which uses the name "f$c" where we use "f_E" in this Essay: "The
; formals of f are obtained by taking the formals of f$c and replacing st$c by
; st.")  By the GUARD-THM for s0, it is a theorem that (implies g g_E); by
; instantiating this formula with Q(b_L'), then since Corr0 holds of
; <b_L'(s0$c),b_L'(s0)> (because this is <s0_E,s0_L>), it is a theorem that
; g_E/Q(b_L') != nil.  So by Lemma 1 (actually the converse noted after it) and
; Lemma 2 (since f_E is guard-verified),

;         (ev_L g_E b_L') = (mv nil val_g_E) for some non-nil val_g_E.

; By this equation, (1), and Lemma 3, we have the following, for some val_f_E
; and val_f.

; (2_E)   (ev_L (f_E v1 ... s0$c ... vk) b_L')  = (mv nil val_f_E)
; (2_L)   (ev_L (f   v1 ... s0   ... vk) b_L)   = (mv nil val_f)

; These equations and Lemma 1 together imply that the following are theorems,
; where for (3_L) we first replace b_L by b_L' in (2_L), which is justified by
; Lemma 5 since as observed above, s0$c is not a formal of f.

; (3_E)   (f_E v1 ... s0$c ... vk)/Q(b_L') = val_f_E
; (3_L)   (f   v1 ... s0   ... vk)/Q(b_L') = val_f

; The following key fact then follows by instantiating the CORRESPONDENCE
; theorem with Q(b_L'), where the hypotheses of that implication hold by the
; fact that Corr0 holds of <b_L'(s0$c),b_L'(s0)> (as noted above) together with
; (1'), and because b_L'(s0) satisfies the recognizer for s0 (since the
; theorem's E-correspondence hypothesis implies that b_L is L-proper).

; (4)     The pair <val_f_E,val_f> satisfies Corr0 if f returns s0 (as per the
;         stobjs-out of f), else val_f_E = val_f.

; Let b_L'' be the result of removing the pair <s0,s0_L> from b_L' (but keeping
; the pair <s0$c,s0_E>).  Thus we may modify equation (2_E) by substituting
; b_L'' for b_L', justified by Lemma 5 since s0 is not a formal of f_E.

; (2_E')  (ev_L (f_E v1 ... s0$c ... vk) b_L'') = (mv nil val_f_E)

; Note that this equation holds not only for the given world, w, but also for
; w2, by Lemma 4.  Let b_E$c be the result of replacing <s0,s0_E> in b_E with
; <s0$c,s0_E>.  Then since b_E E-corresponds to b_L, and since b_E$c and b_L''
; modify these respectively by eliminating s0 from the domain and adding the
; pair <s0$c,s0_E>, therefore b_E$c E-corresponds to b_L''.  (Note that the
; common value of s0_E for s0$c in the two alists is appropriate for
; E-correspondence because s0$c is a concrete stobj, as we are not yet handling
; the general case where the foundational stobj may be an abstract stobj.
; E-correspondence also requires that s0_E satisfy the recognizer for s0$c; but
; that follows since as already noted, b_E E-corresponds to b_L, which by
; definition of E-correspondence that implies that b_E is E-proper, which
; implies that b_E(s0) satisfies the :EXEC recognizer for s0, i.e., that s0$c
; satisfies the recognizer for s0$c.)

; We next use the above deduction that b_E$c and b_L'' E-correspond, by
; applying the top-level inductive hypothesis to w2.  That and equation (2_E')
; together yield the following, for some val_f_E$c and val_f_E.

; (5)     (ev_E (f_E v1 ... s0$c ... vk) b_E$c) = (mv nil val_f_E$c)
;         and
;         val_f_E$c E-corresponds to val_f_E with respect to the stobj returned
;         by f_E (or nil if f_E does not return a stobj).

; This equation is equivalent to the following, since the two left-hand sides
; both reduce to the call of ev_E on the body of f_E in an alist binding each
; formal to its value in b_E -- in particular, binding the formal s0$c to s_E
; in both cases (as s0 is in the s0$c position in (6)).

; (6)     (ev_E (f_E v1 ... s0   ... vk) b_E)   = (mv nil val_f_E$c)

; Recall the following equation.

; (2_L)   (ev_L (f   v1 ... s0   ... vk) b_L)   = (mv nil val_f)

; The proof concludes by (2_L) and (6) if we show that val_f_E$c E-corresponds
; to val_f with respect to the stobjs-out returned by f.  More precisely, let s
; be the car of the stobjs-out of f (which for simplicity we have assumed to be
; a one-element list); think of s as the "type" of f.  We show that val_f_E$c
; E-corresponds to val_f with respect to s.  To see this we will split into
; three cases.  But first we present two Claims.

; Claim 1: Assume that s is a stobj name; then val_f satisfies the :LOGIC
; recognizer for s.  To prove this we consider two cases.  For the case that s
; is s0 this follows from (2_L) and the PRESERVATION theorem (with the use of
; Lemma 1 to trade theoremhood with evaluation, as usual).  So suppose that s
; is not s0.  By (4), val_f_E = val_f.  So by (5), val_f_E$c E-corresponds to
; val_f with respect to s.  By definition of E-corresponds, val_f satisfies the
; :LOGIC recognizer for s.

; Claim 2. Assume that s is an abstract stobj name; then val_f_E$c satisfies
; the :EXEC recognizer for s.  This is clear from (5).

; We return to showing that val_f_E$c E-corresponds to val_f with respect to s.
; First suppose that s is s0, i.e., f returns s0.  Then f_E returns s0$c, which
; is not an abstract stobj, and thus val_f_E$c = val_f_E by (5): val_f_E$c was
; chosen to E-correspond to val_f_E with respect to the stobj returned by f_E,
; which is the concrete stobj, s0$c.  Now <val_f_E,val_f> satisfies Corr0 by
; (4), so substituting equals for equals we see that <val_f_E$c,val_f>
; satisfies Corr0.  This implies that val_f_E$c E-corresponds to val_f by
; Claims 1 and 2.

; Next suppose that s is an abstract stobj other than s0.  Then val_f_E = val_f
; by (4), and val_f_E$c E-corresponds to val_f_E by (5).  Therefore val_f_E$c
; E-corresponds to val_f.

; The final case is that s is not an abstract stobj.  Then val_f_E = val_f by
; (4) and val_f_E$c = val_f_E by (5), so val_f_E$c E-corresponds to val_f with
; respect to s by Claims 1 and 2.  -|

; We now address the general case, in which the foundational stobj may itself
; be an abstract stobj, and both abstract and concrete stobjs may have stobj
; fields (scalar or not), which may themselves be abstract or concrete.  The
; key is to update the notion of E-correspondence to a notion of
; E*-correspondence, so that every logical object is in inverse
; E*-correspondence with the stobj object that is actually used by ACL2
; evaluation.  Informally: The stobj object used by evaluation is obtained from
; the logical object by following a chain of foundations down to a concrete
; stobj (or any stobj not in A), and then similarly replacing child stobjs.

; The following informal example illustrates the idea above.  We start with
; an outline of it.

; Tower of stobjs made successively "more concrete":

; s0 / c0 {s0 has child c0 and foundation s1}
; s1 / c1 {s1 has child c1 and foundation s2}
; s2 / c2 {s2 is a concrete stobj with child c2; c2 has foundation c3}
;      c3 {c3 is a concrete stobj}

; Objects instantiating the stobjs above, preserving correspondence at each
; step:

; x0 / y0 {x0 instantiates s0; has child y0 that instantiates c0}
; x1 / y1 {x1 instantiates s1; has child y1 that instantiates c1}
; x2 / y2 {x2 instantiates s2; has child y2 that instantiates c2}
; x3 / y3 {x3 results from substituting instance y3 of c3 for y2, in x2}

; Here is a more formal description of the example outlined above.

; - Let s0 be an abstract stobj whose foundation is the abstract stobj s1.
; - Let s2 be the foundation for s1, and suppose that s2 is concrete.
; - Suppose that s0 has a child stobj c0 whose :EXEC recognizer is the
;   recognizer for child stobj c1 of s1, whose :EXEC recognizer is for child
;   stobj c2 of s2, where c0, c1, and c2 are all abstract stobjs.
; - Let c3 be the foundation for c2, and assume that c3 a concrete stobj.
;
; - Let x0 be a value satisfying the recognizer for s0.
; - Let x1 be a value satisfying the recognizer for s1 such that the pair
;   <x1,x0> satisfies the correspondence predicate for s0.
; - Let x2 be a value satisfying the recognizer for s2 such that the pair
;   <x2,x1> satisfies the correspondence predicate for s1.
; - Let y2 be the value of the c2 field of x2.
; - Let y3 be a value satisfying the recognizer for c3 such that the pair
;   <y3,y2> satisfies the correspondence predicate for s2.
; - Let x3 be the result of replacing the c2 field of x2 by y3.
;
; - Then x3 E*-corresponds to x0.

; It is evident that ACL2 evaluation respects the following invariant based on
; E*-correspondence: the values of stobjs in the actual ACL2 state
; E*-correspond to the values in a logical version of the ACL2 state.  Our
; task, then, is to modify the argument above to accommodate E*-correspondence.
; We define E*-correspondence below, recursively: E*-corresponds is a relation
; defined with a predicate that mentions E*-corresponds.  That predicate is
; monotone in E*-corresponds: when E*-corresponds is enlarged, the relation
; defined by one "step" of the predicate is too.  As usual, such a recursion
; defines a least fixed point, which can be obtained by starting with the empty
; relation (for E*-corresponds) and iterating through the natural numbers.

; The definition of E*-correspondence (below) applies to array and hash-table
; fields with elements of stobj type.  We arrange this in the following ways.
; (1) We speak of a "child" of a stobj for a given field, which is the field
; value itself in the scalar case but otherwise is a value in that field's
; array or hash table.  (2) We speak of two "isomorphic" field values in the
; non-scalar case, to mean that they have the same array length in the array
; case, and they have the same keys in the hash-table case.  (3) We speak of
; "comparable" child values for two values of a given field, which are the two
; values themselves in the scalar case, values at the same index in the array
; case, and values of the same key in the hash-table case.

; Before defining E*-correspondence, we extend the notion of :EXEC recognizer
; through foundational and child stobjs.

; Definition (:EXEC* recognizer).  The :EXEC* recognizer for a stobj, s, is
; defined recursively as follows.

; - If s is an abstract stobj, then its :EXEC* recognizer is the :EXEC*
;   recognizer for its foundational stobj.

; - If s is a concrete stobj, then its :EXEC* recognizer is obtained by
;   modifying the definition of its :EXEC recognizer to use the :EXEC*
;   recognizer for each child stobj field (scalar, array, or hash-table).

; -|

; Notice that if s is a concrete stobj that has no abstract stobj child, no
; abstract stobj child of a stobj child, etc. -- that is, if no chain of
; children of s leads to an abstract stobj -- then the :EXEC* recognizer for s
; is just the recognizer for s.

; Definition.  The notion of E*-proper alist is defined just as E-proper alist
; is defined, except: replace the requirement that values satisfy :EXEC
; recognizers by the requirement that they satisfy :EXEC* recognizers.  -|

; Definition (E*-correspondence).  Let s be a stobj name (abstract or concrete)
; or nil, and let x and y be arbitrary objects.  (Note: often s is implicit
; from the context.)  Then x E*-corresponds to y with respect to s when the
; following conditions are all met.  This definition is recursive; we are
; defining the least fixed point of this relation [see discussion above].

; - X satisfies the :EXEC* recognizer for s.

; - Y satisfies the recognizer for s.

; - If s is nil then x = y.

; - If s is a concrete stobj name then for each field f of s, let sf be nil
;   unless the type of f involves a stobj, in which case sf is the stobj name
;   for that field.  Then the field values xf and yf of f in x and y
;   (respectively) are equal if sf is nil, and otherwise: xf and yf are
;   isomorphic if the field is not a scalar; and for comparable child values xc
;   and yc of xf and yf, xc E*-corresponds to yc with respect to sf.

; - If s is an abstract stobj name, there exists z such that the pair <z,y>
;   satisfies the correspondence predicate for s and x E*-corresponds to z with
;   respect to s$c, where s$c is the foundation for s.

; The notion of E*-correspondence naturally extends to two alists a1 and a2
; with the same domain, by requiring that for all <s,x> and <s,y> in a1 and a2
; respectively where s is a stobj name, x E*-corresponds to y.  Note that this
; implies that a1 is E*-proper and a2 is L-proper.  -|

; Note that if s is the name of a concrete stobj with no stobj fields, then x
; E*-corresponds to y with respect to s if and only if x = y and x satisfies
; the recognizer for s.  Indeed, this equivalence holds even if the concrete
; stobj has stobj fields, provided those fields are all concrete that
; recursively have that property as well (i.e., child stobjs are all concrete,
; their child stobjs are all concrete, etc.).

; Finally, we adapt the narrow version of the Evaluation Preserves
; Correspondence theorem and its proof, this time removing the restrictions
; that abstract stobjs have concrete foundational stobjs and child stobjs are
; concrete stobjs.  Thus, we will replace the notion of E-correspondence by the
; notion of E*-correspondence.  Uses of "as before" below are references to the
; proof of the narrow version.

; Theorem: Evaluation Preserves Correspondence (general version).  Fix an ACL2
; world w.  Assume that the alist a_E E*-corresponds to the alist a_L, let u be
; a term of w, and let error indicators and return values be defined as
; follows.

;   (mv erp_E r_E) = (ev_E u a_E)
;   (mv erp_L r_L) = (ev_L u a_L).

; Then erp_E = erp_L and r_E E*-corresponds to r_L.

; Proof.  As before, we induct on the number of abstract stobjs in w.  The
; proof for the base case (no abstract stobjs) carries over directly from
; before.

; Also as before: Let s0 be the abstract stobj introduced last in w, let w2 be
; the initial segment of w consisting of all events preceding the introduction
; of s0, assume the inductive hypothesis so that the theorem holds for w2.

; We continue as before by computational (sub-)induction, reducing to the
; following case: u is (f t1 ... tk); for each i, (ev_E ti a_E) = (mv nil xi)
; and (ev_L ti a_L) = (mv nil yi) for E*-corresponding xi and yi; b_E and b_L
; are the E*-corresponding alists that bind each formal vi of f to xi or yi,
; respectively, and for some val_g the following holds where g is the guard of
; f.

; (1)     (ev_L g b_L) = (ev_E g b_E) = (mv nil val_g) and val_g is non-nil

; We conclude as before if f is not a stobj primitive, applying the
; computational inductive hypothesis to the body.

; If f is a concrete stobj primitive then the conclusion follows from the
; definition of E*-correspondence.  For example, suppose f is an updater for
; concrete stobj st; say, the input term is (update-fld t1 st), where (ev_E t1
; a_E) = (mv nil x1) and (ev_L t1 a_L) = (mv nil y1) for E*-corresponding x1
; and y1.  Let s_E and s_L be the values of s in a_E and a_L, respectively.
; Let s_E' and s_L' be the results of respectively updating the given field
; (fld) of s_E and s_L with x1 and y1.  Then (ev_E u a_E) = (mv nil s_E') and
; (ev_L u a_L) = (mv nil s_L').  Since x1 and y1 E*-correspond, then by
; definitions of E*-correspondence and :EXEC* recognizer and the
; E*-correspondence of s_E and s_L (by E*-correspondence of a_E and a_L), s_E'
; E*-corresponds to S_L'.

; The case that f is an abstract stobj primitive for a stobj s other than s0 is
; handled just as before.  So as before we consider the case that f is an
; s0-primitive returning a single value, with formals (v1 ... s0 ... vk), with
; :EXEC version f_E and where s0$c is the foundational stobj for s0.

; As before, let s0_E = b_E(s0) and let s0_L = b_L(s0).  Since b_E
; E*-corresponds to b_L, then s0_E E*-corresponds to s0_L.  So by definition of
; E*-correspondence, there exists z such that the pair <z,s0_L> satisfies the
; correspondence predicate Corr0 for s0 and s0_E E*-corresponds to z with
; respect to s0$c.

; The following is a theorem, by (1) and Lemma 1 as before.

; (1')     g/Q(b_L) = (quote val_g).

; Let g_E be the guard of f_E.  Let b_L' be the result of adding the pair
; <s0$c,z> to b_L; thus (as before) it is a theorem that g/Q(b_L') = (quote
; val_g) by Lemma 5, since s$c does not occur free in g.  By the GUARD-THM for
; s0, it is a theorem that (implies g g_E); by instantiating this formula with
; Q(b_L'), then since Corr0 holds of <b_L'(s0$c),b_L'(s0)> (because this is
; <z,s0_L>), it is a theorem that g_E/Q(b_L') != nil.  Then as before, the
; following hold for some val_f_E.

; (2_E)   (ev_L (f_E v1 ... s0$c ... vk) b_L')  = (mv nil val_f_E)
; (2_L)   (ev_L (f   v1 ... s0   ... vk) b_L)   = (mv nil val_f)

; So as before, the following are theorems.

; (3_E)   (f_E v1 ... s0$c ... vk)/Q(b_L') = val_f_E
; (3_L)   (f   v1 ... s0   ... vk)/Q(b_L') = val_f

; The following key fact then follows by instantiating the CORRESPONDENCE
; theorem with Q(b_L') as before.

; (4)     The pair <val_f_E,val_f> satisfies Corr0 if f returns s0 (as per the
;         stobjs-out of f), else val_f_E = val_f.

; Let b_L'' be the result of removing the pair <s0,s0_L> from b_L' (but keeping
; the pair <s0$c,z>).  As before, we have the following.

; (2_E')  (ev_L (f_E v1 ... s0$c ... vk) b_L'') = (mv nil val_f_E)

; As before, Lemma 4 tells us that this equation holds for w2.  Let b_E$c be
; (as before) the result of replacing <s0,s0_E> in b_E with <s0$c,s0_E>.  We
; claim that b_E$c E*-corresponds to b_L''.  Since we have already assumed that
; b_E E*-corresponds to b_L, and since the alists b_E$c and b_L'' are derived
; respectively from b_E and b_L by mapping s0$c, in place of s0, to s0_E and z
; respectively, then this claim follows from our choice of z, that s0_E
; E*-corresponds to z with respect to s0$c.

; By the claim just above that b_E$c and b_L'' E*-correspond, together with
; the top-level inductive hypothesis applied to w2 and the choice of val_f_E in
; (2_E'), we obtain the following for some val_f_E$c.

; (5)     (ev_E (f_E v1 ... s0$c ... vk) b_E$c) = (mv nil val_f_E$c)
;         and
;         val_f_E$c E*-corresponds to val_f_E with respect to the stobj
;         returned by f_E (or nil if f_E does not return a stobj).

; As before, (5) implies the following (essentially because we are doing a
; simple renaming here).

; (6)     (ev_E (f_E v1 ... s0   ... vk) b_E)   = (mv nil val_f_E$c)

; Recall the following equation.

; (2_L)   (ev_L (f   v1 ... s0   ... vk) b_L)   = (mv nil val_f)

; As before, the proof concludes by (2_L) and (6) if we show that val_f_E$c
; E*-corresponds to val_f with respect to s, where: s is the stobj returned by
; f if any, else nil.  We first state and prove two Claims, as before.

; Claim 1: For s a stobj name, val_f satisfies the :LOGIC recognizer for s.
; This claim holds just as before, by applying (2_L).

; Claim 2. For s a stobj name, val_f_E$c satisfies the :EXEC* recognizer for s.
; This is clear from (5).

; To complete the proof that val_f_E$c E*-corresponds to val_f with respect to
; s, first suppose that s is s0, i.e., f returns s0.  Then f_E returns s0$c, so
; val_f_E$c E*-corresponds to val_f_E with respect to s0$c by (5).  Also,
; <val_f_E,val_f> satisfies Corr0 by (4).  Thus val_f_E$c E*-corresponds to
; val_f, by Claims 1 and 2 and the definition of E*-corresponds (val_f_E serves
; as the required value, z).

; Next suppose that s is an abstract stobj other than s0.  Then val_f_E = val_f
; by (4), and since f_E returns s, val_f_E$c E*-corresponds to val_f_E with
; respect to s by (5).  Therefore val_f_E$c E*-corresponds to val_f with
; respect to s.

; The final case is that s is not an abstract stobj.  Then val_f_E = val_f by
; (4) and since f_E returns s (i.e., not a stobj if s is nil), then val_f_E$c
; E*-corresponds to val_f_E with respect to s by (5).  So val_f_E$c
; E*-corresponds to val_f.  -|

; End of Essay on the Correctness of Abstract Stobjs

#-acl2-loop-only
(defmacro defabsstobj (&whole event-form
                              name
                              &key
                              foundation
                              recognizer creator exports
                              protect-default
                              congruent-to
                              non-executable
                              &allow-other-keys)

; Warning: If you change this definition, consider the possibility of making
; corresponding changes to the #-acl2-loop-only definition of defstobj.

; This function is run when we evaluate (defabsstobj name . args) in raw lisp.

  (let* ((the-live-name (the-live-var name))
         (recognizer (or recognizer (absstobj-name name :RECOGNIZER)))
         (recognizer-name (if (consp recognizer)
                              (car recognizer)
                            recognizer))
         (st$c (cond ((null foundation) (absstobj-name name :C))
                     ((consp foundation) (car foundation))
                     (t foundation)))
         (creator (or creator (absstobj-name name :CREATOR)))
         (creator-name (if (consp creator)
                           (car creator)
                         creator))
         (congruent-stobj-rep (if congruent-to
                                  (congruent-stobj-rep-raw congruent-to)
                                name))
         (fields (list* recognizer

; Recognizer must be first and creator second: the call below of
; simple-translate-absstobj-fields returns methods that are passed to
; defabsstobj-raw-defs, which requires the first two methods to be for the
; recognizer and creator, respectively.

                        creator exports)))
    (mv-let
      (erp methods)

; Each method has only the :NAME, :LOGIC, :EXEC, and :PROTECT fields filled in
; (the others are nil).  But that suffices for the present purposes.

      (simple-translate-absstobj-fields
       name st$c

; See the comment above about the first two fields of the computed methods
; being for the recognizer and creator.

       fields
       '(:RECOGNIZER :CREATOR) ; other types are nil
       protect-default
       nil ; safe value, probably irrelevant in raw Lisp
       )
      (cond
       (erp (interface-er "~@0" methods))
       (t
        (let ((init-form (defabsstobj-raw-init creator-name methods)))
          `(progn

; For defstobj, we lay down a defg form for the variable (st-lst name).  Here,
; we do not do so, because memoize-fn collects st-lst values based on
; (congruent-stobj-rep values for) underlying concrete stobjs.  To see why this
; is appropriate, consider what happens when a stobj primitive is called for an
; abstract stobj that updates that stobj.  That primitive is defined as a macro
; that expands to a call of the :exec function for that stobj primitive.  Any
; memoized function call made on behalf of calling that :exec function will
; take responsibility for flushing memo tables; see the discussion of abstract
; stobjs in comments in memoize-fn.  So there is no defg form to lay down here.

             ,@(mapcar (function (lambda (def)
                                   (cons 'DEFMACRO def)))

; See the comment above in the binding of fields, about a guarantee that the
; first two methods must be for the recognizer and creator, respectively.

                       (defabsstobj-raw-defs name methods))
             (let* ((old-pair (assoc-eq ',name *user-stobj-alist*))
                    (d (and old-pair
                            (get ',the-live-name
                                 'redundant-raw-lisp-discriminator)))
                    (ok-p (and (consp d)
                               (eq (car d) 'defabsstobj)
                               (equal (access
                                       defstobj-redundant-raw-lisp-discriminator-value
                                       (cdr d)
                                       :event)
                                      ',event-form)))
                    (non-executable ',non-executable))
               (cond
                (ok-p ',name)
                ((and old-pair (not (raw-mode-p *the-live-state*)))
                 (interface-er
                  "Illegal attempt to redeclare the (abstract) ~
                   single-threaded object ~s0."
                  ',name))
                (t
                 (setf (get ',the-live-name 'redundant-raw-lisp-discriminator)
                       (cons 'defabsstobj
                             (make defstobj-redundant-raw-lisp-discriminator-value
                                   :event ',event-form
                                   :recognizer ',recognizer-name
                                   :creator ',creator-name
                                   :congruent-stobj-rep ',congruent-stobj-rep
                                   :non-memoizable
                                   ',(non-memoizable-stobj-raw st$c)
                                   :non-executable non-executable)))
                 (cond (*hcomp-book-ht*
; See comment about this case in the raw-Lisp definition of defstobj.
                        (assert (null old-pair))
                        nil)
                       (old-pair ; hence raw-mode
                        (fms "Note:  Redefining and reinitializing (abstract) ~
                              stobj ~x0 in raw mode.~%"
                             (list (cons #\0 ',name))
                             (standard-co *the-live-state*)
                             *the-live-state*
                             nil)
                        (if non-executable
                            (assert$
                             (not (member-eq ',name
                                             *non-executable-user-stobj-lst*))
                             (setq *user-stobj-alist*
                                   (remove1-assoc-eq ',name *user-stobj-alist*)))
                          (setf (cdr old-pair) ,init-form)))
                       (non-executable
                        (pushnew ',name *non-executable-user-stobj-lst*))
                       (t
                        (setq *user-stobj-alist*
                              (cons (cons ',name ,init-form)
                                    *user-stobj-alist*))))
                 ',name))))))))))

#+acl2-loop-only
(defmacro defabsstobj (&whole event-form
                              name
                              &key
                              foundation
                              recognizer creator corr-fn exports
                              protect-default
                              congruent-to non-executable attachable
                              missing-only)
  (declare (xargs :guard (and (symbolp name)
                              (booleanp protect-default))))
  (list 'defabsstobj-fn
        (list 'quote name)
        (list 'quote foundation)
        (list 'quote recognizer)
        (list 'quote creator)
        (list 'quote corr-fn)
        (list 'quote exports)
        (list 'quote protect-default)
        (list 'quote congruent-to)
        (list 'quote non-executable)
        (list 'quote attachable)
        (list 'quote missing-only)
        'state
        (list 'quote event-form)))

(defun concrete-stobj (st wrld)
  (let ((absstobj-info
         (getpropc st 'absstobj-info nil wrld)))
    (and absstobj-info
         (let ((st$c (access absstobj-info
                             (getpropc st 'absstobj-info nil wrld)
                             :st$c)))
           (or (concrete-stobj st$c wrld)
               st$c)))))

(defmacro defabsstobj-missing-events (&whole event-form
                                             name
                                             &key
                                             foundation
                                             recognizer creator
                                             corr-fn exports protect-default
                                             congruent-to non-executable
                                             attachable)
  (declare (xargs :guard (symbolp name)))
  (let ((ctx (list 'quote (msg "( DEFABSSTOBJ-MISSING-EVENTS ~x0 ...)" name))))
    (list 'defabsstobj-fn1
          (list 'quote name)
          (list 'quote foundation)
          (list 'quote recognizer)
          (list 'quote creator)
          (list 'quote corr-fn)
          (list 'quote exports)
          (list 'quote protect-default)
          (list 'quote congruent-to)
          (list 'quote non-executable)
          (list 'quote attachable)
          (list 'quote t) ; missing-only
          ctx
          'state
          (list 'quote event-form)
          nil nil nil)))

(defun redundant-defabsstobjp (name event-form wrld)
  (and (getpropc name 'stobj nil wrld)
       (equal event-form (get-event name wrld))))

(defun absstobj-correspondence-concl-lst (stobjs-out i st$c corr-fn)
  (cond ((endp stobjs-out) nil)
        (t (cons (let ((qi (kwote i)))
                   (fcons-term* (if (eq (car stobjs-out) st$c)
                                    corr-fn
                                  'equal)
                                (fcons-term* 'mv-nth qi 'lhs)
                                (fcons-term* 'mv-nth qi 'rhs)))
                 (absstobj-correspondence-concl-lst
                  (cdr stobjs-out) (1+ i) st$c corr-fn)))))

(defun flatten-ands-in-lit! (term)

; This variant of flatten-ands-in-lit removes duplicates, always keeping the
; first occurrence.  That seems best, rather than keeping the last occurrence.
; Consider for example

;   (and (and (integerp x) (< x 3))
;        (and (integerp x) (> x -2)))

; which translates to:

;   (if (if (integerp x) (< x '3) 'nil)
;       (if (integerp x) (< '-2 x) 'nil)
;     'nil)

; If we apply flatten-ands-in-lit, we obtain:

;   ((INTEGERP X)
;    (< X '3)
;    (INTEGERP X)
;    (< '-2 X))

; If this is being generated to produce a guard, for example, it will be
; important to keep the first occurrence of (INTEGERP X).  Even if we are doing
; theorem proving, it seems plausible that the first occurrence is important as
; a hypothesis for simplifying the rest.  Thus, if we apply
; flatten-ands-in-lit! to the example above, we get this:

;   ((INTEGERP X)
;    (< X '3)
;    (< '-2 X))

  (declare (xargs :guard (pseudo-termp term)))
  (case-match term
    (('if t1 t2 t3)
     (cond ((equal t2 *nil*)
            (union-equal-to-end (flatten-ands-in-lit! (dumb-negate-lit t1))
                                (flatten-ands-in-lit! t3)))
           ((equal t3 *nil*)
            (union-equal-to-end (flatten-ands-in-lit! t1)
                                (flatten-ands-in-lit! t2)))
           (t (list term))))
    (& (cond ((equal term *t*) nil)
             (t (list term))))))

(defun absstobj-correspondence-formula (f$a f$c corr-fn formals guard-pre st
                                            st$c wrld)

; F$A and f$c are the abstract and foundational versions of some exported
; function whose formals are the given formals.  If f$c returns a single
; non-stobj value, then the formula looks as follows, where guard-pre is the
; result of restating the guard on f$a in terms of formals (but still using
; st$ap rather than stp).

; (IMPLIES (AND (corr-fn st$c st)
;               guard-pre)
;          (EQUAL (f$c ... st$c ...) ; (f$c . formals)
;                 (f$a ... st   ...)))

; However, if f$c returns a single stobj value, st$c, then the formula looks as
; follows instead, the only difference being the use of the correspondence
; predicate, corr-fn, in the conclusion.

; (IMPLIES (AND (corr-fn st$c st)
;               guard-pre)
;          (corr-fn (f$c ... st$c ...)
;                   (f$a ... st   ...)))

; We make suitable adjustments if f$c returns multiple values.

  (cond
   ((null formals)

; Note that translate-absstobj-field guarantees that except for the creator
; function, the formals of an exec function must include the foundational
; stobj.  Thus, f$c is the exec creator function.

    `(,corr-fn (,f$c) (,f$a)))
   (t
    (let* ((stobjs-out (stobjs-out f$c wrld))
           (lhs (fcons-term f$c (formals f$c wrld)))
           (rhs (fcons-term f$a formals)))
      (fcons-term*
       'implies
       (conjoin (cons (fcons-term* corr-fn st$c st)
                      (flatten-ands-in-lit! guard-pre)))
       (cond ((null (cdr stobjs-out))
              (fcons-term* (if (eq (car stobjs-out) st$c)
                               corr-fn
                             'equal)
                           lhs rhs))
             (t (fcons-term*
                 (make-lambda '(lhs rhs)
                              (conjoin (absstobj-correspondence-concl-lst
                                        stobjs-out 0 st$c corr-fn)))
                 lhs rhs))))))))

(defun absstobj-preserved-formula (f$a f$c formals guard-pre st st$c st$ap wrld)

; F$A and f$c are the :logic and :exec ("abstract" and "foundational") versions
; of some exported function.  If these return a single stobj value, then the
; formula looks as follows, where guard-pre is the result of restating the
; guard on f$a in terms of formals (but still using st$ap rather than stp).
; Although guard-pre may often include the conjunct (st$ap st), we do not
; enforce that expectation here.

; (IMPLIES guard-pre
;          (st$ap (f$a ... st ...)))

  (cond
   ((null formals)

; Note that translate-absstobj-field guarantees that except for the creator
; function, the formals of an exec function must include the foundational
; stobj.  So in this case, f$c is the exec creator function.

    (fcons-term* st$ap
                 (fcons-term* f$a)))
   (t
    (let ((stobjs-out (stobjs-out f$c wrld))
          (updated-st-term (fcons-term f$a formals)))
      (fcons-term*
       'implies
       (conjoin (add-to-set-equal (fcons-term* st$ap st)
                                  (flatten-ands-in-lit! guard-pre)))

; Note that the :preserved theorem is only generated if st$c is returned by the
; exec function.

       (cond
        ((null (cdr stobjs-out))
         (assert$ (eq (car stobjs-out) st$c)
                  (fcons-term* st$ap updated-st-term)))
        (t (let ((posn (position st$c stobjs-out)))
             (assert$
              (and posn

; We expect translate to disallow returning st$c more than once; if that
; changes, we should collect all such terms and conjoin them.

                   (not (member-eq st$c
                                   (cdr (nthcdr posn stobjs-out)))))
              (fcons-term* st$ap
                           (fcons-term* 'mv-nth
                                        (kwote posn)
                                        updated-st-term)))))))))))

(defrec absstobj-method

; WARNING: We use assoc-eq to test a symbol against a list of methods, which
; assumes that (access absstobj-method method :name) is (car method).  Do not
; change the cheap flag to nil or move name without revisiting such uses!

  (name ; see warning above before changing position
   formals ; formals of name: formals of exec but with st substituted for st$c
   guard-pre ; result of restating the guard on f$a in terms of formals
   guard-post ; restating guard-pre using stp instead of st$ap
   guard-thm guard-thm-p
   stobjs-in-posn stobjs-in-exec stobjs-in-logic stobjs-out logic exec
   correspondence preserved
   protect
   updater)
  t ; see warning above before changing to nil
  )

(mutual-recursion

(defun fn-stobj-updates-p (st fn wrld)

; See stobj-updates-p for background.  We assume (member-eq st (stobjs-out fn
; wrld)).

   (cond
    ((eq st (getpropc fn 'stobj-function nil wrld))
     :once)
    ((getpropc fn 'recursivep nil wrld)

; We can't predict how many updates fn will make to st.

     t)
    ((getpropc fn 'constrainedp nil wrld)

; Fn might be attachable, so we can't predict how many updates fn will make to
; st.

     t)
    (t (let ((body (getpropc fn 'unnormalized-body nil wrld)))
         (assert$ body
                  (stobj-updates-p st body wrld))))))

(defun stobj-updates-p (st term wrld)

; It is always sound for this function to return t.  If it returns :once, then
; st is updated at most once by the execution of term.  If it returns nil, then
; st is not updated by the execution of term.

; Consider for example:

;   (defstobj st fld)
;   (defun foo (a st)
;     (declare (xargs :stobjs st))
;     (let* ((b (cons a a))
;            (st (update-fld b st)))
;       (mv b st)))

; Then we have:

;   ACL2 !>(getpropc 'foo 'unnormalized-body)
;   ((LAMBDA (B ST)
;            ((LAMBDA (ST B) (CONS B (CONS ST 'NIL)))
;             (UPDATE-FLD B ST)
;             B))
;    (CONS A A)
;    ST)
;   ACL2 !>

; Notice that for the inner lambda application, the unique update is in an
; argument, and for the outer lambda, it's in the lambda-body.

; We rely on the following claim, which we believe to be true: if a term can
; make more than one update to st, then this will be observed in our algorithm,
; which uses the result of translating the term.

  (cond ((or (variablep term)
             (fquotep term))
         nil)
        ((flambdap (ffn-symb term))
         (flet ((or! (x y) ; If x and y are both true, then t; else (or x y).
                     (if x
                         (if y t x)
                       y)))
           (or! (stobj-updates-listp st (fargs term) wrld)
                (stobj-updates-p st (lambda-body (ffn-symb term)) wrld))))
        ((member-eq (ffn-symb term) '(if return-last))

; We are conservative here for return-last, avoiding assumptions about whether
; its logic or exec body will be run.

         (let ((temp1 (stobj-updates-p st (fargn term 1) wrld))
               (temp2 (stobj-updates-p st (fargn term 2) wrld)))
           (cond (temp1
                  (er hard! 'stobj-updates-p
                      "Please contact the ACL2 implementors.  Unexpected true ~
                       result for first argument of ~x0."
                      term))
                 ((eq temp2 t)
                  t)
                 (t (let ((temp3 (stobj-updates-p st (fargn term 3) wrld)))
                      (cond
                       ((eq temp3 t)
                        t)
                       (t (or temp2 temp3))))))))
        (t

; The assertion just below should hold, because the output of translate on a
; function body won't allow stobj modification in args of a function call.

         (assert$ (null (stobj-updates-listp st (fargs term) wrld))
                  (and (member-eq st (stobjs-out (ffn-symb term) wrld))

; We recur into the body of fn.  If this process runs too slowly, we may decide
; on a sort of memoization obtained by storing a suitable property for fn.

                       (fn-stobj-updates-p st (ffn-symb term) wrld))))))

(defun stobj-updates-listp (st x wrld)
  (cond ((endp x) nil)
        (t (flet ((or! (x y) ; If x and y are both true, then t; else (or x y).
                       (if x
                           (if y t x)
                         y)))
             (or! (stobj-updates-p st (car x) wrld)
                  (stobj-updates-listp st (cdr x) wrld))))))
)

(defun unprotected-export-p (st$c name wrld)

; Note that even if st$c is an abstract stobj (while serving as the
; foundational stobj for a proposed abstract stobj), we do not concern
; ourselves here with whether st$c primitives are themselves unprotected.
; That's because actually, they are guaranteed to be protected, either because
; they update atomically or because the :PROTECT keyword was supplied at the
; time the abstract stobj st$c was admitted.

  (and (member-eq st$c (stobjs-out name wrld))
       (eq t (fn-stobj-updates-p st$c name wrld))))

(defun key-position-from-end-eq (key alist)
  (declare (xargs :guard (and (symbolp key)
                              (alistp alist))))
  (cond ((endp alist) nil)
        ((eq key (caar alist))
         (length (cdr alist)))
        (t (key-position-from-end-eq key (cdr alist)))))

(defun absstobj-logical-skeleton-difference-msg (old new st-old st-new see-doc
                                                     old-all new-all)

; Old and new are lists of absstobj-info records, corresponding to abstract
; stobjs st-old and st-new, respectively.  We check that the :absstobj-tuples
; fields of respective members of old and new represent the same logical
; skeleton, as defined in the the Essay on Attachable Stobjs.  If so, we return
; nil; otherwise we return a message explaining their difference.

  (cond ((endp old)
         (cond
          ((endp new) nil)
          (t (msg "The proposed abstract stobj, ~x0, has additional exports ~
                   not in the existing abstract stobj, ~x1.  ~@2"
                  st-new st-old see-doc))))
        ((endp new)
         (msg "The existing abstract stobj, ~x0, has additional exports not ~
               in the proposed abstract stobj, ~x1.  ~@2"
              st-old st-new see-doc))
        (t (let* ((old1 (car old))
                  (new1 (car new))
                  (logic-old (cadr old1))
                  (logic-new (cadr new1))
                  (updater-old (cdddr old1))
                  (updater-new (cdddr new1)))
             (cond ((and (equal logic-old logic-new)
                         (or (and (null updater-old)
                                  (null updater-new))
                             (and updater-old
                                  updater-new
                                  (eql (key-position-from-end-eq updater-old
                                                                 old-all)
                                       (key-position-from-end-eq updater-new
                                                                 new-all)))))
                    (absstobj-logical-skeleton-difference-msg
                     (cdr old) (cdr new) st-old st-new see-doc
                     old-all new-all))
                   (t
                    (msg "The existing abstract stobj, ~x0, has an export ~
                          with name ~x1 that should correspond to the export ~
                          with name ~x2 of the proposed abstract stobj, ~x3.  ~
                          However, these exports have non-corresponding ~x4 ~
                          fields: ~x5 for ~x1 and ~x6 for ~x2.  ~@7"
                         st-old
                         (car old1)
                         (car new1)
                         st-new
                         (if (equal logic-old logic-new)
                             :updater
                           :logic)
                         (if (equal logic-old logic-new)
                             updater-old
                           logic-old)
                         (if (equal logic-old logic-new)
                             updater-new
                           logic-new)
                         see-doc)))))))

(defun chk-absstobj-attachment (st-name impl-name new-tuples ctx wrld see-doc
                                        state)
  (assert$
   impl-name
   (pprogn
    (observation ctx
                 "Implementation stobj ~x0 is to be attached to proposed ~
                  attachable stobj ~x1."
                 impl-name st-name)
    (let ((absstobj-info-at
           (getpropc impl-name 'absstobj-info nil wrld)))
      (cond
       ((null absstobj-info-at)
        (er soft ctx
            "Although the event ~x0 was previously executed, the name ~x1 is ~
             not the name of an abstract stobj.  This should only happen if ~
             that name was redefined.  The proposed defabsstobj event for ~
             name ~x2 cannot be admitted since it specifies, with :ATTACHABLE ~
             T and that previous attach-stobj event, that a previous ~
             defabsstobj event for name ~x1 should serve as an attachment."
            `(attach-stobj ,st-name ,impl-name)
            impl-name
            st-name))
       (t
        (let* ((old-tuples
                (access absstobj-info absstobj-info-at :absstobj-tuples))
               (msg (absstobj-logical-skeleton-difference-msg
                     old-tuples new-tuples impl-name st-name see-doc
                     old-tuples new-tuples)))
          (cond
           (msg (er soft ctx
                    "Illegal abstract stobj attachment for ~x0: ~x1.  ~@2"
                    st-name impl-name msg))
           (t (value nil))))))))))

(defun attached-stobj (st wrld top)
; Top is t for a top-level call, nil otherwise.
  (let ((st2 (cdr (assoc-eq st (table-alist 'attach-stobj-table wrld)))))
    (cond (st2 (attached-stobj st2 wrld nil))
          (top nil)
          (t st))))

(defun translate-absstobj-field (st st-new absstobj-tuple
                                    st$c field type protect-default
                                    ld-skip-proofsp see-doc ctx wrld)

; Field is a member of the :exports field of a defabsstobj event if type is
; nil; otherwise type is :recognizer or :creator and field is the recognizer or
; creator argument to defabsstobj.  We return an error triple such that if
; there is no error, then the value component is an appropriate absstobj-method
; record.

; If wrld is nil, then we take a shortcut, returning a record with only the
; :NAME, :LOGIC, :EXEC, and :PROTECT fields filled in (the others are nil),
; which are sufficient for handling a defabsstobj form in raw lisp.  Otherwise,
; this function does all necessary checks except for the presence of suitable
; :correspondence, :preserved, and :guard formulas.  For that, see
; chk-defabsstobj-method.

; Normally st-new and absstobj-tuple are nil.  St-new is non-nil when we are
; completing the processing of a generic abstract stobj event that has an
; attached implementation, in which case st-new is the name of the new stobj
; and st is the old stobj to which st-new is to be attached.  (See the Essay on
; Attachable Stobjs.)  In that case, absstobj-tuple (see make-absstobj-tuples)
; corresponds to field, where field is a member of the :exports of the
; defabsstobj event for the old stobj, st, but with :updater values adjusted to
; be for the new stobj, st-new.  We could probably skip many of the checks here
; when st-new is non-nil, but it seems harmless to leave them.

  (let* ((field0 field)
         (field (if (atom field) (list field) field))
         (name (car field))
         (actual-name ; name of the new stobj, being introduced by defabsstobj
          (or (car absstobj-tuple) name))
         (keyword-lst (cdr field)))
    (cond
     ((not (and (symbolp name)
                (keyword-value-listp keyword-lst)))
      (er-cmp ctx
              "Each field of a DEFABSSTOBJ event must be a symbol or a list ~
               of the form (symbol :KWD1 val1 :KWD2 val2 ...), but the field ~
               ~x0 is not of this form.  ~@1"
              field0 see-doc))
     (t
      (mv-let
        (exec exec-p)
        (let ((exec (cadr (assoc-keyword :EXEC keyword-lst))))
          (cond (exec (mv exec t))
                ((eq type :recognizer)
                 (mv (absstobj-name st :RECOGNIZER-EXEC) nil))
                (t (mv (absstobj-name name :C) nil))))
        (let* ((protect-tail (assoc-keyword :PROTECT keyword-lst))
               (protect (if protect-tail
                            (cadr protect-tail)
                          protect-default)))
          (cond
           ((and protect-tail ; optimization
                 (not (member-eq protect '(t nil))))
            (er-cmp ctx
                    "Illegal value of :PROTECT, ~x0, in the field for ~x1.  ~@2"
                    protect name see-doc))
           (t
            (mv-let
              (logic logic-p)
              (let ((logic (cadr (assoc-keyword :LOGIC keyword-lst))))
                (cond (logic (mv logic t))
                      ((eq type :recognizer)
                       (mv (absstobj-name st :RECOGNIZER-LOGIC) nil))
                      (t (mv (absstobj-name name :A) nil))))
              (cond
               ((null wrld) ; shortcut for raw Lisp definition of defabsstobj
                (value-cmp (make absstobj-method
                                 :NAME actual-name
                                 :LOGIC logic
                                 :EXEC exec
                                 :PROTECT protect)))
               ((strip-keyword-list
                 '(:LOGIC :EXEC :CORRESPONDENCE :PRESERVED :GUARD-THM :PROTECT
                          :UPDATER)
                 keyword-lst)
                (er-cmp ctx
                        "Unexpected keyword~#0~[~/s~], ~&0, in field ~x1.  ~@2"
                        (evens (strip-keyword-list
                                '(:LOGIC :EXEC :CORRESPONDENCE :PRESERVED
                                         :GUARD-THM :UPDATER)
                                keyword-lst))
                        field0 see-doc))
               ((duplicate-key-in-keyword-value-listp keyword-lst)
                (er-cmp ctx
                        "Duplicate keyword~#0~[~/s~] ~&0 found in field ~x1.~|~@2"
                        (duplicates (evens keyword-lst)) field0 see-doc))
               ((not (and (symbolp exec)
                          (function-symbolp exec wrld)))
                (er-cmp ctx
                        "The :EXEC field ~x0, specified~#1~[~/ (implicitly)~] ~
                         for ~#2~[defabsstobj :RECOGNIZER~/defabsstobj ~
                         :CREATOR~/exported~] symbol ~x3, is not a function ~
                         symbol in the current ACL2 logical world.  ~@4"
                        exec
                        (if exec-p 0 1)
                        (case type
                          (:RECOGNIZER 0)
                          (:CREATOR 1)
                          (otherwise 2))
                        name see-doc))
               ((and (null protect)
                     (not (member-eq type '(:RECOGNIZER :CREATOR)))
                     (not (member-eq ld-skip-proofsp ; optimization
                                     '(include-book include-book-with-locals)))

; We believe that in the case of a child stobj updater, the following call of
; unprotected-export-p will always return nil -- that is, the update is
; demonstrably atomic.  That's because the :exec update is atomic: this is
; immediate if the foundational stobj is concrete, and otherwise it's because
; (inductively) the child stobj updater is atomic.  We should revisit our
; understanding if we find otherwise, because we may not need to be concerned
; with non-atomic child stobj updates anyhow; that's because we deal with
; non-atomicity of incomplete child updates in stobj-let-fn-raw by using
; with-inside-absstobj-update.

                     (unprotected-export-p st$c exec wrld))
                (er-cmp ctx
                        "The :EXEC field ~x0, specified~#1~[~/ (implicitly)~] ~
                         for defabsstobj field ~x2, appears capable of ~
                         modifying the foundational stobj, ~x3, ~
                         non-atomically; yet :PROTECT T was not specified for ~
                         this field.  ~@4"
                        exec
                        (if exec-p 0 1)
                        name st$c see-doc))
               (t
                (mv-let
                  (guard-thm guard-thm-p)
                  (let ((guard-thm (cadr (assoc-keyword :GUARD-THM
                                                        keyword-lst))))
                    (cond (guard-thm (mv guard-thm t))
                          (t (mv (absstobj-name name :GUARD-THM) nil))))
                  (let* ((exec-formals (formals exec wrld))
                         (posn-exec (position-eq st$c exec-formals))
                         (stobjs-in-logic (stobjs-in logic wrld))
                         (stobjs-in-exec (stobjs-in exec wrld))
                         (stobjs-out-logic (stobjs-out logic wrld))
                         (stobjs-out-exec (stobjs-out exec wrld))
                         (correspondence-required (not (eq type :RECOGNIZER)))
                         (preserved-required (and (not (eq type :RECOGNIZER))
                                                  (member-eq st$c
                                                             stobjs-out-exec)))
                         (updater-tail (assoc-keyword :UPDATER keyword-lst)))
                    (mv-let
                      (correspondence correspondence-p)
                      (let ((corr (cadr (assoc-keyword :CORRESPONDENCE
                                                       keyword-lst))))
                        (cond (corr (mv corr t))
                              (t (mv (and correspondence-required
                                          (absstobj-name name :CORRESPONDENCE))
                                     nil))))
                      (mv-let
                        (preserved preserved-p)
                        (let ((pres (cadr (assoc-keyword :PRESERVED
                                                         keyword-lst))))
                          (cond (pres (mv pres t))
                                (t (mv (and preserved-required
                                            (absstobj-name name :PRESERVED))
                                       nil))))
                        (cond
                         ((or (and (eq type :RECOGNIZER)
                                   (or correspondence-p preserved-p guard-thm-p
                                       updater-tail

; We expect that expand-recognizer already put in the :logic and :exec fields.

                                       (not logic-p) (not exec-p)))
                              (and (eq type :CREATOR)
                                   (or updater-tail guard-thm-p)))
                          (er-cmp ctx
                                  "The ~@0 for keyword ~x1.  ~@2"
                                  (cond (updater-tail
                                         ":UPDATER field is not allowed")
                                        (guard-thm-p
                                         ":GUARD-THM field is not allowed")
                                        (correspondence-p
                                         ":CORRESPONDENCE field is not allowed")
                                        (preserved-p
                                         ":PRESERVED field is not allowed")
                                        ((not logic-p)
                                         ":LOGIC field is required")
                                        (t ; (not exec-p)
                                         ":EXEC field is required"))
                                  type
                                  see-doc))
                         ((not (and (symbolp logic)
                                    (function-symbolp logic wrld)))
                          (er-cmp ctx
                                  "The :LOGIC field ~x0, specified~#1~[~/ ~
                                   (implicitly)~] for ~#2~[defabsstobj ~
                                   :RECOGNIZER~/defabsstobj ~
                                   :CREATOR~/exported~] symbol ~x3, is not a ~
                                   function symbol in the current ACL2 ~
                                   logical world.  ~@4"
                                  logic
                                  (if logic-p 0 1)
                                  (case type
                                    (:RECOGNIZER 0)
                                    (:CREATOR 1)
                                    (otherwise 2))
                                  name see-doc))
                         ((or (not (eq (symbol-class exec wrld)
                                       :COMMON-LISP-COMPLIANT))
                              (not (eq (symbol-class logic wrld)
                                       :COMMON-LISP-COMPLIANT)))
                          (let* ((lp (not (eq (symbol-class logic wrld)
                                              :COMMON-LISP-COMPLIANT)))
                                 (implicit-p (if lp logic-p exec-p))
                                 (fn (if lp logic exec)))
                            (er-cmp ctx
                                    "The~#0~[~/ (implicit)~] ~x1 component of ~
                                     field ~x2, ~x3, is a function symbol but ~
                                     its guards have not yet been verified.  ~
                                     ~@4"
                                    (if implicit-p 0 1)
                                    (if lp :LOGIC :EXEC)
                                    field0 fn see-doc)))
                         ((and (eq type :RECOGNIZER)
                               (not (eq exec
                                        (get-stobj-recognizer st$c wrld))))

; We use the foundational recognizer in the definition of the recognizer
; returned by defabsstobj-raw-defs.

                          (er-cmp ctx
                                  "The~#0~[~/ (implicit)~] :EXEC component, ~
                                   ~x1, of the specified :RECOGNIZER, ~x2, is ~
                                   not the recognizer of the foundational ~
                                   stobj ~x3.  ~@4"
                                  (if exec-p 0 1) exec name st$c see-doc))
                         ((and preserved-p
                               (not preserved-required))
                          (er-cmp ctx
                                  "It is illegal to specify :PRESERVED for a ~
                                   field whose :EXEC does not return the ~
                                   foundational stobj.  In this case, ~
                                   :PRESERVED ~x0 has been specified for an ~
                                   :EXEC of ~x1, which does not return ~x2.  ~
                                   ~@3"
                                  preserved exec st$c see-doc))
                         ((member-eq (or st-new st) exec-formals)

; We form the formals of actual-name by replacing st$c by st in exec-formals.
; If st is already a formal parameter of exec-formals then this would create a
; duplicate, provided st$c is in exec-formals, as we expect it to be in that
; case (since we are presumably not looking at a creator).  The ensuing defun
; would catch this duplication, but it seems most robust and friendly to cause
; a clear error here.  This check could probably be eliminated by doing
; suitable renaming; but that could be awkward, and it seems quite unlikely
; that anyone will need such an enhancement.  In the worst case one can of
; course define a wrapper for the :EXEC function that avoids the new stobj
; name, st.

                          (er-cmp ctx
                                  "We do not allow the use of the defabsstobj ~
                                   name, ~x0, in the formals of the :EXEC ~
                                   function of a field, in particular, the ~
                                   :EXEC function ~x1 for field ~x2~#3~[ from ~
                                   the attached stobj, ~x4~/~].  ~@5"
                                  (or st-new st)
                                  exec
                                  field0
                                  (if st-new 0 1)
                                  st-new
                                  see-doc))
                         ((and (eq type :CREATOR)
                               (not (and (null stobjs-in-logic)
                                         (null stobjs-in-exec)
                                         (null (cdr stobjs-out-exec))
                                         (eq (car stobjs-out-exec) st$c)
                                         (null (cdr stobjs-in-exec))
                                         (eql (length stobjs-out-logic) 1))))
                          (cond ((or stobjs-in-logic
                                     stobjs-in-exec)
                                 (er-cmp ctx
                                         "The :LOGIC and :EXEC versions of ~
                                          the :CREATOR function must both be ~
                                          functions of no arguments but ~&0 ~
                                          ~#0~[is not such a function~/xare ~
                                          not such functions~].  ~@1"
                                         (append (and stobjs-in-logic
                                                      (list logic))
                                                 (and stobjs-in-exec
                                                      (list exec)))
                                         see-doc))
                                ((or (not (eql (length stobjs-out-logic) 1))
                                     (not (eql (length stobjs-out-exec) 1)))
                                 (er-cmp ctx
                                         "The :LOGIC and :EXEC versions of ~
                                          the :CREATOR function must both be ~
                                          functions that return a single ~
                                          value, but ~&0 ~#0~[is not such a ~
                                          function~/are not such functions~]. ~
                                          ~ ~@1"
                                         (append
                                          (and (not (eql (length stobjs-out-logic) 1))
                                               (list logic))
                                          (and (not (eql (length stobjs-out-exec) 1))
                                               (list exec)))
                                         see-doc))
                                (t ; (not (eq (car stobjs-out-exec) st$c))
                                 (er-cmp ctx
                                         "The :EXEC version of the :CREATOR ~
                                          function must return a single value ~
                                          that is the stobj ~x0, but ~x1 does ~
                                          not have that property.  ~@2"
                                         st$c exec see-doc))))
                         ((and (not (eq type :CREATOR))
                               (not posn-exec))

; Warning: before weakening this test, consider how it is relied upon in
; absstobj-correspondence-formula.  Also, note that stobj-creatorp relies on
; empty formals, so this check guarantees that stobj-creatorp returns nil for
; functions other than the creator.

                          (er-cmp ctx
                                  "The foundational stobj name, ~x0, is not ~
                                   a known stobj parameter of :EXEC function ~
                                   ~x1 for field ~x2.~|~@3"
                                  st$c exec field0 see-doc))
                         ((and (not (eq type :CREATOR))
                               (not (equal (length stobjs-in-logic)
                                           (length stobjs-in-exec))))
                          (er-cmp ctx
                                  "The :LOGIC and :EXEC functions for a field ~
                                   must have input signatures of the same ~
                                   length.  However, this fails for field ~
                                   descriptor ~x0, as the input signatures ~
                                   are as follows.~|~%~x1 ~
                                   (:LOGIC):~|~X25~|~%~x3 ~
                                   (:EXEC):~|~X45~|~%~@6"
                                  field0 logic
                                  (prettyify-stobj-flags stobjs-in-logic)
                                  exec
                                  (prettyify-stobj-flags stobjs-in-exec)
                                  nil see-doc))
                         ((and (not (eq type :CREATOR)) ; handled elsewhere
                               (not (equal (length stobjs-out-logic)
                                           (length stobjs-out-exec))))
                          (er-cmp ctx
                                  "The output signatures of the :LOGIC and ~
                                   :EXEC functions for an abstract stobj ~
                                   export must have the same length.  ~
                                   However, the output signatures are as ~
                                   follows for field descriptor ~x0 of ~
                                   abstract stobj ~x1.~|~%~x2 ~
                                   (:LOGIC):~|~X36~|~%~x4 ~
                                   (:EXEC):~|~X56~|~%~@7"
                                  field0 st
                                  logic (prettyify-stobj-flags stobjs-out-logic)
                                  exec (prettyify-stobj-flags stobjs-out-exec)
                                  nil see-doc))
                         (t
                          (let* ((formals (if (eq type :CREATOR)
                                              nil
                                            (update-nth posn-exec
                                                        (or st-new st)
                                                        exec-formals)))
                                 (guard-pre (subcor-var (formals logic wrld)
                                                        formals
                                                        (guard logic nil wrld))))
                            (cond
                             ((member-eq st$c stobjs-in-logic)

; We cause an error in this case in order to avoid a much more confusing
; error.  Without it, defabsstobj-axiomatic-defs can declare st$c as a stobj
; even though st$c is not among the formals.

; This error should not occur if st-new is non-nil, i.e., when we are
; attaching an implementation stobj to a generic stobj, since this check passed
; when the attached implementation stobj was admitted.  But just in case this
; check somehow does fail, the error message uses actual-name and st-new so
; that the message is about the proposed, (attached) generic stobj.

                              (er-cmp ctx
                                      "the :LOGIC function ~x0 for export ~x1 ~
                                       declares as a stobj the formal ~
                                       parameter, ~x2.  This is illegal ~
                                       because ~x2 is the foundational stobj ~
                                       for the proposed abstract stobj, ~x3."
                                      logic
                                      (or actual-name name)
                                      st$c
                                      (or st-new st)))
                             (t
                              (value-cmp
                               (make absstobj-method
                                     :NAME actual-name
                                     :FORMALS formals
                                     :GUARD-PRE guard-pre
                                     :GUARD-POST nil ; to be filled in later
                                     :GUARD-THM guard-thm
                                     :GUARD-THM-P (if type :SKIP guard-thm-p)
                                     :STOBJS-IN-POSN posn-exec
                                     :STOBJS-IN-EXEC stobjs-in-exec
                                     :STOBJS-IN-LOGIC stobjs-in-logic
                                     :STOBJS-OUT
                                     (substitute (or st-new st)
                                                 st$c
                                                 stobjs-out-exec)
                                     :LOGIC logic
                                     :EXEC exec
                                     :CORRESPONDENCE correspondence
                                     :PRESERVED preserved
                                     :PROTECT protect
                                     :UPDATER
                                     (cadr updater-tail)))))))))))))))))))))))

(defun simple-translate-absstobj-fields (st st$c fields types protect-default
                                            ld-skip-proofsp)

; Warning: Return methods in the same order as fields.  See the comments about
; simple-translate-absstobj-fields in the #-acl2-loop-only definition of
; defabsstobj.  Each returned method has only the :NAME, :LOGIC, :EXEC, and
; :PROTECT fields filled in (the others are nil).

  (cond ((endp fields) (mv nil nil))
        (t (er-let*-cmp
            ((method (translate-absstobj-field
                      st nil nil st$c
                      (car fields)
                      (car types)
                      protect-default
                      ld-skip-proofsp
                      "" 'defabsstobj nil))
             (rest (simple-translate-absstobj-fields
                    st st$c (cdr fields) (cdr types) protect-default
                    ld-skip-proofsp)))
            (value-cmp (cons method rest))))))

(defun one-way-unify-p (pat term)

; Returns true when term2 is an instance of term1.

  (or (equal pat term) ; optimization
      (mv-let (ans unify-subst)
              (one-way-unify pat term)
              (declare (ignore unify-subst))
              ans)))

(defun obviously-equal-lambda-args (x-formals-tail x-args-tail y-formals
                                                   y-args)

; At the top level, x-formals-tail and x-args-tail are the formals and
; arguments of a lambda application; let's call these x-formals and x-args.  We
; know that x-formals and y-formals have the same length, and we want to check
; that y-formals is a permutation of x-formals and, moreover: when the
; arguments are correspondingly permuted, then the respective members of
; x-args and y-args are equal.

  (declare (xargs :guard (and (symbol-listp x-formals-tail)
                              (pseudo-term-listp x-args-tail)
                              (symbol-listp y-formals)
                              (pseudo-term-listp y-args))))
  (cond ((endp x-formals-tail) t)
        (t (let ((posn (position-eq (car x-formals-tail) y-formals)))
             (and
              posn
              (and (equal (car x-args-tail)
                          (nth posn y-args))
                   (obviously-equal-lambda-args (cdr x-formals-tail)
                                                (cdr x-args-tail)
                                                y-formals y-args)))))))

(mutual-recursion

(defun obviously-equiv-terms (x y iff-flg)

; Warning: It is desirable to keep this reasonably in sync with untranslate1,
; specifically, giving similar attention in both to functions like implies,
; iff, and not, which depend only on the propositional equivalence class of
; each argument.

; Here we code a restricted version of equivalence of x and y, for use in
; chk-defabsstobj-method-lemmas or other places where we expect this to be
; sufficient.  The only requirement is that if (obviously-equiv-terms x y
; iff-flg), then (equal x y) a theorem (in every theory extending the
; ground-zero theory) unless iff-flg is true, in which case (iff x y) is a
; theorem.

  (declare (xargs :guard (and (pseudo-termp x)
                              (pseudo-termp y))))
  (or (equal x y) ; common case
      (cond ((or (variablep x)
                 (variablep y))
             nil)
            ((or (fquotep x)
                 (fquotep y))
             (and iff-flg
                  (fquotep x)
                  (fquotep y)
                  (unquote x)
                  (unquote y)))
            ((flambda-applicationp x)
             (and (flambda-applicationp y)

; There are (at least) two ways that x and y can be obviously equivalent.

; (1) The arguments agree, and their lambdas (function symbols) are equivalent
;     but have different formals and correspondingly different bodies, for
;     example:
;       ((lambda (x y) (cons x y)) '3 '4)
;       ((lambda (u v) (cons u v)) '3 '4)

; (2) The formals in the lambdas have been permuted and the arguments have been
;     correspondingly permuted, and the bodies of the lambdas are the same, for
;     example:
;       ((lambda (x y) (cons x y)) '3 '4)
;       ((lambda (y x) (cons x y)) '4 '3)

; Of course the function symbols of x and y can be equal, which fits into both
; (1) and (2).  And the discrepancies of (1) and (2) can happen together, as in
; the following example:
;       ((lambda (x y) (cons x y)) '3 '4)
;       ((lambda (u v) (cons v u)) '4 '3)

; But it is more complicated to handle this combination in full generality, so
; we content ourselves with (1) and (2).

; We could also relax (2) by checking that the respective arguments are merely
; obviously-equiv-terms, rather than requiring equality, but at this point we
; see no need for that generalization.

                  (let ((x-fn (ffn-symb x))
                        (y-fn (ffn-symb y))
                        (x-args (fargs x))
                        (y-args (fargs y)))
                    (cond
                     ((equal x-fn y-fn) ; simple case
                      (obviously-equiv-terms-lst x-args y-args))
                     (t
                      (let ((x-formals (lambda-formals x-fn))
                            (x-body (lambda-body x-fn))
                            (y-formals (lambda-formals y-fn))
                            (y-body (lambda-body y-fn)))
                        (and (eql (length x-formals) (length y-formals))
                             (or

; (1) -- see above

                              (and (obviously-equiv-terms
                                    (subcor-var x-formals y-formals x-body)
                                    y-body
                                    iff-flg)
                                   (obviously-equiv-terms-lst x-args y-args))

; (2) -- see above

                              (and (obviously-equiv-terms
                                    x-body y-body iff-flg)
                                   (obviously-equal-lambda-args
                                    x-formals (fargs x)
                                    y-formals (fargs y)))))))))))
            ((not (eq (ffn-symb x) (ffn-symb y)))
             nil)
            ((member-eq (ffn-symb x) '(implies iff))
             (and (obviously-equiv-terms (fargn x 1) (fargn y 1) t)
                  (obviously-equiv-terms (fargn x 2) (fargn y 2) t)))
            ((eq (ffn-symb x) 'not)
             (obviously-equiv-terms (fargn x 1) (fargn y 1) t))
            ((eq (ffn-symb x) 'if)
             (and (obviously-equiv-terms (fargn x 1) (fargn y 1) t)
                  (obviously-equiv-terms (fargn x 3) (fargn y 3) iff-flg)
                  (or (obviously-equiv-terms (fargn x 2) (fargn y 2) iff-flg)

; Handle case that a term is of the form (or u v).

                      (and iff-flg
                           (cond ((equal (fargn x 2) *t*)
                                  (obviously-equiv-terms
                                   (fargn y 2) (fargn y 1) t))
                                 ((equal (fargn y 2) *t*)
                                  (obviously-equiv-terms
                                   (fargn x 2) (fargn x 1) t))
                                 (t nil))))))
            (t (and (equal (length (fargs x))
                           (length (fargs y)))
                    (obviously-equiv-terms-lst (fargs x) (fargs y)))))))

(defun obviously-equiv-terms-lst (x y)

; X and y are true-lists of the same length.

  (declare (xargs :guard (and (pseudo-term-listp x)
                              (pseudo-term-listp y))))
  (cond ((endp x) t)
        (t (and (obviously-equiv-terms (car x) (car y) nil)
                (obviously-equiv-terms-lst (cdr x) (cdr y))))))
)

(defun obviously-iff-equiv-terms (x y)
  (declare (xargs :guard (and (pseudo-termp x)
                              (pseudo-termp y))))
  (obviously-equiv-terms x y t))

(defun chk-defabsstobj-method-lemmas (method st st$c st$ap corr-fn
                                             missing wrld state)
  (let ((correspondence (access absstobj-method method :CORRESPONDENCE))
        (preserved (access absstobj-method method :PRESERVED)))
    (cond
     ((null correspondence) ; recognizer method
      (assert$ (null preserved)
               (value (cons missing wrld))))
     (t
      (let* ((formals (access absstobj-method method :FORMALS))
             (guard-pre (access absstobj-method method :GUARD-PRE))
             (logic (access absstobj-method method :LOGIC))
             (exec (access absstobj-method method :EXEC))
             (expected-corr-formula
              (absstobj-correspondence-formula
               logic exec corr-fn formals guard-pre st st$c wrld))
             (old-corr-formula (formula correspondence nil wrld))
             (tuple (cond
                     ((null old-corr-formula)
                      `(,correspondence
                        ,expected-corr-formula))
                     ((obviously-iff-equiv-terms expected-corr-formula
                                                 old-corr-formula)

; We will be printing formulas with untranslate using t for its iff-flg, for
; readability.  But imagine what happens if the printed, untranslated formula
; has a call (or x y) that came from translated formula (if x 't y).
; When the user submits a version with (or x y), it will translate to (if x x
; y), and we will have a mismatch!  Thus, we allow obviously-iff-equiv-terms
; rather than requiring equality.

; Why not consider it sufficient for the two formulas to untranslate, using
; iff-flg = t, to the same user-level formula?  The problem is that utilities
; like untranslate, untranslate*, and even untranslate1 depend on inputs that
; can destroy any meaningful semantics for these functions.  In particular,
; (untrans-table wrld) is important for getting pretty results from
; untranslate, but we cannot trust it to produce meaningful results because the
; user gets to decide what goes into this table.

                      nil)
                     ((one-way-unify-p old-corr-formula
                                       expected-corr-formula)
                      nil)
                     (t `(,correspondence
                          ,expected-corr-formula
                          ,@old-corr-formula))))
             (missing (cond (tuple (cons tuple missing))
                            (t missing)))
             (guard-thm-p (access absstobj-method method :GUARD-THM-P))
             (tuple
              (cond
               ((eq guard-thm-p :SKIP) nil)
               (t
                (let* ((expected-guard-thm-formula
                        (make-implication
                         (cons (fcons-term* corr-fn st$c st)
                               (flatten-ands-in-lit! guard-pre))
                         (conjoin (flatten-ands-in-lit!
                                   (guard exec t wrld)))))
                       (taut-p
                        (and (null guard-thm-p)
                             (tautologyp expected-guard-thm-formula
                                         wrld)))
                       (guard-thm (access absstobj-method method
                                          :GUARD-THM))
                       (old-guard-thm-formula
                        (and (not taut-p) ; optimization
                             (formula guard-thm nil wrld))))
                  (cond
                   (taut-p nil)
                   ((null old-guard-thm-formula)
                    `(,guard-thm ,expected-guard-thm-formula))
                   ((obviously-iff-equiv-terms expected-guard-thm-formula
                                               old-guard-thm-formula)
; See the comment at the first call of obviously-iff-equiv-terms above.
                    nil)
                   ((one-way-unify-p old-guard-thm-formula
                                     expected-guard-thm-formula)
                    nil)
                   (t `(,guard-thm
                        ,expected-guard-thm-formula
                        ,@old-guard-thm-formula)))))))
             (missing (cond (tuple (cons tuple missing))
                            (t missing))))
        (cond
         ((null preserved)
          (value (cons missing wrld)))
         (t
          (let* ((expected-preserved-formula
                  (absstobj-preserved-formula
                   logic exec formals guard-pre st st$c st$ap
                   wrld))
                 (old-preserved-formula
                  (formula preserved nil wrld))
                 (tuple
                  (cond
                   ((null old-preserved-formula)
                    `(,preserved ,expected-preserved-formula))
                   ((obviously-iff-equiv-terms expected-preserved-formula
                                               old-preserved-formula)
; See the comment at the first call of obviously-iff-equiv-terms above.
                    nil)
                   ((one-way-unify-p old-preserved-formula
                                     expected-preserved-formula)
                    nil)
                   (t
                    `(,preserved
                      ,expected-preserved-formula
                      ,@old-preserved-formula))))
                 (missing (cond (tuple (cons tuple missing))
                                (t missing))))
            (value (cons missing wrld))))))))))

(defun chk-defabsstobj-method (method st st$c st$ap corr-fn congruent-to
                                      missing ctx wrld state)

; The input, missing, is a list of tuples (name expected-event . old-event),
; where old-event may be nil; see chk-acceptable-defabsstobj.  We return a pair
; (missing1 . wrld1), where missing1 extends missing as above and wrld1 extends
; wrld as necessary for redefinition.

  (let ((name (access absstobj-method method :name)))
    (er-let* ((wrld (er-progn
                     (chk-all-but-new-name name ctx 'function wrld state)
                     (chk-just-new-name name nil 'function nil ctx wrld
                                        state))))
      (cond
       ((or congruent-to
            (member-eq (ld-skip-proofsp state)
                       '(include-book include-book-with-locals)))

; We allow the :correspondence, :preserved, and :guard-thm theorems to be
; local.

        (value (cons missing wrld)))
       (t (chk-defabsstobj-method-lemmas method st st$c st$ap corr-fn
                                         missing wrld state))))))

(defun intersperse (lst1 lst2)
  (declare (xargs :guard (and (true-listp lst1)
                              (true-listp lst2)
                              (= (length lst1) (length lst2)))))
  (cond ((endp lst1) nil)
        (t (list* (car lst1) (car lst2) (intersperse (cdr lst1) (cdr lst2))))))

(defun sort-absstobj-names (names accessors updaters)

; Names is a list of export names for an abstract stobj that includes the
; indicated child stobj accessors and corresponding updaters.  We return a
; permutation of names in which each member of accessors is immediately
; followed by the corresponding member of updaters.

  (let ((lst (intersperse accessors updaters)))
    (append lst
            (set-difference-eq names lst))))

(defun chk-acceptable-defabsstobj1 (st st$c st$ap corr-fn fields
                                       types protect-default congruent-to
                                       see-doc ctx wrld state methods missing)

; See chk-acceptable-defabsstobj (whose return value is computed by the present
; function) for the form of the result.  We rely on the assumption that fields
; begins with the recognizer and then the creator.  For one thing, this
; function supplies the methods for the call of make-absstobj-tuples in
; defabsstobj-fn1, which puts the 'absstobj-info property, which is assumed in
; stobj-field-fn-of-stobj-type-p to start with the creator and recognizer
; tuples (see comments in stobj-field-fn-of-stobj-type-p).  Also see the
; comments about chk-acceptable-defabsstobj1 in defabsstobj-fn1 and
; chk-acceptable-defabsstobj.

  (cond
   ((endp fields)
    (value (list* (reverse missing) (reverse methods) wrld)))
   (t
    (mv-let
     (erp method)
     (translate-absstobj-field st nil nil st$c
                               (car fields)
                               (car types)
                               protect-default
                               (ld-skip-proofsp state)
                               see-doc ctx wrld)
     (cond
      (erp ; erp is ctx, method is a msg
       (er soft erp "~@0" method))
      (t
       (er-let* ((missing/wrld
                  (chk-defabsstobj-method method st st$c st$ap corr-fn
                                          congruent-to missing ctx wrld state)))
         (let ((missing (car missing/wrld))
               (wrld (cdr missing/wrld)))
           (cond ((assoc-eq (access absstobj-method method :name)
                            methods)
                  (er soft ctx
                      "The name ~x0 is introduced more than once by a ~
                       DEFABSSTOBJ event.  ~@1"
                      (access absstobj-method method :name)
                      see-doc))
                 (t (chk-acceptable-defabsstobj1
                     st st$c st$ap corr-fn
                     (cdr fields)
                     (cdr types)
                     protect-default
                     congruent-to see-doc ctx wrld state
                     (cons method methods)
                     missing)))))))))))

(defun first-keyword (lst)
  (declare (xargs :guard (true-listp lst)))
  (cond ((endp lst) nil)
        ((keywordp (car lst))
         (car lst))
        (t (first-keyword (cdr lst)))))

(defun collect-defabsstobj-updaters (methods st$c all-methods wrld
                                             accessors updaters
                                             accessors-exec updaters-exec)

; We collect from methods all child stobj accessors and corresponding updaters,
; as well as their :exec counterparts.  These are collected into the four given
; accumulators, which are all nil at the top level.  The multiple-value return
; also includes nil as the first value unless an error is discovered, in which
; case the first value returned is a suitable message and the other values are
; irrelevant.

  (cond
   ((endp methods) (mv nil
                       (reverse accessors) (reverse updaters)
                       (reverse accessors-exec) (reverse updaters-exec)))
   (t (let* ((method (car methods))
             (updater (access absstobj-method method :updater)))
        (cond
         ((null updater)
          (collect-defabsstobj-updaters (cdr methods) st$c all-methods wrld
                                        accessors updaters
                                        accessors-exec updaters-exec))
         (t (let* ((exec (access absstobj-method method :exec))
                   (stobjs-out (assert$ exec (stobjs-out exec wrld)))
                   (child (and (consp stobjs-out)
                               (null (cdr stobjs-out))
                               (not (eq (car stobjs-out) :df))
                               (car stobjs-out)))
                   (name (access absstobj-method method :name)))
              (cond
               ((or (not (stobj-field-accessor-p exec st$c wrld))
                    (null child))
                (mv (msg "The function spec for ~x0 specifies an :UPDATER ~
                          function, which is only allowed when the specified ~
                          :EXEC function is a stobj field accessor for the ~
                          foundational stobj.  However, the :EXEC function is ~
                          ~x1, which ~@2."
                         name
                         exec
                         (cond
                          ((stobj-field-accessor-p exec st$c wrld)
                           (msg "is an accessor of ~x0 for a non-stobj field"
                                st$c))
                          (t (msg "is not a field accessor of ~x0"
                                  st$c))))
                    nil nil nil nil))
               (t (let* ((updater-method (assoc-eq updater all-methods)))
                    (cond
                     ((null updater-method)
                      (mv (msg "In the function spec for ~x0, the :UPDATER ~
                                keyword has value ~x1.  However, there is no ~
                                function spec for ~x1."
                               name updater)
                          nil nil nil nil))
                     (t (collect-defabsstobj-updaters
                         (cdr methods) st$c all-methods wrld
                         (cons name accessors)
                         (cons updater updaters)
                         (cons exec accessors-exec)
                         (cons (access absstobj-method updater-method :exec)
                               updaters-exec))))))))))))))

(defun chk-defabsstobj-updaters-1 (accessors accessors-exec
                                             updaters updaters-exec
                                             lst)

; This supports checking updaters for defabsstobj.  See chk-stobj-updaters-1
; for a similar utility for stobj-let; comments there might be helpful as well.

  (cond ((endp updaters-exec) nil)
        (t
         (let* ((updater-exec (car updaters-exec))
                (accessor-exec (car accessors-exec))
                (accessor-tail (member-eq (car accessors-exec) lst))
                (actual-updater-exec (cadr accessor-tail)))
           (assert$

; This assertion should be true because of the check done by a call of
; stobj-field-accessor-p in chk-stobj-let/bindings.

            accessor-tail
            (cond
             ((eq updater-exec actual-updater-exec)
              (chk-defabsstobj-updaters-1 (cdr accessors) (cdr accessors-exec)
                                          (cdr updaters) (cdr updaters-exec)
                                          lst))
             (t (msg "The :EXPORTS specify that the :UPDATER for accessor ~x0 ~
                      is the exported function, ~x1.  The :EXEC function for ~
                      ~x1 is ~x2, but is expected to be ~x3, which is the ~
                      updater corresponding to the :EXEC function for ~x0, ~
                      ~x4."
                     (car accessors) (car updaters)
                     updater-exec actual-updater-exec accessor-exec))))))))

(defun chk-defabsstobj-updaters (st$c methods wrld)

; This supports checking updaters for defabsstobj.  See chk-stobj-let/updaters
; for a similar utility for stobj-let.

; Implicit is an abstract stobj definition with the given methods (perhaps
; partially fleshed out) and with the given foundational stobj, st$c.  We
; either return (msg nil nil), where msg explains why methods illegally
; specifies child stobj accessors and updaters, or else (in the absence of such
; illegality) we return (mv nil accessors updaters), where accessors and
; updaters have the same length L and for all i < L, the ith elements of
; accessors and updaters are a corresponding accessor/updater pair for a child
; stobj (of the implicit abstract stobj).

  (mv-let
    (msg accessors updaters accessors-exec updaters-exec)
    (collect-defabsstobj-updaters methods st$c methods wrld nil nil nil nil)
    (cond (msg (mv msg nil nil))
          (t (let* ((prop (getpropc st$c 'stobj nil wrld))
                    (msg (chk-defabsstobj-updaters-1
                          accessors accessors-exec
                          updaters updaters-exec
                          (access stobj-property prop :names))))
               (cond (msg (mv msg nil nil))
                     (t (mv nil accessors updaters))))))))

(defun chk-acceptable-defabsstobj (name st$c recognizer st$ap creator
                                        corr-fn exports protect-default
                                        congruent-to non-executable
                                        see-doc ctx wrld state)

; Warning: If you change this function, change
; defabsstobj-methods-for-attachment; see comments in that function's
; definition.

; We return an error triple such that when there is no error, the value
; component is a tuple of the form (missing methods . wrld1).  Missing is
; always nil if we are including a book; otherwise, missing is a list of tuples
; (name event . old-event), where event must be proved and old-event is an
; existing event of the same name that (unfortunately) differs from event, if
; such exists, and otherwise old-event is nil.  Methods is a list of
; absstobj-method records corresponding to the recognizer, creator, and
; exports.  Wrld1 is an extension of the given world, wrld, that deals with
; redefinition.

  (cond
   ((atom exports)
    (er soft ctx
        "~x0 requires at least one export.  ~@1"
        'defabsstobj see-doc))
   ((not (stobjp st$c t wrld))
    (er soft ctx
        "The symbol ~x0 is not the name of a stobj in the current ACL2 world. ~
         ~ ~@1"
        st$c see-doc))
   ((not (true-listp exports))
    (er soft ctx
        "DEFABSSTOBJ requires the value of its :EXPORTS keyword argument to ~
         be a non-empty true list.  ~@0"
        see-doc))
   ((first-keyword exports) ; early error here, as a courtesy
    (er soft ctx
        "The keyword ~x0 is being specified as an export.  This may indicate ~
         a parenthesis error, since keywords cannot be exports.  ~@1"
        (first-keyword exports)
        see-doc))
   ((and congruent-to
         (not (and (symbolp congruent-to)
                   (getpropc congruent-to 'absstobj-info nil wrld))))

; Here, we only check that congruent-to is a candidate for a congruent abstract
; stobj.  The check is elsewhere that it is truly congruent to the proposed
; abstract stobj.  But at least we will know that congruent-to, if non-nil,
; does name some abstract stobj; see the binding of old-absstobj-info in
; defabsstobj-fn1.

    (er soft ctx
        "The :CONGRUENT-TO parameter of a DEFABSSTOBJ must either be nil or ~
         the name of an existing abstract stobj, but the value ~x0 is ~
         neither.  ~@1."
        congruent-to see-doc))
   ((not (booleanp non-executable))
    (er soft ctx
        "DEFABSSTOBJ requires the :NON-EXECUTABLE keyword argument to have a ~
         Boolean value.  See :DOC defabsstobj."))
   (t
    (er-progn
     (chk-all-but-new-name name ctx 'stobj wrld state)
     (chk-legal-defstobj-name name state)
     (er-let* ((wrld1 (chk-just-new-name name nil 'stobj nil ctx wrld state))
               (wrld2 (chk-just-new-name (the-live-var name)
                                         nil 'stobj-live-var nil ctx wrld1
                                         state)))
       (chk-acceptable-defabsstobj1 name st$c st$ap corr-fn

; Keep the recognizer and creator first and second in our call to
; chk-acceptable-defabsstobj1.  See the comment about
; chk-acceptable-defabsstobj1 in defabsstobj-fn1, and also note that the first
; two methods must be for the recognizer and creator in defabsstobj-raw-defs,
; which is called in defabsstobj-fn1, where it consumes the methods we return
; here.

                                    (list* recognizer creator exports)
                                    (list* :RECOGNIZER :CREATOR nil)
                                    protect-default congruent-to see-doc ctx
                                    wrld2 state nil nil))))))

(defun defabsstobj-axiomatic-defs (methods)
  (cond
   ((endp methods) nil)
   (t (cons (let ((method (car methods)))
              (mv-let (name formals guard-post logic stobjs-in-logic)
                (mv (access absstobj-method method :NAME)
                    (access absstobj-method method :FORMALS)
                    (access absstobj-method method :GUARD-POST)
                    (access absstobj-method method :LOGIC)
                    (access absstobj-method method :STOBJS-IN-LOGIC))
                `(,name
                  ,formals
                  (declare
                   (xargs :GUARD ,guard-post
                          ,@(let ((stobjs (remove-eq nil stobjs-in-logic)))

; This stobj declaration is potentially bogus, since there is no requirement
; about which stobjs are declared for the :logic function (for the abstract
; stobj primitive that is being defined here).  However, we avoid a potential
; error when translating the body by having the stobjs-in for the primitive
; match the stobjs-in for its body (below, i.e., the corresponding call of the
; :logic function for that primitive).

; Note that we use put-absstobjs-in-and-outs to set the stobjs-in and
; stobjs-out after the definitions are admitted, thus overriding this
; potentially bogus :stobjs declaration.

; Given the signature mismatch between the primitive and its :logic function,
; there could be concern about inappropriate calls of the :logic function on
; live stobjs.  This would involve calling the *1* function for the primitive,
; which could happen in particular when there is invariant-risk.  However, *1*
; calls don't happen where there are live stobj inputs: as noted in
; ev-fncall-creator-er-msg, "ACL2 does not support non-compliant live stobj
; manipulation."

                              (and stobjs `(:stobjs ,stobjs)))))

; In Version_8.3 we had (mbe :logic (,logic ,@formals) :exec (,exec ,@formals))
; below, but that caused a soundness bug; see :DOC note-8-4.  We tried changing
; that to (prog2$ (,exec ,@formals) (,logic ,@formals)), in some github
; versions after that.  But then we realized that the call of exec, which was
; intended to help track invariant-risk, was unnecessary because invariant-risk
; for abstract stobjs is already handled by put-defabsstobj-invariant-risk.  By
; avoiding such a prog$ call, we avoided having to deal with the possibility
; that exec doesn't return a single non-stobj value, as required by prog2$.
; (We considered making an exception in translate11, which might work; but its
; seems best to avoid such a complication.  We also tried using a non-exec
; wrapper, but that interfered with some proofs when executing abstract stobj
; primitives in the logic.)

                        (,logic ,@formals))))
            (defabsstobj-axiomatic-defs (cdr methods))))))

(defun with-inside-absstobj-update (temp saved name form)

; Temp and saved should be variables not occurring in form.

  (declare (xargs :guard (and (symbolp name) (symbolp temp))))
  `(let* ((,temp *inside-absstobj-update*)
          (,saved (svref ,temp 0)))
     (declare (type simple-array ,temp))
     (cond
      ((eq ,saved :ignore)
       ,form)
      ((eql ,saved 0) ; optimization of next case
       (setf (svref ,temp 0) 1)
       (our-multiple-value-prog1
        ,form
        (setf (svref ,temp 0) 0)))
      ((typep ,saved 'fixnum)
       (incf (the fixnum (svref ,temp 0)))
       (our-multiple-value-prog1
        ,form
        (decf (the fixnum (svref ,temp 0)))))
      (t

; If the value of ,saved is a number, then it is bounded by the number of calls
; of abstract stobj exports on the stack.  But surely the length of the stack
; is a fixnum!  So if the value of ,saved is not a fixnum, then it is not a
; number, and hence it must be a symbol or a list of symbols with a non-nil
; final cdr.

       (cond
        ((eq nil ,saved)
         (setf (svref ,temp 0) ',name)
         (our-multiple-value-prog1
          ,form
          (setf (svref ,temp 0) nil)))
        (t
         (push ',name (svref ,temp 0))
         (our-multiple-value-prog1
          ,form
          (pop (svref ,temp 0)))))))))

(defun defabsstobj-raw-def (method)

; Warning: Method, which is an absstobj-method record, might only have valid
; :NAME, :LOGIC, :EXEC, and :PROTECT fields filled in.  Do not use other fields
; unless you adjust how methods is passed in.

  (let* ((name (access absstobj-method method :NAME))
         (exec (access absstobj-method method :EXEC))
         (protect (access absstobj-method method :PROTECT))
         (form0 `(cons ',exec args))
         (body (cond ((null protect)
                      form0)
                     (t `(with-inside-absstobj-update
                          'temp 'saved ; variables not occurring in form0
                          ',name ,form0)))))
    (list name '(&rest args) body)))

(defun defabsstobj-raw-defs-rec (methods)

; See defabsstobj-raw-defs.

  (cond ((endp methods) nil)
        (t (cons (defabsstobj-raw-def (car methods))
                 (defabsstobj-raw-defs-rec (cdr methods))))))

(defun defabsstobj-raw-defs (st-name methods)

; Warning: Each method, which is an absstobj-method record, might only have
; valid :NAME, :LOGIC, :EXEC, and :PROTECT fields filled in.  Do not use other
; fields unless you adjust how methods is passed in.

; Warning: The first two methods in methods should be for the recognizer and
; creator, respectively.  See comments about that where defabsstobj-raw-defs is
; called.

; We define the bodies of macros.  By defining macros instead of functions, not
; only do we get better runtime efficiency, but also we avoid having to grab
; formals for the :EXEC function from the world.

; We pass in st-name because when we call defabsstobj-raw-defs from the
; #-acl2-loop-only definition of defabsstobj, we have methods that have nil for
; their :LOGIC components, and we need st-name to generate the :LOGIC
; recognizer name.

  (list*
   (let* ((method (car methods)) ; for the recognizer
          (name (access absstobj-method method :NAME))
          (logic (or (access absstobj-method method :LOGIC)
                     (absstobj-name st-name :RECOGNIZER-LOGIC))))
     `(,name (x) ; recognizer definition
             (list 'let
                   (list (list 'y x))
                   '(cond ((live-stobjp y) t)
                          (t (,logic y))))))
   (let* ((method (cadr methods)) ; for the creator
          (name (access absstobj-method method :NAME))
          (exec (access absstobj-method method :EXEC)))
     (assert$ (not (eq exec 'args)) ; ACL2 built-in
              `(,name (&rest args) (cons ',exec args))))
   (defabsstobj-raw-defs-rec (cddr methods))))

(defun expand-recognizer (st-name recognizer see-doc ctx state)
  (let ((recognizer (or recognizer (absstobj-name st-name :RECOGNIZER))))
    (cond ((symbolp recognizer)
           (value (list recognizer
                        :LOGIC (absstobj-name st-name :RECOGNIZER-LOGIC)
                        :EXEC (absstobj-name st-name :RECOGNIZER-EXEC))))
          ((and (consp recognizer)
                (keyword-value-listp (cdr recognizer))
                (assoc-keyword :LOGIC (cdr recognizer))
                (assoc-keyword :EXEC (cdr recognizer))
                (null (cddddr (cdr recognizer))))
           (value recognizer))
          (t (er soft ctx
                 "Illegal :RECOGNIZER field.  ~@0"
                 see-doc)))))

(defun put-absstobjs-in-and-outs (st methods wrld)
  (cond ((endp methods) wrld)
        (t (put-absstobjs-in-and-outs
            st
            (cdr methods)
            (mv-let (name posn stobjs-in-exec stobjs-out)
                    (let ((method (car methods)))
                      (mv (access absstobj-method method :name)
                          (access absstobj-method method :stobjs-in-posn)
                          (access absstobj-method method :stobjs-in-exec)
                          (access absstobj-method method :stobjs-out)))
                    (putprop name
                             'stobjs-in
                             (if posn
                                 (update-nth posn st stobjs-in-exec)
                               stobjs-in-exec)
                             (putprop name 'stobjs-out stobjs-out wrld)))))))

(defun method-exec (name methods)
  (cond ((endp methods)
         (er hard 'method-exec
             "Name ~x0 not found in methods, ~x1."
             name methods))
        ((eq name (access absstobj-method (car methods) :name))
         (access absstobj-method (car methods) :exec))
        (t (method-exec name (cdr methods)))))

(defun defabsstobj-raw-init (creator-name methods)
  `(,(method-exec creator-name methods)))

(defun defabsstobj-missing-msg (missing wrld)

; We are given missing,  a list of tuples (name expected-event . old-event),
; where old-event may be nil; see chk-acceptable-defabsstobj.  We return a
; message for ~@ fmt printing that indicates the events remaining to be proved
; in support of a defabsstobj event.

  (assert$
   missing
   (let* ((tuple (car missing))
          (name (car tuple))
          (expected-formula (untranslate (cadr tuple) t wrld))
          (old-formula (untranslate (cddr tuple) t wrld))
          (expected-defthm `(defthm ,name ,expected-formula
                              :rule-classes nil))
          (msg (cond (old-formula (msg "~%~Y01[Note discrepancy with existing ~
                                        formula named ~x2:~|  ~Y31~|]~%"
                                       expected-defthm nil name old-formula))
                     (t (msg "~%~Y01" expected-defthm nil name old-formula)))))
     (cond ((endp (cdr missing)) msg)
           (t (msg "~@0~@1"
                   msg
                   (defabsstobj-missing-msg (cdr missing) wrld)))))))

(defun update-guard-post (logic-subst methods)

; We are processing a defabsstobj event.  Methods is a list of absstobj-method
; records, and logic-subst is an alist that maps f$a to f for each exported
; function fn and corresponding :logic function symbol f$a.

; Note that the :guard-pre term of a method is the guard of a guard-verified
; function (with a variable replaced); hence its guard proof obligations are
; provable.  Consider the :guard-post for that method, which is created by this
; function using sublis-fn-simple; it is obtained by replacing some functions
; with equal functions.  The guard proof obligations for that :guard-post are
; thus obtained by replacing some functions with equal functions; hence those
; proof obligations are also provable.  Now that :guard-post becomes the guard
; of the exported function for that method (the :name); we have thus shown that
; the guard of that guard is provable, as required.

  (cond ((endp methods) nil)
        (t (cons (change absstobj-method (car methods)
                         :guard-post
                         (sublis-fn-simple logic-subst
                                           (access absstobj-method
                                                   (car methods)
                                                   :guard-pre)))
                 (update-guard-post logic-subst (cdr methods))))))

(defun defabsstobj-logic-subst (methods)
  (cond ((endp methods) nil)
        (t (acons (access absstobj-method (car methods) :logic)
                  (access absstobj-method (car methods) :name)
                  (defabsstobj-logic-subst (cdr methods))))))

(defun chk-defabsstobj-guard (method ctx wrld state-vars)
  (mv-let (ctx msg)
          (translate-cmp (access absstobj-method method
                                 :guard-post)
                         '(nil) ; stobjs-out
                         t ; logic-modep = t because we expect :logic mode here
                         (stobjs-in (access absstobj-method method :name)
                                    wrld)
                         ctx wrld state-vars)
          (cond (ctx (er-cmp ctx
                             "The guard for exported function ~x0 fails to ~
                              pass a test for being suitably single-threaded. ~
                              ~ Here is that guard (derived from the guard ~
                              for function ~x1).~|  ~x2~|And here is the ~
                              error message for the failed test.~|  ~@3"
                             (access absstobj-method method :name)
                             (access absstobj-method method :logic)
                             (access absstobj-method method :guard-post)
                             msg))
                (t (value-cmp nil)))))

(defun chk-defabsstobj-guards1 (methods msg ctx wrld state-vars)
  (cond ((endp methods)
         msg)
        (t (mv-let
            (ctx0 msg0)
            (chk-defabsstobj-guard (car methods) ctx wrld state-vars)
            (chk-defabsstobj-guards1 (cdr methods)
                                     (cond (ctx0
                                            (assert$
                                             msg0
                                             (cond (msg
                                                    (msg "~@0~|~%~@1" msg msg0))
                                                   (t msg0))))
                                           (t msg))
                                     ctx wrld state-vars)))))

(defun chk-defabsstobj-guards (methods congruent-to ctx wrld state)
  (cond
   (congruent-to (value nil)) ; no need to check!
   (t (let ((msg (chk-defabsstobj-guards1 methods nil ctx wrld
                                          (default-state-vars t))))
        (cond (msg (er soft ctx
                       "At least one guard of an exported function fails to ~
                        obey single-threadedness restrictions.  See :DOC ~
                        defabsstobj.  See below for details.~|~%~@0~|~%"
                       msg))
              (t (value nil)))))))

(defun make-absstobj-tuples (methods)

; Warning: If you change this, look for places that access absstobj tuples,
; including function absstobj-logical-skeleton-difference-msg.

  (cond ((endp methods) nil)
        (t (cons (list* (access absstobj-method (car methods) :name)
                        (access absstobj-method (car methods) :logic)
                        (access absstobj-method (car methods) :exec)
                        (access absstobj-method (car methods) :updater))
                 (make-absstobj-tuples (cdr methods))))))

(defun put-defabsstobj-invariant-risk (methods wrld)

; See also put-invariant-risk.  Invariant-risk from a stobj export, fn,
; trivially derives from the invariant-risk of its :exec function, fn_E, since
; a call of fn in raw Lisp is just the corresponding call of fn_E.

  (cond ((endp methods) wrld)
        (t (let ((method (car methods)))
             (put-defabsstobj-invariant-risk
              (cdr methods)
              (let ((invariant-risk
                     (getpropc (access absstobj-method method :EXEC)
                               'invariant-risk nil wrld)))
                (cond (invariant-risk
                       (putprop (access absstobj-method method :NAME)
                                'invariant-risk invariant-risk wrld))
                      (t wrld))))))))

(defun congruent-absstobj-tuples-rec (tuples1 tuples2 all-tuples1 all-tuples2)
  (cond
   ((endp tuples1) (null tuples2))
   (t
    (let ((x1 (car tuples1))
          (x2 (car tuples2)))
      (and (or (equal (cdr x1) (cdr x2))
               (and (eq (cadr x1) (cadr x2))
                    (eq (caddr x1) (caddr x2))
                    (let ((up1 (cdddr x1))
                          (up2 (cdddr x2)))
                      (and up1
                           up2
                           (eql (key-position-from-end-eq up1 all-tuples1)
                                (key-position-from-end-eq up2 all-tuples2))))))
           (congruent-absstobj-tuples-rec (cdr tuples1) (cdr tuples2)
                                          all-tuples1 all-tuples2))))))

(defun congruent-absstobj-tuples (tuples1 tuples2)

; Each of tuples1 and tuples2 has the shape of an :absstobj-tuples field of an
; absstobj-info record, which is created by make-absstobj-tuples as a list of
; tuples of the form (name logic exec . updater).  When tuples1 and tuples2 are
; absstobj-info records for abstract stobjs st1 and st2, congruence of st1 and
; st2 is defined by equality of those tuples except for treatment of non-nil
; updaters.  For corresponding tuples (name1 logic1 exec1 . updater1) and
; (name2 logic2 exec2 . updater2) with non-nil updater1 and updater2,
; congruence demands that updater1 and updater2 are names of tuples having the
; same position in those lists of tuples.  A relevant example is in community
; books file
; books/system/tests/abstract-stobj-nesting/nested-abstract-stobjs-input.lsp,
; where admission of abstract stobjs top2, specified to be congruent to
; abstract stobj top, generates the following call of
; congruent-absstobj-tuples.  Notice that corresponding tuples are equal except
; for those with a non-nil updater, where the only difference is in those
; updaters, which however each have the same position (second to last) in the
; lists of tuples.

;   (congruent-absstobj-tuples ((top2p top$ap top$cp)
;                               (create-top2 create-top$a create-top$c)
;                               (sub02 sub0$a sub0$c . update-sub02)
;                               (sub02-again sub0$a sub0$c . update-sub02)
;                               (update-sub02 update-sub0$a update-sub0$c)
;                               (misc2 misc$a misc$c))
;                              ((topp top$ap top$cp)
;                               (create-top create-top$a create-top$c)
;                               (sub0 sub0$a sub0$c . update-sub0)
;                               (sub0-again sub0$a sub0$c . update-sub0)
;                               (update-sub0 update-sub0$a update-sub0$c)
;                               (misc misc$a misc$c)))

  (congruent-absstobj-tuples-rec tuples1 tuples2 tuples1 tuples2))

(defun defabsstobj-methods-for-attachment1 (st st-new absstobj-tuples
                                               st$c fields
                                               types protect-default
                                               see-doc ctx wrld
                                               state methods)

; This variant of chk-acceptable-defabsstobj1 supports
; defabsstobj-methods-for-attachment.  See defabsstobj-methods-for-attachment.

  (cond
   ((endp fields)
    (value (list* nil (reverse methods) wrld)))
   (t
    (mv-let
     (erp method)
     (translate-absstobj-field st st-new (car absstobj-tuples)
                               st$c
                               (car fields)
                               (car types)
                               protect-default
                               (ld-skip-proofsp state)
                               see-doc ctx wrld)
     (cond
      (erp ; erp is ctx, method is a msg
       (er soft erp "~@0" method))
      (t
       (defabsstobj-methods-for-attachment1
        st st-new (cdr absstobj-tuples)
        st$c
        (cdr fields)
        (cdr types)
        protect-default
        see-doc ctx wrld state
        (cons method methods))))))))

(defun defabsstobj-methods-for-attachment (name name-new absstobj-tuples
                                                st$c recognizer
                                                creator exports
                                                protect-default
                                                see-doc ctx wrld state)

; Warning: If you change this function, change chk-acceptable-defabsstobj; see
; comments below.

; This is analogous to chk-acceptable-defabsstobj, but in support of the case
; that defabsstobj-fn1 is being called recursively to attach an implementation
; stobj to an attachable stobj.  See the Essay on Attachable Stobjs.  Name is
; the name of the implementation stobj and name-new is the name of the
; attachable stobj.  The remaining parameters through protect-default are from
; the implementation stobj.  As with chk-acceptable-defabsstobj, we return an
; error triple whose non-error value is a tuple of the form (missing methods
; . wrld1).  In this case, however, missing is always nil and methods are
; suitable for the attached stobj.

; The code here has thus been adapted from the code for
; chk-acceptable-defabsstobj, but with many checks omitted since the
; implementation stobj (named name) was previously admitted successfully.

  (defabsstobj-methods-for-attachment1
    name name-new absstobj-tuples
    st$c

; Keep the recognizer and creator first and second in our call to
; chk-acceptable-defabsstobj1.  See the comment about
; chk-acceptable-defabsstobj1 in defabsstobj-fn1, and also note that the first
; two methods must be for the recognizer and creator in defabsstobj-raw-defs,
; which is called in defabsstobj-fn1, where it consumes the methods we return
; here.

    (list* recognizer creator exports)
    (list* :RECOGNIZER :CREATOR nil)
    protect-default see-doc ctx
    wrld state nil))

(defun defabsstobj-update-ext-gens-1 (methods ext-gens acc)
  (cond ((endp methods) acc)
        (t (let ((method (car methods)))
             (defabsstobj-update-ext-gens-1
               (cdr methods)
               ext-gens
               (if (member-eq (access absstobj-method method :exec)
                              ext-gens)
                   (cons (access absstobj-method method :name)
                         acc)
                 acc))))))

(defun defabsstobj-update-ext-gens (ext-gens doit names methods wrld)

; See the Essay on Attachable Stobjs for relevant background.  If doit is true
; then we are to add all of the given names to the ext-gens world global.
; Otherwise, we add all of the given names whose :logic or :exec function is in
; ext-gens.

  (cond
   (doit (global-set 'ext-gens
                     (append? names ext-gens)
                     wrld))
   ((null ext-gens) wrld) ; optimization
   (t (global-set? 'ext-gens
                   (defabsstobj-update-ext-gens-1 methods ext-gens ext-gens)
                   wrld
                   ext-gens))))

(defun fix-export-updaters1 (old old-to-new)
  (cond
   ((endp old)
    nil)
   (t
    (let* ((field-old (car old))
           (updater-old (cadr (assoc-keyword :updater (cdr field-old)))))
      (cond
       (updater-old
        (mv-let (pre post)
          (split-keyword-alist :updater (cdr field-old))
          (cons (cons (car field-old)
                      (append pre
                              (list* :updater
                                     (cdr (assoc-eq (cadr post) old-to-new))
                                     (cddr post))))
                (fix-export-updaters1 (cdr old) old-to-new))))
       (t
        (cons-with-hint field-old
                        (fix-export-updaters1 (cdr old) old-to-new)
                        (cdr old))))))))

(defun export-names (exports)
  (cond ((endp exports) nil)
        (t (cons (if (symbolp (car exports))
                     (car exports)
                   (caar exports))
                 (export-names (cdr exports))))))

(defun fix-export-updaters (old new)

; Old and new are :export values for old and new defabsstobj events, say for
; names st-old and st-new, where st-old has been checked as acceptable to
; attach to st-new.  In particular, old and new suitably correspond; in
; particular, they have the same length and their :updater fields suitably
; correspond.  We return the result of modifying the :updater fields of members
; of old according to corresponding names of new.

  (let ((old-to-new (pairlis$ (export-names old) (export-names new))))
    (fix-export-updaters1 old old-to-new)))

(defun defabsstobj-fn1 (st-name st$c recognizer creator corr-fn exports
                                protect-default congruent-to non-executable
                                attachable missing-only ctx state event-form
                                discriminator
                                creator-name-orig
                                absstobj-tuples-new)

; When this function is called at the top level, i.e., by defabsstobj-fn1,
; discriminator is nil.  This function calls itself tail-recursively when
; discriminator is nil (i.e., we are at the top level) and there is an attached
; stobj, i.e., attachable is t and the current world provides an attached stobj
; (by way of attach-stobj-table).  In that case, the recursive call installs an
; abstract stobj suitably based on that attachment, but with suitable
; non-executable and other arguments based on the attached implementation
; stobj; see the recursive call below.  For relevant background, see the Essay
; on Attachable Stobjs.

; It may be tempting to use make-event, instead of using a recursive call as
; described above.  Thus, a defabsstobj with a non-nil :attachable keyword
; would macroexpand to a make-event whose expansion is a defabsstobj with
; :attachable nil that updates the given event to reflect the attachment.
; (Alternatively, perhaps the update would be to make the attached stobj be the
; value of :attachable, and defabsstobj-fn1 could do the work of reflecting the
; attachment.)  NO -- DON'T USE MAKE-EVENT!  The expansion when purely generic
; at certification time isn't suitable when later we include the book after
; attaching an implementation, which would be unfortunate since we don't redo
; the expansion of a make-event at include-book time.

  (let* ((wrld0 (w state))
         (st-name-new (if discriminator
                          (cadr event-form)
                        st-name))
         (see-doc "See :DOC defabsstobj.")
         (st$c (or st$c
                   (absstobj-name st-name :C)))
         (creator (or creator
                      (absstobj-name st-name :CREATOR)))
         (creator-name (if (consp creator)
                           (car creator)
                         creator))
         (corr-fn (or corr-fn
                      (absstobj-name st-name :CORR-FN)))
         (ext-gens-wrld0 (global-val 'ext-gens wrld0)))
    (cond
     ((and (not discriminator)
           (redundant-defabsstobjp st-name event-form wrld0))
      (value 'redundant))
     (t
      (er-let* ((recognizer0

; Since the call of chk-acceptable-defabsstobj requires st$ap, we need to
; expand the recognizer here (rather than letting it getting expanded by
; chk-acceptable-defabsstobj).  We really only need the :logic recognizer
; (st$ap) here, not the :exec recognizer, but we might as well do the full
; expansion of the recognizer function spec.

                 (expand-recognizer st-name recognizer see-doc ctx state))
                (recognizer
                 (value (if discriminator ; recursive case for attachment
                            (cons st-name-new (cdr recognizer0))
                          recognizer0)))
                (st$ap (value (cadr (assoc-keyword :logic (cdr recognizer)))))
                (missing/methods/wrld1
                 (if discriminator ; recursive case for attachment
                     (defabsstobj-methods-for-attachment
                      st-name st-name-new absstobj-tuples-new
                      st$c recognizer creator exports protect-default see-doc
                      ctx wrld0 state)
                   (chk-acceptable-defabsstobj
                    st-name st$c recognizer st$ap creator corr-fn exports
                    protect-default congruent-to non-executable see-doc ctx
                    wrld0 state))))
        (let* ((missing (car missing/methods/wrld1))
               (methods0 (cadr missing/methods/wrld1))
               (absstobj-info-cong

; Note that if absstobj-info-cong is non-nil, then because of the congruent-to
; check in chk-acceptable-defabsstobj, congruent-to is a symbol and the getprop
; below returns a non-nil value (which must then be an absstobj-info record).
; See the comment about this in chk-acceptable-defabsstobj.

                (and congruent-to
                     (getpropc congruent-to 'absstobj-info nil wrld0)))
               (absstobj-tuples (make-absstobj-tuples methods0))
               (att-name (and (eq attachable t)
                              (assert$
                               (null discriminator) ; not recursive call
                               (attached-stobj st-name wrld0 t)))))
          (er-progn
            (if att-name ; top-level call, not for attached stobj
                (assert$
                 (null discriminator)
                 (chk-absstobj-attachment st-name att-name absstobj-tuples ctx
                                          wrld0 see-doc state))
              (value nil))

; The first three COND clauses just below, all related to missing-only or
; congruent-to, can be skipped in the recursive case (for an attached stobj).
; But it seems harmless to include them for that case as well.

           (cond
            ((and missing-only
                  (not congruent-to)) ; else do check before returning missing
             (value (car missing/methods/wrld1)))
            ((and congruent-to
                  (not att-name) ; else check congruent-to in recursive call
                  (not (equal st$c
                              (access absstobj-info absstobj-info-cong
                                      :st$c))))
             (er soft ctx
                 "The value provided for :congruent-to, ~x0, is illegal, ~
                  because the foundational stobj associated with ~x0 is ~x1, ~
                  while the foundational stobj proposed for ~x2 is ~x3.  ~@4"
                 congruent-to
                 (access absstobj-info absstobj-info-cong :st$c)
                 st-name
                 st$c
                 see-doc))
            ((and congruent-to
                  (not att-name) ; else check congruent-to in recursive call
                  (not (congruent-absstobj-tuples
                        absstobj-tuples
                        (access absstobj-info absstobj-info-cong
                                :absstobj-tuples))))
             (er soft ctx
                 "The value provided for :congruent-to, ~x0, is illegal.  ~
                  ACL2 requires that the :LOGIC, :EXEC, and :UPDATER ~
                  functions match up perfectly (in the same order), for stobj ~
                  primitives introduced by the proposed new abstract stobj, ~
                  ~x1 and the existing stobj to which it is supposed to be ~
                  congruent, ~x0. Here are the lists of tuples (:LOGIC :EXEC ~
                  . :UPDATER) for each.~|~%For ~x1 (proposed):~|~Y24~%For ~
                  ~x0:~|~Y34~%~|~@5"
                 congruent-to
                 st-name
                 (strip-cdrs absstobj-tuples)
                 (strip-cdrs (access absstobj-info absstobj-info-cong
                                     :absstobj-tuples))
                 nil
                 see-doc))
            (t
             (mv-let (msg accessors updaters)
               (chk-defabsstobj-updaters st$c methods0 wrld0)
               (cond
                (msg ; should be impossible in recursive case
                 (er soft ctx "~@0  ~@1" msg see-doc))
                (missing-only (value missing))
                (t
                 (er-progn
                  (cond
                   ((or (null missing) ; including recursive case
                        (member-eq (ld-skip-proofsp state)
                                   '(include-book include-book-with-locals)))
                    (value nil))
                   ((ld-skip-proofsp state)
                    (pprogn (warning$ ctx "defabsstobj"
                                      "The following events would have to be ~
                                       admitted, if not for proofs currently ~
                                       being skipped (see :DOC ~
                                       ld-skip-proofsp), before the given ~
                                       defabsstobj event.  ~@0~|~@1"
                                      see-doc
                                      (defabsstobj-missing-msg missing wrld0))
                            (value nil)))
                   (t (er soft ctx
                          "The following events must be admitted before the ~
                           given defabsstobj event is admitted.  ~@0~|~@1"
                          see-doc
                          (defabsstobj-missing-msg missing wrld0))))
                  (enforce-redundancy
                   event-form ctx wrld0
                   (let* ((methods (update-guard-post
                                    (defabsstobj-logic-subst methods0)
                                    methods0))
                          (wrld1 (cddr missing/methods/wrld1))
                          (ax-def-lst (defabsstobj-axiomatic-defs methods))
                          (raw-def-lst

; The first method in methods is for the recognizer, as is guaranteed by
; chk-acceptable-defabsstobj (as explained in a comment there that refers to
; the present function, defabsstobj-fn1).

                           (defabsstobj-raw-defs st-name methods))
                          (names (strip-cars ax-def-lst))
                          (the-live-var (the-live-var st-name-new)))
                     (er-progn
                      (cond ((equal names (strip-cars raw-def-lst))
                             (value nil))
                            (t (value
                                (er hard ctx
                                    "Defabsstobj-axiomatic-defs and ~
                                     defabsstobj-raw-defs are out of sync!  ~
                                     We expect them to define the same list ~
                                     of names.  Here are the strip-cars of ~
                                     the axiomatic defs:  ~x0.  And here are ~
                                     the strip-cars of the raw defs:  ~x1."
                                    names
                                    (strip-cars raw-def-lst)))))
                      (revert-world-on-error
                       (pprogn
                        (set-w 'extension wrld1 state)
                        (er-progn
                         (process-embedded-events
                          'defabsstobj
                          (table-alist 'acl2-defaults-table wrld1)
                          (or (ld-skip-proofsp state) t)
                          (current-package state)
                          (list 'defstobj st-name-new names) ; ee-entry

; Warning: Don't change the following list of events without first considering
; whether that invalidates the translation of definitions for logic rather than
; execution (by use of inside-defabsstobj in translate-bodies1).

                          (append
                           (pairlis-x1 'defun ax-def-lst)
                           `((encapsulate
                               ()
                               (set-inhibit-warnings "theory")
                               (in-theory
                                (disable
                                 (:executable-counterpart
                                  ,creator-name))))))
                          0
                          t ; might as well do make-event check
                          (f-get-global 'cert-data state)
                          ctx state)

; The processing above will install defun events but defers installation of raw
; Lisp definitions, just as for defstobj.

                         (let* ((wrld2 (w state))
                                (congruent-stobj-rep
                                 (and congruent-to
                                      (congruent-stobj-rep congruent-to
                                                           wrld2)))
                                (non-memoizable
                                 (getpropc st$c 'non-memoizable nil wrld2))
                                (wrld3
                                 (put-defabsstobj-invariant-risk
                                  methods
                                  (putprop
                                   st-name-new 'congruent-stobj-rep
                                   congruent-stobj-rep
                                   (putprop-unless
                                    st-name-new 'non-memoizable
                                    non-memoizable nil
                                    (putprop-unless
                                     st-name-new 'non-executablep
                                     non-executable nil
                                     (putprop
                                      st-name-new 'absstobj-info
                                      (make absstobj-info
                                            :st$c st$c
                                            :absstobj-tuples
                                            absstobj-tuples)
                                      (putprop
                                       st-name-new 'symbol-class
                                       :common-lisp-compliant
                                       (put-absstobjs-in-and-outs
                                        st-name-new methods
                                        (putprop
                                         st-name-new 'stobj
                                         (make stobj-property
                                               :live-var the-live-var

; We know that the first two members of names are the recognizer and creator,
; respectively.  The remaining names need to be put into proper order for the
; use of the 'stobj property in functions chk-stobj-updaters (in support of
; stobj-let) and stobj-field-fn-of-stobj-type-p (for the call there of
; absstobj-field-fn-of-stobj-type-p): each updater must immediately follow the
; corresponding accessor in the :names field.

                                               :recognizer (car names)
                                               :creator (cadr names)
                                               :names
                                               (sort-absstobj-names
                                                (cddr names)
                                                accessors
                                                updaters))
                                         (putprop-x-lst1
                                          names 'stobj-function st-name-new
                                          (putprop
                                           the-live-var 'stobj-live-var
                                           st-name-new
                                           (putprop
                                            the-live-var 'symbol-class
                                            :common-lisp-compliant
                                            wrld2))))))))))))
                                (discriminator1
                                 (or
                                  discriminator
                                  (cons 'defabsstobj
                                        (make
                                         defstobj-redundant-raw-lisp-discriminator-value
                                         :event event-form
                                         :recognizer (car names)
                                         :creator creator-name
                                         :congruent-stobj-rep
                                         (or congruent-stobj-rep
                                             st-name-new)
                                         :non-memoizable non-memoizable
                                         :non-executable
                                         non-executable))))
                                (raw-init-form-new
                                 (defabsstobj-raw-init
                                   (or creator-name-orig creator-name)
                                   methods))
                                (wrld4 (if att-name

; This special case, where att-name is non-nil, is simply an optimization.  It
; is the case that we will be calling defabsstobj-fn1 recursively on wrld1.
; There is no need to update ext-gens or ext-gen-barriers in the world when all
; that is left to do, before making that recursive call, is to call
; chk-defabsstobj-guards.
;

                                           wrld3
                                         (defabsstobj-update-ext-gens
                                           ext-gens-wrld0

; The stobj has an attachment if the input discriminator is non-nil (and hence
; we are in a recursive call of defabsstobj-fn1) and is generic if attachable
; is non-nil.  Either way, the stobj is generic so its primitives need to be
; added to the list of extended generics.  See defabsstobj-update-ext-gens.

                                           (or discriminator attachable)
                                           names methods wrld3))))
                           (pprogn
                            (set-w 'extension wrld4 state)
                            (er-progn
                             (chk-defabsstobj-guards methods congruent-to ctx
                                                     wrld4 state)

; The call of install-event below follows closely the corresponding call in
; defstobj-fn.  In particular, see the comment in defstobj-fn about a "cheat".

                             (cond
                              (att-name
                               (pprogn
                                (set-w 'retraction wrld1 state)
                                (let ((kwa
                                       (cddr (get-event att-name wrld0))))
                                  (defabsstobj-fn1
                                    att-name
                                    (cadr (assoc-keyword :foundation kwa))
                                    (cadr (assoc-keyword :recognizer kwa))
                                    (cadr (assoc-keyword :creator kwa))
                                    :irrelevant ; corr-fn
                                    (fix-export-updaters
                                     (cadr (assoc-keyword :exports kwa))
                                     exports)
                                    (cadr (assoc-keyword :protect-default
                                                         kwa))
                                    (cadr (assoc-keyword :congruent-to kwa))
                                    non-executable ; use the generic's
                                    nil nil
                                    ctx state event-form discriminator1
                                    creator-name
                                    absstobj-tuples))))
                              (t
                               (install-event st-name-new
                                              event-form
                                              'defstobj
                                              (list* st-name-new
                                                     the-live-var
                                                     names) ; namex
                                              nil
                                              `(defabsstobj ,st-name-new
                                                 ,the-live-var
                                                 ,raw-init-form-new
                                                 ,raw-def-lst
                                                 ,discriminator1
                                                 ,ax-def-lst)
                                              t
                                              ctx
                                              wrld4
                                              state)))))))))))))))))))))))))

(defun defabsstobj-fn (st-name st$c recognizer creator corr-fn exports
                               protect-default congruent-to non-executable
                               attachable missing-only state event-form)

; This definition shares a lot of code and ideas with the definition of
; defstobj-fn.  See the comments there for further explanation.  Note that we
; use the name "defstobj" instead of "defabsstobj" in some cases where defstobj
; and defabsstobj are handled similarly.  For example, install-event-defuns
; uses (cons 'defstobj (defstobj-functionsp ...)) for the ignorep field of its
; cltl-command because we look for such a cons in add-trip, and
; defstobj-functionsp looks for 'defstobj in the embedded-event-lst, which is
; why the ee-entry argument of process-embedded-events below uses 'defstobj.

  (with-ctx-summarized
   (msg "( DEFABSSTOBJ ~x0 ...)" st-name)
   (cond
    ((not (booleanp attachable))
     (er soft ctx
         "The value of the :ATTACHABLE keyword for DEFABSSTOBJ must be ~x0 or ~
          ~x1.  The value ~x2 is thus illegal."
         t nil attachable))
    (t (defabsstobj-fn1 st-name st$c recognizer creator corr-fn exports
         protect-default congruent-to non-executable attachable missing-only
         ctx state event-form nil nil nil)))))

(defun create-state ()
  (declare (xargs :guard t))
  (coerce-object-to-state *default-state*))

(defmacro with-local-state (mv-let-form)
  `(with-local-stobj state ,mv-let-form))

; Essay on Nested Stobjs

; After Version_6.1 we introduced a new capability: allowing fields of stobjs
; to themselves be stobjs or arrays of stobjs.  (Hash-table fields with stobj
; values were added after Version_8.4.)  Initially we resisted this idea
; because of an aliasing problem, which we review now, as it is fundamental to
; understanding our implementation.

; Consider the following events.

;   (defstobj st fld)
;   (defstobj st2 (fld2 :type st))

; Now suppose we could evaluate the following code, to be run immediately after
; admitting the two defstobj events above.

;   (let* ((st (fld2 st2))
;          (st (update-fld 3 st)))
;     (mv st st2))

; A reasonable raw-Lisp implementation of nested stobjs, using destructive
; updates, could be expected to have the property that for the returned st and
; st2, st = (fld2 st2) and thus (fld (fld2 st2)) = (fld st) = 3.  However,
; under an applicative semantics, st2 has not changed and thus, logically, it
; follows that (fld (fld2 st2)) has its original value of nil, not 3.

; In summary, a change to st can cause a logically-inexplicable change to st2.
; But this problem can also happen in reverse: a change to st2 can cause a
; logically-inexplicable change to st.  Consider evaluation of the following
; code, to be run immediately after admitting the two defstobj events above.

;   (let ((st2 (let* ((st (fld2 st2))
;                     (st (update-fld 3 st)))
;                (update-fld2 st st2))))
;     (mv st st2))

; With destructive updates in raw Lisp, we expect that st = (fld2 st2) for the
; returned st and st2, and thus (fld st) = (fld (fld2 st2)) = 3.  But
; logically, the returned st is as initially created, and hence (fld st) =
; nil.

; One can imagine other kinds of aliasing problems; imagine putting a single
; stobj into two different slots of a parent stobj.

; Therefore, we carefully control access to stobj fields of stobjs by
; introducing a new construct, stobj-let.  Consider for example the following
; events.

; (defstobj st1 ...)
; (defstobj st2 ...)
; (defstobj st3 ...)
; (defstobj st+
;           (fld1 :type st1)
;           (fld2 :type st2)
;           (fld3 :type (array st3 (8))))

; If producer and consumer are functions, then we can write the following
; form.  Note that stobj-let takes four "arguments": bindings, producer
; variables, a producer form, and a consumer form.

;   (stobj-let
;    ((st1 (fld1 st+))
;     (st2 (fld2 st+))
;     (st3 (fld3i 4 st+)))
;    (x st1 y st3 ...) ; producer variables
;    (producer st1 st2 st3 ...)
;    (consumer st+ x y ...))

; Updater names need to be supplied if not the default.  Thus, the form above
; is equivalent to the following.

;   (stobj-let
;    ((st1 (fld1 st+) update-fld1)
;     (st2 (fld2 st+) update-fld2)
;     (st3 (fld3i 4 st+) update-fld3i))
;    (x st1 y st3 ...) ; producer variables
;    (producer st1 st2 st3 ...)
;    (consumer st+ x y ...))

; The form above expands as follows in the logic (or at least, essentially so).
; The point is that we avoid the aliasing problem: there is no direct access to
; the parent stobj when running the producer, which is updated to stay in sync
; with updates to the child stobjs; and there is no direct access to the child
; stobjs when running the consumer.  Note that since st2 is not among the
; producer variables, fld2 is not updated.

;   (let ((st1 (fld1 st+))
;         (st2 (fld2 st+))
;         (st3 (fld3i 4 st+)))
;     (declare (ignorable st1 st2 st3)) ; since user has no way to do this
;     (mv-let (x st1 y st3 ...) ; producer variables
;             (check-vars-not-free (st+)
;                                  (producer st1 st2 st3 ...))
;             (let* ((st+ (update-fld1 st1 st+))
;                    (st+ (update-fld3i 4 st3 st+)))
;               (check-vars-not-free (st1 st2 st3)
;                                    (consumer st+ x y ...)))))

; We consider next whether the use of check-vars-not-free truly prevents access
; to a stobj named in its variable list (first argument).  For example, if
; <form> is the stobj-let form displayed above, might we let-bind foo to st+
; above <form> and then reference foo in the producer?  Such aliasing is
; prevented (or had better be!) by our implementation; in general, we cannot
; have two variables bound to the same stobj, or there would be logical
; problems: changes to a stobj not explained logically (because they result
; from destructive changes to a "copy" of the stobj that is really EQ to the
; original stobj).  On first glance, one might wonder if support for congruent
; stobjs could present a problem, for example as follows.  Suppose that
; function h is the identity function that maps stobj st1 to itself, suppose
; that st2 is a stobj congruent to st1, and consider the form (let ((st2 (h
; st1))) <term>).  If such a form could be legal when translating for execution
; (which is the only way live stobjs can be introduced), then the aliasing
; problem discussed above could arise, because st2 is bound to st1 and <term>
; could mention both st1 and st2.  But our handling of congruent stobjs allows
; h to map st1 to st2 and also to map st2 to st2, but not to map st1 to st2.
; There are comments about aliasing in the definitions of translate11-let and
; translate11-mv-let.

; In the bindings, an index in an array access or a key in a hash-table access
; must be a symbol, natural number, or quoted constant -- after all, there
; could be a waste of computation otherwise when doing updates at the end.  (If
; there are no updates involving the index or key then perhaps we can relax
; this condition, but for now we leave it as is.)  For each index that is a
; variable, it must not be among the producer variables, to prevent its capture
; in the generated updater call.

; Of course, we make other checks too: for example, all of the top-level
; let-bound stobj fields must be distinct stobj variables that suitably
; correspond to distinct field calls on the same stobj.  (If we want to relax
; that restriction, we need to think very carefully about capture issues.)

; In raw Lisp, the expansion avoids the expense of binding st+ to the updates,
; or even updating st+ at all, since the updates to its indicated stobj fields
; are all destructive.  IGNORE declarations take the place of those updates.
; And the update uses let* instead of let at the top level, since (at least in
; CCL) that adds efficiency.

;   (let* ((st1 (fld1 st+))
;          (st2 (fld2 st+))
;          (st3 (fld3i 4 st+)))
;     (declare (ignorable st1 st2 st3))
;     (mv-let (x st1 y st3 ...)
;             (producer st1 st2 st3 ...)
;             (declare (ignore st1 st3))
;             (consumer st+ x y ...)))

; Note that bound variables of a stobj-let form must be unique.  Thus, if the
; parent stobj has two fields of the same stobj type, then they cannot be bound
; by the same stobj-let form unless different variables are used.  This may be
; possible, since stobj-let permits congruent stobjs in the bindings.  For
; example, suppose that we started instead with these defstobj events.

; (defstobj st1 ...)
; (defstobj st2 ... :congruent-to st1)
; (defstobj st3 ...)
; (defstobj st+
;           (fld1 :type st1)
;           (fld2 :type st1)
;           (fld3 :type (array st3 (8))))

; Then we can write the same stobj-let form as before.  ACL2 will check that
; st2 is congruent to the type of fld2, which is st1.

; The discussion above assumes that there are at least two producer variables
; for a stobj-let.  However, one producer variable is permitted, which
; generates a LET in place of an MV-LET.  For example, consider the following.

;   (stobj-let
;    ((st1 (fld1 st+))
;     (st2 (fld2 st+))
;     (st3 (fld3i 4 st+)))
;    (st1) ; producer variable
;    (producer st1 st2 st3 ...)
;    (consumer st+ x y ...))

; Here is the translation in the logic.

;   (let ((st1 (fld1 st+))
;         (st2 (fld2 st+))
;         (st3 (fld3 st+)))
;     (declare (ignorable st1 st2 st3))
;     (let ((st1 (check-vars-not-free (st+)
;                                     (producer st1 st2 st3 ...))))
;       (let* ((st+ (update-fld1 st1 st+)))
;         (check-vars-not-free (st1 st2 st3)
;                              (consumer st+ x y ...)))))

; For simplicity, each binding (in the first argument of stobj-let) should be
; for a stobj field.

; We had the following concern about *1* code generated for updaters of stobjs
; with stobj fields.  Oneify-cltl-code generates a check for *1* updater calls,
; for whether a stobj argument is live.  But should we consider the possibility
; that one stobj argument is live and another stobj argument is not?
; Fortunately, that's not an issue: if one stobj argument is live, then we are
; running code, in which case translate11 ensures that all stobj arguments are
; live.

; End of Essay on Nested Stobjs

(defmacro stobj-let (&whole x &rest args)

; It is usually a mistake to invoke the stobj-let macro during logical
; evaluation, because some checks are generated by translate, using its access
; to the world, rather than by this macro; see for example
; chk-stobj-let/accessors.

  (declare (ignore args))
  #+acl2-loop-only
  (stobj-let-fn x)
  #-acl2-loop-only
  (stobj-let-fn-raw x))

(defun collect-badged-fns (fns wrld)

; Note that executable-badge is not yet defined in the boot-strap, so we work
; around that issue here.  The result may suffer a bit in performance.

  (cond ((endp fns) nil)
        ( ;(executable-badge (car fns) wrld)
         (mv-let (erp val)
           (ev-fncall-w 'executable-badge
                        (list (car fns) wrld)
                        wrld
                        nil  ; user-stobj-alist
                        nil  ; safe-mode
                        nil  ; gc-off
                        t    ; hard-error-returns-nilp
                        nil) ; aok
           (assert$ (not erp)
                    val))
         (cons (car fns)
               (collect-badged-fns (cdr fns) wrld)))
        (t (collect-badged-fns (cdr fns) wrld))))

(defun collect-macros (names wrld)
  (cond ((endp names) nil)
        ((eq (getpropc (car names) 'macro-args t wrld) t)
         (collect-macros (cdr names) wrld))
        (t (cons (car names)
                 (collect-macros (cdr names) wrld)))))

(defun push-untouchable-fn (name fn-p state event-form)

; Warning: If this event ever generates proof obligations, remove it from the
; list of exceptions in install-event just below its "Comment on irrelevance of
; skip-proofs".

  (with-ctx-summarized
   (cond ((symbolp name)
          (msg "( PUSH-UNTOUCHABLE ~x0 ~x1)" name fn-p))
         (t "( PUSH-UNTOUCHABLE ...)"))
   (let ((wrld (w state))
         (event-form (or event-form
                         (list 'push-untouchable name fn-p)))
         (names (if (symbolp name) (list name) name))
         (untouchable-prop (cond (fn-p 'untouchable-fns)
                                 (t 'untouchable-vars))))
     (cond
      ((not (symbol-listp names))
       (er soft ctx
           "The argument to push-untouchable must be either a non-nil symbol ~
            or a non-empty true list of symbols and ~x0 is neither."
           name))
      ((subsetp-eq names (global-val untouchable-prop wrld))
       (stop-redundant-event ctx state))
      (t
       (let ((bad1 (if fn-p
                       (collect-never-untouchable-fns-entries
                        names
                        (global-val 'never-untouchable-fns wrld))
                     nil))
             (bad2 (if fn-p
                       (collect-badged-fns names wrld)
                     nil))
             (bad3 (and fn-p
                        (collect-macros names wrld))))
         (cond
          (bad1 (er soft ctx
                    "You have tried to make untouchable the ~
                     function~#0~[~/s~], ~&0.  However, ~#0~[this function ~
                     is~/these functions are~] sometimes introduced into ~
                     proofs by one or more metatheorems or clause processors ~
                     having well-formedness guarantees.   If you insist on ~
                     making ~#0~[this name~/these names~] untouchable you ~
                     must redefine the relevant metafunctions and clause ~
                     processors so they do not create terms involving ~
                     ~#0~[it~/them~] and prove and cite appropriate ~
                     :WELL-FORMEDNESS-GUARANTEE theorems.  The following data ~
                     structure may help you find the relevant events to ~
                     change.  The data structure is an alist pairing each ~
                     function name above with information about all the ~
                     metatheorems or clause processors that may introduce ~
                     that name.  The information for each metatheorem or ~
                     clause processor is the name of the correctness theorem, ~
                     the name of the metafunction or clause processor ~
                     verified by that metatheorem, the name of the ~
                     well-formedness guarantee for that metafunction or ~
                     clause processor, and analogous information about any ~
                     hypothesis metafunction involved.  All of these events ~
                     (and possibly their supporting functions and lemmas) ~
                     must be fixed so that the names you now want to be ~
                     untouchable are not produced.~%~X12"
                    (strip-cars bad1)
                    bad1
                    nil))
          (bad2 (er soft ctx
                    "You have tried to make untouchable the ~
                     function~#0~[~/s~], ~&0.  However, ~#0~[this function ~
                     has a badge~/these functions have badges~] (see :DOC ~
                     apply$).  We do not allow a badged function F to be ~
                     untouchable because (apply$ 'F (list arg1 arg2 ...)) is ~
                     still a legal term that, however, is a proxy for (F arg1 ~
                     arg2 ...)."
                    bad2))
          (bad3 (er soft ctx
                    "You have tried to make untouchable the macro~#0~[~/s~], ~
                     ~&0.  However, macros are never directly untouchable.  ~
                     To get the effect of an untouchable macro, see :DOC ~
                     defmacro-untouchable."
                    bad3))
          (t (install-event name
                            event-form
                            'push-untouchable
                            0
                            nil
                            nil
                            nil
                            nil
                            (global-set
                             untouchable-prop
                             (union-eq names (global-val untouchable-prop wrld))
                             wrld)
                            state)))))))))

(defun remove-untouchable-fn (name fn-p state event-form)

; Warning: If this event ever generates proof obligations, remove it from the
; list of exceptions in install-event just below its "Comment on irrelevance of
; skip-proofs".

  (with-ctx-summarized
   (cond ((symbolp name)
          (msg "( REMOVE-UNTOUCHABLE ~x0 ~x1)" name fn-p))
         (t "( REMOVE-UNTOUCHABLE ...)"))
   (let ((wrld (w state))
         (event-form (or event-form
                         (list 'remove-untouchable name fn-p)))
         (names (if (symbolp name) (list name) name))
         (untouchable-prop (cond (fn-p 'untouchable-fns)
                                 (t 'untouchable-vars))))
     (cond
      ((not (symbol-listp names))
       (er soft ctx
           "The argument to remove-untouchable must be either a non-nil ~
            symbol or a non-empty true list of symbols and ~x0 is neither."
           name))
      ((not (intersectp-eq names (global-val untouchable-prop wrld)))
       (stop-redundant-event ctx state))
      (t
       (let ((old-untouchable-prop (global-val untouchable-prop wrld)))
         (install-event name
                        event-form
                        'remove-untouchable
                        0
                        nil
                        nil
                        nil
                        nil
                        (global-set
                         untouchable-prop
                         (set-difference-eq old-untouchable-prop names)
                         wrld)
                        state)))))))

(defun def-body-lemmas (def-bodies lemmas)
  (cond ((endp def-bodies)
         nil)
        (t (cons (find-runed-lemma (access def-body (car def-bodies)
                                           :rune)
                                   lemmas)
                 (def-body-lemmas (cdr def-bodies) lemmas)))))

(defmacro show-bodies (fn)
  (declare (xargs :guard (or (symbolp fn)
                             (and (true-listp fn)
                                  (eql (length fn) 2)
                                  (eq (car fn) 'quote)
                                  (symbolp (cadr fn))))))
  (let ((fn (if (symbolp fn) fn (cadr fn))))
    `(let* ((wrld (w state))
            (fn (deref-macro-name ',fn (macro-aliases wrld)))
            (lemmas (def-body-lemmas
                      (getpropc fn 'def-bodies nil wrld)
                      (getpropc fn 'lemmas nil wrld))))
       (cond (lemmas
              (pprogn (fms "Definitional bodies available for ~x0, current ~
                            one listed first:~|"
                           (list (cons #\0 fn))
                           (standard-co state) state nil)
                      (print-info-for-rules
                       (info-for-lemmas lemmas t (ens-maybe-brr state) wrld)
                       (standard-co state) state)))
             (t (er soft 'show-bodies
                    "There are no definitional bodies for ~x0."
                    fn))))))

(defun set-body-fn1 (rune def-bodies acc)
  (cond ((null def-bodies) ; error
         nil)
        ((equal rune (access def-body (car def-bodies) :rune))
         (cons (car def-bodies)
               (revappend acc (cdr def-bodies))))
        (t (set-body-fn1 rune
                         (cdr def-bodies)
                         (cons (car def-bodies) acc)))))

(defun set-body-fn (fn name-or-rune state event-form)

; Warning: If this event ever generates proof obligations, remove it from the
; list of exceptions in install-event just below its "Comment on irrelevance of
; skip-proofs".

  (with-ctx-summarized
   (cond ((symbolp fn)
          (msg "( SET-BODY ~x0)" fn))
         (t "( SET-BODY ...)"))
   (let* ((wrld (w state))
          (rune (if (symbolp name-or-rune)

; We don't yet know that name-or-rune is a function symbol in the current
; world, so we do not call fn-rune-nume here.

                    (list :definition name-or-rune)
                  name-or-rune))
          (fn (and (symbolp fn)
                   (deref-macro-name fn (macro-aliases wrld))))
          (old-def-bodies
           (getpropc fn 'def-bodies nil wrld))
          (def-bodies
            (and fn
                 old-def-bodies
                 (cond ((equal rune
                               (access def-body (car old-def-bodies)
                                       :rune))
                        :redundant)
                       (t (set-body-fn1 rune old-def-bodies nil))))))
     (cond
      ((null def-bodies)
       (er soft ctx
           "No definitional body was found for function ~x0 with rune ~
            ~x1.  See :DOC set-body."
           fn rune))
      ((eq def-bodies :redundant)
       (stop-redundant-event ctx state))
      (t (install-event rune event-form 'set-body 0 nil nil nil ctx
                        (putprop fn 'def-bodies def-bodies wrld)
                        state))))))

; Section:  trace/untrace

#-acl2-loop-only
(progn

(defparameter *trace-evisc-tuple*
  nil)

(defparameter *trace-evisc-tuple-world*
  nil)

(defun trace-evisc-tuple ()
  (cond ((and *trace-evisc-tuple-world*
              (not (eq *trace-evisc-tuple-world* (w *the-live-state*))))
         (set-trace-evisc-tuple t *the-live-state*)
         *trace-evisc-tuple*)
        (t
         *trace-evisc-tuple*)))
)

(defun trace-multiplicity (name state)

; Returns nil for functions unknown to ACL2.

  (let ((stobjs-out

; Return-last cannot be traced, so it is harmless to get the stobjs-out here
; without checking if name is return-last.

         (getpropc name 'stobjs-out)))
    (and stobjs-out
         (length stobjs-out))))

#-acl2-loop-only
(defvar *trace-level* 0)

#-acl2-loop-only
(defun first-trace-printing-column ()

; This returns the first column after the trace prompt ("n> " or "<n ").

; Warning: Keep this in sync with custom-trace-ppr.

  (let ((trace-level *trace-level*))
    (cond ((< trace-level 10)
           (1+ (* 2 trace-level)))
          ((< trace-level 100)
           22)
          ((< trace-level 1000)
           23)
          ((< trace-level 10000)
           24)
          (t 25))))

#-acl2-loop-only
(defun trace-ppr (x trace-evisc-tuple msgp state)
  (fmt1 (if msgp "~@0~|" "~y0~|")
        (list (cons #\0 x))
        (if (eq msgp :fmt!)
            0
          (first-trace-printing-column))
        (f-get-global 'trace-co state)
        state
        trace-evisc-tuple))

#-acl2-loop-only
(defvar *inside-trace$* nil)

#-acl2-loop-only
(defun custom-trace-ppr (direction x &optional evisc-tuple msgp)

; NOTE: The caller for direction :in should first increment *trace-level*.
; This function, however, takes care of decrementing that state global if
; direction is not :in.

; We need to provide all the output that one expects when using a trace
; facility.  Hence the cond clause and the first argument.

; We will keep *trace-level* appropriate for printing in both directions (:in
; and :out).

; Warning: Keep this in sync with first-trace-printing-column.

  (when (eq evisc-tuple :no-print)
    (return-from custom-trace-ppr nil))
  (let ((*inside-trace$* t))
    (when (eq direction :in)
      (incf *trace-level*))
    (let ((trace-level *trace-level*)
          (*trace-output* (get-output-stream-from-channel
                           (f-get-global 'trace-co *the-live-state*))))
      (when (not (eq msgp :fmt!))
        (cond
         ((eq direction :in)

; Originally we incremented the trace level here.  But instead we wait until
; calling trace-ppr, in order to get the spacing to work out.

          (case trace-level
            (1 (princ "1> " *trace-output*))
            (2 (princ "  2> " *trace-output*))
            (3 (princ "    3> " *trace-output*))
            (4 (princ "      4> " *trace-output*))
            (5 (princ "        5> " *trace-output*))
            (6 (princ "          6> " *trace-output*))
            (7 (princ "            7> " *trace-output*))
            (8 (princ "              8> " *trace-output*))
            (9 (princ "                9> " *trace-output*))
            (t (princ (format nil "                  ~s> " trace-level)
                      *trace-output*))))
         (t
          (case trace-level
            (1 (princ "<1 " *trace-output*))
            (2 (princ "  <2 " *trace-output*))
            (3 (princ "    <3 " *trace-output*))
            (4 (princ "      <4 " *trace-output*))
            (5 (princ "        <5 " *trace-output*))
            (6 (princ "          <6 " *trace-output*))
            (7 (princ "            <7 " *trace-output*))
            (8 (princ "              <8 " *trace-output*))
            (9 (princ "                <9 " *trace-output*))
            (t (princ (format nil "                  <~s " trace-level)
                      *trace-output*))))))
      (cond ((eq evisc-tuple :print)
; We avoid using pprint since it is preceded by a newline.
             (let ((*print-pretty* t))
               (prin1 x *trace-output*))
             (terpri *trace-output*))
            (t (trace-ppr x evisc-tuple msgp *the-live-state*)))
      (when (not (eq direction :in))
        (decf *trace-level*))
      (finish-output *trace-output*))))

(defun *1*defp (trace-spec wrld)
  (let ((fn (car trace-spec)))
    (not (eq (getpropc fn 'formals t wrld)
             t))))

(defun trace$-er-msg (fn)
  (msg "Ignoring request to trace function ~x0, because"
       fn))

(defun decls-and-doc (forms)
  (cond ((endp forms)
         nil)
        ((or (stringp (car forms))
             (and (consp (car forms))
                  (eq (caar forms) 'declare)))
         (cons (car forms)
               (decls-and-doc (cdr forms))))
        (t nil)))

(defun trace$-when-gcond (gcond form)
  (if gcond
      `(when ,gcond ,form)
    form))

(defun evisceration-stobj-mark-simple (name)

; Warning: Keep this in sync with evisceration-stobj-mark.

; This version of evisceration-stobj-mark assumes that name is a stobj name and
; not :DF.

  (cond
   ((eq name 'STATE)
    *evisceration-state-mark*)
   (t
    (cons *evisceration-mark* (stobj-print-name name)))))

(defun stobj-evisceration-alist (user-stobj-alist state)
  (cond ((endp user-stobj-alist)
         (list (cons (coerce-state-to-object state)
                     *evisceration-state-mark*)))
        (t (cons (cons (cdar user-stobj-alist)
                       (evisceration-stobj-mark-simple (caar user-stobj-alist)))
                 (stobj-evisceration-alist (cdr user-stobj-alist) state)))))

(defun trace-evisceration-alist (state)
  (append (world-evisceration-alist state nil)
          (stobj-evisceration-alist (user-stobj-alist state) state)))

(defun set-trace-evisc-tuple (val state)
  #+acl2-loop-only
  (declare (ignore val))
  #-acl2-loop-only
  (cond ((null val)
         (setq *trace-evisc-tuple-world* nil)
         (setq *trace-evisc-tuple* nil))
        ((eq val t)
         (setq *trace-evisc-tuple-world*
               (w *the-live-state*))
         (setq *trace-evisc-tuple*
               (list (trace-evisceration-alist *the-live-state*)
                     *print-level*
                     *print-length*
                     nil)))
        ((standard-evisc-tuplep val)
         (setq *trace-evisc-tuple-world* nil)
         (setq *trace-evisc-tuple* val))
        (t (er hard 'set-trace-evisc-tuple
               "Illegal evisc tuple, ~x0"
               val)))
  state)

; The following functions, through print-brr-status, are useful for debugging
; break-rewrite.  Prettyify-brr-status converts a brr-status record into a
; readable term and, if the hide-stuff-flg is t, will elide the often very
; large rcnst (by replacing it with |some-rewrite-constant|), elide all the
; numes (by replacing them with |some-nume|), and elide the saved-standard-oi
; field.  The reason for the latter two is illustrated by the run-script book
; books/demos/brr-test-input.lsp.  That book uses print-brr-status (which uses
; prettyify-brr-status) to display the status at various points in a
; break-rewrite session and the brr-test-log.txt file records the right
; answers.  But as we add new functions to the ACL2 sources the numes
; associated with rewrite rules change and the book fails to re-certify because
; the "right" answers have the newly wrong numes in them; also, the value of
; saved-standard-oi is dependent on the filesystem.

(defun hide-nume-in-rewrite-or-linear-rule (lemma)
  (cond
   ((eq (record-type lemma) 'rewrite-rule)
    (change rewrite-rule
            lemma
            :nume '|some-nume|))
   ((eq (record-type lemma) 'linear-lemma)
    (change linear-lemma
            lemma
            :nume '|some-nume|))
   (t lemma)))

(defun prettyify-brr-gstack-frame (frame)

; Keep this in sync with the cw-gframe vis-a-vis the shapes of each possible
; frame.  Observe that push-gframe actually uses :args `(list* ,@args) to save
; a cons at the end, i.e., args may be (a b c) but in the frame they're (a b
; . c).

  (case (access gframe frame :sys-fn)
    ((rewrite-with-lemma
      rewrite-quoted-constant-with-lemma)
     (let* ((args (access gframe frame :args))
            (lemma (cadr args))
            (geneqv (cddr args)))
       (change gframe frame
               :args
               (list* (car args)
                      (hide-nume-in-rewrite-or-linear-rule lemma)
                      geneqv))))
    (add-linear-lemma
     (let* ((args (access gframe frame :args))
            (lemma (cdr args)))
       (change gframe frame
               :args
               (cons (car args)
                     (hide-nume-in-rewrite-or-linear-rule lemma)))))
    (otherwise frame)))

(defun prettyify-brr-gstack (gstack)
  (cond
   ((endp gstack) nil)
   (t (cons (prettyify-brr-gstack-frame (car gstack))
            (prettyify-brr-gstack (cdr gstack))))))

(defun prettyify-brr-status (hide-stuff-flg status)
  (cond
   ((null status) nil)
   (t `(make brr-status
             :entry-code
             ',(access brr-status status :entry-code)
             :brr-monitored-runes
             ',(access brr-status status :brr-monitored-runes)
             :brr-gstack
             ',(prettyify-brr-gstack (access brr-status status :brr-gstack))
             :brr-local-alist
             ',(let* ((alist0 (access brr-status status :brr-local-alist))
                      (alist1 (cond
                               ((and hide-stuff-flg
                                     (assoc-eq 'rcnst alist0))
                                (put-assoc-eq 'rcnst '|some-rewrite-constant|
                                              alist0))
                               (t alist0)))
                      (alist2 (cond
                               ((and hide-stuff-flg
                                     (assoc-eq 'lemma alist1))
                                (let ((lemma (cdr (assoc-eq 'lemma alist1))))
                                  (put-assoc-eq
                                   'lemma
                                   (hide-nume-in-rewrite-or-linear-rule lemma)
                                   alist1)))
                               (t alist1)))
                      (alist3 (cond
                               ((and hide-stuff-flg
                                     (assoc-eq 'saved-standard-oi alist2))
                                (put-assoc-eq 'saved-standard-oi
                                              '|some-channel|
                                              alist2))
                               (t alist2))))
                 alist3)
             :brr-previous-status
             ,(prettyify-brr-status
               hide-stuff-flg
               (access brr-status status :brr-previous-status))))))

(defun print-brr-status (hide-rcnst-flg)
  #+acl2-loop-only (declare (ignore hide-rcnst-flg))
  #-acl2-loop-only
  (cw "~X01"
      (prettyify-brr-status
       hide-rcnst-flg
       (cdr (assoc-eq 'brr *wormhole-status-alist*)))
      nil)

  nil)

(defun chk-trace-options-aux (form kwd formals ctx wrld state)

; Check that the indicated form returns a single, non-stobj value, and that
; term has no unexpected free variables.

  (er-let* ((term (translate form '(nil) nil '(state) ctx wrld state)))
           (let ((vars (set-difference-eq
                        (all-vars term)
                        (append (case kwd
                                  ((:entry :cond)
                                   '(traced-fn trace-level arglist state))
                                  (:exit
                                   '(traced-fn trace-level arglist value values
                                               state))
                                  (:hide
                                   nil)
                                  (otherwise
                                   '(state)))
                                formals))))
             (cond (vars
                    (er soft ctx
                        "Global variables, such as ~&0, are not allowed for ~
                         tracing option ~x1, especially without a trust tag.  ~
                         See :DOC trace$."
                        (reverse vars)
                        kwd))
                   (t (value nil))))))

(defun trace$-value-msgp (x kwd)
  (and (consp x)
       (keywordp (car x))
       (or (and (member-eq (car x) '(:fmt :fmt!))
                (consp (cdr x))
                (null (cddr x)))
           (er hard 'trace$
               "Illegal ~x0 value.  A legal ~x0 value starting with a ~
                keyword must be of the form (:FMT x).  The ~x0 value ~x1 ~
                is therefore illegal."
               kwd x))
       (car x)))

(defun chk-trace-options (fn predefined trace-options formals ctx wrld state)
  (let ((notinline-tail (assoc-keyword :notinline trace-options))
        (multiplicity-tail (assoc-keyword :multiplicity trace-options)))
    (cond
     ((and notinline-tail
           (not (member-eq (cadr notinline-tail)
                           '(t nil :fncall))))

; We are tempted to use a hard error here so that we don't see the message
; about trace! printed by trace$-fn-general.  But then instead we see a message
; suggesting the use of trace, which is very odd here, since we are trying to
; trace!  So we'll just live with seeing a not very helpful message about
; trace!.

      (er soft ctx
          "The only legal values for trace option :NOTINLINE are ~&0.  The ~
           value ~x1 is thus illegal."
          '(t nil :fncall)
          (cadr notinline-tail)))
     ((and multiplicity-tail
           (not (natp (cadr multiplicity-tail))))
      (er soft ctx
          "The value of trace option :MULTIPLICITY must be a non-negative ~
           integer value.  The value ~x0 is thus illegal."
          (cadr multiplicity-tail)))
     ((and predefined
           (or (eq fn 'return-last)
               (and notinline-tail
                    (not (eq (cadr notinline-tail) :fncall))
                    (or (member-eq fn (f-get-global 'program-fns-with-raw-code
                                                    state))
                        (member-eq fn (f-get-global 'logic-fns-with-raw-code
                                                    state))
                        (not (ttag wrld))))))
      (cond
       ((eq fn 'return-last)
        (er soft ctx
            "Due to its special nature, tracing of ~x0 is not allowed."
            fn))
       ((or (member-eq fn (f-get-global 'program-fns-with-raw-code
                                        state))
            (member-eq fn (f-get-global 'logic-fns-with-raw-code
                                        state)))

; We could probably just arrange not to trace the *1* function in this case.
; But for now we'll cause an error.

        (er soft ctx
            "The ACL2 built-in function ~x0 has special code that will not be ~
             captured properly when creating code for its traced executable ~
             counterpart.  It is therefore illegal to specify a value for ~
             :NOTINLINE other than :FNCALL unless there is an active trust ~
             tag.  There may be an easy fix, so contact the ACL2 implementors ~
             if this error presents a hardship."
            fn))
       (t
        (er soft ctx
            "The function ~x0 is built into ACL2.  It is therefore illegal to ~
             specify a value for :NOTINLINE other than :FNCALL unless there ~
             is an active trust tag."
            fn))))
     ((ttag wrld)
      (value nil))
     (t
      (let* ((cond-tail (assoc-keyword :cond  trace-options))
             (entry-tail (assoc-keyword :entry trace-options))
             (exit-tail (assoc-keyword :exit trace-options))
             (evisc-tuple-tail (assoc-keyword :evisc-tuple trace-options)))
        (er-progn
         (if cond-tail
             (chk-trace-options-aux
              (cadr cond-tail) :cond formals ctx wrld state)
           (value nil))
         (if entry-tail
             (chk-trace-options-aux
              (if (trace$-value-msgp (cadr entry-tail) :entry)
                  (cadr (cadr entry-tail))
                (cadr entry-tail))
              :entry formals ctx wrld state)
           (value nil))
         (if exit-tail
             (chk-trace-options-aux
              (if (trace$-value-msgp (cadr exit-tail) :exit)
                  (cadr (cadr exit-tail))
                (cadr exit-tail))
              :exit formals ctx wrld state)
           (value nil))
         (if (and evisc-tuple-tail
                  (not (member-eq (cadr evisc-tuple-tail)
                                  '(:print :no-print))))
             (chk-trace-options-aux
              (cadr evisc-tuple-tail) :evisc-tuple formals ctx wrld state)
           (value nil))))))))

(defun memoize-off-trace-error (fn ctx)
  (er hard ctx
      "Memoized function ~x0 is to be traced or untraced, but its ~
       symbol-function differs from the :MEMOIZED-FN field of its memoization ~
       hash-table entry.  Perhaps the trace or untrace request occurred in ~
       the context of ~x1; at any rate, it is illegal."
      fn ctx))

(defun untrace$-fn1 (fn state)
  #-acl2-loop-only
  (let* ((old-fn (get fn 'acl2-trace-saved-fn))
         (*1*fn (*1*-symbol? fn))
         (old-*1*fn (get *1*fn 'acl2-trace-saved-fn))
         (memo-entry (memoizedp-raw fn)))
    (when (and memo-entry
               (not (eq (symbol-function fn)
                        (access memoize-info-ht-entry memo-entry
                                :memoized-fn))))

; See comment about this "strange state of affairs" in trace$-def.

      (memoize-off-trace-error fn 'untrace$))

; We do a raw Lisp untrace in case we traced with :native.  We use eval here
; because at the time we evaluate this definition, untrace might not yet have
; been modified (e.g., by allegro-acl2-trace.lisp).

    (eval `(maybe-untrace ,fn))
    (when old-fn
; Warning: Do not print an error or warning here.  See the comment about
; "silent no-op" below and in trace$-fn-general.
      (setf (symbol-function fn)
            old-fn)
      (when memo-entry
        (setf (gethash fn *memoize-info-ht*)
              (change memoize-info-ht-entry memo-entry
                      :memoized-fn old-fn)))
      (setf (get fn 'acl2-trace-saved-fn)
            nil))
    (when old-*1*fn
; Warning: Do not print an error or warning here.  See the comment about
; "silent no-op" below and in trace$-fn-general.
      (setf (symbol-function *1*fn)
            old-*1*fn)
      (setf (get *1*fn 'acl2-trace-saved-fn)
            nil)))

; If we interrupt before completing update of the global below, then we may leave a
; trace-spec in that global even though the function is partially or totally
; untraced in the sense of the two forms above.  That's perfectly OK, however,
; because if the function is not actually traced then the corresponding WHEN
; form above will be a silent no-op.

  (f-put-global 'trace-specs
                (remove1-assoc-eq fn (f-get-global 'trace-specs state))
                state))

(defun untrace$-rec (fns ctx state)
  (cond
   ((endp fns)
    (value nil))
   (t
    (let ((trace-spec
           (assoc-eq (car fns) (f-get-global 'trace-specs state))))
      (cond
       (trace-spec
        (pprogn (untrace$-fn1 (car fns) state)
                (er-let* ((fnlist (untrace$-rec (cdr fns) ctx state)))
                         (value (cons (car fns) fnlist)))))
       (t (pprogn
           (warning$ ctx "Trace"
                     "The function ~x0 is not currently traced.  Ignoring ~
                      attempt to apply untrace$ to it."
                     (car fns))
           (untrace$-rec (cdr fns) ctx state))))))))

(defun untrace$-fn (fns state)
  (let ((ctx 'untrace$))
    (cond ((null fns)
           (untrace$-rec (strip-cars (f-get-global 'trace-specs state)) ctx
                         state))
          ((symbol-listp fns)
           (untrace$-rec fns ctx state))
          (t (er soft ctx
              "Untrace$ may only be applied to a list of symbols, hence not ~
               to the list ~x0."
              fns)))))

(defun maybe-untrace$-fn (fn state)
  (prog2$ (or (symbolp fn)
              (er hard 'untrace$
                  "Illegal attempt to untrace non-symbol: ~x0"
                  fn))
          (if (assoc-eq fn (f-get-global 'trace-specs state))
              (untrace$-fn1 fn state)
            state)))

(defmacro maybe-untrace$ (fn)
  `(maybe-untrace$-fn ',fn state))

#-acl2-loop-only
(defmacro maybe-untrace (fn)

; We use eval here because at the time we evaluate this definition, untrace
; might not yet have been modified (e.g., by allegro-acl2-trace.lisp).

  `(when (member-eq ',fn (trace))
     (eval '(untrace ,fn))
     t))

#-acl2-loop-only
(defun maybe-untrace! (fn &optional verbose)

; WART: Calling this in raw Lisp changes the state without an in-the-logic
; explanation, because it modifies state global variable 'trace-specs.
; Consider using the oracle of the state within the logic to explain this
; wart.

; Inline maybe-untrace$-fn:

  (let ((state *the-live-state*))
    (when (assoc-eq fn (f-get-global 'trace-specs state))
      (untrace$-fn1 fn state)
      (when verbose
        (observation "untracing"
                     "Untracing ~x0."
                     fn)))
    (when (and (eval `(maybe-untrace ,fn))
               verbose)
      (observation "untracing"
                   "Raw-Lisp untracing ~x0."
                   fn))
    nil))

#-acl2-loop-only
(defun trace$-def (arglist def trace-options predefined multiplicity ctx)
  (let* ((state-bound-p (member-eq 'state arglist))
         (fn (car def))
         (cond-tail (assoc-keyword :cond trace-options))
         (cond (cadr cond-tail))
         (cond (oneify cond nil (w *the-live-state*) nil))
         (hide-tail (assoc-keyword :hide trace-options))
         (hide (or (null hide-tail) ; default is t
                   (cadr hide-tail)))
         (entry (or (cadr (assoc-keyword :entry trace-options))
                    (list 'cons (kwote fn) 'arglist)))
         (entry-msgp (trace$-value-msgp entry :entry))
         (entry (if entry-msgp (cadr entry) entry))
         (entry (oneify entry nil (w *the-live-state*) nil))
         (exit  (or (cadr (assoc-keyword :exit  trace-options))
                    (list 'cons (kwote fn) 'values)))
         (exit-msgp (trace$-value-msgp exit :exit))
         (exit (if exit-msgp (cadr exit) exit))
         (exit (oneify exit nil (w *the-live-state*) nil))
         (notinline-tail (assoc-keyword :notinline trace-options))
         (notinline-nil (and notinline-tail
                             (null (cadr notinline-tail))))
         (memo-entry (memoizedp-raw fn))
         (notinline-fncall
          (cond (notinline-tail
                 (or (eq (cadr notinline-tail) :fncall)
                     (and memo-entry
                          (er hard ctx
                              "It is illegal to specify a value for ~
                                      trace$ option :NOTINLINE other than ~
                                      :FNCALL for a memoized function.  The ~
                                      suggested trace spec for ~x0, which ~
                                      specifies :NOTINLINE ~x0, is thus ~
                                      illegal."
                              fn
                              (cadr notinline-tail)))))
                (memo-entry

; Memoization installs its own symbol-function for fn, so we do not want to
; insert the body of fn into the traced definition; instead, we want to call
; the traced version of fn to call the "old" (memoized) fn.  Note that we
; always remove any trace when memoizing or unmemoizing, so we don't have the
; symmetric problem of figuring out how to make a memoized function call a
; traced function.

                 t)
                ((or (not def) ; then no choice in the matter!
                     predefined
                     (member-eq fn (f-get-global 'program-fns-with-raw-code
                                                 *the-live-state*))
                     (member-eq fn (f-get-global 'logic-fns-with-raw-code
                                                 *the-live-state*)))
                 t)
                (t nil)))
         (gcond (and cond-tail (acl2-gentemp "COND")))
         (garglist (acl2-gentemp "ARGLIST"))
         (evisc-tuple-tail (assoc-keyword :evisc-tuple trace-options))
         (evisc-tuple (if evisc-tuple-tail
                          (cadr evisc-tuple-tail)
                        '(trace-evisc-tuple)))
         (gevisc-tuple (and evisc-tuple-tail (acl2-gentemp "EVISC-TUPLE")))
         (decls-and-doc (and def ; optimization
                             (decls-and-doc (cddr def))))
         (body (and def ; optimization
                    (nthcdr (length decls-and-doc) (cddr def))))
         (new-body (if notinline-fncall
                       `(funcall (get ',fn 'acl2-trace-saved-fn)
                                 ,@arglist)
                     `(block ,fn (progn ,@body)))))
    (when (and memo-entry
               (not (eq (symbol-function fn)
                        (access memoize-info-ht-entry memo-entry
                                :memoized-fn))))

; This is a strange state of affairs that we prefer not to try to support.  For
; example, it is not clear how things would work out after we installed the
; traced symbol-function as the :memoized-fn.

      (memoize-off-trace-error fn ctx))
    `(defun ,fn
       ,(if state-bound-p
            arglist
          (append arglist '(&aux (state *the-live-state*))))
       ,@(if state-bound-p
             nil
           '((declare (ignorable state))))

; At one time we included declarations and documentation here:
;      ,@(and (not notinline-fncall) ; else just lay down fncall; skip decls
;             decls-and-doc)
; But then we saw compiler warnings, for example:
; (defun foo (x y) (declare (ignore x)) y)
; (trace$ (foo :compile t))
; could give:
;   ; While compiling FOO:
;   Warning: variable X is used yet it was declared ignored
; When tracing, it seems needless to install documentation or to keep
; declarations (as tracing can't be expected to be fast), so we keep things
; simple and just throw away the declarations and documentation.  Notice that
; because of ,@arglist below, none of the formals is ignored.

       ,@(and (not notinline-nil)
              `((declare (notinline ,fn))))
       ,@(and predefined
              `((when *inside-trace$*
                  (return-from ,fn
                    (funcall (get ',fn 'acl2-trace-saved-fn)
                             ,@arglist)))))
       (let ((,garglist (list ,@arglist))
             ,@(and gevisc-tuple
                    `((,gevisc-tuple ,evisc-tuple))))
         (let ,(and gcond
                    `((,gcond (let ((arglist ,garglist)
                                    (traced-fn ',fn)
                                    (trace-level ,*trace-level*))
                                (declare
                                 (ignorable traced-fn trace-level arglist))
                                ,cond))))
           ,(trace$-when-gcond
             gcond
             `(let ((arglist ,garglist)
                    (traced-fn ',fn)
                    (trace-level *trace-level*))
                (declare (ignorable traced-fn trace-level arglist))
                (custom-trace-ppr :in
                                  ,(if hide
                                       `(trace-hide-world-and-state
                                         ,entry
                                         ,(eq evisc-tuple :print))
                                     entry)
                                  ,(or gevisc-tuple evisc-tuple)
                                  ,entry-msgp)))
           (let* ((values

; The use of block below is critical for *1* functions, so that a return-from
; doesn't pass control all the way out and we can exit the remaining call of
; custom-trace-ppr below.  It is unnecessary for user-defined ACL2 functions,
; but is presumably harmless.

; Also note that it is important that ARGLIST, TRACED-FN, and TRACE-LEVEL be
; bound in the right order.  For example, if we bind ARGLIST before VALUES but
; ARGLIST is a formal, then a reference to ARGLIST in new-body will be a
; reference to the entire arglist instead of what it should be: a reference to
; the formal parameter, ARGLIST.

                   (multiple-value-list ,new-body))

; Warning: It may be tempting to eliminate value, since it is not used below.
; But we deliberately generate a binding of value here so that users can refer
; to it in their :exit conditions (see :DOC trace$).

                  (value ,(if (eql multiplicity 1)
                              '(car values)
                            'values))
                  (arglist ,garglist)
                  (traced-fn ',fn)
                  (trace-level *trace-level*))
             (declare (ignorable value values traced-fn trace-level arglist))
             ,(trace$-when-gcond
               gcond
               `(custom-trace-ppr :out
                                  ,(if hide
                                       `(trace-hide-world-and-state
                                         ,exit
                                         ,(eq evisc-tuple :print))
                                     exit)
                                  ,(or gevisc-tuple evisc-tuple)
                                  ,exit-msgp))
             (values-list values)))))))

#-acl2-loop-only
(defun trace$-install (fn formals def trace-options predefined multiplicity
                          ctx)

; We redefine the given function after saving the existing symbol-function.
; Note that fn can be a function defined in the ACL2 loop, or the *1* function
; of such, or a function defined directly in raw Lisp.

  (when (get fn 'acl2-trace-saved-fn)
    (er hard ctx
        "Implementation error: attempted to call trace$-install on a ~
         function, ~x0, that already has a saved 'acl2-trace-saved-fn ~
         property."
        fn))
  (let* ((compile-tail (assoc-keyword :compile trace-options))
         (compile-option (cadr compile-tail))
         (do-compile (cond ((or (null compile-tail)
                                (eq compile-option :same))
                            (compiled-function-p! fn))
                           (t compile-option))))
    (setf (get fn 'acl2-trace-saved-fn)
          (symbol-function fn))
    (eval (trace$-def formals def trace-options predefined multiplicity ctx))
    (let ((memo-entry (memoizedp-raw fn)))
      (when memo-entry
        (setf (gethash fn *memoize-info-ht*)
              (change memoize-info-ht-entry memo-entry
                      :memoized-fn (symbol-function fn)))))
    (when do-compile
      (compile fn))))

#-acl2-loop-only
(defun oneified-def (fn wrld &optional trace-rec-for-none)
  (let* ((stobj-function (getpropc fn 'stobj-function nil wrld))
         (form (cltl-def-from-name1 fn stobj-function t wrld)))
    (oneify-cltl-code
     (cond ((or (getpropc fn 'constrainedp nil wrld)
                (getpropc fn 'non-executablep nil wrld))
            nil)
           ((eq (symbol-class fn wrld) :program)
            :program) ; see oneify-cltl-code
           (t :logic))
     (cdr form)
     stobj-function
     wrld
     trace-rec-for-none)))

(defun trace$-fn-general (trace-spec ctx state)
  (let* ((fn (car trace-spec))
         (trace-options (cdr trace-spec))
         (native (cadr (assoc-keyword :native trace-options)))
         (wrld (w state))
         (stobj-function
          (and (not (assoc-keyword :def trace-options)) ; optimization
               (getpropc fn 'stobj-function nil wrld)))
         #-acl2-loop-only (*inside-trace$* t)
         (def (or (cadr (assoc-keyword :def trace-options))
                  (let ((defun+def
                          (cltl-def-from-name1 fn stobj-function nil wrld)))
                    (cond (defun+def (cdr defun+def))
                          ((and stobj-function
                                (cltl-def-from-name1 fn stobj-function t wrld))
                           :macro)
                          (t nil)))
                  (and (getpropc fn 'constrainedp nil wrld)
                       (let ((formals (getpropc fn 'formals t wrld)))
                         (assert$ (not (eq formals t))
                                  (list fn
                                        formals
                                        (null-body-er fn formals t)))))))
         (formals-tail (assoc-keyword :formals trace-options))
         (formals-default (and (not formals-tail)
                               (atom def)
                               (not native) ; else formals doesn't much matter
                               (getpropc fn 'formals t wrld)))
         (formals (cond (formals-tail (cadr formals-tail))
                        ((consp def) (cadr def))
                        (t formals-default)))
         (evisc-tuple (cadr (assoc-keyword :evisc-tuple trace-options)))
         (compile (cadr (assoc-keyword :compile trace-options)))
         (predefined ; (acl2-system-namep fn wrld)
          (getpropc fn 'predefined nil wrld)))
    (cond
     ((eq def :macro)
      (assert$
       stobj-function
       (cond
        ((getpropc stobj-function 'absstobj-info nil wrld)
         (er very-soft ctx
             "~x0 cannot be traced, because it is a macro in raw Lisp, ~
              introduced with the defabsstobj event for abstract stobj ~x1."
             fn
             stobj-function))
        (t
         (er very-soft ctx
             "~x0 cannot be traced, because it is a macro in raw Lisp: its ~
              introducing defstobj event (for stobj ~x1) was supplied with ~
              :INLINE T."
             fn
             stobj-function)))))
     ((eq formals-default t)
      (cond ((getpropc fn 'macro-body nil wrld)
             (er very-soft ctx
                 "~x0 is an ACL2 macro, hence cannot be traced in ACL2.~@1"
                 fn
                 (let ((sym (deref-macro-name fn (macro-aliases wrld))))
                   (cond ((eq sym fn) "")
                         (t (msg "  Perhaps you meant instead to trace the ~
                                  corresponding function, ~x0."
                                 sym))))))
            (t
             (er very-soft ctx
                 "~@0 this symbol does not have an ACL2 function definition.  ~
                  Consider using option :native, :def, or :formals.  See :DOC ~
                  trace$."
                 (trace$-er-msg fn)))))
     ((and def
           (not (equal (cadr def) formals)))
      (er very-soft ctx
          "~@0 the formals list, ~x1, does not match the definition's formals ~
           ~x2."
          (trace$-er-msg fn)
          formals
          (cadr def)))
     ((not (symbol-listp formals))
      (er very-soft ctx
          "~@0 the provided formals is not a true list of symbols."
          (trace$-er-msg fn)))
     ((and (keywordp evisc-tuple)
           (not (member-eq evisc-tuple '(:print :no-print))))
      (er very-soft ctx
          "~@0 the only legal keyword values for option :evisc-tuple are ~
           :print and :no-print."
          (trace$-er-msg fn)))
     ((member-eq fn '(wormhole-eval))
      (er very-soft ctx
          "~@0 it is illegal (for ACL2 implementation reasons) to trace ~x1."
          (trace$-er-msg fn)
          fn))
     ((and (not native)
           (equal (symbol-package-name fn) *main-lisp-package-name*))
      (er very-soft ctx
          "~@0 the ACL2 trace$ utility must be used with option :native for ~
           function symbols in the main Lisp package, ~x1.  See :DOC trace$."
          (trace$-er-msg fn)
          *main-lisp-package-name*))
     ((and compile native)
      (er very-soft ctx
          "~@0 we do not support compilation in trace specs (via keyword ~
           :compile) when :native is present, as in trace spec ~x1.  Consider ~
           removing :compile and performing compilation separately."
          (trace$-er-msg fn)
          trace-spec))
     (t
      (mv-let
       (erp val state)
       (chk-trace-options fn predefined trace-options formals ctx wrld state)
       (declare (ignore val))
       (if erp
           (if (or (ttag wrld)
                   (eq fn 'return-last))
               (value nil)
             (er very-soft ctx
                 "It is possible that you can use TRACE! to avoid the above ~
                  error (but consider that only with great care!).  See :DOC ~
                  trace!."))
         (let* ((state ; this handles *1* function if appropriate
                 (maybe-untrace$-fn fn state))
                (new-trace-specs
                 (cons trace-spec (f-get-global 'trace-specs state))))
           (cond
            ((and (not native) (null def))
             (er very-soft ctx
                 "ACL2 found no definition for ~x0.  Consider supplying the ~
                  :def trace option.  See :DOC trace$."
                 fn))
            (t
             (pprogn

; We update the value of 'trace-specs before modifying symbol-functions, since
; if we reverse the order then it is possible that we would interrupt between
; compilation of the raw Lisp and *1* function, after which (untrace$) would
; not untrace the raw Lisp function.  Note that untrace$ is a silent no-op if
; 'trace-specs has entries that are not truly traced -- see untrace$-fn1 -- so
; better that 'trace-specs have a value that is too large than too small.

              (f-put-global 'trace-specs new-trace-specs state)
              (cond
               (native
                #-acl2-loop-only
                (let* ((trace-options-1
                        (remove-keyword :multiplicity
                                        (remove-keyword :native
                                                        trace-options)))
                       (new-trace-options
                        (pprogn (when (assoc-keyword :multiplicity
                                                     trace-options)
                                  (let ((state *the-live-state*))
                                    (with-output
                                      :on (warning)
                                      (warning$ ctx "Trace"
                                                "The :multiplicity option of ~
                                                 trace$ has no effect in this ~
                                                 Lisp.  Only one value will ~
                                                 be passed to trace printing ~
                                                 by function ~x0."
                                                fn))))
                                trace-options-1)))
                  (if new-trace-options
                      (eval `(trace (,fn ,@new-trace-options)))
                    (eval `(trace ,fn))))
                (value trace-spec))
               (t
                #-acl2-loop-only
                (let ((multiplicity (or (cadr (assoc-keyword :multiplicity
                                                             trace-options))
                                        (trace-multiplicity fn state))))
                  (assert$
                   multiplicity
                   (trace$-install fn formals def trace-options predefined
                                   multiplicity ctx))
                  (when (*1*defp trace-spec wrld)
                    (trace$-install (*1*-symbol fn) formals
                                    (oneified-def fn wrld t)
                                    trace-options predefined multiplicity
                                    ctx)))
                (value trace-spec)))))))))))))

(defun trace$-fn-simple (trace-spec ctx state)
  (trace$-fn-general (list trace-spec) ctx state))

(defconst *trace-keywords*

; WARNING: If you add a keyword here, consider also adding it to
; *trace-keywords-needing-ttag*.

  '(:cond :entry :exit
          :compile :def :multiplicity :evisc-tuple :formals :hide :native
          :notinline))

(defconst *trace-keywords-needing-ttag*

; We omit options here that can need a trust tag, such as :entry with a term
; that does not translate, as these are managed in chk-trace-options.

  '(:native :def :multiplicity))

(defun first-assoc-keyword (keys x)
  (declare (xargs :guard (and (keyword-value-listp x)
                              (keyword-listp keys))))
  (cond ((endp keys)
         nil)
        (t (or (assoc-keyword (car keys) x)
               (first-assoc-keyword (cdr keys) x)))))

(defconst *illegal-trace-spec-fmt-string*
  "A trace spec must be a symbol or a symbol consed onto an alternating list ~
   of the form (:kwd1 val1 :kwd2 val2 ...).  The trace spec ~x0 is thus ~
   illegal.  See :DOC trace$.")

(defun trace$-fn (trace-spec ctx state)
  (cond ((symbolp trace-spec)
         (trace$-fn-simple trace-spec ctx state))
        ((and (consp trace-spec)
              (symbolp (car trace-spec))
              (keyword-value-listp (cdr trace-spec)))
         (cond ((and (not (assoc-keyword :native (cdr trace-spec)))
                     (strip-keyword-list *trace-keywords* (cdr trace-spec)))
                (let ((bad-keywords
                       (evens (strip-keyword-list *trace-keywords*
                                                  (cdr trace-spec)))))
                  (er very-soft ctx
                      "The keyword~#0~[~/s~] ~&0 ~#0~[is~/are~] illegal for ~
                       trace specs.  See :DOC trace."
                      bad-keywords)))
               ((and (not (f-get-global 'retrace-p state))
                     (first-assoc-keyword *trace-keywords-needing-ttag*
                                          (cdr trace-spec))
                     (not (ttag (w state))))
                (er very-soft ctx
                    "The keyword ~x0 cannot be used in a trace spec unless ~
                     there is an active trust tag.  The trace spec ~x1 is ~
                     thus illegal.  Consider using trace! instead.  The ~
                     complete list of keywords that require a trust tag for ~
                     use in a trace spec is: ~x2."
                    (car (first-assoc-keyword *trace-keywords-needing-ttag*
                                              (cdr trace-spec)))
                    trace-spec
                    *trace-keywords-needing-ttag*))
               (t (trace$-fn-general trace-spec ctx state))))
        (t (er very-soft ctx
               *illegal-trace-spec-fmt-string*
               trace-spec))))

(defun trace$-lst (trace-spec-lst ctx state)
  (cond
   ((endp trace-spec-lst)
    (value nil))
   (t
    (er-let* ((tspec (trace$-fn (car trace-spec-lst) ctx state))
              (tspecs (trace$-lst (cdr trace-spec-lst) ctx state)))
             (value (if tspec
                        (cons tspec tspecs)
                      tspecs))))))

(defmacro trace$ (&rest trace-specs)
  (cond
   ((null trace-specs)
    '(value (f-get-global 'trace-specs state)))
   (t
    `(pprogn
      (if (equal (f-get-global 'trace-co state) *standard-co*)
          state
        (fms "**NOTE**: Trace output will continue to go to a file.~|~%"
             nil *standard-co* state nil))
      (if (eql 0 (f-get-global 'ld-level state))
          (ld '((trace$-lst ',trace-specs 'trace$ state))
              :ld-verbose nil

; Do we want to allow this macro to be called inside code?  There's no obvious
; reason why not.  So we need to specify the following keyword.

              :ld-user-stobjs-modified-warning :same)
        (trace$-lst ',trace-specs 'trace$ state))))))

(defmacro with-ubt! (form)
  (let ((label 'with-ubt!-label))
    `(er-progn (with-output
                :stack :push
                :off :all
                (ld '((deflabel ,label)
                      (with-output :stack :pop
                                   ,form)
                      (ubt! ',label))
                    :ld-verbose nil
                    :ld-prompt nil
                    :ld-pre-eval-print nil
                    :ld-post-eval-print nil
                    :ld-error-action :error

; Do we want to allow this macro to be called inside code?  There's no obvious
; reason why not.  So we need to specify the following keyword.

                    :ld-user-stobjs-modified-warning :same))
               (value :invisible))))

(defmacro trace! (&rest fns)
  (let ((form
         `(with-ubt!
           (with-output
            :off :all
            (with-output
             :on (error warning warning!)
             (make-event
              (progn (defttag :trace!)
                     (progn! (er-let* ((specs (trace$ ,@fns)))
                                      (value (list 'value-triple
                                                   (kwote specs))))))))))))
    #-acl2-loop-only

; We use ld so that this can work in raw Lisp.  We allow a different
; macroexpansion in raw Lisp because we know that no function will ever call
; this macro, since with-output is prohibited inside code.  With this raw Lisp
; code, one can call trace! in raw Lisp, which is handy for example when
; calling break-on-error.  Of course, no trust tag note will be printed in raw
; Lisp -- but all bets are off anyhow in raw Lisp!

    `(ld '(,form)

; Do we want to allow this macro to be called inside code?  There's no obvious
; reason why not.  So we need to specify the following keyword.

         :ld-user-stobjs-modified-warning :same)
    #+acl2-loop-only
    form))

(defmacro untrace$ (&rest fns)
  `(untrace$-fn ',fns state))

(defun open-trace-file-fn (filename state)

; Logically, this function opens a channel to the given file.  But there is no
; logical accounting for subsequent writes to that channel on behalf of
; tracing.  We view those subsequent writes as being to the file, but not the
; channel, in analogy to how cw prints to the screen but does not modify the
; contents of *standard-co*.

  (mv-let (chan state)
          (open-output-channel filename :character state)
          (cond
           (chan #-acl2-loop-only
                 (setq *trace-output*
                       (get-output-stream-from-channel chan))
                 (pprogn
                  (if (equal (f-get-global 'trace-co state) *standard-co*)
                      state
                    (close-output-channel (f-get-global 'trace-co state)
                                          state))
                  (f-put-global 'trace-co chan state)))
           (t (prog2$
               (er hard 'open-trace-file
                   "Unable to open file ~s0 for trace output."
                   filename)
               state)))))

(defmacro open-trace-file (filename)
  (declare (xargs :guard (stringp filename)))
  `(pprogn (close-trace-file-fn t state)
           (open-trace-file-fn ,filename state)))

(defun close-trace-file-fn (quiet-p state)
  #-acl2-loop-only
  (setq *trace-output* (get-output-stream-from-channel *standard-co*))
  (if (equal (f-get-global 'trace-co state) *standard-co*)
      (if quiet-p
          state
        (prog2$
         (er hard 'close-trace-file
             "No change: trace is already written to standard output.~%")
         state))
    (pprogn (close-output-channel (f-get-global 'trace-co state) state)
            (f-put-global 'trace-co *standard-co* state))))

(defmacro close-trace-file ()
  '(close-trace-file-fn nil state))

(defmacro break-on-error (&optional (on 't))
  `(if (raw-mode-p state)
       (er soft 'break-on-error
           "It is illegal to call ~x0 while in raw-mode.  Consider exiting ~
            raw-mode and then trying again."
           'break-on-error)
     ,(let* ((error1-trace-form
              '(error1
                :entry (:fmt (msg "[Breaking on error:]"))
                :exit (prog2$ (maybe-print-call-history state)
                              (break$))
                :compile nil))
             (er-cmp-fn-trace-form
              '(er-cmp-fn
                :entry ; body of error1, to avoid second break on error1
                (pprogn (io? error nil state (ctx msg)
                             (error-fms nil ctx nil
                                        "~|[Breaking on cmp error:]~|~@0"
                                        (list (cons #\0 msg))
                                        state))
                        (mv :enter-break nil state))
                :exit (prog2$ (maybe-print-call-history state)
                              (break$))
                :compile nil))
             (abort!-trace-form
              `(abort! :entry
                       (progn$ (fmt-abbrev
                                "~%Breaking on abort to top level."
                                nil 0 *standard-co* state "~|~%")
                               (maybe-print-call-history state)
                               (break$))))
             (throw-raw-ev-fncall-string
              "[Breaking on error (entry to ev-fncall-msg)]")
             (throw-raw-ev-fncall-trace-form
              `(throw-raw-ev-fncall
                :def
                (throw-raw-ev-fncall (val)
                                     (throw 'raw-ev-fncall val))
                :multiplicity
                1
                :entry
                (progn$ (fmt-abbrev
                         "~%ACL2 Error ~@0:   ~@1"
                         (list (cons #\0 ,throw-raw-ev-fncall-string)
                               (cons #\1 (ev-fncall-msg
                                          (car arglist)
                                          (w state)
                                          (user-stobj-alist state))))
                         0 *standard-co* state
                         "~|~%")
                        (maybe-print-call-history state)
                        (break$)))))
        `(let ((on ,on))
           (er-progn
            (case on
              (:all  (trace! ,error1-trace-form
                             ,er-cmp-fn-trace-form
                             ,abort!-trace-form
                             ,throw-raw-ev-fncall-trace-form))
              ((t)   (trace! ,error1-trace-form
                             ,er-cmp-fn-trace-form
                             ,abort!-trace-form
                             (,@throw-raw-ev-fncall-trace-form
                              :cond
                              (not (f-get-global 'in-prove-flg
                                                 state)))))
              ((nil) (with-output :off warning (untrace$ error1
                                                         er-cmp-fn
                                                         throw-raw-ev-fncall)))
              (otherwise (er soft 'break-on-error
                             "Illegal argument value for break-on-error: ~x0."
                             on)))
            (value :invisible))))))

(mutual-recursion

(defun explore-giant-term (term raddr bq-lst i min max)

; In the following when we say ``cons-count'' of an object we mean the number
; of conses in it, but bounded by max.  We explore term looking for big quoted
; constants, i.e., those whose cons-counts equal or exceed min. We also compute
; the cons-count of the ``matrix'' of term.  The matrix of term is term itself
; with the large constants replaced by terms of 0 cons-counts.  We return (mv
; bq-lst i).  where bq-lst is a ``big quote list'' (explained below) and i is
; the total cons-count of the matrix of term.  The bq-lst contains triples (cc
; addr . bq), where bq is a big quote collected from term, addr is its address
; and cc is the cons-count of bq.  By ``address'' we mean a list of nats for
; navigating to term from the top.  E.g., address (1 3 2) in the term ((lambda
; (x y) (foo z)) a b) is z.  We accumulate address in reverse order, as raddr.

; However, this whole exploration stops if the cons-count of the matrix of term
; exceeds max.  So we might not find all of the large constants.  The indicator
; that this has occurred is if the returned i is max or greater.

  (cond
   ((>= i max)
    (mv bq-lst i))
   ((variablep term) (mv bq-lst i))
   ((fquotep term)
    (let ((qi (cons-count-bounded-ac term 0 max)))
      (cond
       ((< qi min) ; term is not a ``large'' quoted constant
        (mv bq-lst (+ qi i)))
       (t (mv (cons (cons qi (cons (revappend raddr nil) term))
                    bq-lst)
              i)))))
   ((flambdap (ffn-symb term))

; We know the fnn-symb is a well-formed lambda expression, (LAMBDA vars body),
; where vars is a true-list of symbols (with cons-count (len vars)).

    (mv-let (bq-lst1 i1)
      (explore-giant-term
       (lambda-body (ffn-symb term))
       (cons 3 (cons 1 raddr))
       bq-lst
       (+ 4 (len (lambda-formals (ffn-symb term))) i)
       min max)
      (explore-giant-term-lst (fargs term)
                                          2 raddr bq-lst1 i1 min max)))
   (t (explore-giant-term-lst (fargs term)
                                          2 raddr bq-lst (+ 1 i) min max))))

(defun explore-giant-term-lst (terms n raddr bq-lst i min max)
  (cond
   ((endp terms)
    (mv bq-lst i))
   (t (mv-let (bq-lst1 i1)
        (explore-giant-term
         (car terms)
         (cons n raddr)
         bq-lst i min max)
        (explore-giant-term-lst (cdr terms)
                                (+ 1 n) raddr
                                bq-lst1 (+ 1 i1) min max))))))

(defun tilde-*-big-constants-phrase (bq-lst)
  (cond
   ((endp bq-lst) nil)
   (t (cons
       (msg "* ~X01~|  accounts for at ~
             least ~x2 conses:~|~  ~Y34"
            `(fetch-addr ',(cadr (car bq-lst)) (@ giant-lambda-object))
            nil
            (car (car bq-lst))
            (cddr (car bq-lst))
            (evisc-tuple 3 6 nil nil))
       (tilde-*-big-constants-phrase (cdr bq-lst))))))

; The following code supports the explain-giant-lambda-object utility that the
; user might invoke when hons-copy-lambda-object? signals an error because a
; lambda is too big.  We wait to now to introduce this stuff because it
; mentions trace-evisceration-alist which was only recently defined above.

(defun explain-giant-lambda-object-fn (state)

; We recover the most recent excessively large lambda object reported by
; hons-copy-lambda-object? and try to determine why it is so big.  We focus
; entirely on finding an explanation in its body.  It is possible that it's
; large because it has hundreds of thousands of formals and a ridiculous
; DECLARE form.  But we completely ignore the LAMBDA, the formals, and the
; declaration (if any).  We think these sources of conses contribute relatively
; few to a count that has exceeded (lambda-object-count-max-val).

  (er-let*
      ((quoted-lambda-obj (read-hons-copy-lambda-object-culprit state))
       (lambda-obj (assign giant-lambda-object (unquote quoted-lambda-obj)))
       (body (value (lambda-object-body lambda-obj))))
    (let* ((max (lambda-object-count-max-val))
           (qmin (floor max 1000))
           (qmax (floor max 2)))
      (mv-let (bq-lst i)
        (explore-giant-term body
                            (if (lambda-object-dcl lambda-obj)
                                '(4)
                                '(3))
                            nil 0 qmin qmax)
        (let ((bq-lst (merge-sort-car-> bq-lst))
              (chan (f-get-global 'standard-co state)))
          (pprogn

; We partition the possible explanations into 5 cases:

; (a1) There is one big quoted constant and the matrix of the body is ok (not
;      excessive).

; (a2) There are multiple big quoted constants and the matrix of the body is ok
;      (not excessive)

; (a3) There are no big constants and the matrix of the body is ok (not
;      excessive) -- which indicates the formals and declare account for the
;      size.

; (b) There are no big quoted constants and the matrix (i.e., the body) is
;     excessive.

; (c) There are large constants and a large matrix

           (cond
            ((null lambda-obj)
             (fms "No giant lambda object has been encountered yet."
                  nil
                  chan state nil))
            ((and (consp bq-lst) ; (a1)
                  (null (cdr bq-lst))
                  (< i qmax))
             (fms
              "The offending lambda object is~%~X01.~%You may retrieve this ~
               object with (@ GIANT-LAMBDA-OBJECT).~%~%The reason it is so ~
               big is probably due to the fact that at address ~X23 you'll ~
               see the quoted constant ~X45, which contains at least ~x6 ~
               conses.  You can retrieve this constant with ~X73.  ~
               Alternatively, you can explore the giant lambda object with ~
               walkabout (see :DOC walkabout).  The walkabout command ~X83 ~
               will take you from the top of the lambda object to the large ~
               constant.~%~%See :DOC explain-giant-lambda-object for ~
               suggestions."
              (list (cons #\0 lambda-obj)
                    (cons #\1 (evisc-tuple 10 12
                                           (trace-evisceration-alist state)
                                           nil))
                    (cons #\2 (cadr (car bq-lst)))
                    (cons #\3 nil)
                    (cons #\4 (cddr (car bq-lst)))
                    (cons #\5 (evisc-tuple 3 6 nil nil))
                    (cons #\6 (car (car bq-lst)))
                    (cons #\7 `(fetch-addr ',(cadr (car bq-lst))
                                           (@ giant-lambda-object)))
                    (cons #\8 `(cmds ,@(cadr (car bq-lst)))))
              chan state nil))
            ((and (consp bq-lst) ; (a2)
                  (< i qmax))
             (fms
              "The offending lambda object is~%~X01.~%You may retrieve this ~
               object with (@ GIANT-LAMBDA-OBJECT).~%~%This lambda object ~
               contains ~x2 large constants (described below) and the body of ~
               the lambda itself is small (no more than ~x3 conses not ~
               counting the large constants detailed below).~%~%The large ~
               constants are sketched below.  The addresses, (i1 i2 ... in), ~
               shown in the FETCH-ADDR forms are the locations of the ~
               constants.  Executing the FETCH-ADDR forms will retrieve the ~
               indicated constant.  Alternatively, if you use walkabout (see ~
               :DOC walkabout) to explore the giant lambda object and you are ~
               standing at the top of the object and wish to go to the ~
               constant at address (i1 i2 ... in), use the walkabout command ~
               (cmds i1 i2 ... in).~%~%~*4See :DOC ~
               explain-giant-lambda-object for suggestions."
              (list (cons #\0 lambda-obj)
                    (cons #\1 (evisc-tuple 10 12
                                           (trace-evisceration-alist state)
                                           nil))
                    (cons #\2 (len bq-lst))
                    (cons #\3 i)
                    (cons #\4 (list "" "~@*~%" "~@*~%" "~@*."
                                    (tilde-*-big-constants-phrase bq-lst))))
              chan state nil))
            ((and (null bq-lst) ; (b)
                  (>= i qmax))
             (fms
              "The offending lambda object is~%~X01.~%You may retrieve this ~
               object with (@ GIANT-LAMBDA-OBJECT).~%~%This lambda object ~
               apparently contains no quoted constants with more than ~x2 ~
               conses.  We say ``apparently'' because we stopped looking when ~
               the body's cons-count reached ~x3 conses.  This lambda object ~
               has a large body and quoted constants apparently don't ~
               contribute.~%~%See :DOC explain-giant-lambda-object for ~
               suggestions."
              (list (cons #\0 lambda-obj)
                    (cons #\1 (evisc-tuple 10 12
                                           (trace-evisceration-alist state)
                                           nil))
                    (cons #\2 qmin)
                    (cons #\3 i))
              chan state nil))
            ((and (consp bq-lst) ; (c)
                  (>= i qmax))
             (fms
              "The offending lambda object is~%~X01.~%You may retrieve this ~
               object with (@ GIANT-LAMBDA-OBJECT).~%~%This lambda object ~
               contains at least ~x2 large constant~#5~[~/s~] (described ~
               below) and the body of the lambda itself is large too ~
               (containing at least ~x3 conses not counting the large ~
               constant~#5~[~/s~] detailed below).  We stopped looking for ~
               large constants when the body's cons-count reached ~x3.~%~%The ~
               large constant~#5~[ is~/s are~] sketched below.  The ~
               address~#5~[~/es~], (i1 i2 ... in), shown in the FETCH-ADDR ~
               form~#5~[ is~/s are~] the location~#5~[~/s~] of the ~
               constant~#5~[~/s~].  Executing a FETCH-ADDR form will retrieve ~
               the indicated constant.  Alternatively, if you use walkabout ~
               (see :DOC walkabout) to explore the giant lambda object and ~
               you are standing at the top of the object and wish to go to ~
               the constant at address (i1 i2 ... in), use the walkabout ~
               command (cmds i1 i2 ... in).~%~%~*4See :DOC ~
               explain-giant-lambda-object for suggestions."
              (list (cons #\0 lambda-obj)
                    (cons #\1 (evisc-tuple 10 12
                                           (trace-evisceration-alist state)
                                           nil))
                    (cons #\2 (len bq-lst))
                    (cons #\3 i)
                    (cons #\4 (list "" "~@*~%" "~@*~%and~%" "~@*."
                                    (tilde-*-big-constants-phrase bq-lst)))
                    (cons #\5 (if (cdr bq-lst)
                                  1
                                  0)))
              chan state nil))
            (t ; (a3) (and (null bq-lst) (< i qmax))
             (fms
              "The offending lambda object is~%~X01.~%You may retrieve this ~
               object with (@ GIANT-LAMBDA-OBJECT).~%~%But the body of this ~
               lambda object contains no more than ~x2 conses, so the ~
               excessive size is due to the formals and declaration (if ~
               any).~%~%See :DOC explain-giant-lambda-object for suggestions."
              (list (cons #\0 lambda-obj)
                    (cons #\1 (evisc-tuple 10 12
                                           (trace-evisceration-alist state)
                                           nil))
                    (cons #\2 i))
              chan state nil)))
           (value nil)))))))

(defmacro explain-giant-lambda-object ()
  '(explain-giant-lambda-object-fn state))

(defun defexec-extract-key (x keyword result result-p)

; X is a keyword-value-listp from an xargs declaration, and result-p indicates
; whether we expect to see no further value of the indicated keyword (in which
; case we should return result and result-p unchanged if erp, below, is nil).
; We return (mv erp result result-p), where if erp is nil, result-p is nil
; coming in, and x contains (keyword result), then we return (mv nil result t).

  (declare (xargs :guard (and (keywordp keyword)
                              (keyword-value-listp x))))
  (cond ((endp x)
         (mv nil result result-p))
        (t (mv-let (erp result result-p)
             (defexec-extract-key (cddr x) keyword result result-p)
             (cond (erp (mv erp nil nil))
                   ((eq (car x) keyword)
                    (cond
                     (result-p (mv "more than one ~x0 has been specified"
                                  nil nil))
                     (t (mv nil (cadr x) t))))
                   (t (mv nil result result-p)))))))

(defun parse-defexec-dcls-1 (alist guard guard-p hints hints-p measure
                                   measure-p ruler-extenders ruler-extenders-p
                                   wfrel wfrel-p stobjs stobjs-p dfs dfs-p
                                   exec-xargs exec-test exec-default acc)

; We return (mv nil declare-form ...) as suggested in the first (endp) case
; below, where exec-xargs has been removed from alist in creating the declare
; form (the second returned value).

  (declare (xargs :guard (symbol-alistp alist)))
  (cond
   ((endp alist)
    (mv nil
        (cons 'declare (reverse acc))
        guard guard-p
        hints hints-p
        measure measure-p
        ruler-extenders ruler-extenders-p
        wfrel wfrel-p
        stobjs stobjs-p
        dfs dfs-p
        exec-xargs exec-test exec-default))
   (t
    (let* ((decl (car alist))
           (sym (car decl))
           (x (cdr decl)))
      (cond
       ((eq sym 'xargs)
        (cond
         ((keyword-value-listp x)
          (mv-let
            (erp guard guard-p)
            (defexec-extract-key x :GUARD guard guard-p)
            (cond
             (erp (mv erp nil nil nil nil nil nil nil nil nil nil nil nil nil
                      nil nil nil nil nil))
             (t
              (mv-let
                (erp hints hints-p)
                (defexec-extract-key x :HINTS hints hints-p)
                (cond
                 (erp (mv erp nil nil nil nil nil nil nil nil nil nil nil nil
                          nil nil nil nil nil nil))
                 (t
                  (mv-let
                    (erp measure measure-p)
                    (defexec-extract-key x :MEASURE measure measure-p)
                    (cond
                     (erp (mv erp nil nil nil nil nil nil nil nil nil nil nil
                              nil nil nil nil nil nil nil))
                     (t
                      (mv-let
                        (erp ruler-extenders ruler-extenders-p)
                        (defexec-extract-key x :RULER-EXTENDERS ruler-extenders
                          ruler-extenders-p)
                        (cond
                         (erp (mv erp nil nil nil nil nil nil nil nil nil nil
                                  nil nil nil nil nil nil nil nil))
                         (t
                          (mv-let
                            (erp wfrel wfrel-p)
                            (defexec-extract-key x :WELL-FOUNDED-RELATION
                              wfrel wfrel-p)
                            (cond
                             (erp (mv erp nil nil nil nil nil nil nil nil nil
                                      nil nil nil nil nil nil nil nil nil))
                             (t
                              (mv-let (erp stobjs stobjs-p)
                                (defexec-extract-key x :STOBJS stobjs stobjs-p)
                                (cond
                                 (erp (mv erp nil nil nil nil nil nil nil nil
                                          nil nil nil nil nil nil nil nil nil
                                          nil))
                                 (t (mv-let (erp dfs dfs-p)
                                      (defexec-extract-key x :DFS dfs dfs-p)
                                      (cond
                                       (erp (mv erp nil nil nil nil nil nil nil
                                                nil nil nil nil nil nil nil nil
                                                nil nil nil))
                                       (t
                                        (parse-defexec-dcls-1
                                         (cdr alist)
                                         guard guard-p
                                         hints hints-p
                                         measure measure-p
                                         ruler-extenders ruler-extenders-p
                                         wfrel wfrel-p
                                         stobjs stobjs-p
                                         dfs dfs-p
                                         exec-xargs exec-test exec-default
                                         (cons decl acc))))))))))))))))))))))))
         (t (mv "we found (XARGS . x) where x is not a keyword-value-listp"
                nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
                nil nil))))
       ((eq sym 'exec-xargs)
        (cond
         ((or exec-xargs exec-test exec-default)
          (mv "more than one EXEC-XARGS has been specified"
              nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
              nil nil nil))
         ((and (keyword-value-listp x) x)
          (let* ((exec-test (cadr (assoc-keyword :test x)))
                 (x (if exec-test (remove-keyword :test x) x))
                 (exec-default (cadr (assoc-keyword :default-value x)))
                 (x (if exec-default (remove-keyword :default-value x) x)))
            (parse-defexec-dcls-1 (cdr alist)
                                  guard guard-p
                                  hints hints-p
                                  measure measure-p
                                  ruler-extenders ruler-extenders-p
                                  wfrel wfrel-p
                                  stobjs stobjs-p
                                  dfs dfs-p
                                  x
                                  exec-test
                                  exec-default
                                  acc)))
         (t (mv "we found declaration (EXEC-XARGS . x) where x is not a ~
                   non-empty keyword-value-listp"
                nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
                nil nil))))
       (t (parse-defexec-dcls-1 (cdr alist)
                                guard guard-p
                                hints hints-p
                                measure measure-p
                                ruler-extenders ruler-extenders-p
                                wfrel wfrel-p
                                stobjs stobjs-p
                                dfs dfs-p
                                x
                                exec-test
                                exec-default
                                (cons (car alist) acc))))))))

(defun fix-exec-xargs (exec-xargs hints hints-p
                                  measure measure-p
                                  ruler-extenders ruler-extenders-p
                                  wfrel wfrel-p
                                  stobjs stobjs-p
                                  dfs dfs-p)
  (declare (xargs :guard (keyword-value-listp exec-xargs)))

; Update exec-xargs to incorporate the hints, measure, and stobjs extracted
; from the xargs (if any).

  (let* ((x (if (and hints-p (not (assoc-keyword :HINTS exec-xargs)))
                (list* :HINTS hints exec-xargs)
              exec-xargs))
         (x (if (and measure-p (not (assoc-keyword :MEASURE exec-xargs)))
                (list* :MEASURE measure x)
              x))
         (x (if (and ruler-extenders-p
                     (not (assoc-keyword :RULER-EXTENDERS exec-xargs)))
                (list* :RULER-EXTENDERS ruler-extenders x)
              x))
         (x (if (and wfrel-p (not (assoc-keyword :WELL-FOUNDED-RELATION
                                                 exec-xargs)))
                (list* :WELL-FOUNDED-RELATION wfrel x)
              x))
         (x (if (and stobjs-p (not (assoc-keyword :STOBJS exec-xargs)))
                (list* :STOBJS stobjs x)
              x))
         (x (if (and dfs-p (not (assoc-keyword :DFS exec-xargs)))
                (list* :DFS dfs x)
              x)))
    x))

(defun parse-defexec-dcls (dcls-and-strings final
                                            guard guard-p
                                            hints hints-p
                                            measure measure-p
                                            ruler-extenders ruler-extenders-p
                                            wfrel wfrel-p
                                            stobjs stobjs-p
                                            dfs dfs-p
                                            exec-xargs exec-test exec-default)

; We return the following values.  Note that input guard-p is true if we have
; encountered a guard on an earlier call.

;  erp          - nil or a string that indicates an error
;  final        - what is left of dcls-and-strings after (exec-xargs ...) is
;                 removed
;  guard        - the guard from (xargs ... :guard ...)
;  exec-xargs   - the cdr of (exec-xargs ...) from input
;  exec-test    - from (exec-xargs ... :test ...) if present, else guard
;  exec-default - from (exec-xargs ... :default-value ...), else nil

  (cond
   ((endp dcls-and-strings)
    (cond
     ((null guard-p)
      (mv "no :GUARD has been specified in the XARGS.  The MBE proof ~
           obligation is actually a guard condition -- we have to prove that ~
           the guard ensures that the :LOGIC and :EXEC terms are equivalent ~
           and that the guards are satisfied for the :EXEC term.  Please ~
           specify a :GUARD.  Note also that you can delay the verification ~
           of the MBE conditions by delaying guard verification, as with ~
           :VERIFY-GUARDS NIL"
          nil nil nil nil nil))
     (t
      (mv nil
          (reverse final)
          guard
          (fix-exec-xargs exec-xargs hints hints-p measure measure-p
                          ruler-extenders ruler-extenders-p wfrel wfrel-p
                          stobjs stobjs-p dfs dfs-p)
          (or exec-test guard)
          exec-default))))
   (t (let ((x (car dcls-and-strings)))
        (cond
         ((stringp x)
          (parse-defexec-dcls (cdr dcls-and-strings) (cons x final) guard
                              guard-p hints hints-p measure measure-p
                              ruler-extenders ruler-extenders-p wfrel wfrel-p
                              stobjs stobjs-p dfs dfs-p exec-xargs exec-test
                              exec-default))
         ((and (consp x)
               (eq (car x) 'declare)
               (symbol-alistp (cdr x)))
          (mv-let (erp decl guard guard-p hints hints-p measure measure-p
                       ruler-extenders ruler-extenders-p wfrel wfrel-p stobjs
                       stobjs-p dfs dfs-p exec-xargs exec-test exec-default)
            (parse-defexec-dcls-1 (cdr x) guard guard-p hints hints-p measure
                                  measure-p ruler-extenders ruler-extenders-p
                                  wfrel wfrel-p stobjs stobjs-p dfs dfs-p
                                  exec-xargs exec-test exec-default nil)
            (cond
             (erp (mv erp nil nil nil nil nil))
             (t (parse-defexec-dcls (cdr dcls-and-strings) (cons decl final)
                                    guard guard-p hints hints-p measure
                                    measure-p ruler-extenders ruler-extenders-p
                                    wfrel wfrel-p stobjs stobjs-p dfs dfs-p
                                    exec-xargs exec-test exec-default)))))
         (t
          (mv (msg "the form ~x0 is neither a string nor a form (declare . x) ~
                    where x is a symbol-alistp"
                   x)
              nil nil nil nil nil)))))))

(defmacro defexec (&whole whole fn formals &rest rest)
  (let ((dcls-and-strings (butlast rest 1))
        (body (car (last rest))))
    (mv-let (erp exec-body)
      (case-match body
        (('mbe ':logic & ':exec exec-body)
         (mv nil exec-body))
        (('mbe ':exec exec-body ':logic &)
         (mv nil exec-body))
        (('mbe . &)
         (mv 'mbe nil))
        (& (mv t nil)))
      (cond
       (erp `(er soft 'defexec
                 "A defexec form must have a body that is a valid call of mbe. ~
                  See :DOC ~s0."
                 ,(if (eq erp 'mbe) "mbe" "defexec")))
       ((not (symbolp fn))
        `(er soft 'defexec
             "The first argument of defexec must be a symbol, but ~x0 is not."
             ',fn))
       ((not (arglistp formals))
        `(er soft 'defexec
             "The second argument of defexec must be legal list of formals, ~
              but ~x0 is not."
             ',formals))
       (t (mv-let (erp final-dcls-and-strings guard exec-xargs exec-test
                       exec-default)
            (parse-defexec-dcls dcls-and-strings nil nil nil nil nil nil nil
                                nil nil nil nil nil nil nil nil nil nil nil)
            (cond
             (erp
              `(er soft 'defexec
                   "Macroexpansion of ~x0 has failed because ~@1."
                   ',whole
                   ',erp))
             (t `(encapsulate ()
                   (local
                    (encapsulate ()
                                 (set-ignore-ok t)
                                 (set-irrelevant-formals-ok t)
                                 (local (defun ,fn ,formals
                                          (declare (xargs :verify-guards nil
                                                          ,@exec-xargs))
                                          (if ,exec-test
                                              ,exec-body
                                            ,exec-default)))
                                 (local (defthm ,(packn
                                                  (list fn
                                                        '-GUARD-IMPLIES-TEST))
                                          (implies ,guard ,exec-test)
                                          :rule-classes nil))))
                   (defun ,fn ,formals
                     ,@final-dcls-and-strings
                     ,body))))))))))

; Start code for :pl and proof-builder show-rewrites command.

(defrec sar ; single-applicable-rewrite
  ((lemma . alist) (index . equiv))
  nil)

; Here's the idea.  Both showing and using of rewrites benefits from knowing
; which hypotheses are irrelevant.  But when rewriting in the proof-builder, we
; will try to do more, namely relieve all the hyps by instantiating free
; variables.  So we avoid doing any instantiation in forming the sar record.
; Actually, if we knew that rewriting were to be done with the empty
; substitution, then we'd go ahead and store the result of trying to relieve
; hypotheses at this point; but we don't.  Nevertheless, we should have a
; function that takes the fields of an sar record and returns an appropriate
; structure representing the result of trying to relieve the hyps (possibly
; starting with a unify-subst extending the one that was originally produced).

(defun applicable-rewrite-rules1 (term geneqv lemmas current-index
                                       target-name-or-rune target-index wrld)

; Warning: If you change this function, consider changing related function
; applicable-linear-rules1.

; Call this initially with current-index equal to 1.

  (declare (xargs :guard (or (null target-index) (integerp target-index))))
  (cond
   ((consp lemmas)
    (let ((lemma (car lemmas)))
      (cond
       ((and (or (null target-name-or-rune)
                 (if (symbolp target-name-or-rune)
                     (equal target-name-or-rune
                            (cadr (access rewrite-rule lemma :rune)))
                   (equal target-name-or-rune
                          (access rewrite-rule lemma :rune))))
             (member (access rewrite-rule lemma :subclass)
                     '(backchain abbreviation definition
                                 rewrite-quoted-constant))
             (or (eq geneqv :none)
                 (geneqv-refinementp (access rewrite-rule lemma :equiv)
                                     geneqv
                                     wrld)))
        (mv-let
         (flg alist)
         (one-way-unify
          (if (and (eq (access rewrite-rule lemma :subclass)
                       'rewrite-quoted-constant)
                   (eql (car (access rewrite-rule lemma :heuristic-info)) 2))
              (access rewrite-rule lemma :rhs)
              (access rewrite-rule lemma :lhs))
          term)
         (cond
          (flg
           (if target-index
               (if (eql target-index current-index)
                   (list (make sar
                               :index current-index
                               :lemma lemma
                               :alist alist
                               :equiv (access rewrite-rule lemma
                                              :equiv)))
                 (applicable-rewrite-rules1
                  term geneqv (cdr lemmas) (1+ current-index)
                  target-name-or-rune target-index wrld))
             (cons (make sar
                         :index (if target-name-or-rune
                                    nil
                                  current-index)
                         :lemma lemma
                         :alist alist
                         :equiv (access rewrite-rule lemma
                                        :equiv))
                   (applicable-rewrite-rules1
                    term geneqv (cdr lemmas) (1+ current-index)
                    target-name-or-rune target-index wrld))))
          (t (applicable-rewrite-rules1
              term geneqv (cdr lemmas) current-index
              target-name-or-rune target-index wrld)))))
       (t (applicable-rewrite-rules1
           term geneqv (cdr lemmas) current-index
           target-name-or-rune target-index wrld)))))
   (t nil)))

(defun applicable-linear-rules1 (term lemmas current-index target-name-or-rune
                                      target-index)

; Warning: If you change this function, consider changing related function
; applicable-rewrite-rules1.

; Call this initially with current-index equal to 1.

  (declare (xargs :guard (or (null target-index) (integerp target-index))))
  (cond
   ((consp lemmas)
    (let ((lemma (car lemmas)))
      (cond
       ((or (null target-name-or-rune)
            (if (symbolp target-name-or-rune)
                (equal target-name-or-rune
                       (cadr (access linear-lemma lemma :rune)))
              (equal target-name-or-rune
                     (access linear-lemma lemma :rune))))
        (mv-let
         (flg alist)
         (one-way-unify (access linear-lemma lemma :max-term) term)
         (cond
          (flg
           (cond
            (target-index
             (cond
              ((eql target-index current-index)
               (list (make sar ; omit :equiv, which is not needed
                           :index current-index
                           :lemma lemma
                           :alist alist)))
              (t (applicable-linear-rules1
                  term (cdr lemmas) (1+ current-index)
                  target-name-or-rune target-index))))
            (t (cons (make sar ; omit :equiv, which is not needed
                           :index (if target-name-or-rune
                                      nil
                                    current-index)
                           :lemma lemma
                           :alist alist)
                     (applicable-linear-rules1
                      term (cdr lemmas) (1+ current-index)
                      target-name-or-rune target-index)))))
          (t (applicable-linear-rules1
              term (cdr lemmas) current-index
              target-name-or-rune target-index)))))
       (t (applicable-linear-rules1
           term (cdr lemmas) current-index
           target-name-or-rune target-index)))))
   (t nil)))

(defun pc-relieve-hyp (rune hyp unify-subst type-alist wrld state ens ttree)

; This function is adapted from ACL2 function relieve-hyp, but without
; rewriting.  Notice that there are no arguments for obj, equiv, fnstack,
; ancestors, or simplify-clause-pot-lst.  Also notice that rcnst has been
; replaced by ens (an enable structure).

; We return t or nil indicating whether we won, an extended unify-subst and a
; new ttree, with one exception: we can return (mv :unify-subst-list lst
; new-ttree), where lst is a list of binding alists, as for relieve-hyp.  This
; function is a No-Change Loser.

  (cond ((and (ffn-symb-p hyp 'synp)

; Skip special treatment here for type-prescription and other rule classes that
; do not give special treatment to synp hypotheses.

              (member-eq (car rune) '(:rewrite :meta :definition :linear)))
         (mv-let
          (wonp failure-reason unify-subst ttree)
          (relieve-hyp-synp rune hyp unify-subst
                            (rewrite-stack-limit wrld)
                            type-alist
                            wrld
                            state
                            nil ; fnstack
                            nil ; ancestors
                            nil ; backchain-limit
                            nil ; simplify-clause-pot-lst
                            (make-rcnst ens wrld state
                                        :force-info 'weak) ; conservative
                            nil ; gstack
                            ttree
                            nil ; bkptr
                            )
          (declare (ignore failure-reason))
          (mv wonp unify-subst ttree)))
        (t (mv-let
            (forcep bind-flg)
            (binding-hyp-p hyp unify-subst wrld)
            (let ((hyp (if forcep (fargn hyp 1) hyp)))
              (cond
               (bind-flg
                (mv t
                    (cons (cons (fargn hyp 1)
                                (sublis-var unify-subst (fargn hyp 2)))
                          unify-subst)
                    ttree))
               (t
                (mv-let
                 (lookup-hyp-ans unify-subst ttree)
                 (lookup-hyp hyp type-alist wrld unify-subst ttree ens)
                 (cond
                  (lookup-hyp-ans
                   (mv t unify-subst ttree))
                  ((free-varsp hyp unify-subst)
                   (search-ground-units hyp unify-subst type-alist ens
                                        (ok-to-force-ens ens) wrld ttree))
                  (t
                   (let ((inst-hyp (sublis-var unify-subst hyp)))
                     (mv-let
                      (knownp nilp nilp-ttree)
                      (known-whether-nil inst-hyp type-alist ens
                                         (ok-to-force-ens ens)
                                         nil ; dwp
                                         wrld ttree)
                      (cond
                       (knownp
                        (mv (not nilp) unify-subst nilp-ttree))
                       (t
                        (mv-let
                         (not-flg atm)
                         (strip-not hyp)

; Again, we avoid rewriting in this proof-builder code.

                         (cond
                          (not-flg
                           (if (equal atm *nil*)
                               (mv t unify-subst ttree)
                             (mv nil unify-subst ttree)))
                          (t
                           (if (if-tautologyp atm)
                               (mv t unify-subst ttree)
                             (mv nil unify-subst ttree)))))))))))))))))))

(mutual-recursion

(defun pc-relieve-hyps1-iter (rune hyps unify-subst-lst unify-subst
                                   unify-subst0 ttree0 type-alist
                                   keep-unify-subst wrld state ens ttree)

; Keep-unify-subst must be t, nil, or :FAILED.

  (mv-let
   (relieve-hyps1-ans unify-subst1 ttree1)
   (pc-relieve-hyps1 rune hyps
                     (extend-unify-subst (car unify-subst-lst) unify-subst)
                     unify-subst0 ttree0 type-alist keep-unify-subst wrld state
                                   ens ttree)
   (cond ((or (endp (cdr unify-subst-lst))
              relieve-hyps1-ans)
          (mv relieve-hyps1-ans unify-subst1 ttree1))
         (t (pc-relieve-hyps1-iter rune hyps
                                   (cdr unify-subst-lst)
                                   unify-subst unify-subst0 ttree0
                                   type-alist keep-unify-subst wrld
                                   state ens ttree)))))

(defun pc-relieve-hyps1 (rune hyps unify-subst unify-subst0 ttree0 type-alist
                              keep-unify-subst wrld state ens ttree)

; This function is adapted from ACL2 function relieve-hyp.  Notice that there
; are no arguments for obj, equiv, fnstack, ancestors, or
; simplify-clause-pot-lst.  Also notice that rcnst has been replaced by ens (an
; enable structure).

; Keep-unify-subst should be t, :FAILED, or nil.  When it is non-nil, we run
; through all of the hyps in order to find extensions of unify-subst that bind
; free variables in order to make hyps true.  Keep-unify-subst is t at the top
; level, but when we get a failure, we set it to :FAILED so that we can return
; nil at the end.

; This function is a No-Change Loser when keep-unify-subst is nil.  In order to
; accomplish this without requiring it have to test the answer to its own
; recursive calls, we have to pass down the original unify-subst and ttree so
; that when it fails it can return them instead of the accumulated versions.

  (cond ((null hyps)
         (mv (not (eq keep-unify-subst :FAILED)) unify-subst ttree))
        (t (mv-let
            (relieve-hyp-ans new-unify-subst ttree)

; We avoid rewriting in this proof-builder code, so new-ttree = ttree.

            (pc-relieve-hyp rune (car hyps) unify-subst type-alist wrld
                            state ens ttree)
            (cond
             ((eq relieve-hyp-ans :unify-subst-list)

; The hypothesis (car hyps) is a call of bind-free that has produced a list of
; unify-substs.

              (pc-relieve-hyps1-iter rune (cdr hyps)
                                     new-unify-subst ; a list of alists
                                     unify-subst unify-subst0 ttree0 type-alist
                                     keep-unify-subst wrld state ens ttree))
             ((or relieve-hyp-ans keep-unify-subst)
              (pc-relieve-hyps1 rune
                                (cdr hyps)
                                new-unify-subst
                                unify-subst0 ttree0
                                type-alist
                                (if (and keep-unify-subst
                                         (not relieve-hyp-ans))
                                    :FAILED
                                  keep-unify-subst)
                                wrld state ens ttree))
             (t (mv nil unify-subst0 ttree0)))))))
)

(defun pc-relieve-hyps (rune hyps unify-subst type-alist keep-unify-subst wrld
                             state ens ttree)

; Adapted from ACL2 function relieve-hyp.  Notice that there are no arguments
; for obj, equiv, fnstack, ancestors, or simplify-clause-pot-lst.  Also notice
; that rcnst has been replaced by ens (an enable structure).

; We return t or nil indicating success, an extended unify-subst and
; a new ttree.  This function is a No-Change Loser.

  (pc-relieve-hyps1 rune hyps unify-subst unify-subst ttree type-alist

; Pc-relieve-hyps1 expects keep-unify-subst to be t, nil, or :failed.

                    (not (null keep-unify-subst))
                    wrld state ens ttree))

(defun remove-trivial-lits (lst type-alist alist wrld ens ttree)

; Removes trivially true lits from lst.  However, we don't touch elements of
; lst that contain free variables.  We apply the substitution at this point
; because we need to know whether a lit contains a free variable (one not bound
; by alist) that might get bound later, thus changing its truth value.

  (if (consp lst)
      (mv-let (rest-list ttree)
        (remove-trivial-lits (cdr lst) type-alist alist wrld ens ttree)
        (let ((new-lit (sublis-var alist (car lst))))
          (if (free-varsp (car lst) alist)
              (mv (cons new-lit rest-list) ttree)
            (mv-let (knownp nilp nilp-ttree)
              (known-whether-nil new-lit type-alist
                                 ens (ok-to-force-ens ens)
                                 nil ; dwp
                                 wrld ttree)
              (if (and knownp (not nilp))
                  (mv rest-list nilp-ttree)
                (mv (cons new-lit rest-list) ttree))))))
    (mv nil ttree)))

(defun unrelieved-hyps (rune hyps unify-subst type-alist keep-unify-subst wrld
                             state ens ttree)

; Returns unrelieved hyps (with the appropriate substitution applied), an
; extended substitution, and a new tag-tree.  Note: the substitution really has
; been applied already to the returned hyps, even though we also return the
; extended substitution.

; If keep-unify-subst is true, then we allow unify-subst to extend even if we
; do not relieve all of the hypotheses.

  (mv-let (success-flg new-unify-subst new-ttree)
    (pc-relieve-hyps rune hyps unify-subst type-alist keep-unify-subst wrld
                     state ens ttree)
    (if success-flg
        (mv nil new-unify-subst new-ttree)
      (mv-let (unify-subst ttree)
        (if keep-unify-subst
            (mv new-unify-subst new-ttree)
          (mv unify-subst ttree))
        (mv-let (lits ttree)
          (remove-trivial-lits hyps type-alist unify-subst wrld ens ttree)
          (mv lits unify-subst ttree))))))

(defun untranslate-subst-abb (sub abbreviations state)
  (declare (xargs :guard (symbol-alistp sub)))
  (if (consp sub)
      (cons (list (caar sub) (untrans0 (cdar sub) nil abbreviations))
            (untranslate-subst-abb (cdr sub) abbreviations state))
    nil))

(defun show-rewrite-linear (caller index col rune nume show-more subst-hyps
                                   subst-hyps-2 unify-subst unify-subst-2 free
                                   free-2 rhs rewrite-quoted-constant-form-2p
                                   abbreviations term-id-iff ens
                                   enabled-only-flg equiv pl-p state)

; Pl-p is true when we are calling this function on behalf of :pl, and is false
; when we are calling it on behalf of the proof-builder.

  (let ((enabledp (enabled-numep nume ens))
        (subst-rhs (sublis-var unify-subst rhs))
        (term-id-iff (and (eq caller 'show-rewrites)
                          term-id-iff)))
    (if (and enabled-only-flg
             (not enabledp))
        state
      (pprogn
       (fms "~|~#a~[~/~c0. ~/  ~]~x1~#2~[~/ (disabled)~]"
            (list (cons #\a (if pl-p 0 (if index 1 2)))
                  (cons #\0 (cons index col))
                  (cons #\1
                        (cond
                         (pl-p rune)
                         ((cddr rune)
                          rune) ; just print name if rune seems unique for it
                         (t (base-symbol rune))))
                  (cons #\2 (if enabledp 0 1)))
            (standard-co state) state nil)
       (let ((fmt-string
              "~@x~|~
               ~ ~ ~#c~[New term~/Conclusion~]: ~Y3t~|~
               ~ ~ Hypotheses: ~#b~[<none>~/~Y4t~]~|~
               ~#c~[~ ~ Equiv: ~ye~|~/~]~
               ~#s~[~/~ ~ Substitution: ~Yat~|~]~
               ~#5~[~/~
                    ~ ~ ~@f variable: ~&6~/~
                    ~ ~ ~@f variables: ~&6~sn~]~
               ~#7~[~/  WARNING:  One of the hypotheses is (equivalent to) NIL, ~
               and hence will apparently be impossible to relieve.~]~
               ~#8~[~/  WARNING:  The new term above is only used if it ~
               rewrites to a quoted constant!~]~|"))
         (pprogn
          (fms fmt-string
               (list (cons #\x "")
                     (cons #\c (if (eq caller 'show-rewrites) 0 1))
                     (cons #\3 (untrans0 subst-rhs term-id-iff
                                         abbreviations))
                     (cons #\s (if pl-p 1 0))
                     (cons #\a (untranslate-subst-abb unify-subst
                                                      abbreviations
                                                      state))
                     (cons #\b (if subst-hyps 1 0))
                     (cons #\e equiv)
                     (cons #\4 (untrans0-lst subst-hyps t abbreviations))
                     (cons #\f (if pl-p "Free" "Remaining free"))
                     (cons #\5 (zero-one-or-more (length free)))
                     (cons #\6 free)
                     (cons #\n "")
                     (cons #\7 (if (member-equal *nil* subst-hyps) 1 0))
                     (cons #\t (term-evisc-tuple nil state))
                     (cons #\8 (if rewrite-quoted-constant-form-2p 1 0)))
               (standard-co state) state nil)
          (cond (show-more
                 (pprogn
                  (cond
                   (pl-p state)
                   (t
                    (fms0 "  -- IF ~#c~[REWRITE~/APPLY-LINEAR~] is called ~
                           with a third argument of t: --"
                          (list (cons #\c (if (eq caller 'show-rewrites)
                                              0 1))))))
                  (fms fmt-string
                       (list (cons #\x
                                   (let ((extra
                                          (untranslate-subst-abb
                                           (alist-difference-eq
                                            unify-subst-2
                                            unify-subst)
                                           abbreviations
                                           state)))
                                     (cond
                                      (extra ; always true?
                                       (msg
                                        "~ ~ Additional bindings: ~X01"
                                        extra
                                        (term-evisc-tuple nil state)))
                                      (t ""))))
                             (cons #\c (if (eq caller 'show-rewrites) 0 1))
                             (cons #\3 (untrans0
                                        (sublis-var unify-subst-2 rhs)
                                        term-id-iff abbreviations))
                             (cons #\s (if pl-p 1 0))
                             (cons #\a (untranslate-subst-abb unify-subst-2
                                                              abbreviations
                                                              state))
                             (cons #\b (if subst-hyps-2 1 0))
                             (cons #\e equiv)
                             (cons #\4 (untrans0-lst subst-hyps-2 t
                                                     abbreviations))
                             (cons #\f (if pl-p "Free" "Remaining free"))
                             (cons #\5 (if (eql (length free-2) 1)
                                           1
                                         2))
                             (cons #\6 free-2)
                             (cons #\n (if (null free-2)
                                           "[none]"
                                         ""))
                             (cons #\7 (if (member-equal *nil* subst-hyps-2)
                                           1
                                         0))
                             (cons #\t (term-evisc-tuple nil state))
                             (cons #\8 (if rewrite-quoted-constant-form-2p 1 0)))
                       (standard-co state) state nil)))
                (t state))))))))

(defun show-rewrites-linears (caller app-rules col abbreviations
                                     term-id-iff ens type-alist
                                     enabled-only-flg pl-p w state)

; Pl-p is true when we are calling this function on behalf of :pl, and is false
; when we are calling it on behalf of the proof-builder.

  (cond
   ((null app-rules)
    state)
   (t
    (pprogn
     (let* ((sar (car app-rules))
            (lemma (access sar sar :lemma))
            (alist (access sar sar :alist))
            (index (access sar sar :index)))
       (mv-let
        (hyps result rune)
        (cond
         ((eq caller 'show-rewrites)
          (mv (access rewrite-rule lemma :hyps)
              (if (and (eq (access rewrite-rule lemma :subclass)
                           'rewrite-quoted-constant)
                       (eql (car (access rewrite-rule lemma :heuristic-info))
                            2))
                  (access rewrite-rule lemma :lhs)
                  (access rewrite-rule lemma :rhs))
              (access rewrite-rule lemma :rune)))
         (t
          (mv (access linear-lemma lemma :hyps)
              (access linear-lemma lemma :concl)
              (access linear-lemma lemma :rune))))
        (mv-let
         (subst-hyps unify-subst ttree)
         (unrelieved-hyps rune hyps alist type-alist nil w state ens nil)
         (declare (ignore ttree))
         (let* ((result-and-hyps-vars
                 (union-eq (all-vars result)
                           (all-vars1-lst hyps nil)))
                (free (reverse (set-difference-assoc-eq
                                result-and-hyps-vars
                                unify-subst)))
                (rewrite-quoted-constant-form-2p
                 (and (eq caller 'show-rewrites)
                      (eq (access rewrite-rule lemma :subclass)
                          'rewrite-quoted-constant)
                      (eql (car (access rewrite-rule lemma :heuristic-info))
                           2))))
           (cond
            (pl-p
             (show-rewrite-linear
              caller index col rune
              (if (eq caller 'show-rewrites)
                  (access rewrite-rule lemma :nume)
                (access linear-lemma lemma :nume))
              nil ; show-more
              subst-hyps
              nil ; subst-hyps-2, irrelevant
              unify-subst
              nil ; unify-subst-2,  irrelevant
              free
              nil ; free-2, irrelevant
              result
              rewrite-quoted-constant-form-2p
              abbreviations term-id-iff ens enabled-only-flg
              (and (eq caller 'show-rewrites)
                   (access sar sar :equiv))
              t ; pl-p
              state))
            (t
             (mv-let
              (show-more subst-hyps-2 unify-subst-2)
              (cond ((and free subst-hyps)

; Then we try to find at least a partial extension of unify-subst that
; eliminates some hypotheses.

                     (mv-let (subst-hyps-2 unify-subst-2 ttree)
                             (unrelieved-hyps rune hyps alist type-alist t
                                              w state ens nil)
                             (declare (ignore ttree))
                             (cond ((equal unify-subst-2 unify-subst)
                                    (assert$
                                     (equal subst-hyps-2 subst-hyps)
                                     (mv nil subst-hyps unify-subst)))
                                   (t
                                    (mv t subst-hyps-2 unify-subst-2)))))
                    (t (mv nil subst-hyps unify-subst)))
              (show-rewrite-linear
               caller index col rune
               (if (eq caller 'show-rewrites)
                   (access rewrite-rule lemma :nume)
                 (access linear-lemma lemma :nume))
               show-more subst-hyps subst-hyps-2 unify-subst unify-subst-2
               free
               (reverse (set-difference-assoc-eq
                         result-and-hyps-vars
                         unify-subst-2))
               result
               rewrite-quoted-constant-form-2p
               abbreviations term-id-iff ens enabled-only-flg
               (and (eq caller 'show-rewrites)
                    (access sar sar :equiv))
               nil ; pl-p
               state))))))))
     (show-rewrites-linears
      caller (cdr app-rules) col abbreviations term-id-iff ens type-alist
      enabled-only-flg pl-p w state)))))

(defun expand-assumptions-1 (term)
  (case-match term
    (('if a b ''nil)
     (append (expand-assumptions-1 a) (expand-assumptions-1 b)))
    ((equality-p a b)
     (if (or (and (eq equality-p 'eq)
                  (or (and (consp a) (eq (car a) 'quote) (symbolp (cadr a)))
                      (and (consp b) (eq (car b) 'quote) (symbolp (cadr b)))))
             (and (eq equality-p 'eql)
                  (or (and (consp a) (eq (car a) 'quote) (eqlablep (cadr a)))
                      (and (consp b) (eq (car b) 'quote) (eqlablep (cadr b))))))
         (list term (mcons-term* 'equal a b))
       (list term)))
    (& (list term))))

(defun expand-assumptions (x)

; If x is (and a b) then we get (list a b), etc.

  (declare (xargs :guard (true-listp x)))
  (if x
      (append (expand-assumptions-1 (car x))
              (expand-assumptions (cdr x)))
    nil))

(defun hyps-type-alist (assumptions ens wrld state)

; Note that the force-flg arg to type-alist-clause is nil here, so we shouldn't
; wind up with any assumptions in the returned tag-tree. Also note that we
; return (mv contradictionp type-alist fc-pair-lst), where actually fc-pair-lst
; is a ttree if contradictionp holds; normally we ignore fc-pair-lst otherwise.

  (forward-chain-top 'show-rewrites
                     (dumb-negate-lit-lst (expand-assumptions assumptions))
                     nil
                     (ok-to-force-ens ens)
                     nil ; do-not-reconsiderp
                     wrld ens (match-free-override wrld) state))

(defun show-rewrites-linears-fn (caller rule-id enabled-only-flg ens
                                        current-term abbreviations term-id-iff
                                        all-hyps geneqv pl-p state)

; Pl-p is true when we are calling this function on behalf of :pl, and is false
; when we are calling it on behalf of the proof-builder.

  (let ((name (and (symbolp rule-id) rule-id))
        (index (and (integerp rule-id) (< 0 rule-id) rule-id))
        (rune (and (consp rule-id)
                   (if pl-p
                       (keywordp (car rule-id))
                     (member-eq (car rule-id)
                                (cond ((eq caller 'show-rewrites)
                                       '(:rewrite
                                         :rewrite-quoted-constant
                                         :definition))
                                      (t :linear))))
                   rule-id))
        (w (w state)))
    (cond
     ((and (not pl-p) ; optimization -- check is already made by pl2-fn
           rule-id
           (not (or name index rune)))
      (fms "The rule-id argument to ~s0 must be a name, a positive integer, ~
            or a rune representing a rewrite, rewrite-quoted-constant, or ~
            definition rule, but ~x1 is none of these.~|"
           (list (cons #\0 (symbol-name caller))
                 (cons #\1 rule-id))
           (standard-co state) state nil))
     ((and (not pl-p) ; optimization -- check is already made by pl2-fn
           (or (variablep current-term)
               (and (fquotep current-term)
                    (not (and (eq caller 'show-rewrites)
                              rule-id
                              (eq (car rule-id) :rewrite-quoted-constant))))
               (flambdap (ffn-symb current-term))))
; The message below intentionally conflates ``rewrite rules'' with
; ``rewrite-quoted-constant'' rules, since this facility doesn't really
; distinguish the two.
      (fms "It is only possible to apply ~#0~[rewrite rules to terms that are ~
            not variables or applications of lambda expressions~/linear rules ~
            for triggers that are not variables, quoted constants, or ~
            applications of lambda expressions~].  However, the current term ~
            is:~%~ ~ ~y1.~|"
           (list (cons #\0 (if (eq caller 'show-rewrites) 0 1))
                 (cons #\1 current-term))
           (standard-co state) state (term-evisc-tuple nil state)))
     ((and (not pl-p) ; optimization -- check is already made by pl2-fn
           (eq (ffn-symb current-term) 'if)
           (eq caller 'show-linears))
      (fms "It is only possible to apply linear rules for triggers that are ~
            applications of function symbols other than IF.  However, the ~
            current term is~|~ ~ ~y0.~|"
           (list (cons #\0 current-term))
           (standard-co state) state (term-evisc-tuple nil state)))
     (t
      (mv-let
       (flg hyps-type-alist ttree)
       (hyps-type-alist all-hyps ens w state)
       (declare (ignore ttree))
       (cond
        (flg ; contradiction in hyps, so we are in the proof-builder
         (assert$
          (not pl-p)
          (fms "*** Contradiction in the hypotheses! ***~%The S command ~
                should complete this goal.~|"
               nil (standard-co state) state nil)))
        (t (let ((app-rules
                  (cond
                   ((eq caller 'show-rewrites)
                    (applicable-rewrite-rules1
                     current-term
                     geneqv
                     (if (quotep current-term)
                         (global-val 'rewrite-quoted-constant-rules w)
                         (getpropc (ffn-symb current-term) 'lemmas nil w))
                     1 (or name rune) index w))
                   (t
                    (applicable-linear-rules1
                     current-term
                     (getpropc (ffn-symb current-term) 'linear-lemmas nil w)
                     1 (or name rune) index)))))
             (cond
              ((null app-rules)
               (cond (pl-p state)
                     ((and index (> index 1))
                      (fms "~|*** There are fewer than ~x0 applicable ~s1 ~
                            rules. ***~%"
                           (list (cons #\0 index)
                                 (cons #\1 (if (eq caller 'show-rewrites)
                                               "rewrite"
                                             "linear")))
                           (standard-co state) state
                           nil))
                     (t (fms "~|*** There are no applicable ~s0 rules. ***~%"
                             (list (cons #\0 (if (eq caller 'show-rewrites)
                                                 "rewrite"
                                               "linear")))
                             (standard-co state) state nil))))
              (t
               (show-rewrites-linears
                caller
                app-rules
                (floor (length app-rules) 10)
                abbreviations term-id-iff
                ens hyps-type-alist
                enabled-only-flg pl-p w state)))))))))))

(defun show-meta-lemmas1 (lemmas rule-id term wrld ens state)
  (cond
   ((endp lemmas) state)
   (t
    (pprogn
     (let* ((lemma (car lemmas))
            (rune (and (eq (access rewrite-rule lemma :subclass)
                           'meta)
                       (access rewrite-rule lemma :rune))))
       (cond ((and rune ; hence lemma is a meta lemma
                   (or (null rule-id)
                       (if (symbolp rule-id)
                           (eq rule-id (base-symbol rune))
                         (equal rule-id rune))))
              (let* ((fn (access rewrite-rule lemma :lhs))
                     (extendedp (access rewrite-rule lemma :rhs))
                     (args (meta-fn-args term extendedp ens state)))
                (mv-let
                 (erp new-term latches)
                 (ev-fncall-meta fn args state)
                 (declare (ignore latches))
                 (cond ((or erp
                            (equal new-term term)
                            (not (termp new-term wrld)))
                        state)
                       (t
                        (let ((hyp-fn (access rewrite-rule lemma :hyps)))
                          (mv-let
                           (erp hyp latches)
                           (if hyp-fn
                               (ev-fncall-meta
                                hyp-fn
                                (meta-fn-args term extendedp ens state)
                                state)
                             (mv nil *t* nil))
                           (declare (ignore latches))
                           (cond
                            ((or erp (not (termp hyp wrld)))
                             state)
                            (t
                             (fms
                              "~Y01~|~
                               ~ ~ New term: ~Y2t~|~
                               ~ ~ Hypothesis: ~Y3t~|~
                               ~ ~ Equiv: ~y4~|"
                              (list (cons #\0 rune)
                                    (cons #\1 nil)
                                    (cons #\2 new-term)
                                    (cons #\3 (untranslate hyp nil wrld))
                                    (cons #\4 (access rewrite-rule lemma
                                                      :equiv))
                                    (cons #\t
                                          (term-evisc-tuple nil state)))
                              (standard-co state) state nil))))))))))
             (t state)))
     (show-meta-lemmas1 (cdr lemmas) rule-id term wrld ens state)))))

(defun show-meta-lemmas (term rule-id ens state)
  (cond ((and (nvariablep term)
              (not (fquotep term))
              (not (flambdap (ffn-symb term))))
         (let ((wrld (w state)))
           (show-meta-lemmas1 (getpropc (ffn-symb term) 'lemmas nil wrld)
                              rule-id term wrld ens state)))
        (t state)))

(defun decoded-type-set-from-tp-rule (tp unify-subst wrld ens)
  (mv-let
   (ts type-alist ttree)
   (type-set-with-rule1 unify-subst
                        (access type-prescription tp :vars)
                        (ok-to-force-ens ens)
                        nil ; dwp, as in known-whether-nil (see relieve-hyp)
                        nil ; type-alist
                        nil ; ancestors
                        ens
                        wrld
                        (access type-prescription tp :basic-ts)
                        nil ; ttree
                        nil ; pot-lst
                        nil ; pt
                        nil ; backchain-limit
                        )
   (declare (ignore type-alist ttree))
   (decode-type-set ts)))

(defun show-type-prescription-rule (rule unify-subst type-alist abbreviations
                                         wrld ens state)
  (let ((rune (access type-prescription rule :rune))
        (nume (access type-prescription rule :nume))
        (hyps (access type-prescription rule :hyps)))
    (pprogn
     (fms "~x1~#2~[~/ (disabled)~]"
          (list (cons #\1 rune)
                (cons #\2 (if (enabled-numep nume ens) 0 1)))
          (standard-co state) state nil)
     (let ((fmt-string
            "~ ~ Type: ~Y01~|~
             ~ ~ Hypotheses: ~#b~[<none>~/~Y4t~]~|~
             ~ ~ Substitution: ~Yat~|~
             ~#5~[~/~
                  ~ ~ Remaining free variable: ~&6~/~
                  ~ ~ Remaining free variables: ~&6~sn~]~
             ~#7~[~/  WARNING:  One of the hypotheses is (equivalent to) NIL, ~
                  and hence will apparently be impossible to relieve.~]~|"))
       (mv-let
        (subst-hyps unify-subst ttree)
        (unrelieved-hyps rune hyps unify-subst type-alist nil wrld state ens nil)
        (declare (ignore ttree))
        (let ((free (reverse
                     (set-difference-assoc-eq (all-vars1-lst hyps nil)
                                              unify-subst))))
          (fms fmt-string
               (list (cons #\a (untranslate-subst-abb unify-subst abbreviations
                                                      state))
                     (cons #\b (if subst-hyps 1 0))
                     (cons #\0 (decoded-type-set-from-tp-rule rule unify-subst
                                                              wrld ens))
                     (cons #\1 nil)
                     (cons #\4 (untrans0-lst subst-hyps t abbreviations))
                     (cons #\5 (zero-one-or-more (length free)))
                     (cons #\6 free)
                     (cons #\n "")
                     (cons #\7 (if (member-eq nil subst-hyps) 1 0))
                     (cons #\t (term-evisc-tuple nil state)))
               (standard-co state) state nil)))))))

(defun show-type-prescription-rules1 (rules term rule-id type-alist
                                            abbreviations wrld ens state)
  (cond
   ((endp rules) state)
   (t (pprogn
       (mv-let (unify-ans unify-subst)
               (cond
                ((or (null rule-id)
                     (let ((rune (access type-prescription (car rules) :rune)))
                       (if (symbolp rule-id)
                           (eq rule-id (base-symbol rune))
                         (equal rule-id rune))))
                 (one-way-unify (access type-prescription (car rules) :term)
                                term))
                (t (mv nil nil)))
               (cond (unify-ans (show-type-prescription-rule
                                 (car rules) unify-subst type-alist
                                 abbreviations wrld ens state))
                     (t state)))
       (show-type-prescription-rules1 (cdr rules) term rule-id type-alist
                                      abbreviations wrld ens state)))))

(defun show-type-prescription-rules (term rule-id abbreviations all-hyps ens
                                          state)
  (cond ((and (nvariablep term)
              (not (fquotep term))
              (not (flambdap (ffn-symb term))))

; We could also rule out a function symbol of IF, but then we will get the
; message in the other case (see "(other than IF)" below) even with calls of
; :pl and :pl2 intended to show rewrite rules hung on IF.  So we just silently
; fail to show any type-prescription rules in the case of IF.

         (let ((wrld (w state)))
           (mv-let
            (flg hyps-type-alist ttree)
            (hyps-type-alist all-hyps ens wrld state)
            (declare (ignore ttree))
            (cond
             (flg ; contradiction, so hyps is non-nil: we are in proof-builder
              (fms "*** Contradiction in the hypotheses! ***~%The S command ~
                    should complete this goal.~|"
                   nil (standard-co state) state nil))
             (t (show-type-prescription-rules1
                 (getpropc (ffn-symb term) 'type-prescriptions nil wrld)
                 term rule-id hyps-type-alist abbreviations wrld ens
                 state))))))
        (t

; Presumably we are inside the proof-builder, since pl2-fn has already checked
; term.

         (fms "Type-prescription rules are associated with function symbols ~
               (other than IF).  The current term, ~x0, is therefore not ~
               suitable for listing associated type-prescription rules.~|"
              (list (cons #\0 term))
              (standard-co state) state nil))))

(defun pl2-fn (form rule-id caller state)
  (let ((ens (ens-maybe-brr state))
        (wrld (w state)))
    (er-let*
        ((term (translate form t t nil caller wrld state)))
      (cond
       ((not (or (symbolp rule-id)
                 (and (consp rule-id)
                      (keywordp (car rule-id)))))
        (er soft caller
            "The rule-id supplied to ~x0 must be a symbol or a rune, but ~x1 ~
             is neither.  See :DOC ~x0."
            caller rule-id))
       (t (mv-let
            (flg term1)
            (cond ((or (variablep term)
                       (flambdap (ffn-symb term)))
                   (mv t (remove-guard-holders term wrld)))
                  (t (mv nil term)))
            (cond ((or (variablep term1)
                       (flambdap (ffn-symb term1)))
                   (er soft caller
                       "~@0 must represent a term that is not a variable or a ~
                        LET (or LAMBDA application).  But ~x1 does not meet ~
                        this requirement."
                       (case caller
                         (pl (msg "A non-symbol argument of ~x0" caller))
                         (pl2 (msg "The first argument of ~x0" caller))
                         (otherwise (er hard 'pl2-fn
                                        "Implementation error: Unexpected case! ~
                                       ~ Please contact the ACL2 implementors.")))
                       form))
                  (t (let ((term term1))
                       (pprogn
                        (cond (flg (fms "+++++++++~%**NOTE**:~%Instead showing ~
                                       rules for the following term, which is ~
                                       much more likely to be encountered ~
                                       during proofs:~|~%  ~y0+++++++++~%"
                                        (list (cons #\0 (untranslate term1
                                                                     nil
                                                                     wrld)))
                                        (standard-co state) state nil))
                              (t state))
                        (show-rewrites-linears-fn
                         'show-rewrites rule-id nil ens term nil nil nil :none t
                         state)
                        (show-meta-lemmas term rule-id ens state)
                        (show-rewrites-linears-fn
                         'show-linears rule-id nil ens term nil nil nil :none t
                         state)
                        (show-type-prescription-rules term rule-id nil nil
                                                      ens state)
                        (value :invisible)))))))))))

(defun pl-fn (name0 state)
  (cond
   ((symbolp name0)
    (let* ((wrld (w state))
           (ens (ens-maybe-brr state))
           (name (deref-macro-name name0 (macro-aliases wrld))))
      (cond
       ((eq name 'quote)
        (print-info-for-rules
         (info-for-lemmas
          (global-val 'rewrite-quoted-constant-rules wrld)
          t ens wrld)
         (standard-co state) state))
       ((function-symbolp name wrld)
        (print-info-for-rules
         (append
          (info-for-lemmas
           (getpropc name 'lemmas nil wrld)
           t ens wrld)
          (info-for-linear-lemmas
           (getpropc name 'linear-lemmas nil wrld)
           t ens wrld)
          (info-for-type-prescriptions
           (getpropc name 'type-prescriptions nil wrld)
           t ens wrld)
          (info-for-forward-chaining-rules
           (getpropc name 'forward-chaining-rules nil wrld)
           t ens wrld)
          (info-for-eliminate-destructors-rules
           (getpropc name 'eliminate-destructors-rules nil wrld)
           t ens wrld)
          (info-for-induction-rules
           (getpropc name 'induction-rules nil wrld)
           t ens wrld))
         (standard-co state) state))
       (t (er soft 'pl
              "If the argument to PL is a symbol, then it must be a function ~
               symbol in the current world, the symbol QUOTE, or else a macro ~
               that is associated with a function symbol (see :DOC ~
               add-macro-alias).~@0"
              (cond
               ((getpropc name0 'macro-body)
                (msg "  Since ~x0 is a macro without such association, ~
                      consider applying PL to a call (~x0 ...); see :DOC pl."
                     name0))
               (t "")))))))
   (t (pl2-fn name0 nil 'pl state))))

(defmacro pl (name)
  (list 'pl-fn name 'state))

(defmacro pl2 (form rule-id)
  (list 'pl2-fn form rule-id ''pl2 'state))

; Essay on Include-book-dir-alist

; ACL2 supports three alists that associate keywords with absolute directory
; pathnames, to be used as values of the :dir argument of include-book and ld:
; the include-book-dir!-table, the :include-book-dir-alist field of the
; acl2-defaults-table, and the project-dir-alist.  The macros
; add-include-book-dir and add-include-book-dir! provide ways to extend these
; first two alists to allow additional legal values for :dir; see :DOC
; project-dir-alist regarding the third.  The remainder of this essay discusses
; some subtlety with the first two of these, and a solution.  (The
; project-dir-alist never changes throughout a session and therefore has no
; such issue.)

; Up through ACL2 Version_3.6.1, when add-include-book-dir was executed in raw
; Lisp it would be ignored, because it macroexpanded to a table event.  But
; consider a file loaded in raw Lisp, say when we are in raw-mode and are
; executing an include-book command with a :dir argument.  If that :dir value
; were defined by an add-include-book-dir event also evaluated in raw Lisp, and
; hence ignored, then that :dir value would not really be defined after all and
; the include-book would fail.

; The above problem with raw-mode could be explained away by saying that
; raw-mode is a hack, and you get what you get.  But Version_4.0 introduced the
; loading of compiled files before corresponding event processing, which causes
; routine evaluation of add-include-book-dir, add-include-book-dir!, and
; include-book in raw Lisp.

; Therefore we maintain for raw Lisp variants of these two alists: state
; globals 'raw-include-book-dir-alist and 'raw-include-book-dir!-alist.  The
; values of these variables are initially :ignore, meaning that we are to use
; the two tables, not the state globals.  But when the values are not :ignore,
; then they are alists to use in place of the corresponding table values.  We
; guarantee that every embedded event form that defines handling of :dir values
; for include-book does so in a manner that works when loading compiled files,
; and we weakly extend this guarantee to raw-mode as well (weakly, since we
; cannot perfectly control raw-mode; but a trust tag is necessary to enter
; raw-mode so our guarantee need not be ironclad).  The above :ignore value
; must then be set to a legitimate include-book-alist when inside include-book
; or (ideally) in raw-mode, and should remain :ignore when not in those
; contexts.  When the value of 'raw-include-book-dir-alist is not :ignore, then
; execution of add-include-book-dir will extend the value of
; 'raw-include-book-dir-alist instead of modifying the acl2-defaults-table.
; Whenever we execute include-book in raw Lisp, we use this value instead of
; the one in the acl2-defaults-table, by binding it to nil upon entry.  Thus,
; any add-include-book-dir will be local to the book, which respects the
; semantics of include-book.  We bind it to nil because that is also how
; include-book works: the acl2-defaults-table initially has an empty
; :include-book-dir-alist field (see process-embedded-events).  Of course,
; add-include-book-dir! corresponds to the include-book-dir!-table, not to the
; acl2-defaults-table, and its effect is not local to a book.  Thus, we handle
; 'raw-include-book-dir!-alist a bit differently from how we handle
; 'raw-include-book-dir-alist, though similarly: we bind it to nil in
; include-book-raw-top, at the top level of the entry into raw Lisp (for early
; load of compiled files) from include-book, bindings state global
; 'raw-include-book-dir!-alist to the current value of the
; include-book-dir!-table.

; In order to be able to rely on the above scheme, we disallow any direct table
; update of the include-book-dir!-table or of the :include-book-dir-alist field
; of the acl2-defaults-table.  We use the state global
; 'modifying-include-book-dir-alist for this purpose, which is globally nil but
; is bound to t by add-include-book-dir and related macros.  We insist that it
; be non-nil in chk-table-guard.  We considered making such a check instead in
; chk-embedded-event-form, but that would have been more awkward, and more
; importantly, it would have allowed such direct updates when developing a book
; interactively but not when certifying the book, which could provide a rude
; surprise to the user at certification time.

; End of Essay on Include-book-dir-alist

(defun acl2-defaults-table-local-ctx-p (state)
  (let ((wrld (w state)))
    (or (global-val 'include-book-path wrld)
        (f-get-global 'certify-book-info state)
        (in-encapsulatep (global-val 'embedded-event-lst wrld)
                         nil))))

(defun change-include-book-dir (keyword dir0 caller state)

; Caller is add-include-book-dir, add-include-book-dir!,
; delete-include-book-dir!, or delete-include-book-dir.  Dir0 is nil if and
; only caller is one of the latter two.

; See the Essay on Include-book-dir-alist.

  (declare (xargs :guard (state-p state)
                  :mode :program))
  (let* ((ctx (if dir0
                  (cons caller keyword)
                (msg "~x0" (list caller keyword))))
         (bang-p (member-eq caller '(add-include-book-dir!
                                     delete-include-book-dir!)))
         (dir (and dir0
                   (sysfile-to-filename dir0 state))))
    (cond ((not (if dir
                    (member-eq caller '(add-include-book-dir
                                        add-include-book-dir!))
                  (member-eq caller '(delete-include-book-dir
                                      delete-include-book-dir!))))

; We do this check at runtime, rather than in the guard, so that, for the sake
; of efficient execution, we can include it in the list of functions given to
; oneify-cltl-code whose *1* function is defined simply to call the raw Lisp
; function.  An added benefit is that we can check here that dir is not nil.

           (cond
            ((and (null dir)
                  (member-eq caller '(add-include-book-dir
                                      add-include-book-dir!)))
             (er soft ctx
                 "It is illegal to call ~x0 with a directory argument of nil."
                 caller))
            (t
             (er soft ctx
                 "Internal error: Illegal call of change-include-book-dir: ~
                  ~x0 is ~x1 but ~x2 is ~x3 (expected ~v4)."
                 'dir dir 'caller caller
                 (if dir
                     '(add-include-book-dir add-include-book-dir!)
                   '(delete-include-book-dir delete-include-book-dir!))))))
          ((not (keywordp keyword))
           (er soft ctx
               "The first argument of ~x0 must be a keyword other than ~
                :SYSTEM, but ~x1 is not."
               caller keyword))
          ((and dir (not (stringp dir)))
           (er soft ctx
               "The second argument of ~x0 must be a string or ~
                of the form (:keyword . string), but ~x1 is not."
               caller dir))
          (t
           (let* ((dir (and dir
                            (maybe-add-separator
                             (extend-pathname (cbd) dir state))))
                  (wrld (w state))
                  (fname (project-dir-lookup keyword
                                             (project-dir-alist wrld)
                                             nil))
                  (raw-p (raw-include-book-dir-p state)))
             (cond
              ((and fname
                    (not (equal fname dir)))
               (er soft ctx
                   "Illegal call of ~x0: it associates ~x1 with ~x2, yet ~x1 ~
                    is already bound to a different value, ~x3, in the ~
                    project-dir-alist (see :DOC project-dir-alist)."
                   caller keyword dir fname))
              (t
               (state-global-let*
                ((inhibit-output-lst (cons 'summary (@ inhibit-output-lst)))
                 (modifying-include-book-dir-alist t))
                (mv-let
                  (old alt)
                  (cond
                   (raw-p
                    (cond
                     (bang-p
                      (mv (f-get-global 'raw-include-book-dir!-alist
                                        state)
                          (f-get-global 'raw-include-book-dir-alist
                                        state)))
                     (t
                      (mv (f-get-global 'raw-include-book-dir-alist
                                        state)
                          (f-get-global 'raw-include-book-dir!-alist
                                        state)))))
                   (bang-p
                    (mv (table-alist 'include-book-dir!-table wrld)
                        (cdr (assoc-eq :include-book-dir-alist
                                       (table-alist 'acl2-defaults-table
                                                    wrld)))))
                   (t
                    (mv (cdr (assoc-eq :include-book-dir-alist
                                       (table-alist 'acl2-defaults-table
                                                    wrld)))
                        (table-alist 'include-book-dir!-table wrld))))
                  (let ((old-pair (assoc-eq keyword old))
                        (alt-pair (assoc-eq keyword alt)))
                    (cond
                     ((and dir
                           (not (absolute-pathname-string-p dir t (os wrld))))

; The call above of maybe-add-separator should make this branch dead code, but
; we leave it here for robustness, e.g., in case we change that call.

                      (er soft ctx
                          "The second argument of ~x0 must represent a ~
                           directory, in particular ending with character ~
                           '~s1', but ~x2 does not."
                          caller *directory-separator-string* dir))
                     ((and dir
                           (equal (cdr old-pair) dir))
                      (stop-redundant-event ctx state))
                     ((if dir
                          (or old-pair alt-pair) ; already bound
                        alt-pair)                ; bound in the wrong table
                      (mv-let
                        (other-add other-delete)
                        (cond (bang-p
                               (mv 'add-include-book-dir
                                   'delete-include-book-dir))
                              (t
                               (mv 'add-include-book-dir!
                                   'delete-include-book-dir!)))
                        (cond ((null dir) ; hence alt-pair
                               (er soft ctx
                                   "The keyword ~x0 was previously bound to ~
                                    directory ~x1 by a call of ~x2.  Perhaps ~
                                    you intended to call ~x3 instead of ~x4."
                                   keyword (cdr alt-pair) other-add other-delete
                                   caller))
                              (alt-pair
                               (er soft ctx
                                   "The keyword ~x0 was previously bound to ~
                                    directory ~x1 by a call of ~x2.  To bind ~
                                    ~x0 with ~x3 first evaluate ~x4."
                                   keyword
                                   (cdr alt-pair)
                                   other-add
                                   caller
                                   (list other-delete keyword)))
                              (t (er soft ctx
                                     "The keyword ~x0 was previously bound to ~
                                      directory ~x1.  If you intend to ~
                                      override the old setting with directory ~
                                      ~x2, first evaluate ~x3."
                                     keyword
                                     (cdr old-pair)
                                     dir
                                     (list (cond
                                            (bang-p 'delete-include-book-dir!)
                                            (t 'delete-include-book-dir))
                                           keyword))))))
                     ((and (null dir)
                           (null (cdr old-pair)))
                      (stop-redundant-event ctx state))
                     (t (let ((new (cond (dir (acons keyword dir old))
                                         (t (remove1-assoc-eq keyword old)))))
                          (er-progn
                           (cond
                            (raw-p
                             (pprogn
                              (cond
                               (bang-p
                                (f-put-global 'raw-include-book-dir!-alist
                                              new
                                              state))
                               (t
                                (f-put-global 'raw-include-book-dir-alist
                                              new
                                              state)))
                              (value nil)))
                            ((not bang-p)
                             (table-fn 'acl2-defaults-table
                                       (list :include-book-dir-alist
                                             (kwote new))
                                       state
                                       (list 'table
                                             'acl2-defaults-table
                                             ':include-book-dir-alist
                                             (kwote new))))
                            (dir
                             (table-fn 'include-book-dir!-table
                                       (list keyword (kwote dir))
                                       state
                                       (list 'table
                                             'include-book-dir!-table
                                             keyword
                                             (kwote dir))))
                            (t
                             (table-fn 'include-book-dir!-table
                                       (list nil (kwote new) :clear)
                                       state
                                       (list 'table
                                             'include-book-dir!-table
                                             nil
                                             (kwote new)
                                             :clear))))
                           (value new)))))))))))))))

(defun add-custom-keyword-hint-fn (key uterm1 uterm2 state)

; We translate uterm1 and uterm2 to check the syntactic requirements and we
; cause errors if we don't like what we see.  BUT we store the untranslated
; uterm1 and uterm2 in the custom-keywords-table!  The reason is that the
; invariant on the table cannot ensure that the terms there meet the
; requirements -- translated, single-threaded, error-triple signatured terms.
; So when we use the terms we find in the table we have to use trans-eval to
; (re-)translate and evaluate them.  Thus, we might as well store the pretty
; versions of the terms in case the user ever looks at them.

; Note: The new entry on the custom-keyword-hints-alist will be of the form
; (key uterm1 uterm2).  Uterm1 is the untranslated generator term and uterm2 is
; the untranslated checker term.

  (declare (xargs :guard (state-p state)
                  :mode :program))
  (let ((world (w state))
        (ctx 'add-custom-keyword-hint)
        (allowed-gvars
         '(val keyword-alist
               id clause world stable-under-simplificationp
               hist pspv ctx state))
        (allowed-cvars
         '(val world ctx state)))
    (er-let*
     ((term1 (translate-simple-or-error-triple uterm1 ctx world state))
      (term2 (translate uterm2 *error-triple-sig* nil '(state) ctx world
                        state)))
     (cond
      ((not (keywordp key))
       (er soft ctx
           "The first argument of add-custom-keyword-hint must be a keyword ~
            and ~x0 is not!"
           key))
      ((member-eq key *hint-keywords*)
       (er soft ctx
           "It is illegal to use the name of a primitive hint, ~e.g., ~x0, as ~
            a custom keyword hint."
           key))
      ((assoc-eq key
                 (table-alist 'custom-keywords-table (w state)))
       (er soft ctx
           "It is illegal to use the name of an existing custom keyword hint, ~
            e.g., ~x0.  Use remove-custom-keyword-hint first to remove the ~
            existing custom keyword hint of that name."
           key))
      ((not (subsetp-eq (all-vars term1) allowed-gvars))
       (er soft ctx
           "The second argument of add-custom-keyword-hint must be a term ~
            whose free variables are among ~%~Y01, but you provided the term ~
            ~x2, whose variables include~%~Y31."
           allowed-gvars
           nil
           uterm1
           (reverse (set-difference-eq (all-vars term1) allowed-gvars))))
      ((not (subsetp-eq (all-vars term2) allowed-cvars))
       (er soft ctx
           "The :checker argument of add-custom-keyword-hint must be a term ~
            whose free variables are among ~%~Y01, but you provided the term ~
            ~x2, whose variables include~%~Y31."
           allowed-cvars
           nil
           uterm2
           (reverse (set-difference-eq (all-vars term2) allowed-cvars))))
      (t
       (state-global-let*
        ((inhibit-output-lst (cons 'summary (@ inhibit-output-lst))))
        (let ((val (list uterm1 uterm2))) ; WARNING: Each term is UNtranslated
          (er-progn (table-fn 'custom-keywords-table
                              (list (kwote key) (kwote val))
                              state
                              (list 'table
                                    'custom-keywords-table
                                    (kwote key)
                                    (kwote val)))
                    (table-fn 'custom-keywords-table
                              'nil
                              state
                              '(table custom-keywords-table))))))))))

#-acl2-loop-only
(defmacro reset-prehistory (&rest args)
  (declare (ignore args))
  nil)

#+acl2-loop-only
(defmacro reset-prehistory (&whole event-form &optional pflg)

; Warning: If this event ever generates proof obligations, remove it from the
; list of exceptions in install-event just below its "Comment on irrelevance of
; skip-proofs".

  (declare (xargs :guard (member-eq pflg '(t nil))))
  (list 'reset-prehistory-fn
        (list 'quote pflg)
        'state
        (list 'quote event-form)))

(defmacro disable-ubt (&whole event-form &optional (arg ':disable-ubt))
  (list 'reset-prehistory-fn
        (or arg :disable-ubt)
        'state
        (list 'quote event-form)))

(defun reset-kill-ring (n state)
  (declare (xargs :guard (or (eq n t) (natp n))))
  (let ((n (if (eq n t)
               (length (f-get-global 'undone-worlds-kill-ring state))
             n)))
    (if n
        (pprogn (f-put-global 'undone-worlds-kill-ring (make-list n) state)
                (value :invisible))
      (value (f-get-global 'undone-worlds-kill-ring state)))))

(defun reset-prehistory-fn (pflg state event-form)

; Warning: If this event ever generates proof obligations, remove it from the
; list of exceptions in install-event just below its "Comment on irrelevance of
; skip-proofs".

  (with-ctx-summarized
   (if (and (consp event-form)
            (eq (car event-form) 'disable-ubt))
       (if (cdr event-form)
           (msg "( DISABLE-UBT ...)")
         (msg "( DISABLE-UBT)"))
     (msg "( RESET-PREHISTORY ~x0 ...)" pflg))
   (cond ((not (or (member-eq pflg '(t nil :disable-ubt))
                   (msgp pflg)))

; The guard on reset-prehistory guarantees that pflg is t or nil.  So we must
; be executing reset-prehistory-fn on behalf of disable-ubt, unless the call
; is made directly rather than by way of a macro -- in which case one is
; breaking the interface and doesn't deserve the very best error message!

          (er soft ctx
              "The optional argument of ~x0 must be the default, which is ~
               ~x1, or an expression whose evaluation result satisfies ~x2 ~
               (see :DOC msgp).  But that argument has evaluated to ~x3."
              'disable-ubt :disable-ubt 'msgp pflg))
         ((and (not (eq pflg t))
               (or (f-get-global 'certify-book-info state)
                   (eq (f-get-global 'ld-skip-proofsp state) 'include-book)
                   (f-get-global 'skip-reset-prehistory state)))
          (pprogn (observation ctx
                               "~x0 events with pflg not equal to ~x1 ~
                                are skipped when ~@2.  See :DOC ~
                                reset-prehistory."
                               'reset-prehistory
                               t
                               (cond
                                ((f-get-global 'certify-book-info state)
                                 "certifying books")
                                ((eq (f-get-global 'ld-skip-proofsp state)
                                     'include-book)
                                 "including books or during the second pass ~
                                  of an encapsulate")
                                (t "state global 'skip-reset-prehistory has a ~
                                    non-nil value")))
                  (value :skipped)))
         (t
          (let* ((wrld (w state))
                 (event-form (or event-form
                                 (list 'reset-prehistory pflg)))
                 (next-absolute-command-number
                  (next-absolute-command-number wrld))
                 (old-info (global-val 'command-number-baseline-info wrld))
                 (new-info
                  (if (or (eq pflg :disable-ubt)
                          (msgp pflg))
                      (change command-number-baseline-info old-info
                              :permanent-p
                              (cons next-absolute-command-number
                                    (if (eq pflg :disable-ubt)
                                        nil
                                      pflg)))
                    (change command-number-baseline-info
                            old-info
                            :permanent-p pflg
                            :current next-absolute-command-number))))
            (er-let*
             ((val
               (install-event (if (or (eq pflg :disable-ubt)
                                      (msgp pflg))
                                  :disable-ubt
                                :new-prehistory-set)
                              event-form
                              'reset-prehistory
                              0
                              nil
                              nil
                              nil
                              ctx
                              (global-set 'command-number-baseline-info
                                          new-info
                                          wrld)
                              state)))
             (er-progn (reset-kill-ring t state)
                       (value val))))))))

; Next we develop memoization table support.  We defer this way past hons.lisp
; because some functions we call are defined relatively late (at least that was
; the case when cltl-def-from-name was defined here).

(defun memoize-table-chk-commutative-msg (str fn val wrld)

; Function memoize-table-chk does a full check that the given fn/val pair is a
; legal entry for memoize-table in the given world.  Here we check in
; particular that if the :commutativity value is supplied in val, then it names
; a lemma in wrld stating the commutativity of fn.  This function always
; returns nil or else a message that reports an error using the same string
; (str) as is used by memoize-table-chk.

  (declare (xargs :guard (and (symbolp fn)
                              (not (eq (getpropc fn 'formals t wrld)
                                       t))
                              (symbol-alistp val))))
  (let ((commutative (cdr (assoc-eq :commutative val))))
    (cond ((null commutative) nil)
          ((not (eql (len (getpropc fn 'formals t wrld))
                     2))
           (msg "~@0~x1 is not a binary function symbol, so it is illegal to ~
                 specify a non-nil value of :commutative (here, ~x2) for ~
                 memoization of this function."
                str fn commutative))
          ((not (symbolp commutative))
           (msg "~@0Attempted to memoize ~x1 with a non-symbolp value of ~
                 :commutative, ~x2."
                str fn commutative))
          (t (let ((thm (getpropc commutative 'theorem nil wrld)))
               (cond ((null thm)
                      (msg "~@0The theorem ~x1 specified for :commutative ~
                            memoization of ~x2 does not exist."
                           str commutative fn))
                     ((case-match thm
                        (('equal (!fn x y) (!fn y x))
                         (cond ((and (variablep x)
                                     (variablep y)
                                     (not (eq x y)))
                                t)
                               (t nil)))
                        (& nil))
                      nil)
                     (t (msg "~@0The theorem ~x1 specified for :commutative ~
                              memoization of ~x2 does not have the expected ~
                              form.  See :DOC memoize."
                             str commutative fn))))))))

(defun non-memoizable-stobjs (stobjs-in wrld)
  (cond ((endp stobjs-in) nil)
        ((getpropc (car stobjs-in) 'non-memoizable nil wrld)
         (cons (car stobjs-in)
               (non-memoizable-stobjs (cdr stobjs-in) wrld)))
        (t (non-memoizable-stobjs (cdr stobjs-in) wrld))))

(defun filter-absstobjs (lst wrld abs conc)
  (cond ((endp lst) (mv (reverse abs) (reverse conc)))
        ((getpropc (car lst) 'absstobj-info nil wrld)
         (filter-absstobjs (cdr lst) wrld (cons (car lst) abs) conc))
        (t
         (filter-absstobjs (cdr lst) wrld abs (cons (car lst) conc)))))

; The following code supports print-gv.

(defun remove-stobjs-in-by-position (lst stobjs-in)
  (declare (xargs :guard (and (true-listp lst)
                              (true-listp stobjs-in)
                              (eql (length lst)
                                   (length stobjs-in)))))
  (cond ((endp lst) nil)
        ((car stobjs-in)
         (remove-stobjs-in-by-position (cdr lst) (cdr stobjs-in)))
        (t (cons (car lst)
                 (remove-stobjs-in-by-position (cdr lst) (cdr stobjs-in))))))

(defun add-suffix-to-fn (sym suffix)

; We add a suffix to sym, which is a legal function symbol, to create a new
; legal function symbol.  Thus, we avoid creating a name in the "COMMON-LISP"
; package, since ACL2 won't allow such a name to be a function symbol.

  (declare (xargs :guard (and (symbolp sym)
                              (stringp suffix))))
  (if (equal (symbol-package-name sym)
             *main-lisp-package-name*)
      (intern (concatenate 'string (symbol-name sym) suffix)
              "ACL2")
    (add-suffix sym suffix)))

(mutual-recursion

(defun fsubcor-var (vars terms form)

; This analogue of subcor-var uses fcons-term instead of cons-term, in order to
; avoid losing the structure of form.  For example, (fsubcor-var (x) ('3)
; (consp x)) evaluates to (consp '3) rather than to nil.

  (declare (xargs :guard (and (symbol-listp vars)
                              (pseudo-term-listp terms)
                              (equal (length vars) (length terms))
                              (pseudo-termp form))))
  (cond ((variablep form)
         (subcor-var1 vars terms form))
        ((fquotep form) form)
        (t (fcons-term (ffn-symb form)
                       (fsubcor-var-lst vars terms (fargs form))))))

(defun fsubcor-var-lst (vars terms forms)
  (declare (xargs :guard (and (symbol-listp vars)
                              (pseudo-term-listp terms)
                              (equal (length vars) (length terms))
                              (pseudo-term-listp forms))))
  (cond ((endp forms) nil)
        (t (cons (fsubcor-var vars terms (car forms))
                 (fsubcor-var-lst vars terms (cdr forms))))))

)

(mutual-recursion

(defun print-gv-substitute-p1 (bound term alist acc)

; Bound is a natural number, and alist pairs each variable in term with a
; term.  Acc accumulates an alist that associates each variable occurring in
; term with nil at the first occurrence and t afterwards.  We return the
; resulting acc, except that if any variable occurring twice (or more) in term
; is associated in alist with a term whose cons-count exceeds bound, then we
; return t.

  (cond ((variablep term)
         (let ((pair (assoc-eq term acc)))
           (cond ((null pair)
                  (acons term nil acc))
                 ((null (cdr pair))
                  (if (eql (cons-count-bounded-ac (cdr (assoc-eq term alist))
                                                  0 bound)
                           bound)
                      t
                    (put-assoc-eq term t acc)))
                 (t acc))))
        ((fquotep term) acc)
        (t (print-gv-substitute-p1-lst bound (fargs term) alist acc))))

(defun print-gv-substitute-p1-lst (bound termlist alist acc)
  (cond ((endp termlist) acc)
        (t (let ((acc (print-gv-substitute-p1 bound (car termlist) alist acc)))
             (cond ((eq acc t) t)
                   (t (print-gv-substitute-p1-lst bound (cdr termlist) alist
                                                  acc)))))))
)

(defun print-gv-substitute-p (substitute tguard vars args)
  (cond ((natp substitute)
         (not (eq (print-gv-substitute-p1 substitute
                                          tguard
                                          (pairlis$ vars args)
                                          nil)
                  t)))
        (t substitute)))

(defun print-gv-form (guard-fn guard tguard vars args ignorable substitute ctx
                               state)

; If tguard is non-nil, then guard is nil and should be created by
; untranslating tguard (perhaps after substitution).  Args are always in
; translated form.

  (let ((wrld (w state)))
    (er-let* ((tguard (if (and substitute ; if false, we don't need tguard
                               (null tguard))
                          (translate guard '(nil) nil t ctx wrld state)
                        (value tguard))))
      (cond
       ((print-gv-substitute-p substitute tguard vars args)
        (assert$
         tguard
         (value (untranslate (fsubcor-var vars args tguard) t wrld))))
       (t
        (let ((guard (if tguard
                         (untranslate tguard t wrld)
                       guard)))
          (value `(flet ((,guard-fn
                          ,vars
                          ,@(and ignorable
                                 `((declare (ignorable ,@vars))))
                          ,guard))
                    (,guard-fn ,@(untranslate-lst args nil wrld))))))))))

(defun print-gv-conjunct (guard-fn formals conjuncts args index
                                   len-all-conjuncts fn substitute ctx state)
  (cond
   ((endp conjuncts)
    (er soft ctx
        "It is surprising that ~x0 yields no conjunct of the guard of ~x1 ~
         that evaluates to ~x2.  Sorry!  Try ~x0 without the :conjunct ~
         keyword argument."
        'print-gv
        fn
        nil))
   (t (let* ((conjunct (car conjuncts))
             (alist (restrict-alist-to-all-vars (pairlis$ formals args)
                                                conjunct))
             (f1 (strip-cars alist))
             (a1 (strip-cdrs alist)))
        (er-let* ((form (print-gv-form guard-fn
                                       nil      ; guard
                                       conjunct ; tguard
                                       f1 a1 nil substitute ctx state)))
          (mv-let (erp stobjs-out/replaced-val state)
            (trans-eval-default-warning form ctx state t)
            (cond (erp
                   (value (msg "Evaluation causes an error:~|~x0"
                               conjunct)))
                  ((cdr stobjs-out/replaced-val)
                   (print-gv-conjunct guard-fn formals (cdr conjuncts) args
                                      (1+ index)
                                      len-all-conjuncts fn substitute ctx
                                      state))
                  (t
                   (value (msg "Showing guard conjunct (#~x0 of ~x1) that ~
                                evaluates to nil:~|~%~x2."
                               index len-all-conjuncts form))))))))))

(defun print-gv1 (info conjunct substitute ctx state)
  (cond
   ((not (or (booleanp substitute)
             (natp substitute)))
    (er soft 'print-gv
        "The :substitute keyword argument of PRINT-GV must evaluate to T, ~
         NIL, or a natural number."
        substitute))
   (t
    (let* ((fn (nth 0 info))
           (guard (nth 1 info))
           (wrld (nth 4 info))
           (guard-fn (add-suffix-to-fn fn "{GUARD}")))

; Note: (nth 2 fn-guard-stobjsin-args) is the stobjs-in of fn, but we don't
; need it.

      (revert-world
       (pprogn
        (set-w! wrld state)
        (let ((formals (formals fn wrld))
              (args (apply-user-stobj-alist-or-kwote
                     (user-stobj-alist state)
                     (nth 3 info)
                     nil)))
          (if conjunct
              (let ((conjuncts (flatten-ands-in-lit (guard fn nil wrld))))
                (print-gv-conjunct guard-fn formals conjuncts args 1
                                   (length conjuncts) fn substitute ctx state))
            (print-gv-form guard-fn guard nil formals args t substitute ctx
                           state)))))))))

(defun print-gv-fn (evisc-tuple conjunct substitute state)
  (prog2$
   (wormhole 'ev-fncall-guard-er-wormhole
             '(lambda (whs)
                (set-wormhole-entry-code whs :ENTER))
             nil
             `(er-progn
               (let ((info ; see save-ev-fncall-guard-er
                      (wormhole-data (f-get-global 'wormhole-status state))))
                 (cond ((null info)
                        (pprogn
                         (fms "There is no guard violation to debug.~|~%"
                              nil (standard-co state) state nil)
                         (value nil)))
                       (t
                        (er-let* ((val (print-gv1 info ',conjunct ',substitute
                                                  'print-gv state)))
                          (pprogn
                           (fms ,(if conjunct
                                     "~@0~|~%"
                                   "~x0~|~%")
                                (list (cons #\0 val))
                                (standard-co state) state ',evisc-tuple)
                           (value nil))))))
               (value :q))
             :ld-prompt  nil
             :ld-missing-input-ok nil
             :ld-always-skip-top-level-locals nil
             :ld-pre-eval-filter :all
             :ld-pre-eval-print  nil
             :ld-post-eval-print :command-conventions
             :ld-evisc-tuple nil
             :ld-error-triples  t
             :ld-error-action :error
             :ld-query-control-alist nil
             :ld-verbose nil)
   (value :invisible)))

(defun set-print-gv-defaults-fn (state evisc-tuple evisc-tuple-p
                                       conjunct conjunct-p
                                       substitute substitute-p)
  (declare (xargs :guard t :mode :program))
  (cond
   ((and (null evisc-tuple-p)
         (null conjunct-p)
         (null substitute-p)) ; optimization, really
    (value (f-get-global 'print-gv-defaults state)))
   (t
    (let ((ctx 'set-print-gv-defaults))
      (cond ((not (or (null evisc-tuple)
                      (eq evisc-tuple :restore)
                      (standard-evisc-tuplep evisc-tuple)))
             (er soft ctx
                 "Illegal evisc-tuple: ~x0"
                 evisc-tuple))
            ((not (or (booleanp conjunct)
                      (eq conjunct :restore)))
             (er soft ctx
                 "Illegal value for :conjunct (must be Boolean): ~x0"
                 conjunct))
            ((not (or (booleanp substitute)
                      (natp substitute)
                      (eq substitute :restore)))
             (er soft ctx
                 "Illegal value for :conjunct (must be Boolean or a natural ~
                  number): ~x0"
                 substitute))
            (t (let* ((alist (f-get-global 'print-gv-defaults state))
                      (alist (cond ((not evisc-tuple-p)
                                    alist)
                                   ((eq evisc-tuple :restore)
                                    (remove1-assoc-eq :evisc-tuple alist))
                                   (t
                                    (put-assoc-eq :evisc-tuple evisc-tuple alist))))
                      (alist (cond ((not conjunct-p)
                                    alist)
                                   ((eq conjunct :restore)
                                    (remove1-assoc-eq :conjunct alist))
                                   (t
                                    (put-assoc-eq :conjunct conjunct alist))))
                      (alist (cond ((not substitute-p)
                                    alist)
                                   ((eq substitute :restore)
                                    (remove1-assoc-eq :substitute alist))
                                   (t
                                    (put-assoc-eq :substitute substitute
                                                  alist)))))
                 (pprogn (f-put-global 'print-gv-defaults alist state)
                         (value alist)))))))))

(defmacro set-print-gv-defaults (&key (evisc-tuple 'nil evisc-tuple-p)
                                      (conjunct 'nil conjunct-p)
                                      (substitute 'nil substitute-p))
  `(set-print-gv-defaults-fn state
                             ,evisc-tuple ,evisc-tuple-p
                             ,conjunct ,conjunct-p
                             ,substitute ,substitute-p))

(defmacro print-gv-evisc-tuple ()
  '(evisc-tuple nil                     ; print-level
                nil                     ; print-length
                (world-evisceration-alist state nil)
                nil ; hiding-cars
                ))

(defmacro print-gv-default (key)
  (declare (xargs :guard (member-eq key ; avoid capture
                                    '(:evisc-tuple
                                      :conjunct
                                      :substitute))))
  (let* ((name (symbol-name key))
         (key-p (intern (concatenate 'string name "-P") "ACL2"))
         (default (if (eq key :evisc-tuple)
                      '(print-gv-evisc-tuple)
                    nil)))
    `(cond (,key-p ,(intern name "ACL2"))
           (t '(let ((pair (assoc-eq ,key (f-get-global 'print-gv-defaults state))))
                 (if pair (cdr pair) ,default))))))

(defmacro print-gv (&key (evisc-tuple 'nil evisc-tuple-p)
                         (conjunct 'nil conjunct-p)
                         (substitute 'nil substitute-p))
  `(print-gv-fn ,(print-gv-default :evisc-tuple)
                ,(print-gv-default :conjunct)
                ,(print-gv-default :substitute)
                state))

(defun disable-iprint-ar (state)
  (cond ((iprint-enabledp state)

; A comment in rollover-iprint-ar explains conditions that allow a certain
; multiplier of 4 to enable maintenance of the invariant that the
; maximum-length of the iprint-ar is always at least four times the dimension.
; We support that reasoning here by making sure that we do not create
; successive entries with index 0.  Note that compress1 does not change the
; array's alist since the :order in its header is :none.

         (let* ((iprint-ar (f-get-global 'iprint-ar state))
                (last-index (aref1 'iprint-ar iprint-ar 0)))
           (pprogn (f-put-global 'iprint-ar
                                 (compress1 'iprint-ar
                                            (acons 0
                                                   (list last-index)
                                                   (if (eql (caar iprint-ar) 0)
                                                       (cdr iprint-ar)
                                                     iprint-ar)))
                                 state)
                   (mv t state))))
        (t (mv nil state))))

(defun enable-iprint-ar (state)
  (cond ((not (iprint-enabledp state))

; See the comment in disable-iprint-ar about an invariant.

         (let* ((iprint-ar (f-get-global 'iprint-ar state))
                (last-index (car (aref1 'iprint-ar iprint-ar 0))))
           (pprogn (f-put-global 'iprint-ar
                                 (compress1 'iprint-ar
                                            (acons 0
                                                   last-index
                                                   (if (eql (caar iprint-ar) 0)
                                                       (cdr iprint-ar)
                                                     iprint-ar)))
                                 state)
                   (mv t state))))
        (t (mv nil state))))

(defconst *iprint-actions*
  '(t nil :reset :reset-enable :same))

(defun set-iprint-fn1 (x state)
  (cond
   ((eq x :same)
    (mv nil state))
   ((null x)
    (mv-let (result state)
            (disable-iprint-ar state)
            (cond (result (mv "Iprinting has been disabled." state))
                  (t (mv "Iprinting remains disabled." state)))))
   ((eq x t)
    (mv-let (result state)
      (enable-iprint-ar state)
      (cond (result (mv "Iprinting has been enabled." state))
            (t (mv "Iprinting remains enabled." state)))))
   ((member-eq x '(:reset :reset-enable))
    (pprogn
     (f-put-global 'iprint-ar
                   (compress1
                    'iprint-ar
                    (init-iprint-ar (f-get-global 'iprint-hard-bound state)
                                    (eq x :reset-enable)))
                   state)
     (mv (cond ((eq x :reset-enable)
                "Iprinting has been reset and enabled.")
               (t
                "Iprinting has been reset and disabled."))
         state)))
   (t

; This is odd!  Apparently we didn't cover all the cases in *iprint-actions*
; above, even though we thought we checked in set-iprint-fn that we are in one
; such case.

    (mv (er hard 'set-iprint-fn1
            "Implementation error!  Please contact the ACL2 implementors.")
          state))))

(defun init-iprint-fal+ (sym ctx state)
  (mv-let (msg state)
    (init-iprint-fal sym state)
    (cond (msg (observation ctx "~@0" msg))
          (t state))))

(defun set-iprint-fn (action0 share share-p
                              soft-bound soft-bound-p
                              hard-bound hard-bound-p
                              ctx state)
  (cond
   ((not (member-eq action0 *iprint-actions*))
    (er soft ctx
        "Unknown option, ~x0.  The legal iprint actions are ~&1."
        action0 *iprint-actions*))
   (t
    (let ((action (cond ((or share-p hard-bound-p)
                         (case action0
                           ((t) :reset-enable)
                           ((nil) :reset)
                           ((:same) (if (iprint-enabledp state)
                                        :reset-enable
                                      :reset))
                           (otherwise
                            (assert$ (member-eq action0
                                                '(:reset :reset-enable))
                                     action0))))
                        (t action0))))
      (cond
       ((not (symbolp share))
        (er soft ctx
            "The :share argument for iprinting must be a symbol, but ~x0 is not."
            share))
       ((and soft-bound-p
             (not (posp soft-bound)))
        (er soft ctx
            "The :SOFT-BOUND argument of SET-IPRINT must be a positive ~
             integer, but ~x0 is not."
            soft-bound))
       ((and hard-bound-p
             (not (posp hard-bound)))
        (er soft ctx
            "The :HARD-BOUND argument of SET-IPRINT must be a positive ~
             integer, but ~x0 is not."
            hard-bound))
       (t (pprogn (cond ((not (eq action action0))
                         (warning$ 'set-iprint "Iprint"
                                   "Converting SET-IPRINT action from ~x0 to ~
                                    ~x1, as required by use of keyword :SHARE ~
                                    or :HARD-BOUND.  See :DOC set-iprint."
                                   action0 action))
                        (t state))
                  (pprogn (cond
                           (soft-bound-p
                            (pprogn (f-put-global 'iprint-soft-bound
                                                  soft-bound
                                                  state)
                                    (observation ctx
                                                 "The soft-bound for ~
                                                  iprinting has been set to ~
                                                  ~x0."
                                                 soft-bound)))
                           (t state))
                          (cond
                           (hard-bound-p
                            (pprogn (f-put-global 'iprint-hard-bound
                                                  hard-bound
                                                  state)
                                    (observation ctx
                                                 "The hard-bound for ~
                                                  iprinting has been set to ~
                                                  ~x0."
                                                 hard-bound)))
                           (t state))
                          (cond ((eq share :same)
                                 (if (member-eq action
                                                '(:reset :reset-enable))
                                     (init-iprint-fal+ :same ctx state)
                                   state))
                                ((eq share nil)
                                 (init-iprint-fal+ share ctx state))
                                (t (init-iprint-fal+ share ctx state)))
                          (mv-let (msg state)
                            (set-iprint-fn1 action state)
                            (pprogn (cond (msg (observation ctx "~@0" msg))
                                          (t state))
                                    (value :invisible)))))))))))

(defmacro set-iprint (&optional (action ':reset ; default ignored
                                        action-p)
                                &key
                                (share ':same share-p)
                                (soft-bound '1 ; default ignored
                                            soft-bound-p)
                                (hard-bound '1 ; default ignored
                                            hard-bound-p))
  (declare (xargs :guard ; the setters deal with illegal values
                  t))
  `(mv-let
     (action action-p share share-p
             soft-bound soft-bound-p
             hard-bound hard-bound-p)
     (mv ,action ,action-p ,share ,share-p
         ,soft-bound ,soft-bound-p
         ,hard-bound ,hard-bound-p)
     (er-let* ((action
                (if action-p
                    (value action)
                  (acl2-query
                   :set-iprint
                   '("Action"
                     :t t :nil nil
                     :reset :reset :reset-enable :reset-enable :same :same
                     :q :q
                     :? ("reply with :Q to quit, or else with one of the ~
                          options to set-iprint, which are ~&0 (see :DOC ~
                          set-iprint)"
                         :t t :nil nil
                         :reset :reset :reset-enable :reset-enable
                         :same :same
                         :q :q))
                   (list (cons #\0 *iprint-actions*))
                   state))))
       (cond ((eq action :q)
              (silent-error state))
             (t (set-iprint-fn action share share-p
                               soft-bound soft-bound-p
                               hard-bound hard-bound-p
                               'set-iprint state))))))

; We develop code for setting evisc-tuples.

(defconst *evisc-tuple-sites*
  '(:TERM :LD :TRACE :ABBREV :GAG-MODE :BRR))

(defun set-brr-evisc-tuple1 (val state)

; This function is untouchable because it assumes val is a legal
; brr-evisc-tuple, i.e., either :default or a standard-evisc-tuplep.

  #-acl2-loop-only
  (setq *wormhole-brr-evisc-tuple* val)
  (f-put-global 'brr-evisc-tuple val state))

(defun set-site-evisc-tuple (site evisc-tuple ctx state)

; This function is untouchable because it assumes that evisc-tuple is legal.
; Note that the special case where site is :trace and evisc-tuple is t is
; handled specially by set-evisc-tuple-fn; set-site-evisc-tuple is not called
; in that case.

  (declare (xargs :guard (and (member-eq site *evisc-tuple-sites*)
                              (or (null evisc-tuple)
                                  (eq evisc-tuple :default)
                                  (and (eq site :gag-mode)
                                       (eq evisc-tuple t))
                                  (standard-evisc-tuplep evisc-tuple))
                              (state-p state))))
  (case site
    (:TERM     (f-put-global 'term-evisc-tuple evisc-tuple state))
    (:ABBREV   (f-put-global 'abbrev-evisc-tuple evisc-tuple state))
    (:GAG-MODE (f-put-global 'gag-mode-evisc-tuple evisc-tuple state))
    (:LD       (f-put-global 'ld-evisc-tuple
                             (if (eq evisc-tuple :default) nil evisc-tuple)
                             state))
    (:TRACE    (set-trace-evisc-tuple
                (if (eq evisc-tuple :default) nil evisc-tuple)
                state))
    (:BRR      (set-brr-evisc-tuple1 evisc-tuple state))
    (otherwise (prog2$ (er hard ctx
                           "Implementation Error: Unrecognized keyword, ~x0.  ~
                            Expected evisc-tuple site: ~v1"
                           site *evisc-tuple-sites*)
                       state))))

(defun chk-evisc-tuple (evisc-tuple ctx state)
  (cond ((or (null evisc-tuple)
             (eq evisc-tuple :default)
             (standard-evisc-tuplep evisc-tuple))
         (value nil))
        (t (er soft ctx
               "Illegal evisc-tuple argument, ~x0.  See :DOC set-evisc-tuple."
               evisc-tuple))))

(defun set-evisc-tuple-lst (keys evisc-tuple acc ctx state)

; This function is untouchable because it assumes that evisc-tuple is legal.

  (cond ((endp keys)
         (value (reverse acc)))
        (t (pprogn (set-site-evisc-tuple (car keys) evisc-tuple ctx state)
                   (set-evisc-tuple-lst (cdr keys) evisc-tuple
                                        (cons (car keys) acc)
                                        ctx state)))))

(defun set-evisc-tuple-fn1 (keys all-keys evisc-tuple acc ctx state)

; This function is untouchable because it assumes that evisc-tuple is legal.

  (declare (xargs :guard (and (symbol-listp keys)
                              (symbol-listp all-keys)
                              (standard-evisc-tuplep evisc-tuple)
                              (symbol-listp acc)
                              (state-p state))))
  (cond ((endp keys)
         (let ((lst (reverse acc)))
           (set-evisc-tuple-lst lst evisc-tuple nil ctx state)))
        (t
         (er-let*
          ((ans
            (acl2-query
             :set-evisc-tuple
             '("Do you wish to set ~s0?"
               :y t :n nil :all :all :rest :rest :q :q :abort :abort
               :? ("reply with REST to set ~s0 and all remaining ~
                    evisc-tuples, ALL to set all evisc-tuples, Q to set only ~
                    the evisc-tuples already specified, or ABORT to quit ~
                    without setting any evisc-tuples at all; or reply with Y ~
                    or N to set or not to set (respectively) ~s0 before ~
                    considering whether to set other evisc-tuples"
                   :y t :n nil :all :all :rest :rest :q :q :abort :abort))
             (list (cons #\0 (string-append (symbol-name (car keys))
                                            "-EVISC-TUPLE")))
             state)))
          (case ans
            ((:REST :ALL :Q)
             (let ((lst (case ans
                          (:REST keys)
                          (:ALL  all-keys)
                          (:Q    (reverse acc)))))
               (set-evisc-tuple-lst lst evisc-tuple nil ctx state)))
            (:ABORT
             (value nil))
            (otherwise
             (set-evisc-tuple-fn1 (cdr keys) all-keys evisc-tuple
                                  (if ans (cons (car keys) acc) acc)
                                  ctx state)))))))

(defun iprint-virginp (state)
  (and (not (iprint-enabledp state))
       (let* ((iprint-ar (f-get-global 'iprint-ar state))
              (bound (default 'iprint-ar iprint-ar)))
         (and (null bound)
              (int= 0 (iprint-last-index* iprint-ar))))))

(defun set-evisc-tuple-fn (evisc-tuple
                           iprint iprint-p
                           sites sites-p
                           state)

; This function checks standard-evisc-tuplep, so it need not be untouchable.

  (let ((ctx 'set-evisc-tuple)
        (fail-string "The legal values for :SITES are :ALL and either members ~
                      or subsets of the list ~x0.  The :SITES ~x1 is thus ~
                      illegal.  See :DOC set-evisc-tuple."))
    (cond
     ((eq evisc-tuple t)
      (cond ((null sites)
             (er soft ctx
                 "The :SITES argument is required for set-evisc-tuple when a ~
                  value of T is specified, in which case :SITES should ~
                  specify :TRACE and/or :GAG-MODE.~ ~ See :DOC ~
                  set-evisc-tuple."))
            ((not (or (and (true-listp sites)
                           (subsetp-eq sites *evisc-tuple-sites*))
                      (member-eq sites *evisc-tuple-sites*)))
             (er soft ctx
                 fail-string
                 *evisc-tuple-sites*
                 sites))
            (t (let ((sites (if (symbolp sites) (list sites) sites)))
                 (cond ((not (subsetp-eq sites '(:trace :gag-mode)))
                        (er soft ctx
                            "You have called set-evisc-tuple with an ~
                             `evisc-tuple' of T.  The only :SITES for which ~
                             this is legal are :TRACE and :GAG-MODE, but you ~
                             have supplied ~&0."
                            sites))
                       (t (pprogn
                           (cond ((member-eq :TRACE sites)
                                  (set-trace-evisc-tuple t state))
                                 (t state))
                           (cond ((member-eq :GAG-MODE sites)
                                  (f-put-global 'gag-mode-evisc-tuple t state))
                                 (t state))
                           (value sites))))))))
     (t
      (er-progn
       (chk-evisc-tuple evisc-tuple ctx state)
       (cond (iprint-p (set-iprint-fn iprint :same nil
                                      nil nil
                                      nil nil
                                      ctx state))
             ((not (iprint-virginp state))
              (value nil))
             (t (set-iprint)))
       (cond ((null sites-p)
              (set-evisc-tuple-fn1 *evisc-tuple-sites* *evisc-tuple-sites*
                                   evisc-tuple nil ctx state))
             ((eq sites :ALL)
              (set-evisc-tuple-lst *evisc-tuple-sites* evisc-tuple nil ctx
                                   state))
             ((and (true-listp sites)
                   (subsetp-eq sites *evisc-tuple-sites*))
              (set-evisc-tuple-lst sites evisc-tuple nil ctx state))
             ((member-eq sites *evisc-tuple-sites*)
              (set-evisc-tuple-lst (list sites) evisc-tuple nil ctx state))
             (t
              (er soft ctx
                  fail-string
                  *evisc-tuple-sites*
                  sites))))))))

(defmacro set-evisc-tuple (evisc-tuple
                           &key
                           (iprint 'nil ; irrelevant default
                                   iprint-p)
                           (sites 'nil ; irrelevant default
                                  sites-p))
  `(set-evisc-tuple-fn ,evisc-tuple
                       ,iprint ,iprint-p
                       ,sites ,sites-p
                       state))

(defmacro top-level (form &rest declares)
  `(mv-let (erp val state)
           (ld '((pprogn ; ensure initialization
                  (f-put-global 'top-level-errorp nil state)
                  (value :invisible))
                 (with-output
                  :off :all
                  :on error
                  (defun top-level-fn (state)
                    (declare (xargs :mode :program :stobjs state)
                             (ignorable state))
                    ,@declares
                    ,form))
                 (ld '((pprogn
                        (f-put-global 'top-level-errorp t state)
                        (value :invisible))
                       (top-level-fn state)
                       (pprogn
                        (f-put-global 'top-level-errorp nil state)
                        (value :invisible)))
                     :ld-post-eval-print :command-conventions
                     :ld-error-action :return
                     :ld-error-triples t

; Do we want to allow this macro to be called inside code?  There's no obvious
; reason why not.  So we need to specify the following keyword.

                     :ld-user-stobjs-modified-warning :same)
                 (with-output
                  :off :all
                  :on error
                  (ubt! 'top-level-fn)))
               :ld-pre-eval-print nil
               :ld-post-eval-print nil
               :ld-error-action :error ; in case top-level-fn fails
               :ld-error-triples t
               :ld-verbose nil
               :ld-prompt nil
; See comment above about :ld-user-stobjs-modified-warning.
               :ld-user-stobjs-modified-warning :same)
           (declare (ignore erp val))
           (mv (@ top-level-errorp) :invisible state)))

; We introduce defwarrant here (along with some related and supporting
; utilities) in support of defattach.

; As described in the ``BTW'' notes in the DEFWARRANT section of apply.lisp,
; we need to convert the lemma provided by defun-sk into an effective rewrite
; rule.  To do that we need a hint and this function creates that hint.

(defun necc-name-ARGS-instance (ilks)

; This odd little function is used to generate an :instance hint.  Search below
; for :instance to see the application.  But imagine that you wanted a concrete
; list, e.g., '(x y z), of actuals satisfying the given ilks, e.g., (NIL :FN
; :EXPR).  Then, for this example, a suitable list would be '(NIL EQUAL T).
; (Indeed, so would '(NIL ZP NIL), but we just need some suitable list.)  We
; generate it here.  Note that the resulting list will be QUOTEd, so we return
; evgs here.

  (declare (xargs :guard (true-listp ilks) :mode :logic))
  (cond ((endp ilks) nil)
        ((eq (car ilks) :fn)
         (cons 'EQUAL (necc-name-ARGS-instance (cdr ilks))))
        ((eq (car ilks) :expr)
         (cons T (necc-name-ARGS-instance (cdr ilks))))
        (t (cons NIL (necc-name-ARGS-instance (cdr ilks))))))

(defun defwarrant-events (fn formals bdg)

; Bdg must be a legal badge for (fn . formals).

; This function returns a list of events that add the appropriate defun-sk
; event for fn and then proves the necessary rewrite rule.

  (declare (xargs :mode :program))
  (let* ((name (warrant-name fn))
         (rule-name (apply$-rule-name fn))
         (necc-name (intern-in-package-of-symbol
                     (coerce
                      (append (coerce (symbol-name name) 'list)
                              '(#\- #\N #\E #\C #\C))
                      'string)
                     fn)))
    (cond
     ((eq (access apply$-badge bdg :ilks) t)
      `(,(make-apply$-warrant-defun-sk fn formals bdg nil) ; trans1-flg = nil
; Make the appropriate defun-sk form.  It will be translated when admitted.
        (in-theory (disable ,(definition-rule-name name)))
        (defthm ,rule-name
          (implies
           (force (,(warrant-name fn)))
           (and (equal (badge ',fn) ',bdg)
                (equal (apply$ ',fn args)
                       ,(if (eql (access apply$-badge bdg :out-arity) 1)
                            `(,fn ,@(successive-cadrs formals 'args))
                            `(mv-list
                              ',(access apply$-badge bdg :out-arity)
                              (,fn ,@(successive-cadrs formals 'args)))))))
          :hints (("Goal" :use ,necc-name
                   :expand ((:free (x) (HIDE (badge x))))
                   :in-theory (e/d (badge apply$)
                                   (,necc-name ,fn)))))))
     (t
      (let* ((hyp-list (tameness-conditions (access apply$-badge bdg :ilks)
                                            'ARGS))
             (hyp (if (null (cdr hyp-list))
                      (car hyp-list)
                      `(AND ,@hyp-list))))
        `(,(make-apply$-warrant-defun-sk fn formals bdg nil) ; trans1-flg = nil
; Make the appropriate defun-sk form.  It will be translated when admitted.
          (in-theory (disable ,(definition-rule-name name)))
          (defthm ,rule-name
            (and (implies (force (,(warrant-name fn)))
                          (equal (badge ',fn) ',bdg))
                 (implies
                  (and (force (,(warrant-name fn)))
                       ,hyp)
                  (equal (apply$ ',fn args)
                         ,(if (eql (access apply$-badge bdg :out-arity) 1)
                              `(,fn ,@(successive-cadrs formals 'args))
                              `(mv-list
                                ',(access apply$-badge bdg :out-arity)
                                (,fn ,@(successive-cadrs formals 'args)))))))

; Notice that the necc-name theorem is of the form (forall (args) (and ...))
; but the theorem above is essentially (and ... (forall (args) ...)) because
; the first conjunct is free of ARGS.  We had to write necc-name that way
; because of the requirements of defun-sk.  But now we have to extract the fact
; that we know (APPLY$-WARRANT fn) --> (badge 'fn) = <whatever>, by instantiating
; necc-name with a suitable ARGS that makes the right components suitably tame.

; The first :instance below takes care of the badge conjunct and the second
; takes care of the apply$ conjunct.

            :hints
            (("Goal"
              :use ((:instance ,necc-name
                               (ARGS ',(necc-name-ARGS-instance
                                        (access apply$-badge bdg :ilks))))
                    (:instance ,necc-name))
              :expand ((:free (x) (HIDE (badge x))))
              :in-theory (e/d (badge apply$)
                              (,necc-name)))))))))))

; Essay on Defattach

; In this essay we discuss both the implementation of defattach and its logical
; characterization.

; We begin this essay with some terminology, starting with concepts that
; permeate logic and ACL2 and then defattach-specific notions.

; Theory:  a deductively closed set of first-order sentences

; Chronology: a sequence of events that is admissible by ACL2 (but here
; ignoring table events and other extra-logical events)

; History: a subsequence of a chronology consisting of axiomatic events (defun,
; defchoose, non-trivial encapsulate, defaxiom)

; Theory (of a chronology or of a history): The obvious extension of the idea
; of the theory of a set of first order sentences.  Every (logical) event
; naturally corresponds to a first-order sentence; the theory of a chronology
; or history is just its deductive closure (viewing a sequence as a set).  If
; ACL2 is sound then the theory of a chronology is the same as the theory of
; the corresponding history: that is, the non-axiomatic events of a chronology
; are all first-order provable from its axiomatic events.

; Standard Model: The standard model of Peano axioms is the set of natural
; numbers together with the usual operators.  In particular, there are no
; objects in the standard model that don't correspond with some natural, e.g.,
; there is no object having an infinite number of predecessors as one could
; arrange by adding the consistent infinite set of axioms of the form n < C,
; for every natural number n.  The standard model of ACL2 is just Common Lisp
; on a machine with unlimited memory and no ``bad atoms,'' e.g., the only
; objects in the model are the objects you can type in.

; Substitution (of a defattach event): We refer to the "substitution of"
; a defattach event, i.e. its "attachment substitution" or "attachment-alist",
; as the functional substitution specified in the event.  An "attachment pair"
; <f,g> is an ordered pair of function symbols f and g such that g is the
; "current attachment" of f: that is, <f,g> is a pair from the substitution of
; a defattach event active in the current ACL2 world.  If <f.g> is an
; attachment pair, then the corresponding "attachment axiom" is defined to be
; the formula (equal (f x1 ... xk) (g x1 ... xk)), where the xi are the formals
; of f.  When we treat this attachment axiom as an event, we consider it
; logically to be a defun event that introduces f, in an "evaluation history"
; as described below.  Note that we only admit attachment pairs <f,g> with the
; same signatures (up to renaming of formals).

; In what follows we allow defaxiom events.  However, we insist on the
; following

; Defaxiom Restriction for Defattach: no ancestor (according to the
; transitive closure of the immediate-supporter relation) of a defaxiom event
; has an attachment.

; Most of the focus in this essay is on logical issues related to defattach,
; but we first say a few words about the implementation.

; In one sense we must disallow attachments to functions introduced by defun,
; since we need to generate our own defuns for attachable functions.  We can
; allow such attachments for logical purposes, however.  Consider the following
; silly example.

; (defstub f (x) t)
; (defun g (x)
;   (f x))
; (encapsulate ((h (x) t))
;   (local (defun h (x) (g x)))
;   (defthm h-prop
;     (equal (h x) (g x))))

; Imagine attaching acl2-numberp to f and also to h.  Our proof obligations are
; obtained by applying the attachment substitution to the conjunction of the
; constraints on f and h, in this case (equal (h x) (g x)).  Thus we must prove
; (equal (acl2-numberp x) (g x)) in the current ACL2 world.  But in that world
; we do not know that g is acl2-numberp.  The solution is to attach
; acl2-numberp to g as well (which also forces the definitional equation of g
; to be added to the constraints which must be instantiated and proved).
; Defattach has a syntax, :attach nil, that specifies that an attachment is not
; to be installed for execution even though the attachment pair is recorded for
; the defattach; and that syntax would need to be used in the case of g.

; Thus, we only allow attachments for execution to functions introduced in
; signatures of encapsulate events.  (We do not expect attachments to defchoose
; functions, which can be simulated anyhow by using suitable wrappers.  But if
; such support becomes necessary, then we can probably provide it.)

; Of course, users can experiment with defattach without concern for proof
; obligations, by wrapping skip-proofs around defattach events.

; Since ACL2 supports two theories -- the current theory and its corresponding
; evaluation theory (described below) -- we add an argument to all ev functions
; (ev-w, ev-fncall, etc.), aok, specifying whether or not to use attachments.
; We will tend to use attachments at the top level but not in logical contexts,
; hence not under waterfall-step except in subroutines where it is again
; appropriate, such as evaluation of syntaxp expressions (ev-synp), meta rules,
; and clause-processor rules (see the Essay on Correctness of Meta Reasoning).
; Note that ev-fncall-rec-logical really needs this information.  With this
; fine-grained control of which of the two theories to use, we can for example
; arrange that mfc-rewrite behave the same inside syntaxp as does rewrite (at
; the top level), as suggested by Robert Krug.

; We next describe the implementation of defattach as an event.  In particular:
; Why is it a separate event type, rather than a macro that generates some
; other kind of event?

; We first considered following the precedent of :induction rules, using
; defthm.  But the user might find it unintuitive if defattach were skipped in
; :program mode, yet defthm is so skipped.  Moreover, we expected to generate
; Lisp code to do the attachment, but defthm doesn't generate any 'cltl-command
; property.

; We thus tentatively decided to implement defattach as a table event.  As a
; bonus, implementing defattach as a table event meant that we could follow the
; precedent of memoize/unmemoize.

; However, using a table event would be awkward.  If several attachments are
; made together (say, because several functions share a single constraint),
; then in order to remove one of those attachments, soundness demands that we
; remove them all.  (For, why did we require them all to be attached together
; in the first place?  Perhaps because we needed all those instantiations to be
; made together in order to prove the instantiated constraint.)  So undoing
; can't be done one function at a time, really; it needs to be atomic.  That
; could be managed, but it "feels" like it could potentially be awkward with
; table events.

; A bigger concern is that through Version_3.6.1, table events have not
; involved proof obligations, as indicated by a comment at the top of table-fn.
; Even merely expressing proof obligations in the language of tables seems
; awkward, unless perhaps we explicitly name each theorem that must be proved
; and refer to it by name in the table event.  And note that although we can do
; some fancy things within the context of table events (for example memoize
; generates a 'cltl-command), it seems much simpler not to have to do so in
; this case.

; It seems more natural, then, to invent a new event to handle attachment,
; rather than having defattach be a macro that expands to an existing event.
; At the time we started our implementation of defattach, there seemed to be
; fewer than 40 occurrences of set-body in the code, as determined by:
;   fgrep -i set-body /projects/acl2/devel/saved/*.lisp | wc -l
; So, we used set-body as a model for adding a new event.

; In general, we pick a canonical representative for the set of function
; symbols to which a defattach event is making attachments; call that
; representative f.  Then the 'attachment property of f is an alist matching
; function symbols to their attachments (including f); but the other function
; symbols in the nest have an 'attachment property of f -- reminiscent of
; handling of the 'constraint-lst property.  We maintain the invariant that for
; every function symbol g with an attachment h to its code, g is associated
; with h using the lookup method described above: if g is associated with an
; alist then h is the result of looking up g in that alist, else g is
; associated with a "canonical" symbol g' that is associated with an alist
; associating g with h.  (Note that this notion of "canonical" is not related
; to the notion of "canonical sibling", described elsewhere.)

; Turning now to logical issues:

; The fundamental guiding notion is that the attachment pairs extend the
; session's set of axioms to form what we call the "evaluation theory".  We say
; more about this theory (and its consistency) below.  But we also want to
; support the use of defattach for specifying refinements, with the following
; understanding: "refinement" means that the new function definitions, together
; with the attachment axioms, extend the current theory (to the evaluation
; theory), and this extension remains consistent, indeed with a standard model
; if there are no defaxiom events.  Moreover, it would be a kindness to the
; user if whenever an attachment substitution is subsequently used for
; functional instantiation, the resulting proof obligations generated are all
; dispatched without proof because they were cached at the time the defattach
; event was admitted.  However, we do not restrict the design to ensure
; definitively that this "kindness" must take place.

; Our logical characterization is based on the idea of an "evaluation theory",
; obtained by extending the current theory with the attachment axiom for each
; attachment pair.  We show that evaluation in the top-level loop is performed
; with respect to the evaluation theory.  Below we also show -- and this is
; where most of our effort lies -- that the evaluation theory is consistent,
; assuming that there are no defaxiom events in the current history.  More
; generally, we show that the evaluation theory is contained in the theory of a
; "evaluation history" containing no new defaxiom events, which replaces
; constraints in the original history by attachment axioms.  Consider the
; following example (which ignores the issue of guards):

; (encapsulate ((f1 (x) t))
;              (local (defun f1 (x) x)))
;              (defthm f1-property
;                (consp (f1 (cons x x)))))
; (defun g1 (x)
;   (if (consp x) x (cons x x)))
; (defattach f1 g1)

; Then the corresponding evaluation history could be as follows, where we
; ignore the defattach event itself.

; (defun g1 (x)
;   (if (consp x) x (cons x x)))
; (defun f1 (x)
;   (g1 x))

; Of course, we could then prove that the original constraint holds for f1.

; (defthm f1-property
;   (consp (f1 (cons x x))))

; Indeed, that is critical: in order to show that the theory of the evaluation
; history extends that of the original history, we must guarantee that the
; original constraints on attached functions (hence on f1 in the example above)
; are provable in the evaluation history.  In the example above, notice that we
; have replaced the constraint of f1 by its definition using the attachment
; axiom.  The property exported from the original encapsulation on f1 now
; becomes a top-level theorem, which is provable because (consp (g1 (cons x
; x))) is provable, as this is the proof obligation generated by the defattach,
; and g1 and f1 are provably equal by the attachment axiom.

; But we must be careful.  Consider for example:

; (encapsulate ((f1 (x) t))
;              (local (defun f1 (x) x)))
; (defun g1 (x)
;   (not (f1 x)))
; (defattach f1 g1)

; Of course, g1 satisfies the constraint on f1, which is trivial.  Also notice
; that we can prove (thm (not (equal (f1 x) (g1 x)))) before the defattach
; event.  Yet after the defattach, (equal (f1 x) (g1 x)) is a theorem of the
; evaluation theory.

; This example motivates an acyclicity condition on functions and their
; attachments, explained below, that is sufficient for supporting a
; characterization of defattach events in terms of evaluation histories.  We
; next provide some motivation, before presenting the appropriate foundational
; theory.

; Consider first a defattach event that attaches certain gi to fi, where the fi
; are all the functions introduced by some individual encapsulate event and the
; gi are all defined before that encapsulate.  Imagine replacing the
; encapsulate by the attachment axioms discussed above, i.e., defining each fi
; to be the corresponding gi.  Before such replacement, the encapsulate's
; constraint is guaranteed to hold of the gi by our conditions for admitting
; the defattach event; therefore the original constraint on the fi trivially
; holds when we replace the encapsulate by these attachment axioms.  Thus, the
; replacement of the encapsulate by the attachment axioms gives us a stronger
; theory than the original theory; so it's pretty clear that the events after
; the encapsulate remain admissible after that replacement -- not that the ACL2
; prover could actually dispatch all proof obligations, but that all proof
; obligations are indeed theorems, since the history's axiom base has been
; strengthened.

; But in general, the gi might be defined *after* introduction of the
; corresponding fi.  For example, one can imagine that f1 is the :logic mode
; built-in function symbol too-many-ifs and g1 is defined by a user (much
; later) to be an efficient implementation.  Notice that in the first example
; displayed above, the definition of g1 could presumably have been made before
; f1, while that is not the case in the second (problematic) example above.

; Thus, although we need not insist that each gi be introduced before fi, we do
; insist that the definition of gi can be relocated to occur before the
; introduction of fi.  We thus provide a criterion that considers gi to be an
; "extended ancestor" of fi, the motivating idea being that gi is an ancestor
; (supporter) of fi in the evaluation history (because gi supports the
; definition of fi in the attachment axiom for <fi,gi>) and to insist that this
; extended ancestor relation is cycle-free.  More details are provided in the
; foundational theory presented below and considered at length in the Essay on
; Merging Attachment Records.

; Of course, if the acyclicity check succeeds then it continues to succeed when
; we remove attachment pairs.  But suppose one defattach event attaches to f1
; and f2 while a second attaches to f1 and f3.  It would be a mistake to leave
; the attachment of f2 in place when attaching to f1 and f3, as illustrated by
; the following example.  For simplicity, we abuse notation a little, sometimes
; writing a zero-ary function symbol, f, to denote a constant, (f), and
; sometimes writing a constant, e.g. 0, to denote a zero-ary function returning
; that value.

; (defstub f1 ...)
; constrain f2=f1
; constrain f3=f1
; (defattach ((f1 0) (f2 0)))
; (defattach ((f1 1) (f3 1)))

; If we don't eliminate the attachment to f2 when carrying out the second
; defattach, then we are left with the following, which violates the constraint
; f2=f1!

; f1=1
; f2=0
; f3=1

; We now make a more careful argument that the evaluation theory is contained
; in the theory of some so-called evaluation history.  To recap: We have
; specified that in order for a defattach event to be admissible, then if C is
; the conjunction of the constraints on the attached functions, the functional
; instance C\s must be a theorem, where s is the set of attachment pairs
; specified by the event.  We have also discussed the requirement for
; acyclicity of an extended ancestors relation; so next, we turn to specifying
; that relation precisely.  We begin by making a couple of remarks.  Note first
; that our arguments below will involve permuting top-level events.  We thus
; prefer not to think about events other than those at the top level, and we
; disallow defattach events except at the top-level; they are illegal inside
; non-trivial encapsulates.  We also assume the absence of trivial encapsulates
; and include-book forms, which can be replaced by the individual events
; within.

; Note that acyclicity checking is necessary even during the include-book pass
; of certify-book (and similarly by any include-book, though we restrict
; attention here to the former case).  Consider the following example.

; (defattach f ...) ; first defattach
; (local (defattach f ...)) ; second defattach
; (defattach ...) ; third defattach

; If the first and third defattach events interact to form a loop, but the
; second and third do not, then the first pass of book certification would not
; catch a loop, but the include-book pass would encounter a loop that needs to
; be detected.

; Acyclicity checking will be unnecessary when including a certified book in a
; world where there are no defattach events outside the boot-strap world,
; because the necessary acyclicity checks for the book's defattach events were
; already made when certifying the book, during its include-book pass.  (At the
; time of this writing, however, no such optimization is implemented.)  But
; otherwise, we need to do an acyclicity check for the defattach events
; encountered while including a book.  The following example illustrates why
; this is necessary.  Imagine that we have two books, each containing the
; following events.

; (defstub g () t)
; (defun h () (not (g)))
; (defstub f () t)

; Now suppose one of the books concludes with the event

; (defattach f h)

; while the other concludes with the event

; (defattach g f).

; Although each book is individually certifiable, it is logically unsound to
; include both in the same session, since the resulting evaluation theory would
; equate g and h (as both are equated to f), and hence be inconsistent.  Of
; course, the extended ancestors relation in this case has a cycle: h supports
; f supports g supports h.

; Our acyclicity check will be made for the following binary relation.  Recall
; the immediate ancestors relation between a function symbol f1 introduced by
; event E1 and a function symbol f2 introduced by a later event E2: f1 occurs
; in the formula of E2.  In this case we also say that E1 is an immediate
; ancestor of E2.  For purposes of our acyclicity check, we are also interested
; in the pair <g,f> if <f,g> is an (existing, or about-to-be-introduced)
; attachment pair.  (The intuition is that ultimately we will define f to be g,
; hence f will depend on g.)  We will refer to this relation as the "extended
; immediate ancestors relation".  (Note that the discussion about events above
; refers to defun, defattach, and non-trivial encapsulate events; in
; particular, we assume that E1 and E2 are not defattach events.)

; But we really want an ancestor relation on events.  So to be more precise, we
; consider f and g to be related by either relation above if they have siblings
; f' and g' (respectively) that are so related, where two function symbols are
; siblings if they are introduced in the same (encapsulate or mutual-recursion)
; event.  We mainly ignore this issue of siblings here, but it is central in
; the Essay on Merging Attachment Records.  In that essay we also discuss in
; some detail the extended ancestor relation, which is the transitive closure
; of the union of the ordinary and extended immediate ancestor relations.  In
; particular, we defer to that essay how we check for cycles.  In summary: our
; ancestor relation is essentially on encapsulate and definitional events.
; This is important for the argument below, in which we complete our ancestor
; relation on events to a total order, essentially rearranging events so that
; for attachment pair <f,g>, g is introduced before f.  Because we want to
; rearrange entire events, our notion of event ancestor incorporates mbe when
; relevant to evaluation (i.e., in defun bodies) and guards.  We could perhaps
; avoid considering guards, actually, were it not for the issue related to
; guards raised at the end of the Essay on Correctness of Meta Reasoning.

; Before leaving the notion of extended ancestor relation, we make the
; following claim.

;   Defaxiom Acyclicity Claim.  If the extended ancestor relation is acyclic
;   without considering defaxiom events, then it remains acyclic when taking
;   the transitive closure after including defaxiom events in the following
;   sense: every event depends on every earlier defaxiom event, and every
;   defaxiom event depends on all its immediate ancestors.

; Because of this claim, we check for acyclicity of the extended ancestor
; relation, R, without considering defaxiom events, but when we assume
; acyclicity of R, we include the extra dependencies for defaxiom events
; mentioned in the claim above.  We may say "(without defaxioms)" to refer to
; the version of the extended ancestor relation that does not include defaxiom
; events as above.

; To prove the claim, suppose for a contradiction that C is a cycle in the
; indicated extension for defaxiom events.  Since the extension is assumed
; acyclic before extending by defaxiom events, then C must go through an edge
; linking a defaxiom to a supporting function symbol, f.  But when we restrict
; C to start with f, we stay in the original ancestor relation, since no
; attached function is ancestral in any defaxiom, by the Defaxiom Restriction
; for Defattach (stated above).  Thus we have a cycle starting with f in the
; original ancestor relation (without extending for defaxiom events), a
; contradiction.

; We turn now to the promised logical characterization of defattach, deferring
; for several paragraphs the proof that it actually holds for admissible
; defattach events.

; The defattach events of a history extend its theory, T, to its corresponding
; "evaluation theory", T', whose axioms include T together with the attachment
; axioms: again, these are the definitions (f x1 ... xn) = (g x1 ... xn), as
; <f,g> ranges over all current attachment pairs.  We assume that the defattach
; events produce an acyclic extended ancestors relation.  A key desired
; property is as follows (see also the Evaluation History Theorem below for a
; sort of generalization).

;   Proposition (Attachment Consistency).  If a history is defaxiom-free,
;   then its evaluation theory is consistent and in fact has a standard model.

; (Note: For ACL2(r), we expect that the argument for the proposition is
; essentially unchanged except that a final step, providing a standard model,
; is of course removed.  Specifically, this proposition follows from the
; Evaluation History Theorem, as explained below, whose proof we expect goes
; through unchanged for ACL2(r).)

; What is the significance of the above proposition?  There are several
; answers, depending on our intended application of defattach.  If our
; motivation is testing, then we want to test in a model of the original
; theory; and that will be the case if we evaluate in an extension of that
; theory, which as explained in the next paragraph is the evaluation theory (as
; we evaluate f using g for each attachment pair <f,g>).  If our motivation is
; attachment to system code, then it's really the same answer: Our system code
; defines a theory of prover functions, such that every model of that theory is
; intended to be correct.  Finally, if the motivation is refinement, the idea
; is that our goal is to refine (extend) the original theory with increasingly
; strong axioms about functions; and each defattach will provide such an
; extension, so that the refinement provided by the final defattach event does
; so as well.  In all cases, the idea is that we originally specified a class
; of models, and defattach events merely shrink that class of models without
; making it empty (indeed, still including a standard model).

; We characterize the effect of defattach for evaluation in the ACL2 loop as
; follows: it takes place relative to the definitions in the current evaluation
; theory, where for each attachment pair <f,g>, the guard of f is defined to be
; the guard of g.  (Implementation note: *1*f may directly call *1*g, and f may
; directly call g, if f has attachment g.)  In particular, as with evaluation
; in the ACL2 loop in general: (a) there is never a guard violation in raw
; Lisp; and (b) if evaluation of a ground term u in the ACL2 loop returns a
; value v, then u=v is a theorem of the evaluation theory.  To see that the
; implementation guarantees this behavior, first note that for every attachment
; pair <f,g>, ACL2 insists that the guard of f logically implies the guard of
; g; hence if we replace the guard of f by the guard of g in every guard proof
; obligation, provability of the original guard proof obligation implies
; provability of this weaker, new guard proof obligation.  Another way of
; thinking about evaluation is that it takes place in the evaluation chronology
; but with the guard of f set to the guard of g; thus guard verification for
; the new definition of f (i.e., equating f with g) is trivial.

; To be more precise: The actual guard proof obligation is obtained from the
; basic one, described above, by applying the attachment substitution.  The
; argument above goes through unchanged, however, because for each attachment
; pair <f,g>, f and g are equal in the evaluation history.  In most cases we
; imagine that this remark doesn't apply, i.e., the attachment substitution
; does not hit the basic guard implications described above.  However, consider
; the case of a generic interpreter using function generic-good-statep as a
; guard, and a concrete interpreter (say, for the JVM) using function
; concrete-good-statep as a guard.  There is no reason to expect that
; generic-good-statep is stronger than (or in any way related to)
; concrete-good-statep; but the implication (implies (generic-good-statep x)
; (concrete-good-statep x)) becomes trivial when applying a functional
; substitution mapping generic-good-statep to concrete-good-statep.

; We refer below to the replacement of an encapsulate using attachment
; equations.  This refers to the process, for each function symbol being
; provided an attachment, of replacing the encapsulate with a sequence
; consisting first of attachment equations (as defun events) for each function
; f that is both attached and is introduced by the encapsulate, and then
; modifying the encapsulate by eliminating a part of it for each such symbol f
; as follows: remove f from the signature if it's present there, and otherwise
; remove the definition of f from the encapsulate.  (If the definition is via a
; sub-encapsulate, then this removal occurs recursively.)  If what is left of
; the encapsulate introduces any functions, then we apply the same argument
; showing that the constraint of the original encapsulate is provable in the
; evaluation theory, to conclude that the first pass of that encapsulate is
; provable; hence the remainder of that encapsulate is admissible in the
; evaluation chronology.

; The Attachment Consistency Proposition, above, is immediate from the
; following theorem.  Here, we say that a sequence of axiomatic events respects
; a binary relation on function symbols if whenever <f,g> is in the relation,
; the axiomatic event for f is introduced before the axiomatic event for g.

;   Evaluation History Theorem.  Let h1 be a history, and fix legal attachments
;   for h1, that is: the extended ancestors relation is acyclic, and no
;   attached function is ancestral in any defaxiom.  Then there is a
;   permutation h2 of h1 that respects the extended dependency relation for h1.
;   Let h3 be obtained from any such h2 by replacing each attached encapsulate
;   using the attachment equations of an admissible defattach event.  Then h3
;   is a history whose theory is the evaluation theory for h1 with respect to
;   the given attachments, and whose syntactic dependency relation is the
;   extended dependency relation (without defaxioms) of h1 with respect to the
;   given attachments.

; Proof. The existence of h2 is immediate by completing the extended dependency
; relation to a total order.  So we focus on the claim that h3 is a history
; whose theory is the evaluation theory for h1.  Since h2 respects the extended
; dependency relation for h1, h3 is a weak history: roughly speaking, each
; function is introduced before it is used.  So our task is to show that all
; proof obligations are met for h3 and that its theory is the evaluation theory
; for h1 with respect to the given attachments.

; Since h2 respects the extended ancestors relation, h2 is a weak history.  To
; see that h2 is a history, it suffices to show that all proof obligations are
; met.  This is clear if there are no defaxiom events, because each initial
; segment of h2 forms a subset of (the events in) h1 that is closed under
; ancestors in h1.  The argument is similar even if there are defaxiom events,
; as follows.  Fix an event A in h2; we show that the proof obligations are met
; for A.  Let B be the predecessor of A in h2 (possibly A itself) that occurs
; latest in h1, and let let h1' be the predecessors of B (including B) in h1,
; and let h2' be the predecessors of A (including A) in h2.  It's easy to see
; that h2' is closed under ancestors in h1'; here we use the fact that h2 is
; closed under the version of the extended ancestors relation that includes
; defaxiom events (see the discussion around the Defaxiom Acyclicity Claim,
; above).  Since h1' is a history (as it is an initial segment of h1), then it
; conservatively extends h2', and thus the proof obligations are met for A as
; it sits in h2.

; We return now to the task of showing that proof obligations are met for
; events in h3.  It suffices to show that each replacement of an encapsulate by
; corresponding attachment equations, as described above, can only strengthen
; the theory.  So for E = E(f1,f2,...) an encapsulate replaced by the use of
; attachment equations A = {fi=gi}, we must show that for E' = E(g1,g2,...),
; the first pass of E' is provable from A together with the predecessors of E'
; in h3.  We induct on the length of h3, so it suffices by the inductive
; hypothesis to show that the first pass of E' is provable from A together with
; the predecessors of E in h2.  But this is obvious, since the first passes of
; E and E' are provably equal under A.

; We have shown that h3 is a history.  Clearly the theory of h3 is axiomatized
; by the theory of h1 together with the attachment equations, so the remaining
; properties of h3 are obvious. -|

; Note that since each defattach event's proof obligations are done without
; taking into account any attachment pairs outside those specified by the
; event, then we can delete any set of defattach events from the world and the
; result is still a legal set of defattach events (as acyclicity is of course
; preserved when we shrink a relation).  But we can do something else: we can
; restrict the set of attachments to any set closed under ancestors, and hence
; under that restriction we can even remove pairs within a single defattach
; event.  (As of this writing we don't support such removal, however, and
; perhaps we won't ever support it since the implementation is simpler for
; removing entire defattach events when we erase.)  A long comment in function
; chk-evaluator-use-in-rule takes advantage of this fact, which we now state
; and prove.

;   Attachment Restriction Lemma.  Let s0 be a set of attachment pairs and let
;   s1 be a subset of s0, such that every function symbol in the domain of s0
;   that is ancestral (including siblings, but ignoring defaxioms) in the
;   domain of s1 is also in the domain of s1.  Let C0 and C1 be the respective
;   lists of constraints on the domains of s0 and s1, and similarly G0 and G1
;   for guard proof obligations, and assume that the functional instances C0\s0
;   and G0\s0 are provable in the current history.  Then C1\s1 and G1\s1 are
;   also provable in the current history.

; Proof: Note that every function symbol occurring in the constraint or guard
; obligation for attaching to a function symbol, f, is ancestral in f
; (syntactically ancestral, ignoring defaxioms, as defaxioms are not considered
; when gathering such constraints; see function defattach-constraint).
; Therefore any function symbol h in the domain of s0 that occurs in C1 or G1
; is ancestral in some element of the domain of s1, and therefore h is in the
; domain of s1, by the assumption about ancestors.  It follows trivially that
; C1\s1 is a subset of C0\s0 and that G1\s1 is a subset of G0\s0.  -|

; We conclude this essay with some remarks.

; Our first implementation of defattach, in Version_4.0, went through
; considerable contortions to support what had seemed a relatively simple
; attachment for too-many-ifs-post-rewrite (then called
; too-many-ifs-post-rewrite-wrapper).  The problem was that during the first
; pass of the boot-strap, the functions pseudo-termp and pseudo-term-listp were
; in :program mode, yet were needed for the :guard of the encapsulated
; function.  Our solution was to introduce (in Version_4.2) the notion of a
; ``proxy'': a non-executable program-mode function, which can be easily
; introduced using the defproxy macro, and to add keyword argument :skip-checks
; to defattach; see :DOC defproxy.

; There are circumstances where we prohibit attachments to a constrained
; function, by associating a value (:ATTACHMENT-DISALLOWED . alist) with the
; 'attachment property of the function, where alist may be used in error
; messages.  This association enforces some restrictions on receiving
; attachments in the cases of meta functions and clause-processor functions;
; see the Essay on Correctness of Meta Reasoning.  (A different mechanism
; prohibits the functions in *unattachable-primitives* from receiving
; attachments.)

; We discuss a few aspects of how we handle this :ATTACHMENT-DISALLOWED case.
; Source function redefinition-renewal-mode disallows redefinition when there
; is an attachment, but allows redefinition in the :ATTACHMENT-DISALLOWED case.
; Thus, function renew-name/overwrite preserves the 'attachment property in
; order to preserve the prohibition of attachments; and since redefinition is
; disallowed when there is an attachment, this is actually the only case
; encountered in renew-name/overwrite for which there is a non-nil 'attachment
; property.  Finally, note that while the :ATTACHMENT-DISALLOWED case can be
; expected never to hold for a proxy, nevertheless we check this in
; redefinition-renewal-mode before attaching to a proxy.

; End of Essay on Defattach

(defun translate-defattach-helpers (kwd-value-lst name-tree ctx wrld state)

; Warning: Keep this in sync with *defattach-keys*.

; We have already checked that kwd-value-lst is a keyword-value-listp without
; duplicate keys each of whose keys is among *defattach-keys*.

  (cond
   ((endp kwd-value-lst)
    (value nil))
   (t
    (let ((key (car kwd-value-lst))
          (val (cadr kwd-value-lst)))
      (er-let*
       ((rest (translate-defattach-helpers (cddr kwd-value-lst) name-tree
                                           ctx wrld state))
        (tval
         (cond ((assoc-eq key rest)
                (er soft ctx
                    "The key ~x0 occurs more than once in the same context ~
                     for a defattach event."
                    key))
               ((or (and (member-eq key '(:OTF-FLG :HINTS))
                         (assoc-eq :INSTRUCTIONS rest))
                    (and (eq key :INSTRUCTIONS)
                         (or (assoc-eq :OTF-FLG rest)
                             (assoc-eq :HINTS rest))))
                (er soft ctx
                    "The combination of :INSTRUCTIONS and either :HINTS or ~
                     :OTF-FLG is illegal for the same context in a defattach ~
                     event."))
               (t
                (case key
                  (:HINTS
                   (translate-hints+ name-tree
                                     val
                                     (default-hints wrld)
                                     ctx wrld state))
                  (:INSTRUCTIONS
                   (translate-instructions val ctx state))
                  (:OTF-FLG
                   (value val))
                  (:ATTACH
                   (cond ((member-eq val '(t nil))
                          (value val))
                         (t (er soft ctx
                                "The only legal values for keyword :ATTACH in ~
                                 a defattach event are ~&0.  The value ~x1 is ~
                                 thus illegal."
                                '(t nil)
                                val))))
                  (otherwise
                   (value (er hard ctx
                              "Implementation error: Should already have ~
                               checked keys in process-defattach-args1."))))))))
       (value (cons (cons key tval)
                    rest)))))))

(defconst *defattach-keys*

; Warning: Keep this in sync with translate-defattach-helpers.

  '(:hints :instructions :otf-flg :attach))

(defun defattach-unknown-constraints-error (name ctx state)
  (er soft ctx
      "Attachment is disallowed in this context, because the function ~x0 has ~
       unknown-constraints.  See :DOC partial-encapsulate."
      name))

(defun intersection-domains (a1 a2)
  (declare (xargs :guard (and (symbol-alistp a1)
                              (symbol-alistp a2))))
  (if (consp a1)
      (if (assoc-eq (caar a1) a2)
          (cons (caar a1)
                (intersection-domains (cdr a1) a2))
        (intersection-domains (cdr a1) a2))
    nil))

(defun process-defattach-args1 (args ctx wrld state erasures explicit-erasures
                                     attachment-alist helper-alist-lst
                                     skip-checks system-ok)

; We accumulate into four arguments as follows:

; - erasures: existing attachment pairs that need to be removed (perhaps before
;   reattachment to the cars of some of these pairs)
; - explicit-erasures: functions associated with nil, for explicit de-attachment
; - attachment-alist: list of pairs (f . g) where g is to be attached to f
; - helper-alist-lst: list of alists corresponding positionally to
;   attachment-alist, where each element is used for the corresponding proof
;   that the guard of f implies the guard of g, and/or to specify :attach nil,
;   and is an alist created by translate-defattach-helpers.

; We return an error triple (mv erp val state), where either erp is non-nil to
; signal an error, or else val is of the form (list* erasures attachment-alist
; helper-alist-lst).

; Args is known to be a true-listp.

  (cond ((endp args)
         (value (list erasures explicit-erasures attachment-alist
                      helper-alist-lst)))
        (t
         (let ((arg (car args))
               (see-doc "  See :DOC defattach.")
               (ld-skip-proofsp (ld-skip-proofsp state))
               (skip-checks-t (eq skip-checks t))
               (unless-ttag
                (msg
                 " (unless :SKIP-CHECKS T is specified with an active trust ~
                  tag)"))
               (not-boot-strap-p (not (f-get-global 'boot-strap-flg state))))
           (case-match arg
             ((f g . kwd-value-lst)
              (er-let*
               ((helper-alist
                 (cond ((or (eq ld-skip-proofsp 'include-book)
                            (eq ld-skip-proofsp 'include-book-with-locals)
                            (eq ld-skip-proofsp 'initialize-acl2))
                        (value nil))
                       ((or (not (keyword-value-listp kwd-value-lst))
                            (strip-keyword-list *defattach-keys* kwd-value-lst))
                        (er soft ctx
                            "Each specified attachment must be of the form (F ~
                             G . LST), where LST is an alternating list of ~
                             keywords and values (see :DOC ~
                             keyword-value-listp) whose keys are without ~
                             duplicates, such that each key is ~v1.  The LST ~
                             specified for the attachment to ~x0 is not of ~
                             this form.~@2"
                            f
                            *defattach-keys*
                            see-doc))
                       (t (translate-defattach-helpers
                           kwd-value-lst
                           (cons "DEFATTACH guard obligation for attaching to"
                                 f)
                           ctx wrld state)))))
               (cond
                ((not (function-symbolp f wrld))
                 (er soft ctx
                     "Attachment is only legal for function symbols, but ~x0 ~
                      is not a known function symbol.~@1~@2"
                     f
                     see-doc
                     (let ((f1 (deref-macro-name f (macro-aliases wrld))))
                       (cond ((not (eq f1 f))

; We cannot soundly allow attachment to macro-aliases.  For, imagine a book
; with non-local macro-alias m1 for f1 followed by local macro-alias m1 for f2,
; followed by a defattach attaching to m1.  The proofs during pass 1 of this
; book's certification would be based on attaching to f2, but a later
; include-book would attach to f1.

                              (msg "  NOTE: You may have intended to use ~x0 ~
                                    instead of ~x1, which is a macro alias ~
                                    for the function symbol ~x0."
                                   f1 f))
                             ((getpropc f 'macro-body nil wrld)
                              (msg "  NOTE: ~x0 is a macro, not a function ~
                                    symbol."
                                   f))
                             (t "")))))
                ((or (untouchable-fn-p f
                                       wrld
                                       (f-get-global 'temp-touchable-fns
                                                     state))
                     (untouchable-fn-p g
                                       wrld
                                       (f-get-global 'temp-touchable-fns
                                                     state)))
                 (er soft ctx
                     "The function symbol~#0~[ ~&0 is~/s ~&0 are~] ~
                      untouchable.  See :DOC remove-untouchable."
                     (append
                      (and (untouchable-fn-p f
                                             wrld
                                             (f-get-global 'temp-touchable-fns
                                                           state))
                           (list f))
                      (and (untouchable-fn-p g
                                             wrld
                                             (f-get-global 'temp-touchable-fns
                                                           state))
                           (list g)))))
                ((and (not skip-checks-t)
                      (not (logicp f wrld)))
                 (cond ((null g)
                        (er soft ctx
                            "You must specify :SKIP-CHECKS T in order to use ~
                             defattach with :PROGRAM mode functions, such as ~
                             ~x0.~@1"
                            f see-doc))
                       (t
                        (er soft ctx
                            "Only function symbols in :LOGIC mode may have ~
                             attachments~@0, but ~x1 is in :PROGRAM mode.~@2"
                            unless-ttag f see-doc))))
                ((and (member-eq f *unattachable-primitives*)
                      not-boot-strap-p)
                 (er soft ctx
                     "It is illegal to add or remove an attachment to the ~
                      function symbol ~x0 because it is given special ~
                      treatment by the ACL2 implementation."
                     f))
                ((and not-boot-strap-p
                      (not system-ok)
                      (getpropc f 'predefined)) ; acl2-system-namep-state
                 (er soft ctx
                     "The function symbol ~x0 is built into ACL2.  Thus, to ~
                      add or remove an attachment to this symbol it is ~
                      required to specify :SYSTEM-OK T in your defattach ~
                      event."
                     f))
                ((and (warrant-function-namep f wrld)
                      (not (eq g 'true-apply$-warrant)))

; We check in attachment-records that the attachment to a warrant is always
; true-apply$-warrant.  See the Essay on Memoization with Attachments.

                 (er soft ctx
                     "The only attachment legal for the warrant function ~x0 ~
                      is ~x1.  The attachment of ~x2 to ~x0 is thus illegal."
                     f 'true-apply$-warrant g))
                (t
                 (let ((at-alist (attachment-alist f wrld)))
                   (cond
                    ((eq (car at-alist) :attachment-disallowed)

; Perhaps we should allow this case if skip-checks is true.  But let's wait and
; see if there is a reason to consider doing so.

                     (let* ((at-alist

; We store the actual alist on the 'attachment property of the canonical
; sibling of f.  See Appendix 2 of the Essay on Correctness of Meta Reasoning.

                             (if (symbolp (cdr at-alist))
                                 (attachment-alist (cdr at-alist)
                                                   wrld)
                               at-alist))
                            (pair (assert$ ; check case f is not canonical
                                   (eq (car at-alist) :attachment-disallowed)
                                   (assert$
                                    (consp (cdr at-alist))
                                    (cadr at-alist))))
                            (rule-name (assert$ (consp pair)
                                                (car pair)))
                            (rule-class (cdr pair))
                            (meta-fn (assert$ (member-eq rule-class
                                                         '(:meta
                                                           :clause-processor))
                                              (if (eq rule-class :meta)
                                                  "meta"
                                                "clause-processor"))))

; It would be polite to print ancestor paths here as we do when the error comes
; from the rule instead (after a successful defattach).  But we don't have the
; evaluator or meta functions handy here.  We could presumably make them handy
; by storing them with the 'attachment property instead of just the at-alist
; mapping rule-names to their rule-classes.

                       (er soft ctx
                           "It is illegal to attach to the function symbol ~
                            ~x0 because it is a common ancestor of the ~
                            evaluator and ~@1 functions of the ~x2 rule, ~x3. ~
                            ~ See :DOC evaluator-restrictions and see :DOC ~
                            transparent-functions."
                           f meta-fn rule-class rule-name)))
                    (t ; at-alist is a legitimate attachment alist
                     (let* ((erasures (cond ((consp at-alist)
                                             (append at-alist erasures))
                                            (t erasures)))
                            (constraint-lst
                             (getpropc f 'constraint-lst t wrld))
                            (attach-pair (assoc-eq :ATTACH helper-alist)))
                       (cond
                        ((and (not skip-checks-t)
                              (unknown-constraints-p constraint-lst))
                         (defattach-unknown-constraints-error f ctx state))
                        ((null g)
                         (cond
                          (helper-alist
                           (er soft ctx
                               "The function symbol ~x0 has been associated ~
                                with NIL in a defattach event, yet keyword ~
                                argument~#1~[ ~&1 has~/s ~&1 have~] been ~
                                supplied for this association, which is ~
                                illegal.~@2"
                               f
                               (strip-cars helper-alist)
                               see-doc))
                          (t
                           (pprogn
                            (cond
                             ((null at-alist)
                              (warning$ ctx "Attachment"
                                        "The function symbol ~x0 does not ~
                                         currently have an attachment, so the ~
                                         directive to remove its attachment ~
                                         will have no effect."
                                        f))
                             (t (assert$ (consp at-alist)
                                         state)))
                            (process-defattach-args1 (cdr args)
                                                     ctx wrld state
                                                     erasures ; updated above
                                                     (cons f explicit-erasures)
                                                     attachment-alist
                                                     helper-alist-lst
                                                     skip-checks
                                                     system-ok)))))
                        ((and (or (null attach-pair)
                                  (cdr attach-pair)) ; attaching for execution
                              (not (and skip-checks-t

; If skip-checks is t and we have a non-executable program-mode function, then
; it is legal to attach for execution, so we can move on to the next COND
; branch.

                                        (eq (getpropc f 'non-executablep nil
                                                      wrld)
                                            :program)))

; Is it legal to attach for execution?  A 'constraint-lst property alone isn't
; enough, because a defined function can have a constraint-lst; for example, g
; has a Common Lisp defun (so we can't attach to it) yet it also has a non-nil
; 'constraint-lst property.

; (encapsulate
;  ((f (x) t))
;  (local (defun f (x) x))
;  (defun g (x) (f x))
;  (defthm some-prop (equal (g x) (f x))))

; A 'constrainedp property alone isn't enough either, because defchoose
; introduces a 'constrainedp property of t but doesn't provide a
; 'constraints-lst property.  That might be OK, depending on how we gather
; constraints; but defchoose is an unusual case and for now we won't consider
; it.

                              (or (eq constraint-lst t) ; property is missing
                                  (not (getpropc f 'constrainedp nil wrld))))

; We cause an error: the function is not permitted an executable attachment.
; The only challenge is to provide a useful error message.

                         (er soft ctx
                             "It is illegal to attach to function symbol ~x0, ~
                              because it ~@1.~@2"
                             f
                             (let ((pair
                                    (assoc-eq f
                                              *primitive-formals-and-guards*)))
                               (cond
                                (pair
                                 "is a built-in primitive")
                                ((getpropc f 'defchoose-axiom nil wrld)
                                 "was introduced with DEFCHOOSE")
                                (t
                                 "was introduced with DEFUN")))
                             see-doc))
                        ((not (symbolp g))
                         (er soft ctx
                             "Only a function symbol may be attached to a ~
                              function symbol.  The proposed attachment of ~
                              ~x0 to ~x1 is thus illegal, since ~x0 is not a ~
                              symbol.~@2"
                             g f see-doc))
                        ((not (function-symbolp g wrld))
                         (er soft ctx
                             "Only a function symbol may be attached to a ~
                              function symbol.  The proposed attachment of ~
                              ~x0 to ~x1 is thus illegal, since ~x0 is not a ~
                              known function symbol.~@2~@3"
                             g f see-doc
                             (let ((g1 (deref-macro-name g (macro-aliases
                                                            wrld))))

; See the comment above explaining why we cannot soundly allow attachment to
; macro-aliases.

                               (cond ((not (eq g1 g))
                                      (msg "  NOTE: You may have intended to ~
                                            use ~x0 instead of ~x1, which is ~
                                            a macro alias for the function ~
                                            symbol ~x0."
                                           g1 g))
                                     ((getpropc g 'macro-body nil wrld)
                                      (msg "  NOTE: ~x0 is a macro, not a ~
                                            function symbol."
                                           g))
                                     (t "")))))
                        ((and (not skip-checks-t)
                              (not (logicp g wrld)))
                         (er soft ctx
                             "Attachments must be function symbols in :LOGIC ~
                              mode~@0, but ~x1 is in :PROGRAM mode.~@2"
                             unless-ttag g see-doc))
                        ((and (not skip-checks-t)
                              (not (eq (symbol-class g wrld)
                                       :common-lisp-compliant)))
                         (er soft ctx
                             "Attachments must be guard-verified function ~
                              symbols~@0, but ~x1 has not had its guard ~
                              verified.  You may wish to use the macro ~x2 in ~
                              community book books/misc/defattach-bang.~@3"
                             unless-ttag g 'defattach! see-doc))
                        ((not (and (equal (stobjs-in f wrld)
                                          (stobjs-in g wrld))
                                   (equal (stobjs-out f wrld)
                                          (stobjs-out g wrld))))
                         (er soft ctx
                             "Attachments must preserve signatures, but the ~
                              signatures differ for ~x0 and ~x1.~@2"
                             f g see-doc))
                        ((eq f g)
                         (er soft ctx
                             "It is illegal to attach a function to itself, ~
                              such as ~x0.~@1"
                             f see-doc))
                        ((and (not skip-checks-t)
                              (eq (canonical-sibling f wrld)
                                  (canonical-sibling g wrld)))

; Perhaps we should avoid causing an error if skip-checks is :cycles.  But that
; will require some thought, so we'll wait for a complaint.

                         (er soft ctx
                             "The function ~x0 is an illegal attachment for ~
                              ~x1~@2, because the two functions were ~
                              introduced in the same event.~@3"
                             g f unless-ttag see-doc))
                        (t
                         (process-defattach-args1
                          (cdr args) ctx wrld state
                          erasures ; updated above
                          explicit-erasures
                          (cons (cons f g) attachment-alist)
                          (cons helper-alist helper-alist-lst)
                          skip-checks system-ok)))))))))))
             (& (er soft ctx
                    "Each tuple supplied to a defattach event must be of the ~
                     form (f g . kwd-value-lst).  The tuple ~x0 is thus ~
                     illegal.~@1"
                    arg see-doc)))))))

(defun duplicate-keysp-eq (alist)

; As with duplicate-keysp, return the first pair whose key is bound twice.

  (declare (xargs :guard (symbol-alistp alist)))
  (cond ((endp alist) nil)
        ((assoc-eq (caar alist) (cdr alist))
         (car alist))
        (t (duplicate-keysp-eq (cdr alist)))))

(defun split-at-first-keyword (args)

; Return (mv x y), where args is (append x y), x contains no keywords, and if
; args contains a keyword then (car y) is a keyword.

  (declare (xargs :guard (true-listp args)))
  (cond ((endp args)
         (mv nil nil))
        ((keywordp (car args))
         (mv nil args))
        (t (mv-let (alist kwd-value-lst)
                   (split-at-first-keyword (cdr args))
                   (mv (cons (car args) alist)
                       kwd-value-lst)))))

(defun maybe-remove1-eq (x lst)

; This is equivalent to remove1-eq, but might be more efficient to use if x is
; usually not a member of lst.

  (declare (xargs :guard (if (symbolp x)
                             (true-listp lst)
                           (symbol-listp lst))))
  (if (member-eq x lst)
      (remove1-eq x lst)
    lst))

(defun filter-for-attachment (attachment-alist helpers-lst attach-by-default
                                               aa hl attach-nil-lst)

; We remove pairs from attachment-alist for which no attachment will be made,
; returning the ones that are left together with the corresponding elements of
; helpers-lst and a list of fns for which :attach nil is specified.  The order
; is reversed for the pared-down attachment-alist and helpers-lst, which were
; presumably passed in the reverse of the desired order.

  (cond ((endp attachment-alist)
         (mv aa hl attach-nil-lst))
        (t (let ((pair (assoc-eq :ATTACH (car helpers-lst))))
             (cond ((if pair (cdr pair) attach-by-default)
                    (filter-for-attachment (cdr attachment-alist)
                                           (cdr helpers-lst)
                                           attach-by-default
                                           (cons (car attachment-alist) aa)
                                           (cons (car helpers-lst) hl)
                                           (maybe-remove1-eq
                                            (caar attachment-alist)
                                            attach-nil-lst)))
                   (t (filter-for-attachment (cdr attachment-alist)
                                             (cdr helpers-lst)
                                             attach-by-default
                                             aa
                                             hl
                                             (add-to-set-eq
                                              (caar attachment-alist)
                                              attach-nil-lst))))))))

(defconst *defattach-keys-extended*
  (append *defattach-keys* '(:skip-checks :system-ok)))

(defun process-defattach-args (args ctx state)

; Args is known to be a true-listp, as it comes from a macro call.

  (let ((msg "Illegal arguments for defattach.  See :DOC defattach.  Note ~
              that if the first argument is a symbol, then there should be ~
              only two arguments, both of them symbols.  Consider instead ~
              executing "))
    (cond
     ((null args)
      (er soft ctx
          "Defattach must specify at least one attachment.  See :DOC ~
           defattach."))
     ((symbolp (car args)) ; (defattach f ...)
      (cond
       ((and (not (keywordp (car args)))
             (consp (cdr args))
             (symbolp (cadr args))
             (not (keywordp (cadr args)))) ; (defattach f g ...)
        (cond
         ((null (cddr args))
          (process-defattach-args `((,(car args) ,(cadr args))) ctx state))
         ((and (true-listp args)
               (member-eq (caddr args) '(:SKIP-CHECKS :SYSTEM-OK)))
          (er soft ctx
              "~@0the form:~|~%~y1."
              msg
              `(defattach (,(car args) ,(cadr args)) ,@(cddr args))))
         ((and (true-listp args)
               (eql (length args) 4)
               (eq (caddr args) :ATTACH))
          (er soft ctx
              "~@0the form:~|~%~y1."
              msg
              `(defattach (,@args))))
         (t
          (er soft ctx
              "~@0one of the following two forms:~|~%~y1~ ~ or~|~y2."
              msg
              `(defattach (,(car args) ,(cadr args)) ,@(cddr args))
              `(defattach (,(car args) ,(cadr args) ,@(cddr args)))))))
       (t
        (er soft ctx
            "Illegal defattach form.  If the first argument is a symbol, then ~
             there must be exactly two arguments, both of which are ~
             non-keyword symbols.  See :DOC defattach."))))
     (t
      (mv-let
       (args constraint-kwd-alist)
       (split-at-first-keyword args)
       (cond
        ((not (symbol-alistp args))
         (er soft ctx
             "Illegal arguments for defattach, ~x0.  See :DOC defattach."
             args))
        ((duplicate-keysp-eq args)
         (er soft ctx
             "A defattach event must specify attachments for distinct ~
              function symbols, but ~x0 is associated with a value more than ~
              once.  See :DOC defattach."
             (car (duplicate-keysp-eq args))))
        ((or (not (keyword-value-listp constraint-kwd-alist))
             (strip-keyword-list *defattach-keys-extended*
                                 constraint-kwd-alist))
         (er soft ctx
             "Illegal defattach argument list.  The tail following the ~
              specified pairs of function symbols should be an alternating ~
              list of keywords and values (see :DOC keyword-value-listp) ~
              whose keys are without duplicates and all belong to the list ~
              ~x0.  That tail is, however, ~x1.  See :DOC defattach."
             *defattach-keys-extended*
             constraint-kwd-alist))
        (t (let* ((wrld (w state))
                  (ld-skip-proofsp (ld-skip-proofsp state))
                  (skip-checks-tail
                   (assoc-keyword :skip-checks constraint-kwd-alist))
                  (skip-checks (cadr skip-checks-tail))
                  (constraint-kwd-alist
                   (if skip-checks-tail
                       (remove-keyword :skip-checks constraint-kwd-alist)
                     constraint-kwd-alist))
                  (system-ok-tail
                   (assoc-keyword :system-ok constraint-kwd-alist))
                  (system-ok (cadr system-ok-tail))
                  (constraint-kwd-alist
                   (if system-ok-tail
                       (remove-keyword :system-ok constraint-kwd-alist)
                     constraint-kwd-alist)))
             (cond
              ((and skip-checks
                    (not (eq skip-checks t))
                    (not (eq skip-checks :cycles)))
               (er soft ctx
                   "Illegal value for :SKIP-CHECKS (must be ~x0, ~x1, or ~
                    ~x2): ~x3."
                   t nil :cycles skip-checks))
              ((and skip-checks
                    (not (or (f-get-global 'boot-strap-flg state)
                             (ttag wrld))))
               (er soft ctx
                   "It is illegal to specify a non-nil value of :SKIP-CHECKS ~
                    for defattach unless there is an active trust tag."))
              ((not (booleanp system-ok))
               (er soft ctx
                   "Illegal value for :SKIP-CHECKS (must be ~x0 or ~x1): ~x2."
                   t nil system-ok))
              (t
               (er-let* ((tuple
                          (process-defattach-args1 args ctx wrld state nil nil
                                                   nil nil
                                                   skip-checks system-ok))
                         (constraint-helpers
                          (cond
                           ((or (eq ld-skip-proofsp 'include-book)
                                (eq ld-skip-proofsp 'include-book-with-locals)
                                (eq ld-skip-proofsp 'initialize-acl2))
                            (value nil))
                           (t (translate-defattach-helpers
                               constraint-kwd-alist
                               "DEFATTACH constraint proof obligation"
                               ctx wrld state)))))
                 (let ((erasures (nth 0 tuple))
                       (explicit-erasures (nth 1 tuple))
                       (attachment-alist (nth 2 tuple))
                       (helper-alist-lst (nth 3 tuple))
                       (attach-by-default
                        (let ((pair (assoc-eq :ATTACH constraint-helpers)))
                          (if pair (cdr pair) t))))
                   (mv-let (attachment-alist-exec
                            helper-alist-lst-exec
                            attach-nil-lst)
                           (filter-for-attachment attachment-alist
                                                  helper-alist-lst
                                                  attach-by-default
                                                  nil nil
                                                  (global-val 'attach-nil-lst
                                                              wrld))
                           (value (list constraint-helpers
                                        erasures
                                        explicit-erasures

; We sort the attachment-alist so that chk-acceptable-defattach gets a sorted
; alist that can ultimately lead to avoidance of proof obligations via
; event-responsible-for-proved-constraint.

                                        (merge-sort-symbol-alistp
                                         attachment-alist)
                                        attachment-alist-exec
                                        helper-alist-lst-exec
                                        skip-checks
                                        attach-nil-lst)))))))))))))))

(defun prove-defattach-guards1 (i n attachment-alist-tail attachment-alist
                                  helpers-lst ctx ens wrld state ttree)

; This function is similar to prove-corollaries1, but for the proof obligations
; arising from a defattach stating that for each attachment pair <f,g>, the
; guard of f implies the guard of g.  See prove-defattach-guards for further
; comments.  We are currently working on the ith our of n such proofs.

  (cond
   ((null attachment-alist-tail)
    (pprogn
     (io? event nil state
          (n)
          (fms "This concludes the ~#0~[guard proof~/~n1 guard proofs~].~%"
               (list (cons #\0 (cond ((= n 1) 0)
                                     (t 1)))
                     (cons #\1 n))
               (proofs-co state) state nil))
     (value ttree)))
   (t (let* ((f (caar attachment-alist-tail))
             (g (cdar attachment-alist-tail))
             (goal (sublis-fn-simple
                    attachment-alist
                    (fcons-term* 'implies
                                 (sublis-var (pairlis$ (formals f wrld)
                                                       (formals g wrld))
                                             (guard f nil wrld))
                                 (guard g nil wrld))))
             (helper-alist (car helpers-lst))
             (otf-flg (cdr (assoc-eq :OTF-FLG helper-alist)))
             (hints (cdr (assoc-eq :HINTS helper-alist)))
             (instructions (cdr (assoc-eq :INSTRUCTIONS helper-alist)))
             (ugoal (untranslate goal t wrld)))
        (pprogn
         (io? event nil state
              (ugoal n i)
              (fms "The~#0~[~/ ~n1 (and last)~/ ~n1~] guard proof obligation ~
                    is~|~%~y2."
                   (list (cons #\0 (cond ((int= n 1)
                                          (assert$ (= i 1) 0))
                                         ((int= i n)
                                          1)
                                         (t
                                          2)))
                         (cons #\1 (list i))
                         (cons #\2 ugoal))
                   (proofs-co state)
                   state
                   (term-evisc-tuple nil state)))
         (er-let*
          ((ttree1 (cond (instructions (proof-builder nil ugoal goal nil
                                                      instructions wrld state))
                         (t (prove goal
                                   (make-pspv ens wrld state
                                              :displayed-goal ugoal
                                              :otf-flg otf-flg)
                                   hints ens wrld ctx state)))))
          (prove-defattach-guards1 (1+ i)
                                   n
                                   (cdr attachment-alist-tail)
                                   attachment-alist
                                   (cdr helpers-lst)
                                   ctx ens wrld state
                                   (cons-tag-trees ttree1 ttree))))))))

(defun prove-defattach-guards (attachment-alist helpers-lst ctx ens wrld state)

; This function is based on prove-corollaries, but instead of being given
; corollaries, we are given an attachment-alist with pairs (f . g) such that
; the guard of f must be proved to imply the guard of g.  Helpers-lst is a list
; of alists corresponding positionally to attachment-alist, each of which binds
; elements of *defattach-keys* to values to help with the respective proof.
; Like prove, we return an error triple; the non-erroneous value is a ttree
; signaling the successful proof of all the goals.

; Note that filter-for-attachment has been applied before calling this
; function.

  (let ((n (length attachment-alist)))
    (assert$
     (and attachment-alist
          (int= n (length helpers-lst)))
     (pprogn
      (cond ((int= n 1)
             state)
            (t (io? event nil state
                    (n)
                    (fms "~%We first consider the ~n0 guard proof ~
                          obligations.~%"
                         (list (cons #\0 n))
                         (proofs-co state) state nil))))
      (prove-defattach-guards1 1 n attachment-alist attachment-alist
                               helpers-lst ctx ens wrld state nil)))))

; We next introduce several events in support of the special treatment of
; warrants given by defattach.

(defun true-apply$-warrant ()

; Warning: We rely on this function not having any extended ancestors.  See
; attachment-records.

  (declare (xargs :guard t :mode :logic))
  t)

(defun defattach-constraint-rec (alist full-alist proved-fnl-insts-alist
                                       constraint event-names
                                       new-entries seen wrld)

; This function is patterned after relevant-constraints1.  See the comments
; there.

; Alist is a tail of full-alist, an attachment-alist.

  (cond ((endp alist)
         (mv constraint event-names new-entries))
        ((and (eq (cdar alist)
                  'true-apply$-warrant)

; We are considering the case of a pair (f . g), where f is a warrant and g is
; true-apply$-warrant, which is the always-true function we have chosen to
; attach to warrants.  The argument supporting attachments of doppelgangers
; also supports the attachment of each warrant to true-apply$-warrant, because
; in the doppelganger model, every warrant is true.

              (warrant-function-namep (caar alist) wrld))
         (defattach-constraint-rec
           (cdr alist) full-alist proved-fnl-insts-alist constraint
           event-names new-entries seen wrld))
        (t
         (mv-let
          (name x)
          (constraint-info (caar alist) wrld)
          (cond
           ((unknown-constraints-p x)
            (mv x name nil)) ; the nil is irrelevant
           (t

; Note that -- ignoring the case of unknown-constraints -- x is a single
; constraint if name is nil and otherwise x is a list of constraints.

            (let ((key (or name (caar alist))))
              (cond
               ((member-eq key seen)
                (defattach-constraint-rec
                  (cdr alist) full-alist proved-fnl-insts-alist constraint
                  event-names new-entries seen wrld))
               (t
                (let* ((ev (and x ; optimization
                                (event-responsible-for-proved-constraint
                                 key full-alist proved-fnl-insts-alist)))
                       (instantiable-fns
                        (and x ; optimization
                             (cond (name (instantiable-ffn-symbs-lst
                                          x wrld nil nil))
                                   (t (instantiable-ffn-symbs
                                       x wrld nil nil)))))
                       (constraint-alist
                        (and x ; optimization
                             (restrict-alist instantiable-fns full-alist)))
                       (seen (cons key seen)))
                  (cond
                   ((null x)
                    (defattach-constraint-rec
                      (cdr alist) full-alist proved-fnl-insts-alist
                      constraint event-names new-entries seen wrld))
                   (ev (defattach-constraint-rec
                         (cdr alist) full-alist proved-fnl-insts-alist
                         constraint
                         (add-to-set ev event-names)
                         new-entries seen wrld))
                   (t (defattach-constraint-rec
                        (cdr alist) full-alist proved-fnl-insts-alist
                        (if name
                            (conjoin (cons constraint
                                           (sublis-fn-lst-simple
                                            constraint-alist x)))
                          (conjoin2 constraint
                                    (sublis-fn-simple constraint-alist x)))
                        event-names
                        (cons (make proved-functional-instances-alist-entry
                                    :constraint-event-name key
                                    :restricted-alist constraint-alist
                                    :behalf-of-event-name 0)
                              new-entries)
                        seen wrld)))))))))))))

(defun defattach-constraint (attachment-alist proved-fnl-insts-alist wrld ctx
                                              state)
  (mv-let
   (goal event-names new-entries)
   (defattach-constraint-rec attachment-alist attachment-alist
     proved-fnl-insts-alist *t* nil nil nil wrld)
   (cond ((unknown-constraints-p goal)
          (defattach-unknown-constraints-error event-names ctx state))
         (t (value (list* goal event-names new-entries))))))

(defun prove-defattach-constraint (goal event-names attachment-alist
                                        helper-alist ctx ens wrld state)
  (assert$
   (not (unknown-constraints-p goal))
   (let ((constraint-bypass-string
          "  Note that we are bypassing constraints that have been proved ~
           when processing ~#0~[previous events~/events including ~&1~/the ~
           event~#1~[~/s~] ~&1~]."))
     (cond
      ((equal goal *t*)
       (pprogn
        (io? event nil state
             (attachment-alist event-names constraint-bypass-string)
             (fms
              "~%The attachment~#0~[ trivially satisfies~/s trivially ~
                 satisfy~] the required constraints.~@1~|~%"
              (list (cons #\0 attachment-alist)
                    (cons #\1 (cond ((null event-names) "")
                                    ((member 0 event-names)
                                     (cond ((null (cdr event-names))
                                            (msg constraint-bypass-string
                                                 0
                                                 event-names))
                                           (t (msg constraint-bypass-string
                                                   1
                                                   (remove 0 event-names)))))
                                    (t (msg constraint-bypass-string
                                            2 event-names)))))
              (proofs-co state) state nil))
        (value nil)))
      (t
       (let ((ugoal (untranslate goal t wrld))
             (otf-flg (cdr (assoc-eq :OTF-FLG helper-alist)))
             (hints (cdr (assoc-eq :HINTS helper-alist)))
             (instructions (cdr (assoc-eq :INSTRUCTIONS helper-alist))))
         (pprogn
          (io? event nil state
               (attachment-alist event-names constraint-bypass-string ugoal)
               (fms
                "~%We now prove that the attachment~#0~[ satisfies~/s ~
                 satisfy~] the required constraint.~@1~|The goal to prove ~
                 is~|~%~y2."
                (list (cons #\0 attachment-alist)
                      (cons #\1 (cond ((null event-names) "")
                                      ((member 0 event-names)
                                       (cond ((null (cdr event-names))
                                              (msg constraint-bypass-string
                                                   0
                                                   event-names))
                                             (t (msg constraint-bypass-string
                                                     1
                                                     (remove 0 event-names)))))
                                      (t (msg constraint-bypass-string
                                              2 event-names))))
                      (cons #\2 ugoal))
                (proofs-co state) state nil))
          (er-let*
           ((ttree (cond
                    (instructions
                     (proof-builder nil ugoal goal nil instructions
                                    wrld state))
                    (t
                     (prove goal
                            (make-pspv ens wrld state
                                       :displayed-goal ugoal
                                       :otf-flg otf-flg)
                            hints ens wrld ctx state)))))
           (value ttree)))))))))

; Essay on Merging Attachment Records

; See the Essay on Defattach for relevant background.  Our goal in this Essay
; is to describe the process whereby we check for loops in the extended
; ancestor relation and, more generally, compute that relation as a transitive
; closure.

; Let S be the siblings relation: thus S(f1,f2) holds if f1 and f2 are
; introduced in the same event.  Clearly S is an equivalence relation, and we
; will write S(f) to denote the canonical representative of that equivalence
; class, i.e., the canonical sibling of f.  A function f is canonical if S(f)
; is f.

; Recall from the Essay on Defattach that our goal is to reorder events in a
; manner that respects not only the original ancestor relation but also a new
; relation containing the ordered pair <g,f> for each attachment pair <f,g>,
; which we'll call the "immediate extended ancestor relation".  (Motivation:
; The < relation implements the use of an attachment equation in the evaluation
; chronology to define f in terms of g.)  However, for each such <g,f> added to
; that relation, we also add <g',f'> for each sibling g' of g and sibling f' of
; f.  We denote the ordinary ancestors relation as <|, which we also consider
; to respect ancestors: we include <f1',f2'> in this relation whenever f1' and
; f2' are siblings of f1 and f2 (respectively) and f1 is an ordinary ancestor
; of f2.  Finally, we define <+ as the transitive closure of the union of < and
; <|.

; The reordering argument in the Essay on Defattach provides the proof
; obligation that <+ must not contain loops.  Since f1 <+ f2 if and only if
; S(f1) <+ S(f2), we will use canonical siblings in our algorithms.  Indeed, it
; is convenient to think of all of these relations (<, <|, and <+) as being
; defined only on canonical function symbols.  Below, we denote as "f-canonical
; and "g-canonical" the function symbols S(f0) and S(g0), respectively, where
; <f0,g0> ranges over attachment pairs.

; We turn now to describe our transitive closure algorithm for computing <+.
; We create a data structure for each g-canonical function, g.  Each such g is
; associated with its canonical predecessors in each of the relations <| and <,
; and we use notation below such as "FNS" for either of these.  Then, we apply
; a "merge" operation to build up to the transitive closure.  If we encounter a
; loop, as described below, then we stop and report the loop.

; We present our algorithm using examples.  Assume that g1 initially has FNS1
; as its set of predecessors in either <| or <, and that g2 is similarly
; related to FNS2, where g1 < f1 and g2 < f2.  Thus there are attachment pairs
; <f1',g1'> and <f2',g2'> such that S(fi') = fi and S(gi') = gi; and we may
; write FNS1 <+ g1 and FNS2 <+ g2.  Now suppose f2 is in FNS1.  So we have this
; picture:

;                             FNS1 <+ g1
;                FNS2 <+ g2 < f2

; We thus associate with g1 a structure exhibiting the following path, obtained
; by merging the paths above using the attachment pair <f2,g2>.

;                FNS2 <+ g2 < f2 <+ g1

; More generally, we may or may not involve the "f field" (first component) of
; an attachment pair <f,g>.  Consider the following paths P0 and P1.

; P0:                                FNS2 <+ g2 < f2 <+ g1
; P1:   FNS4 <+ g4 <+ ... <+ x <+ g3 < f3

; We could merge using f3 if it is in FNS2, as in our previous example, or
; using g3 if it is in FNS2.  Respectively, the resulting merges of P1 into P0
; are:

;       FNS4 <+ g4 <+ ... <+ x <+ g3 < f3 <+ g2 < f2 <+ g1
;       FNS4 <+ g4 <+ ... <+ x <+ g3      <+ g2 < f2 <+ g1

; Let us call these an "f-merge" and a "g-merge", respectively, of P1 into P0.

; As an optimization, for the case FNS2 <| g2 we only allow a g-merge if P1
; consists entirely of FNS4 <+ g3 < f3.  To justify this optimization, suppose
; that P1 is as above where g4 is not g3.  We may restrict ourselves to
; constructing minimal paths.  We can thus rule out the case x <| g3, since
; otherwise we have y <+ x <| g3 <| g2, which by minimality and transitivity of
; <| implies that we have y < x <| g2.  So x is in FNS2, and we can form a path
; from FNS4 to g1 by doing an f-merge after stripping g3 from P1 (with y<x
; playing the role of g3<f3).

; In general, each such g1 is associated with a record structure that we refer
; to as an "attachment record", which includes a list of paths that is
; continually expanded by merging paths from other records into its existing
; paths.  We return later to a brief discussion of the implementation, in
; particular the relevant data structures.

; We employ a further optimization (function defattach-component-has-owner).
; Stored with each path is an "owner": the function symbol immediately
; following the initial set of functions, which we use to avoid attempting any
; merge that would be redundant in the sense that there is already a path with
; the same owner.  Consider again the merge candidate pictured above.

; P0:                                FNS2 <+ g2 < f2 <+ g1
; P1:   FNS4 <+ g4 <+ ... <+ x <+ g3 < f3

; Suppose we are considering a merge of these components, but the attachment
; record for g1 already has a component owned by g4.  Then we avoid considering
; such a merge, since the result would merely produce another <+-path from FNS4
; to g1.  (Note that we actually store both sorts of FNS4: the <-predecessors
; of g4 and the <|-predecessors of g4.)

; In particular, we never need merge two components from the same record, a
; fact we utilize in function defattach-merge-lst-lst.

; It is easy to see by induction that all paths built by this merging process
; stay inside the transitive closure (<*) of <+.  That is, our algorithm is
; sound.  For completeness, we first need a notion of "suitable" path x0 <+ x1
; <+ ... <+ xk (think of x0 as belonging to the FNS associated with x1),
; defined as follows.

; - We can write the path so that each arc joining consecutive elements is of
;   the form g < f or h <| g, where no two consecutive arcs both use <|.
; - Each element of the path is f-canonical or g-canonical.
; - The final arc in the path is of the form h < g or h <| g for some
;   g-canonical g.

; Clearly the f-merge and g-merge operations shown above preserve this notion
; of suitable path.  It is also clear that every minimal path of length at
; least 2 whose penultimate element is g-canonical is a suitable path.

; Thus, we need consider only suitable paths when forming the transitive
; closure.  We claim that after at least n full iterations of our algorithm
; (that is: attempting all possible pairwise merges at each iteration, and
; perhaps more), then every suitable path FNS <+ ... <+ g of length at most
; 2^N+1 is present.  This fact has a straightforward proof by induction on the
; length of a path, where the inductive step proceeds by dividing a path of
; length 2^N+1 into two pieces where the head of one is the tail of the other,
; one of length at most 2^(N-1) and the other of length at most 2^(N-1)+1.

; The argument above shows that in fact, the attachment record for every
; g-canonical g includes every <+-ancestor of g (again, considering only
; canonical function symbols), either as a member of the set FNS defined by FNS
; <| g' for some g-canonical g' <+ g, or else as such a g' (the owner of the a
; component's path for ordinary ancestor set FNS).

; As we compute the transitive closure, we look for loops.  Where do we look?
; First observe that if there is a loop, then the loop involves at least one
; use of <; so there is a loop connecting g to itself for some g-canonical g.
; By the argument above we know that we will at some point construct a path
; from g; thus g is in FNS where we have constructed FNS <+ h <+ ... g.  When
; that occurs, we report the loop.

; (Remark.  Notice that we are building up the set of extended ancestors of g
; in a manner that lets us report any loop that is found.  We may be able to
; change our algorithm to compute this set more efficiently by unioning all the
; FNS found into a single FNS for the entire attachment record, running the
; original algorithm only if a loop is detected; but that can wait.  The
; current approach may have the advantage that less needs to be thrown away
; when we erase, as with (defattach f nil).  End of remark.)

; Let's explore further how this works at the implementation level.

; Attachment records have the following fields, where we write x++y to denote
; the result of appending y to x unless x or y is a symbol, in which case it is
; treated as a list containing just that symbol.  For example, if x is (f1 f2)
; and y is either (f3) or f3, then x++y is (f1 f2 f3).

; - g
;   where g is g-canonical
; - ext-succ
;   (immediate) canonical successors of g in <
; - components
;   A list of components, each of which is an attachment-component record
;   having the following fields:
;     - path
;       a list of function symbols such that each element has relation < or <|
;       to the next
;     - ext-anc, ord-anc
;       the set of predecessors under < (respectively, <|) of the first element
;       of path++g; thus if path is empty then g else the first element of
;       path.  Note that we collect here only canonical function symbols.
; - pairs
;   list of all attachment pairs <f0,g0> such that S(g0) = g; thus, the
;   :ext-succ field is the set of S(f0) for all <f0,g0> in the :pairs field

; Note that the pairs field is used only by the code that erases attachment
; pairs, not by the code that merges paths.

; The notion of owner, introduced above, is realized in the following
; definition.

(defun attachment-component-owner (g path)

; Return the owner of an attachment-component, with :path field of path, that
; is in the :components field of an attachment record with :g field of g.

  (if path (car path) g))

; The initial attachment record for a given g has a unique component, with
; owner g and empty path, and whose ext-anc field (denoted fns<g) and ord-anc
; field (denoted fns<|g) are, respectively, the set of all immediate extended
; ancestors (i.e., <-predecessors) and of ordinary ancestors (i.e.,
; <|-predecessors) of g.  We maintain the invariant that this component is
; always the last one in the list of components of an attachment record.

; We can now build our algorithm from the bottom up.  The fundamental operation
; is (defattach-merge r1 r2), which merges r2 into r1 if there is such a merge.
; Function defattach-merge-lst takes a record r1 and list lst of records, and
; repeatedly merges the elements of lst into r1.  Function
; defattach-merge-lst-lst is called on a list of records and merges each record
; into each other record in the list.

; But we might find a cycle.  The above functions typically return (mv flg
; result), where: flg = nil if there has been no merging, in which case result
; is irrelevant; flg = 'loop if there has been merging, in which case result is
; the representation of a loop; or flg = t, in which case there has been
; merging but there is no loop.

; End of Essay on Merging Attachment Records

(defun defattach-component-has-owner (g g0 comps)

; See the Essay on Merging Attachment Records.

; Comps is a list of attachment components from an attachment record with :g
; field of g0.  We return true when there is a component from comps whose owner
; is g.  The idea is that we are considering whether to try to merge a
; component with path [FNS <+ g <+ ...]  into the set comps of components of
; some attachment record for g0.  If one of those components already contains
; such a path, then we return true to indicate that don't need another one.

  (cond ((endp comps) nil)
        (t (let ((path (access attachment-component (car comps) :path)))
             (or (eq g (attachment-component-owner g0 path))
                 (defattach-component-has-owner g g0 (cdr comps)))))))

(defun defattach-merge-into-component (g0 ext-succ0 comps0 ext-succ1 g1
                                          ord-anc1 ext-anc1 path1)

; See the Essay on Merging Attachment Records.  We return (mv flg x), where if
; flg is 'loop then x is a loop, and otherwise x is a list of components
; extending comps0, as described below, and flg is nil if x is exactly comps0,
; else t.

; We attempt a merge into some component of a record, R0, from a component of
; another record, R1.  The following picture illustrates the situation using
; parameter names from this function and local variables introduced in the code
; below, while omitting unneeded fields.

; R0:
; [:g g0
;  :ext-succ ext-succ0
;  :comps
;  (   ...
;      [:ord-anc ord-anc0
;       :ext-anc ext-anc0
;       :path path0 ; nil or (h0 ...)
;      ...)

; R1:
; (:ext-succ ext-succ1
;  :g g1
;  :comps ; comps1, which is the following list:
;   (
;      ...
;      [:ord-anc ord-anc1
;       :ext-anc ext-anc1
;       :path path1 ; nil
;      ...)

; First consider the f-merge case.  From R0 and R1 we have the following paths,
; where each anci is either ord-anci or ext-anci.

;                       anc0 <+ h0 <+ ... <+ g0
;   anc1 <+ ... <+ g1 < ext-succ1

; For an f-merge we need ext-succ1 and anc0 to intersect; suppose we find h in
; their intersection.  The resulting component then has this path:

;   anc1 <+ ... <+ g1 < h <+ h0 <+ ... <+ g0

; For the g-merge case we require either the use of ext-anc0 for anc0, or else
; that path1 = nil.  Then we can consider the following picture.

;                anc0 <+ h0 <+ ... <+ g0
;   anc1 <+ ... <+ g1

; We can merge if g1 is in anc0, obtaining:

;   anc1 <+ ... <+ g1 <+ h0 <+ ... <+ g0

; Suppose that the merge succeeds.  If g0 is in anc1, then we have a loop.  We
; also have a loop if ext-succ0 intersects anc1, say at h1:

;    h1  <+ ... <+ g1 <+ h0 <+ ... <+ g0 < h1

; If h1 is not itself g-canonical, then will not find the merge below at a later
; step, because it requires merging two components both attached to the same
; record (with :g field g0), which we avoid for efficiency.

;      anc1 <+ ... <+ ... <+ g0
;  g0 < h1

; So we look for these loops, too.

; Since our goal is to produce a <+ path from the owner of the supplied
; component of R1 up to g0, we stop when we find a merge, in which case we
; return (mv nil comp) where comp is the new component for R0.

  (cond
   ((endp comps0)
    (mv nil nil))
   (t
    (let* ((comp0 (car comps0))
           (path0 (access attachment-component comp0 :path))
           (ext-anc0 (access attachment-component comp0 :ext-anc))
           (ord-anc0 (access attachment-component comp0 :ord-anc))
           (new-path ; non-nil if merge succeeds
            (cond
             ((or (member-eq g1 ext-anc0)
                  (and (null path1)
                       (member-eq g1 ord-anc0)))
              (append path1 (cons g1 path0)))
             (t
              (let ((h (or (intersection1-eq ext-anc0 ext-succ1)
                           (intersection1-eq ord-anc0 ext-succ1))))
                (and h
                     (append path1 (list* g1 h path0))))))))
      (cond
       ((null new-path)
        (defattach-merge-into-component
          g0 ext-succ0 (cdr comps0) ext-succ1 g1 ord-anc1 ext-anc1 path1))
       ((or (member-eq g0 ord-anc1)
            (member-eq g0 ext-anc1))
        (mv 'loop (cons g0 new-path)))
       (t
        (let ((h1 (or (intersection1-eq ext-succ0 ord-anc1)
                      (intersection1-eq ext-succ0 ext-anc1))))
          (cond
           (h1

; As explained in a comment above, it is important to include this case rather
; than to wait later to find this loop.

            (mv 'loop (list* g0 h1 new-path)))
           (t
            (mv nil
                (make attachment-component
                      :ord-anc ord-anc1
                      :ext-anc ext-anc1
                      :path new-path)))))))))))

(defun defattach-merge-components (g0 ext-succ0 comps0 ext-succ1 g1 comps1
                                      flg extended-comps0)

; See the Essay on Merging Attachment Records.

; We merge components comps1 of an attachment record with fields ext-succ1, g1,
; and comps1, into components comps0 of an attachment record for attachment g0,
; if possible.  If a loop is found then we return (mv 'loop path), where path
; witnesses a loop.  Otherwise we return (mv flg x), where x is the result of
; appending the list of new components comps0, and flg is nil if that list is
; nil (i.e., no merging took place), else t.

  (cond ((endp comps1)
         (mv flg extended-comps0))
        ((defattach-component-has-owner
           (attachment-component-owner g1
                                       (access attachment-component
                                               (car comps1)
                                               :path))
           g0
           comps0)
         (defattach-merge-components
           g0 ext-succ0 comps0 ext-succ1 g1 (cdr comps1) flg extended-comps0))
        (t (mv-let
            (flg1 new-comp)
            (let ((comp1 (car comps1)))
              (defattach-merge-into-component
                g0 ext-succ0 comps0 ext-succ1 g1
                (access attachment-component comp1 :ord-anc)
                (access attachment-component comp1 :ext-anc)
                (access attachment-component comp1 :path)))
            (cond ((eq flg1 'loop)
                   (mv flg1 new-comp))
                  (new-comp
                   (defattach-merge-components
                     g0 ext-succ0 comps0 ext-succ1 g1 (cdr comps1)
                     t (cons new-comp extended-comps0)))
                  (t
                   (defattach-merge-components
                     g0 ext-succ0 comps0 ext-succ1 g1 (cdr comps1)
                     flg extended-comps0)))))))

(defun defattach-merge (r0 r1)

; See the Essay on Merging Attachment Records.

; Merge attachment record r1 into r0.  We return (mv flg val), where either flg
; is nil and r0 is returned unchanged as val, or flg is 'loop and val is a
; loop, or else flg is t and val is the resulting merge.

  (let ((g0        (access attachment r0 :g))
        (ext-succ0 (access attachment r0 :ext-succ))
        (comps0    (access attachment r0 :components))
        (ext-succ1 (access attachment r1 :ext-succ))
        (g1        (access attachment r1 :g))
        (comps1    (access attachment r1 :components)))
    (mv-let (flg val)
            (defattach-merge-components
              g0 ext-succ0 comps0 ext-succ1 g1 comps1 nil comps0)
            (cond ((eq flg 'loop)
                   (mv flg val))
                  ((null flg)
                   (mv nil r0))
                  (t (mv t (change attachment r0
                                   :components val)))))))

(defun defattach-merge-lst (r lst changedp)

; See the Essay on Merging Attachment Records.  Here we merge each element of
; lst, a list of attachment records, into the given attachment record, r.  We
; return (mv flg x), where either flg is 'loop and x is a path witnessing a
; loop, or else x is the result of merging each record from lst into r and flg
; is t if x is not r or if changedp is t.

  (declare (xargs :measure (acl2-count lst)))
  (cond ((endp lst)
         (mv changedp r))
        (t (mv-let (flg r)
                   (defattach-merge r (car lst))
                   (cond ((eq flg 'loop)
                          (mv flg r))
                         (t (defattach-merge-lst
                              r (cdr lst) (or flg changedp))))))))

(defun defattach-merge-lst-lst (to-do done changedp)

; See the Essay on Merging Attachment Records.

; To-do and done are lists of attachment records.  We recur through to-do,
; successively pushing the first element r of to-do onto done after updating it
; to a record obtained by merging into it every element of (cdr to-do) and of
; done.  If at any point a loop is found then we return (mv 'loop path) to
; witness the loop.  Otherwise we return (mv flg val), where val is the final
; value of done and flg is t if and only if at least one merge was completed.

  (cond ((endp to-do)
         (mv changedp done))
        (t (mv-let (flg r)
                   (defattach-merge-lst (car to-do) (cdr to-do) changedp)
                   (cond ((eq flg 'loop)
                          (mv flg r))
                         (t (mv-let (flg r)
                                    (defattach-merge-lst r done flg)
                                    (cond ((eq flg 'loop)
                                           (mv flg r))
                                          (t (defattach-merge-lst-lst
                                               (cdr to-do)
                                               (cons r done)
                                               (or changedp flg)))))))))))

(defun defattach-loop-error-msg (loop end)
  (cond ((endp loop)
         "")
        (t (let ((h1 (car loop))
                 (h2 (if (cdr loop) (cadr loop) end)))
             (msg "~x0 is an extended ancestor of ~x1.~|~@2"
                  h1 h2
                  (defattach-loop-error-msg (cdr loop) end))))))

(defun defattach-loop-error (loop ctx state)
  (er soft ctx
      "The proposed defattach event is illegal because the following is a ~
       loop in the resulting extended ancestor relation.  See :DOC ~
       defattach.~|~%~@0"
      (defattach-loop-error-msg loop (car loop))))

(defun defattach-close (records ctx state)
  (mv-let (flg records)
          (defattach-merge-lst-lst records nil nil)
          (cond ((eq flg 'loop)
                 (defattach-loop-error records ctx state))
                ((eq flg nil)
                 (value records))
                (t (defattach-close records ctx state)))))

(defun defattach-erase-components (components canonical-erased-fs)

; Components is a list of attachment-component records, and canonical-erased-fs
; lists all canonical siblings of functions whose attachments are to be erased.
; We eliminate any component that takes advantage of an erased g < f.  We are
; already erasing the record if the canonical sibling of some such f is the :g
; field of the record.  Otherwise, the only way removal of g < f can invalidate
; a component is if its path mentions the canonical sibling of f.  (Even though
; paths implicitly start with a member of :ord-anc or of :ext-anc, that member
; would be g in the above scenario; the canonical sibling of f would still be
; in the path explicitly.)

; We can imagine a finer-grained algorithm, in which we only invalidate
; components when we find an inappropriate link (with suitable attention to
; :ext-anc and :ord-anc).  But we expect that in most cases there will only be
; one attachment pair for a given element of canonical-erased-fs, and we would
; wind up with essentially the same algorithm.  So we keep it simple.

  (cond ((endp components) (mv nil nil))
        (t (let ((comp (car components)))
             (mv-let
              (changedp cdr-comps)
              (defattach-erase-components
                (cdr components) canonical-erased-fs)
              (cond
               ((intersectp-eq (access attachment-component comp :path)
                               canonical-erased-fs)
                (mv t cdr-comps))
               (changedp (mv t (cons comp cdr-comps)))
               (t (mv nil components))))))))

(defun defattach-erase-p (record erasures canonical-erased-fs)

; We are deciding whether to erase the given attachment record, where erasures
; is a list of attachment pairs to erase from the world and canonical-erased-fs
; lists all canonical siblings of functions whose attachments are to be erased.
; Return (mv flg pairs), where flg is nil if we are to keep the record, and
; otherwise pairs contains the attachment pairs stored in the record that we do
; not want to erase.

  (let* ((pairs (access attachment record :pairs))
         (removed-pairs (intersection-equal erasures pairs)))
    (cond (removed-pairs
           (mv t (set-difference-equal pairs removed-pairs)))
          ((member-eq (access attachment record :g)
                      canonical-erased-fs)
           (mv t pairs))
          (t (mv nil nil)))))

(defun defattach-erase1 (records attachments erasures canonical-erased-fs
                                 acc-recs)
; See defattach-erase.

  (cond ((endp records)
         (mv acc-recs attachments))
        (t (mv-let
            (flg new-attachments)
            (defattach-erase-p (car records) erasures canonical-erased-fs)
            (cond (flg (defattach-erase1
                         (cdr records)
                         (append new-attachments attachments)
                         erasures
                         canonical-erased-fs
                         acc-recs))
                  (t
                   (let* ((comps (access attachment (car records) :components))
                          (rec (mv-let
                                (changedp comps)
                                (defattach-erase-components
                                  comps
                                  canonical-erased-fs)
                                (assert$
                                 comps
                                 (cond (changedp
                                        (change attachment (car records)
                                                :components comps))
                                       (t (car records)))))))
                     (defattach-erase1
                       (cdr records)
                       attachments
                       erasures
                       canonical-erased-fs
                       (cons rec acc-recs)))))))))

(defun defattach-erase (records attachments erasures wrld)

; This function is called with the existing attachment records of wrld, the
; proposed new attachment pairs, and the existing attachment pairs to erase.
; It returns (mv new-records new-attachments), such that the ultimate extension
; of new-records by new-attachments will produce an update of records that
; reflects the given erasures and attachments.

; We recur through records, eliminating each record from which at least one
; pair in its :pairs fields is deleted, and pushing all remaining pairs on
; attachments.  (We can imagine keep a record if there is at least one
; remaining attachment pair, but that would seem to be a rare case and we
; prefer to keep the code simple.)  We also eliminate any component that could
; be invalid; see defattach-erase1.

  (let ((canonical-erased-fs
         (collect-canonical-siblings (strip-cars erasures) wrld nil nil)))
    (defattach-erase1
      records attachments erasures canonical-erased-fs nil)))

(defun collect-ext-anc (f records)

; We collect all :g fields of records for which f, which is canonical, is in
; the :ext-succ field.

  (cond ((endp records) nil)
        ((member-eq f (access attachment (car records) :ext-succ))
         (cons (access attachment (car records) :g)
               (collect-ext-anc f (cdr records))))
        (t (collect-ext-anc f (cdr records)))))

(defun extend-attachment-components (comps g0 ext-succ f g)

; Comps is a list of attachment-component records in an attachment record with
; :g field of g0.  We are adding g < f to the immediate extended ancestors
; relation, where f and g are canonical and g is not g0.  Each component in
; comps that is owned by f has g added to its :ext-anc field.  If in this case
; g is in ext-succ, the extended (canonical) successors of g0, then we report a
; loop.  Otherwise we return the updated comps.

; We return (mv flg val) as follows.  If flg is nil then val is comps: no loop
; was found, and no component in comps is to change.  If flg is 'loop, then val
; is a loop.  Otherwise flg is t and val is the new list of components.

  (cond ((endp comps) (mv nil nil))
        (t (mv-let
            (flg cdr-comps)
            (extend-attachment-components (cdr comps) g0 ext-succ f g)
            (cond
             ((eq flg 'loop)
              (mv flg cdr-comps))
             (t (let* ((comp (car comps))
                       (path (access attachment-component comp :path)))
                  (cond
                   ((eq f (attachment-component-owner g0 path))
                    (cond
                     ((member-eq g ext-succ)
                      (mv 'loop (list* g0 g path)))
                     (t (let ((ext-anc (access attachment-component comp
                                               :ext-anc)))
                          (cond ((member-eq g ext-anc) ; no change to comp
                                 (cond (flg (mv t (cons comp cdr-comps)))
                                       (t (mv nil comps))))
                                (t (mv t
                                       (cons (change attachment-component comp
                                                     :ext-anc
                                                     (cons g ext-anc))
                                             cdr-comps))))))))
                   (flg (mv t (cons comp cdr-comps)))
                   (t (mv nil comps))))))))))

(defun component-path-extension (f comps)

; Comps is a list of attachment-component records and f is a canonical function
; symbol.  We return non-nil if and only if for some member C of comps, either
; C is non-empty and f is its owner (car), or else f is a member of the
; :ext-anc or :ord-anc field of C.  In that case we return the path of C, but
; extended by f except in the former case.

  (cond ((endp comps) nil)
        ((let ((path (access attachment-component (car comps) :path)))
           (and (eq (car path) f)
                path)))
        ((or (member-eq f (access attachment-component (car comps) :ext-anc))
             (member-eq f (access attachment-component (car comps) :ord-anc)))
         (cons f (access attachment-component (car comps) :path)))
        (t (component-path-extension f (cdr comps)))))

(defun extend-attachment-record (pair f-canon g-canon rec)

; We are given an attachment pair (f . g), with canonical siblings f-canon of f
; and g-canon of g.  We compute a modification the given attachment record,
; rec, to reflect this additional attachment pair.  We return (mv flg val),
; where: flg is 'loop and val is a loop; or else val is the modified record,
; which is equal (in fact eq) to rec if flg is nil.  If flg is not 'loop, then
; flg is 'found if and only if the :g field of rec is g-canon.

  (let ((ext-succ (access attachment rec :ext-succ))
        (g-field (access attachment rec :g))
        (comps (access attachment rec :components)))
    (cond
     ((eq g-canon g-field)
      (let ((pairs (access attachment rec :pairs))
            (path (component-path-extension f-canon comps)))
        (assert$ ; we already erased an attachment for f-canon
         (not (member-equal pair pairs))
         (cond (path
                (mv 'loop (cons g-canon path)))
               ((member-eq f-canon ext-succ)
                (mv 'found (change attachment rec
                                   :pairs (cons pair pairs))))
               (t
                (mv 'found (change attachment rec
                                   :pairs (cons pair pairs)
                                   :ext-succ (cons f-canon ext-succ))))))))
     (t
      (mv-let
       (flg new-comps)
       (extend-attachment-components comps g-field ext-succ f-canon g-canon)
       (cond ((eq flg 'loop)
              (mv 'loop new-comps))
             (flg (mv t (change attachment rec
                                :components new-comps)))
             (t (mv nil rec))))))))

(defun update-attachment-records1 (pair f-canon g-canon records)

; We extend each attachment record in the list, records, for the new given
; attachment pair, pair.  If pair is (f . g), then f-canon and g-canon are the
; canonical siblings of f and g, respectively.  We actually return (mv flg
; recs), where either flg is 'loop and recs is a loop, or else recs is an
; updated version of records.  If flg is nil then recs is equal (even eq) to
; the input records.  If flg is not 'loop, then it is 'found if some record in
; records has :g field equal to g-canon.

  (cond
   ((endp records)
    (mv nil nil))
   (t (mv-let (flg recs)
              (update-attachment-records1 pair f-canon g-canon (cdr records))
              (cond ((eq flg 'loop)
                     (mv 'loop recs))
                    (t (mv-let (flg2 rec)
                               (extend-attachment-record pair f-canon g-canon
                                                         (car records))
                               (cond ((eq flg2 'loop)
                                      (mv 'loop rec))
                                     ((or flg flg2)
                                      (mv (if (or (eq flg 'found)
                                                  (eq flg2 'found))
                                              'found
                                            t)
                                          (cons rec recs)))
                                     (t
                                      (mv nil records))))))))))

(defun update-attachment-records (pair f-canon g-canon records wrld ctx state)

; We attempt to extend the given list of attachment records with the indicated
; attachment pair, which we may write as (f . g).  F-canon and g-canon are the
; canonical siblings of f and g, respectively.  The attempt may fail with the
; reporting of a loop using the extended ancestor relation.

; The basic algorithm is to recur through records, updating each; see
; update-attachment-records.  If none of the records has a :g field of g-canon,
; then we also create a new record for the given attachment pair.

  (mv-let (flg recs)
          (update-attachment-records1 pair f-canon g-canon records)
          (cond ((eq flg 'loop)
                 (defattach-loop-error recs ctx state))
                ((eq flg 'found)
                 (value recs))
                (t ; need to add a new record for g-canon
                 (let* ((ext-succ (siblings f-canon wrld))
                        (ord-anc (canonical-ancestors g-canon wrld nil))
                        (ext-anc (collect-ext-anc g-canon records))
                        (h (or (intersection1-eq ord-anc ext-succ)
                               (intersection1-eq ext-anc ext-succ))))
                   (cond
                    (h (defattach-loop-error (list g-canon h) ctx state))
                    (t (value
                        (cons (make attachment
                                    :ext-succ ext-succ
                                    :g g-canon
                                    :components
                                    (list (make attachment-component
                                                :ord-anc ord-anc
                                                :ext-anc ext-anc
                                                :path nil))
                                    :pairs (list pair))
                              recs)))))))))

(defun attachment-records (attachments records wrld ctx state)

; We extend records by recurring through the given list of attachment pairs,
; incorporating each pair.

  (cond
   ((endp attachments)
    (value records))
   (t (let ((pair (car attachments)))
        (cond
         ((warrant-function-namep (car pair) wrld)

; For the purpose of finding loops, we can ignore attachments to warrants.  The
; reason is that we can view attachments as being done in two stages: first,
; the user does some attachments, and we check here for cycles; then, the
; resulting evaluation theory is extended to a bigger evaluation theory in
; which functions are attached to their doppelgangers, and where the warrants
; are all true.  That second step is justified in the paper, ``Limited Second
; Order Functionality in a First Order Setting'', where we prove that for any
; certified user book we could attach defined functions to badge-userfn and
; apply$-userfn so that all the warrants are valid in the resulting evaluation
; theory.

; We can also ignore attachments to warrants when computing extended ancestors
; for handling functions memoized with :aokp t, because they are all attached to
; true-apply$-warrant, which is a defined function and hence cannot have its
; behavior changed with an attachment, and which has no ancestors.  See the
; Essay on Memoization with Attachments.

; This little change can make a big difference.  We ran some tests, in each
; case turning off output first with (set-inhibit-output-lst
; *valid-output-names*).  First, we ran (tests 1000), which introduces 1000
; definitions and then times 1000 corresponding defattach events.  That took
; 0.15 seconds.  Then in a new session, we ran (tests+ 1000), which is similar
; to (tests 1000) except that it first introduced 1000 defun$ events -- hence,
; and more to the point, 1000 defwarrant events.  The time reported for the
; 1000 defattach events went up from 0.15 seconds to more than 4.5 seconds.
; With the change implemented here, the time for (tests+ 1000) went down to
; 0.15 seconds, about the same as (tests 1000).

;   (defun tests-fn (n)
;     (declare (xargs :guard (natp n)))
;     (cond ((zp n) nil)
;           (t (list* `(defn ,(packn (list 'g n)) (x) (cons x x))
;                     (tests-fn (1- n))))))
;
;   (defun defattach-tests-fn (n)
;     (declare (xargs :guard (natp n)))
;     (cond ((zp n) nil)
;           (t (cons `(defattach f ,(packn (list 'g n)))
;                    (defattach-tests-fn (1- n))))))
;
;   (defmacro tests (n)
;     `(ld '((defstub f (x) t)
;            ,@(tests-fn n)
;            (time$ (progn ,@(defattach-tests-fn n))))))
;
;   (defun defun$-tests-fn (n)
;     (declare (xargs :guard (natp n)))
;     (cond ((zp n) nil)
;           (t (list* `(defun$ ,(packn (list 'f n)) (x)
;                        (declare (xargs :guard t))
;                        (cons x x))
;                     (defun$-tests-fn (1- n))))))
;
;   (defmacro tests+ (n)
;     `(ld '((defstub f (x) t)
;            ,@(defun$-tests-fn n)
;            ,@(tests-fn n)
;            (time$ (progn ,@(defattach-tests-fn n))))))

          (assert$
           (eq (cdr pair) 'true-apply$-warrant)
           (attachment-records (cdr attachments) records wrld ctx state)))
         (t (let ((f-canon (canonical-sibling (car pair) wrld))
                  (g-canon (canonical-sibling (cdr pair) wrld)))
              (er-let* ((records
                         (update-attachment-records pair f-canon g-canon
                                                    records wrld ctx state)))
                (attachment-records (cdr attachments) records wrld ctx
                                    state)))))))))

(defun chk-defattach-loop (attachments erasures wrld ctx state)

; Attachments is the proposed attachment-alist from a defattach event, and
; erasures is a list of attachment pairs to be removed from wrld.

; If a loop exists in the extended ancestor relation, as described in the Essay
; on Defattach and further in the Essay on Merging Attachment Records, then
; cause an error that prints such a loop.  Otherwise, return the new list of
; attachment records for the world.  Note that some of the attachment records
; currently in the world may need to be modified, because extended ancestor
; information depends on attachments being erased.

  (let ((records

; This value ignores attachments to warrants, but that is OK because warrants
; can only be attached to true-apply$-warrant, which has no ancestors.  See the
; Essay on Memoization with Attachments.

         (global-val 'attachment-records wrld)))
    (mv-let (records attachments)
            (cond (erasures
                   (defattach-erase
                     records
                     attachments
                     erasures
                     wrld))
                  (t (mv records attachments)))
            (cond
             ((null attachments)

; Some components may have been deleted, so records may not be suitably closed.
; However, we will close records the next time we add any attachments.  So it
; seems safe to avoid the closure operation here, which is a nice thing to do
; when the only "attachments" are to nil in the proposed defattach event.

              (value records))
             (t
              (er-let* ((records (attachment-records attachments records wrld
                                                     ctx state)))
                       (defattach-close records ctx state)))))))

(defun defaxiom-supporter-msg-list (symbols wrld)
  (cond ((endp symbols) nil)
        (t (let ((prop (getpropc (car symbols) 'defaxiom-supporter nil wrld)))
             (cond
              (prop (cons (msg "function symbol ~x0 supports defaxiom ~x1"
                               (car symbols) prop)
                          (defaxiom-supporter-msg-list (cdr symbols) wrld)))
              (t (defaxiom-supporter-msg-list (cdr symbols) wrld)))))))

(defun defattach-global-stobjs-msg (attachment-alist-exec wrld state)
  (cond ((endp attachment-alist-exec) nil)
        (t (let* ((f (caar attachment-alist-exec))
                  (g (cdar attachment-alist-exec))
                  (gs-f (getpropc f 'global-stobjs nil wrld))
                  (gs-f-reads (car gs-f))
                  (gs-f-writes (cdr gs-f))
                  (gs-g (getpropc g 'global-stobjs nil wrld))
                  (gs-g-reads (car gs-g))
                  (gs-g-writes (cdr gs-g)))
             (cond ((and (subsetp-eq gs-g-writes gs-f-writes)
                         (subsetp-eq gs-g-reads
                                     (append gs-f-writes gs-f-reads)))
                    (defattach-global-stobjs-msg
                      (cdr attachment-alist-exec) wrld state))
                   (t (msg
                       "The attachment of ~x0 to ~x1 restricts stobjs bound ~
                        by WITH-GLOBAL-STOBJ under calls of ~x0, according to ~
                        the :GLOBAL-STOBJS keyword (default nil) in the ~
                        signature introducing ~x1.  But this restriction is ~
                        violated for stobj~#2~[~/s~] ~&2:  ~@3"
                       g f
                       (append (set-difference-eq gs-g-writes gs-f-writes)
                               (set-difference-eq gs-g-reads
                                                  (append gs-f-writes
                                                          gs-f-reads)))
                       (let* ((upd (set-difference-eq gs-g-writes gs-f-writes))
                              (st (if upd
                                      (car (set-difference-eq gs-g-writes
                                                              gs-f-writes) )
                                    (car (set-difference-eq gs-g-reads
                                                            (append gs-f-writes
                                                                    gs-f-reads)))))
                              (path (path-to-with-global-stobj
                                     st
                                     (list g)
                                     upd wrld nil nil)))
                         (with-global-stobj-illegal-path-msg
                          "the attempt is to attach"
                          (msg ", yet that stobj is not specified~@0 by the ~
                                :GLOBAL-STOBJS keyword of ~x1"
                               (if upd " for updating" "")
                               f)
                          path st upd wrld)))))))))

(defun find-transparent (lst wrld)
  (cond ((endp lst) nil)
        ((transparent-fn-p (canonical-sibling (car lst) wrld)
                           wrld)
         (car lst))
        (t (find-transparent (cdr lst) wrld))))

(defun chk-defattach-transparent (attachment-alist-sorted explicit-erasures
                                                          ctx wrld state)
  (let* ((attached-fns (strip-cars attachment-alist-sorted))
         (tr (or (find-transparent attached-fns wrld)
                 (find-transparent explicit-erasures wrld))))
    (cond
     ((null tr) (value nil))
     ((and attached-fns explicit-erasures)
      (er soft ctx
          "When a defattach event specifies a transparent function symbol to ~
           be attached or unattached, then it is illegal for that same event ~
           to specify both an attachment and an erasure.  The proposed ~
           defattach event for transparent function symbol ~x0 is thus ~
           illegal.  See :DOC defattach."
          tr))
     (t (let ((siblings (siblings tr wrld))
              (fns (or attached-fns explicit-erasures)))
          (cond ((equal fns siblings) (value nil))
                ((first-non-member-eq fns siblings)
                 (er soft ctx
                     "The function symbol ~x0 was introduced as transparent, ~
                      but both ~x0 and ~x1 are specified for ~
                      ~#2~[un~/~]attachment in a proposed defattach event ~
                      even though ~x1 was not introduced in the same ~
                      encapsulate event as ~x0.  This is illegal; see :DOC ~
                      defattach."
                     tr
                     (first-non-member-eq fns siblings)
                     (if explicit-erasures 0 1)))
                ((first-non-member-eq siblings fns)
                 (er soft ctx
                     "A proposed defattach event ~#0~[un~/~]attaches to ~x1 ~
                      but not to ~x2, even though ~x1 and ~x2 are transparent ~
                      function symbols that were introduced in the same ~
                      encapsulate event.  This is illegal; see :DOC defattach."
                     (if explicit-erasures 0 1)
                     tr
                     (first-non-member-eq siblings fns)))
                (t (value nil))))))))

(defun chk-acceptable-defattach (args proved-fnl-insts-alist ctx wrld state)

; Given the arguments to defattach, args, we either return an error (mv t nil
; state) or else we return (mv nil (erasures explicit-erasures
; attachment-alist-sorted new-entries ttree . records) state), where:
; - erasures is a list of attachment pairs currently in wrld that need to be
;   removed
; - explicit-erasures contains all f for which f is associated with nil in args
; - attachment-alist-sorted associates function symbols with their proposed
;   attachments, sorted by car (using symbol-<);
; - attachment-alist-exec is a sublist of attachment-alist-sorted (but
;   attachment-alist-exec has not been sorted, designating attachment pairs
;   that are to be installed for execution;
; - new-entries is a list to be used for extending (global-val
;   'proved-functional-instances-alist wrld);
; - ttree is a tag-tree obtained from the proofs done on behalf of the
;   defattach event; and
; - records is the new list of attachment records to install in the world.

; We return an error if any function that would be in the domain of
; attachment-alist-exec is missing a 'constraint-lst property or has a
; 'constrainedp property of nil.  Any proposed attachment or unattachment that
; agrees with the current attachment status will cause a suitable warning, and
; will not be included in the erasures or attachment-alist-sorted that we
; return.

  (er-let* ((tuple (er-progn (chk-non-local-in-non-trivial-encapsulate
                              "Defattach events" nil ctx wrld state)
                             (process-defattach-args args ctx state))))
    (let* ((constraint-helper-alist (nth 0 tuple))
           (erasures                (nth 1 tuple))
           (explicit-erasures       (nth 2 tuple))
           (attachment-alist-sorted (nth 3 tuple))
           (attachment-alist-exec   (nth 4 tuple))
           (guard-helpers-lst       (nth 5 tuple))
           (skip-checks             (nth 6 tuple))
           (attach-nil-lst          (nth 7 tuple))
           (skip-checks-t           (eq (nth 6 tuple) t))
           (ens (ens state))
           (ld-skip-proofsp (ld-skip-proofsp state))
           (defaxiom-supporter-msg-list
             (and (not skip-checks-t)
                  (defaxiom-supporter-msg-list

; With some thought we might be able to replace attachment-alist-sorted just
; below by attachment-alist-exec.  But as we write this comment, we prefer to
; be conservative, in order to avoid rethinking the underlying theory merely in
; order to support what we think is an optimization that is unlikely ever to
; matter.

                    (strip-cars attachment-alist-sorted)
                    wrld)))
           (defattach-global-stobjs-msg
             (and (not (member-eq (ld-skip-proofsp state)
                                  '(include-book include-book-with-locals)))
                  (defattach-global-stobjs-msg attachment-alist-exec wrld
                    state))))
      (cond
       (defaxiom-supporter-msg-list
         (er soft ctx
             "It is illegal for supporters of DEFAXIOM events to receive ~
              attachments, but ~*0.  See :DOC defattach."
             `("impossible" ; This case shouldn't occur.
               "~@*"
               "~@*, and "
               "~@*, "
               ,defaxiom-supporter-msg-list)))
       (defattach-global-stobjs-msg
         (er soft ctx "~@0~@1"
             defattach-global-stobjs-msg
             *see-doc-with-global-stobj*))
       (t
        (er-progn
         (chk-defattach-transparent attachment-alist-sorted explicit-erasures
                                    ctx wrld state)
         (er-let*
             ((records (cond (skip-checks (value :skipped)) ; not used
                             (t (chk-defattach-loop attachment-alist-sorted
                                                    erasures wrld ctx
                                                    state))))
              (goal/event-names/new-entries
               (cond ((and (not skip-checks-t)
                           attachment-alist-sorted)
                      (defattach-constraint
                        attachment-alist-sorted proved-fnl-insts-alist wrld
                        ctx state))
                     (t (value nil))))
              (goal (value (car goal/event-names/new-entries)))
              (event-names (value (cadr goal/event-names/new-entries)))
              (new-entries (value (cddr goal/event-names/new-entries)))
              (ttree1 (cond ((or skip-checks-t
                                 ld-skip-proofsp
                                 (null attachment-alist-exec))
                             (value nil))
                            (t (prove-defattach-guards
                                attachment-alist-exec
                                guard-helpers-lst
                                ctx ens wrld state))))
              (ttree2
               (er-progn
                (chk-assumption-free-ttree ttree1 ctx state)
                (cond ((and (not skip-checks-t)
                            (not ld-skip-proofsp)
                            attachment-alist-sorted)
                       (prove-defattach-constraint goal event-names
                                                   attachment-alist-sorted
                                                   constraint-helper-alist
                                                   ctx ens wrld state))
                      (t (value nil))))))
           (er-progn
            (chk-assumption-free-ttree ttree2 ctx state)
            (value (list erasures
                         explicit-erasures
                         attachment-alist-sorted
                         attachment-alist-exec
                         new-entries
                         (cons-tag-trees ttree1 ttree2)
                         records
                         skip-checks
                         attach-nil-lst))))))))))

(defun attachment-cltl-cmd (erasures alist)

; Erasures is a list of function symbols, each currently with an attachment
; that is to be left without an attachment.  Alist associates function symbols
; with their attachments.  See the Essay on Defattach.

; This command is passed to add-trip, and should be of the form (attachment x1
; x2 ... xk), where each xi is either a function symbol, denoting the erasure
; of an attachment to that symbol, or else is of the form (f . g) for
; attachment pair <f,g>.

  (cons 'attachment
        (append erasures alist)))

(defun chk-meta-fn-attachments-lst (name lst-lst ctx wrld state)

; Lst-lst is the cddr of the 'evaluator-check-inputs property of name.  See
; Appendix 2 of the Essay on Correctness of Meta Reasoning.

  (let* ((lst (car lst-lst))
         (rule-class  (car lst))
         (meta-fn-lst (cadr lst))
         (ev-anc      (caddr lst))
         (extra-anc   (cadddr lst))
         (ev-fns      (cadddr (cdr lst))))
    (er-let* ((val1 (chk-meta-fn-attachments name rule-class meta-fn-lst
                                             ev-anc extra-anc ev-fns
                                             nil ctx wrld state)))
      (cond ((null (cdr lst-lst)) (value val1))
            (t (er-let* ((val2 (chk-meta-fn-attachments-lst name (cdr lst-lst)
                                                            ctx wrld state)))
                 (value
                  (cond ((null val1) val2)
                        ((null val2) val1)
                        (t (cons (union-eq (car val1) (car val2))
                                 (union-eq (cdr val1) (cdr val2))))))))))))

(defun put-defattach-props-tr-meta-anc-removals (fns name wrld wrld0)
  (cond ((endp fns) wrld)
        (t (let* ((fn (car fns))
                  (constrainedp (getpropc fn 'constrainedp nil wrld0))
                  (names (assert$

; Every function in fns comes from a set tr-meta-anc of transparent canonical
; functions.  Each thus has a transparent-rec value for its 'constrainedp
; property.

                          (weak-transparent-rec-p constrainedp)
                          (access transparent-rec constrainedp
                                  :names)))
                  (new-names (assert$

; Fns comes from the tr-meta-anc field of the 'evaluator-check-inputs property
; of name.  So by the Tr-meta-anc Invariant of Appendix 2 of the Essay on
; Correctness of Meta Reasoning, name is one of the names in the 'constrainedp
; property of fn.

                              (member-eq name names)
                              (remove1 name names))))
             (put-defattach-props-tr-meta-anc-removals
              (cdr fns)
              name
              (putprop fn
                       'constrainedp
                       (change transparent-rec constrainedp
                               :names new-names)
                       wrld)
              wrld0)))))

(defun put-defattach-props-tr-meta-anc-additions (fns name wrld wrld0)

; The comments in put-defattach-props-tr-meta-anc-removals explain the assert$
; calls here as well.

  (cond ((endp fns) wrld)
        (t (let* ((fn (car fns))
                  (constrainedp (getpropc fn 'constrainedp nil wrld0))
                  (names (assert$ (weak-transparent-rec-p constrainedp)
                                  (access transparent-rec constrainedp
                                          :names)))
                  (new-names (assert$ (not (member-eq name names))
                                      (cons name names))))
             (put-defattach-props-tr-meta-anc-additions
              (cdr fns)
              name
              (putprop fn
                       'constrainedp
                       (change transparent-rec constrainedp
                               :names new-names)
                       wrld)
              wrld0)))))

(defun put-defattach-props-tr-meta-anc (name tr-meta-anc-old tr-meta-anc-new
                                             wrld wrld0)
  (let* ((wrld1 (put-defattach-props-tr-meta-anc-removals
                 (set-difference-eq tr-meta-anc-old tr-meta-anc-new)
                 name wrld wrld0)))
    (put-defattach-props-tr-meta-anc-additions
     (set-difference-eq tr-meta-anc-new tr-meta-anc-old)
     name wrld1 wrld0)))

(defun put-defattach-props-common-anc-removals (fns name wrld wrld0)
  (cond ((endp fns) wrld)
        (t (let* ((fn (car fns))
                  (prop (getpropc fn 'attachment nil wrld0))
                  (new-alist (assert$

; By Common-anc Invariant 1 of Appendix 2 of the Essay on Correctness of Meta
; Reasoning, since fn is a common-anc of name, then the 'attachment property of
; fn specifies name as one of the reasons given in that property that the
; attachment is disallowed.

                              (and (consp prop)
                                   (eq (car prop)
                                       :attachment-disallowed)
                                   (assoc-eq name (cdr prop)))
                              (remove1-assoc-eq name (cdr prop)))))
             (put-defattach-props-common-anc-removals
              (cdr fns)
              name
              (putprop fn
                       'attachment
                       (and new-alist
                            (cons :attachment-disallowed new-alist))
                       wrld)
              wrld0)))))

(defun put-defattach-props-common-anc-additions (fns new-pair wrld wrld0)
  (cond ((endp fns) wrld)
        (t (let* ((fn (car fns))
                  (prop (getpropc fn 'attachment nil wrld0))
                  (alist (if (null prop)
                             nil
                           (assert$

; We have already checked in put-defattach-props-names, via
; chk-meta-fn-attachments-lst, that no function in fns has an attachment.
; Therefore prop is not an attachment-alist; so since at this point prop is
; non-nil, it must be of the form (:attachment-disallowed . &).

                            (and (consp prop)
                                 (eq (car prop)
                                     :attachment-disallowed))
                            (cdr prop)))))
             (put-defattach-props-common-anc-additions
              (cdr fns)
              new-pair
              (putprop fn
                       'attachment
                       (list* :attachment-disallowed
                              new-pair
                              alist)
                       wrld)
              wrld0)))))

(defun put-defattach-props-common-anc (name common-anc-old common-anc-new
                                            rule-class wrld wrld0)
  (let* ((wrld1 (put-defattach-props-common-anc-removals
                 (set-difference-eq common-anc-old common-anc-new)
                 name wrld wrld0))
         (only-new (set-difference-eq common-anc-new common-anc-old)))
    (cond (only-new (put-defattach-props-common-anc-additions
                     only-new
                     (cons name rule-class)
                     wrld1
                     wrld0))
          (t wrld1))))

(defun put-defattach-props-names (names ctx wrld wrld0 state)

; Wrld0 is the currently installed world of state; so, getpropc is fast on that
; world.  We use it in various places in this algorithm, because on inspection,
; none of those uses depend on additions already made to wrld.

  (cond
   ((endp names) (value wrld))
   (t (let* ((name (car names))
             (prop (getpropc name 'evaluator-check-inputs nil wrld0))
             (tr-meta-anc-old (car prop))
             (common-anc-old (cadr prop)))
        (er-let* ((pair (chk-meta-fn-attachments-lst name (cddr prop) ctx wrld0
                                                     state)))
          (let* ((tr-meta-anc-new (car pair))
                 (common-anc-new (cdr pair))
                 (wrld1 (put-defattach-props-tr-meta-anc
                         name tr-meta-anc-old tr-meta-anc-new wrld wrld0))
                 (rule-class (if (cdr (cddr prop)) ; two or more rules
                                 t
                               (car (car (cddr prop)))))
                 (wrld2 (put-defattach-props-common-anc
                         name common-anc-old common-anc-new rule-class wrld1
                         wrld0))
                 (wrld3 (assert$ tr-meta-anc-new
                                 (putprop name
                                          'evaluator-check-inputs
                                          (list* tr-meta-anc-new
                                                 common-anc-new
                                                 (cddr prop))
                                          wrld2))))
            (put-defattach-props-names (cdr names) ctx wrld3 wrld0 state)))))))

(defun put-defattach-props (fn ctx wrld state)

; Fn is a canonical transparent function.  So by the Transparent Function
; Invariant of Appendix 2 of the Essay on Correctness of Meta Reasoning, its
; 'constrainedp property is a transparent-rec record.

  (revert-world-on-error
   (pprogn
    (set-w 'extension wrld state) ; for a little more efficiency
    (let* ((prop (getpropc fn 'constrainedp nil wrld))
           (names (assert$
                   (weak-transparent-rec-p prop)
                   (access transparent-rec prop :names))))
      (put-defattach-props-names names ctx wrld wrld state)))))

(defun defattach-fn (args state event-form)
  (with-ctx-summarized
   (case-match args
     (((x y))
      (msg "( DEFATTACH (~x0 ~x1))" x y))
     (((x y . &))
      (msg "( DEFATTACH (~x0 ~x1 ...))" x y))
     (((x y) . &)
      (msg "( DEFATTACH (~x0 ~x1) ...)" x y))
     (((x y . &) . &)
      (msg "( DEFATTACH (~x0 ~x1 ...) ...)" x y))
     ((x y)
      (msg "( DEFATTACH ~x0 ~x1)" x y))
     ((x y . &)
      (msg "( DEFATTACH ~x0 ~x1 ...)" x y))
     (&
      (msg "( DEFATTACH ...)")))
   (let* ((wrld (w state))
          (proved-fnl-insts-alist
           (global-val 'proved-functional-instances-alist wrld)))
     (er-let* ((tuple (chk-acceptable-defattach args proved-fnl-insts-alist ctx
                                                wrld state)))
       (let* ((erasures                (strip-cars (nth 0 tuple)))
              (explicit-erasures       (nth 1 tuple))
              (attachment-alist-sorted (nth 2 tuple))
              (attachment-alist-exec   (nth 3 tuple))
              (new-entries             (nth 4 tuple))
              (ttree                   (nth 5 tuple))
              (records                 (nth 6 tuple))
              (skip-checks             (nth 7 tuple))
              (attach-nil-lst          (nth 8 tuple))
              (attachment-fns (strip-cars attachment-alist-sorted))
              (wrld0 (global-set? 'attach-nil-lst
                                  attach-nil-lst
                                  wrld
                                  (global-val 'attach-nil-lst
                                              wrld)))
              (wrld1 (putprop-x-lst1 erasures 'attachment nil wrld0))
              (wrld2 (cond (attachment-fns
                            (putprop-x-lst1 (cdr attachment-fns)
                                            'attachment
                                            (car attachment-fns)
                                            (putprop (car attachment-fns)
                                                     'attachment
                                                     attachment-alist-sorted
                                                     wrld1)))
                           (t wrld1)))
              (wrld3 (cond (new-entries
                            (global-set
                             'proved-functional-instances-alist
                             (append new-entries proved-fnl-insts-alist)
                             wrld2))
                           (t wrld2)))
              (wrld4 (cond (skip-checks wrld3) ; for skip-checks t or :cycles
                           (t (global-set 'attachment-records records
                                          wrld3))))
              (cltl-cmd (attachment-cltl-cmd
                         (set-difference-assoc-eq erasures
                                                  attachment-alist-exec)
                         attachment-alist-exec))
              (fn-tr (assert$
                      (or (consp attachment-alist-sorted)
                          (consp explicit-erasures))
                      (let ((fn-canon (canonical-sibling
                                       (or (caar attachment-alist-sorted)
                                           (car explicit-erasures))
                                       wrld)))
                        (and (transparent-fn-p fn-canon wrld)
                             fn-canon)))))
         (er-let* ((wrld5 (if fn-tr
                              (put-defattach-props fn-tr ctx wrld4 state)
                            (value wrld4))))
           (pprogn (let ((implicit-erasures
                          (set-difference-eq erasures explicit-erasures)))
                     (cond (implicit-erasures
                            (observation ctx
                                         "The pre-existing attachment~#0~[ ~
                                          is~/s are~] being removed for ~
                                          function~#0~[~/s~] ~&0~@1~@2."
                                         implicit-erasures
                                         (cond (explicit-erasures
                                                (msg ", in addition to the ~
                                                      association~#0~[~/s~] ~
                                                      with nil provided ~
                                                      explicitly for ~&0"
                                                     explicit-erasures))
                                               (t ""))
                                         (cond (attachment-fns
                                                (msg ", before adding the ~
                                                      requested ~
                                                      attachment~#0~[~/s~]"
                                                     attachment-fns))
                                               (t ""))))
                           (t state)))
                   (install-event :attachments-recorded event-form 'defattach 0
                                  ttree cltl-cmd nil ctx wrld5 state))))))))

(defmacro defattach-system (&whole form &rest args)
  (cond ((and (symbolp (car args)) ; (defattach-system f g)
              (eql (length args) 2)
              (symbolp (cadr args)))
         `(local (defattach (,(car args) ,(cadr args))
                   :system-ok t)))
        ((symbolp (car args))
         (er hard 'defattach-system
             "When the first argument of a defattach-system call is a symbol, ~
              there must be exactly two arguments, both of them symbols.  The ~
              call ~x0 is thus illegal."
             form))
        ((member-eq :system-ok args)
         (er hard 'defattach-system
             "The argument :system-ok is illegal for a defattach-system call. ~
              Consider instead using defattach or removing :system-ok."
             form))
        (t
         `(local (defattach ,@args :system-ok t)))))

; We now provide support for return-last.

(defun chk-return-last-entry (key val wrld)

; Warning: If you change this, consider whether also to change
; chk-return-last-entry-coda.

; Key is a symbol such as prog2$ that has a macro definition in raw Lisp that
; takes two arguments.  Val is either nil, denoting that key is not in the
; table; the name of a macro known to ACL2; or (list m), where m is the name of
; a macro known to ACL2.  The latter case causes ACL2 to disallow corresponding
; return-last calls at the top level (as opposed to inside function bodies).

  (declare (xargs :guard (plist-worldp wrld)
                  :mode :program))
  (cond ((or (ttag wrld)
             (global-val 'boot-strap-flg wrld))
         (and (symbolp key)
              key
              (or (symbolp val)
                  (and (consp val)
                       (symbolp (car val))
                       (car val)
                       (null (cdr val))))
              (not (member-eq key '(progn mbe1-raw ec-call1-raw
                                          with-guard-checking1-raw)))
              (or (null val)
                  (let ((val2 (if (symbolp val) val (car val))))
                    (getpropc val2 'macro-body nil wrld)))
              #-acl2-loop-only
              (fboundp key) ; holds for functions, macros, and special ops
              t))
        (t nil)))

(defun chk-return-last-entry-coda (key val wrld)

; See chk-return-last-entry.

  (declare (xargs :guard (plist-worldp wrld)
                  :mode :program))
  (cond ((or (ttag wrld)
             (global-val 'boot-strap-flg wrld))
         (cond ((member-eq key '(progn mbe1-raw ec-call1-raw
                                       with-guard-checking1-raw))

; Keep the list above in sync with the comment about these macros in
; *initial-return-last-table* and with return-last-lookup.

                (msg
                 "Note that the proposed key ~x0 for ~x1 is illegal because ~
                  it is given special treatment."
                 key 'return-last-table))
               ((and val
                     (let ((val2 (if (symbolp val) val (car val))))
                       (and
                        (not (getpropc val2 'macro-body nil wrld))
                        (msg "~|Note that the proposed value ~x0 for key ~x1 ~
                              in ~x2 is illegal because ~x3 is not the name ~
                              of a macro known to ACL2.  See :DOC return-last ~
                              and (for the above point made explicitly) see ~
                              :DOC return-last-table."
                             val key 'return-last-table val2)))))
               #-acl2-loop-only
               ((not (fboundp key))

; Note that fboundp holds for functions, macros, and special operators.

                (msg "~|Note that the proposed key ~x0 for ~x1 is illegal ~
                      because it is does not have a Common Lisp definition.  ~
                      See :DOC return-last and (for the above point made ~
                      explicitly) see :DOC return-last-table."
                     key 'return-last-table))
               (t nil)))
        (t (msg "~|The error is simply that it is illegal to modify the ~
                 table, ~x0, unless there is an active trust tag.  See :DOC ~
                 return-last and see :DOC return-last-table."
                'return-last-table))))

(set-table-guard return-last-table
                 (chk-return-last-entry key val world)
                 :topic return-last
                 :show t
                 :coda (chk-return-last-entry-coda key val world))

(defmacro defmacro-last (fn &key raw (top-level-ok 't))
  (declare (xargs :guard (and (symbolp fn)
                              (symbolp raw))))
  (let ((raw (or raw (add-suffix fn "-RAW"))))
    `(progn (defmacro ,fn (x y)
              (list 'return-last (list 'quote ',raw) x y))
            (table return-last-table ',raw '
                   ,(if top-level-ok fn (list fn))))))

; Formatted printing to strings requires local stobjs (actually
; with-local-state), so we place the relevant code below.  It could certainly
; go in later source files if that is desired.

(defconst *fmt-control-defaults*

; This constant should set up a state-global-let* binding for every state
; global variable that can have an effect on evaluation of a call of fms, fmt,
; or fmt1 (or their "!" versions), which are the functions on which we apply
; the macro channel-to-string.  The values for the margins are simply
; convenient large values.

; Warning: If any supplied third component must be what is called during
; cleanup for state-global-let*, think about the effect of not using it when
; calling state-free-global-let* instead, as is done in channel-to-string.  As
; of this writing in Feb. 2023, that can only matter for iprint-ar, but
; channel-to-string disables iprinting so that doesn't matter after all.

  (append *print-control-defaults*
          `((write-for-read t)
            (fmt-hard-right-margin ,*fmt-hard-right-margin-default*
                                   set-fmt-hard-right-margin)
            (fmt-soft-right-margin ,*fmt-soft-right-margin-default*
                                   set-fmt-soft-right-margin)
            (iprint-soft-bound ,*iprint-soft-bound-default*)
            (iprint-hard-bound ,*iprint-hard-bound-default*)
            (ppr-flat-right-margin
             ,(cdr (assoc-eq 'ppr-flat-right-margin *initial-global-table*)))
            (current-package "ACL2")

; Values not to be modified; keep in sync with *fixed-fmt-controls*.

            (iprint-ar (f-get-global 'iprint-ar state) set-iprint-ar)
            (evisc-hitp-without-iprint nil))))

(defconst *fixed-fmt-controls*

; These are the state global variables that have bindings in
; *fmt-control-defaults* but must not have those bindings overridden by the
; user (because they are managed by ACL2).

  '(iprint-ar
    evisc-hitp-without-iprint))

(defun fmt-control-bindings1 (alist fmt-control-defaults-tail rawp)

; Alist is a variable whose value is an alist used to modify
; fmt-control-defaults-tail, which is a tail of *fmt-control-defaults*.

; Rawp is true when we are to construct doublets only, typically for a call of
; state-free-global-let* instead of a call of state-global-let*.

  (cond ((endp fmt-control-defaults-tail) nil)
        (t
         (cons (let* ((trip (car fmt-control-defaults-tail))
                      (var (car trip)))
                 (list* var
                        `(let ((pair (assoc-eq ',var ,alist)))
                           (cond (pair
                                  ,(cond
                                    ((member-eq var *fixed-fmt-controls*)
                                     `(er hard 'fmt-control-bindings
                                          "The binding of ~x0 is illegal in ~
                                           this context."
                                          ',var))
                                    (t '(cdr pair))))
                                 (t ,(cadr trip))))
                        (and (null rawp)
                             (cddr trip))))
               (fmt-control-bindings1 alist
                                      (cdr fmt-control-defaults-tail)
                                      rawp)))))

(defun drop-cddrs (lst)
  (declare (xargs :guard (true-list-listp lst)))
  (cond ((endp lst) nil)
        (t (cons (list (caar lst) (cadar lst))
                 (drop-cddrs (cdr lst))))))

(defconst *fmt-control-defaults-raw*
  (drop-cddrs *fmt-control-defaults*))

(defun fmt-control-bindings (alist rawp)

; Rawp is true when we are to construct doublets only, typically for a call of
; state-free-global-let* instead of a call of state-global-let*.

  (cond (alist (fmt-control-bindings1 alist *fmt-control-defaults* rawp))
; optimizations:
        (rawp *fmt-control-defaults-raw*)
        (t *fmt-control-defaults*)))

(defun set-iprint-ar (iprint-ar state)

; This function, which is untouchable, assumes that iprint-ar is well-formed.
; It is used when restoring a valid iprint-ar.

  (f-put-global 'iprint-ar (compress1 'iprint-ar iprint-ar) state))

(defun override-global-evisc-table (evisc-tuple state)

; This function expands evisc-tuple as necessary so that entries in the global
; evisc-table will be ignored when printing with evisceration.

  (let ((evisc-table (table-alist 'evisc-table (w state))))
    (cond ((null evisc-table) ; optimization
           evisc-tuple)
          ((consp evisc-tuple)
           (cons (append (car evisc-tuple)
                         (pairlis$ (strip-cars evisc-table)
                                   nil))
                 (cdr evisc-tuple)))
          (t ; presumably evisc-tuple is nil
           (evisc-tuple nil
                        nil
                        (pairlis$ (strip-cars evisc-table)
                                  nil)
                        nil)))))

(defun block-iprint-ar (state)

; This is like disable-iprint-ar, except that it signifies that eviscerate-top
; and eviscerate-stobjs-top should not update first from iprint modifications
; made in a wormhole.  This is important for avoiding a safe-mode violation due
; to using raw code (namely, via iprint-oracle-updates) in fmt-to-string and
; the like.

; See comments in the related function, disable-iprint-ar.

  (let* ((iprint-ar (f-get-global 'iprint-ar state))
         (elt-0 (aref1 'iprint-ar iprint-ar 0)))
    (pprogn (f-put-global 'iprint-ar
                          (compress1 'iprint-ar
                                     (acons 0
                                            (if (integerp elt-0)
                                                (cons elt-0 t)
                                              (if (cdr elt-0)
                                                  elt-0
                                                (cons (car elt-0) t)))
                                            (if (eql (caar iprint-ar) 0)
                                                (cdr iprint-ar)
                                              iprint-ar)))
                          state)
            (mv t state))))

(defmacro channel-to-string (form channel-var
                                  &optional
                                  extra-var fmt-controls
                                  outside-loop-p)

; Form is a call of fms, fmt, or fmt1 (or their "!" versions) on variables.  To
; see why we make this restriction, consider the following form:

;   (channel-to-string
;    (f-put-global 'xxx (f-get-global 'term-evisc-tuple state) state)
;    chan)

; If you evaluate this form in raw-mode and then evaluate (@ xxx), you'll
; initially get :default.  But if then evaluate the form

;   (set-term-evisc-tuple (evisc-tuple 4 5 nil nil) state)

; and then evaluate the above channel-to-string call again, this time (@ xxx)
; evaluates to (NIL 4 5 NIL).  Thus, state changed even though
; channel-to-string generates a with-local-state call, which should not change
; state!

; If variable outside-loop-p (which is evaluated) is true, then evaluation of
; this form might be done more efficiently -- but it must be suitable for
; execution outside the loop or, if inside the loop, then without the
; evaluation of state-global-let* (or any other use of the
; *acl2-unwind-protect-stack*) for any state global modified by
; fmt-control-bindings.

; Note that fmt-controls is evaluated, but channel-var and extra-var are not
; evaluated.

; This macro is not recommended for users, as it has been designed specifically
; for the fmt family of functions.  In fact, the code below provides
; idiosyncratic special handling for evisc-tuple.  If one wishes to use this or
; a similar macro outside the boot-strap then one will need to avoid issues
; with untouchables; here is an example.

;   (defttag t)
;   (remove-untouchable temp-touchable-fns nil)
;   (set-temp-touchable-fns t state)
;   (remove-untouchable temp-touchable-vars nil)
;   (set-temp-touchable-vars t state)
;   (defun fms-to-string-fn-again
;     (str alist evisc-tuple fmt-control-alist)
;     (declare (xargs :mode :program))
;     (channel-to-string
;      (fms str alist chan-do-not-use-elsewhere state evisc-tuple)
;      chan-do-not-use-elsewhere nil fmt-control-alist))
;   (defmacro fmt-to-string-again
;     (str alist &key evisc-tuple fmt-control-alist)
;     `(fmt-to-string-fn-again ,str ,alist ,evisc-tuple ,fmt-control-alist))

; If you now evaluate
;   (fmt-to-string-again "Hello, ~s0." (list (cons #\0 "World")))
; you will get the cons of 13 with "\nHello, World." (here we write \n to
; indicate a newline).

  (declare (xargs :guard (and (symbol-listp form) ; see "on variables" above
                              (symbolp channel-var)
                              (symbolp extra-var)
                              (symbolp fmt-controls)
                              (not (eq 'result extra-var))
                              (not (eq 'state extra-var)))))
  (let* ((form0
          (if (member-eq 'evisc-tuple form)
              `(let ((evisc-tuple
                      (override-global-evisc-table evisc-tuple state)))
                 ,form)
            form))
         (body0 ; error triple (mv nil val state), where val may cons extra-var
          `(mv?-let
            (,@(and extra-var (list extra-var)) state)
            ,form0
            (mv-let (erp result state)
                    (get-output-stream-string$ ,channel-var state)
                    (mv nil
                        (and (not erp)
                             ,(if extra-var
                                  `(cons ,extra-var result)
                                'result))
                        state))))
         (body1 ; bind fmt controls and clean up around body0

; Warning: Keep the two branches below in sync.

; We use acl2-unwind-protect and unwind-protect to guarantee that the new
; channel is finally closed.  See the comment about channels in
; mv-let-for-with-local-stobj.

; We disable iprinting because the iprint index values won't be available to
; the user anyhow when exiting the state-(free-)global-let* forms below.  And
; indeed they should not be available, since the state being modified here is
; supposed to be a local state.  A nice consequence of disabling iprinting is
; that it supports our use here of state-free-global-let*, as discussed in a
; comment in *fmt-control-defaults*.

          (cond
           (outside-loop-p
            `(unwind-protect
                 (state-free-global-let*
                  ,(fmt-control-bindings fmt-controls t)
                  (progn (block-iprint-ar state)
                         ,body0))
               (when (open-output-channel-p ,channel-var :character state)
                 (close-output-channel ,channel-var state))
               (f-put-global 'iprint-ar
                             (compress1 'iprint-ar (f-get-global 'iprint-ar state))
                             state)))
           (t
            `(acl2-unwind-protect

; We use acl2-unwind-protect to guarantee that the new channel is finally
; closed.  See the comment about channels in mv-let-for-with-local-stobj.

              "channel-to-string"
              (state-global-let*
               ,(fmt-control-bindings fmt-controls nil)
               (pprogn (mv-let (result state)
                         (block-iprint-ar state)
                         (declare (ignore result))
                         state)
                       ,body0))
              (pprogn
               (f-put-global 'iprint-ar
                             (compress1 'iprint-ar
                                        (f-get-global 'iprint-ar state))
                             state)
               (cond ((open-output-channel-p ,channel-var :character state)
                      (close-output-channel ,channel-var state))
                     (t state)))
              (f-put-global 'iprint-ar
                            (compress1 'iprint-ar
                                       (f-get-global 'iprint-ar state))
                            state)))))
         (body ; open a string output channel and then evaluate body1
          `(mv-let
            (,channel-var state)
            (open-output-channel :string :character state)
            (cond (,channel-var ,body1)
                  (t ,(cond
                       (outside-loop-p
                        "ERROR: Failed to open string output channel to ~
                         report an error.")
                       (t '(er soft 'channel-to-string
                               "Implementation error: Unable to open a ~
                                channel to a string."))))))))
    `(with-local-state
      (mv-let
       (erp result state)
       (with-live-state ,body)
       (declare (ignore erp))
       ,(cond (extra-var `(mv (car result) (cdr result)))
              (t 'result))))))

(defconst *fmt-control-defaults-keys*
  (strip-cars *fmt-control-defaults*))

(defun fms-to-string-fn (str alist evisc-tuple fmt-control-alist)
  (declare (xargs :guard ; incomplete guard
                  (and (stringp str)
                       (character-alistp alist)
                       (standard-evisc-tuplep evisc-tuple)
                       (alistp fmt-control-alist)
                       (alist-keys-subsetp fmt-control-alist
                                           *fmt-control-defaults-keys*))))
  (channel-to-string
   (fms str alist chan-do-not-use-elsewhere state evisc-tuple)
   chan-do-not-use-elsewhere nil fmt-control-alist))

(defmacro fms-to-string (str alist &key evisc-tuple fmt-control-alist)
  `(fms-to-string-fn ,str ,alist ,evisc-tuple ,fmt-control-alist))

(defun fms!-to-string-fn (str alist evisc-tuple fmt-control-alist)
  (declare (xargs :guard ; incomplete guard
                  (and (stringp str)
                       (character-alistp alist)
                       (standard-evisc-tuplep evisc-tuple)
                       (alistp fmt-control-alist)
                       (alist-keys-subsetp fmt-control-alist
                                           *fmt-control-defaults-keys*))))
  (channel-to-string
   (fms! str alist chan-do-not-use-elsewhere state evisc-tuple)
   chan-do-not-use-elsewhere nil fmt-control-alist))

(defmacro fms!-to-string (str alist &key evisc-tuple fmt-control-alist)
  `(fms!-to-string-fn ,str ,alist ,evisc-tuple ,fmt-control-alist))

(defun fmt-to-string-fn (str alist evisc-tuple fmt-control-alist)
  (declare (xargs :guard ; incomplete guard
                  (and (stringp str)
                       (character-alistp alist)
                       (standard-evisc-tuplep evisc-tuple)
                       (alistp fmt-control-alist)
                       (alist-keys-subsetp fmt-control-alist
                                           *fmt-control-defaults-keys*))))
  (channel-to-string
   (fmt str alist chan-do-not-use-elsewhere state evisc-tuple)
   chan-do-not-use-elsewhere col fmt-control-alist))

(defmacro fmt-to-string (str alist &key evisc-tuple fmt-control-alist)
  `(fmt-to-string-fn ,str ,alist ,evisc-tuple ,fmt-control-alist))

(defun fmt!-to-string-fn (str alist evisc-tuple fmt-control-alist)
  (declare (xargs :guard ; incomplete guard
                  (and (stringp str)
                       (character-alistp alist)
                       (standard-evisc-tuplep evisc-tuple)
                       (alistp fmt-control-alist)
                       (alist-keys-subsetp fmt-control-alist
                                           *fmt-control-defaults-keys*))))
  (channel-to-string
   (fmt! str alist chan-do-not-use-elsewhere state evisc-tuple)
   chan-do-not-use-elsewhere col fmt-control-alist))

(defmacro fmt!-to-string (str alist &key evisc-tuple fmt-control-alist)
  `(fmt!-to-string-fn ,str ,alist ,evisc-tuple ,fmt-control-alist))

(defun fmt1-to-string-fn (str alist col evisc-tuple fmt-control-alist)
  (declare (xargs :guard ; incomplete guard
                  (and (character-alistp alist)
                       (stringp str)
                       (standard-evisc-tuplep evisc-tuple)
                       (alistp fmt-control-alist)
                       (alist-keys-subsetp fmt-control-alist
                                           *fmt-control-defaults-keys*)))
           (type #.*fixnat-type* col))
  (channel-to-string
   (fmt1 str alist col chan-do-not-use-elsewhere state evisc-tuple)
   chan-do-not-use-elsewhere col fmt-control-alist))

(defmacro fmt1-to-string (str alist col &key evisc-tuple fmt-control-alist)
  `(fmt1-to-string-fn ,str ,alist ,col ,evisc-tuple ,fmt-control-alist))

(defun fmt1!-to-string-fn (str alist col evisc-tuple fmt-control-alist)
  (declare (xargs :guard ; incomplete guard
                  (and (stringp str)
                       (character-alistp alist)
                       (standard-evisc-tuplep evisc-tuple)
                       (alistp fmt-control-alist)
                       (alist-keys-subsetp fmt-control-alist
                                           *fmt-control-defaults-keys*)))
           (type #.*fixnat-type* col))
  (channel-to-string
   (fmt1! str alist col chan-do-not-use-elsewhere state evisc-tuple)
   chan-do-not-use-elsewhere col fmt-control-alist))

(defmacro fmt1!-to-string (str alist col &key evisc-tuple fmt-control-alist)
  `(fmt1!-to-string-fn ,str ,alist ,col ,evisc-tuple ,fmt-control-alist))

#-acl2-loop-only
(defun hard-error-is-error (ctx str alist)
  (state-free-global-let*
   (#+acl2-par (parallel-execution-enabled

; We avoid an infinite loop here that is caused when calling channel-to-string
; with non-nil parallel-execution-enabled in ACL2(p).  The problem was that
; channel-to-string calls with-local-state, which is illegal when
; parallel-execution is enabled.

                nil))
   (error "~a" (channel-to-string
                (error-fms-channel t ctx nil str alist chan

; Leave the following as state, not *the-live-state*, to avoid compiler
; warning.

                                   state
                                   0)
                chan nil nil t))))

; Essay on Memoization with Attachments

; We maintain the invariant that every stored value in a memo table is valid.

; The main idea is to ensure that if a function m is memoized with :aok t, then
; for every possible call of m, every function called has the same attachment
; now as it did when the value was stored.  To do this, we maintain a stronger
; invariant, described in the next paragraph, that is based on the acyclic
; "extended ancestor" relation introduced in the Essay on Defattach.
; Roughly speaking, this relation is the transitive closure of the immediate
; ancestor relation, where g is an immediate ancestor of f if either g is an
; ordinary ancestor of f or else <f,g> is an attachment pair (think: f is
; redefined to be g).  We say "roughly speaking" primarily because we traffic
; entirely in "canonical" function symbols, as explained in the Essay on
; Defattach.  Moreover, for our defattach implementation, we include guards in
; the calculation of canonical ancestors.  Guards are relevant in the sense
; that changing or (especially) removing an attachment used in a guard could
; invalidate a stored value, not logically, but in the sense that its
; computation should now cause a guard violation error and thus we don't want
; to return such a value.

; We do something a bit special for apply$-userfn, badge-userfn, and warrants.
; This Essay ignores such special treatment until the end of this Essay.

; Let m be a memoized function symbol.  If m was memoized with :aok nil (the
; default), then the invariant maintained is simply that the
; :ext-anc-attachments field of the memoize-info-ht-entry record for m is nil.
; This implies the property we desire, that all stored entries for m are valid,
; because defattach events do not destroy the validity of stored results.  But
; in the case that f was memoized with :aok t, the :ext-anc-attachments field
; of the memoize-info-ht-entry record for m is a non-null fast alist whose keys
; are exactly the (canonical) extended ancestors of m, including the canonical
; sibling of m.  We maintain the invariant that the value of key f in this fast
; alist is itself an alist associating each sibling f' of f with its
; attachment, for each sibling f' that has an attachment.

; To summarize: in the :aok t case, we maintain the :ext-anc-attachments field
; to have the value described above, and every value stored in the memo table
; is correct with respect to the current attachments, which are those indicated
; in the :ext-anc-attachments field.  Thus, if a defattach event changes the
; attachment of (some sibling of) an extended ancestor, then the
; :ext-anc-attachments field is recalculated and stored anew.  If the only
; changes are to add new attachments, without changing or removing any existing
; attachments, then the memo table is not cleared; otherwise, it is.  The
; analogous actions are taken when we undo.

; For efficiency, we implement extend-world1 and retract-world1 so that they do
; not update such fields or clear memo-tables until all trips have been
; processed.  (This update is performed by update-memo-entries-for-attachments,
; which is called at the end of the above world updates, by
; update-wrld-structures.)  At that point we see whether any defattach event
; has been installed or undone, and then we see whether any memo-table's
; :ext-anc-attachments field needs to be recalculated, and whether furthermore
; the table needs to be invalidated, as discussed above.  For efficiency, we
; set a global variable, *defattach-fns*, to a list L of canonical siblings of
; all functions whose attachment may have been installed, eliminated, or
; changed.  We then restrict our check on :ext-anc-attachments fields (in
; update-memo-entries-for-attachments) to check attachments for siblings of
; functions in L.  In particular, if L is empty then nothing needs to be done.

; The case of warrants is a bit subtle, because we do not store their
; attachments in the world global, 'attachment-records.  (That world global is
; calculated by attachment-records, which has a comment about efficiency
; obtained by omitting warrants.)  That is concerning, since that world global
; is used in the calculation performed by function ext-ancestors-attachments,
; which is called to update memo-tables in update-memo-entry-for-attachments.
; However, we insist (see the check in process-defattach-args1 and the assert$
; in attachment-records) that a warrant may only be attached to
; true-apply$-warrant, which is a fully-defined function (hence cannot receive
; an executable attachment) and has no ancestors.  So we are comfortable with
; omitting true-apply$-warrant from the check for whether any attachment has
; changed in the extended-ancestors of a function.

; Before we consider apply$-userfn and badge-userfn, we say a bit more about
; how the variable *defattach-fns* (discussed above) is extended.  When a
; defattach event is installed, an "attachment object" -- a cons whose car is
; 'attachment -- is added to the world.  When add-trip or undo-trip sees such
; an object produced by defattach, it extends *defattach-fns* with the
; functions for which attachments are given or removed.  The way that undo-trip
; sees these is by a call of maybe-push-undo-stack in add-trip.

; Finally let us turn to how memoization deals with apply$-userfn and
; badge-userfn.  (Also see community book
; books/system/tests/apply-with-memoization.lisp for discussion of an example.)
; These are attached respectively to doppelganger-apply$-userfn and
; doppelganger-badge-userfn, whose behaviors can change (and probably do
; change) every time the badge-table changes.  So consider what happens for a
; call of a function, fn, memoized with :aokp t, when that call invokes
; apply$-userfn or badge-userfn.  The result stored for that call of fn needs
; to be invalidated when the badge is removed from the badge-table for the
; function argument of that subsidiary call of apply$-userfn or badge-userfn.
; We take the conservative approach of considering that the attachment to
; apply$-userfn or badge-userfn has changed; thus, table-cltl-cmd produces a
; special attachment object, *special-cltl-cmd-attachment-mark*, which is (list
; 'attachment *special-cltl-cmd-attachment-mark-name*).  Unlike normal
; attachment objects, add-trip does not extend *defattach-fns* when
; encountering this special one, because there is no need to invalidate
; memoization results when the badge-table is extended.  Add-trip does however
; still call maybe-push-undo-stack, so that undo-trip will push this special
; object onto *defattach-fns*.  Then when it is time for
; update-memo-entries-for-attachments to invalidate memo-tables and recalculate
; :ext-anc-attachments fields, the function ext-anc-attachments-valid-p will
; look for apply$-userfn and badge-userfn among the extended ancestors when it
; encounters the special name, *special-cltl-cmd-attachment-mark-name*,
; handling this case as though the attachments to apply$-userfn and
; badge-userfn have changed.

; Note that we do not concern ourselves with extended-ancestors of
; doppelganger-apply$-userfn or doppelganger-badge-userfn, because these
; functions are untouchable.  Thus, they should never arise except as extended
; ancestors of apply$-userfn and badge-userfn, which we already handle fully as
; discussed above.  That is why we do not mind using nil for the supporters of
; the partial-encapsulate events for doppelganger-badge-userfn and
; doppelganger-apply$-userfn.

; Start code supporting ext-ancestors-attachments.

(defun attachment-pairs (fns wrld acc)

; Accumulate into acc all attachment pairs (f . g) for f in fns.

  (cond ((endp fns) acc)
        (t (attachment-pairs
            (cdr fns)
            wrld
            (let ((pair (attachment-pair (car fns) wrld)))
              (cond (pair (cons pair acc))
                    (t acc)))))))

(defun sibling-attachments (f wrld)

; We return all attachment pairs (f0 . g0) for which f0 is a sibling of f.

  (attachment-pairs (siblings f wrld) wrld nil))

(defun ext-ancestors-attachments4 (fns wrld fal)
  (cond ((endp fns) fal)
        (t (ext-ancestors-attachments4
            (cdr fns)
            wrld
            (cond ((hons-get (car fns) fal)
                   fal)
                  (t (hons-acons (car fns)
                                 (sibling-attachments (car fns) wrld)
                                 fal)))))))

(defun ext-ancestors-attachments3 (components wrld fal)
  (cond ((endp components) fal)
        (t (ext-ancestors-attachments3
            (cdr components)
            wrld
            (let ((anc (access attachment-component (car components) :ord-anc))
                  (path (access attachment-component (car components) :path)))
              (ext-ancestors-attachments4
               (if path
                   (cons (car path) ; attachment-component-owner
                         anc)
                 anc)
               wrld
               fal))))))

(defun ext-ancestors-attachments2 (canon-gs arfal wrld canon-gs-fal fal)
  (cond ((endp canon-gs) fal)
        (t (let ((g (car canon-gs)))
             (cond ((hons-get g canon-gs-fal)
                    (ext-ancestors-attachments2
                     (cdr canon-gs) arfal wrld canon-gs-fal fal))
                   (t (let ((rec (cdr (hons-get g arfal))))
                        (ext-ancestors-attachments2
                         (cdr canon-gs) arfal wrld
                         (hons-acons g fal canon-gs-fal)
                         (let ((fal (hons-acons
                                     g
                                     (sibling-attachments (car canon-gs)
                                                          wrld)
                                     fal)))
                           (cond (rec (ext-ancestors-attachments3
                                       (access attachment rec :components)
                                       wrld
                                       fal))
                                 (t ; :skip-checks was used
                                  fal)))))))))))

(defun canonical-cdrs (alist wrld acc)
  (cond ((endp alist) acc)
        (t (canonical-cdrs (cdr alist)
                           wrld
                           (cons (canonical-sibling (cdar alist) wrld)
                                 acc)))))

(defun ext-ancestors-attachments1 (fns canon-gs arfal wrld fal)

; Arfal is a fast alist mapping g-canonical function symbols to attachment
; records.  We accumulate ordinary ancestors of members of fns, including those
; functions, into fal, as we accumulate immediate extended ancestors of members
; of fns into canon-gs.  Once fns is empty, however, we accumulate all extended
; ancestors of members of canon-gs (including those functions) into fal.

  (cond ((endp fns)
         (ext-ancestors-attachments2
          canon-gs arfal wrld 'ext-ancestors-attachments2 fal))
        ((hons-get (car fns) fal)
         (ext-ancestors-attachments1 (cdr fns) canon-gs arfal wrld fal))
        (t (let* ((alist (sibling-attachments (car fns) wrld))
                  (canon-gs (cond ((null alist) ; optimization
                                   canon-gs)
                                  (t (append (canonical-cdrs alist wrld nil)
                                             canon-gs)))))
             (ext-ancestors-attachments1
              (append (canonical-ancestors (car fns) wrld nil)
                      (cdr fns))
              canon-gs arfal wrld
              (hons-acons (car fns) alist fal))))))

(defun attachment-records-fal (attachment-records fal)
  (cond ((endp attachment-records) fal)
        (t (attachment-records-fal
            (cdr attachment-records)
            (hons-acons (access attachment (car attachment-records) :g)
                        (car attachment-records)
                        fal)))))

(defun ext-ancestors-attachments (f wrld)

; See the Essay on Memoization with Attachments.

  (let ((g (canonical-sibling f wrld)))
    (ext-ancestors-attachments1 (cons g
                                      (canonical-ancestors g wrld nil))
                                nil
                                (attachment-records-fal
                                 (global-val 'attachment-records wrld)
                                 :attachment-records-fal)
                                wrld
                                f)))

(defun ext-anc-attachment-missing (alist wrld)

; See ext-anc-attachments-valid-p.

  (cond ((endp alist) nil)
        ((eq (cdar alist)
             (cdr (attachment-pair (caar alist) wrld)))
         (ext-anc-attachment-missing (cdr alist) wrld))
        (t (caar alist))))

(defun ext-anc-attachments-valid-p-1 (fns alist wrld)

; See ext-anc-attachments-valid-p.  We assume that for every pair (f . g) in
; alist, g is the attachment of f in wrld.

  (cond ((endp fns) t)
        ((or (assoc-eq (car fns) alist)
             (not (attachment-pair (car fns) wrld)))
         (ext-anc-attachments-valid-p-1 (cdr fns) alist wrld))
        (t nil)))

(defun ext-anc-attachments-valid-p (fns ext-anc-attachments special-name wrld
                                        acc)

; Each member of the fast alist ext-ancestor-attachments associates a function
; symbol f with an alist.  That alist is intended to have as its keys the
; siblings of f that have an attachment, associating each such key with its
; attachment.  This function returns t if that spec currently holds.
; Otherwise, if some such key is no longer attached to its value, return that
; key.  The other possibility is that some key is missing, in which case we
; return nil to indicate that we need to grow.  A special case is that fns
; contains special-name, which is actually
; *special-cltl-cmd-attachment-mark-name*, and either apply$-userfn or
; badge-userfn is in ext-anc-attachments.  In that case we return that special
; mark.

; Acc is initially t, but is nil when we find that an alist needs to grow.

  (cond
   ((endp fns) acc)
   ((eq (car fns) special-name)
    (if (or (hons-get 'apply$-userfn ext-anc-attachments)
            (hons-get 'badge-userfn ext-anc-attachments))
        special-name
      (ext-anc-attachments-valid-p
       (cdr fns) ext-anc-attachments special-name wrld acc)))
   (t (let* ((f (car fns))
             (alist (cdr (hons-get f ext-anc-attachments)))
             (missing (ext-anc-attachment-missing alist wrld)))
        (or missing
            (ext-anc-attachments-valid-p
             (cdr fns)
             ext-anc-attachments
             special-name
             wrld
             (and acc
                  (ext-anc-attachments-valid-p-1 (siblings f wrld)
                                                 alist
                                                 wrld))))))))

(defun regenerate-tau-database-fn0 (user-auto-modep auto-modep ens trips
                                                     ctx wrld state)
; Tau will visit each triple in trips and extend the tau database using the
; given auto-modep and ens.  Trips is a list of the tau-relevant triples in the
; current world, in chronological order from the earliest relevant boot-strap
; triple.  Auto-modep is the setting of the tau auto modep flag to use during
; the visit of each triple.  It is presumably T, since that is how the system
; boots.  However, when we pass the EXIT-BOOT-STRAP-MODE triple, we switch the
; auto-modep to user-auto-modep.

  (cond ((endp trips) (value wrld))
        ((eq (cadr (car trips)) 'formals)
         (regenerate-tau-database-fn0
          user-auto-modep auto-modep ens
          (cdr trips)
          ctx
          (tau-visit-function-introduction (car (car trips)) wrld)
          state))
        ((and (eq (car (car trips)) 'event-landmark)
              (eq (cadr (car trips)) 'global-value))
         (cond ((eq (access-event-tuple-type (cddr (car trips)))
                    'EXIT-BOOT-STRAP-MODE)
                (regenerate-tau-database-fn0
                 user-auto-modep user-auto-modep ens
                 (cdr trips)
                 ctx wrld state))
               (t
                (er-let*
                  ((wrld1
                    (tau-visit-event nil
                                     (access-event-tuple-type (cddr (car trips)))
                                     (access-event-tuple-namex (cddr (car trips)))
                                     auto-modep ens ctx wrld state)))
                  (regenerate-tau-database-fn0
                   user-auto-modep auto-modep ens
                   (cdr trips)
                   ctx wrld1 state)))))
        (t (value
            (er hard 'regenerate-tau-database-fn0
                "Collect-tau-relevant-triples collected an unrecognized ~
                 property!  We expected to see fn FORMALS and EVENT-LANDMARK ~
                 GLOBAL-VALUE triples, but we see the triple ~x0."
                (car trips))))))

(defun regenerate-tau-database-fn1
  (boot-strap-auto-modep user-auto-modep ens ctx wrld state)

; Collect all the tau-relevant triples in the world, in chronological order,
; then re-initialize the tau globals, and then visit each triple in turn and
; regenerate the tau database.  We start with the tau auto mode set to
; boot-strap-auto-mode (presumably t), and switch to the user-auto-mode setting
; when we get out of the boot strap region.

; Tau Todo: It might be worthwhile trying to compress the world we get from
; this event.  See how big it is and think about it.

  (regenerate-tau-database-fn0
   user-auto-modep
   boot-strap-auto-modep
   ens
   (collect-tau-relevant-triples wrld nil)
   ctx
   (initialize-tau-preds
    *primitive-monadic-booleans*
    (initialize-tau-globals wrld))
   state))

; Essay on Regenerate-tau-database

; Regenerate-tau-database is motivated by the desire to provide the user with
; some facility for adjusting the tau database to reflect a theory, since
; otherwise there would be no way to achieve that end short of removing certain
; theorems from the script!  We think this will be a rarely-used event simply
; because tau is designed to prove goals, not to simplify or rewrite them.  How
; often will the user wish a goal NOT to be proved?  This is an admittedly
; naive view of the situation, since as of this writing no one has ever used
; the tau system!  It is still being developed.

; Regenerate-tau-database recomputes the database but only considers those
; runes enabled by the current global theory.  But this represents a design
; choice: why not allow the user to specify the theory governing the
; regeneration process?  For example, why not provide:

; (regenerate-tau-database (disable lemma55))

; We call this the ``tau theory alternative'' and rejected it because we think
; it will confuse the user moving forward.  That is, while a particular tau
; theory might be used to regenerate the database when the regeneration event
; is processed, the subsequent incremental extension of the database with
; :tau-system or implicit (auto mode) rules is done under the global theory.
; This could be confusing if the user thinks that the tau theory governs what
; is in the tau database (instead of what was put in it ``initially'' by the
; regeneration event).

; One solution would be to provide a completely separate theory to be used by
; tau.  Setting the tau theory to some new theory would actually recompute the
; tau database.  As new events are added, both the current theory and the tau
; theory are explicitly extended.  All queries to enabled status by the tau
; system, including its use of type-set, would refer to the tau theory.  In a
; situation similar to in-arithmetic-theory we would either have to provide
; versions of enable and disable that are relative to current-tau-theory or
; else warn the user not to use those macros.  All things considered this seems
; like a lot of infrastructure for a rarely used event.

; The design we actually implement doesn't allow for a distinct tau theory.
; The global theory is always used.  If the user wants to regenerate the
; database he or she must reset the global theory appropriately and set it back
; afterwards.  This has the advantage of forcing the user to acknowledge which
; theory is being used.

; In a similar vein, we use the global (acl2-defaults-table) setting of
; tau-auto-modep during the regeneration.

; Tau Todo:  see the install-event comment below!

(defun regenerate-tau-database-fn (state event-form)

; Warning: If this event ever generates proof obligations, remove it from the
; list of exceptions in install-event just below its "Comment on irrelevance of
; skip-proofs".

  (when-logic
   "REGENERATE-TAU-DATABASE"
   (with-ctx-summarized
    "( REGENERATE-TAU-DATABASE)"
    (let* ((wrld (w state))
           (event-form (or event-form
                           '(REGENERATE-TAU-DATABASE)))
           (boot-strap-auto-modep (cdar *tau-status-boot-strap-settings*))
           (user-auto-modep (tau-auto-modep wrld))
           (ens (ens state)))

; Note: We do not permit REGENERATE-TAU-DATABASE events to be redundant.  If
; this is changed, change the text of the :doc for redundant-events.

      (er-let*
        ((wrld1 (regenerate-tau-database-fn1 boot-strap-auto-modep
                                             user-auto-modep
                                             ens ctx wrld state))
         (val (install-event t
                             event-form
                             'regenerate-tau-database
                             0
                             nil
                             nil
                             :protect
                             nil
                             wrld1 state)))
        (value t))))))

; Next comes support for time-tracker (but see axioms.lisp for
; time-tracker-fn).

(defun rational-to-decimal-string (x state)
  (declare (xargs :mode :program
                  :stobjs state
                  :guard (rationalp x)))
  (mv-let (channel state)
          (open-output-channel :string :character state)
          (pprogn (print-rational-as-decimal x channel state)
                  (er-let* ((str (get-output-stream-string$
                                  channel state nil)))
                           (pprogn (close-output-channel channel state)
                                   (value str))))))

#-acl2-loop-only
(progn

(defvar *time-tracker-alist* nil)

(defvar *time-tracker-disabled-p* nil)

(defstruct time-tracker

; When this structure is created for a given tag, Init is set to the current
; run-time.  Tracking is on when Latest is non-nil, in which case Latest marks
; the run-time at the time time-tracker was turned on (for an implicitly
; associated tag) with option :init.  Elapsed marks the total elapsed run-time
; accumulated with tracking active, except that if tracking is currently
; inactive (i.e., :latest is non-nil), then Elapsed does not include the
; run-time since Latest.  Times and Interval come from the :init option of
; time-tracker, though Times may have been cdr'ed; so these are a true-list of
; rationals and either a rational or nil, respectively.

; The Msg field is marked as :read-only simply because we currently see no
; reason to update that field.

  (init ; reset by :init
   (get-internal-time) :type rational :read-only t)
  (latest   ; reset by :init, :stop, and :start
   nil :type (or null rational))
  (elapsed  ; total time tracked, updated when updating Latest
   0 :type rational)
  (msg
   nil :read-only t)
  (times    ; can be updated by time-tracker with option :print?
   nil :type (satisfies rational-listp))
  (interval ; if non-nil, used for updating an empty Times
   nil :type (or null rational) :read-only t)
  )

(defun tt-print-msg (tag msg total)
  (assert msg)
  (let* ((state *the-live-state*) ; local state
         (*file-clock* *file-clock*)
         (seconds (/ total internal-time-units-per-second)))
    (mv-let
     (erp seconds-as-decimal-string state)
     (rational-to-decimal-string seconds state)
     (assert$ (null erp)
              (fms "TIME-TRACKER-NOTE [~x0]: ~@1~|"
                   (list (cons #\0 tag)
                         (cons #\1 msg)
                         (cons #\t seconds-as-decimal-string))
                   (proofs-co state) state nil)))))

(defun tt-init (tag times interval msg)
  (cond
   ((null times)
    (er hard 'time-tracker
        "Illegal :INIT option (tag ~x0): the :TIMES keyword is required, with ~
         a value that is a non-empty list of rational numbers."
        tag))
   ((not (rational-listp times))
    (er hard 'time-tracker
        "Illegal value of :TIMES for :INIT (tag ~x0): ~x1 is not a true list ~
         of rationals.  See :DOC time-tracker."
        tag times))
   ((not (or (null interval)
             (rationalp interval)))
    (er hard 'time-tracker
        "Illegal value of :INTERVAL for :INIT (tag ~x0): ~x1 is neither NIL ~
         nor a rational number.  See :DOC time-tracker."
        tag interval))
   ((and msg
         (not (msgp msg)))
    (er hard 'time-tracker
        "Illegal value of :MSG for :INIT (tag ~x0): ~x1 is not a string or a ~
         true list whose first element is a string.  See :DOC time-tracker."
        tag msg))
   ((assoc-eq tag *time-tracker-alist*)
    (er hard 'time-tracker
        "It is illegal to specify :INIT for tag ~x0, because this tag is ~
         already being tracked.  Specify :END first to solve this problem.  ~
         See :DOC time-tracker."
        tag))
   (t (setq *time-tracker-alist*
            (acons tag
                   (make-time-tracker
                    :msg
                    (or msg "~st s")
                    :times
                    (mapcar (lambda (x) (* x internal-time-units-per-second))
                            times)
                    :interval
                    (and interval
                         (* internal-time-units-per-second interval)))
                   *time-tracker-alist*)))))

(defun tt-end (tag)

; We allow :end to run without error even when tag is not being tracked, so
; that we can run :end in case an anticipated earlier :end was not run because
; of an interceding interrupt.

  (when (assoc-eq tag *time-tracker-alist*)
    (setq *time-tracker-alist*
          (remove1-assoc-eq tag *time-tracker-alist*))))

(defun tt-print? (tag min-time msg)

; When we print based on the first of time-tracker-times (because min-time
; isn't supplied), we update time-tracker-times, taking the cdr but if the
; result is empty and the :interval is not nil, then leaving an empty singleton
; list containing the interval.  If min-time is supplied, then
; time-tracker-times is not updated.

  (cond
   ((not (or (null min-time)
             (rationalp min-time)))
    (er hard 'time-tracker
        "Illegal value of :MIN-TIME for :PRINT? (tag ~x0): ~x1 is not a ~
         rational number or nil.  See :DOC time-tracker."
        tag min-time))
   ((and msg
         (not (msgp msg)))
    (er hard 'time-tracker
        "Illegal value of :MSG for :PRINT? (tag ~x0): ~x1 is not a string or ~
         a true list whose first element is a string.  See :DOC time-tracker."
        tag msg))
   (t (let ((tt (cdr (assoc-eq tag *time-tracker-alist*))))
        (when tt
          (let* ((min-time (and min-time
                                (* internal-time-units-per-second min-time)))
                 (times (time-tracker-times tt))
                 (time (or min-time (car times))))
            (when time
              (let* ((current-internal-time (get-internal-time))
                     (total (let ((latest (time-tracker-latest tt)))
                              (if latest
                                  (+ (time-tracker-elapsed tt)
                                     (- current-internal-time latest))
                                (time-tracker-elapsed tt)))))
                (when (>= total time)
                  (let ((msg (or msg (time-tracker-msg tt))))
                    (when msg
                      (tt-print-msg tag msg total)))
                  (when (not min-time) ; see comment above discussing this test
                    (pop times)
                    (loop (cond ((or (null times)
                                     (< total (car times)))
                                 (return))
                                (t (pop times))))
                    (setf (time-tracker-times tt)
                          (if (null times)
                              (let ((interval (time-tracker-interval tt)))
                                (if interval
                                    (list (+ total interval))
                                  nil))
                            times))))))))))))

(defun tt-stop (tag)
  (let* ((tt (cdr (assoc-eq tag *time-tracker-alist*)))
         (latest (and tt (time-tracker-latest tt))))
    (cond
     ((not tt)
      (er hard 'time-tracker
          "It is illegal to specify :STOP for tag ~x0, because this tag is ~
           not being tracked.  Evaluate (~x1 '~x0 :INIT ...) to solve this ~
           problem.  See :DOC time-tracker."
          tag
          'time-tracker))
     ((not latest)
      (er hard 'time-tracker
          "It is illegal to specify :STOP for tag ~x0, because tracking for ~
           this tag is already in an inactive state.  Evaluate ~x1 to solve ~
           this problem.  See :DOC time-tracker."
          tag
          `(time-tracker ',tag :start)))
     (t (setf (time-tracker-elapsed tt)
              (+ (time-tracker-elapsed tt)
                 (- (get-internal-time) latest)))
        (setf (time-tracker-latest tt)
              nil)))))

(defun tt-start (tag &optional do-it)
  (let ((tt (cdr (assoc-eq tag *time-tracker-alist*))))
    (cond
     ((not tt)
      (er hard 'time-tracker
          "It is illegal to specify :START for tag ~x0, because this tag is ~
           not being tracked.  Evaluate (~x1 '~x0 :INIT ...) to solve this ~
           problem.  See :DOC time-tracker."
          tag
          'time-tracker))
     ((and (time-tracker-latest tt)
           (or (not do-it)
               (and (eval `(time-tracker ',tag :stop))
                    nil)))
      (er hard 'time-tracker
          "It is illegal to specify :START for tag ~x0, because tracking for ~
           this tag is already in an active state.  Evaluate ~x1 to solve ~
           this problem.  See :DOC time-tracker."
          tag
          `(time-tracker ',tag :stop)))
     (t (setf (time-tracker-latest tt)
              (get-internal-time))))))
)

; We originally defined defund in axioms.lisp, but now that its definition
; depends on remove-strings and other functions defined after axioms.lisp, we
; define it here.

#+acl2-loop-only
(defmacro defund (&rest def)
  (declare (xargs :guard (and (true-listp def)
                              (symbolp (car def))
                              (symbol-listp (cadr def)))))

  `(with-output
     :stack :push :off :all
     (progn (with-output :stack :pop (defun ,@def))
            ,@(and (not (program-declared-p def))
                   `((with-output
                       :stack :pop

; We never want to see the summary here.  But we do want to see a redundancy
; message, which is printed in stop-redundant-event with (io? event ...) --
; unless event output is inhibited at the start of the defund call.

                       :off summary
                       (in-theory (disable ,(car def))))))
            (value-triple ',(event-keyword-name 'defund (car def))
                          :on-skip-proofs t))))

#-acl2-loop-only
(defmacro defund (&rest def)
  (cons 'defun def))

; The next three events introduce a :logic mode version of ev-fncall that has
; unknown-constraints.  Note that magic-ev-fncall is introduced eventually with
; partial-encapsulate, but we use defproxy here because state-p is still in
; :program mode.

; Historical Note from before this use of defproxy.  We originally put this in
; boot-strap-pass-2.lisp (a precursor to the combination of
; boot-strap-pass-2-a.lisp and boot-strap-pass-2-b.lisp), but it didn't work
; there, because add-trip doesn't give special treatment for defun-overrides in
; pass 2 of the boot-strap, which is the only time that the events in
; boot-strap-pass-2.lisp were evaluated.

#+acl2-loop-only
(defproxy magic-ev-fncall (* * state * *) => (mv * *))

#-acl2-loop-only
(progn

(defun raw-ev-fncall-simple (fn args w hard-error-returns-nilp aok programp
                                stobjs-out)

; Warning: Keep this in sync with raw-ev-fncall.  The present version is
; somewhat faster, and supports efficient execution of magic-ev-fncall, thus
; avoiding any consideration of stobjs.

; We assume that w = (w *the-live-state*), that the call of
; ev-fncall-w-guard in magic-ev-fncall has been successfully executed, that
; programp = (programp fn w), and that stobjs-out = (stobjs-out fn w).

  (the (values t t)
       (let* ((*aokp*

; We expect the parameter aok, here and in all functions in the "ev family"
; that take aok as an argument, to be Boolean.  If it's not, then there is no
; real harm done: *aokp* would be bound here to a non-Boolean value, suggesting
; that an attachment has been used when that isn't necessarily the case; see
; *aokp*.

               aok)
              (throw-raw-ev-fncall-flg t)
              (**1*-as-raw*

; We defeat the **1*-as-raw* optimization so that when we use raw-ev-fncall to
; evaluate a call of a :logic mode term, all of the evaluation will take place
; in the logic.  Note that we don't restrict this special treatment to
; :common-lisp-compliant functions, because such a function might call an
; :ideal mode function wrapped in ec-call.  But we do restrict to :logic mode
; functions, since they cannot call :program mode functions and hence there
; cannot be a subsidiary rebinding of **1*-as-raw* to t.

               (if programp
                   **1*-as-raw*
                 nil))
              (applied-fn (*1*-symbol fn))
              (val (catch-raw-ev-fncall

; Since w = (w *the-live-state*), we can avoid calling (chk-raw-ev-fncall fn w
; aok) or checking (fboundp fn).

                    (prog1
                        (let ((*hard-error-returns-nilp*
                               hard-error-returns-nilp))
                          (cond ((null (cdr stobjs-out))
                                 (apply applied-fn args))
                                (t (multiple-value-list
                                    (apply applied-fn args)))))
                      (setq throw-raw-ev-fncall-flg nil)))))

; Observe that if a throw to 'raw-ev-fncall occurred during the
; (apply fn args) then the local variable throw-raw-ev-fncall-flg
; is t and otherwise it is nil.  If a throw did occur, val is the
; value thrown.

         (cond
          (throw-raw-ev-fncall-flg
           (mv t (ev-fncall-msg val w nil)))
          (t ; val already adjusted for multiple value case
             (mv nil val))))))

(defun-overrides magic-ev-fncall (fn args state hard-error-returns-nilp aok)
  (let* ((wrld (w state))
         (programp/stobjs-out
          (ev-fncall-w-guard fn args wrld
                             (f-get-global 'temp-touchable-fns state))))
    (cond
     (programp/stobjs-out
      (if (car programp/stobjs-out)
          (state-free-global-let*
           ((safe-mode t))
           (raw-ev-fncall-simple fn args
                                 wrld
                                 hard-error-returns-nilp
                                 aok
                                 t
                                 (cdr programp/stobjs-out)))
        (raw-ev-fncall-simple fn args wrld hard-error-returns-nilp aok nil
                              (cdr programp/stobjs-out))))
     (t
      (let ((msg
             (msg "~%~%Meta-level function Problem: Magic-ev-fncall attempted ~
                   to apply ~X02 to argument list ~X12.  This is illegal ~
                   because ~@3.  The meta-level function computation was ~
                   ignored.~%~%"
                  fn
                  args
                  (abbrev-evisc-tuple *the-live-state*)
                  (cond
                   ((not (symbolp fn))
                    (msg "~x0 is not a symbol" fn))
                   ((not (true-listp args))
                    (msg "that argument list is not a true list"))
                   ((eq (getpropc fn 'formals t wrld) t)
                    (msg "~x0 is not a known function symbol in the current ~
                          ACL2 logical world"
                         fn))
                   ((not (eql (length args)
                              (length (getpropc fn 'formals t wrld))))
                    (msg "the length of that argument list is ~x0, but ~x1 ~
                          takes ~x2 arguments"
                         (length args)
                         fn
                         (length (getpropc fn 'formals t wrld))))
                   (t

; Since we don't expect many direct calls of magic-ev-fncall and we have
; covered most cases above, we leave it up to the user to investigate which
; part of ev-fncall-w-guard fails.  The condition (all-nils-or-dfs stobjs-in)
; from ev-fncall-w-guard1 is automatically met here, since stobjs could not be
; put into the list, args.

                    (msg "even though the call of ~x0 is well-formed, it ~
                          fails to satisfy ~x1"
                         fn
                         'ev-fncall-w-guard))))))
        (mv t msg))))))
)

(defun make-event-ctx (event-form)
  (msg "( MAKE-EVENT ~@0~@1)"
       (tilde-@-abbreviate-object-phrase (cadr event-form))
       (if (cddr event-form) " ..." "")))

(defun protected-eval (form on-behalf-of ctx state aok)

; Warning: If you change this definition, consider whether the code in
; value-triple-fn1 should also be changed around the call there of
; protect-system-state-globals.

; This evaluator is intended to be used for make-event expansion.

; We assume that this is executed under a revert-world-on-error, so that we do
; not have to protect the world here in case of error, though we do set the
; world back to the starting world when returning a non-erroneous error triple.
; Form should evaluate either to an ordinary value, val, or to (mv nil val
; state stobj1 ... stobjk), where k may be 0.  If so, we return (value (list*
; val new-kpa new-ttags-seen)), where new-kpa and new-ttags-seen are the
; known-package-alist and value of world global 'ttags-seen immediately after
; form is evaluated; and if not, we return a soft error.

; See the comment at the call of trans-eval-default-warning, below.

  (let ((original-wrld (w state)))
    (state-global-let*
     ((in-local-flg

; During make-event expansion, there is no reason to prohibit local events
; (unless we move to inside an encapsulate or include-book, of course).

       nil)
      (ld-always-skip-top-level-locals nil))
     (protect-system-state-globals
      (er-let* ((result

; We call trans-eval-default-warning here, so that if make-event modifies
; stobjs, we issue a warning if and only if the current setting of LD special
; ld-user-stobjs-modified-warning says to issue that warning.  That seems
; reasonable since make-event may only be called in event contexts.  See :DOC
; user-stobjs-modified-warning.

; It would be nice to add (state-global-let* ((safe-mode t)) here.  But some
; *1* functions need always to call their raw Lisp counterparts.  Although we
; have made progress in oneify-cltl-code to that end by keeping functions like
; certify-book-fn from being replaced by their *1* counterparts, still that
; process is not complete, so we play it safe here by avoiding safe-mode.

; If we bind safe-mode to t here, visit occurrences of comments "; Note that
; safe-mode for make-event will require addition".  Those comments are
; associated with membership tests that, for now, we avoid for efficiency.
; Also note that we have similarly decided that value-triple does not use
; safe-mode (at least by default); it did at one time, but we decided that
; since make-event doesn't use safe-mode, it is a bit pointless to require
; value-triple to use safe-mode.  So if we decide that make-event expansion
; should use safe-mode, then we should strongly consider making the same
; decision for value-triple.

                 (trans-eval-default-warning form ctx state aok)))
        (let* ((new-kpa (known-package-alist state))
               (new-ttags-seen (global-val 'ttags-seen (w state)))
               (stobjs-out (car result))
               (vals (cdr result))
               (safep (equal stobjs-out '(nil))))
          (cond (safep (value (list* vals new-kpa new-ttags-seen)))
                ((or (null (cdr stobjs-out))
                     (not (eq (caddr stobjs-out) 'state))
                     (member-eq nil (cdddr stobjs-out)))
                 (er soft ctx
                     "The form ~x0 was expected to return a result that is ~
                      either a single ordinary value or else is a tuple (mv ~
                      erp val state stobj1 stobj2 ... stobjk) for some k >= ~
                      0.  But the shape of that result was ~x1."
                     form
                     (prettyify-stobjs-out stobjs-out)))
                ((car vals)
                 (cond
                  ((eq on-behalf-of :quiet!)
                   (silent-error state))
                  ((stringp (car vals))
                   (er soft ctx
                       (car vals)))
                  ((tilde-@p (car vals)) ; a message
                   (er soft ctx
                       "~@0"
                       (car vals)))
                  ((eq on-behalf-of :quiet)
                   (silent-error state))
                  (t (er soft ctx
                         "Error in MAKE-EVENT ~@0from expansion of:~|  ~y1"
                         (cond (on-behalf-of
                                (msg "on behalf of~|  ~y0~|"
                                     on-behalf-of))
                               (t ""))
                         form))))
                (t (pprogn
                    (set-w! original-wrld state)
                    (value (list* (cadr vals) new-kpa new-ttags-seen)))))))))))

(defun make-event-debug-pre (depth form on-behalf-of state)

; Assumes state global 'make-event-debug has a non-nil value.

  (fms "~x0> Expanding for MAKE-EVENT~@1~|  ~y2~|"
       (list (cons #\0 depth)
             (cons #\1
                   (if (and on-behalf-of
                            (not (member-eq on-behalf-of
                                            '(:quiet :quiet!))))
                       (msg " on behalf of~|  ~Y01:"
                            on-behalf-of
                            (term-evisc-tuple nil state))
                     ":"))
             (cons #\2 form))
       (proofs-co state) state nil))

(defun make-event-debug-post (debug-depth expansion0 state)

; Assumes state global 'make-event-debug has a non-nil value.

  (fms "<~x0 Returning MAKE-EVENT expansion:~|  ~Y12~|"
       (list (cons #\0 debug-depth)
             (cons #\1 expansion0)
             (cons #\2 (term-evisc-tuple nil state)))
       (proofs-co state) state nil))

(defstub always-do-proofs-during-make-event-expansion () t)

(defattach always-do-proofs-during-make-event-expansion
  constant-nil-function-arity-0)

(defmacro do-proofs? (do-proofsp use-always-do-proofs form)

; Use-always-do-proofs should be t when make-event expansion is carried out,
; meaning that we allow an attachable function to specify that proofs should be
; done even when not normally the case.  But in other cases we expect
; use-always-do-proofs to be nil -- we see no reason for the user to cause
; proofs to be done with an attachment in those cases.

  `(if ,(if use-always-do-proofs
            `(or ,do-proofsp
                 (let ((flg (always-do-proofs-during-make-event-expansion)))

; The attachable function called just above is useful for causing expansions to
; be done even when evaluating events with ld-skip-proofsp = t.  It may be a
; bad idea for it to interfere with include-book unless that is deliberately
; intended.

                   (and flg ; normally false
                        (or (eq flg :all)
                            (not (eq (ld-skip-proofsp state)
                                     'include-book))))))
          do-proofsp)
       (state-global-let*
        ((ld-skip-proofsp nil))
        ,form)
     ,form))

(defun make-event-fn2 (expansion0 whole-form in-encapsulatep check-expansion
                                  wrld ctx state)
  (mv-let
    (do-proofsp expansion0)
    (case-match expansion0
      ((':DO-PROOFS x)
       (mv (ld-skip-proofsp state)
           x))
      (& (mv nil expansion0)))
    (er-let* ((expansion1a ; apply macroexpansion to get embedded event form
               (do-proofs?

; This wrapper of do-proofs? avoids errors in checking expansions when
; ld-skip-proofsp is 'include-book.  See the "Very Technical Remark" in
; community book  books/make-event/read-from-file.lisp.

                check-expansion
                t ; use-always-do-proofs (part of expansion)
                (chk-embedded-event-form
                 expansion0 whole-form wrld ctx state (primitive-event-macros)
                 (f-get-global 'in-local-flg state)
                 in-encapsulatep
                 nil)))
              (expansion1b
               (value (or expansion1a

; Else the alleged embedded event form, from the expansion, is nil, presumably
; because of local.

                          *local-value-triple-elided*)))
              (stobjs-out-and-raw-result
               (do-proofs?
                do-proofsp
                nil ; use-always-do-proofs (nil, as this is eval of expansion)
                (trans-eval-default-warning

; Note that expansion1b is guaranteed to be an embedded event form, which (as
; checked just below) must evaluate to an error triple.

                 expansion1b
                 ctx state t))))
      (let ((raw-result (cdr stobjs-out-and-raw-result)))
        (cond ((car raw-result)
               (silent-error state))
              (t (let ((expansion1
                        (if (f-get-global 'boot-strap-flg state)
                            expansion1b
                          (make-include-books-absolute
                           expansion1b
                           (cbd)
                           nil
                           (primitive-event-macros)
                           nil ctx state))))
                   (value (list* expansion1
                                 (car stobjs-out-and-raw-result)
                                 (cadr raw-result))))))))))

(defun make-event-fn2-lst (expansion-lst whole-form in-encapsulatep
                                         check-expansion on-behalf-of wrld ctx
                                         state)
  (cond ((atom expansion-lst)
         (cond ((member-eq on-behalf-of '(:quiet :quiet!))
                (silent-error state))
               (t (er soft ctx
                      "Evaluation failed for all expansions."))))
        (t (pprogn
            (cond
             ((f-get-global 'make-event-debug state)
              (fms "Attempting evaluation of next expansion:~|~Y01"
                   (list (cons #\0 (car expansion-lst))
                         (cons #\1 (abbrev-evisc-tuple state)))
                   (proofs-co state)
                   state
                   nil))
             (t state))
            (mv-let
             (erp val state)
             (make-event-fn2 (car expansion-lst)
                             whole-form in-encapsulatep check-expansion
                             wrld ctx state)
             (cond (erp (make-event-fn2-lst (cdr expansion-lst)
                                            whole-form in-encapsulatep
                                            check-expansion on-behalf-of
                                            wrld ctx state))
                   (t (value val))))))))

(defun make-event-fn1 (expansion0 whole-form in-encapsulatep check-expansion
                                  on-behalf-of wrld ctx state)
  (cond ((and (consp expansion0)
              (eq (car expansion0) :OR))

; In the unlikely event that we are in the process of including a book or
; executing the second pass of an encapsulate, we don't want to use cert-data
; on defun forms that are not the ones that will be kept.  Imagine for example
; that we have encountered an expansion (:OR (defun f1 ...) (defun f2 ...)),
; where f2 is to be kept, but there is a later defun of f1.  Then the cert-data
; for f1 should not be applied to the defun of f1 in the :OR expression.

         (state-global-let*
          ((cert-data nil))
          (make-event-fn2-lst (cdr expansion0)
                              whole-form in-encapsulatep check-expansion
                              on-behalf-of wrld ctx state)))
        (t (make-event-fn2 expansion0
                           whole-form in-encapsulatep check-expansion
                           wrld ctx state))))

(defun ultimate-expansion (x)

; We dive inside values of :expansion? keywords, starting with x, and stepping
; past wrappers (in the sense of destructure-expansion).  Except, if
; :expansion? is provided but :check-expansion is non-nil (hence t), then
; :expansion? is ignored for this purpose, so that we can avoid destroying the
; surrounding make-event that should be saved for purposes of :check-expansion.
; The idea is that when including a book (or doing the second pass of an
; encapsulate), we replace a make-event form directly by its :expansion? value
; unless :check-expansion is t, in which case the make-event form and the
; :expansion?  value are not equivalent, because the make-event form redoes the
; expansion process.

; Warning: Be careful not to use this function unless each make-event form
; encountered during the traversal that has a value for the :expansion? keyword
; can be trusted to have an expansion suitably consistent with that value.

  (case-match x
    (('make-event & . kwd-alist)
     (let ((exp (cadr (assoc-keyword :expansion? kwd-alist))))
       (cond ((and exp
                   (not (cadr (assoc-keyword :check-expansion kwd-alist))))
              (ultimate-expansion exp))
             (t x))))
    (& (mv-let (w y)
               (destructure-expansion x)
               (cond (w (rebuild-expansion w (ultimate-expansion y)))
                     (t x))))))

(defun make-event-fn (form expansion? check-expansion on-behalf-of
                           save-event-data whole-form state)
  (let ((ctx (make-event-ctx whole-form))
        #-acl2-loop-only
        (old-kpa (known-package-alist state)))
    (with-ctx-summarized
     ctx
     (cond
      ((and (eq (cert-op state) :convert-pcert)
            (not (f-get-global 'in-local-flg state))
            (not (consp check-expansion))
            (not expansion?)

; This case should not happen, because all make-event forms should already be
; expanded away when we do the Convert procedure of provisional certification,
; since a suitable expansion-alist should have been stored in the .pcert0 file.
; We include this check just for robustness.

            (eql (f-get-global 'make-event-debug-depth state)

; We only enforce the above consp requirement at the top-level.  If we have
; (make-event ... :check-expansion exp ...), and this event is admissible
; (perhaps when skipping proofs) then we know that the result will be exp and
; will be independent of the current state.  In particular, exp will not be a
; call of make-event if form is admissible.

                 0))
       (er soft ctx
           "Implementation error: You should not be seeing this message!  ~
            Please contact the ACL2 implementors.~|~%Make-event expansion is ~
            illegal during the Convert procedure of provisional certification ~
            (unless :check-expansion is supplied a consp argument or ~
            :expansion? is supplied a non-nil argument).  The form ~x0 is ~
            thus illegal.  The use of a .acl2x file can sometimes solve this ~
            problem.  See :DOC provisional-certification."
           whole-form))
      ((not (or (eq check-expansion nil)
                (eq check-expansion t)
                (consp check-expansion)))
       (er soft ctx
           "The check-expansion flag of make-event must be t, nil, or a cons ~
            pair.  The following check-expansion flag is thus illegal: ~x0.  ~
            See :DOC make-event."
           check-expansion))
      ((and expansion?
            (consp check-expansion))

; We considered allowing :EXPANSION? FORM1 and :CHECK-EXPANSION FORM2 (where
; FORM2 is not nil or t), and if someone presents a natural example for which
; this would be useful, we might do so.  But the semantics of this would be
; potentially confusing.  Which one is consulted when including a book or
; running in raw Lisp?  If FORM1 = FORM2, this looks redundant.  Otherwise,
; this is, oddly, inherently contradictory, in the sense that FORM1 should
; never be the expansion (unless one is deliberately arranging for evaluation
; of the make-event call to fail -- but there are simpler ways to do that).

; If we decide to support the combination of expansion? and (consp
; check-expansion), then we need to be careful to handle that combination --
; something we don't do now, but we code defensively, giving priority to (consp
; check-expansion).

       (er soft ctx
           "It is illegal to supply a non-nil value for the keyword argument ~
            :EXPANSION? of make-event when keyword argument :CHECK-EXPANSION ~
            is give a value other than T or NIL.  If you think you have a ~
            reason why such a combination should be supported, please contact ~
            the ACL2 implementors."))
      (t
       (revert-world-on-error
        (let* ((make-event-debug (f-get-global 'make-event-debug state))
               (new-debug-depth (1+ (f-get-global 'make-event-debug-depth state)))
               (wrld (w state)))
          (er-let*
              ((expansion0/new-kpa/new-ttags-seen
                (pprogn
                 (if make-event-debug
                     (make-event-debug-pre new-debug-depth form on-behalf-of
                                           state)
                   state)
                 (state-global-let*
                  ((make-event-debug-depth new-debug-depth))
                  (cond
                   ((and expansion?
                         (eq (ld-skip-proofsp state) 'include-book)
                         (not (f-get-global 'including-uncertified-p state))

; Even if expansion? is specified, we do not assume it's right if
; check-expansion is t.

                         (assert$ (iff check-expansion

; In code above, we disallowed the combination of non-nil expansion? with a
; consp value of :check-expansion.

                                       (eq check-expansion t))
                                  (not (eq check-expansion t))))
                    (value (list* expansion? nil nil)))
                   (t
                    (do-proofs?
                     (or check-expansion

; For example, a must-fail form in community book books/make-event/defspec.lisp
; will fail during the Pcertify process of provisional certification unless we
; turn proofs on during expansion at that point.  It's reasonable to do proofs
; under make-event expansion during the Pcertify process: after all, we need
; the expansion done in order for other books to include the make-event's book
; with the .pcert0 certificate, and also proofs might well be necessary in
; order to come up with the correct expansion (else why do them?).  We could
; indeed always do proofs, but it's pretty common to do proofs only during
; certification as a way of validating some code.  So our approach is only to
; move proofs from the Convert procedure to the Pcertify procedure.

                         (eq (cert-op state) :create-pcert))
                     t ; use-always-do-proofs (for the main expansion here)

; Just below, the use of protected-eval ensures, among other things, that
; global cert-data won't be consulted.  To see why, imagine that a defun for
; foo is evaluated here during make-event expansion with non-nil
; :check-expansion while including a book, where a different defun of foo
; occurs later at the top level of the book.

                     (protected-eval form on-behalf-of ctx state t)))))))
               (expansion0 (value (car expansion0/new-kpa/new-ttags-seen)))
               (new-kpa (value (cadr expansion0/new-kpa/new-ttags-seen)))
               (new-ttags-seen
                (value (cddr expansion0/new-kpa/new-ttags-seen)))
               (need-event-landmark-p
                (pprogn
                 (if make-event-debug
                     (make-event-debug-post new-debug-depth expansion0 state)
                   state)
                 (cond ((or (null new-ttags-seen)

; The condition above holds when the new ttags-seen is nil or was not computed.
; Either way, no addition has been made to the value of world global
; 'ttags-seen.

                            (equal new-ttags-seen
                                   (global-val 'ttags-seen wrld)))
                        (value nil))
                       (t (pprogn
                           (set-w 'extension
                                  (global-set 'ttags-seen new-ttags-seen
                                              wrld)
                                  state)
                           (value t))))))
               (wrld0 (value (w state)))
               (expansion1/stobjs-out/result
                (make-event-fn1
                 expansion0 whole-form
                 (in-encapsulatep (global-val 'embedded-event-lst wrld0) nil)
                 check-expansion on-behalf-of wrld0 ctx state)))
            (let* ((expansion1 (car expansion1/stobjs-out/result))
                   (stobjs-out (cadr expansion1/stobjs-out/result))
                   (result (cddr expansion1/stobjs-out/result))
                   (expansion2
                    (cond
                     ((f-get-global 'last-make-event-expansion state)
                      (mv-let
                        (wrappers base)
                        (destructure-expansion expansion1)

; At this point we know that (car base) is from the list '(make-event progn
; progn! encapsulate); indeed, just after the release of v3-5, we ran a
; regression in community book books/make-event with the code C below replaced
; by (assert$ (member-eq (car base) X) C), where X is the above quoted list.
; However, we do not add that assertion, so that for example the ccg book of
; ACL2s can create make-event expansions out of events other than the four
; types above, e.g., defun.

                        (declare (ignore base))
                        (rebuild-expansion
                         wrappers
                         (ultimate-expansion
                          (f-get-global 'last-make-event-expansion state)))))
                     (t (ultimate-expansion expansion1)))))
              (assert$
               (equal stobjs-out *error-triple-sig*) ; evaluated an event form
               (let ((expected-expansion (if (consp check-expansion)
                                             check-expansion
                                           (and (eq (ld-skip-proofsp state)
                                                    'include-book)
                                                check-expansion
                                                expansion?))))
                 (cond ((and expected-expansion
                             (not (equal expected-expansion ; easy try first
                                         expansion2))
                             (not (equal (ultimate-expansion
                                          expected-expansion)
                                         expansion2)))
                        (er soft ctx
                            "The current MAKE-EVENT expansion differs from ~
                              the expected (original or specified) expansion. ~
                              ~ See :DOC make-event.~|~%~|~%Make-event ~
                              argument:~|~%~y0~|~%Expected ~
                              expansion:~|~%~y1~|~%Current expansion:~|~%~y2~|"
                            form
                            expected-expansion
                            expansion2))
                       (t
                        (let ((actual-expansion
                               (cond
                                ((or (consp check-expansion)
                                     (equal expansion?
                                            expansion2) ; easy try first
                                     (equal (ultimate-expansion
                                             expansion?)
                                            expansion2))

; The original make-event form does not generate a make-event replacement (see
; :doc make-event).

                                 nil)
                                (check-expansion
                                 (assert$
                                  (eq check-expansion t) ; from macro guard
                                  (list* 'make-event form

; Note that we deliberately omit :expansion? here, even if it was supplied
; originally.  If :expansion? had been supplied and appropriate, then we would
; be in the previous case, where we don't generate a make-event around the
; expansion.

                                         :check-expansion expansion2
                                         (and on-behalf-of
                                              `(:on-behalf-of
                                                ,on-behalf-of)))))
                                (t expansion2))))
                          #-acl2-loop-only
                          (let ((msg

; We now may check the expansion to see if an unknown package appears.  The
; following example shows why this can be important.  Consider a book "foo"
; with this event.

; (make-event
;  (er-progn
;   (include-book "foo2") ; introduces "MY-PKG"
;   (assign bad (intern$ "ABC" "MY-PKG"))
;   (value `(make-event
;            (list 'defconst '*a*
;                  (list 'length
;                        (list 'symbol-name
;                              (list 'quote ',(@ bad)))))))))
;

; where "foo2" is as follows, with the indicated portcullis command:

; (in-package "ACL2")
;
; ; (defpkg "MY-PKG" nil)
;
; (defun foo (x)
;   x)

; In ACL2 Version_3.4, we certified these books; but then, in a new ACL2
; session, we got a raw Lisp error about unknown packages when we try to
; include "foo".

; On the other hand, the bad-lisp-objectp test is potentially expensive for
; large objects such as are encountered at Centaur Tech. in March 2010.  The
; value returned by expansion can be expected to be a good lisp object in the
; world installed at the end of expansion, so if expansion doesn't extend the
; world with any new packages, then we can avoid this check.

                                 (and (not (eq old-kpa new-kpa))
                                      (bad-lisp-objectp actual-expansion))))
                            (when msg
                              (er hard ctx
                                  "Make-event expansion for the form ~x0 has ~
                                    produced an illegal object for the ~
                                    current ACL2 world.  ~@1"
                                  form
                                  msg)))
                          (er-progn
                           (cond ((f-get-global 'boot-strap-flg state)

; In the boot-strap, we prevent make-event from storing an expansion, since
; otherwise we get an error for (when-pass-2 ... (make-event ...) ...), because
; make-event is not in an event context.

                                  (pprogn
                                   (if (in-encapsulatep
                                        (global-val 'embedded-event-lst
                                                    (w state))
                                        nil)
                                       (er soft ctx
                                           "Illegal form:~|~x0~|~%Make-event ~
                                             is illegal inside an encapsulate ~
                                             when in the boot-strap. See the ~
                                             relevant discussion in ~
                                             make-event-fn."
                                           form)
                                     (value nil))))
                                 (t
                                  (pprogn
                                   (f-put-global 'last-make-event-expansion
                                                 actual-expansion
                                                 state)
                                   (value nil))))
                           (pprogn
                            (cond
                             ((f-get-global 'make-event-debug state)
                              (fms "Saving make-event replacement into state ~
                                    global 'last-make-event-expansion (debug ~
                                    level ~
                                    ~x0):~|Form:~|~X13~|Expansion:~|~X23~|"
                                   (list (cons #\0 new-debug-depth)
                                         (cons #\1 form)
                                         (cons #\2 actual-expansion)
                                         (cons #\3 (abbrev-evisc-tuple state)))
                                   (proofs-co state)
                                   state
                                   nil))
                             (t state))
                            (er-progn
                             (cond (need-event-landmark-p ; optimization

; We lay down an event landmark if we aren't already looking at one.  Before we
; did so, an error was reported by print-redefinition-warning in the following
; example, because we weren't looking at an event landmark.

; (redef!)
; (make-event (er-progn (defttag t)
;                       (value '(value-triple nil))))

                                    (maybe-add-event-landmark state))
                                   (t (value nil)))
                             (value result)))))))))))))))
     :event-type (if save-event-data
                     'make-event-save-event-data
                   'make-event))))

(defun trans*-fn1 (iter transp quiet make-event-p form ctx wrld state)

; This function performs one iteration of trans*, returning an error triple
; whose value, in the non-error case, is (cons flg val), where val is the
; result of expanding or translating, and flg is t in the case of expanding,
; else nil.  The error case includes the case that form is not a call of
; make-event or a macro and transp is nil.  The non-error result is printed if
; and only if quiet is non-nil.  The caller is responsible for deciding whether
; to continue iterating.

  (cond
   ((and (consp form)
         (member-eq (car form) *destructure-expansion-wrappers*))
    (pprogn
     (cond
      (quiet state)
      (t (fms "Iteration ~x0 is dropping the ~x1 wrapper:~|~x2~|----------~|"
              (list (cons #\0 iter)
                    (cons #\1 (car form))
                    (cons #\2 (car (last form))))
              (standard-co state) state nil)))
     (value (cons t (car (last form))))))
   (t
    (let* ((make-event-case (and make-event-p
                                 (consp form)
                                 (eq (car form) 'make-event)
                                 (consp (cdr form))
                                 (keyword-value-listp (cddr form))))
           (macrop (and (not make-event-case) ; optimization
                        (consp form)
                        (symbolp (car form))
                        (getpropc (car form) 'macro-body))))
      (er-let* ((next
                 (cond
                  (make-event-case
                   (er-let* ((expansion0/new-kpa/new-ttags-seen
                              (revert-world-on-error
                               (protected-eval (cadr form)
                                               (cadr (assoc-eq :on-behalf-of
                                                               (cddr form)))
                                               ctx state t))))
                     (value (car expansion0/new-kpa/new-ttags-seen))))
                  (macrop (macroexpand1 form ctx state))
                  (transp (translate form
                                     t   ; stobjs-out
                                     nil ; logic-modep [don't care]
                                     t   ; known-stobjs
                                     ctx wrld state))
                  (t (silent-error state)))))
        (pprogn
         (cond
          (quiet state)
          (t (fms "Iteration ~x0 produces (by ~#1~[expansion~/make-event ~
                   expansion~/translation~]):~|~x2~|----------~|"
                  (list (cons #\0 iter)
                        (cons #\1 (if macrop 0 (if make-event-case 1 2)))
                        (cons #\2 next))
                  (standard-co state) state nil)))
         (value (cons (or make-event-case macrop) next))))))))

(defun trans*-fn-iter (iter bound transp quiet make-event-p names-fal
                            form
                            ctx wrld state)
  (declare (xargs :guard (and (posp iter)
                              (or (eq bound t)
                                  (posp bound)))))
  (cond
   ((or (and (not (eq bound t))
             (> iter bound))
        (and (consp form)
             (not (and make-event-p
                       (eq (car form) 'make-event)))
             (not (member-eq (car form) *destructure-expansion-wrappers*))
             (hons-get (car form) names-fal)))
    (value (if quiet form :invisible)))
   (t (mv-let (erp flg/next state)
        (trans*-fn1 iter transp quiet make-event-p form ctx wrld state)
        (let ((flg (car flg/next))
              (next (cdr flg/next)))
          (cond
           (erp (value (if quiet form :invisible)))
           ((and (eq (car form) 'make-event)
                 (and (consp next)
                      (eq (car next) :or)))
            (value (if quiet next :invisible)))
           ((not flg)
            (value (if quiet next :invisible)))
           (t (trans*-fn-iter (1+ iter) bound transp quiet make-event-p names-fal
                              next
                              ctx wrld state))))))))

(defun trans*-fn (bound form make-event-p ctx state)
  (mv-let (reps0 quiet)
    (cond ((consp bound)
           (cond ((cdr bound)
                  (mv :error nil))
                 (t (mv (car bound) t))))
          (t (mv bound nil)))
    (mv-let (reps transp)
      (cond ((integerp reps0)
             (cond ((< reps0 0)
                    (mv (- reps0) nil))
                   ((> reps0 0)
                    (mv reps0 t))
                   (t (mv :error nil))))
            ((eq reps0 nil)
             (mv t nil))
            ((eq reps0 t)
             (mv t t))
            (t (mv :error nil)))
      (cond ((eq reps :error)
             (er soft ctx
                 "Illegal first argument for trans*, ~x0.  See :DOC trans*."
                 bound))
            ((and (consp form)
                  (not (and make-event-p
                            (eq (car form) 'make-event)))
                  (not (member-eq (car form) *destructure-expansion-wrappers*))
                  (hons-get (car form) *syms-not-callable-in-code-fal*))
             (er soft ctx
                 "Nothing to do: The input form is already the final result."))
            (t (trans*-fn-iter 1 reps transp quiet make-event-p
                               *syms-not-callable-in-code-fal*
                               form
                               ctx (w state) state))))))

(defmacro trans* (bound form)
  `(trans*-fn ,bound ,form t 'trans* state))

(defmacro trans*- (bound form)
  `(trans*-fn ,bound ,form nil 'trans*- state))

(defun get-check-invariant-risk (state)
  (let ((pair (assoc-eq :check-invariant-risk
                        (table-alist 'acl2-defaults-table (w state))))
        (cir (f-get-global 'check-invariant-risk state)))
    (cond (pair (case (cdr pair) ; then take the "minimum" with cir
                  ((:ERROR :CLEAR) cir)
                  ((:WARNING) (if (eq cir :ERROR) :WARNING cir))
                  ((T) (if (eq cir nil) nil t))
                  (otherwise nil)))
          (t cir))))

(defmacro set-check-invariant-risk (x &optional table-p)

; In oneify-cltl-code we handle an "invariant-risk" that stobj invariants
; aren't violated upon ill-guarded calls of stobj updaters.  The idea is to
; force evaluation to use *1* functions down to those primitives, which always
; check their guards.  See also the comment in **1*-as-raw*.  Note that this
; is a separate issue from the lack of atomicity of some defabsstobj exports
; (which is implemented using *inside-absstobj-update*).

; There may be cases where this use of *1* functions may be slower than one
; likes.  By setting the invariant-risk mode to nil, one defeats that behavior;
; see :DOC set-check-invariant-risk.  This could be unsound, but since one
; needs an active trust tag to set this global, we take the position that
; setting it is much like redefining prove so that one always gets the "Q.E.D."

; Perhaps we will consider avoiding this use of *1* functions when the only
; danger of invariant violations is from local stobjs.  Since only :program
; mode functions are at issue (because a :logic mode function call only slips
; into raw Lisp when the function has been guard-verified and the call is
; guard-checked, and because raw-ev-fncall binds **1*-as-raw* to nil for
; :logic mode functions), it seems plausible that we can provide this
; optimization for local stobjs.  After all, local stobjs are let-bound rather
; than global; so it seems that during proofs, any local stobj encountered will
; either be created and destroyed during a computed hint or else will be
; modified only by :logic mode functions manipulated by the prover.  (Trusted
; clause processors might provide an exception, but then trust tags are
; involved, so it's their responsibility to do the right thing.)

; But we'll leave that for another day, if at all, as it seems risky and
; error-prone to implement.  In particular, we would likely need to track
; invariant-risk on a per-stobj basis, and built-ins (see
; initialize-invariant-risk) might not be associated with stobjs at all.

  (declare (xargs :guard (booleanp table-p)))
  (cond
   (table-p
    `(with-output
      :off :all :on (observation error)
      (progn (table acl2-defaults-table :check-invariant-risk ,x)
             (make-event
              (pprogn (if (and (not (eq ,x (get-check-invariant-risk state)))
                               (not (eq ,x :CLEAR)))
                          (observation 'set-check-invariant-risk
                                       "No change is being made in the value ~
                                        computed by ~x0.  This happens when ~
                                        the value of state global ~
                                        'check-invariant-risk is less than ~
                                        the new table value; see :DOC ~
                                        set-check-invariant-risk."
                                       '(get-check-invariant-risk state))
                        state)
                      (value '(value-triple ,x)))
              :check-expansion t))))
   ((and x (member-eq x *check-invariant-risk-values*))
    `(set-check-invariant-risk-fn ,x state))
   (t `(cond
        ((not (member-eq ,x '(t nil :ERROR :WARNING)))
         (er soft 'check-invariant-risk
             "Illegal value for ~x0: ~x1"
             'check-invariant-risk
             ',x))
        (t (er-progn
            (with-ubt!
             (with-output
              :off :all
              (with-output
               :on (error warning warning!)
               (progn (defttag :set-check-invariant-risk)
                      (progn! (set-check-invariant-risk-fn ,x state))))))
            (value nil)))))))

(defun set-check-invariant-risk-fn (x state)
  (declare (xargs :guard (member-eq x *check-invariant-risk-values*)))
  (progn$ (mbt (and (member-eq x *check-invariant-risk-values*) t))
          (cond ((and (null x)
                      (f-get-global 'check-invariant-risk state)
                      (not (ttag (w state))))
                 (er soft 'set-check-invariant-risk
                     "There must be an active trust tag to set '~x0 to ~x1."
                     'check-invariant-risk nil))
                (t (pprogn
                    (f-put-global 'check-invariant-risk x state)
                    (if (not (eq x (get-check-invariant-risk state)))
                        (observation 'set-check-invariant-risk
                                     "No change is being made in the value ~
                                      computed by ~x0, because the new value ~
                                      of state global 'check-invariant-risk ~
                                      is greater than the table value; see ~
                                      :DOC set-check-invariant-risk."
                                     '(get-check-invariant-risk state))
                      state)
                    (value x))))))

(defun get-register-invariant-risk (state)
  (get-register-invariant-risk-world (w state)))

(defmacro set-register-invariant-risk (val)
  (declare (xargs :guard ; note: table event enforces ttag if val is nil
                  (booleanp val)))
  `(with-output
     :off (event summary)
     (progn (table acl2-defaults-table :register-invariant-risk ,val)
            (table acl2-defaults-table :register-invariant-risk))))

; The following two functions support the community books utility,
; include-raw.

(defun sort-fboundps (lst wrld ps ls ms)

; Accumulate, into ps, ls, and ms, the symbols of lst that are program-mode
; function symbols, logic-mode function symbols, and macro names, respectively.

  (declare (xargs :mode :program))
  (cond ((endp lst) (mv ps ls ms))
        (t (let ((s (car lst)))
             (cond ((getpropc s 'macro-body nil wrld)
                    (sort-fboundps (cdr lst) wrld ps ls (cons s ms)))
                   ((member (symbol-class s wrld)
                            '(:ideal :common-lisp-compliant)
                            :test 'eq)
                    (sort-fboundps (cdr lst) wrld ps (cons s ls) ms))
                   ((not (eq (getpropc s 'formals t wrld)
                             t))
                    (sort-fboundps (cdr lst) wrld (cons s ps) ls ms))
                   (t
                    (sort-fboundps (cdr lst) wrld ps ls ms)))))))

#-acl2-loop-only
(defun extend-with-raw-code (form state)

; The popular macro include-raw, defined in community book
; books/tools/include-raw.lisp, can be used to smash the symbol-functions of
; ACL2 functions and macros.  If one uses include-raw and then (comp t), one
; doesn't want to lose those new symbol-functions!  It is thus important, in
; support of (comp t), to extend the values of state globals
; 'program-fns-with-raw-code and 'logic-fns-with-raw-code, with those
; program-mode function symbols whose definitions that have been smashed.  It
; may be less important to extend the value of state global
; 'macros-with-raw-code, but that also seems the right thing to do.

; Thus, this function is essentially (eval form), except that instead of
; returning the value(s) from that evaluation, it returns a new state where the
; xxx-with-raw-code state globals are extended, according to the definitions of
; ACL2 macros and functions that have changed when form is evaluated.

; We considered making such a modification within the definition of the
; include-raw macro.  However, the do-all-symbols call took well over a half
; second on a small example when it was run interpreted in LispWorks, and that
; time was virtually eliminated when running compiled.  The simplest way to
; compile was to place this definition in the ACL2 sources (so, we added the
; definition of supporting function, sort-fboundps, as well).

  (let ((ht (make-hash-table :test 'eq)))
    (do-all-symbols (s)
      (when (fboundp s)
        (setf (gethash s ht)
              (symbol-function s))))
    (eval form) ; may overwrite some symbol-functions
    (let (lst)
      (maphash (lambda (key val)
                 (when (not (and (fboundp key) ; always true?

; It is tempting to use eq rather than equal just below.  However, in GCL we
; found that the symbol-function for a macro need not be EQ to itself (more
; accurately: fetching the symbol-function twice can give non-EQ results).
; Should we go further and use EQUALP?  So far, at least, that doesn't seem
; necessary.

                                 (equal val (symbol-function key))))
                   (push key lst)))
               ht)
      (mv-let (ps ls ms)
        (sort-fboundps lst (w state) nil nil nil)
        (pprogn
         (cond
          (ps (f-put-global
               'program-fns-with-raw-code
               (append ps (f-get-global 'program-fns-with-raw-code state))
               state))
          (t state))
         (cond
          (ls (f-put-global
               'logic-fns-with-raw-code
               (append ls (f-get-global 'logic-fns-with-raw-code state))
               state))
          (t state))
         (cond
          (ms (f-put-global
               'macros-with-raw-code
               (append ms (f-get-global 'macros-with-raw-code state))
               state))
          (t state)))))))

; Below we introduce doppelganger-badge-userfn and doppelganger-apply$-userfn
; as constrained functions.  See the Essay on the APPLY$ Integration in
; apply-prim.lisp for an overview.  These functions are intended to be the
; doppelgangers of badge-userfn and apply$-userfn, so we introduce them each
; with partial-encapsulate since the explicit constraints do not comprehend all
; properties of the doppelgangers.  Moreover, these doppelgangers change as the
; world changes, so they are each really a class of functions; therefore we
; make them each untouchable, so that users cannot take advantage of their
; changing nature to prove nil.  Also see the Essay on Memoization with
; Attachments.

#+acl2-loop-only
(partial-encapsulate
  (((doppelganger-badge-userfn *) => *))
  nil ; not the true supporters (see the Essay on Memoization with Attachments)
  (logic)
  (local (defun doppelganger-badge-userfn (fn)
           (declare (xargs :mode :logic))
           (declare (ignore fn))
           nil))

; The only purpose of this function is to serve as an executable attachment to
; badge-userfn.  So it must satisfy the constraint on that function.  That
; constraint is (or (null (badge-userfn fn)) (apply$-badgep (badge-userfn
; fn))).  See apply-prim.lisp for the defun of apply$-badgep.  Since it is not
; defined in the ACL2 sources, we just use its expansion below.

  (defthm doppelganger-badge-userfn-type
    (or
     (null (doppelganger-badge-userfn fn))
     (let ((x (doppelganger-badge-userfn fn)))
       (and (weak-apply$-badge-p x)
            (natp (access apply$-badge x :arity))
            (natp (access apply$-badge x :out-arity))
            (or (eq (access apply$-badge x :ilks) t)
                (and (true-listp (access apply$-badge x :ilks))
                     (equal (len (access apply$-badge x :ilks))
                            (access apply$-badge x :arity))
                     (not (all-nils (access apply$-badge x :ilks)))
                     (subsetp (access apply$-badge x :ilks)
                              '(nil :fn :expr)))))))

; If badge-userfn has the requirement that it is nil on the built-ins, then you
; need to conjoin the following to what's above.  See the Note on Strengthening
; the Constraint in badge-userfn-type found in constraints.lisp for a
; discussion of why we might want to strengthen this constraint.  But you can't
; do it in ACL2(a) because the function apply$-primp and the constant
; *apply$-boot-fns-badge-alist*, used in the constraint below, are not in the
; ACL2 sources and so aren't in the logic at the time we build ACL2.

;         (implies (or (apply$-primp fn)
;                      (assoc-eq fn *apply$-boot-fns-badge-alist*))
;                  (equal (doppelganger-badge-userfn fn) nil))

    :rule-classes nil))

#+acl2-loop-only
(partial-encapsulate
  (((doppelganger-apply$-userfn * *) => *))
  nil ; not the true supporters (see the Essay on Memoization with Attachments)
  (logic)
  (local (defun doppelganger-apply$-userfn (fn args)
           (declare (xargs :mode :logic))
           (declare (ignore fn args))
           nil))
  (defthm doppelganger-apply$-userfn-takes-arity-args
    (implies
     (doppelganger-badge-userfn fn)
     (equal (doppelganger-apply$-userfn fn args)
            (doppelganger-apply$-userfn
             fn
             (take (caddr (doppelganger-badge-userfn fn))
                   args))))
    :rule-classes nil))

(defmacro apply$-lambda-logical (fn args)

; This macro is called in apply-raw.lisp, so we put it here since the more
; natural location, apply.lisp, is too late (see *acl2-files*).

  (declare (xargs :guard ; avoid re-evaluation
                  (symbolp fn)))
  `(ev$ (lambda-object-body ,fn)
        (ec-call
         (pairlis$ (lambda-object-formals ,fn)
                   ,args))))

(defmacro our-quote-macro (x)

; This odd little macro is just an alias for quote, which add-trip uses to
; communicate information to install-for-add-trip (as described in comments in
; those functions).

  (list 'quote x))

(defun value-triple-fn1 (form check stobjs-out0 ctx state)
  (declare (xargs :guard t))
  (er-let* ((stobjs-out0 (value (or stobjs-out0 '(nil))))
            (stobjs-out/replaced-val
             (cond ((equal stobjs-out0 '(nil)) ; take efficiency short-cut
                    (cond ((or (eq form t)
                               (eq form nil)
                               (keywordp form))
                           (mv nil `((nil) . ,form) state))
                          ((and (consp form)
                                (eq (car form) 'QUOTE)
                                (consp (cdr form))
                                (null (cddr form)))

; We avoid quotep just above since we do not want to include the case that form
; is ill-formed, as in (QUOTE x . y) where y is not nil.

                           (mv nil `((nil) . ,(cadr form)) state))
                          (t (trans-eval `(value ,form) ctx state t))))
                   (t ; no warning when stobjs-out is explicit

; We ensure that the state is protected from inappropriate changes, much as
; we do in protected-eval.  If you change this protection below, consider
; whether corresponding changes should be made to protected-eval.

                    (revert-world
                     (state-global-let*
                      ((ttags-allowed nil))
                      (protect-system-state-globals
                       (if (eq stobjs-out0 :auto)

; We could use trans-eval-default-warning here, as we do during make-event
; expansion (as explained in protected-eval).  But by default, that is
; trans-eval-no-warning.  We view the use of :auto as a way to ask for the
; warning when user stobjs are modified.

                           (trans-eval form ctx state t)
                         (trans-eval-no-warning form ctx state t)))))))))
    (let* ((stobjs-out (car stobjs-out/replaced-val))
           (replaced-val (cdr stobjs-out/replaced-val))
           (error-triple-p (equal stobjs-out *error-triple-sig*))
           (error-triple-p+ (or error-triple-p
                                (equal stobjs-out *error-triple-df-sig*)))
           (val0 (cond (error-triple-p+
                        (cadr replaced-val))
                       ((cdr stobjs-out)
                        (car replaced-val))
                       (t
                        replaced-val))))
      (cond
       ((not (or (eq stobjs-out0 :auto)
                 (equal stobjs-out stobjs-out0)
                 (and (equal stobjs-out0 '(nil))
                      error-triple-p)))
        (flet ((output-msg (stobjs-out)
                           (cond
                            ((equal stobjs-out '(nil))
                             "an ordinary (non-stobj, non-df) value")
                            ((null (cdr stobjs-out))
                             (cond ((eq (car stobjs-out) :df)
                                    "a single :DF value")
                                   (t
                                    (msg "a single stobj value, ~x0"
                                         (car stobjs-out)))))
                            (t
                             (msg "multiple values of shape ~x0"
                                  (cons 'mv stobjs-out))))))
          (er soft ctx
              "Expected ~@0, but got ~@1.~@2"
              (output-msg stobjs-out0)
              (if (and (equal stobjs-out0 '(nil))
                       (= (length stobjs-out) 3)
                       (eq (caddr stobjs-out) 'state))
                  (output-msg (list (cadr stobjs-out)))
                (output-msg stobjs-out))

; Report modified user stobjs even if stobjs-out is not :auto, since warnings
; may have been turned off and also to emphasize that the changes occurred in
; spite of there being an error.

              (let ((stobjs (if (equal stobjs-out0 '(nil))

; In this common case, we avoid reporting that state may have changed during
; evaluation of form, because we know it hasn't!

                                nil
                              (collect-non-nil-df stobjs-out))))
                (cond ((null stobjs) "")
                      (t (msg "  Note that in spite of the error, evaluation ~
                               may have modified the stobj~#0~[~/s~] ~&0."
                              stobjs)))))))
       ((and error-triple-p+ (car replaced-val))
        (er soft ctx
            "Evaluation failed: Result was of the form (mv t _ state).  See ~
             :DOC error-triple."
            (car replaced-val)))
       (check (cond ((and (car stobjs-out)
                          (not (eq (car stobjs-out) :df)))
                     (er soft ctx
                         "Ill-formed assertion: The~@0 value returned is ~@1."
                         (if (cdr stobjs-out) " first" "")
                         (if (eq (car stobjs-out) 'state)
                             "the ACL2 state"
                           (msg "the stobj, ~x0"
                                (car stobjs-out)))))
                    (val0 (value :passed))
                    ((tilde-@p check)
                     (er soft ctx
                         "Assertion failed:~%~@0~|"
                         check))
                    (t
                     (er soft ctx
                         "Assertion failed on form:~%~x0~|"
                         form))))
       ((and (car stobjs-out)
             (not (eq (car stobjs-out) :df)))
        (value (car stobjs-out)))
       (t (value val0))))))

(defun chk-value-triple (on-skip-proofs check safe-mode stobjs-out ctx state)

; Warning: The checks in chk-value-triple should be at least as strong as the
; ones made here.

  (cond
   ((not (or (booleanp on-skip-proofs)
             (eq on-skip-proofs :interactive)))
    (er soft ctx
        "The value of keyword argument :ON-SKIP-PROOFS must be Boolean or ~
         :INTERACTIVE, but ~x0 is not."
        on-skip-proofs))
   ((not (or (booleanp check)
             (msgp check)))
    (er soft ctx
        "The value of keyword argument :CHECK must be Boolean or satisfy the ~
         predicate msgp.  The value ~x0 is thus illegal."
        check))
   ((not (or (booleanp safe-mode)
             (eq safe-mode :same)))
    (er soft ctx
        "The value of keyword argument :SAFE-MODE must be Boolean, but ~x0 is ~
         not."
        safe-mode))
   ((not (or (eq stobjs-out :auto)
             (symbol-listp stobjs-out)))
    (er soft ctx
        "The value of keyword argument :STOBJS-OUT must either be :AUTO or ~
         satisfy symbol-listp.  The value ~x0 is thus illegal."
        stobjs-out))
   (t (value nil))))

(defun value-triple-fn (form on-skip-proofs check safe-mode stobjs-out ctx
                             state)
  (declare (xargs :guard t))
  (er-progn
   (chk-value-triple on-skip-proofs check safe-mode stobjs-out ctx state)
   (cond
    ((and (not on-skip-proofs)
          (f-get-global 'ld-skip-proofsp state))
     (value :skipped))
    ((and (eq on-skip-proofs :interactive)
          (eq (f-get-global 'ld-skip-proofsp state) 'include-book))
     (value :skipped))
    ((or (eq safe-mode :same)
         (eq safe-mode (f-get-global 'safe-mode state)))
     (value-triple-fn1 form check stobjs-out ctx state))
    (t
     (state-global-let*
      ((safe-mode (if safe-mode t nil)))
      (value-triple-fn1 form check stobjs-out ctx state))))))

; Essay on Memoization with Partial Functions (Memoize-partial)

; A common trick is to admit a recursively-defined function by adding a
; stack-depth argument.  Traditionally that argument often is called a "clock"
; but we will call it a "limit".  It seems unlikely that this additional
; argument significantly impacts performance, with one exception: it may
; severely limit the value of memoization, because the limit argument might not
; match a saved call that otherwise matches the current call.

; We use a motivating example, with explanation following below.  A slight
; variant of this example, as well as other examples, may be found in community
; book books/system/tests/memoize-partial.lisp.

;   (defun fib-limit (n limit)
;     (declare (type (integer 0 *) limit))
;     (declare (xargs :guard (integerp n)
;                     :measure (nfix limit)))
;     (if (zp limit)
;         0 ; base case; any term is fine here
;       (let ((limit (1- limit)))
;         (if (or (= n 0) (= n 1))
;             1
;           (+ (fib-limit (- n 1) limit)
;              (fib-limit (- n 2) limit))))))

;   (defchoose fib-limit-change (large) (n limit)
;     (and (natp large)
;          (<= limit large)
;          (not (equal (fib-limit n limit)
;                      (fib-limit n large)))))

;   (defchoose fib-limit-stable (limit) (n)
;     (and (natp limit)
;          (equal (fib-limit n limit)
;                 (fib-limit n (fib-limit-change n limit)))))

;   (defun fib (n)
;     (declare (xargs :guard (let ((limit 0))
;                              (declare (ignorable limitbound))
;                              (integerp n))))
;     (fib n (fib-limit-stable n)))

; Then when we evaluate

;   (memoize-partial fib)

; we actually memoize with the call below of memoize-fn under the hood.  That
; will happen automatically, but here we do it manually.

;   :q

;   (MEMOIZE-FN
;    'FIB
;    :CONDITION T
;    :INLINE T
;    :CL-DEFUN '(defun fib (n)
;                 (flet ((fib-limit (n limit)
;                                   (declare (ignore limit))
;                                   (fib n)))
;                   (declare (inline fib-limit))
;                   (let ((limit 0))
;                     (declare (ignorable limit))
;                     (if (or (= n 0) (= n 1))
;                         1
;                       (+ (fib-limit (- n 1) limit)
;                          (fib-limit (- n 2) limit))))))
;    :FORMALS '(N)
;    :STOBJS-IN '(NIL)
;    :STOBJS-OUT '(NIL)
;    :COMMUTATIVE NIL
;    :FORGET NIL
;    :MEMO-TABLE-INIT-SIZE 60
;    :AOKP NIL)
;
;   (lp)

; That works:

;   ACL2 !>(time$ (fib 100))
;   ; (EV-REC *RETURN-LAST-ARG3* ...) took
;   ; 0.00 seconds realtime, 0.00 seconds runtime
;   ; (7,648 bytes allocated).
;   573147844013817084101
;   ACL2 !>(time$ (fib 100))
;   ; (EV-REC *RETURN-LAST-ARG3* ...) took
;   ; 0.00 seconds realtime, 0.00 seconds runtime
;   ; (16 bytes allocated).
;   573147844013817084101
;   ACL2 !>

; We have measured an increase of 14% by using flet in the definition of fib
; when evaluating (time (fib 38)), rather than just recurring directly with
; fib.  (The increase was 52% without the inline declaration.  And of course,
; the time is negligible is we submit the memoize-fn form above rather than
; just the defun that is inside it.)  But the use of flet supports the theory
; below, in particular the correspondence between macroexpansions of the
; original body and the body of the :CL-DEFUN argument (see above).  So it
; seems best to live with that inefficiency rather than to eliminate flet (by
; essentially expanding it away).  Moreover, it seems plausible that there will
; typically be significantly more computation per call than with the example
; above (the recursive fib function), in which case the percentage penalty may
; drop substantially.

; We now provide theory to justify the approach outlined above, ignoring
; details that we do not consider important to discuss here.  In particular we
; ignore here the straightforward extension of this theory to mutual-recursion.

; Consider a guard-verified function f0-limit that is defined as follows, where
; <base> is arbitrary.  Here we require that in the translation of <body>, the
; occurrences of limit are exactly as the final parameter in each recursive
; call.

;   (defun f0-limit (x1 ... xk limit)
;     (declare ...)
;     (if (zp limit) <base> (let ((limit (1- limit))) <body>)))

; The restriction can probably be relaxed somewhat, for example to allow
; subtracting a number larger than 1.  But we expect this form to be convenient
; in practice, hence sufficient to support.  (We could quite possibly support
; the variants zpf and 1-f of zp and 1-, respectively; if so we should think
; through guard issues.)  The restriction of limit to the final parameter of
; each recursive call is reminiscent of the test for irrelevant formals,
; although the present requirement is much simpler and also sufficient here.

; Now consider the following raw Lisp definition, which is based entirely on
; the definition of f0-limit above, not on its translated body.

;   (defun f1 (x1 ... xk)
;     (flet ((f0-limit (x1 ... xk limit)
;                      (declare (ignore limit))
;                      (f1 x1 ... xk)))
;       (let ((limit 0))
;            (declare (ignorable limit))
;            <body>)))

; Below, we discuss notions "well-guarded call" and "well-guarded evaluation"
; in raw Lisp.  These are evaluations where every function call is made on
; arguments in its intended domain, as guaranteed by evaluation of ACL2 terms
; involving only guard-verified functions applied (at the top level) to
; arguments satisfying their guards.  Of course, a key claim about ACL2 is that
; error-free evaluation with only guard-verified functions is always
; well-guarded evaluation.  Note that the assumption of well-guarded can be
; necessary since some ACL2 functions behave differently when their guard is
; false; consider for example (zpf -1).  When dealing with :logic mode
; functions, the raw Lisp versions of function definitions are only invoked in
; well-guarded code; recall that evaluation always starts with *1* functions,
; which only call corresponding raw Lisp functions when guards hold.

; We argue below for the following

;   Key Claim.

;   If a well-guarded call of (f1 a1 ... ak) in raw Lisp terminates with result
;   R, then there is a natural number L such that when we form a corresponding
;   call (f0-limit a1 ... ak M) with any integer M >= L, the Lisp evaluation
;   result is also R.

; Fix a1, ..., ak, and suppose that (f1 a1 ... ak) evaluates in raw Lisp to a
; result R.  Pick L as provided by the Key Claim.  Then for every integer M we
; see that the following is a theorem, by appealing to a property that is
; already used in the ACL2 prover: the correctness of raw Lisp evaluation for
; ACL2 ground terms.

;  (a)  (implies (<= 'L 'M)
;                (equal (f0-limit 'a1 ... 'ak 'M)
;                       'R)).

; Now define (f0 x1 ... xk) to be the limit (if there is one) of (f0-limit x1
; ... xk L) for natural numbers L, defined in ACL2 in analogy to how fib is
; defined in terms of fib-limit in the example above.  (The guard on f0 will
; bind limit to 0 in the guard on f0-limit, as in that example, and a moment's
; thought should be convincing that this guard is sufficient for guard
; verification when the guard on f0 allows limit to be any natp; we say no more
; about that here.)  Note that since we do not intend to execute f0, we do not
; need its body to be guard-verifiable (which justifies the use of defun-nx, as
; we do when there are stobj inputs) -- all that matters are the logical
; definition of f0 and well-guardedness for the executable definition that we
; install.

; By (a), every instance of the following formula is a theorem.

;  (b) (implies (and (natp limit)
;                    (<= 'L limit))
;               (equal (f0-limit 'a1 ... 'ak limit)
;                      'R))

; But considering how f0 is defined in terms of f0-limit (by way of defchoose
; events), we need for (b) to be a theorem.  Is it?  That question brings us to
; a subtle point: provability of a property for each instance does not imply
; that the universal closure of the property is provable.  In our specific
; instance, we have seen that (equal (f0-limit 'a1 ... 'ak limit) 'R) is
; provable when limit is (the quotation of) L, or L+1, or L+2, or L+3, and so
; on.  However, that alone does not imply provability of the theorem that this
; equality holds for all values of limit >= L.  (Logicians would say that to
; make that deduction, one needs to apply the omega-rule, which is not a
; first-order rule of inference.  Informally, they might say that we haven't
; proved that the equality holds for non-standard values of limit.)

; We can address this subtle issue by considering the following definitions, as
; illustrated in community book books/system/bigger-limits.lisp.  Here, (lim)
; is introduced as a constrained zero-ary function that returns an arbitrary
; natural number, and fib-limit2 is defined in complete analogy with fib-limit,
; except that the "base case" for fib-limit2 says to continue with fib-limit.

;   (encapsulate
;     ((lim () t))
;     (local (defun lim () 0))
;     (defthm natp-lim
;       (natp (lim))
;       :rule-classes :type-prescription))
;
;   (defun fib-limit2 (n limit)
;     (declare (type (integer 0 *) limit))
;     (declare (xargs :guard (integerp n)
;                     :measure (nfix limit)))
;     (if (zp limit)
;         (fib-limit n (lim)) ; base case
;       (let ((limit (1- limit)))
;         (if (or (= n 0) (= n 1))
;             1
;           (+ (fib-limit2 (- n 1) limit)
;              (fib-limit2 (- n 2) limit))))))

; Our argument below for the Key Claim is agnostic about the base case, (zp
; limit).  To be concrete, suppose f0-limit is fib-limit and f1 is the raw Lisp
; definition supplied to memoize-fn, above.  Then just as (equal (fib-limit 'a1
; ... 'ak 'L) 'R) is provable, so is (equal (fib-limit2 'a1 ... 'ak 'L) 'R).
; But we can prove the following.

;   (implies (and (natp limit)
;                 (natp n))
;            (equal (fib-limit2 n limit)
;                   (fib-limit n (+ limit (lim)))))

; By functional instantiation of lim with (lambda () (nfix lim)), we see
; that the following is a theorem.

;   (implies (natp lim)
;            (equal (fib-limit n (+ L lim))
;                   R))

; That immediately implies provability of the formula of interest.

;   (implies (and (natp limit)
;                 (<= L limit))
;            (equal (fib-limit n limit)
;                   R))

; It remains to argue for the Key Claim.  Suppose that a well-guarded call (f1
; a1 ... ak) in raw Lisp terminates with result R.  We argue for the conclusion
; of the Key Claim by strong induction on the length of the computation of the
; call of f1.  By definition of f1, evaluation of (f1 a1 ... ak) leads to
; evaluation of <body> where each formal xi is bound to ai, limit is bound to
; 0, and the function symbol f0-limit is bound (as a function symbol) to
; (lambda (x1 ... xk limit) (f1 x1 ... xk)).  Similarly, a corresponding call
; (f0-limit a1 ... ak L), where L is a positive integer, leads to an evaluation
; of <body> with limit bound to (1- limit) and without rebinding f0-limit.  It
; suffices to observe that these two evaluations proceed in lockstep, giving
; the same results along the way, for sufficiently large L.  This observation
; follows from the inductive hypothesis, provided we do not encounter
; evaluation of limit except in the latter case as the final parameter of each
; call of f0-limit.  These properties are stated in the following Proposition,
; whose truth we assert as fundamental to our use of Common Lisp in evaluating
; ACL2 forms.

; Proposition.

;   Consider well-guarded Common Lisp evaluation of an ACL2 term.  Let limit be
;   an ACL2 variable and suppose that every occurrence of limit in the ACL2
;   translation of that term is in the last argument of calls of a specific
;   function, f, where the last argument is indeed always limit.  Then the
;   evaluation process never encounters a free occurrence of limit, except as
;   the last argument of a call of f that is encountered during evaluation.
;   (By "encountered" we mean in the usual sense for Common Lisp EVAL, which
;   does not include diving into recursive calls, but rather uses APPLY on each
;   of them.)

; The precondition is about translated code, and is something we easily check.
; This proposition relies on the ACL2 variable (called "limit" above) not being
; introduced by Common Lisp macroexpansion.  We imagine, for example, that the
; symbol CHAR-CODE-LIMIT might be introduced by Common Lisp macroexpansion.
; But we expect any such symbol either to be fresh (courtesy of gensym,
; gentemp, or the like) or else to belong to the list value of the ACL2
; constant, *common-lisp-specials-and-constants*, and ACL2 does not allow such
; symbols to be ACL2 variables.

; We conclude with remarks on our high-level design for memoizing with a
; partial function.  We preferred to minimize disruption to existing
; memoization code.  In particular, memoization using partial functions is
; accomplished in raw Lisp simply by modifying the call to memoize-fn to use
; the desired executable partial function.  At the event level, memoization
; events are unchanged except to take an additional argument, :total.  This is
; a bit of a challenge for the mutual-recursion case, however, since in general
; one needs to memoize each functions in the nest in order to get
; executability, yet the precondition for each such function involves all
; functions in the nest.  Therefore it is natural to separate out a table event
; (using a new table, partial-functions-table) that stores all the information
; needed for each such memoization.  By storing all that information on a
; single key (namely, the function symbol introduced by the first definition in
; the mutual-recursion), we need only do all the accompanying checks once,
; i.e., when storing the value for that key.  We do those checks in the table
; guard, partial-functions-table-guard.  The user-level macro memoize-partial
; is provided as a user convenience, to avoid the need to modify the
; partial-functions-table directly.

; Perhaps in the future we will install the executable partial functions at the
; time the partial-functions-table is updated, rather than waiting for memoize
; events.  It might be reasonable to implement this by modifying table-cltl-cmd
; to generate defuns tuples for partial-functions-table, but we would need to
; be careful not to install new *1* functions.

; Other possible future work may include loosening the syntactic restrictions,
; for example so that the popular DEFINE macro can be used for the :total (i.e
; limited, clocked) function without the need to specify :no-function t.  There
; could also be tweaks to the user interface, for example to make the output of
; memoize-partial less verbose or to improve the error message when the limit
; variable isn't the last formal (or, relax that restriction).

(defun collect-non-redundant (events wrld)

; We check that each event E in events is stored as the 'event property in
; (cadr E).  We return the list of all E in events that do not have that
; property.

  (cond ((endp events) nil)
        ((and (true-listp (car events))
              (symbolp (cadr (car events)))
              (equal (get-event (cadr (car events)) wrld)
                     (car events)))
         (collect-non-redundant (cdr events) wrld))
        (t (cons (car events)
                 (collect-non-redundant (cdr events) wrld)))))

(defun remove-var-from-type-dcls (var type-dcls)

; Var is a variable, and type-dcls is a list of legal type declarations with
; the leading TYPE stripped off.  We remove var from each member of type-dcls
; and return the list of non-empty results.

  (cond ((endp type-dcls) nil)
        (t
         (let* ((d (car type-dcls))
                (tp (car d))
                (vars (remove-eq var (cdr d))))
           (cond ((null vars)
                  (remove-var-from-type-dcls var (cdr type-dcls)))
                 (t
                  (cons `(type ,tp ,@vars)
                        (remove-var-from-type-dcls var (cdr type-dcls)))))))))

(defun memoize-partial-def (fn fn-limit fn-limit-formals flet-bindings wrld)

; Fn is a function to be defined nonconstructively without a limit (clock) from
; a limited version, fn-limit (with formals fn-limit-formals), which is to be
; supplied in the :total argument of a memoize call on fn.  Flet bindings is
; passed in as appropriate; see the Essay on Memoization with Partial Functions
; (Memoize-partial).

; Note that the checks here are far from sufficient to allow memoization of fn
; with :total fn-limit.  Additional checks are made before putting this
; definition into the partial-functions-table, made by its table guard,
; partial-functions-table-guard.

  (cond
   ((member-eq 'state fn-limit-formals)
    :state)
   ((collect-user-stobjs (stobjs-out fn-limit wrld))

; This will lead to an error, so we don't mind calling collect-user-stobjs a
; second time here.

    (cons :stobjs (collect-user-stobjs (stobjs-out fn-limit wrld))))
   (t (let* ((ev (cltl-def-from-name fn-limit wrld))
             (limit (assert$ (consp fn-limit-formals)
                             (car (last fn-limit-formals))))
             (def
              (case-match ev
                (('DEFUN !fn-limit !fn-limit-formals . &)
                 (cdr ev))
                (('MUTUAL-RECURSION . defs)
                 (let* ((def (assoc-eq fn-limit (strip-cdrs defs))))
                   (and (equal (cadr def) fn-limit-formals)
                        def)))
                (& nil))))
        (cond
         ((null def) :definition-not-found)
         (t
          (let* ((fn-limit-body (car (last ev)))
                 (rest
                  (case-match fn-limit-body
                    (('IF ('ZP !limit)
                          &
                          ('LET ((!limit ('1- !limit)))
                                . rest))
                     rest)
                    (('COND (('ZP !limit)
                             &)
                            (t ('LET ((!limit ('1- !limit)))
                                     . rest)))
                     rest)

; We do not support other macros because we have not (yet?) convinced ourselves
; of sufficient similarity in their behaviors in Common Lisp and ACL2 (which
; seems important; see the Essay mentioned above).

                    (& nil))))
            (and rest
                 (let* ((fn-formals (butlast fn-limit-formals 1))
                        (body (car (last rest)))
                        (dcls (butlast (cddr def) 1))
                        (type-dcls (remove-var-from-type-dcls
                                    limit
                                    (fetch-dcl-field 'type dcls))))
                   `(defun ,fn ,fn-formals

; We are confident about this definition, so rather than recover the ignore and
; ignorable declarations, we simply declare all formals to be ignorable.

                      (declare (ignorable ,@fn-formals))
                      ,@(and type-dcls `((declare ,@type-dcls)))
                      (flet ,flet-bindings
                        (declare (inline ,fn-limit))
                        (let ((,limit 0))
                          (declare (ignorable ,limit))
                          ,body))))))))))))

(defun memoize-partial-declare (fn-limit limit wrld)

; We compute the declare form for the non-constructive function, fn (see
; memoize-partial-supporting-events), to be memoized on behalf of fn-limit.
; Thus, fn-limit is to be the :total argument of a call (memoize 'fn ...), and
; at a higher level, a tuple (fn fn-limit ...) may be in the list of tuples
; supplied to memoize-partial.

  (let* ((ev (get-event fn-limit wrld))
         (def
          (case-match ev
            (('DEFUN !fn-limit . &)
             (cdr ev))
            (('MUTUAL-RECURSION . defs)
             (assoc-eq fn-limit (strip-cdrs defs)))
            (& (er hard 'memoize-partial-declare
                   "Implementation error: Unable to find event for the ~
                    alleged function, ~x0"
                   fn-limit))))
         (dcls (butlast (cddr def) 1))
         (type-lst (remove-var-from-type-dcls limit
                                              (fetch-dcl-field 'type dcls)))
         (guard (conjoin-untranslated-terms (fetch-dcl-field :guard dcls)))
         (split-types-lst (fetch-dcl-field :split-types dcls))
         (guard-simplify-lst (fetch-dcl-field :guard-simplify dcls)))
    `(declare ,@type-lst
              (xargs :guard ,(if (eq guard t)
                                 t
                               `(let ((,limit 0))
                                  (declare (ignorable ,limit))
                                  ,guard))
                     ,@(and split-types-lst
                            (pairlis-x1 :split-types split-types-lst))
                     ,@(and guard-simplify-lst
                            (pairlis-x1 :guard-simplify
                                        guard-simplify-lst))))))

(defun memoize-partial-supporting-events-1 (fn fn-limit fn-limit-change
                                               fn-limit-stable flet-bindings
                                               wrld)

; Fn is a function to be defined nonconstructively without a limit (clock) from
; a limited version, fn-limit, which is to be the :total argument of a
; memoization of fn.  Here we return events to introduce fn.

; We return (mv nil events tuple) upon success, where events are the desired
; definitions and tuple will be used in the resulting memoize-partial call.  On
; failure we return (mv msg nil nil), where msg is a message explaining the
; failure.

; Note that the checks here are far from sufficient to allow memoization of fn
; with :total fn-limit.  Additional checks are made in the table guard for
; partial-functions-table, partial-functions-table-guard.

  (let* ((fn-limit-formals (formals fn-limit wrld))
         (def (memoize-partial-def fn fn-limit fn-limit-formals flet-bindings
                                   wrld)))
    (cond
     ((eq def :definition-not-found)

; This is surprising, since by this point, partial-functions-table-guard-msg
; has already checked that each function fn-limit being passed into the present
; function is a member of the 'recursivep property of some function.

      (mv (msg "Implementation error: Unable to find the definition of ~x0."
               fn-limit)
          nil nil))
     ((eq def :state)
      (mv (msg "STATE is among the formals of ~x0, which is illegal for ~
                memoization."
               fn-limit)
          nil nil))
     ((eq (car def) :stobjs)
      (mv (msg "The stobj~#0~[ ~&0 is~/s ~&0 are~] returned by ~x1, which is ~
                illegal for memoization."
               (cdr def)
               fn-limit)
          nil nil))
     ((null def) ; same as (atom def)
      (mv (msg "The (untranslated) body of function ~x0 is not of the ~
                appropriate form."
               fn-limit)
          nil nil))
     (t
      (let* ((limit (assert$ (consp fn-limit-formals)
                             (car (last fn-limit-formals))))
             (fn-formals (butlast fn-limit-formals 1))
             (large (genvar limit "LARGE" nil fn-limit-formals)))
        (mv nil
            `((defchoose ,fn-limit-change (,large) ,fn-limit-formals
                (and (natp ,large)
                     (<= ,limit ,large)
                     (not (equal (,fn-limit ,@fn-limit-formals)
                                 (,fn-limit ,@fn-formals ,large)))))

              (defchoose ,fn-limit-stable (,limit) ,fn-formals
                (and (natp ,limit)
                     (equal (,fn-limit ,@fn-limit-formals)
                            (,fn-limit
                             ,@fn-formals
                             (,fn-limit-change ,@fn-limit-formals)))))
              ,(let* ((stobjs-in (stobjs-in fn-limit wrld))
                      (stobjs (collect-user-stobjs stobjs-in)))
                 `(defun ,fn ,fn-formals
                    ,(memoize-partial-declare fn-limit limit wrld)
                    ,@(and stobjs
                           `((declare (xargs :stobjs ,@stobjs))))

; We need non-exec when there is at least one stobj or df among fn-formals.
; Since calls of fn-limit-stable cannot be executed, it seems harmless to use
; non-exec in all cases.  We put non-exec only where it is needed rather than
; around the entire body, so as to obtain the expected output signature.

                    (,fn-limit ,@fn-formals
                               (nfix (non-exec
                                      (,fn-limit-stable ,@fn-formals)))))))
            `(,fn ,fn-limit ,fn-limit-change ,fn-limit-stable ,def)))))))

(defun memoize-partial-supporting-events-rec (tuples flet-bindings wrld msg
                                                     defs table-tuples)

; Each element of tuples is of the form (fn fn-limit fn-limit-change
; fn-limit-stable . memoize-args), as returned by memoize-partial-tuples.
; The final three arguments are all nil at the top level.

  (cond ((endp tuples)
         (mv (and msg
                  (msg "~|~@0~|See :DOC memoize-partial.~|" msg))
             (reverse defs)
             (let* ((val (reverse table-tuples))
                    (key (cadr (car val))))
               `(table partial-functions-table ',key
                       (put-assoc-eq-alist
                        (cdr (assoc-eq ',key
                                       (table-alist 'partial-functions-table
                                                    world)))
                        ',val)))))
        (t (mv-let (msg1 defs1 table-tuple)
              (let ((tuple (car tuples)))
                (memoize-partial-supporting-events-1
                 (car tuple) (cadr tuple) (caddr tuple) (cadddr tuple)
                 flet-bindings wrld))
             (memoize-partial-supporting-events-rec
              (cdr tuples) flet-bindings wrld
              (cond (msg1 (cond (msg (msg "~@0~|~@1" msg msg1))
                                (t msg1)))
                    (t msg))
              (revappend defs1 defs)
              (cons table-tuple table-tuples))))))

(defun flet-bindings (tuples wrld)
  (cond ((endp tuples) nil)
        (t (cons (let* ((tuple (car tuples))
                        (fn (car tuple))
                        (fn-limit (cadr tuple))
                        (fn-limit-formals (formals fn-limit wrld))
                        (limit (car (last fn-limit-formals)))
                        (fn-formals (butlast fn-limit-formals 1)))
                   `(,fn-limit ,fn-limit-formals
                               (declare (ignore ,limit))
                               (,fn ,@fn-formals)))
                 (flet-bindings (cdr tuples) wrld)))))

(defun memoize-partial-supporting-events (tuples wrld)
  (memoize-partial-supporting-events-rec
   tuples
   (flet-bindings tuples wrld)
   wrld nil nil nil))

(defun memoize-partial-tuple-shape-p (lst)
  (declare (xargs :guard t))
  (cond ((atom lst) (null lst))
        (t (let ((tuple (car lst)))
             (and (symbolp (car tuple))
                  (symbolp (cadr tuple))
                  (symbolp (caddr tuple))
                  (symbolp (cadddr tuple))
                  (consp (cddddr tuple))
                  (null (cdr (cddddr tuple)))
                  (memoize-partial-tuple-shape-p (cdr lst)))))))

(defun memoize-partial-translations-msg-formals (fns limit fn0 wrld)
  (cond ((endp fns) nil)
        (t (let* ((fn (car fns))
                  (formals (formals fn wrld)))
             (cond
              ((null (cdr formals))
               (msg "The function symbol ~x0 must have at least two formal ~
                     parameters."
                    fn))
              ((eq (car (last formals)) limit)
               (memoize-partial-translations-msg-formals (cdr fns) limit fn0
                                                         wrld))
              (t
               (msg "The formal parameter lists for function symbols ~x0 and ~
                     ~x1 have different final elements (of ~x2 and ~x3, ~
                     respectively)."
                    fn0 fn limit (car (last formals)))))))))

(mutual-recursion

; For context, see the Essay on Memoization with Partial Functions
; (Memoize-partial), in particular the Proposition there.

(defun free-exactly-in-last-arg-of-calls (limit fns-limit term)
  (cond
   ((eq term limit)
    nil)
   ((or (variablep term)
        (fquotep term))
    t)
   ((flambdap (ffn-symb term))
    (let ((posn (position limit (lambda-formals (ffn-symb term))))
          (args (fargs term)))
      (and (free-exactly-in-last-arg-of-calls limit fns-limit
                                              (lambda-body (ffn-symb term)))
           (cond
            (posn

; We recognize terms
;   ((lambda (x0 x1 ... limit ... xk) body)
;    (t0 t1 ... limit ... tk))
; for which all occurrences of limit in each ti and in body are exactly as the
; last argument of a call of a function in fns-limit.  Evaluation then works as
; described in the Essay on Memoization with Partial Functions
; (Memoize-partial).

             (and (eq (nth posn args) limit)
                  (free-exactly-in-last-arg-of-calls-lst
                   limit fns-limit (take posn args) nil)
                  (free-exactly-in-last-arg-of-calls-lst
                   limit fns-limit (nthcdr (1+ posn) args) nil)))
            (t (free-exactly-in-last-arg-of-calls-lst limit fns-limit args
                                                      nil))))))
   (t (free-exactly-in-last-arg-of-calls-lst
       limit fns-limit (fargs term)
       (member-eq (ffn-symb term) fns-limit)))))

(defun free-exactly-in-last-arg-of-calls-lst (limit fns-limit args
                                                    last-is-limit)
  (cond
   ((endp args) t)
   ((and last-is-limit
         (endp (cdr args)))
    (eq (car args) limit))
   (t (and (free-exactly-in-last-arg-of-calls limit fns-limit (car args))
           (free-exactly-in-last-arg-of-calls-lst limit fns-limit (cdr args)
                                                  last-is-limit)))))
)

(defun memoize-partial-translations-msg-bodies (tail fns-limit limit wrld)

; The error cases below, except for the one about limit occurring free, will
; probably never occur, because such checks are already made on the
; untranslated bodies (see memoize-partial-supporting-events-1).  But we make
; them here anyhow, for extra confidence in the completeness of our checks.

  (cond
   ((endp tail) nil)
   (t
    (let* ((fn (car tail))
           (body (body fn nil wrld))
           (str "Unexpected form for translated body of ~x0"))
      (case-match body
        (('IF ('ZP !limit)
              &
              (('LAMBDA (!limit . vars) body)
               ('binary-+ ''-1 !limit)
               . vars))
         (declare (ignore vars))
         (if (free-exactly-in-last-arg-of-calls limit fns-limit body)
             (memoize-partial-translations-msg-bodies
              (cdr tail) fns-limit limit wrld)
           (msg "The limit variable ~x0 fails to occur free exactly where ~
                 expected in the body of the definition of function ~x1 ~
                 (essentially, as the last argument of each recursive call)."
                limit fn)))
        (& (msg "~@0 (must be of the form (IF (ZP LIMIT) & &))."
                (msg str fn))))))))

(defun memoize-partial-translations-msg (fns-limit wrld)

; Fns-limit is a non-empty list of function symbols that equals the 'recursivep
; property in wrld of the first member of the list; thus, this list represents
; exactly the set of functions introduced by a single mutual-recursion.  This
; function checks criteria from the Essay on Memoization with Partial Functions
; (Memoize-partial) about the translated bodies of the function symbols in
; fns-limit.

; If no problems are found then nil is returned.  Otherwise the return value is
; a suitable error message.

  (assert$
   (and (all-function-symbolps fns-limit wrld)
        (consp fns-limit))
   (let* ((fn (car fns-limit))
          (limit (car (last (formals fn wrld)))))
     (or (memoize-partial-translations-msg-formals
          fns-limit limit fn wrld)
         (memoize-partial-translations-msg-bodies
          fns-limit fns-limit limit wrld)))))

(defun partial-functions-table-guard-msg (key new-tuples/old-tuples wrld)

; Key is a "limit" ("clocked", "total") function, such as fib-limit in
; community books books/system/tests/memoize-partial.lisp.  See also the Essay
; on Memoization with Partial Functions (Memoize-partial).

  (declare (xargs :guard t))
  (let* ((old-tuples (cdr (assoc-eq key (table-alist 'partial-functions-table
                                                     wrld))))
         (len-old-tuples (len old-tuples))
         (len-new-tuples/old-tuples (len new-tuples/old-tuples))
         (len-new (- len-new-tuples/old-tuples len-old-tuples))
         (common-case (and (true-listp new-tuples/old-tuples)
                           (< len-old-tuples len-new-tuples/old-tuples)
                           (equal (nthcdr len-new new-tuples/old-tuples)
                                  old-tuples))))
    (cond
     ((not (and (symbolp key)
                (function-symbolp key wrld)))
      (msg "The key is not a known function symbol."))
     ((not (eq (symbol-class key wrld) :common-lisp-compliant))
      (msg "The key is a function symbol but it is not guard-verified."))
     ((null (cdr (formals key wrld)))
      (msg "The key is a guard-verified function symbol but it needs at least ~
            two formal parameters."))
     ((not (or common-case
               (subsetp-equal old-tuples
                              new-tuples/old-tuples)))
      (msg "The value is not an extension of the previous value."))
     (t (let ((new-tuples (if common-case
                              (take len-new new-tuples/old-tuples)
                            (set-difference-equal new-tuples/old-tuples
                                                  old-tuples))))
          (cond
           ((not (memoize-partial-tuple-shape-p new-tuples))
            (msg "The extension of the old value is not a list of 5-tuples ~
                  where each tuple consists of four symbols followed by one ~
                  more element."))
           (t
            (let ((fns-limit (strip-cadrs new-tuples))
                  (r (getpropc key 'recursivep nil wrld)))
              (cond
               ((not r)
                (msg "The key is a non-recursive function symbol."))
               ((not (equal fns-limit r))
                (cond ((cdr r)
                       (msg "The strip-cadrs of the proposed extension of the ~
                             old value is not the list of function symbols, ~
                             in order, defined by mutual-recursion with the ~
                             key.  That expected list of functions is ~x0."
                            r))
                      (t
                       (msg "The proposed extension of the old value is not a ~
                             one-element list containing the key."))))

; At this point, we know that key is a guard-verified function symbol whose
; 'recursivep property agrees with the function symbols in the cadr positions
; of the new-tuples -- hence they are also guard-verified.

               (t
                (mv-let (msg defs table-event)
                  (memoize-partial-supporting-events new-tuples wrld)
                  (declare (ignore table-event))
                  (or msg
                      (let ((bad-events (collect-non-redundant defs wrld)))
                        (cond
                         (bad-events
                          (msg "The following ~#0~[event is~/events are~] ~
                                missing:~|~%~*1"
                               bad-events
                               (list "" "~X*2~|~%" "~X*2~|~%" "~X*2~|~%"
                                     bad-events
                                     (cons #\2 nil))))
                         (t (memoize-partial-translations-msg
                             fns-limit wrld))))))))))))))))

(defun partial-functions-table-guard (fn val wrld)
  (let ((msg0 ; nil if fn/val is OK as a key/value pair, else a msg
         (partial-functions-table-guard-msg fn val wrld)))
    (cond
     (msg0 (mv nil
               (msg
                "Illegal partial-functions-table key and value (see :DOC ~
                 memoize-partial):~|key = ~y0value  = ~y1Reason:~%~@2~|~%"
                fn val msg0)))
     (t (mv t nil)))))

(table partial-functions-table nil nil
       :guard
       (partial-functions-table-guard key val world))

; Essay on the :INVOKE option of Memoize

; See the code and :DOC memoize for details about this option.  Here we discuss
; miscellaneous issues relevant to its design.

; The wide use of MBE has established the value of computing a call of a
; function symbol, f, by using a definition of f that differs from the logical
; definition of f.  The :INVOKE option of memoize provides such a capability
; that avoids the inconvenience of setting up the alternate definition at defun
; time.

; A typical invocation of memoize using :invoke is as follows.

; (memoize 'old-fn :invoke 'new-fn)

; The implementation searches the world for the proof obligations that justify
; this operation: equality of old-fn and new-fn, and (when not sufficiently
; trivial) implication of their guards.  We considered supporting a way for the
; user to specify the names of those theorems in the memoize command.  On a
; 2019-vintage MacBook Pro it took only 0.28 seconds to search the entire world
; (fruitlessly) for the former after including (a previous version of) system
; book top.lisp, which produced a world of length 5,633,256.  Moreover, we skip
; the checks during include-book and the second pass of encapsulate (see the
; call of skip-proofs-due-to-system in memoize-table-chk-invoke-msg), which is
; justified by the usual conservativity argument.  So we kept the interface
; simple, sparing users from specifying those theorems.  Note that memoize is
; not doing the proofs itself; if the table event were to invoke the prover, we
; would probably need to remove TABLE from the list of event types excluded
; under the comment, "Comment on irrelevance of skip-proofs", in install-event.
; That comment also serves to justify our decision to check for the necessary
; theorems in the world even when skipping proofs (unless the system is doing
; the skipping, in particular during include-book or the second pass of
; encapsulate).

; We considered allowing a new body in place of the new-fn:

; (memoize 'old-fn :invoke 'term).
;
; However, that would require complicating the implementation by computing the
; guard proof obligation for the term (which depends on state via the global
; enabled structure, by the way, because simplification of ground terms is
; baked into computing a guard), as well as ensuring that term is
; guard-verified; a new function would probably be defined whose body is term
; (but would we carry over declarations from the old function?).  Moreover,
; such a version is less general since it doesn't support recursion that could
; take place in the definition of new-fn.  Note that there needn't be any
; execution overhead for the new-fn approach if new-fn is defined with
; defun-inline.  User macros can take care of defining a variant that takes a
; term if need be; see use-io-pairs for an example of generating a function
; symbol that is very likely to be new.  So in summary, we only allow a
; function symbol for the value of :invoke.

; Here is the basic idea of how we redefine f in raw lisp in response to
; (memoize 'f :invoke 'g); see cltl-def-memoize-invoke for details.

; (defun f (x) <dcls> <f-body>)
; (defun g (x) (... (f ...) ...))
; ; Then redefine as follows.
; (defvar *g* nil) ; a gensym actually
; (defun f (x)
;   <dcls>
;   (if *g*
;       (funcall <old_symbol-function_of_f> x)
;     (let ((*g* t))
;       (g x))))

; It's tempting just to define (f x) to be (g x) if g doesn't call f.  But even
; then, we can't preclude returning to a call of f from g, perhaps due to
; attachments or other memoization with :invoke.  It seems safest for the
; redefinition of f to ensure that we don't re-enter g from f within a
; computation where g already passed control to f.

; We considered the following potential optimization, but as explained below,
; we rejected it.  The idea is to avoid testing *g* on every recursive call of
; f after we enter f via g; below, just one such test puts us into the labels
; form.  Of course, this alleged optimization has no purpose unless f calls
; itself, and we could check that directly using ffnnamep (or maybe, if we want
; to get fancy, a variant of ffnnamep-mod-mbe that uses :exec rather than
; :logic).

; (defun f (x)
;   (if *g*
;       (labels ((f (x)
;                   (if (consp x)
;                       (cons (list (car x)) (f (cdr x)))
;                     x)))
;               (f x))
;     (let ((*g* t))
;       (g x))))

; But actually, this change would probably provide no efficiency gain in CCL or
; SBCL, at least, since experiments show that recursive calls of f are actually
; calls of the old symbol-function for f, which would never lead to further
; testing of *g*.  (LispWorks, on the other hand, does seem to test *g*
; repeatedly.  We are hopeful that this doesn't present much slowdown.)  At any
; rate: as hinted at above, the use of labels wouldn't prevent calls of the
; global f from being made by way of other functions that might, in turn, be
; reached from f by way of attachments or other uses of :invoke.  To summarize:
; We have abandoned the labels idea above because it's unnecessary for (at
; least) CCL and SBCL and it's incomplete as a solution.

; We considered possible hypotheses for the equality of the old and invoked
; functions.  We briefly considered allowing the :condition argument as a
; hypothesis, but that makes no sense when :condition is nil, which is the
; default when :invoke is non-nil (and is probably the common case).  More
; tempting is to allow the guard of the old function as a hypothesis, since we
; expect that this guard will always hold during evaluation.  The problem is
; that the guard might not hold when the old function is called under a
; program-mode function call.  So for now, at least, we require an
; unconditional equality to be proved.  We might be tempted to consider
; allowing the guard hypothesis if that turns out to be important, but in that
; case we need some mechanism, perhaps based on invariant-risk or **1*-as-raw*
; (though we haven't thought this through), to keep function calls as *1*
; calls.  But then memoization wouldn't take effect, which would defeat the
; point of all this!  So we require the unconditional equality to hold.

; Note that :recursive has default nil in the (sole) case that :invoke is
; non-nil.  It is an error to specify :recursive t in that case, because
; that doesn't make sense.  Or does it?  Recall:

; (defun f (x)
;   <dcls>
;   (if *g*
;       (funcall <old_symbol-function_of_f> x)
;     (let ((*g* t))
;       (g x))))

; What if we want recursive calls of f to go through g?  (We don't, for the
; application to the use-io-pairs tool; but maybe there's a reason for someone
; to want this.)  There is serious danger of looping unless we are careful.  We
; choose to postpone further consideration of such a :recursive t argument
; unless and until there is a demonstrated need.

; For (memoize 'f :invoke 'g), must f and/or g be in logic mode and even
; guard-verified?  Well, they must in be logic mode, because otherwise the
; necessary equality theorem won't exist.  We further require g to be
; guard-verified; otherwise we can't trust that the guard of f is sufficient to
; ensure a well-guarded call of g.  Should we also require f to be
; guard-verified?  That doesn't seem necessary, since *1*f won't call f unless
; f is guard-verified, and *1*f doesn't call g.  Of course, there could be a
; program-mode wrapper for f.  But at that point we are subverting the guard
; check on f anyhow, so it's not really worse to subvert the guard check on g.

(defun memoize-invoke-equality-p (fn invoke term)
  (and (ffn-symb-p term 'equal)
       (let ((lhs (fargn term 1))
             (rhs (fargn term 2)))
         (and (if (ffn-symb-p lhs fn)
                  (ffn-symb-p rhs invoke)
                (if (ffn-symb-p lhs invoke)
                    (ffn-symb-p rhs fn)
                  nil))
              (all-variablep (fargs lhs))
              (equal (fargs lhs) (fargs rhs))
              (no-duplicatesp-eq (fargs lhs))))))

(defun memoize-invoke-equality-exists (fn invoke wrld-tail wrld)
  (cond ((null wrld-tail) nil)
        ((and (eq (cadr (car wrld-tail)) 'theorem)
              (memoize-invoke-equality-p fn invoke
                                         (cddr (car wrld-tail)))
; We do a final check in case redefinition has obliterated the theorem.
              (equal (getpropc (car (car wrld-tail)) 'theorem nil wrld)
                     (cddr (car wrld-tail))))
         t)
        (t (memoize-invoke-equality-exists fn invoke (cdr wrld-tail) wrld))))

(defun memoize-invoke-guard-implication-default-name (f g)
  (intern-in-package-of-symbol
   (concatenate 'string
                (symbol-name f) "-guard-implies-"
                (symbol-name g) "-guard")
   g))

(defun memoize-invoke-guard-implication-term (f g wrld)

; This function normally returns an implication: the guard of f implies the
; guard of g (stated in terms of the formals of f).  However, if that
; implication is trivial then this function may return nil.

  (let ((guard-g (guard g nil wrld)))
    (cond ((equal guard-g *t*) nil)
          (t (let ((guard-f (guard f nil wrld))
                   (guard-g (sublis-var (pairlis$ (formals g wrld)
                                                  (formals f wrld))
                                        guard-g)))
               (cond ((equal guard-f guard-g) nil)
                     ((if-tautologyp (fcons-term* 'if guard-f guard-g *t*))
                      nil)
                     (t (fcons-term* 'implies guard-f guard-g))))))))

(defmacro verify-guard-implication (f g &key hints otf-flg)
  `(make-event
    (let ((term (or (memoize-invoke-guard-implication-term ',f ',g (w state))
                    t))
          (name (memoize-invoke-guard-implication-default-name ',f ',g)))
      (list 'defthm name
            term
            ,@(and hints (list :hints (list 'quote hints)))
            ,@(and otf-flg (list :otf-flg (list 'quote otf-flg)))
            :rule-classes nil))))

(defun memoize-invoke-guard-thm-exists-1 (term wrld-tail wrld)
  (cond ((null wrld-tail) nil)
        ((and (eq (cadr (car wrld-tail)) 'theorem)
              (equal term (cddr (car wrld-tail)))
; We do a final check in case redefinition has obliterated the theorem.
              (equal (getpropc (car (car wrld-tail)) 'theorem nil wrld)
                     term))
         t)
        (t (memoize-invoke-guard-thm-exists-1 term (cdr wrld-tail) wrld))))

(defun memoize-invoke-guard-thm-exists (fn invoke wrld)
  (let ((term (memoize-invoke-guard-implication-term fn invoke wrld)))
    (if term
        (memoize-invoke-guard-thm-exists-1 term wrld wrld)
      t)))

(defun memoize-table-chk-invoke-msg (key invoke str wrld state)

; Invoke is the non-nil value of the :invoke keyword for a call of memoize on
; the given function symbol, key.  We return nil if these values are
; acceptable, and otherwise return a message to print.

  (cond
   ((not (and (symbolp invoke)
              (function-symbolp invoke wrld)
              (eq (symbol-class invoke wrld)
                  :common-lisp-compliant)))
    (msg "~@0The value of keyword :INVOKE, ~x1, is not a guard-verified ~
          function symbol."
         str invoke))
   ((untouchable-fn-p invoke wrld (f-get-global 'temp-touchable-fns state))
    (msg "~@0The value of keyword :INVOKE, ~x1, is an untouchable function ~
          symbol."
         str invoke))
   ((and (assoc-eq invoke *ttag-fns*)
         (not (ttag wrld)))
    (msg "~@0The value of keyword :INVOKE, ~x1, is a function symbol that ~
          cannot be called unless a trust tag is in effect.  See :DOC ~
          defttag.~@2"
         str
         invoke
         (or (cdr (assoc-eq invoke *ttag-fns*))
             "")))
   ((not (logicp key wrld))
    (msg "~@0When memoizing with memoize keyword :INVOKE, the memoized ~
          function must be in :logic mode, which ~x1 is not."
         str key))
   ((not (and (equal (stobjs-in key wrld) (stobjs-in invoke wrld))
              (not (member-eq key *stobjs-out-invalid*))
              (not (member-eq invoke *stobjs-out-invalid*))
              (equal (stobjs-out key wrld) (stobjs-out invoke wrld))))
    (msg "~@0The function to be memoized, ~x1, has a different signature from ~
          the function to be :INVOKEd, ~x2."
         str key invoke))
   ((skip-proofs-due-to-system state)

; By conservativity it is sound to skip the theorem checks (for equality and
; guard implication) when we are including a book or in the second pass of
; encapsulate.

    nil)
   (t (let ((eq-thm-p (memoize-invoke-equality-exists key invoke wrld wrld))
            (gd-thm-p (memoize-invoke-guard-thm-exists key invoke wrld)))
        (cond
         ((and eq-thm-p gd-thm-p) nil)
         (t (let* ((thm-formula
                    (and (not eq-thm-p)
                         `(defthm ,(intern-in-package-of-symbol
                                    (concatenate 'string
                                                 (symbol-name key)
                                                 "-is-"
                                                 (symbol-name invoke))
                                    invoke)
                            ,(let ((formals (formals key wrld)))
                               `(equal (,key ,@formals)
                                       (,invoke ,@formals)))
                            :rule-classes nil)))
                   (guard-thm-formula
                    (and (not gd-thm-p)
                         `(verify-guard-implication ,key ,invoke)))
                   (msg (cond (gd-thm-p
                               (msg "~x0" thm-formula))
                              (eq-thm-p
                               (msg "~x0" guard-thm-formula))
                              (t
                               (msg "~x0~|~%~x1"
                                    thm-formula
                                    guard-thm-formula)))))
              (msg "~@0The following event~#1~[~/s~] must be admitted ~
                    (possibly with differing name or macro) before memoizing ~
                    function ~x2 with :INVOKE value ~x3.  See :DOC ~
                    memoize.~|~%~@4"
                   str
                   (if (or eq-thm-p gd-thm-p) 0 1)
                   key invoke msg))))))))

(defun memoize-table-chk (key val wrld state)

; The usual table guard mechanism provides crude error messages when there is a
; violation.  We avoid that problem by causing a hard error.  We rely on the
; fact that illegal and hard-error return nil.

; The memoize-table maps :common-lisp-compliant function symbols (to be
; memoized or unmemoized) to nil (unmemoized) or to a non-empty alist that
; stores relevant information, such as the condition (see memoize-form).  The
; guard requirement then ensures that when we call the raw Lisp version of fn,
; then since the guard for fn must hold in that case, so does the guard for
; condition-fn.  The body of condition-fn can therefore be called in raw Lisp
; on the arguments of any call of fn made in raw Lisp from the ACL2
; read-eval-print loop.  This is important because the memoized function body
; includes code from the body of condition-fn.

  (let ((ctx '(table . memoize-table))
        (str "Illegal attempt to set memoize-table:  "))
    (cond
     ((not (symbolp key))
      (mv nil (msg "~@0The first argument of memoize must be a symbol, unlike ~
                    ~x1."
                   str key)))
     ((not (symbol-alistp val))
      (mv nil (msg "~@0Function symbol ~x1 must be associated with a ~
                    symbol-alistp, unlike ~x2."
                   str key val)))
     (t
      (let* ((memoize-table (table-alist 'memoize-table wrld))
             (key-formals (getpropc key 'formals t wrld))
             (key-class (symbol-class key wrld))
             (condition (and val (cdr (assoc-eq :condition-fn val))))
             (inline (and val (cdr (assoc-eq :inline val))))
             (aokp (and val (cdr (assoc-eq :aokp val))))
             (invoke (and val (cdr (assoc-eq :invoke val))))
             (total (and val (cdr (assoc-eq :total val))))
             (msg
              (cond
               ((eq key-formals t)
                (msg "~@0~x1 is not a function symbol."
                     str key))
               ((and (or condition (cdr (assoc-eq :inline val)))

; The preceding term says that we are not profiling.  Why not replace it simply
; with condition, allowing :inline t?  Perhaps we could, but that would require
; a bit of thought since memoization with :inline t will modify recursive
; calls, and we would need to be sure that this replacement doesn't violate
; syntactic restrictions.  We can think about this if someone has reason to
; memoize with :condition nil but not :inline nil.

                     (member-eq 'state (stobjs-in key wrld)))
                (msg "~@0~x1 takes ACL2's STATE as an argument (illegal ~
                      except for profiling)."
                     str key))
               ((not (booleanp aokp))
                (msg "~@0:aokp has a non-Boolean value, ~x1."
                     str aokp))
               ((and (or condition (cdr (assoc-eq :inline val)))

; See comment above for the case of 'state.

                     (non-memoizable-stobjs (stobjs-in key wrld) wrld))
                (mv-let
                  (abs conc)
                  (filter-absstobjs (non-memoizable-stobjs (stobjs-in key wrld)
                                                           wrld)
                                    wrld nil nil)
                  (cond
                   ((null abs)
                    (msg "~@0~x1 has input stobj~#2~[ ~&2~/s ~&2, each~] ~
                          introduced with :NON-MEMOIZABLE T.  See :DOC ~
                          defstobj."
                         str key conc))
                   ((null conc)
                    (msg "~@0~x1 has input abstract stobj~#2~[ ~&2~/s ~&2, ~
                          each of~] whose corresponding foundational stobj is ~
                          non-memoizable.  See :DOC defabsstobj."
                         str key abs))
                   (t
                    (msg "~@0~x1 has input foundational stobj~#2~[ ~&2~/s ~
                          ~&2, each~] introduced as non-memoizable.  ~x1 also ~
                          has input abstract stobj~#3~[ ~&2~/s ~&3, each of~] ~
                          whose corresponding foundational stobj is ~
                          non-memoizable.  See :DOC defstobj."
                         str key conc abs)))))
               ((member-eq key *stobjs-out-invalid*)
                (msg "~@0~x1 is a primitive without a fixed output signature."
                     str key))
               ((and (or condition (cdr (assoc-eq :inline val)))

; See comment above for the case of 'state.

                     (collect-non-nil-df (stobjs-out key wrld)))
                (let ((stobj (car (collect-non-nil-df (stobjs-out key wrld)))))
                  (msg "~@0~x1 returns a stobj, ~x2 (illegal except for ~
                        profiling)."
                       str key stobj)))
               ((member-eq key *hons-primitive-fns*)
                (msg "~@0~x1 is a HONS primitive."
                     str key))
               ((not (cltl-def-from-name key wrld))
                (msg "~@0Although ~x1 is a defined ACL2 function, its ~
                      implementation in raw Lisp is not.~@2"
                     str key
                     (let* ((st (getpropc key 'stobj-function nil wrld))
                            (ev (and st (get-event st wrld))))
                       (cond
                        ((and ev
                              (or (and (eq (car ev) 'defstobj)
                                       (member-eq :inline ev))
                                  (eq (car ev) 'defabsstobj)))
                         (msg "  Note that ~x0 was introduced with the event ~
                               ~x1, so ~x0 is ``inlined'' by making it a ~
                               macro in raw Lisp."
                              key ev))
                        (t "")))))
               ((getpropc key 'constrainedp nil wrld)

; Should we consider removing this restriction if :INVOKE has a non-nil value?
; A potential use would be to prove some io-pairs for a given constrained
; function and then provide for execution of that constrained function; see
; community book books/kestrel/utilities/use-io-pairs.lisp.  A fundamental
; issue however is that constrained functions do not have
; executable-counterpart runes, so they presumably wouldn't be executed
; directly during proofs.  They could be executed under a call of a defined
; function, however.

                (msg "~@0~x1 is constrained.  You may instead wish to memoize ~
                      a caller or to memoize its attachment (see :DOC ~
                      defattach)."
                     str key))
               ((and inline

; The test below isn't right if a built-in function with raw Lisp code has been
; promoted to logic mode after assigning state global
; 'verify-termination-on-raw-program-okp to t.  However, that assignment may
; only be done with a trust tag, and the documentation warns that doing this
; promotion could be unsound.  So we don't worry about that case here.

; Note that here we are disallowing inline memoization of apply$-lambdas.
; That's fine; we essentially do our own memoization via the cl-cache.

                     (if (eq key-class :program)
                         (member-eq key *initial-program-fns-with-raw-code*)
                       (member-eq key *initial-logic-fns-with-raw-code*)))
                (msg "~@0The built-in function symbol ~x1 has associated ~
                      raw-Lisp code, hence is illegal to memoize unless ~
                      :RECURSIVE is nil."
                     str key))
               ((let ((pair (assoc-eq :memo-table-init-size val)))
                  (and pair (not (posp (cdr pair)))))
                (msg "~@0The :memo-table-init-size must be a positive ~
                      integer, unlike ~x1."
                     str (cdr (assoc-eq :memo-table-init-size val))))
               ((memoize-table-chk-commutative-msg str key val wrld))
               ((and invoke total)
                (msg "~@0It is illegal to specify non-nil values for both the ~
                      :INVOKE and :TOTAL memoize keywords."
                     str))
               ((and invoke inline)
                (msg "~@0It is illegal to specify a non-NIL value for the ~
                      :INVOKE keyword of memoize when the :RECURSIVE keyword ~
                      (i.e., the :INLINE keyword for the memoize table) is T."
                     str))
               ((and invoke
                     (memoize-table-chk-invoke-msg key invoke str wrld state)))
               ((not (symbolp total))
                (msg "~@0The value of the :total keyword for memoize must be ~
                      a symbol, but ~x1 is not.  Presumably you are trying to ~
                      use the :total option of memoize directly, which is not ~
                      recommended.  See :DOC memoize-partial."
                     str total))
               ((and total
                     (not (cltl-def-memoize-partial key total wrld)))
                (msg "~@0Unable to find executable Common Lisp definition for ~
                      ~x1 in the table, ~x2.  Presumably you are trying to ~
                      use the :total option of memoize directly, which is not ~
                      recommended.  See :DOC memoize-partial."
                     str total 'partial-functions-table))

; The next two checks require that we do not memoize or unmemoize a function
; that is already memoized or unmemoized, respectively.  The function
; maybe-push-undo-stack relies on this check.

               ((and val (cdr (assoc-eq key memoize-table)))
                (msg "~@0Function ~x1 is already memoized."
                     str key))
               ((and (null val) (null (cdr (assoc-eq key memoize-table))))
                (msg "~@0Cannot unmemoize function ~x1 because it is not ~
                      currently memoized."
                     str key))
               ((and (eq key-class :ideal)
                     val ; memoize, not unmemoize
                     (let* ((pair (assoc-eq :ideal-okp val))
                            (okp
                             (if pair
                                 (cdr pair)
                               (cdr (assoc-eq :memoize-ideal-okp
                                              (table-alist 'acl2-defaults-table
                                                           wrld))))))
                       (cond ((eq okp t)
                              nil)
                             ((not okp)
                              (msg "~@0The function symbol ~x1 is in :logic ~
                                    mode but has not had its guards verified. ~
                                    ~ Either run ~x2, or specify :IDEAL-OKP ~
                                    ~x3 in your ~x4 call, or else evaluate ~
                                    ~x5 or ~x6."
                                   str key 'verify-guards t 'memoize
                                   '(table acl2-defaults-table :memoize-ideal-okp
                                           t)
                                   '(table acl2-defaults-table :memoize-ideal-okp
                                           :warn)))
                             (t ; okp is :warn
                              (prog2$ (warning$-cw0
                                       'memoize-table-chk
                                       "Memoize"
                                       (default-state-vars t)
                                       "The function ~x0 to be memoized is in ~
                                        :logic mode but has not had its ~
                                        guards verified.  Memoization might ~
                                        therefore not take place; see :DOC ~
                                        memoize."
                                       key)
                                      nil))))))

; Finally, check conditions on the memoization condition function.

               (t
                (let ((val-formals (and condition
                                        (if (symbolp condition)
                                            (getpropc condition 'formals t wrld)
                                          t)))
                      (val-guard (and condition
                                      (if (symbolp condition)
                                          (guard condition t wrld)
                                        t))))

                  (cond
                   ((or (eq val nil)
                        (member-eq condition '(t nil)))
                    nil)
                   ((eq val-formals t)
                    (msg "~@0The proposed memoization condition function, ~
                          ~x1, is neither T, NIL, nor a function symbol known ~
                          to ACL2."
                         str condition))
                   ((not (and (symbolp condition)
                              (or (eq key-class :program)
                                  (eq (symbol-class condition wrld)
                                      :common-lisp-compliant))))
                    (msg "~@0Function ~x1 cannot serve as a memoization ~
                          condition function for function ~x2, because unlike ~
                          ~x2, ~x1 is not common-lisp-compliant (a logic-mode ~
                          function that has had its guards verified)."
                         str condition key))
                   ((not (equal key-formals val-formals))
                    (msg "~@0Function ~x1 cannot serve as a memoization ~
                          condition function for ~x2, because the two ~
                          functions have different formal parameter lists."
                         str condition key))
                   ((not (equal (guard key t wrld)
                                val-guard))
                    (msg "~@0Function ~x1 cannot serve as a memoization ~
                          condition function for ~x2, because the two ~
                          functions have different guards."
                         str condition key))
                   (t nil)))))))
        (progn$
         (and val
              (let* ((stobjs-in (stobjs-in key wrld))
                     (relevant-input-stobjs
                      (and condition
                           (collect-non-nil-df stobjs-in))))
                (cond
                 (relevant-input-stobjs
                  (observation-cw
                   ctx
                   "The function ~x0 has input stobj~#1~[~/s~] ~&1.  The ~
                    memoization table for ~x0 will be cleared whenever ~
                    ~#2~[this stobj is~/either of these stobjs is~/any of ~
                    these stobjs is~] updated.  Any update of a stobj may ~
                    therefore be significantly slower, perhaps by a factor of ~
                    5 or 10, when it is an input of a memoized function."
                   key
                   relevant-input-stobjs
                   (zero-one-or-more (cdr relevant-input-stobjs))))
                 (t nil))))
         (if msg
             (mv nil msg)
           (mv t nil))))))))

(table memoize-table nil nil
       :guard
       (memoize-table-chk key val world state))

(defun memoize-partial-calls (tuples)
  (declare (xargs :guard (and (symbol-alistp tuples)
                              (true-list-listp tuples))))
  (cond ((endp tuples) nil)
        (t (cons `(memoize ',(caar tuples) :total ',(cadar tuples)
                           ,@(cddddr (car tuples)))
                 (memoize-partial-calls (cdr tuples))))))

(defun memoize-partial-tuple-1 (x1 x2 ctx str fn fn-limit
                                   change stable)
  (declare (xargs :guard (and (keyword-value-listp x1)
                              (keyword-value-listp x2)
                              (stringp str))))
  (cond ((endp x1)
         (list* fn
                fn-limit
                (or change
                    (add-suffix fn-limit "-CHANGE"))
                (or stable
                    (add-suffix fn-limit "-STABLE"))
                x2))
        ((eq (car x1) :change)
         (cond (change (er hard ctx str
                           (msg "The keyword :CHANGE appears more than once ~
                                 for the tuple associated with ~x0"
                                fn)))
               (t (memoize-partial-tuple-1 (cddr x1) x2 ctx str fn fn-limit
                                           (cadr x1) stable))))
        ((eq (car x1) :stable)
         (cond (stable (er hard ctx str
                           (msg "The keyword :STABLE appears more than once ~
                                 for the tuple associated with ~x0"
                                fn)))
               (t (memoize-partial-tuple-1 (cddr x1) x2 ctx str fn fn-limit
                                           change (cadr x1)))))
        (t
         (memoize-partial-tuple-1 (cddr x1)
                                  (list* (car x1) (cadr x1)
                                         (if (assoc-keyword (car x1) x2)
                                             (remove-keyword (car x1) x2)
                                           x2))
                                  ctx str fn fn-limit change stable))))

(defun memoize-partial-tuple (tuple args ctx str)
  (declare (xargs :guard (and (consp tuple)
                              (consp (cdr tuple))
                              (keyword-value-listp (cddr tuple))
                              (keyword-value-listp args)
                              (stringp str))))
  (memoize-partial-tuple-1 (cddr tuple) args ctx str
                           (car tuple) (cadr tuple)
                           nil nil))

(defun memoize-partial-tuples (tuples args ctx)

; Tuples is a :total argument of a call of memoize, and args is a keyword-alist
; to be used for memoize arguments, possibly overridden for some functions as
; specified in tuples.  We return tuples of the form (fn fn-limit
; fn-limit-change fn-limit-stable . memoize-args).

  (declare (xargs :guard (keyword-value-listp args)))
  (let ((str
         "Ill-formed argument for memoize-partial: ~@0.  See :DOC ~
          memoize-partial."))
    (cond ((null tuples) nil)
          ((atom tuples) (er hard ctx str
                             "Not a null-terminated list"))
          (t (let* ((tuple (car tuples))
                    (tuple (if (symbolp tuple)
                               (list tuple (add-suffix tuple "-LIMIT"))
                             tuple)))
               (cond ((and (<= 2 (len tuple))
                           (symbolp (car tuple))
                           (car tuple)
                           (symbolp (cadr tuple))
                           (cadr tuple)
                           (keyword-value-listp (cddr tuple)))
                      (cons (memoize-partial-tuple tuple args ctx str)
                            (memoize-partial-tuples (cdr tuples) args ctx)))
                     (t (er hard ctx str
                            (msg "The tuple associated with ~x0 is not of the ~
                                  form (fn fn-limit :kwd1 val1 ... :kwdn ~
                                  valn)"
                                 (car tuple))))))))))

(defun memoize-partial-basic-checks (tuples ctx state)

; These checks are made when executing memoize-partial.  But we should not rely
; on them; they should also be made, albeit with potentially unhelpful error
; messages, when attempting to run directly the events otherwise generated by
; memoize-partial.

  (let* ((fns (strip-cadrs tuples))
         (wrld (w state))
         (bad (non-function-symbols fns wrld)))
    (cond
     (bad (er soft ctx
              "You must define ~&0 before submitting your memoize-partial ~
               form.  See :DOC memoize-partial."
              bad))
     (t (let ((bad (collect-non-common-lisp-compliants fns wrld)))
          (cond
           (bad

; The defchoose events are agnostic about the guard-verified status of the
; -limit functions.  It seems simplest to insist that they are guard-verified
; rather than declaring :ideal mode for the :total function if the -limit
; function is :ideal.

            (er soft ctx
                "The function~#0~[ ~&0 is~/s ~&0 are~] not guard-verified.  ~
                 See :DOC memoize-partial."
                bad))
           (t (value nil))))))))

(defmacro memoize-partial (&whole whole tuples &rest args)

; Tuples has members of the form (fn fn-limit), (fn fn-limit-change), or (fn
; fn-limit-change fn-limit-stable).  That syntax is consistent with that of
; (memoize fn :total fn-limit), which is treated as (memoize fn :total (list
; fn-limit)): fn is defined nonconstructively, and a modification of fn-limit
; is a partial function used for its execution.

  (let ((ctx 'memoize-partial))
    (cond
      ((and (true-listp tuples)
            (equal (length tuples) 2)
            (equal (car tuples) 'quote))
       (er hard ctx "The argument for memoize-partial should not be quoted.  ~
                     Perhaps you intended that argument to be ~x0.  See :DOC ~
                     memoize-partial."
           (cadr tuples)))
      ((not (keyword-value-listp args))
       (er hard ctx "The arguments to MEMOIZE-PARTIAL after the first ~
                     argument should be an alternating list of keywords and ~
                     values (keyword first), which will be passed to ~
                     MEMOIZE.  The call ~x0 is thus illegal.  See :DOC ~
                     memoize-partial."
           whole))
      (t (let ((tuples (memoize-partial-tuples (if (symbolp tuples)
                                                   (list tuples)
                                                 tuples)
                                               args
                                               ctx)))
           `(progn
              (make-event
               (er-progn
                (memoize-partial-basic-checks ',tuples ',ctx state)
                (mv-let (msg defs table-event)
                  (memoize-partial-supporting-events ',tuples (w state))
                  (cond (msg (er soft ',ctx "~@0" msg))
                        (t (value (cons 'progn
                                        (append defs
                                                (list table-event))))))))
               :on-behalf-of :quiet!)
              ,@(memoize-partial-calls tuples)))))))

(defun read-event-data-fal (alist fal)

; Extend the given fast-alist, fal, with the key-value pairs (key . val) in
; alist, by including val in the list of values associated with key in the
; resulting extension.

  (cond ((endp alist) fal)
        (t
         (let* ((key (caar alist))
                (val (cdar alist))
                (old (cdr (hons-get key fal))))
           (read-event-data-fal (cdr alist)
                                (hons-acons key (cons val old) fal))))))

(defun first-non-string-key-pair (fal)
  (cond ((atom fal) nil)
        ((stringp (caar fal))
         (first-non-string-key-pair (cdr fal)))
        (t (car fal))))

(defun old-and-new-event-data-fal (book-string dir ctx state)

; An event-data-fal, as stored in the state global of that name, is an alist
; whose entries are of two types.  If the key is an event name, then the value
; is a list of event-data values (see :DOC get-event-data), often a singleton
; list -- one for each event whose name is the key -- except that for a THM
; event, the key is nil.  Otherwise the key is a full-book-string (a string
; that is the canonical pathname for a book) and the value is the
; event-data-fal based on the events in that book.

; This function returns a pair (file-event-data-fal . new-event-data-fal),
; where new-event-data-fal is the updated (by this function) value of state
; global 'event-data-fal and file-event-data-fal is the event-data-fal
; associated with book-string and with respect to directory dir, if non-nil,
; else with respect to the current cbd.

  (let ((current-event-data-fal (f-get-global 'event-data-fal state)))
    (cond
     ((null current-event-data-fal)
      (er soft ctx
          "No event-data-fal has been saved in this session.  See :DOC ~
           saving-event-data."))
     (t
      (mv-let (full-book-string full-book-name directory-name familiar-name)
        (parse-book-name (or dir (cbd)) book-string nil ctx state)
        (declare (ignore full-book-name directory-name familiar-name))
        (let* ((cached (cdr (hons-get full-book-string current-event-data-fal))))
          (cond
           (cached (value (cons cached current-event-data-fal)))
           (t
            (let ((event-data-filename
                   (event-data-filename full-book-string nil)))
              (with-packages-unhidden
               (mv-let (channel state)
                 (open-input-channel event-data-filename :object state)
                 (cond
                  (channel
                   (er-let* ((alist
                              (state-global-let*
                               ((current-package "ACL2"
                                                 set-current-package-state))
                               (mv-let (alist state)
                                 (read-file-iterate-safe channel nil state)
                                 (value alist)))))
                     (let ((file-event-data-fal
                            (read-event-data-fal alist 'read-event-data-fal)))
                       (pprogn
                        (close-input-channel channel state)
                        (let ((new-event-data-fal
                               (hons-acons full-book-string
                                           file-event-data-fal
                                           current-event-data-fal)))
                          (pprogn
                           (f-put-global 'event-data-fal ; cache the result
                                         new-event-data-fal
                                         state)
                           (value (cons file-event-data-fal
                                        new-event-data-fal))))))))
                  (t (er soft ctx
                         "Unable to open file ~x0 for reading event-data."
                         event-data-filename))))))))))))))

(defun old-and-new-event-data-fn (book-string name namep dir ctx state)

; This function returns (old-event-data . new-event-date), where the car and
; cdr are event-data values (see :DOC get-event-data) that are intended to
; correspond, where new-event-data is the most recent event-data -- associated
; with name, if namep is true -- and old-event-data is intended to be the
; corresponding event-data from the current session.

  (er-let* ((old/new (old-and-new-event-data-fal book-string dir ctx state)))
    (let* ((old (car old/new))
           (new (cdr old/new))
           (pair (and (not namep)
                      (first-non-string-key-pair new)))
           (name (if namep name (car pair)))
           (old-event-data-lst (cdr (hons-get name old)))
           (old-len (length old-event-data-lst))
           (new-event-data-lst (if pair
                                   (cdr pair)
                                 (cdr (hons-get name new))))
           (new-len (length new-event-data-lst)))
      (cond ((< old-len new-len)
             (pprogn
              (warning$ ctx "Event-data"
                        "The number of events named ~x0 in the current ~
                         session, which is ~x1, exceeds the number of events, ~
                         ~x2, that are named ~x0 in the given file.  Thus no ~
                         result is available."
                        name new-len old-len)
              (value nil)))
            ((= new-len 0)
             (er soft ctx
                 "No event-data ~#0~[was~/ for events named ~x1 were~] saved ~
                  in the current session.  Thus no result is available."
                 (if namep 1 0)
                 name))
            (t ; e.g., old = (e0 e1 e2 e3 ...), new = (f2 f3 ...)
             (value (cons (nth (- old-len new-len) old-event-data-lst)
                          (car new-event-data-lst))))))))

(defmacro old-and-new-event-data (book-string &key (name 'nil namep) dir)

; When name is nil, this returns an error triple whose value is a pair (cons
; old-event-data new-event-data), where new-event-data is the latest event-data
; saved by saving-event-data and old-event-data is the corresponding event-data
; from the given book (as determined by book-string and, optionally, dir, which
; is a directory name or a keyword representing a directory).  If name is
; non-nil then we provide such event-data associated most recently with name in
; the current session.

  `(old-and-new-event-data-fn ,book-string ,name ,namep ,dir
                              'old-and-new-event-data state))

(defun runes-diff-fn (book-string name namep dir ctx state)
  (er-let* ((old/new (old-and-new-event-data-fn book-string name namep dir ctx
                                                state)))
    (let* ((old (car old/new))
           (new (cdr old/new))
           (old-runes (get-event-data-1 'rules old))
           (new-runes (get-event-data-1 'rules new))
           (old-diff (set-difference-equal old-runes new-runes))
           (new-diff (set-difference-equal new-runes old-runes)))
      (value (list (list :old old-diff) (list :new new-diff))))))

(defmacro runes-diff (book-string &key (name 'nil namep) dir)

; See old-and-new-event-data.  Here we return (value (list (list :old
; runes-old) (list :new runes-new))), where runes-old lists the runes from the
; old event-data that are not in the new event-data, and runes-new is analogous
; (new but not old).

; Of course, there may be more convenient ways to return this information
; programmatically, for runes or other fields.  The code for this macro (and
; runes-diff-fn) shows one way to get such information.

  `(runes-diff-fn ,book-string ,name ,namep ,dir 'runes-diff state))

(defun add-global-stobj (name state)
  (declare (xargs :guard (symbolp name)
                  :mode :program
                  :stobjs state))
  (let ((user-stobj-alist (user-stobj-alist state))
        (wrld (w state))
        (ctx 'add-global-stobj))
    (cond ((not (stobjp name t wrld))
           (er soft ctx
               "~x0 is not the name of a known stobj."
               name))
          ((assoc-eq name user-stobj-alist)
           (er soft ctx
               "The stobj ~x0 is already global."
               name))
          (t
           (mv-let (erp init-val state)
             #-acl2-loop-only
             (let ((creator (access stobj-property
                                    (getpropc name 'stobj nil wrld)
                                    :creator)))
               (assert creator)
               (assert (member-eq name *non-executable-user-stobj-lst*))
               (setq *non-executable-user-stobj-lst*
                     (remove1 name *non-executable-user-stobj-lst*))
               (value (eval (list creator))))
             #+acl2-loop-only

; We're perhaps being a bit lazy here.  We might be able to use
; magic-ev-fncall, ev-fncall, or the like to apply the stobj creator for name,
; which can be obtained as follows.

;   (access stobj-property
;           (getpropc name 'stobj nil wrld)
;           :creator))

; But it is tricky to overcome the problem that the creator is untouchable, so
; we punt here and use the oracle to represent the value of the creator.  This
; is just logic-only code that nobody will be reasoning about, since
; add-global-stobj is in :program mode and the #-acl2-loop-only code above
; makes it ineligible for conversion to :logic mode.

             (read-acl2-oracle state)
             (declare (ignore erp))
             (pprogn (update-user-stobj-alist
                      (acons name init-val user-stobj-alist)
                      state)
                     (value name)))))))

(defun remove-global-stobj (name state)
  (declare (xargs :guard (symbolp name)
                  :mode :program
                  :stobjs state))
  (let ((user-stobj-alist (user-stobj-alist state))
        (wrld (w state))
        (ctx 'add-global-stobj))
    (cond ((not (stobjp name t wrld))
           (er soft ctx
               "~x0 is not the name of a known stobj."
               name))
          ((not (assoc-eq name user-stobj-alist))
           (er soft ctx
               "The stobj ~x0 is not currently global."
               name))
          (t
           #-acl2-loop-only
           (progn (assert (not (member-eq name
                                          *non-executable-user-stobj-lst*)))
                  (push name *non-executable-user-stobj-lst*))
           (pprogn (update-user-stobj-alist
                    (remove-assoc-eq name user-stobj-alist)
                    state)
                   (value name))))))

; Essay on Correctness of Evaluation with Stobjs

; This Essay provides an argument that stobjs are handled properly for
; applicative semantics even with destructive updates.  With the July 2022
; addition of with-global-stobj to existing stobj variants (local, nested,
; abstract, and congruent stobjs), such an argument seemed important for
; confidence in the soundness of ACL2 stobj updates.  Our approach is to define
; an evaluator faithful to Lisp execution semantics and argue that it agrees
; with a simpler, purely applicative model of evaluation.

; This Essay assumes familiarity with stobjs in ACL2.  See in particular the
; Essay on the Design of With-global-stobj.

; Throughout this Essay we may say "stobj" when we mean "stobj name" or when we
; mean "stobj value", when the context seems sufficient to disambiguate.

; This Essay is long.  We keep it from being even longer in two ways, in the
; hope and expectation that our evaluation model and our arguments suffice to
; inspire some confidence in our treatment of stobjs.  First, although we give
; a fairly detailed proof of the main claim, we permit ourselves to skip over
; some details.  (As noted by Rob Sumners, we could gain more confidence if
; someone were to mechanize the proof.)  Second, we impose the following
; limitations on what we try to accomplish.

; Limitations of Scope

; (1) We ignore abstract stobjs, taking the view that evaluation takes place
; with the following notion of underlying concrete stobj: starting with an
; abstract stobj's foundational stobj, recur through foundational stobjs until
; reaching a concrete stobj.

; (2) We largely ignore checking of guards.  Below we discuss an "undef" value
; that is returned by non-executable functions, and we could presumably return
; it for guard violations as well as a step towards incorporating guards into
; our model of evaluation.

; (3) We do not fully model the cases that an error occurs during evaluation;
; specifically, we do not argue for correct top-level update of the
; user-stobj-alist of state in error cases.  With additional effort that seems
; feasible; our correctness argument for evaluation focuses on appropriate
; disjointness (non-aliasing) of stobj values being preserved by evaluation.

; (4) We play a bit loose with stobjs-out.  Although we incorporate that notion
; into our evaluator -- see cl-stobjs-out and term-stobjs-out-set below -- we
; don't work out many details.

; (5) We do not address the fact that stobjs have array-based representations.
; For purposes of this essay, think of stobjs in terms of their logical
; definitions as lists (though we can still conceive of destructive operations
; on them, and we consider disjointness of stobj memories as a way of
; preventing problems due to aliasing).

; (6) We largely ignore the ACL2 implementation, referencing it (e.g., by
; mentioning translate) only when relevant to laying out this theory, not to
; implementing it.  For example, there needs to be a mechanism for ensuring
; that when attaching g to f the 'global-stobjs property of g is contained in
; that of f, hence there needs to be a mechanism for specifying a constrained
; function's 'global-stobjs property.  We do not discuss such issues much here
; (but see the Essay on the Design of With-global-stobj for discussion of the
; :global-stobjs keyword for signatures).

; (7) Our argument isn't complete.  Consider for example evaluation of the
; expression (let ((var1 exp1) ... (vark expk)) body) where no vari is a known
; stobj.  It would be good to reason that evaluation of each expi leaves all
; stobj values unchanged, since if for example stobj s is destructively
; modified by evaluation of exp1, then a reference to s in body will
; erroneously be to the modified value.  Our model of evaluation does not
; comprehend that issue.  Nevertheless, our argument does comprehend the issue
; of potential aliasing, thus giving us confidence in the faithfulness of ACL2
; to its applicative semantics.

; End of Limitations of Scope

; Our argument is based on two evaluators for ACL2 terms -- actually,
; untranslated expressions: (acl2-eval term alist) and (cl-eval term alist gs),
; where we explain gs ("global state") below.  Each evaluator returns a value.
; Acl2-eval is a straightforward, usual sort of evaluator with respect to a
; variable-binding alist; we omit its definition, other than to note that a
; special value "undef" is returned when the input term is a call of a function
; that is either constrained without an attachment or is non-executable.  The
; non-executable case includes non-exec, since that macro's calls expand to
; calls of the (in essence) non-executable function, throw-nonexec-error.

; Our more realistic model of evaluation is given by (cl-eval u a gs) -- "cl"
; referencing Common Lisp -- where u is an untranslated term, a is a
; variable-binding alist, and gs is described later below.  We intend to show
; that this agrees with the simpler applicative semantics given by acl2-eval.
; While cl-eval is more complex than acl2-eval, nevertheless cl-eval is
; reasonably straightforward -- but its accuracy depends on being able to rely
; on gs as a model of the global state.  Imagine for example evaluation of (let
; ((st exp)) body) where st is a stobj that is destructively modified by
; evaluation of exp.  Our (reasonably straightforward) definition of cl-eval
; could fail to model evaluation faithfully if st shares memory with some other
; stobj st' occurring in body when either is writable, as cl-eval doesn't model
; destructive modification of st'.  We address this issue by maintaining an
; invariant on gs that prevents such sharing, called "coherence".  To show that
; the invariant holds, we define cl-eval to return a special value, "bomb",
; when the invariant fails -- and then we prove in the Main Claim below that
; cl-eval never returns "bomb".

; We discuss gs informally before giving a precise definition of "global state
; representation".  Gs is a directed tree with labeled edges and named nodes.
; Its edges represent the parent-child stobj relation.  For the initial gs used
; at the top level of a term's evaluation, there is one node N_s for each stobj
; name s occurring free in that term, where s is the name of N_s.  Each such
; N_s for a user-defined stobj s is the successor of a special root node that
; represents the user-stobj-alist of state; we therefore call that special node
; "USA".  A key benefit of USA is that its edges contain stobj names that must
; not be bound by with-global-stobj forms, to prevent aliasing (an exception
; being when the stobj is only read, not written, at the top level and by
; with-global-stobj).  For a recursive call of the evaluator, cl-eval, gs may
; be updated in several ways, including adding or removing nodes, replacing the
; stobj naming a node with a congruent stobj, and changing which stobj names
; are "known" in the current context.  Edges do not change (except when
; removed); an edge from a node with stobj name p to a node with stobj name c
; indicates, using an accessor name and stobj (the type) and possibly other
; information, how child stobj c fits into parent stobj p.

; Here are three examples of how cl-eval proceeds.  When we enter stobj-let to
; evaluate its producer, the bound child stobjs generate successor nodes under
; their parent's node and are marked as "known", while the "known" marker is
; removed from the parent's node (reflecting the syntactic requirement that the
; parent stobj not occur free in the producer of the stobj-let).  A call of
; with-local-stobj extends the tree with a new, "known" root node for that
; local stobj.  A call of with-global-stobj adds a "known" node immediately
; below USA.  For a function call, each actual parameter that is a stobj name
; causes the "known" node with that name to be renamed to the corresponding
; formal parameter (which is equal or congruent to the actual parameter), and
; those are the only nodes marked as "known" when evaluating the body of the
; called function.

; Another important aspect of gs is the read-only status of each node.  The
; read-only field of a node is set to T when the node is created by the
; read-only version of with-global-stobj, and that T value is passed down to
; the read-only field of any subsequent children.  A key aspect of read-only
; nodes is that two of them may have the same value, as can happen with nested
; read-only with-global-stobj calls that bind the same stobj.

; We turn now to defining the requirements on gs.  After that we introduce
; other key notions, up through the definition of cl-eval.  Then we state and
; prove our Main Claim.

; Definition.  A "global state representation", or "gs-rep" for short, is a
; finite directed labeled tree, gs, with names at the nodes, which satisfies
; the properties described below, where we also introduce related terminology.

; - There are three classes of root node.

;   + The "state" node has the name, state.  Its value is an ACL2 state, and it
;     has no successor (or predecessor).

;   + The "USA" root node has as its value the user-stobj-alist of the state,
;     i.e., the user-stobj-alist of the value of the state node.  This alist
;     has as its keys all the user-defined stobj names.  Each key st maps to a
;     value that satisfies the recognizer for st.

;   + Every other root node of gs is has a user-defined stobj as its name.
;     (Motivation: We will see that such a node is initially introduced with
;     name st by a form (with-local-stobj st mv-let-form), though during
;     evaluation the name may change to a stobj congruent to st.)  The node's
;     value satisfies the stobj recognizer for its name.

; - The successor (i.e., non-root) nodes and edges to them are as follows.

;   + Each edge from USA is labeled by a user-defined stobj name, st.  If there
;     is such an edge, we may call its terminus N a "global-stobj node" and we
;     may call st a "global-stobj name".  The name of N is st or a stobj name
;     congruent to st.  The value at N satisfies the stobj recognizer for st.

;   + Let N be a successor node that is not a global-stobj node (i.e., N is not
;     a successor of USA).  The name of N is a user-defined stobj name, c, and
;     the name of the parent node of N is a user-defined stobj name, p.  The
;     edge from p to c has a label that indicates a field accessor and stobj
;     type c' taken from a defstobj event for either p or a stobj congruent to
;     p, where c' is c or a stobj congruent to c.  In the case of an array,
;     hash-table, or stobj-table field, the label also includes an appropriate
;     array index, hash key, or stobj name, respectively.  The value at N
;     satisfies the stobj recognizer for c.

; - Every node other than USA has a Boolean "knownp" field that is intended to
;   represent whether the stobj name is "known" (in the sense of translate) in
;   a given context.  For each stobj name st there is at most one node in gs
;   with knownp = t whose name is st; such a node is called a "known node" and
;   we say that it is "the known node of" st.  A "known stobj" is the name of
;   some known node.

; - Every node other than USA has a Boolean "read-only" field that is intended
;   to represent whether the stobj value at that node may be modified.  We may
;   say "the read-only bit is set" to indicate that this field has value T;
;   such a node is a "read-only node".  A node whose read-only field is nil may
;   be called a "writable node".  If a read-only node P other than USA is the
;   parent of a node C, then C is a read-only node and the value at C satisfies
;   the recognizer indicated by the edge from P to C.  If a read-only node C is
;   directly under USA with label st, then the value at C equals the value of
;   st in USA, i.e., the value of st in the user-stobj-alist of the value of
;   the state node.  If a writable node C is directly under USA with label st,
;   then it is the unique node under USA whose edge has label st.  If a known
;   node N is writable, then N is a leaf node (i.e., N is not the source of an
;   edge, or said yet another way, N is not the parent of any node).

; - Each node other than the state node is associated with a set of abstract,
;   pairwise disjoint "stable child memories", representing the memories of its
;   child stobjs that are not indicated by labels on edges from that node.  In
;   summary: for a leaf node, its set of stable child memories partitions the
;   memory of the node's (stobj) value; but memories of children of a non-leaf
;   node N (representing bindings from a stobj-let form) are not included in
;   the set of stable child memories of N.  The idea is to remove memories of
;   child stobjs from a parent, so that we can maintain an invariant that the
;   resulting memories are pairwise disjoint (by avoiding overlapping memories
;   of a parent and child).  These abstractions are informal, though
;   formalization is surely feasible.  Intuitively, "stable" is intended to
;   convey the exclusion of stobj fields whose memories may change during
;   evaluation, though for simplicity we exclude memories even of read-only
;   child nodes.  For USA, the stable child memories represent the memories of
;   all stobjs st0 for which a pair (st . st0) is in the state's
;   user-stobj-alist such that st does not label a successor node of USA.  For
;   any node other than the state or USA node, the stable child memories
;   represent the memories of each child whose field is not indicated by the
;   label of some edge from the node.  There is also a notion of "free memory",
;   representing the available memory for new local stobjs; this is disjoint
;   from all stable child memories.

;   Each field of stable child memories is implicit, in the sense that our
;   discussion below does not explicitly update the stable child memories when
;   modifying a gs-rep to create a new gs-rep.  Rather, they are implicitly
;   updated to reflect changes in node values.

; -|

; Convention.  We assume that every untranslated term to be evaluated is
; associated with a "known-stobjs context" that is a set of stobj names.  In a
; function body, this set is determined by the :stobjs declaration (including
; state if state is a formal parameter).  The known-stobjs context is preserved
; at subterms, macroexpansion, and replacement of a lambda expression by a
; corresponding let expression, except that known-stobjs contexts are extended
; by stobj names bound by stobj-let, with-local-stobj, or with-global-stobj
; when entering the appropriate subterm.  The known-stobjs context is intended
; to represent what translate calls known-stobjs, with the following exception.
; When called at the top level rather than in a function body, translate uses
; the symbol t to indicate a list of all stobj names in the current world; but
; for this Essay, the known-stobjs context at the top level is the set of stobj
; names that occur free in the (translation of the) term.

; Definition.  Let u be an untranslated term and let a be a variable-binding
; alist.  We say that u is "translatable with respect to" a if the following
; conditions are met.

; (T1) U can be translated for execution with respect to the known-stobjs
;      context of u and the current ACL2 world.

; (T2) Every free variable of the translation of u is bound in a.

; -|

; Consider for example a function call (f e0 e1 ...) that is translatable with
; respect to a.  Thus each ei can be translated according to the ith element of
; the stobjs-in of f.  Thus, the arguments at stobjs-in positions that are
; neither nil nor :df must be distinct stobj names each congruent to the
; stobjs-in value at its position, and each of the other arguments must be
; terms that return a single non-stobj value.

; Definition.  The term-stobjs-out-set of an untranslated term u is the union
; of the stobjs-out of all function symbols called in u, with nil and :df
; removed and with obvious exceptions: term-stobjs-out-set accounts for
; stobj-let (its bound stobj is removed from stobjs-out of calls in its body)
; and with-local-stobj (its producer-vars are removed from stobjs-out of calls
; in the producer), and it is determined by the :values keyword in DO loop$
; expressions.  Note that neither stobj-let nor with-local-stobj is allowed
; directly in the top-level loop, which simplifies the definition in those
; cases.  Note that calculation of term-stobjs-out-set may be awkward if apply$
; can return a stobj, which fortunately it cannot as of July 2022 except within
; translations of DO loop$ expressions (handled above by the :values keyword
; instead).

; Definition.  A call (cl-eval u a gs) is "coherent" if the following
; properties hold.

; (C1) Gs is a gs-rep with the following properties for each stable child
;      memory M.

;      (a) Suppose M2 is a stable child memory other than M.  If M or M2 is
;          from a writable node, then M and M2 are disjoint.
;
;      (b) M is disjoint from the free memory.

; (C2) Let N be a known stobj node of gs with stobj name st.  Then st is bound
;      in a, and the value at N equals the value of st in a.

; (C3) U is translatable with respect to the variable-binding alist a.

; (C4) If there is an edge from USA labeled by st, then the following hold,
;      where N is the node at the terminus of that edge.

;      (a) If u contains a call of with-global-stobj that binds st, then N is
;          read-only and that call is a read-only call.

;      (b) St is not an updating global-stobj of any function symbol f of u,
;          i.e., st is not in (cdr (getpropc f 'global-stobjs)).

;      (c) If st is a global-stobj of any function symbol f of u (which is
;          necessarily a read-only global-stobj, by (b), i.e., st is in (car
;          (getpropc f 'global-stobjs))), then N is read-only.

; (C5) The set of known stobjs of gs is equal to the known-stobjs context of u.

; (C6) For every st in the term-stobjs-out-set of u (which by (C3) and (C5) is
;      necessarily in the known-stobjs of gs), the known node of st is
;      writable.

; -|

; Definition.  Let u be an untranslated term that passes translate for
; evaluation at the top level.  The "top-level coherent call" (cl-eval u a gs)
; is as follows.  The known-stobjs context of u is the set S of stobj names
; occurring free in the translation of u.  The alist, a, binds state to the
; current ACL2 state if state is in S, and for each other stobj name st in S, a
; binds st to its value st0 in the user-stobj-alist of the state.  There are no
; local stobj nodes in gs.  The state node of gs, N_state, is known if and only
; if state occurs free in u, and has as its value the ACL2 state.  Each
; successor node is a child of USA; these are the nodes N_st for st in S,
; defined as follows: st is both the label on the edge from USA to N_st and the
; name of N_st, N_st has value st0, and N_st is known.  For each such node N_st
; (including the case that st is state), N_st is writable if and only if st is
; in the term-stobjs-out-set of u.  -|

; To justify coherence of the top-level coherent call, specifically property
; (C1), we rely on suitable memory disjointness for distinct stobjs and fields
; within a stobj, which we are happy to assume; see Limitation (3) above.

; We are nearly ready to define some notions that support the definition of
; cl-eval.  First we note that evaluation naturally produces two results: the
; value returned and the stobjs-out for that value.  (This is similar to what
; trans-eval returns, except that unlike trans-eval, here we don't replace
; stobjs in the value.)  The returned stobjs-out comes up only occasionally
; below, so for the sake of the exposition we define cl-eval to return a value
; only and we let cl-stobjs-out be a separate function that returns the
; stobjs-out -- which depends on cl-eval, as we can see when u is of the form
; (if tst st1 st2) where st1 and st2 are distinct stobjs.  Note that
; (cl-stobjs-out u a gs) is always a subset of (term-stobjs-out-set u),
; possibly a strict subset as evidenced by the call of if just above.

; Definitions.  Let gs be a gs-rep and let N be a node of gs.  (a) To "make N
; known" is to modify gs as follows.  If a known node N' of gs has the same
; name as does N, set the knownp flag of N' to nil.  Then set the knownp flag
; of N to T.  (b) To "augment gs with known child node C of N via labeled edge
; E" is to add such an edge and node to gs with value obtained from the value
; at N, as indicated by the field in the label on E, and then to make C known
; as defined in (a).  Note that this can result in more than one edge from N
; both with the same label, E; but this will only happen if N is read-only
; (this being a consequence of (C1)).  -|

; Definition.  Given a coherent call (cl-eval u a gs) with value v, we define
; the "update of gs from" the call as follows, the idea being to update
; according to the returned stobjs.  If v is one of the special values "undef"
; or "bomb" (as per the next Definition, where "bomb" is later proved to be
; impossible), then the update of gs from that call is just gs.  Suppose
; otherwise.  Let L be (cl-stobjs-out u a gs).  Then v has the same length as L
; (see Limitation (4)) and for each position i of L with stobj sti, then sti is
; a known stobj of gs by (C3) and (C5) and (again, see Limitation (4)) the ith
; element sti0 of v satisfies the recognizer of sti.  Then the update of gs
; from the call is obtained by changing the known node with name sti in gs, for
; each i as above, replacing its value with sti0.  Note that in the special
; case that sti is state, the stable child memories of USA automatically update
; according to the user-stobj-alist of sti0.  -|

; Definition.  We define (cl-eval u a gs) and (cl-stobjs-out u a gs).

; The definition of cl-stobjs-out is reasonably straightforward, without
; surprises; we provide only a few highlights.  If u is a call of a function
; not in *stobjs-out-invalid*, then cl-stobjs-out is the stobjs-out of that
; function, modified to accommodate replacement of stobj formals by congruent
; stobjs.  The cl-stobjs-out of a let expression is the cl-stobjs-out of its
; body.  For an updating with-global-stobj call, the cl-stobjs-out is obtained
; by dropping the bound stobj from the supplied output signature and, if state
; is already in that signature, then adding state to the end of it.  The
; cl-stobjs-out of a DO loop$ expression is specified by its :values keyword
; (default (nil)).  Note that the value of cl-stobjs-out for an if call depends
; on the value returned by cl-eval on its test.

; Let v be (cl-eval u a gs); we specify v by cases on u.

; - Case: The call is not coherent.  Then v is the special value, "bomb".  (Our
;   proof below shows that this case does not actually arise.)

; Otherwise, where we know that u is translatable, by (C3):

; - Case: u is a variable.  Then v is the value of u in a (which exists, by
;   coherence).

; - Case: u is a constant.  Then v is the value of u.

; - Case: u is a macro call.  Then expand the call and recur (with the same a
;   and gs).

; - Case: u is a lambda application.  Then recur (with the same a and gs) after
;   replacing u by its corresponding let expression.

; - Case: u is a function symbol call, (f u1 ... uk).  For each i let vi be
;   (cl-eval ui a gs).  If any vi is "bomb" return "bomb", and otherwise, if
;   any vi is "undef" return "undef".  Otherwise there are sub-cases according
;   to whether f is non-executable, a primitive, constrained, or defined.

;   + If f is non-executable then v is "undef".

;   + If f is a primitive, then v is the application of f to the vi.

;   + If f is constrained, then v is "undef" unless f has attachment g, in
;     which case v is (cl-eval (g u1 ... uk) a gs).

;   + If f is defined as (f w1 ... wk) = body, then v is (cl-eval body a' gs'),
;     where:

;     * a' binds each wi to vi; and

;     * gs' is obtained from gs by changing each known node with name wi, where
;       wi is in a stobjs-in position of the call u, to have value vi; and by
;       setting the knownp flag to T for those nodes and NIL for all other
;       nodes.

;     Note that this case includes stobj primitives, using their logical
;     definitions; see Limitation (5).

; - Case: u is (let ((var exp)) body) where var is in the known-stobjs context
;   of u.  Hence by (C5), var is a known stobj of gs, and by (C6), the known
;   node of var is writable (hence it's a leaf node).  Let e be the value of
;   the recursive call (cl-eval exp a gs).  If e is "bomb" or "undef", then v
;   is "bomb" or "undef", respectively.  Otherwise, let a' modify a by binding
;   var to e and let gs' be the update of gs from the recursive call (i.e., by
;   changing the stobj value to e at the known node with name var).  Then v is
;   (cl-eval body a' gs').

; - Case: u is a let-expression not of the form just above, say, (let ((var1
;   exp1) ... (vark expk)) body) where no vari is in the known-stobjs context
;   of u (hence by (C5) again, no vari is a known stobj of gs).  Let ei be
;   (cl-eval expi a gs), returning "bomb" or "undef" if any ei is "bomb" or
;   else any ei is "undef", respectively.  Otherwise let a' be the result of
;   modifying a by binding each vari to ei; then v is (cl-eval body a' gs).

; - Case: u is (mv-let (var0 ... vark) exp body).  Let e be the recursive call
;   (cl-eval exp a gs).  If e is "bomb" or "undef" then v is "bomb" or "undef",
;   respectively.  Otherwise let a' be the result of modifying a by binding
;   each vari to (nth i e) and let gs' be the update of gs from the recursive
;   call.  Then v is (cl-eval body a' gs').

; - Case: u is (with-local-stobj st body).  Let st0 be a new instance of st
;   (obtained from the free memory by applying the stobj creator for st).
;   Obtain gs' from gs by adding a new writable root node N with name st and
;   value st0, and then making N known.  Extend a to a' by binding st to st0
;   (overriding any existing binding of st).  Then v is (cl-eval body a' gs').

; - Case: u is a call of with-global-stobj that binds st.  Since u is
;   translatable with respect to gs, state is in the known-stobjs context of u;
;   so by (C5), state is a known stobj of gs.  Let st0 be the value of st in
;   USA.  Change gs to gs' as follows.  First augment gs with known child node
;   N of USA with name st via an edge labeled with st.  Make N writable if and
;   only if the with-global-stobj call is an updating call.  Extend a to a' by
;   binding st to st0 (overriding the existing binding of st, if any).  Let v0
;   be (cl-eval body a' gs').  If u is a read-only call then the return value v
;   is simply v0.  Otherwise, v is obtained from v0 by updating the returned
;   state of v0 -- i.e., at the state position in v0 based on the output
;   signature in the call -- so that st is bound to st1 in that state's
;   user-stobj-alist.

; - Case: u is (stobj-let bindings producer-vars producer consumer).  We
;   consider the case that each binding in bindings is of the form (childi
;   (fldi p)) or (childi (fldi p) updateri), as the non-scalar cases (i.e., the
;   cases of array, hash-table, and stobj-table fields) are completely
;   analogous.  Since u is translatable, these bindings all reference the same
;   parent stobj, p, which is a known stobj name; say p is the name of the
;   known stobj node, N, with value p0.  We define gs2 from gs.  First change
;   the knownp flag of N to nil (reflecting the restriction that the parent not
;   occur in the producer).  Then make the following additional changes to gs
;   for each binding as above: augment with known child node Ni of N via an
;   edge Ei whose label indicates accessor fldi and type childi, where Ni has
;   name childi, and Ni has value ci equal to the fldi of p0.  Finally, set the
;   read-only bit for Ni if and only if childi is not in producer-vars.  Let a2
;   result from a by binding childi to ci.  Let v0 be the value returned by the
;   recursive call, (cl-eval producer a2 gs2).  If v0 = "bomb" or "undef" then
;   v is "bomb" or "undef", respectively.  Otherwise, let gs2' be the update of
;   gs2 from that recursive call.  We modify gs2' to obtain gs3 by setting the
;   knownp flag of N to T and doing the following for each new edge Ei as above
;   from N to new node Ni: let fldi be the label of Ei, and if childi is in
;   producer-vars then update the value at N by replacing its field at fldi
;   with the value at Ni in gs2'; then (for all i, not merely when childi is in
;   producer-vars) drop the edge Ei and the node Ni.  Let p1 be the value of N
;   in gs3.  Finally, v is (cl-eval consumer a3 gs3), where a3 is obtained from
;   a by binding p to p1 and binds all known-stobjs producer variables that are
;   not bound in bindings to their respective elements in v0 (which we may
;   assume has the appropriate shape, by Limitation (4)).

; -|

; It remains to state and justify the claim we want to make about cl-eval.  We
; are really interested in (a) below: it tells us that the value computed by
; the top-level coherent call (cl-eval u a gs) is equal to the value computed
; by the simple applicative ACL2 semantics, (acl2-eval u a).  But we include
; (b) to support the ensuing proof by computational induction.

; Main Claim.  Assume that the call (cl-eval u a gs) is coherent.  Then

; (a) (cl-eval u a gs) = (acl2-eval u a) so in particular, (cl-eval u a gs) is
;     not "bomb" (since acl2-eval never returns "bomb"); and

; (b) the update of gs from this call satisfies (C1).

; Proof.  We proceed by computational induction under the given assumption that
; the call (cl-eval u a gs) is coherent.  We proceed according to the cases in
; the definition of cl-eval.  We first dispatch the cases that u is a variable,
; a constant, or a call of a macro, a primitive function, a non-executable
; function, a constrained function, or a lambda.  In these cases the result is
; obvious, with a trivial appeal to the inductive hypothesis where necessary
; (macro, constrained with attachment, lambda, and arguments of a function
; call).  Let us now consider the other cases, each accompanied by a brief
; summary of the case.

; - Case: u is (f u1 ... uk), where f is defined as (f w1 ... wk) = body.  The
;   result is thus (cl-eval body a' gs'), where: a' binds wi to vi = (cl-eval
;   ui a gs), which we know by the inductive hypothesis is not "bomb" and we
;   may assume is not "undef" since otherwise (a) and (b) are immediate; and
;   gs' has the wi as its known stobjs.  The recursive calls producing the vi
;   are clearly coherent, so by the inductive hypothesis vi = (acl2-eval ui a).

;   Conclusion (a) follows from the equation (cl-eval body a' gs') = (acl2-eval
;   body a').  This follows immediately from the inductive hypothesis once we
;   show that this recursive call of cl-eval is coherent.  First note that no
;   node values have changed from gs to gs', so (C1) clearly still holds.  (C2)
;   and (C3) remain true by construction of a' and gs'.  (C4) holds by
;   translatability of u and how the global-stobjs of f incorporate the
;   global-stobjs of every function called in the body of f and also every
;   stobj bound by with-global-stobj in the body of f.  (C5) and (C6) hold by
;   construction of gs'.  This completes the proof of (a).  Finally, (b) also
;   follows from the inductive hypothesis since the update of gs' and the
;   update of gs have the same values at every node.

;   Note that no special attention is necessary in the case that f is
;   swap-stobjs; in particular, swapping of stobjs preserves the disjointness
;   required by (C1).

; - Case: u is (let ((var exp)) body) where var is a known stobj of gs.
;   Coherence is clearly preserved for the call (cl-eval exp a gs), so by the
;   inductive hypothesis this equals (acl2-eval exp a).  Let e be this common
;   value, which we therefore know is not "bomb".  We assume that e is not
;   "undef"; otherwise we are done.  Let a' and gs' be as in the definition,
;   i.e., where a' is obtained from a by binding var to e and gs' is the update
;   of gs from the call (cl-eval exp a gs).  By the inductive hypothesis, (b)
;   gives us that gs' satisfies (C1); it is then easy to see that the call
;   (cl-eval body a' gs') is coherent, so we are done by the inductive
;   hypothesis, noting for (b) that the update of gs' from that call is the
;   update of gs from the original call: both result from gs by replacing the
;   value at the known node for var by the value of var returned from (cl-eval
;   body a' gs').

; - Case: u is a let-expression (let ((var1 exp1) ... (vark expk)) body) where
;   no vari is in the known-stobj context of u by (C3) and hence, by (C5), no
;   vari is a known stobj of gs.  Coherence is trivially preserved for each
;   call (cl-eval expi a gs); let ei be the value of that call.  By the
;   inductive hypothesis, no ei is "bomb".  If any ei is "undef", then we are
;   done.  Otherwise, we are done by the inductive hypothesis applied to
;   (cl-eval body a' gs) where a' is as in the definition for this case, i.e.,
;   binding each vari to ei.

; - Case: u is (mv-let (var0 ... vark) exp body).  Let e be the value returned
;   by (cl-eval exp a gs), which is clearly coherent.  By the inductive
;   hypothesis, e is not "bomb" and we may assume that e is not "undef" since
;   otherwise we are done.  Otherwise the inductive hypothesis concludes this
;   case in analogy to the proof of the case of let-binding a stobj, in
;   particular by applying the inductive hypothesis to know that (b) holds for
;   the evaluation of body.

; - Case: u is (with-local-stobj st body).  We skip the easy check that the
;   recursive call (cl-eval body a' gs') is coherent, where a' and gs' are as
;   defined for this case of cl-eval, thus accommodating a new root note for
;   local stobj st.  Then conclusion (a) follows from the inductive hypothesis,
;   which also gives us that the update of gs' from the recursive call
;   satisfies the disjointness specified by (C1).  Conclusion (b) also follows
;   from the inductive hypothesis; in particular, the update of gs from the
;   original call satisfies (C1) since it is the same the update of gs' from
;   the recursive call with one exception: the child stobj memories of the new
;   (local-stobj) node added to gs' disappear when finally updating gs.

; - Case: u is a call of with-global-stobj that binds st.  Let body be the body
;   of that call; so the recursive call is (cl-eval body a' gs'), where a' and
;   gs' are as in the definition of cl-eval, accommodating the augmentation of
;   gs to include a known stobj node for st as a successor to the USA node.
;   Coherence of that recursive call is straightforward, the key concern being
;   whether (C1) is preserved in the case that there is already a successor N
;   of USA with label st.  But in that case, N must be read-only by (C4)(a), so
;   by definition of gs-rep, N's value (and hence memory) in gs (and gs')
;   agrees with the value of st in USA hence with the new node's value; so gs'
;   adds only read-only stable child memories that were already present, which
;   node imposes no new checks in (C1).  So we may apply the inductive
;   hypothesis, which trivially yields conclusion (a).  For conclusion (b),
;   first apply the inductive hypothesis to conclude that the update of gs'
;   from the recursive call satisfies (C1); let's call that update gs''.  Then
;   the update of gs from the original call satisfies (C1) because it is just
;   the result of removing the new st node from gs'' and, only when u is an
;   updating with-global-stobj call, updating user-stobj-alist accordingly.

; - Case: u is (stobj-let bindings producer-vars producer consumer).  We follow
;   this case in the definition of cl-eval, where as before we assume scalar
;   bindings (childi (fldi p) ...) for a parent p, without loss of generality.
;   The recursive call (cl-eval producer a2 gs2) produces a value v0, where --
;   as per the definition of cl-eval -- a2 binds child stobjs of p, and gs2
;   adds corresponding nodes to gs, which are writable only for childi in
;   producer-vars.  To show coherence of this recursive call, the interesting
;   case is (C1), which however is easy to see since only the new nodes for
;   producer-vars are writable, and their memories are not shared since they're
;   removed from the parent node's stable child memories.  By the inductive
;   hypothesis applied to conclusion (a), v0 equals (acl2-eval producer a2),
;   hence is not "bomb"; and if v0 is "undef" then we are done.  Otherwise we
;   apply the inductive hypothesis again, this time for conclusion (b), to see
;   that the gs-rep gs2' resulting from the recursive call above of cl-eval (on
;   producer) satisfies (C1).  Let gs3 and a3 be as in the definition, i.e.,
;   obtained from gs2' and a2 by absorbing the new child nodes into the parent.
;   Then (C1) is clearly preserved from gs2' to gs3, which is the key
;   observation to confirm that the call (cl-eval consumer a3 gs3) is coherent.
;   The inductive hypothesis concludes the proof, since the update of gs from
;   the original call (on u) is the same as the update of gs3 from the final
;   call (on consumer): the cl-stobjs-out of u and consumer are the same, and
;   each (known) stobj in that common list is updated the same in the two
;   cases.

; -|

; End of Essay on Correctness of Evaluation with Stobjs